Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -1396,12 +1396,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 @@ -2251,11 +2251,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 @@ -2284,24 +2287,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)) @@ -2568,12 +2573,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)) @@ -2645,11 +2654,16 @@ (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) ;; 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-id item-path run_duration final-logf-id comment short-dir-id 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 id=?;") test-id) res)))) @@ -2679,11 +2693,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 @@ -63,30 +63,61 @@ (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) + ((testname "") : string) + ((state "") : string) + ((status "") : string) + ((event_time -1) : number) + ((host "") : string) + ((cpuload -1) : number) + ((diskfree -1) : number) + ((uname "") : string) + ((rundir "") : string) + ((item_path "") : string) + ((run_duration -1) : number) + ((final_logf "") : string) + ((comment "") : string) + ((process_id -1) : number) + ((archived -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-testname 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-cpuload typed-rec)) +(define (db:test-get-diskfree typed-rec) (db:test-rec-diskfree 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-rundir 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)))