Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -902,11 +902,12 @@ (let* ((testdat (let ((matching (hash-table-ref/default testsdat-by-name testname #f))) ;; (filter ;; (lambda (x)(equal? (test:test-get-fullname x) testname)) ;; testsdat))) (if (not matching) - (vector -1 -1 "" "" "" 0 "" "" 0 "" "" "" 0 "" "") + ;;(vector -1 -1 "" "" "" 0 "" "" 0 "" "" "" 0 "" "") + (make-db:test-rec (id -1)) ;; (car matching)))) matching))) (testname (db:test-get-testname testdat)) (itempath (db:test-get-item-path testdat)) (testfullname (test:test-get-fullname testdat)) @@ -1421,12 +1422,12 @@ last-update) *dashboard-mode*) '()))) ;; get 'em all ;; (debug:print 0 *default-log-port* "dboard:get-tests-dat: got " (length tdat) " test records for run " run-id) (sort tdat (lambda (a b) - (let* ((aval (vector-ref a 2)) - (bval (vector-ref b 2)) + (let* ((aval (db:test-get-testname a));;(vector-ref a 2)) + (bval (db:test-get-testname b));;(vector-ref b 2)) (anum (string->number aval)) (bnum (string->number bval))) (if (and anum bnum) (< anum bnum) (string<= aval bval))))))) Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -2258,11 +2258,14 @@ (debug:print-info 8 *default-log-port* "db:get-tests-for-run run-id=" run-id ", qry=" qry) (db:with-db dbstruct run-id #f (lambda (db) (sqlite3:for-each-row (lambda (a . b) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment) - (set! res (cons (apply vector a b) res))) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment) res))) + ;;(set! res (cons (apply vector a b) res))) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment) res))) + ;;(print (cons a b)) + (set! res (cons (alist->db:test-rec (db:qry-gen-alist qryvalstr (cons a b))) res))) + db qry run-id ))) (case qryvals @@ -2291,24 +2294,26 @@ (db:with-db dbstruct run-id #f (lambda (db) (sqlite3:for-each-row (lambda (id testname item-path state status) ;; id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment - (set! res (cons (vector id run-id testname state status -1 "" -1 -1 "" "-" item-path -1 "-" "-") res))) + ;;(set! res (cons (vector id run-id testname state status -1 "" -1 -1 "" "-" item-path -1 "-" "-") res))) + (cons (make-db:test-rec id: id testname: testname item_path: item-path state: state status: status) res)) db qry run-id))) res)) (define (db:get-testinfo-state-status dbstruct run-id test-id) - (let ((res #f)) + (let ((res '())) (db:with-db dbstruct run-id #f (lambda (db) (sqlite3:for-each-row (lambda (run-id testname item-path state status) ;; id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment - (set! res (vector test-id run-id testname state status -1 "" -1 -1 "" "-" item-path -1 "-" "-"))) + ;;(set! res (vector test-id run-id testname state status -1 "" -1 -1 "" "-" item-path -1 "-" "-"))) + (cons (make-db:test-rec run_id: run-id testname: testname item_path: item-path state: state status: status) res)) db "SELECT run_id,testname,item_path,state,status FROM tests WHERE id=?;" test-id))) res)) @@ -2575,12 +2580,16 @@ (res '())) (db:delay-if-busy dbdat) (sqlite3:for-each-row (lambda (id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment shortdir attemptnum archived) ;; 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 - (set! res (cons (vector id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment shortdir attemptnum archived) - res))) + ;;(set! res (cons (vector id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment shortdir attemptnum archived) + (cons (make-db:test-rec id: id run-id: run-id testname: testname state: state status: status event_time: event-time + host: host cpuload: cpuload diskfree: diskfree uname: uname rundir: rundir item_path: item-path + run_duration: run-duration final_logf: final-logf comment: comment shortdir: shortdir + attemptnum: attemptnum archived: archived ) + res)) db (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE state != 'DELETED' AND run_id=?;") run-id) res)) @@ -2650,13 +2659,17 @@ run-id #f (lambda (db) (let ((res #f)) (sqlite3:for-each-row ;; attemptnum added to hold pid of top process (not Megatest) controlling a test - (lambda (id run-id testname state status event-time host cpuload diskfree uname rundir-id item-path run_duration final-logf-id comment short-dir-id attemptnum archived) + (lambda (id run-id test-name state status event-time host cpu-load disk-free uname run-dir item-path run-duration final-logf comment short-dir attempt-num archived) ;; 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 - (set! res (vector id run-id testname state status event-time host cpuload diskfree uname rundir-id item-path run_duration final-logf-id comment short-dir-id attemptnum archived))) + ;;(set! res (vector id run-id testname state status event-time host cpuload diskfree uname rundir item-path run_duration final-logf comment short-dir attemptnum archived))) + (set! res (make-db:test-rec id: id run-id: run-id test-name: test-name state: state status: status event-time: event-time + host: host cpu-load: cpu-load disk-free: disk-free uname: uname run-dir: run-dir item-path: item-path + run-duration: run-duration final-logf: final-logf comment: comment short-dir: short-dir + attempt-num: attempt-num archived: archived))) db (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE id=?;") test-id) res)))) @@ -2686,11 +2699,11 @@ #f (lambda (db) (let ((res #f)) (sqlite3:for-each-row (lambda (a . b) - (set! res (apply vector a b))) + (print a));;set! res (apply vector a b))) db (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE testname=? AND item_path=?;") test-name item-path) res)))) Index: db_records.scm ================================================================== --- db_records.scm +++ db_records.scm @@ -65,30 +65,63 @@ (hash-table-ref/default (dbr:dbstruct-get-locdbs v) run-id #f)) (define (dbr:dbstruct-set-localdb! v run-id db) (hash-table-set! (dbr:dbstruct-get-locdbs v) run-id db)) - -(define (make-db:test)(make-vector 20)) -(define-inline (db:test-get-id vec) (vector-ref vec 0)) -(define-inline (db:test-get-run_id vec) (vector-ref vec 1)) -(define-inline (db:test-get-testname vec) (vector-ref vec 2)) -(define-inline (db:test-get-state vec) (vector-ref vec 3)) -(define-inline (db:test-get-status vec) (vector-ref vec 4)) -(define-inline (db:test-get-event_time vec) (vector-ref vec 5)) -(define-inline (db:test-get-host vec) (vector-ref vec 6)) -(define-inline (db:test-get-cpuload vec) (vector-ref vec 7)) -(define-inline (db:test-get-diskfree vec) (vector-ref vec 8)) -(define-inline (db:test-get-uname vec) (vector-ref vec 9)) -;; (define-inline (db:test-get-rundir vec) (sdb:qry 'getstr (vector-ref vec 10))) -(define-inline (db:test-get-rundir vec) (vector-ref vec 10)) -(define-inline (db:test-get-item-path vec) (vector-ref vec 11)) -(define-inline (db:test-get-run_duration vec) (vector-ref vec 12)) -(define-inline (db:test-get-final_logf vec) (vector-ref vec 13)) -(define-inline (db:test-get-comment vec) (vector-ref vec 14)) -(define-inline (db:test-get-process_id vec) (vector-ref vec 16)) -(define-inline (db:test-get-archived vec) (vector-ref vec 17)) +(require-extension typed-records) +(defstruct db:test-rec ((id -1) : number) + ((run-id -1) : number) + ((test-name "") : string) + ((state "") : string) + ((status "") : string) + ((event-time -1) : number) + ((host "") : string) + ((cpu-load -1) : number) + ((disk-free -1) : number) + ((uname "") : string) + ((run-dir "") : string) + ((item-path "") : string) + ((run-duration -1) : number) + ((final-logf "") : string) + ((comment "") : string) + ((process-id -1) : number) + ((archived -1) : number) + ((short-dir -1) : number) + ((attempt-num -1) : number)) + +(define (db:qry-gen-alist qrystr listvals) + (define listqry (string-split qrystr ",")) + (if (null? listqry) + '() + (let loop ((strhead (car listqry)) + (strtail (cdr listqry)) + (valhead (car listvals)) + (valtail (cdr listvals)) + (res '())) + (let* ((slot-val-pair (cons (string->symbol strhead) valhead))) + (if (or (null? strtail) + (null? valtail)) + (cons slot-val-pair res);;(print strhead valhead));;(cons (cons (string->symbol strhead) valhead) res)) + (loop (car strtail)(cdr strtail)(car valtail)(cdr valtail)(cons slot-val-pair res))))))) + +(define (db:test-get-id typed-rec) (db:test-rec-id typed-rec)) +(define (db:test-get-run_id typed-rec) (db:test-rec-run-id typed-rec)) +(define (db:test-get-testname typed-rec) (db:test-rec-test-name typed-rec)) +(define (db:test-get-state typed-rec) (db:test-rec-state typed-rec)) +(define (db:test-get-status typed-rec) (db:test-rec-status typed-rec)) +(define (db:test-get-event_time typed-rec) (db:test-rec-event-time typed-rec)) +(define (db:test-get-host typed-rec) (db:test-rec-host typed-rec)) +(define (db:test-get-cpuload typed-rec) (db:test-rec-cpu-load typed-rec)) +(define (db:test-get-diskfree typed-rec) (db:test-rec-disk-free typed-rec)) +(define (db:test-get-uname typed-rec) (db:test-rec-uname typed-rec)) +(define (db:test-get-rundir typed-rec) (db:test-rec-run-dir typed-rec)) +(define (db:test-get-item-path typed-rec) (db:test-rec-item-path typed-rec)) +(define (db:test-get-run_duration typed-rec) (db:test-rec-run-duration typed-rec)) +(define (db:test-get-final_logf typed-rec) (db:test-rec-final-logf typed-rec)) +(define (db:test-get-comment typed-rec) (db:test-rec-comment typed-rec)) +(define (db:test-get-process_id typed-rec) (db:test-rec-process-id typed-rec)) +(define (db:test-get-archived typed-rec) (db:test-rec-archived typed-rec)) ;; (define-inline (db:test-get-pass_count vec) (vector-ref vec 15)) ;; (define-inline (db:test-get-fail_count vec) (vector-ref vec 16)) (define-inline (db:test-get-fullname vec) (conc (db:test-get-testname vec) "/" (db:test-get-item-path vec))) Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -1700,11 +1700,11 @@ (debug:print-info 0 *default-log-port* "action not recognised " action))) ;; actions that operate on one test at a time can be handled below ;; (let ((sorted-tests (filter - vector? + db:test-rec? (sort tests (lambda (a b)(let ((dira ;; (rmt:sdb-qry 'getstr (db:test-get-rundir a)) ;; ) ;; (filedb:get-path *fdb* (db:test-get-rundir a))) (dirb ;; (rmt:sdb-qry 'getstr (db:test-get-rundir b))) ;; ) ;; ((filedb:get-path *fdb* (db:test-get-rundir b)))) (if (and (string? dira)(string? dirb))