Index: dashboard-guimonitor.scm ================================================================== --- dashboard-guimonitor.scm +++ dashboard-guimonitor.scm @@ -179,11 +179,11 @@ ;; (print "On-exit called") (tasks:remove-monitor-record tdb) (sqlite3:finalize! tdb)))) (define (gui-monitor db) - (let ((keys (get-keys db)) + (let ((keys (rdb:get-keys db)) (tdb (tasks:open-db))) (tasks:register-monitor db tdb) ;;; let the other monitors know we are here (control-panel db tdb keys) ;(tasks:remove-monitor-record db) ;(sqlite3:finalize! db) Index: dashboard-tests.scm ================================================================== --- dashboard-tests.scm +++ dashboard-tests.scm @@ -197,21 +197,21 @@ (iup:frame #:title "Set fields" (iup:vbox (iup:hbox (iup:label "Comment:") (iup:textbox #:action (lambda (val a b) - (db:test-set-state-status-by-id *db* test-id #f #f b) + (rdb:test-set-state-status-by-id *db* test-id #f #f b) (set! newcomment b)) #:value (db:test-get-comment testdat) #:expand "HORIZONTAL")) (apply iup:hbox (iup:label "STATE:" #:size "30x") (let* ((btns (map (lambda (state) (let ((btn (iup:button state #:expand "HORIZONTAL" #:size "50x" #:font "Courier New, -10" #:action (lambda (x) - (db:test-set-state-status-by-id *db* test-id state #f #f) + (rdb:test-set-state-status-by-id *db* test-id state #f #f) (db:test-set-state! testdat state))))) btn)) (list "COMPLETED" "NOT_STARTED" "RUNNING" "REMOTEHOSTSTART" "KILLED" "KILLREQ")))) (vector-set! *state-status* 0 (lambda (state color) @@ -227,11 +227,11 @@ (iup:label "STATUS:" #:size "30x") (let* ((btns (map (lambda (status) (let ((btn (iup:button status #:expand "HORIZONTAL" #:size "50x" #:font "Courier New, -10" #:action (lambda (x) - (db:test-set-state-status-by-id *db* test-id #f status #f) + (rdb:test-set-state-status-by-id *db* test-id #f status #f) (db:test-set-status! testdat status))))) btn)) (list "PASS" "WARN" "FAIL" "CHECK" "n/a" "WAIVED")))) (vector-set! *state-status* 1 (lambda (status color) @@ -249,22 +249,22 @@ ;; ;;====================================================================== (define (examine-test db test-id) ;; run-id run-key origtest) (let* ((testdat (db:get-test-data-by-id db test-id)) (run-id (if testdat (db:test-get-run_id testdat) #f)) - (keydat (if testdat (keys:get-key-val-pairs db run-id) #f)) - (rundat (if testdat (db:get-run-info db run-id) #f)) + (keydat (if testdat (rdb:get-key-val-pairs db run-id) #f)) + (rundat (if testdat (rdb:get-run-info db run-id) #f)) (runname (if testdat (db:get-value-by-header (db:get-row rundat) (db:get-header rundat) "runname") #f)) ;(teststeps (if testdat (db:get-steps-for-test db test-id) #f)) (logfile "/this/dir/better/not/exist") (rundir logfile) (testfullname (if testdat (db:test-get-fullname testdat) "Gathering data ...")) (testname (if testdat (db:test-get-testname testdat) "n/a")) (testmeta (if testdat - (let ((tm (db:testmeta-get-record db testname))) + (let ((tm (rdb:testmeta-get-record db testname))) (if tm tm (make-db:testmeta))) (make-db:testmeta))) (keystring (string-intersperse (map (lambda (keyval) @@ -285,16 +285,16 @@ ""))) (system (conc "cd " rundir ";xterm -T \"" (string-translate testfullname "()" " ") "\" " shell "&"))) (message-window (conc "Directory " rundir " not found"))))) (refreshdat (lambda () - (let ((newtestdat (db:get-test-data-by-id db test-id))) + (let ((newtestdat (rdb:get-test-data-by-id db test-id))) (if newtestdat (begin ;(mutex-lock! mx1) (set! testdat newtestdat) - (set! teststeps (db:get-steps-for-test db test-id)) + (set! teststeps (rdb:get-steps-for-test db test-id)) (set! logfile (conc (db:test-get-rundir testdat) "/" (db:test-get-final_logf testdat))) (set! rundir (db:test-get-rundir testdat)) (set! testfullname (db:test-get-fullname testdat)) ;(mutex-unlock! mx1) ) @@ -391,11 +391,11 @@ #:size "60x100"))) (hash-table-set! widgets "Test Steps" (lambda (testdat) (let* ((currval (iup:attribute stepsdat "VALUE")) ;; "TITLE")) (fmtstr "~20a~10a~10a~12a~15a~20a") - (comprsteps (db:get-steps-table db test-id)) + (comprsteps (rdb:get-steps-table db test-id)) (newval (string-intersperse (append (list (format #f fmtstr "Stepname" "Start" "End" "Status" "Time" "Logfile") (format #f fmtstr "========" "=====" "===" "======" "====" "=======")) Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -80,20 +80,20 @@ (define *db* (open-db)) (define toplevel #f) (define dlg #f) (define max-test-num 0) -(define *keys* (get-keys *db*)) +(define *keys* (rdb:get-keys *db*)) (define *dbkeys* (map (lambda (x)(vector-ref x 0)) (append *keys* (list (vector "runname" "blah"))))) (define *header* #f) (define *allruns* '()) (define *buttondat* (make-hash-table)) ;; (define *alltestnamelst* '()) (define *searchpatts* (make-hash-table)) (define *num-runs* 8) -(define *tot-run-count* (db:get-num-runs *db* "%")) +(define *tot-run-count* (rdb:get-num-runs *db* "%")) (define *last-update* (current-seconds)) (define *num-tests* 15) (define *start-run-offset* 0) (define *start-test-offset* 0) (define *examine-test-dat* (make-hash-table)) @@ -121,59 +121,10 @@ (define-inline (dboard:uidat-get-keycol vec)(vector-ref vec 0)) (define-inline (dboard:uidat-get-lftcol vec)(vector-ref vec 1)) (define-inline (dboard:uidat-get-header vec)(vector-ref vec 2)) (define-inline (dboard:uidat-get-runsvec vec)(vector-ref vec 3)) -;; (megatest-dashboard) - -;(define img1 (iup:image/palette 16 16 (u8vector->blob (u8vector -; 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 2 -; 1 1 1 1 1 1 1 1 1 1 1 1 1 1 2 2 -; 1 1 1 1 1 1 1 1 1 1 1 1 1 2 2 2 -; 1 1 1 1 1 1 1 1 1 1 1 1 2 2 2 2 -; 1 1 1 1 1 1 1 1 1 1 1 2 2 2 2 2 -; 1 1 1 1 1 1 1 1 1 1 2 2 2 2 2 2 -; 1 1 1 1 1 1 1 1 1 2 2 2 2 2 2 2 -; 1 1 1 1 1 1 1 1 2 2 2 2 2 2 2 2 -; 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 -; 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 -; 2 2 2 0 2 2 2 2 2 2 2 2 2 2 2 2 -; 2 2 2 0 2 2 2 2 2 2 2 2 2 2 2 2 -; 2 2 2 0 2 0 2 0 2 2 0 2 2 2 0 0 -; 2 2 2 0 2 0 0 2 0 0 2 0 2 0 2 2 -; 2 2 2 0 2 0 2 2 0 2 2 0 2 2 2 2 -; 2 2 2 0 2 0 2 2 0 2 2 0 2 2 0 0 -; 2 2 2 0 2 0 2 2 0 2 2 0 2 0 2 1)))) -; -;(define img2 (iup:image/palette 16 16 (u8vector->blob (u8vector -; 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 1 -; 2 2 2 2 2 2 2 2 2 2 2 2 2 2 1 1 -; 2 2 2 2 2 2 2 2 2 2 2 2 2 1 1 1 -; 1 1 1 1 1 1 1 1 1 1 1 1 2 2 2 2 -; 1 1 1 1 1 1 1 1 1 1 1 2 2 2 2 2 -; 1 1 1 1 1 1 1 1 1 1 2 2 2 2 2 2 -; 1 1 1 1 1 1 1 1 1 2 2 2 2 2 2 2 -; 1 1 1 1 1 1 1 1 2 2 2 2 2 2 2 2 -; 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 -; 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 -; 2 2 2 0 2 2 2 2 2 2 2 2 2 2 2 2 -; 2 2 2 0 2 2 2 2 2 2 2 2 2 2 2 2 -; 2 2 2 0 2 0 2 0 2 2 0 2 2 2 0 0 -; 2 2 2 0 2 0 0 2 0 0 2 0 2 0 2 2 -; 2 2 2 0 2 0 2 2 0 2 2 0 2 2 2 2 -; 2 2 2 0 2 0 2 2 0 2 2 0 2 2 0 0 -; 2 2 2 0 2 0 2 2 0 2 2 0 2 0 2 1)))) -; -;(iup:handle-name-set! img1 "img1") -;(iup:attribute-set! img1 "0" "0 0 0") -;(iup:attribute-set! img1 "1" "BGCOLOR") -;(iup:attribute-set! img1 "2" "255 0 0") -; -;(iup:handle-name-set! img2 "img2") -;(iup:attribute-set! img2 "0" "0 0 0") -;(iup:attribute-set! img2 "1" "BGCOLOR") -;(iup:attribute-set! img2 "2" "255 0 0") (define (message-window msg) (iup:show (iup:dialog (iup:vbox @@ -207,11 +158,11 @@ (> *delayed-update* 0)) (begin (set! *please-update-buttons* #t) (set! *last-db-update-time* modtime) (set! *delayed-update* (- *delayed-update* 1)) - (let* ((allruns (db:get-runs *db* runnamepatt numruns ;; (+ numruns 1) ;; (/ numruns 2)) + (let* ((allruns (rdb:get-runs *db* runnamepatt numruns ;; (+ numruns 1) ;; (/ numruns 2)) *start-run-offset* keypatts)) (header (db:get-header allruns)) (runs (db:get-rows allruns)) (result '()) (maxtests 0) @@ -219,16 +170,16 @@ (statuses (hash-table-keys *status-ignore-hash*))) (debug:print 6 "update-rundat, got " (length runs) " runs") (if (> (+ *last-update* 300) (current-seconds)) ;; every five minutes (begin (set! *last-update* (current-seconds)) - (set! *tot-run-count* (db:get-num-runs *db* runnamepatt)))) + (set! *tot-run-count* (rdb:get-num-runs *db* runnamepatt)))) (for-each (lambda (run) (let* ((run-id (db:get-value-by-header run header "id")) - (tests (let ((tsts (db-get-tests-for-run *db* run-id testnamepatt itemnamepatt states statuses))) + (tests (let ((tsts (rdb:get-tests-for-run *db* run-id testnamepatt itemnamepatt states statuses))) (if *tests-sort-reverse* (reverse tsts) tsts))) - (key-vals (get-key-vals *db* run-id))) + (key-vals (rdb:get-key-vals *db* run-id))) (if (> (length tests) maxtests) (set! maxtests (length tests))) (if (or (not *hide-empty-runs*) ;; this reduces the data burden when set (not (null? tests))) (set! result (cons (vector run tests key-vals) result))))) @@ -295,22 +246,10 @@ (if (equal? (vector-ref x 1) "") (vector-ref x 0) (conc (vector-ref x 0) "(" (vector-ref x 1) ")"))) vlst-s2))) - ;; (sort newlst (lambda (a b) - ;; (let* ((partsa (string-split a "(")) - ;; (partsb (string-split b "(")) - ;; (lena (length partsa)) - ;; (lenb (length partsb))) - ;; (if (or (and (eq? lena 1)(> lenb 1)) - ;; (and (eq? lenb 1)(> lena 1))) - ;; (if (equal? (car partsa)(car partsb)) ;; same test - ;; (> lenb lena) - ;; #t) - ;; #t)))))) - (define (update-labels uidat) (let* ((rown 0) (keycol (dboard:uidat-get-keycol uidat)) (lftcol (dboard:uidat-get-lftcol uidat)) (numcols (vector-length lftcol)) Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -29,50 +29,56 @@ (include "key_records.scm") (include "run_records.scm") (define (open-db) ;; (conc *toppath* "/megatest.db") (car *configinfo*))) (let* ((dbpath (conc *toppath* "/megatest.db")) ;; fname) - (configdat (car *configinfo*)) (dbexists (file-exists? dbpath)) (db (sqlite3:open-database dbpath)) ;; (never-give-up-open-db dbpath)) (handler (make-busy-timeout 36000))) (sqlite3:set-busy-handler! db handler) (if (not dbexists) - (let* ((keys (config-get-fields configdat)) - (havekeys (> (length keys) 0)) - (keystr (keys->keystr keys)) - (fieldstr (keys->key/field keys))) - (for-each (lambda (key) - (let ((keyn (vector-ref key 0))) - (if (member (string-downcase keyn) - (list "runname" "state" "status" "owner" "event_time" "comment" "fail_count" - "pass_count")) - (begin - (print "ERROR: your key cannot be named " keyn " as this conflicts with the same named field in the runs table") - (system (conc "rm -f " dbpath)) - (exit 1))))) - keys) - ;; (sqlite3:execute db "PRAGMA synchronous = OFF;") - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS keys (id INTEGER PRIMARY KEY, fieldname TEXT, fieldtype TEXT, CONSTRAINT keyconstraint UNIQUE (fieldname));") - (for-each (lambda (key) - (sqlite3:execute db "INSERT INTO keys (fieldname,fieldtype) VALUES (?,?);" (key:get-fieldname key)(key:get-fieldtype key))) - keys) - (sqlite3:execute db (conc - "CREATE TABLE IF NOT EXISTS runs (id INTEGER PRIMARY KEY, " - fieldstr (if havekeys "," "") - "runname TEXT," - "state TEXT DEFAULT ''," - "status TEXT DEFAULT ''," - "owner TEXT DEFAULT ''," - "event_time TIMESTAMP," - "comment TEXT DEFAULT ''," - "fail_count INTEGER DEFAULT 0," - "pass_count INTEGER DEFAULT 0," - "CONSTRAINT runsconstraint UNIQUE (runname" (if havekeys "," "") keystr "));")) - (sqlite3:execute db (conc "CREATE INDEX runs_index ON runs (runname" (if havekeys "," "") keystr ");")) - (sqlite3:execute db - "CREATE TABLE IF NOT EXISTS tests + (db:initialize db)) + (if (not (args:get-arg "-server")) + (server:client-setup db)) + db)) + +(define (db:initialize db) + (let* ((configdat (car *configinfo*)) ;; tut tut, global warning... + (keys (config-get-fields configdat)) + (havekeys (> (length keys) 0)) + (keystr (keys->keystr keys)) + (fieldstr (keys->key/field keys))) + (for-each (lambda (key) + (let ((keyn (vector-ref key 0))) + (if (member (string-downcase keyn) + (list "runname" "state" "status" "owner" "event_time" "comment" "fail_count" + "pass_count")) + (begin + (print "ERROR: your key cannot be named " keyn " as this conflicts with the same named field in the runs table") + (system (conc "rm -f " dbpath)) + (exit 1))))) + keys) + ;; (sqlite3:execute db "PRAGMA synchronous = OFF;") + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS keys (id INTEGER PRIMARY KEY, fieldname TEXT, fieldtype TEXT, CONSTRAINT keyconstraint UNIQUE (fieldname));") + (for-each (lambda (key) + (sqlite3:execute db "INSERT INTO keys (fieldname,fieldtype) VALUES (?,?);" (key:get-fieldname key)(key:get-fieldtype key))) + keys) + (sqlite3:execute db (conc + "CREATE TABLE IF NOT EXISTS runs (id INTEGER PRIMARY KEY, " + fieldstr (if havekeys "," "") + "runname TEXT," + "state TEXT DEFAULT ''," + "status TEXT DEFAULT ''," + "owner TEXT DEFAULT ''," + "event_time TIMESTAMP," + "comment TEXT DEFAULT ''," + "fail_count INTEGER DEFAULT 0," + "pass_count INTEGER DEFAULT 0," + "CONSTRAINT runsconstraint UNIQUE (runname" (if havekeys "," "") keystr "));")) + (sqlite3:execute db (conc "CREATE INDEX runs_index ON runs (runname" (if havekeys "," "") keystr ");")) + (sqlite3:execute db + "CREATE TABLE IF NOT EXISTS tests (id INTEGER PRIMARY KEY, run_id INTEGER, testname TEXT, host TEXT DEFAULT 'n/a', cpuload REAL DEFAULT -1, @@ -92,27 +98,27 @@ fail_count INTEGER DEFAULT 0, pass_count INTEGER DEFAULT 0, archived INTEGER DEFAULT 0, -- 0=no, 1=in progress, 2=yes CONSTRAINT testsconstraint UNIQUE (run_id, testname, item_path) );") - (sqlite3:execute db "CREATE INDEX tests_index ON tests (run_id, testname);") - (sqlite3:execute db "CREATE VIEW runs_tests AS SELECT * FROM runs INNER JOIN tests ON runs.id=tests.run_id;") - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_steps + (sqlite3:execute db "CREATE INDEX tests_index ON tests (run_id, testname);") + (sqlite3:execute db "CREATE VIEW runs_tests AS SELECT * FROM runs INNER JOIN tests ON runs.id=tests.run_id;") + (sqlite3:execute db "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));") - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS extradat (id INTEGER PRIMARY KEY, run_id INTEGER, key TEXT, val TEXT);") - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS metadat (id INTEGER PRIMARY KEY, var TEXT, val TEXT, + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS extradat (id INTEGER PRIMARY KEY, run_id INTEGER, key TEXT, val TEXT);") + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS metadat (id INTEGER PRIMARY KEY, var TEXT, val TEXT, CONSTRAINT metadat_constraint UNIQUE (var));") - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS access_log (id INTEGER PRIMARY KEY, user TEXT, accessed TIMESTAMP, args TEXT);") - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_meta (id INTEGER PRIMARY KEY, + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS access_log (id INTEGER PRIMARY KEY, user TEXT, accessed TIMESTAMP, args TEXT);") + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_meta (id INTEGER PRIMARY KEY, testname TEXT DEFAULT '', author TEXT DEFAULT '', owner TEXT DEFAULT '', description TEXT DEFAULT '', reviewed TIMESTAMP, @@ -120,11 +126,11 @@ avg_runtime REAL, avg_disk REAL, tags TEXT DEFAULT '', jobgroup TEXT DEFAULT 'default', CONSTRAINT test_meta_constraint UNIQUE (testname));") - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_data (id INTEGER PRIMARY KEY, + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_data (id INTEGER PRIMARY KEY, test_id INTEGER, category TEXT DEFAULT '', variable TEXT, value REAL, expected REAL, @@ -132,15 +138,13 @@ units TEXT, comment TEXT DEFAULT '', status TEXT DEFAULT 'n/a', type TEXT DEFAULT '', CONSTRAINT test_data_constraint UNIQUE (test_id,category,variable));") - ;; Must do this *after* running patch db !! No more. - (db:set-var db "MEGATEST_VERSION" megatest-version) - )) - (server:client-setup db) - db)) + ;; Must do this *after* running patch db !! No more. + (db:set-var db "MEGATEST_VERSION" megatest-version) + )) ;;====================================================================== ;; TODO: ;; put deltas into an assoc list with version numbers ;; apply all from last to current @@ -247,11 +251,11 @@ ;; use a global for some primitive caching, it is just silly to re-read the db ;; over and over again for the keys since they never change (define *db-keys* #f) -(define (db-get-keys db) +(define (db:get-keys db) (if *db-keys* *db-keys* (let ((res '())) (sqlite3:for-each-row (lambda (key keytype) (set! res (cons (vector key keytype) res))) @@ -258,12 +262,10 @@ db "SELECT fieldname,fieldtype FROM keys ORDER BY id DESC;") (set! *db-keys* res) res))) -(define db:get-keys db-get-keys) - (define (db:get-value-by-header row header field) ;; (debug:print 2 "db:get-value-by-header row: " row " header: " header " field: " field) (if (null? header) #f (let loop ((hed (car header)) (tal (cdr header)) @@ -291,11 +293,11 @@ ;; ;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") ) ;; (define (db:get-runs db runpatt count offset keypatts) (let* ((res '()) - (keys (db-get-keys db)) + (keys (db:get-keys db)) (remfields (list "id" "runname" "state" "status" "owner" "event_time")) (header (append (map key:get-fieldname keys) remfields)) (keystr (conc (keys->keystr keys) "," (string-intersperse remfields ","))) @@ -315,11 +317,11 @@ (conc " LIMIT " count) "") (if (number? offset) (conc " OFFSET " offset) "")))) - (debug:print 4 "db:get-runs qrystr: " qrystr "\nkeypatts: " keypatts "\n offset: " offset " limit: " count) + (debug:print 8 "INFO: db:get-runs qrystr: " qrystr "\nkeypatts: " keypatts "\n offset: " offset " limit: " count) (sqlite3:for-each-row (lambda (a . x) (set! res (cons (apply vector a x) res))) db qrystr @@ -334,15 +336,14 @@ (set! numruns count)) db "SELECT COUNT(id) FROM runs WHERE runname LIKE ?;" runpatt) numruns)) - ;; use (get-value-by-header (db:get-header runinfo)(db:get-row runinfo)) (define (db:get-run-info db run-id) (let* ((res #f) - (keys (db-get-keys db)) + (keys (db:get-keys db)) (remfields (list "id" "runname" "state" "status" "owner" "event_time")) (header (append (map key:get-fieldname keys) remfields)) (keystr (conc (keys->keystr keys) "," (string-intersperse remfields ",")))) @@ -362,33 +363,71 @@ (define (db:delete-run db run-id) (sqlite3:execute db "DELETE FROM runs WHERE id=?;" run-id)) (define (db:update-run-event_time db run-id) (sqlite3:execute db "UPDATE runs SET event_time=strftime('%s','now') WHERE id=?;" run-id)) + +;;====================================================================== +;; K E Y S +;;====================================================================== + +;; get key val pairs for a given run-id +;; ( (FIELDNAME1 keyval1) (FIELDNAME2 keyval2) ... ) +(define (db:get-key-val-pairs db run-id) + (let* ((keys (get-keys db)) + (res '())) + (debug:print 6 "keys: " keys " run-id: " run-id) + (for-each + (lambda (key) + (let ((qry (conc "SELECT " (key:get-fieldname key) " FROM runs WHERE id=?;"))) + ;; (debug:print 0 "qry: " qry) + (sqlite3:for-each-row + (lambda (key-val) + (set! res (cons (list (key:get-fieldname key) key-val) res))) + db qry run-id))) + keys) + (reverse res))) + +;; get key vals for a given run-id +(define (db:get-key-vals db run-id) + (let* ((keys (get-keys db)) + (res '())) + (debug:print 6 "keys: " keys " run-id: " run-id) + (for-each + (lambda (key) + (let ((qry (conc "SELECT " (key:get-fieldname key) " FROM runs WHERE id=?;"))) + ;; (debug:print 0 "qry: " qry) + (sqlite3:for-each-row + (lambda (key-val) + (set! res (cons key-val res))) + db qry run-id))) + keys) + (reverse res))) ;;====================================================================== ;; T E S T S ;;====================================================================== ;; states and statuses are lists, turn them into ("PASS","FAIL"...) and use NOT IN ;; i.e. these lists define what to NOT show. ;; states and statuses are required to be lists, empty is ok -(define (db-get-tests-for-run db run-id testpatt itempatt states statuses) - (let ((res '()) - (states-str (conc "('" (string-intersperse states "','") "')")) - (statuses-str (conc "('" (string-intersperse statuses "','") "')")) - ) +(define (db:get-tests-for-run db run-id testpatt itempatt states statuses) + (let* ((res '()) + (states-str (conc "('" (string-intersperse states "','") "')")) + (statuses-str (conc "('" (string-intersperse statuses "','") "')")) + (qry (conc "SELECT id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment " + " FROM tests WHERE run_id=? AND testname like ? AND item_path LIKE ? " + " AND NOT (state in " states-str " AND status IN " statuses-str ") " + ;; " ORDER BY id DESC;" + " ORDER BY event_time ASC;" ;; POTENTIAL ISSUE! CHECK ME! Does anyting depend on this being sorted by id? + ))) + (debug:print 8 "INFO: db:get-tests-for-run qry=" qry) (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))) db - (conc "SELECT id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment " - " FROM tests WHERE run_id=? AND testname like ? AND item_path LIKE ? " - " AND NOT (state in " states-str " AND status IN " statuses-str ") " - ;; " ORDER BY id DESC;" - " ORDER BY event_time ASC;" ;; POTENTIAL ISSUE! CHECK ME! Does anyting depend on this being sorted by id? - ) + qry run-id (if testpatt testpatt "%") (if itempatt itempatt "%")) res)) @@ -833,38 +872,17 @@ "\ntime: " (db:step-get-event_time step)))) ;; (else (vector-set! record 1 (db:step-get-event_time step))) (sort steps (lambda (a b)(< (db:step-get-event_time a)(db:step-get-event_time b))))) res))) -;; USE: (lset-difference string=? '("a" "b" "c") '("d" "c" "e" "a")) -;; -;; Return a list of prereqs that were NOT met -;; Tests (and all items) in waiton list must be "COMPLETED" and "PASS" -(define (db-get-prereqs-not-met db run-id waiton) - (if (null? waiton) - '() - (let* ((unmet-pre-reqs '()) - (tests (db-get-tests-for-run db run-id #f #f '() '())) - (result '())) - (for-each (lambda (waitontest-name) - (let ((ever-seen #f)) - (for-each (lambda (test) - (if (equal? waitontest-name (db:test-get-testname test)) - (begin - (set! ever-seen #t) - (if (not (and (equal? (db:test-get-state test) "COMPLETED") - (member (db:test-get-status test) '("PASS" "WARN" "CHECK")))) - (set! result (cons waitontest-name result)))))) - tests) - (if (not ever-seen)(set! result (cons waitontest-name result))))) - waiton) - (delete-duplicates result)))) - ;; the new prereqs calculation, looks also at itempath if specified ;; all prereqs must be met: ;; if prereq test with itempath='' is COMPLETED and PASS, WARN, CHECK, or WAIVED then prereq is met ;; if prereq test with itempath=ref-item-path and COMPLETED with PASS, WARN, CHECK, or WAIVED then prereq is met +;; +;; Note: do not convert to remote as it calls remote under the hood +;; (define (db:get-prereqs-not-met db run-id waitons ref-item-path) (if (or (not waitons) (null? waitons)) '() (let* ((unmet-pre-reqs '()) @@ -871,11 +889,11 @@ (result '())) (for-each (lambda (waitontest-name) ;; by getting the tests with matching name we are looking only at the matching test ;; and related sub items - (let ((tests (db-get-tests-for-run db run-id waitontest-name #f '() '())) + (let ((tests (rdb:get-tests-for-run db run-id waitontest-name #f '() '())) (ever-seen #f) (parent-waiton-met #f) (item-waiton-met #f)) (for-each (lambda (test) @@ -1114,8 +1132,109 @@ (define (rdb:test-set-log! db run-id test-name item-path logf) (if *runremote* (let ((host (vector-ref *runremote* 0)) (port (vector-ref *runremote* 1))) - ((rpc:procedure 'rpc:test-set-log! host port) + ((rpc:procedure 'rdb:test-set-log! host port) run-id test-name item-path logf)) (db:test-set-log! db run-id test-name item-path logf))) + +(define (rdb:get-runs db runnamepatt numruns startrunoffset keypatts) + (if *runremote* + (let ((host (vector-ref *runremote* 0)) + (port (vector-ref *runremote* 1))) + ((rpc:procedure 'rdb:get-runs host port) + runnamepatt numruns startrunoffset keypatts)) + (db:get-runs db runnamepatt numruns startrunoffset keypatts))) + +(define (rdb:get-tests-for-run db run-id testpatt itempatt states statuses) + (if *runremote* + (let ((host (vector-ref *runremote* 0)) + (port (vector-ref *runremote* 1))) + ((rpc:procedure 'rdb:get-tests-for-run host port) + run-id testpatt itempatt states statuses)) + (db:get-tests-for-run db run-id testpatt itempatt states statuses))) + +(define (rdb:get-keys db) + (if *runremote* + (let ((host (vector-ref *runremote* 0)) + (port (vector-ref *runremote* 1))) + ((rpc:procedure 'rdb:get-keys host port))) + (db:get-keys db))) + +(define (rdb:get-num-runs db runpatt) + (if *runremote* + (let ((host (vector-ref *runremote* 0)) + (port (vector-ref *runremote* 1))) + ((rpc:procedure 'rdb:get-num-runs host port) runpatt)) + (db:get-num-runs db runpatt))) + +(define (rdb:test-set-state-status-by-id db test-id newstate newstatus newcomment) + (if *runremote* + (let ((host (vector-ref *runremote* 0)) + (port (vector-ref *runremote* 1))) + ((rpc:procedure 'rdb:test-set-state-status-by-id host port) + test-id newstate newstatus newcomment)) + (db:test-set-state-status-by-id db test-id newstate newstatus newcomment))) + +(define (rdb:get-key-val-pairs db run-id) + (if *runremote* + (let ((host (vector-ref *runremote* 0)) + (port (vector-ref *runremote* 1))) + ((rpc:procedure 'rdb:get-key-val-pairs host port) run-id)) + (db:get-key-val-pairs db run-id))) + +(define (rdb:get-key-vals db run-id) + (if *runremote* + (let ((host (vector-ref *runremote* 0)) + (port (vector-ref *runremote* 1))) + ((rpc:procedure 'rdb:get-key-vals host port) run-id)) + (db:get-key-vals db run-id))) + +(define (rdb:testmeta-get-record db testname) + (if *runremote* + (let ((host (vector-ref *runremote* 0)) + (port (vector-ref *runremote* 1))) + ((rpc:procedure 'rdb:testmeta-get-record host port) testname)) + (db:testmeta-get-record db testname))) + +(define (rdb:get-test-data-by-id db test-id) + (if *runremote* + (let ((host (vector-ref *runremote* 0)) + (port (vector-ref *runremote* 1))) + ((rpc:procedure 'rdb:get-test-data-by-id host port) test-id)) + (db:get-test-data-by-id db test-id))) + +(define (rdb:get-run-info db run-id) + (if *runremote* + (let ((host (vector-ref *runremote* 0)) + (port (vector-ref *runremote* 1))) + ((rpc:procedure 'rdb:get-run-info host port) run-id)) + (db:get-run-info run-id))) + +(define (rdb:get-steps-for-test db test-id) + (if *runremote* + (let ((host (vector-ref *runremote* 0)) + (port (vector-ref *runremote* 1))) + ((rpc:procedure 'rdb:get-steps-for-test host port) test-id)) + (db:get-steps-for-test test-id))) + +(define (rdb:get-steps-table db test-id) + (if *runremote* + (let ((host (vector-ref *runremote* 0)) + (port (vector-ref *runremote* 1))) + ((rpc:procedure 'rdb:get-steps-table host port) test-id)) + (db:get-steps-table test-id))) + +(define (rdb:read-test-data db test-id categorypatt) + (if *runremote* + (let ((host (vector-ref *runremote* 0)) + (port (vector-ref *runremote* 1))) + ((rpc:procedure 'rdb:read-test-data host port) test-id categorypatt)) + (db:read-test-data db test-id categorypatt))) + +(define (rdb:get-test-info db run-id testname item-path) + (if *runremote* + (let ((host (vector-ref *runremote* 0)) + (port (vector-ref *runremote* 1))) + ((rpc:procedure 'rdb:get-test-info host port) run-id testname item-path)) + (db:get-test-info db run-id testname item-path))) Index: keys.scm ================================================================== --- keys.scm +++ keys.scm @@ -27,43 +27,10 @@ (set! keys (cons (vector fieldname fieldtype) keys))) db "SELECT fieldname,fieldtype FROM keys ORDER BY id ASC;") (reverse keys))) ;; could just sort desc? -;; get key vals for a given run-id -(define (get-key-vals db run-id) - (let* ((keys (get-keys db)) - (res '())) - (debug:print 6 "keys: " keys " run-id: " run-id) - (for-each - (lambda (key) - (let ((qry (conc "SELECT " (key:get-fieldname key) " FROM runs WHERE id=?;"))) - ;; (debug:print 0 "qry: " qry) - (sqlite3:for-each-row - (lambda (key-val) - (set! res (cons key-val res))) - db qry run-id))) - keys) - (reverse res))) - -;; get key val pairs for a given run-id -;; ( (FIELDNAME1 keyval1) (FIELDNAME2 keyval2) ... ) -(define (keys:get-key-val-pairs db run-id) - (let* ((keys (get-keys db)) - (res '())) - (debug:print 6 "keys: " keys " run-id: " run-id) - (for-each - (lambda (key) - (let ((qry (conc "SELECT " (key:get-fieldname key) " FROM runs WHERE id=?;"))) - ;; (debug:print 0 "qry: " qry) - (sqlite3:for-each-row - (lambda (key-val) - (set! res (cons (list (key:get-fieldname key) key-val) res))) - db qry run-id))) - keys) - (reverse res))) - (define (keys->keystr keys) ;; => key1,key2,key3,additiona1, ... (string-intersperse (map key:get-fieldname keys) ",")) (define (args:usage . a) #f) Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -371,11 +371,11 @@ (item-path (let ((ip (item-list->path itemdat))) (if (equal? ip "") "" (conc "/" ip)))) (runname (db:get-value-by-header (db:get-row run-info) (db:get-header run-info) "runname")) - (key-vals (get-key-vals db run-id)) + (key-vals (rdb:get-key-vals db run-id)) (key-str (string-intersperse key-vals "/")) (dfullp (conc disk-path "/" key-str "/" runname "/" testname item-path)) (toptest-path (conc disk-path "/" key-str "/" runname "/" testname)) (linktree (let ((rd (config-lookup *configdat* "setup" "linktree"))) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -8,20 +8,22 @@ ;; PURPOSE. ;; (include "common.scm") ;; (include "megatest-version.scm") -(use sqlite3 srfi-1 posix regex regex-case srfi-69 base64 format) +(use sqlite3 srfi-1 posix regex regex-case srfi-69 base64 format readline apropos) (import (prefix sqlite3 sqlite3:)) (import (prefix base64 base64:)) (declare (uses common)) (declare (uses megatest-version)) (declare (uses margs)) (declare (uses runs)) (declare (uses launch)) (declare (uses server)) + +(define *db* #f) ;; this is only for the repl, do not use in general!!!! (include "common_records.scm") (include "key_records.scm") (include "db_records.scm") @@ -93,10 +95,11 @@ -setvars VAR1=val1,VAR2=val2 : Add environment variables to a run NB// these are overwritten by values set in config files. -archive : archive tests, use -target, :runname, -itempatt and -testpatt -server -|hostname : start the server (reduces contention on megatest.db), use - to automatically figure out hostname + -repl : start a repl (useful for extending megatest) Spreadsheet generation -extract-ods fname.ods : extract an open document spreadsheet from the database -pathmod path : insert path, i.e. path/runame/itempath/logfile.html will clear the field if no rundir/testname/itempath/logfile @@ -170,10 +173,11 @@ "-load-test-data" "-summarize-items" "-gui" ;; misc "-archive" + "-repl" ;; queries "-test-paths" ;; get path(s) to a test, ordered by youngest first "-runall" ;; run all tests "-remove-runs" @@ -266,14 +270,14 @@ (setup-for-run) (open-db))) (runpatt (args:get-arg "-list-runs")) (testpatt (args:get-arg "-testpatt")) (itempatt (args:get-arg "-itempatt")) - (runsdat (db:get-runs db runpatt #f #f '())) + (runsdat (rdb:get-runs db runpatt #f #f '())) (runs (db:get-rows runsdat)) (header (db:get-header runsdat)) - (keys (db-get-keys db)) + (keys (rdb:get-keys db)) (keynames (map key:get-fieldname keys))) ;; Each run (for-each (lambda (run) (debug:print 2 "Run: " @@ -393,18 +397,18 @@ (db (if toppath (open-db) #f))) (if db (server:start db (args:get-arg "-server")) (debug:print 0 "ERROR: Failed to setup for megatest")))) -;;;====================================================================== +;;====================================================================== ;; Rollup into a run ;;====================================================================== (if (args:get-arg "-rollup") (general-run-call "-rollup" "rollup tests" - (lambda (db keys keynames keyvallst) + (lambda (db target runname keys keynames keyvallst) (runs:rollup-run db keys (keys->alist keys "na") (args:get-arg ":runname") user)))) @@ -437,11 +441,11 @@ (begin (debug:print 0 "Failed to setup, giving up on -test-paths, exiting") (exit 1))) (set! db (open-db)) (let* ((itempatt (args:get-arg "-itempatt")) - (keys (db-get-keys db)) + (keys (rdb:get-keys db)) (keynames (map key:get-fieldname keys)) (paths (db:test-get-paths-matching db keynames target))) (set! *didsomething* #t) (for-each (lambda (path) (print path)) @@ -485,11 +489,11 @@ (begin (debug:print 0 "Failed to setup, giving up on -archive, exiting") (exit 1))) (set! db (open-db)) (let* ((itempatt (args:get-arg "-itempatt")) - (keys (db-get-keys db)) + (keys (rdb:get-keys db)) (keynames (map key:get-fieldname keys)) (paths (db:test-get-paths-matching db keynames target))) (set! *didsomething* #t) (for-each (lambda (path) (print path)) @@ -682,11 +686,11 @@ (if (not (setup-for-run)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) (set! db (open-db)) - (set! keys (db-get-keys db)) + (set! keys (rdb:get-keys db)) (debug:print 1 "Keys: " (string-intersperse (map key:get-fieldname keys) ", ")) (sqlite3:finalize! db) (set! *didsomething* #t))) (if (args:get-arg "-gui") @@ -724,10 +728,31 @@ ;; now can find our db (set! db (open-db)) (runs:update-all-test_meta db) (sqlite3:finalize! db) (set! *didsomething* #t))) + +;;====================================================================== +;; Start a repl +;;====================================================================== +(if (args:get-arg "-repl") + (let* ((toppath (setup-for-run)) + (db (if toppath (open-db) #f))) + (if db + (begin + (set! *db* db) + (import readline) + (import apropos) + (gnu-history-install-file-manager + (string-append + (or (get-environment-variable "HOME") ".") "/.megatest_history")) + (current-input-port (make-gnu-readline-port "megatest> ")) + (repl))))) + +;;====================================================================== +;; Exit and clean up +;;====================================================================== (if (not *didsomething*) (debug:print 0 help)) (if (not (eq? *globalexitstatus* 0)) Index: runconfig.scm ================================================================== --- runconfig.scm +++ runconfig.scm @@ -9,12 +9,12 @@ (declare (uses common)) (include "common_records.scm") (define (setup-env-defaults db fname run-id already-seen #!key (environ-patt #f)) - (let* ((keys (get-keys db)) - (keyvals (get-key-vals db run-id)) + (let* ((keys (rdb:get-keys db)) + (keyvals (rdb:get-key-vals db run-id)) (thekey (string-intersperse (map (lambda (x)(if x x "-na-")) keyvals) "/")) (confdat (read-config fname #f #f environ-patt: environ-patt)) (whatfound (make-hash-table)) (sections (list "default" thekey))) (debug:print 4 "Using key=\"" thekey "\"") Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -57,28 +57,18 @@ db (conc "SELECT " keystr " FROM runs WHERE runname like ? " key-patt ";") runnamepatt) (vector header res))) -;; ;; TODO: Converge this with db:get-test-info -;; (define (runs:get-test-info db run-id test-name item-path) -;; (let ((res #f)) ;; (vector #f #f #f #f #f #f))) -;; (sqlite3:for-each-row -;; (lambda (id run-id test-name state status) -;; (set! res (vector id run-id test-name state status item-path))) -;; db "SELECT id,run_id,testname,state,status FROM tests WHERE run_id=? AND testname=? AND item_path=?;" -;; run-id test-name item-path) -;; res)) - (define (runs:test-get-full-path test) (let* ((testname (db:test-get-testname test)) (itempath (db:test-get-item-path test))) (conc testname (if (equal? itempath "") "" (conc "(" itempath ")"))))) (define (set-megatest-env-vars db run-id) - (let ((keys (db-get-keys db))) + (let ((keys (rdb:get-keys db))) (for-each (lambda (key) (sqlite3:for-each-row (lambda (val) (debug:print 2 "setenv " (key:get-fieldname key) " " val) (setenv (key:get-fieldname key) val)) @@ -168,11 +158,11 @@ #f)))) ;; This is a duplicate of run-tests (which has been deprecated). Use this one instead of run tests. ;; keyvals (define (runs:run-tests db target runname test-patts item-patts user flags) - (let* ((keys (db-get-keys db)) + (let* ((keys (rdb:get-keys db)) (keyvallst (keys:target->keyval keys target)) (run-id (runs:register-run db keys keyvallst runname "new" "n/a" user)) ;; test-name))) (deferred '()) ;; delay running these since they have a waiton clause ;; keepgoing is the defacto modality now, will add hit-n-run a bit later ;; (keepgoing (hash-table-ref/default flags "-keepgoing" #f)) @@ -407,17 +397,17 @@ (runs:update-test_meta db test-name test-conf) ;; (lambda (itemdat) ;;; ((ripeness "overripe") (temperature "cool") (season "summer")) (let* ((new-test-path (string-intersperse (cons test-path (map cadr itemdat)) "/")) (new-test-name (if (equal? item-path "") test-name (conc test-name "/" item-path))) ;; just need it to be unique - (testdat (db:get-test-info db run-id test-name item-path))) + (testdat (rdb:get-test-info db run-id test-name item-path))) (if (not testdat) (begin ;; ensure that the path exists before registering the test (system (conc "mkdir -p " new-test-path)) (register-test db run-id test-name item-path) - (set! testdat (db:get-test-info db run-id test-name item-path)))) + (set! testdat (rdb:get-test-info db run-id test-name item-path)))) (change-directory test-path) (case (if force ;; (args:get-arg "-force") 'NOT_STARTED (if testdat (string->symbol (test:get-state testdat)) @@ -487,11 +477,11 @@ (take dparts (- (length dparts) count)) "/")))) ;; Remove runs ;; fields are passing in through (define (runs:remove-runs db runnamepatt testpatt itempatt) - (let* ((keys (db-get-keys db)) + (let* ((keys (rdb:get-keys db)) (rundat (runs:get-runs-by-patt db keys runnamepatt)) (header (vector-ref rundat 0)) (runs (vector-ref rundat 1))) (debug:print 1 "Header: " header) (for-each @@ -510,11 +500,11 @@ (lambda (test) (let* ((item-path (db:test-get-item-path test)) (test-name (db:test-get-testname test)) (run-dir (db:test-get-rundir test))) (debug:print 1 " " (db:test-get-testname test) " id: " (db:test-get-id test) " " item-path) - (db:delete-test-records db (db:test-get-id test)) + (rdb:delete-test-records db (db:test-get-id test)) (if (> (string-length run-dir) 5) ;; bad heuristic but should prevent /tmp /home etc. (let ((fullpath run-dir)) ;; "/" (db:test-get-item-path test)))) (set! lasttpath fullpath) (hash-table-set! dirs-to-remove fullpath #t) ;; The following was the safe delete code but it was not being exectuted. @@ -592,11 +582,11 @@ (if (not (setup-for-run)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) (set! db (open-db)) - (set! keys (db-get-keys db)) + (set! keys (db:get-keys db)) ;; have enough to process -target or -reqtarg here (if (args:get-arg "-reqtarg") (let* ((runconfigf (conc *toppath* "/runconfigs.config")) ;; DO NOT EVALUATE ALL (runconfig (read-config runconfigf #f #f environ-patt: #f))) (if (hash-table-ref/default runconfig (args:get-arg "-reqtarg") #f) @@ -623,15 +613,15 @@ ;; Rollup runs ;;====================================================================== ;; Update the test_meta table for this test (define (runs:update-test_meta db test-name test-conf) - (let ((currrecord (db:testmeta-get-record db test-name))) + (let ((currrecord (rdb:testmeta-get-record db test-name))) (if (not currrecord) (begin (set! currrecord (make-vector 10 #f)) - (db:testmeta-add-record db test-name))) + (rdb:testmeta-add-record db test-name))) (for-each (lambda (key) (let* ((idx (cadr key)) (fld (car key)) (val (config-lookup test-conf "test_meta" fld))) Index: server.scm ================================================================== --- server.scm +++ server.scm @@ -45,10 +45,12 @@ (ipaddrstr (if (string=? "-" hostn) (string-intersperse (map number->string (u8vector->list (hostname->ip hostname))) ".") #f)) (host:port (conc (if ipaddrstr ipaddrstr hostname) ":" (rpc:default-server-port)))) (db:set-var db "SERVER" host:port) + + ;; can use this to run most anything at the remote (rpc:publish-procedure! 'remote:run (lambda (procstr . params) (server:autoremote procstr params))) @@ -90,14 +92,98 @@ 'rdb:test-set-comment (lambda (run-id test-name item-path comment) (db:test-set-comment db run-id test-name item-path comment))) (rpc:publish-procedure! - 'rpc:test-set-log! + 'rdb:test-set-log! (lambda (run-id test-name item-path logf) (db:test-set-log! db run-id test-name item-path logf))) + (rpc:publish-procedure! + 'serve:get-toppath + (lambda () + *toppath*)) + + (rpc:publish-procedure! + 'serve:login + (lambda (toppath) + (if (equal? *toppath* toppath) + (begin + (debug:print 2 "INFO: login successful") + #t) + #f))) + + (rpc:publish-procedure! + 'rdb:get-runs + (lambda (runnamepatt numruns startrunoffset keypatts) + (db:get-runs db runnamepatt numruns startrunoffset keypatts))) + + (rpc:publish-procedure! + 'rdb:get-tests-for-run + (lambda (run-id testpatt itempatt states statuses) + (db:get-tests-for-run db run-id testpatt itempatt states statuses))) + + (rpc:publish-procedure! + 'rdb:get-keys + (lambda () + (db:get-keys db))) + + (rpc:publish-procedure! + 'rdb:get-num-runs + (lambda (runpatt) + (db:get-num-runs db runpatt))) + + (rpc:publish-procedure! + 'rdb:test-set-state-status-by-id + (lambda (test-id newstate newstatus newcomment) + (db:test-set-state-status-by-id db test-id newstate newstatus newcomment))) + + (rpc:publish-procedure! + 'rdb:get-key-val-pairs + (lambda (run-id) + (db:get-key-val-pairs db run-id))) + + (rpc:publish-procedure! + 'rdb:get-key-vals + (lambda (run-id) + (db:get-key-vals db run-id))) + + (rpc:publish-procedure! + 'rdb:testmeta-get-record + (lambda (run-id) + (db:testmeta-get-record db run-id))) + + (rpc:publish-procedure! + 'rdb:get-test-data-by-id + (lambda (test-id) + (db:get-test-data-by-id db test-id))) + + (rpc:publish-procedure! + 'rdb:get-run-info + (lambda (run-id) + (db:get-run-info db run-id))) + + (rpc:publish-procedure! + 'rdb:get-steps-for-test + (lambda (test-id) + (db:get-steps-for-test db test-id))) + + (rpc:publish-procedure! + 'rdb:get-steps-table + (lambda (test-id) + (db:get-steps-table db test-id))) + + (rpc:publish-procedure! + 'rdb:read-test-data + (lambda (test-id categorypatt) + (db:read-test-data db test-id categorypatt))) + + (rpc:publish-procedure! + 'rdb:get-test-info + (lambda (run-id testname item-path) + (db:get-test-info db run-id testname item-path))) + (set! *rpc:listener* rpc:listener) (on-exit (lambda () (sqlite3:execute db "DELETE FROM metadat WHERE var='SERVER' and val=?;" host:port) (sqlite3:finalize! db))) (thread-start! th1) @@ -117,8 +203,22 @@ (hostdat (if hostinfo (string-split hostinfo ":"))) (host (if hostinfo (car hostdat))) (port (if (and hostinfo (> (length hostdat) 1))(cadr hostdat) #f))) (if (and port (string->number port)) - (debug:print 2 "INFO: Setting up to connect to host " host ":" port)) - (set! *runremote* (if port (vector host (string->number port)) #f)))) + (let ((portn (string->number port))) + (debug:print 2 "INFO: Setting up to connect to host " host ":" port) + (handle-exceptions + exn + (begin + (print "Exception: " exn) + (set! *runremote* #f)) + (if (and (not (args:get-arg "-server")) ;; no point in the server using the server using the server + ((rpc:procedure 'serve:login host portn) *toppath*)) + (begin + (debug:print 2 "INFO: Connected to " host ":" port) + (set! *runremote* (vector host portn))) + (begin + (debug:print 2 "INFO: Failed to connect to " host ":" port) + (set! *runremote* #f))))) + (debug:print 2 "INFO: no server available")))) Index: tests/Makefile ================================================================== --- tests/Makefile +++ tests/Makefile @@ -13,11 +13,11 @@ csi -b -I .. ../megatest.scm -- -runall -target ubuntu/afs/tmp :runname blah cd ../;make test make runall dashboard : - cd ../;make dboard + cd ../;make install $(BINPATH)/dboard & remove : (cd ../;make);$(MEGATEST) -remove-runs :runname $(RUN) -testpatt % -itempatt % :sysname % :fsname % :datapath %