Index: api-inc.scm
==================================================================
--- api-inc.scm
+++ api-inc.scm
@@ -323,12 +323,12 @@
(run-id (cadr params))
(realparams (cddr params)))
(db:general-call dbstruct stmtname realparams)))
((sdb-qry) (apply sdb:qry params))
((ping) (current-process-id))
- ((get-changed-record-ids) (apply db:get-changed-record-ids dbstruct params))
- ((get-run-record-ids) (apply db:get-run-record-ids dbstruct params))
+ ((get-changed-record-ids) (apply db:get-changed-record-ids dbstruct params))
+ ((get-run-record-ids) (apply db:get-run-record-ids dbstruct params))
;; TESTMETA
((testmeta-get-record) (apply db:testmeta-get-record dbstruct params))
;; TASKS
((find-task-queue-records) (apply tasks:find-task-queue-records dbstruct params))
Index: configf-inc.scm
==================================================================
--- configf-inc.scm
+++ configf-inc.scm
@@ -641,19 +641,19 @@
(configf:comment-rx _ (set! res (append res (list hed)))) ;; (loop (read-line inp) curr-section-name #f #f))
(configf:blank-l-rx _ (set! res (append res (list hed)))) ;; (loop (read-line inp) curr-section-name #f #f))
(configf:section-rx ( x section-name ) (let ((section-hash (hash-table-ref/default refdat section-name #f)))
(if (not section-hash)
(let ((newhash (make-hash-table)))
- (hash-table-set! refhash section-name newhash)
+ (hash-table-set! refdat section-name newhash) ;; was refhash - not sure that refdat is correct here
(set! sechash newhash))
(set! sechash section-hash))
(set! new hed) ;; will append this at the bottom of the loop
(set! secname section-name)
))
;; No need to process key cmd, let it fall though to key val
(configf:key-val-pr ( x key val )
- (let ((newval (config-lookup indat sec key)))
+ (let ((newval (config-lookup indat section-name key))) ;; was sec, bug or correct?
;; can handle newval == #f here => that means key is removed
(cond
((equal? newval val)
(set! res (append res (list hed))))
((not newval) ;; key has been removed
Index: dashboard.scm
==================================================================
--- dashboard.scm
+++ dashboard.scm
@@ -2445,24 +2445,10 @@
(current-seconds)) ;; something went wrong - just print an error and return current-seconds
(common:max (map (lambda (filen)
(file-modification-time filen))
(glob (conc dbdir "/*.db*"))))))
-(define (dashboard:monitor-changed? commondat tabdat)
- (let* ((run-update-time (current-seconds))
- (monitor-db-path (dboard:tabdat-monitor-db-path tabdat))
- (monitor-modtime (if (and monitor-db-path (common:file-exists? monitor-db-path))
- (file-modification-time monitor-db-path)
- -1)))
- (if (and (eq? (dboard:commondat-curr-tab-num commondat) 0)
- (or (> monitor-modtime *last-monitor-update-time*)
- (> (- run-update-time *last-monitor-update-time*) 5))) ;; update every 1/2 minute just in case
- (begin
- (set! *last-monitor-update-time* run-update-time) ;; monitor-modtime)
- #t)
- #f)))
-
(define (dboard:get-last-db-update tabdat context)
(hash-table-ref/default (dboard:tabdat-last-db-update tabdat) context 0))
(define (dboard:set-last-db-update! tabdat context newtime)
(hash-table-set! (dboard:tabdat-last-db-update tabdat) context newtime))
Index: db-inc.scm
==================================================================
--- db-inc.scm
+++ db-inc.scm
@@ -600,11 +600,11 @@
((equal? fname "monitor.db")
(sqlite3:execute "DELETE FROM servers WHERE state LIKE 'defunct%';"))
(else
(sqlite3:execute db "vacuum;")))
- (finalize! db)
+ (sqlite3:finalize! db)
#t))))))
;; tbls is ( ("tablename" ( "field1" [#f|proc1] ) ( "field2" [#f|proc2] ) .... ) )
;; db's are dbdat's
;;
@@ -4092,17 +4092,18 @@
;;
(define (db:get-state-status-summary dbstruct run-id testname)
(let ((res '()))
(db:with-db
dbstruct #f #f
- (sqlite3:for-each-row
- (lambda (state status count)
- (set! res (cons (vector state status count) res)))
- db
- "SELECT state,status,count(state) FROM tests WHERE run_id=? AND testname=? AND item_path='' GROUP BY state,status;"
- run-id testname)
- res)))
+ (lambda (db)
+ (sqlite3:for-each-row
+ (lambda (state status count)
+ (set! res (cons (vector state status count) res)))
+ db
+ "SELECT state,status,count(state) FROM tests WHERE run_id=? AND testname=? AND item_path='' GROUP BY state,status;"
+ run-id testname)
+ res))))
(define (db:get-latest-host-load dbstruct raw-hostname)
(let* ((hostname (string-substitute "\\..*$" "" raw-hostname))
(res (cons -1 0)))
(db:with-db
@@ -4552,10 +4553,11 @@
;; (if (not ever-seen)(set! result (cons waitontest-name result)))))
((not ever-seen)
(set! result (append (if (null? waiton-tests)(list waitontest-name) waiton-tests) result))))))
waitons)
(delete-duplicates result)))))
+
;;======================================================================
;; To sync individual run
;;======================================================================
(define (db:get-run-record-ids dbstruct target run keynames test-patt)
(let ((backcons (lambda (lst item)(cons item lst))))
@@ -4570,15 +4572,15 @@
" AND "))
(run-qry (conc "SELECT id FROM runs WHERE " keystr " and runname='" run"'"))
(test-qry (conc "SELECT id FROM tests WHERE run_id in (" run-qry ") and testname like '" test-patt "'")))
(print run-qry)
(print test-qry)
- `((runs . ,(fold-row backcons '() db run-qry))
- (tests . ,(fold-row backcons '() db test-qry))
- (test_steps . ,(fold-row backcons '() db (conc "SELECT id FROM test_steps WHERE test_id in (" test-qry ")")))
- (test_data . ,(fold-row backcons '() db (conc "SELECT id FROM test_data WHERE test_id in (" test-qry ")" )))
- ))))))
+ `((runs . ,(sqlite3:fold-row backcons '() db run-qry))
+ (tests . ,(sqlite3:fold-row backcons '() db test-qry))
+ (test_steps . ,(sqlite3:fold-row backcons '() db (conc "SELECT id FROM test_steps WHERE test_id in (" test-qry ")")))
+ (test_data . ,(sqlite3:fold-row backcons '() db (conc "SELECT id FROM test_data WHERE test_id in (" test-qry ")" )))
+ ))))))
;;======================================================================
;; Just for sync, procedures to make sync easy
;;======================================================================
@@ -4589,16 +4591,16 @@
;; no transaction, allow the db to be accessed between the big queries
(let ((backcons (lambda (lst item)(cons item lst))))
(db:with-db
dbstruct #f #f
(lambda (db)
- `((runs . ,(fold-row backcons '() db "SELECT id FROM runs WHERE last_update>=?" since-time))
- (tests . ,(fold-row backcons '() db "SELECT id FROM tests WHERE last_update>=?" since-time))
- (test_steps . ,(fold-row backcons '() db "SELECT id FROM test_steps WHERE last_update>=?" since-time))
- (test_data . ,(fold-row backcons '() db "SELECT id FROM test_data WHERE last_update>=?" since-time))
+ `((runs . ,(sqlite3:fold-row backcons '() db "SELECT id FROM runs WHERE last_update>=?" since-time))
+ (tests . ,(sqlite3:fold-row backcons '() db "SELECT id FROM tests WHERE last_update>=?" since-time))
+ (test_steps . ,(sqlite3:fold-row backcons '() db "SELECT id FROM test_steps WHERE last_update>=?" since-time))
+ (test_data . ,(sqlite3:fold-row backcons '() db "SELECT id FROM test_data WHERE last_update>=?" since-time))
;; (test_meta . ,(fold-row backcons '() db "SELECT id FROM test_meta WHERE last_update>?" since-time))
- (run_stats . ,(fold-row backcons '() db "SELECT id FROM run_stats WHERE last_update>=?" since-time))
+ (run_stats . ,(sqlite3:fold-row backcons '() db "SELECT id FROM run_stats WHERE last_update>=?" since-time))
)))))
;;======================================================================
;; Extract ods file from the db
;;======================================================================
Index: dcommon-inc.scm
==================================================================
--- dcommon-inc.scm
+++ dcommon-inc.scm
@@ -768,11 +768,11 @@
(iup:menu-item "Files" (iup:menu ;; Note that you can use either #:action or action: for options
(iup:menu-item "Open" action: (lambda (obj)
(let* ((area-name (iup:textbox #:expand "HORIZONTAL"))
(fd (iup:file-dialog #:dialogtype "DIR"))
(top (iup:show fd #:modal? "YES")))
- (iup:attribute-set! source-tb "VALUE"
+ (iup:attribute-set! area-name "VALUE" ;; was source-tb, no idea what is correct
(iup:attribute fd "VALUE"))
(iup:destroy! fd))))
;; (lambda (obj)
;; (iup:show (iup:file-dialog))
;; (print "File->open " obj)))
@@ -1376,6 +1376,20 @@
(define (dcommon:run-html-viewer lfilename)
(let ((htmlviewercmd (configf:lookup *configdat* "setup" "htmlviewercmd")))
(if htmlviewercmd
(system (conc "(" htmlviewercmd " " lfilename " ) &"))
(iup:send-url lfilename))))
+
+(define (dashboard:monitor-changed? commondat tabdat)
+ (let* ((run-update-time (current-seconds))
+ (monitor-db-path (dboard:tabdat-monitor-db-path tabdat))
+ (monitor-modtime (if (and monitor-db-path (common:file-exists? monitor-db-path))
+ (file-modification-time monitor-db-path)
+ -1)))
+ (if (and (eq? (dboard:commondat-curr-tab-num commondat) 0)
+ (or (> monitor-modtime *last-monitor-update-time*)
+ (> (- run-update-time *last-monitor-update-time*) 5))) ;; update every 1/2 minute just in case
+ (begin
+ (set! *last-monitor-update-time* run-update-time) ;; monitor-modtime)
+ #t)
+ #f)))
Index: megamod.scm
==================================================================
--- megamod.scm
+++ megamod.scm
@@ -189,10 +189,11 @@
(include "runconfig-inc.scm")
(include "runs-inc.scm")
(include "server-inc.scm")
(include "subrun-inc.scm")
(include "tasks-inc.scm")
+(include "tdb-inc.scm")
(include "tests-inc.scm")
(include "vg-inc.scm")
)
;; http-transport:server-dat definition moved to common_records.scm
ADDED tdb-inc.scm
Index: tdb-inc.scm
==================================================================
--- /dev/null
+++ tdb-inc.scm
@@ -0,0 +1,396 @@
+;;======================================================================
+;; Copyright 2006-2013, Matthew Welland.
+;;
+;; This file is part of Megatest.
+;;
+;; Megatest is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; Megatest is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with Megatest. If not, see .
+;;
+;;======================================================================
+
+;;======================================================================
+;; Database access
+;;======================================================================
+
+;;======================================================================
+;;
+;; T E S T D A T A B A S E S
+;;
+;;======================================================================
+
+;;======================================================================
+;; T E S T S P E C I F I C D B
+;;======================================================================
+
+;; Create the sqlite db for the individual test(s)
+;;
+;; Moved these tables into .db
+;; THIS CODE TO BE REMOVED
+;;
+(define (open-test-db work-area)
+ (debug:print-info 11 *default-log-port* "open-test-db " work-area)
+ (if (and work-area
+ (directory? work-area)
+ (file-read-access? work-area))
+ (let* ((dbpath (conc work-area "/testdat.db"))
+ (dbexists (common:file-exists? dbpath))
+ (work-area-writeable (file-write-access? work-area))
+ (db (handle-exceptions ;; open the db if area writeable or db pre-existing. open in-mem otherwise. if exception, open in-mem
+ exn
+ (begin
+ (print-call-chain (current-error-port))
+ (debug:print 2 *default-log-port* "ERROR: problem accessing test db " work-area ", you probably should clean and re-run this test"
+ ((condition-property-accessor 'exn 'message) exn))
+ (set! dbexists #f) ;; must force re-creation of tables, more tom-foolery
+ (sqlite3:open-database ":memory:")) ;; open an in-memory db to allow readonly access
+ (if (or work-area-writeable
+ dbexists)
+ (sqlite3:open-database dbpath)
+ (sqlite3:open-database ":memory:"))))
+ (tdb-writeable (and (file-write-access? work-area)
+ (file-write-access? dbpath)))
+ (handler (make-busy-timeout (if (args:get-arg "-override-timeout")
+ (string->number (args:get-arg "-override-timeout"))
+ 136000))))
+
+ (if (and tdb-writeable
+ *db-write-access*)
+ (sqlite3:set-busy-handler! db handler))
+ (if (not dbexists)
+ (begin
+ (db:set-sync db) ;; (sqlite3:execute db "PRAGMA synchronous = FULL;")
+ (debug:print-info 11 *default-log-port* "Initialized test database " dbpath)
+ (tdb:testdb-initialize db)))
+ ;; (sqlite3:execute db "PRAGMA synchronous = 0;")
+ (debug:print-info 11 *default-log-port* "open-test-db END (sucessful)" work-area)
+ ;; now let's test that everything is correct
+ (handle-exceptions
+ exn
+ (begin
+ (print-call-chain (current-error-port))
+ (debug:print-error 0 *default-log-port* "problem accessing test db " work-area ", you probably should clean and re-run this test or remove the file "
+ dbpath ".\n "
+ ((condition-property-accessor 'exn 'message) exn))
+ #f)
+ ;; Is there a cheaper single line operation that will check for existance of a table
+ ;; and raise an exception ?
+ (sqlite3:execute db "SELECT id FROM test_data LIMIT 1;"))
+ db)
+ ;; no work-area or not readable - create a placeholder to fake rest of world out
+ (let ((baddb (sqlite3:open-database ":memory:")))
+ (debug:print-info 11 *default-log-port* "open-test-db END (unsucessful)" work-area)
+ ;; provide an in-mem db (this is dangerous!)
+ (tdb:testdb-initialize baddb)
+ baddb)))
+
+;; find and open the testdat.db file for an existing test
+(define (tdb:open-test-db-by-test-id test-id #!key (work-area #f))
+ (let* ((test-path (if work-area
+ work-area
+ (rmt:test-get-rundir-from-test-id test-id))))
+ (debug:print 3 *default-log-port* "TEST PATH: " test-path)
+ (open-test-db test-path)))
+
+;; find and open the testdat.db file for an existing test
+(define (tdb:open-test-db-by-test-id-local dbstruct run-id test-id #!key (work-area #f))
+ (let* ((test-path (if work-area
+ work-area
+ (db:test-get-rundir-from-test-id dbstruct run-id test-id))))
+ (debug:print 3 *default-log-port* "TEST PATH: " test-path)
+ (open-test-db test-path)))
+
+;; find and open the testdat.db file for an existing test
+(define (tdb:open-run-close-db-by-test-id-local dbstruct run-id test-id work-area proc . params)
+ (let* ((test-path (if work-area
+ work-area
+ (db:test-get-rundir-from-test-id dbstruct run-id test-id)))
+ (tdb (open-test-db test-path)))
+ (apply proc tdb params)))
+
+(define (tdb:testdb-initialize db)
+ (debug:print 11 *default-log-port* "db:testdb-initialize START")
+ (sqlite3:with-transaction
+ db
+ (lambda ()
+ (for-each
+ (lambda (sqlcmd)
+ (sqlite3:execute db sqlcmd))
+ (list "CREATE TABLE IF NOT EXISTS test_rundat (
+ id INTEGER PRIMARY KEY,
+ update_time TIMESTAMP,
+ cpuload INTEGER DEFAULT -1,
+ diskfree INTEGER DEFAULT -1,
+ diskusage INTGER DEFAULT -1,
+ run_duration INTEGER DEFAULT 0);"
+ "CREATE TABLE IF NOT EXISTS test_data (
+ id INTEGER PRIMARY KEY,
+ test_id INTEGER,
+ category TEXT DEFAULT '',
+ variable TEXT,
+ value REAL,
+ expected REAL,
+ tol REAL,
+ units TEXT,
+ comment TEXT DEFAULT '',
+ status TEXT DEFAULT 'n/a',
+ type TEXT DEFAULT '',
+ CONSTRAINT test_data_constraint UNIQUE (test_id,category,variable));"
+ "CREATE TABLE IF NOT EXISTS test_steps (
+ id INTEGER PRIMARY KEY,
+ test_id INTEGER,
+ stepname TEXT,
+ state TEXT DEFAULT 'NOT_STARTED',
+ status TEXT DEFAULT 'n/a',
+ event_time TIMESTAMP,
+ comment TEXT DEFAULT '',
+ logfile TEXT DEFAULT '',
+ CONSTRAINT test_steps_constraint UNIQUE (test_id,stepname,state));"
+ ;; test_meta can be used for handing commands to the test
+ ;; e.g. KILLREQ
+ ;; the ackstate is set to 1 once the command has been completed
+ "CREATE TABLE IF NOT EXISTS test_meta (
+ id INTEGER PRIMARY KEY,
+ var TEXT,
+ val TEXT,
+ ackstate INTEGER DEFAULT 0,
+ CONSTRAINT metadat_constraint UNIQUE (var));"))))
+ (debug:print 11 *default-log-port* "db:testdb-initialize END"))
+
+;; This routine moved to db:read-test-data
+;;
+(define (tdb:read-test-data tdb test-id categorypatt)
+ (let ((res '()))
+ (sqlite3:for-each-row
+ (lambda (id test_id category variable value expected tol units comment status type)
+ (set! res (cons (vector id test_id category variable value expected tol units comment status type) res)))
+ tdb
+ "SELECT id,test_id,category,variable,value,expected,tol,units,comment,status,type FROM test_data WHERE test_id=? AND category LIKE ? ORDER BY category,variable;" test-id categorypatt)
+ (sqlite3:finalize! tdb)
+ (reverse res)))
+
+;;======================================================================
+;; T E S T D A T A
+;;======================================================================
+
+;; ;; get a list of test_data records matching categorypatt
+;; (define (tdb:read-test-data test-id categorypatt #!key (work-area #f))
+;; (let ((tdb (tdb:open-test-db-by-test-id test-id work-area: work-area)))
+;; (if (sqlite3:database? tdb)
+;; (let ((res '()))
+;; (sqlite3:for-each-row
+;; (lambda (id test_id category variable value expected tol units comment status type)
+;; (set! res (cons (vector id test_id category variable value expected tol units comment status type) res)))
+;; tdb
+;; "SELECT id,test_id,category,variable,value,expected,tol,units,comment,status,type FROM test_data WHERE test_id=? AND category LIKE ? ORDER BY category,variable;" test-id categorypatt)
+;; (sqlite3:finalize! tdb)
+;; (reverse res))
+;; '())))
+
+;; NOTE: Run this local with #f for db !!!
+(define (tdb:load-test-data run-id test-id)
+ (let loop ((lin (read-line)))
+ (if (not (eof-object? lin))
+ (begin
+ (debug:print 4 *default-log-port* lin)
+ ;;(when lin ;; this when blocked stack dump caused by .dat file from logpro being 0-byte. fixed by upgrading logpro
+ (rmt:csv->test-data run-id test-id lin)
+ ;;)
+ (loop (read-line)))))
+ ;; roll up the current results.
+ ;; FIXME: Add the status too
+ (rmt:test-data-rollup run-id test-id #f))
+
+;; NOTE: Run this local with #f for db !!!
+(define (tdb:load-logpro-data run-id test-id)
+ (let loop ((lin (read-line)))
+ (if (not (eof-object? lin))
+ (begin
+ (debug:print 4 *default-log-port* lin)
+ ;;(when lin ;; this when blocked stack dump caused by .dat file from logpro being 0-byte. fixed by upgrading logpro
+ (rmt:csv->test-data run-id test-id lin)
+ ;;)
+ (loop (read-line)))))
+ ;; roll up the current results.
+ ;; FIXME: Add the status too
+ (rmt:test-data-rollup run-id test-id #f))
+
+(define (tdb:get-prev-tol-for-test tdb test-id category variable)
+ ;; Finish me?
+ (values #f #f #f))
+
+;;======================================================================
+;; S T E P S
+;;======================================================================
+
+(define (tdb:step-get-time-as-string vec)
+ (seconds->time-string (tdb:step-get-event_time vec)))
+
+;; get a pretty table to summarize steps
+;;
+;; NOT USED, WILL BE REMOVED
+;;
+(define (tdb:get-steps-table steps);; organise the steps for better readability
+ (let ((res (make-hash-table)))
+ (for-each
+ (lambda (step)
+ (debug:print 6 *default-log-port* "step=" step)
+ (let ((record (hash-table-ref/default
+ res
+ (tdb:step-get-stepname step)
+ ;; stepname start end status Duration Logfile
+ (vector (tdb:step-get-stepname step) "" "" "" "" ""))))
+ (debug:print 6 *default-log-port* "record(before) = " record
+ "\nid: " (tdb:step-get-id step)
+ "\nstepname: " (tdb:step-get-stepname step)
+ "\nstate: " (tdb:step-get-state step)
+ "\nstatus: " (tdb:step-get-status step)
+ "\ntime: " (tdb:step-get-event_time step))
+ (case (string->symbol (tdb:step-get-state step))
+ ((start)(vector-set! record 1 (tdb:step-get-event_time step))
+ (vector-set! record 3 (if (equal? (vector-ref record 3) "")
+ (tdb:step-get-status step)))
+ (if (> (string-length (tdb:step-get-logfile step))
+ 0)
+ (vector-set! record 5 (tdb:step-get-logfile step))))
+ ((end)
+ (vector-set! record 2 (any->number (tdb:step-get-event_time step)))
+ (vector-set! record 3 (tdb:step-get-status step))
+ (vector-set! record 4 (let ((startt (any->number (vector-ref record 1)))
+ (endt (any->number (vector-ref record 2))))
+ (debug:print 4 *default-log-port* "record[1]=" (vector-ref record 1)
+ ", startt=" startt ", endt=" endt
+ ", get-status: " (tdb:step-get-status step))
+ (if (and (number? startt)(number? endt))
+ (seconds->hr-min-sec (- endt startt)) "-1")))
+ (if (> (string-length (tdb:step-get-logfile step))
+ 0)
+ (vector-set! record 5 (tdb:step-get-logfile step))))
+ (else
+ (vector-set! record 2 (tdb:step-get-state step))
+ (vector-set! record 3 (tdb:step-get-status step))
+ (vector-set! record 4 (tdb:step-get-event_time step))))
+ (hash-table-set! res (tdb:step-get-stepname step) record)
+ (debug:print 6 *default-log-port* "record(after) = " record
+ "\nid: " (tdb:step-get-id step)
+ "\nstepname: " (tdb:step-get-stepname step)
+ "\nstate: " (tdb:step-get-state step)
+ "\nstatus: " (tdb:step-get-status step)
+ "\ntime: " (tdb:step-get-event_time step))))
+ ;; (else (vector-set! record 1 (tdb:step-get-event_time step)))
+ (sort steps (lambda (a b)
+ (cond
+ ((< (tdb:step-get-event_time a)(tdb:step-get-event_time b)) #t)
+ ((eq? (tdb:step-get-event_time a)(tdb:step-get-event_time b))
+ (< (tdb:step-get-id a) (tdb:step-get-id b)))
+ (else #f)))))
+ res))
+
+;; Move this to steps.scm
+;;
+;; get a pretty table to summarize steps
+;;
+(define (tdb:get-steps-table-list steps)
+ ;; organise the steps for better readability
+ (let ((res (make-hash-table)))
+ (for-each
+ (lambda (step)
+ (debug:print 6 *default-log-port* "step=" step)
+ (let ((record (hash-table-ref/default
+ res
+ (tdb:step-get-stepname step)
+ ;; stepname start end status
+ (vector (tdb:step-get-stepname step) "" "" "" "" ""))))
+ (debug:print 6 *default-log-port* "record(before) = " record
+ "\nid: " (tdb:step-get-id step)
+ "\nstepname: " (tdb:step-get-stepname step)
+ "\nstate: " (tdb:step-get-state step)
+ "\nstatus: " (tdb:step-get-status step)
+ "\ntime: " (tdb:step-get-event_time step))
+ (case (string->symbol (tdb:step-get-state step))
+ ((start)(vector-set! record 1 (tdb:step-get-event_time step))
+ (vector-set! record 3 (if (equal? (vector-ref record 3) "")
+ (tdb:step-get-status step)))
+ (if (> (string-length (tdb:step-get-logfile step))
+ 0)
+ (vector-set! record 5 (tdb:step-get-logfile step))))
+ ((end)
+ (vector-set! record 2 (any->number (tdb:step-get-event_time step)))
+ (vector-set! record 3 (tdb:step-get-status step))
+ (vector-set! record 4 (let ((startt (any->number (vector-ref record 1)))
+ (endt (any->number (vector-ref record 2))))
+ (debug:print 4 *default-log-port* "record[1]=" (vector-ref record 1)
+ ", startt=" startt ", endt=" endt
+ ", get-status: " (tdb:step-get-status step))
+ (if (and (number? startt)(number? endt))
+ (seconds->hr-min-sec (- endt startt)) "-1")))
+ (if (> (string-length (tdb:step-get-logfile step))
+ 0)
+ (vector-set! record 5 (tdb:step-get-logfile step))))
+ (else
+ (vector-set! record 2 (tdb:step-get-state step))
+ (vector-set! record 3 (tdb:step-get-status step))
+ (vector-set! record 4 (tdb:step-get-event_time step))))
+ (hash-table-set! res (tdb:step-get-stepname step) record)
+ (debug:print 6 *default-log-port* "record(after) = " record
+ "\nid: " (tdb:step-get-id step)
+ "\nstepname: " (tdb:step-get-stepname step)
+ "\nstate: " (tdb:step-get-state step)
+ "\nstatus: " (tdb:step-get-status step)
+ "\ntime: " (tdb:step-get-event_time step))))
+ ;; (else (vector-set! record 1 (tdb:step-get-event_time step)))
+ (sort steps (lambda (a b)
+ (cond
+ ((< (tdb:step-get-event_time a)(tdb:step-get-event_time b)) #t)
+ ((eq? (tdb:step-get-event_time a)(tdb:step-get-event_time b))
+ (< (tdb:step-get-id a) (tdb:step-get-id b)))
+ (else #f)))))
+ res))
+
+;;
+;; Move to steps.scm
+;;
+(define (tdb:get-compressed-steps comprsteps) ;; from tdb:get-steps-table
+ (map (lambda (x)
+ ;; take advantage of the \n on time->string
+ (vector
+ (vector-ref x 0)
+ (let ((s (vector-ref x 1)))
+ (if (number? s)(seconds->time-string s) s))
+ (let ((s (vector-ref x 2)))
+ (if (number? s)(seconds->time-string s) s))
+ (vector-ref x 3) ;; status
+ (vector-ref x 4)
+ (vector-ref x 5))) ;; time delta
+ (sort (hash-table-values comprsteps)
+ (lambda (a b)
+ (let ((time-a (vector-ref a 1))
+ (time-b (vector-ref b 1)))
+ (if (and (number? time-a)(number? time-b))
+ (if (< time-a time-b)
+ #t
+ (if (eq? time-a time-b)
+ (string