Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -11,11 +11,11 @@ OFILES = $(SRCFILES:%.scm=%.o) GOFILES = $(GUISRCF:%.scm=%.o) HELPERS=$(addprefix $(PREFIX)/bin/,mt_laststep mt_runstep mt_ezstep) - +MTESTHASH=$(shell fsl info|grep checkout:| awk '{print $$2}') all : mtest dboard mtest: $(OFILES) megatest.o csc $(CSCOPTS) $(OFILES) megatest.o -o mtest @@ -26,10 +26,15 @@ tests.o db.o launch.o runs.o dashboard-tests.o dashboard-guimonitor.o dashboard-main.o monitor.o dashboard.o megatest.o : db_records.scm tests.o runs.o dashboard.o dashboard-tests.o dashboard-main.o : run_records.scm db.o ezsteps.o keys.o launch.o megatest.o monitor.o runs-for-ref.o runs.o tests.o : key_records.scm tests.o tasks.o dashboard-tasks.o : task_records.scm runs.o : test_records.scm +megatest.o : megatest-fossil-hash.scm + +megatest-fossil-hash.scm : $(SRCFILES) megatest.scm *_records.scm + echo "(define megatest-fossil-hash \"$(MTESTHASH)\")" > megatest-fossil-hash.new + if ! diff -q megatest-fossil-hash.new megatest-fossil-hash.scm ; then echo copying .new to .scm;cp -f megatest-fossil-hash.new megatest-fossil-hash.scm;fi $(OFILES) $(GOFILES) : common_records.scm %.o : %.scm csc $(CSCOPTS) -c $< Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -28,10 +28,11 @@ (define home (getenv "HOME")) (define user (getenv "USER")) ;; global gletches +(define *db-keys* #f) (define *configinfo* #f) (define *configdat* #f) (define *toppath* #f) (define *already-seen-runconfig-info* #f) (define *waiting-queue* (make-hash-table)) @@ -39,13 +40,20 @@ (define *globalexitstatus* 0) ;; attempt to work around possible thread issues (define *passnum* 0) ;; when running track calls to run-tests or similar (define *verbosity* 1) (define *rpc:listener* #f) ;; if set up for server communication this will hold the tcp port (define *runremote* #f) ;; if set up for server communication this will hold -(define *last-db-access* 0) ;; update when db is accessed via server -(define *target* #f) ;; cache the target here; target is keyval1/keyval2/.../keyvalN +(define *last-db-access* (current-seconds)) ;; update when db is accessed via server +(define *max-cache-size* 0) +(define *target* (make-hash-table)) ;; cache the target here; target is keyval1/keyval2/.../keyvalN +(define *keys* (make-hash-table)) ;; cache the keys here +(define *keyvals* (make-hash-table)) (define *toptest-paths* (make-hash-table)) ;; cache toptest path settings here +(define *test-paths* (make-hash-table)) ;; cache test-id to test run paths here +(define *test-ids* (make-hash-table)) ;; cache run-id, testname, and item-path => test-id +(define *test-info* (make-hash-table)) ;; cache the test info records, update the state, status, run_duration etc. from testdat.db + (define *run-info-cache* (make-hash-table)) ;; run info is stable, no need to reget (define (get-with-default val default) (let ((val (args:get-arg val))) (if val val default))) Index: configf.scm ================================================================== --- configf.scm +++ configf.scm @@ -213,16 +213,18 @@ (loop (configf:read-line inp res) curr-section-name #f #f)))) (else (debug:print 0 "ERROR: problem parsing " path ",\n \"" inl "\"") (set! var-flag #f) (loop (configf:read-line inp res) curr-section-name #f #f)))))))) -(define (find-and-read-config fname #!key (environ-patt #f)(given-toppath #f)) +;; pathenvvar will set the named var to the path of the config +(define (find-and-read-config fname #!key (environ-patt #f)(given-toppath #f)(pathenvvar #f)) (let* ((curr-dir (current-directory)) (configinfo (find-config fname toppath: given-toppath)) (toppath (car configinfo)) (configfile (cadr configinfo))) (if toppath (change-directory toppath)) + (if (and toppath pathenvvar)(setenv pathenvvar toppath)) (let ((configdat (if configfile (read-config configfile #f #t environ-patt: environ-patt) #f))) ;; (make-hash-table)))) (if toppath (change-directory curr-dir)) (list configdat toppath configfile fname)))) (define (config-lookup cfgdat section var) 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) - (rdb:test-set-state-status-by-id *db* test-id #f #f b) + (open-run-close db: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) - (rdb:test-set-state-status-by-id *db* test-id state #f #f) + (open-run-close db: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) - (rdb:test-set-state-status-by-id *db* test-id #f status #f) + (open-run-close db: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) @@ -246,33 +246,34 @@ ;;====================================================================== ;; ;;====================================================================== -(define (examine-test db test-id) ;; run-id run-key origtest) - (let* ((testdat (rdb:get-test-data-by-id db test-id)) +(define (examine-test test-id) ;; run-id run-key origtest) + (let* ((testdat (open-run-close db:get-test-info-by-id #f test-id)) (db-path (conc *toppath* "/megatest.db")) (db-mod-time 0) ;; (file-modification-time db-path)) (last-update 0) ;; (current-seconds)) - (request-update #t)) + (request-update #t) + (db #f)) (if (not testdat) (begin (debug:print 0 "ERROR: No test data found for test " test-id ", exiting") (exit 1)) (let* ((run-id (if testdat (db:test-get-run_id testdat) #f)) - (keydat (if testdat (rdb:get-key-val-pairs db run-id) #f)) - (rundat (if testdat (rdb:get-run-info db run-id) #f)) + (keydat (if testdat (open-run-close db:get-key-val-pairs db run-id) #f)) + (rundat (if testdat (open-run-close db: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 (open-run-close db:testmeta-get-record db testname))) (if tm tm (make-db:testmeta))) (make-db:testmeta))) (keystring (string-intersperse (map (lambda (keyval) @@ -297,15 +298,15 @@ (refreshdat (lambda () (let* ((curr-mod-time (file-modification-time db-path)) (need-update (or (and (> curr-mod-time db-mod-time) (> (current-seconds) (+ last-update 2))) ;; every two seconds if db touched request-update)) - (newtestdat (if need-update (rdb:get-test-data-by-id db test-id)))) + (newtestdat (if need-update (open-run-close db:get-test-info-by-id db test-id)))) (cond ((and need-update newtestdat) (set! testdat newtestdat) - (set! teststeps (rdb:get-steps-for-test db test-id)) + (set! teststeps (open-run-close db: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))) (need-update ;; if this was true and yet there is no data .... (db:test-set-testname! testdat "DEAD OR DELETED TEST")))))) @@ -400,11 +401,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 (rdb:get-steps-table db test-id)) + (comprsteps (open-run-close db:get-steps-table db test-id)) (newval (string-intersperse (append (list (format #f fmtstr "Stepname" "Start" "End" "Status" "Time" "Logfile") (format #f fmtstr "========" "=====" "===" "======" "====" "=======")) @@ -458,11 +459,11 @@ (db:test-data-get-tol x) (db:test-data-get-status x) (db:test-data-get-units x) (db:test-data-get-type x) (db:test-data-get-comment x))) - (db:read-test-data db test-id "%"))) + (open-run-close db:read-test-data db test-id "%"))) "\n"))) (if (not (equal? currval newval)) (iup:attribute-set! test-data "VALUE" newval ))))) ;; "TITLE" newval))))) test-data))) ))) Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -1,6 +1,6 @@ -k;;====================================================================== +;;====================================================================== ;; Copyright 2006-2012, Matthew Welland. ;; ;; This program is made available under the GNU GPL version 2.0 or ;; greater. See the accompanying file COPYING for details. ;; @@ -75,30 +75,30 @@ (if (not (setup-for-run)) (begin (print "Failed to find megatest.config, exiting") (exit 1))) -(define *db* (open-db)) +(define *db* #f) ;; (open-db)) ;; HACK ALERT: this is a hack, please fix. (define *read-only* (not (file-read-access? (conc *toppath* "/megatest.db")))) ;; (server:client-setup *db*) (define toplevel #f) (define dlg #f) (define max-test-num 0) -(define *keys* (rdb:get-keys *db*)) +(define *keys* (open-run-close db:get-keys *db*)) ;; (define *keys* (db: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* (rdb:get-num-runs *db* "%")) +(define *tot-run-count* (open-run-close db:get-num-runs *db* "%")) ;; (define *tot-run-count* (db:get-num-runs *db* "%")) (define *last-update* (current-seconds)) (define *num-tests* 15) (define *start-run-offset* 0) (define *start-test-offset* 0) @@ -115,14 +115,19 @@ (define *tests-sort-reverse* #f) (define *hide-empty-runs* #f) (define *verbosity* (cond - ((args:get-arg "-debug")(string->number (args:get-arg "-debug"))) + ((string? (args:get-arg "-debug"))(string->number (args:get-arg "-debug"))) ((args:get-arg "-v") 2) ((args:get-arg "-q") 0) (else 1))) + +(if (not (number? *verbosity*)) + (begin + (print "ERROR: Invalid debug value " (args:get-arg "-debug")) + (exit))) (define uidat #f) (define-inline (dboard:uidat-get-keycol vec)(vector-ref vec 0)) (define-inline (dboard:uidat-get-lftcol vec)(vector-ref vec 1)) @@ -166,11 +171,11 @@ (begin (debug:print 4 "INFO: update-rundat runnamepatt: " runnamepatt " numruns: " numruns " testnamepatt: " testnamepatt " itemnamepatt: " itemnamepatt " keypatts: " keypatts) (set! *please-update-buttons* #t) (set! *last-db-update-time* modtime) (set! *delayed-update* (- *delayed-update* 1)) - (let* ((allruns (rdb:get-runs *db* runnamepatt numruns ;; (+ numruns 1) ;; (/ numruns 2)) + (let* ((allruns (open-run-close db: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) @@ -181,13 +186,13 @@ (begin (set! *last-update* (current-seconds)) (set! *tot-run-count* (length runs)))) ;; (rdb:get-num-runs *db* runnamepatt)))) (for-each (lambda (run) (let* ((run-id (db:get-value-by-header run header "id")) - (tests (let ((tsts (rdb:get-tests-for-run *db* run-id testnamepatt itemnamepatt states statuses))) + (tests (let ((tsts (open-run-close db:get-tests-for-run *db* run-id testnamepatt itemnamepatt states statuses))) (if *tests-sort-reverse* (reverse tsts) tsts))) - (key-vals (rdb:get-key-vals *db* run-id))) + (key-vals (open-run-close db: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))))) @@ -445,11 +450,11 @@ (iup:attribute-set! obj "TITLE" (if *hide-empty-runs* "+Hide" "-Hide")) (mark-for-update))) (iup:button "Refresh" #:action (lambda (obj) (mark-for-update)))) (iup:hbox - (iup:button "Quit" #:action (lambda (obj)(sqlite3:finalize! *db*)(exit))) + (iup:button "Quit" #:action (lambda (obj)(if *db* (sqlite3:finalize! *db*))(exit))) (iup:button "Monitor" #:action (lambda (obj)(system (conc (car (argv))" -guimonitor &"))))) )) ;; (iup:button "<- Left" #:action (lambda (obj)(set! *start-run-offset* (+ *start-run-offset* 1)))) ;; (iup:button "Up ^" #:action (lambda (obj)(set! *start-test-offset* (if (> *start-test-offset* 0)(- *start-test-offset* 1) 0)))) ;; (iup:button "Down v" #:action (lambda (obj)(set! *start-test-offset* (if (>= *start-test-offset* (length *alltestnamelst*))(length *alltestnamelst*)(+ *start-test-offset* 1))))) @@ -472,11 +477,11 @@ (iup:toggle state #:action (lambda (obj val) (mark-for-update) (if (eq? val 1) (hash-table-set! *state-ignore-hash* state #t) (hash-table-delete! *state-ignore-hash* state))))) - '("RUNNING" "COMPLETED" "INCOMPLETE" "LAUNCHED" "NOT_STARTED" "KILLED"))) + '("RUNNING" "COMPLETED" "INCOMPLETE" "LAUNCHED" "NOT_STARTED" "KILLED" "DELETED"))) (iup:valuator #:valuechanged_cb (lambda (obj) (let ((val (inexact->exact (round (/ (string->number (iup:attribute obj "VALUE")) 10)))) (oldmax (string->number (iup:attribute obj "MAX"))) (maxruns *tot-run-count*)) (set! *start-run-offset* val) @@ -637,18 +642,18 @@ (if runid (begin (lambda (x) (on-exit (lambda () (sqlite3:finalize! *db*))) - (examine-run *db* runid))) + (open-run-close examine-run *db* runid))) (begin (print "ERROR: runid is not a number " (args:get-arg "-run")) (exit 1))))) ((args:get-arg "-test") (let ((testid (string->number (args:get-arg "-test")))) (if testid - (examine-test *db* testid) + (examine-test testid) (begin (print "ERROR: testid is not a number " (args:get-arg "-test")) (exit 1))))) ((args:get-arg "-guimonitor") (gui-monitor *db*)) Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -34,10 +34,28 @@ (define *incoming-data* '()) (define *incoming-last-time* (current-seconds)) (define *incoming-mutex* (make-mutex)) (define *cache-on* #f) +(define (db:set-sync db) + (let* ((syncval (config-lookup *configdat* "setup" "synchronous")) + (val (cond ;; 0 | OFF | 1 | NORMAL | 2 | FULL; + ((not syncval) #f) + ((string->number syncval) + (let ((val (string->number syncval))) + (if (member val '(0 1 2)) val #f))) + ((string-match (regexp "yes" #t) syncval) 1) + ((string-match (regexp "no" #t) syncval) 0) + ((string-match (regexp "(off|normal|full)" #t) syncval) syncval) + (else + (debug:print 0 "ERROR: synchronous must be 0,1,2,OFF,NORMAL or FULL, you provided: " syncval) + #f)))) + (if val + (begin + (debug:print 2 "INFO: Setting pragma synchronous to " val) + (sqlite3:execute db (conc "PRAGMA synchronous = '" val "';")))))) + (define (open-db) ;; (conc *toppath* "/megatest.db") (car *configinfo*))) (let* ((dbpath (conc *toppath* "/megatest.db")) ;; fname) (dbexists (file-exists? dbpath)) (db (sqlite3:open-database dbpath)) ;; (never-give-up-open-db dbpath)) (handler (make-busy-timeout (if (args:get-arg "-override-timeout") @@ -45,16 +63,61 @@ 36000)))) ;; 136000))) (debug:print 4 "INFO: dbpath=" dbpath) (sqlite3:set-busy-handler! db handler) (if (not dbexists) (db:initialize db)) - (if (config-lookup *configdat* "setup" "synchronous") - (begin - (debug:print 4 "INFO: Turning on pragma synchronous") - (sqlite3:execute db "PRAGMA synchronous = 0;")) - (debug:print 4 "INFO: NOT turning on pragma synchronous")) + (db:set-sync db) db)) + +;; keeping it around for debugging purposes only +(define (open-run-close-no-exception-handling proc idb . params) + (let* ((db (if idb idb (open-db))) + (res #f)) + (set! res (apply proc db params)) + (if (not idb)(sqlite3:finalize! db)) + res)) + +(define (open-run-close-exception-handling proc idb . params) + (let ((runner (lambda () + (let* ((db (if idb idb (open-db))) + (res #f)) + (set! res (apply proc db params)) + (if (not idb)(sqlite3:finalize! db)) + res)))) + (handle-exceptions + exn + (begin + (debug:print 0 "EXCEPTION: database probably overloaded?") + (debug:print 0 " " ((condition-property-accessor 'exn 'message) exn)) + (print-call-chain) + (thread-sleep! (random 120)) + (debug:print 0 "trying db call one more time....") + (runner)) + (runner)))) + +(define open-run-close open-run-close-exception-handling) + +(define *global-delta* 0) +(define *last-global-delta-printed* 0) + +(define (open-run-close-measure proc idb . params) + (let* ((start-ms (current-milliseconds)) + (db (if idb idb (open-db))) + (throttle (string->number (config-lookup *configdat* "setup" "throttle")))) + + (db:set-sync db) + (set! res (apply proc db params)) + (if (not idb)(sqlite3:finalize! db)) + ;; scale by 10, average with current value. + (set! *global-delta* (/ (+ *global-delta* (* (- (current-milliseconds) start-ms) + (if throttle throttle 0.01))) + 2)) + (if (> (abs (- *last-global-delta-printed* *global-delta*)) 0.08) ;; don't print all the time, only if it changes a bit + (begin + (debug:print 1 "INFO: launch throttle factor=" *global-delta*) + (set! *last-global-delta-printed* *global-delta*))) + res)) (define (db:initialize db) (let* ((configdat (car *configinfo*)) ;; tut tut, global warning... (keys (config-get-fields configdat)) (havekeys (> (length keys) 0)) @@ -68,11 +131,11 @@ (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 "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 @@ -155,10 +218,80 @@ 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) )) +;; Create the sqlite db for the individual test(s) +(define (open-test-db testpath) + (if (and (directory? testpath) + (file-read-access? testpath)) + (let* ((dbpath (conc testpath "/testdat.db")) + (dbexists (file-exists? dbpath)) + (db (sqlite3:open-database dbpath)) ;; (never-give-up-open-db dbpath)) + (handler (make-busy-timeout (if (args:get-arg "-override-timeout") + (string->number (args:get-arg "-override-timeout")) + 36000)))) + (debug:print 4 "INFO: test dbpath=" dbpath) + (sqlite3:set-busy-handler! db handler) + (if (not dbexists) + (begin + (sqlite3:execute db "PRAGMA synchronous = FULL;") + (debug:print 0 "Initialized test database " dbpath) + (db:testdb-initialize db))) + ;; (sqlite3:execute db "PRAGMA synchronous = 0;") + db) + #f)) + +;; find and open the testdat.db file for an existing test +(define (db:open-test-db-by-test-id db test-id) + (let* ((test-path (db:test-get-rundir-from-test-id db test-id))) + (open-test-db test-path))) + +(define (db:testdb-initialize db) + (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));"))) + ;;====================================================================== ;; TODO: ;; put deltas into an assoc list with version numbers ;; apply all from last to current ;;====================================================================== @@ -245,29 +378,40 @@ ;;====================================================================== ;; meta get and set vars ;;====================================================================== ;; returns number if string->number is successful, string otherwise +;; also updates *global-delta* (define (db:get-var db var) - (let ((res #f)) + (let* ((start-ms (current-milliseconds)) + (throttle (let ((t (config-lookup *configdat* "setup" "throttle"))) + (if t (string->number t) t))) + (res #f)) (sqlite3:for-each-row (lambda (val) (set! res val)) db "SELECT val FROM metadat WHERE var=?;" var) + ;; convert to number if can (if (string? res) (let ((valnum (string->number res))) - (if valnum valnum res)) - res))) + (if valnum (set! res valnum)))) + ;; scale by 10, average with current value. + (set! *global-delta* (/ (+ *global-delta* (* (- (current-milliseconds) start-ms) + (if throttle throttle 0.01))) + 2)) + (if (> (abs (- *last-global-delta-printed* *global-delta*)) 0.08) ;; don't print all the time, only if it changes a bit + (begin + (debug:print 4 "INFO: launch throttle factor=" *global-delta*) + (set! *last-global-delta-printed* *global-delta*))) + res)) (define (db:set-var db var val) (sqlite3:execute db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" var val)) ;; 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) (if *db-keys* *db-keys* (let ((res '())) (sqlite3:for-each-row (lambda (key keytype) @@ -326,17 +470,17 @@ (string-intersperse remfields ","))) (qrystr (conc "SELECT " keystr " FROM runs WHERE (" runpattstr ") " ;; runname LIKE ? " ;; Generate: " AND x LIKE 'keypatt' ..." (if (null? keypatts) "" (conc " AND " - (string-join - (map (lambda (keypatt) - (let ((key (car keypatt)) - (patt (cadr keypatt))) - (db:patt->like key patt))) - keypatts) - " AND "))) + (string-join + (map (lambda (keypatt) + (let ((key (car keypatt)) + (patt (cadr keypatt))) + (db:patt->like key patt))) + keypatts) + " AND "))) " ORDER BY event_time DESC " (if (number? count) (conc " LIMIT " count) "") (if (number? offset) @@ -380,15 +524,15 @@ (conc "SELECT " keystr " FROM runs WHERE id=?;") run-id) (let ((finalres (vector header res))) (hash-table-set! *run-info-cache* run-id finalres) finalres)))) - + (define (db:set-comment-for-run db run-id comment) (sqlite3:execute db "UPDATE runs SET comment=? WHERE id=?;" comment run-id)) -;; does not (obviously!) removed dependent data. +;; does not (obviously!) removed dependent data. But why not!!? (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)) @@ -424,36 +568,57 @@ 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))) + (let ((mykeyvals (hash-table-ref/default *keyvals* run-id #f))) + (if mykeyvals + mykeyvals + (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) + (let ((final-res (reverse res))) + (hash-table-set! *keyvals* run-id final-res) + final-res))))) ;; The target is keyval1/keyval2..., cached in *target* as it is used often (define (db:get-target db run-id) - (if *target* - *target* - (let* ((keyvals (rdb:get-key-vals db run-id)) - (thekey (string-intersperse (map (lambda (x)(if x x "-na-")) keyvals) "/"))) - (set! *target* thekey) - thekey))) + (let ((mytarg (hash-table-ref/default *target* run-id #f))) + (if mytarg + mytarg + (let* ((keyvals (db:get-key-vals db run-id)) + (thekey (string-intersperse (map (lambda (x)(if x x "-na-")) keyvals) "/"))) + (hash-table-set! *target* run-id thekey) + thekey)))) ;;====================================================================== ;; T E S T S ;;====================================================================== + +(define (db:tests-register-test db run-id test-name item-path) + (debug:print 4 "INFO: db:tests-register-test db=" db ", run-id=" run-id ", test-name=" test-name ", item-path=\"" item-path "\"") + (let ((item-paths (if (equal? item-path "") + (list item-path) + (list item-path "")))) + (for-each + (lambda (pth) + (sqlite3:execute db "INSERT OR IGNORE INTO tests (run_id,testname,event_time,item_path,state,status) VALUES (?,?,strftime('%s','now'),?,'NOT_STARTED','n/a');" + run-id + test-name + pth)) + item-paths) + #f)) + ;; 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 ;; not-in #t = above behaviour, #f = must match @@ -491,31 +656,41 @@ ;; (if itempatt itempatt "%")) ) res)) ;; this one is a bit broken BUG FIXME -(define (db:delete-test-step-records db run-id test-name itemdat) +(define (db:delete-test-step-records db test-id) ;; Breaking it into two queries for better file access interleaving - (let ((ids '())) - (sqlite3:for-each-row (lambda (id) - (set! ids (cons id ids))) - db - "SELECT id FROM tests WHERE run_id=? AND testname=? AND item_path=?;" - run-id test-name (item-list->path itemdat)) - (for-each (lambda (id) - (sqlite3:execute db "DELETE FROM test_steps WHERE test_id=?;" id) - (thread-sleep! 0.1) ;; give others access to the db - (sqlite3:execute db "DELETE FROM test_data WHERE test_id=?;" id) - (thread-sleep! 0.1)) ;; give others access to the db - ids))) -;;"DELETE FROM test_steps WHERE test_id in (SELECT id FROM tests WHERE run_id=? AND testname=? AND item_path=?);" - + (let* ((tdb (db:open-test-db-by-test-id db test-id))) + ;; test db's can go away - must check every time + (if tdb + (begin + (sqlite3:execute tdb "DELETE FROM test_steps;") + (sqlite3:execute tdb "DELETE FROM test_data;") + (sqlite3:finalize! tdb))))) + ;; -(define (db:delete-test-records db test-id) - (sqlite3:execute db "DELETE FROM test_steps WHERE test_id=?;" test-id) - (sqlite3:execute db "DELETE FROM test_data WHERE test_id=?;" test-id) - (sqlite3:execute db "DELETE FROM tests WHERE id=?;" test-id)) +(define (db:delete-test-records db tdb test-id #!key (force #f)) + (if tdb + (begin + (sqlite3:execute tdb "DELETE FROM test_steps;") + (sqlite3:execute tdb "DELETE FROM test_data;"))) + ;; (sqlite3:execute db "DELETE FROM tests WHERE id=?;" test-id)) + (if db + (begin + (sqlite3:execute db "DELETE FROM test_steps WHERE test_id=?;" test-id) + (sqlite3:execute db "DELETE FROM test_data WHERE test_id=?;" test-id) + (if force + (sqlite3:execute db "DELETE FROM tests WHERE id=?;" test-id) + (sqlite3:execute db "UPDATE tests SET state='DELETED',status='n/a' WHERE id=?;" test-id))))) + +(define (db:delete-tests-for-run db run-id) + (sqlite3:execute db "DELETE FROM tests WHERE run_id=?;" run-id)) + +(define (db:delete-old-deleted-test-records db) + (let ((targtime (- (current-seconds)(* 30 24 60 60)))) ;; one month in the past + (sqlite3:execute db "DELETE FROM tests WHERE state='DELETED' AND event_timenumber last-delete-str) #f))) + (if (and last-delete (> last-delete *last-test-cache-delete*)) + (begin + (set! *test-info* (make-hash-table)) + (set! *test-id-cache* (make-hash-table)) + (set! *last-test-cache-delete* last-delete) + (debug:print 4 "INFO: Clearing test data cache")))) + (if (not test-id) + (begin + (debug:print 4 "INFO: db:get-test-info-by-id called with test-id=" test-id) + #f) + (let* ((res (hash-table-ref/default *test-info* test-id #f))) + (if (and res + (member (db:test-get-state res) '("RUNNING" "COMPLETED"))) + (db:patch-tdb-data-into-test-info db test-id res) + ;; if no cached value then full read and write to cache + (begin + (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) + ;; 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 + (set! res (vector id run-id testname state status event-time host cpuload diskfree uname rundir item-path run_duration final_logf comment))) + db + "SELECT id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment FROM tests WHERE id=?;" + test-id) + (if res (db:patch-tdb-data-into-test-info db test-id res)) + res))))) ;; Get test data using test_id -(define (db:get-test-data-by-id db test-id) +(define (db:get-test-info-not-cached-by-id db test-id) (if (not test-id) (begin - (debug:print 0 "INFO: db:get-test-data-by-id called with test-id=" test-id) + (debug:print 4 "INFO: db:get-test-info-by-id called with test-id=" test-id) #f) (let ((res #f)) (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) + ;; 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 (set! res (vector id run-id testname state status event-time host cpuload diskfree uname rundir item-path run_duration final_logf comment))) db "SELECT id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment FROM tests WHERE id=?;" test-id) res))) +(define db:get-test-info-by-id db:get-test-info-not-cached-by-id) + +(define (db:get-test-info db run-id testname item-path) + (db:get-test-info-by-id db (db:get-test-id db run-id testname item-path))) (define (db:test-set-comment db test-id comment) (sqlite3:execute db "UPDATE tests SET comment=? WHERE id=?;" @@ -610,15 +886,36 @@ (define (db:test-set-rundir! db run-id test-name item-path rundir) (sqlite3:execute db "UPDATE tests SET rundir=? WHERE run_id=? AND testname=? AND item_path=?;" rundir run-id test-name item-path)) + +(define (db:test-set-rundir-by-test-id! db test-id rundir) + (sqlite3:execute + db + "UPDATE tests SET rundir=? WHERE id=?" + rundir test-id)) + +;; +(define (db:test-get-rundir-from-test-id db test-id) + (let ((res (hash-table-ref/default *test-paths* test-id #f))) + (if res + res + (begin + (sqlite3:for-each-row + (lambda (tpath) + (set! res tpath)) + db + "SELECT rundir FROM tests WHERE id=?;" + test-id) + (hash-table-set! *test-paths* test-id res) + res)))) (define (db:test-set-log! db test-id logf) (if (string? logf) (sqlite3:execute db "UPDATE tests SET final_logf=? WHERE id=?;" - logf test-id) + logf test-id) (debug:print 0 "ERROR: db:test-set-log! called with non-string log file name " logf))) ;;====================================================================== ;; Misc. test related queries ;;====================================================================== @@ -725,55 +1022,146 @@ ;;====================================================================== ;; QUEUE UP META, TEST STATUS AND STEPS ;;====================================================================== -(define (db:updater db) +(define (db:updater) + (debug:print 4 "INFO: Starting cache processing") (let loop ((start-time (current-time))) - (thread-sleep! 0.5) ;; move save time around to minimize regular collisions? - (db:write-cached-data db) + (thread-sleep! 5) ;; move save time around to minimize regular collisions? + (db:write-cached-data) (loop start-time))) - -(define (db:test-update-meta-info db test-id minutes cpuload diskfree tmpfree) + +(define (cdb:test-set-status-state test-id status state msg) + (debug:print 4 "INFO: cdb:test-set-status-state test-id=" test-id ", status=" status ", state=" state ", msg=" msg) + (mutex-lock! *incoming-mutex*) + (set! *last-db-access* (current-seconds)) + (if msg + (set! *incoming-data* (cons (vector 'state-status-msg + (current-milliseconds) + (list state status msg test-id)) + *incoming-data*)) + (set! *incoming-data* (cons (vector 'state-status + (current-milliseconds) + (list state status test-id)) ;; run-id test-name item-path minutes cpuload diskfree tmpfree) + *incoming-data*))) + (mutex-unlock! *incoming-mutex*) + (if *cache-on* + (debug:print 6 "INFO: *cache-on* is " *cache-on* ", skipping cache write") + (db:write-cached-data))) + +(define (cdb:test-rollup-test_data-pass-fail test-id) + (debug:print 4 "INFO: Adding " test-id " for test_data rollup to the queue") + (mutex-lock! *incoming-mutex*) + (set! *last-db-access* (current-seconds)) + (set! *incoming-data* (cons (vector 'test_data-pf-rollup + (current-milliseconds) + (list test-id test-id test-id test-id)) + *incoming-data*)) + (mutex-unlock! *incoming-mutex*) + (if *cache-on* + (debug:print 6 "INFO: *cache-on* is " *cache-on* ", skipping cache write") + (db:write-cached-data))) + +(define (cdb:pass-fail-counts test-id fail-count pass-count) + (debug:print 4 "INFO: Adding " test-id " for setting pass/fail counts to the queue") (mutex-lock! *incoming-mutex*) - (set! *incoming-data* (cons (vector 'meta-info - (current-seconds) - (list cpuload - diskfree - minutes - test-id)) ;; run-id test-name item-path minutes cpuload diskfree tmpfree) + (set! *last-db-access* (current-seconds)) + (set! *incoming-data* (cons (vector 'pass-fail-counts + (current-milliseconds) + (list fail-count pass-count test-id)) *incoming-data*)) (mutex-unlock! *incoming-mutex*) (if *cache-on* - (debug:print 6 "INFO: *cache-on* is " *cache-on* ", skipping cache write as part of test-update-meta-info") - (db:write-cached-data db))) - -(define (db:write-cached-data db) - (let ((meta-stmt (sqlite3:prepare db "UPDATE tests SET cpuload=?,diskfree=?,run_duration=?,state='RUNNING' WHERE id=? AND state NOT IN ('COMPLETED','KILLREQ','KILLED');")) - (step-stmt (sqlite3:prepare db "INSERT OR REPLACE into test_steps (test_id,stepname,state,status,event_time,comment,logfile) VALUES(?,?,?,?,?,?,?);")) ;; strftime('%s','now')#f) - (data (sort *incoming-data* (lambda (a b)(< (vector-ref a 1)(vector-ref b 1)))))) - (if (> (length data) 0) - (debug:print 4 "Writing cached data " data)) + (debug:print 6 "INFO: *cache-on* is " *cache-on* ", skipping cache write") + (db:write-cached-data))) + +(define (cdb:tests-register-test db run-id test-name item-path #!key (force-write #f)) + (let ((item-paths (if (equal? item-path "") + (list item-path) + (list item-path "")))) + (debug:print 4 "INFO: Adding " run-id ", " test-name "/" item-path " for setting pass/fail counts to the queue") (mutex-lock! *incoming-mutex*) - (sqlite3:with-transaction - db - (lambda () - (for-each (lambda (entry) - (case (vector-ref entry 0) - ((meta-info) - (apply sqlite3:execute meta-stmt (vector-ref entry 2))) - ((step-status) - (apply sqlite3:execute step-stmt (vector-ref entry 2))) - (else - (debug:print 0 "ERROR: Queued entry not recognised " entry)))) - data))) - (sqlite3:finalize! meta-stmt) ;; sqlite is the bottleneck, clear the statements asap? - (sqlite3:finalize! step-stmt) - (set! *incoming-data* '()) - (mutex-unlock! *incoming-mutex*))) + (set! *last-db-access* (current-seconds)) + (set! *incoming-data* (cons (vector 'register-test + (current-milliseconds) + (list run-id test-name item-path)) ;; fail-count pass-count test-id)) + *incoming-data*)) + (mutex-unlock! *incoming-mutex*) + (if (and (not force-write) *cache-on*) + (debug:print 6 "INFO: *cache-on* is " *cache-on* ", skipping cache write") + (db:write-cached-data)))) + +;; The queue is a list of vectors where the zeroth slot indicates the type of query to +;; apply and the second slot is the time of the query and the third entry is a list of +;; values to be applied +;; +(define (db:write-cached-data) + (open-run-close + (lambda (db . params) + (let ((register-test-stmt (sqlite3:prepare db "INSERT OR IGNORE INTO tests (run_id,testname,event_time,item_path,state,status) VALUES (?,?,strftime('%s','now'),?,'NOT_STARTED','n/a');")) + (state-status-stmt (sqlite3:prepare db "UPDATE tests SET state=?,status=? WHERE id=?;")) + (state-status-msg-stmt (sqlite3:prepare db "UPDATE tests SET state=?,status=?,comment=? WHERE id=?;")) + (pass-fail-counts-stmt (sqlite3:prepare db "UPDATE tests SET fail_count=?,pass_count=? WHERE id=?;")) + (test_data-rollup-stmt (sqlite3:prepare db "UPDATE tests + SET status=CASE WHEN (SELECT fail_count FROM tests WHERE id=?) > 0 + THEN 'FAIL' + WHEN (SELECT pass_count FROM tests WHERE id=?) > 0 AND + (SELECT status FROM tests WHERE id=?) NOT IN ('WARN','FAIL') + THEN 'PASS' + ELSE status + END WHERE id=?;")) + (data #f) + (rollups (make-hash-table))) + (mutex-lock! *incoming-mutex*) + (set! data (sort *incoming-data* (lambda (a b)(< (vector-ref a 1)(vector-ref b 1))))) + (set! *incoming-data* '()) + (mutex-unlock! *incoming-mutex*) + (if (> (length data) 0) + (debug:print 4 "INFO: Writing cached data " data)) + (sqlite3:with-transaction + db + (lambda () + (debug:print 4 "INFO: flushing " data " to db") + (for-each (lambda (entry) + (let ((params (vector-ref entry 2))) + (debug:print 4 "INFO: Applying " entry " to params " params) + (case (vector-ref entry 0) + ((state-status) + (apply sqlite3:execute state-status-stmt params)) + ((state-status-msg) + (apply sqlite3:execute state-status-msg-stmt params)) + ((test_data-pf-rollup) + ;; (hash-table-set! rollups (car params) params)) + (apply sqlite3:execute test_data-rollup-stmt params)) + ((pass-fail-counts) + (apply sqlite3:execute pass-fail-counts-stmt params)) + ((register-test) + (apply sqlite3:execute register-test-stmt params)) + (else + (debug:print 0 "ERROR: Queued entry not recognised " entry))))) + data))) + ;; now do any rollups + ;; (for-each + ;; (lambda (test-id) + ;; (apply sqlite3:execute test_data-rollup-stmt (hash-table-ref rollups test-id))) + ;; (hash-table-keys rollups)) + (sqlite3:finalize! state-status-stmt) + (sqlite3:finalize! state-status-msg-stmt) + (sqlite3:finalize! test_data-rollup-stmt) + (sqlite3:finalize! pass-fail-counts-stmt) + (sqlite3:finalize! register-test-stmt) + (let ((cache-size (length data))) + (if (> cache-size *max-cache-size*) + (set! *max-cache-size* cache-size))) + )) + #f)) + +(define cdb:flush-queue db:write-cached-data) (define (db:roll-up-pass-fail-counts db run-id test-name item-path status) + (rdb:flush-queue) (if (and (not (equal? item-path "")) (or (equal? status "PASS") (equal? status "WARN") (equal? status "FAIL") (equal? status "WAIVED") @@ -784,11 +1172,11 @@ "UPDATE tests SET fail_count=(SELECT count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND status='FAIL'), pass_count=(SELECT count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND (status='PASS' OR status='WARN' OR status='WAIVED')) WHERE run_id=? AND testname=? AND item_path='';" run-id test-name run-id test-name run-id test-name) - (thread-sleep! 0.1) ;; give other processes a chance here + ;; (thread-sleep! 0.1) ;; give other processes a chance here, no, better to be done ASAP? (if (equal? status "RUNNING") ;; running takes priority over all other states, force the test state to RUNNING (sqlite3:execute db "UPDATE tests SET state=? WHERE run_id=? AND testname=? AND item_path='';" "RUNNING" run-id test-name) (sqlite3:execute db "UPDATE tests @@ -798,11 +1186,10 @@ status=CASE WHEN fail_count > 0 THEN 'FAIL' WHEN pass_count > 0 AND fail_count=0 THEN 'PASS' ELSE 'UNKNOWN' END WHERE run_id=? AND testname=? AND item_path='';" run-id test-name run-id test-name)) #f) #f)) - ;;====================================================================== ;; Tests meta data ;;====================================================================== @@ -828,112 +1215,135 @@ ;; T E S T D A T A ;;====================================================================== (define (db:csv->test-data db test-id csvdata) (debug:print 4 "test-id " test-id ", csvdata: " csvdata) - (let ((csvlist (csv->list (make-csv-reader - (open-input-string csvdata) - '((strip-leading-whitespace? #t) - (strip-trailing-whitespace? #t)) )))) ;; (csv->list csvdata))) - (for-each - (lambda (csvrow) - (let* ((padded-row (take (append csvrow (list #f #f #f #f #f #f #f #f #f)) 9)) - (category (list-ref padded-row 0)) - (variable (list-ref padded-row 1)) - (value (any->number-if-possible (list-ref padded-row 2))) - (expected (any->number-if-possible (list-ref padded-row 3))) - (tol (any->number-if-possible (list-ref padded-row 4))) ;; >, <, >=, <=, or a number - (units (list-ref padded-row 5)) - (comment (list-ref padded-row 6)) - (status (let ((s (list-ref padded-row 7))) - (if (and (string? s)(or (string-match (regexp "^\\s*$") s) - (string-match (regexp "^n/a$") s))) - #f - s))) ;; if specified on the input then use, else calculate - (type (list-ref padded-row 8))) - ;; look up expected,tol,units from previous best fit test if they are all either #f or '' - (debug:print 4 "BEFORE: category: " category " variable: " variable " value: " value - ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment " type: " type) - - (if (and (or (not expected)(equal? expected "")) - (or (not tol) (equal? expected "")) - (or (not units) (equal? expected ""))) - (let-values (((new-expected new-tol new-units)(db:get-prev-tol-for-test db test-id category variable))) - (set! expected new-expected) - (set! tol new-tol) - (set! units new-units))) - - (debug:print 4 "AFTER: category: " category " variable: " variable " value: " value - ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment) - ;; calculate status if NOT specified - (if (and (not status)(number? expected)(number? value)) ;; need expected and value to be numbers - (if (number? tol) ;; if tol is a number then we do the standard comparison - (let* ((max-val (+ expected tol)) - (min-val (- expected tol)) - (result (and (>= value min-val)(<= value max-val)))) - (debug:print 4 "max-val: " max-val " min-val: " min-val " result: " result) - (set! status (if result "pass" "fail"))) - (set! status ;; NB// need to assess each one (i.e. not return operator since need to act if not valid op. - (case (string->symbol tol) ;; tol should be >, <, >=, <= - ((>) (if (> value expected) "pass" "fail")) - ((<) (if (< value expected) "pass" "fail")) - ((>=) (if (>= value expected) "pass" "fail")) - ((<=) (if (<= value expected) "pass" "fail")) - (else (conc "ERROR: bad tol comparator " tol)))))) - (debug:print 4 "AFTER2: category: " category " variable: " variable " value: " value - ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment) - (sqlite3:execute db "INSERT OR REPLACE INTO test_data (test_id,category,variable,value,expected,tol,units,comment,status,type) VALUES (?,?,?,?,?,?,?,?,?,?);" - test-id category variable value expected tol units (if comment comment "") status type))) - csvlist))) + (let ((tdb (db:open-test-db-by-test-id db test-id))) + (if tdb + (let ((csvlist (csv->list (make-csv-reader + (open-input-string csvdata) + '((strip-leading-whitespace? #t) + (strip-trailing-whitespace? #t)) )))) ;; (csv->list csvdata))) + (for-each + (lambda (csvrow) + (let* ((padded-row (take (append csvrow (list #f #f #f #f #f #f #f #f #f)) 9)) + (category (list-ref padded-row 0)) + (variable (list-ref padded-row 1)) + (value (any->number-if-possible (list-ref padded-row 2))) + (expected (any->number-if-possible (list-ref padded-row 3))) + (tol (any->number-if-possible (list-ref padded-row 4))) ;; >, <, >=, <=, or a number + (units (list-ref padded-row 5)) + (comment (list-ref padded-row 6)) + (status (let ((s (list-ref padded-row 7))) + (if (and (string? s)(or (string-match (regexp "^\\s*$") s) + (string-match (regexp "^n/a$") s))) + #f + s))) ;; if specified on the input then use, else calculate + (type (list-ref padded-row 8))) + ;; look up expected,tol,units from previous best fit test if they are all either #f or '' + (debug:print 4 "BEFORE: category: " category " variable: " variable " value: " value + ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment " type: " type) + + (if (and (or (not expected)(equal? expected "")) + (or (not tol) (equal? expected "")) + (or (not units) (equal? expected ""))) + (let-values (((new-expected new-tol new-units)(db:get-prev-tol-for-test db test-id category variable))) + (set! expected new-expected) + (set! tol new-tol) + (set! units new-units))) + + (debug:print 4 "AFTER: category: " category " variable: " variable " value: " value + ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment) + ;; calculate status if NOT specified + (if (and (not status)(number? expected)(number? value)) ;; need expected and value to be numbers + (if (number? tol) ;; if tol is a number then we do the standard comparison + (let* ((max-val (+ expected tol)) + (min-val (- expected tol)) + (result (and (>= value min-val)(<= value max-val)))) + (debug:print 4 "max-val: " max-val " min-val: " min-val " result: " result) + (set! status (if result "pass" "fail"))) + (set! status ;; NB// need to assess each one (i.e. not return operator since need to act if not valid op. + (case (string->symbol tol) ;; tol should be >, <, >=, <= + ((>) (if (> value expected) "pass" "fail")) + ((<) (if (< value expected) "pass" "fail")) + ((>=) (if (>= value expected) "pass" "fail")) + ((<=) (if (<= value expected) "pass" "fail")) + (else (conc "ERROR: bad tol comparator " tol)))))) + (debug:print 4 "AFTER2: category: " category " variable: " variable " value: " value + ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment) + (sqlite3:execute tdb "INSERT OR REPLACE INTO test_data (test_id,category,variable,value,expected,tol,units,comment,status,type) VALUES (?,?,?,?,?,?,?,?,?,?);" + test-id category variable value expected tol units (if comment comment "") status type) + (sqlite3:finalize! tdb))) + csvlist))))) ;; get a list of test_data records matching categorypatt (define (db:read-test-data db 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))) - db - "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) - (reverse res))) + (let ((tdb (db:open-test-db-by-test-id db test-id))) + (if 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)) + '()))) (define (db:load-test-data db test-id) (let loop ((lin (read-line))) (if (not (eof-object? lin)) (begin (debug:print 4 lin) - (rdb:csv->test-data db test-id lin) + (db:csv->test-data db test-id lin) (loop (read-line))))) ;; roll up the current results. ;; FIXME: Add the status to - (rdb:test-data-rollup db test-id #f)) + (db:test-data-rollup db test-id #f)) ;; WARNING: Do NOT call this for the parent test on an iterated test ;; Roll up test_data pass/fail results ;; look at the test_data status field, ;; if all are pass (any case) and the test status is PASS or NULL or '' then set test status to PASS. ;; if one or more are fail (any case) then set test status to PASS, non "pass" or "fail" are ignored (define (db:test-data-rollup db test-id status) - (sqlite3:execute - db - "UPDATE tests - SET fail_count=(SELECT count(id) FROM test_data WHERE test_id=? AND status like 'fail'), - pass_count=(SELECT count(id) FROM test_data WHERE test_id=? AND status like 'pass') - WHERE id=?;" - test-id test-id test-id) - ;; if the test is not FAIL then set status based on the fail and pass counts. - (thread-sleep! 1) - (sqlite3:execute - db ;;; NOTE: Should this be WARN,FAIL? A WARN is not a FAIL????? BUG FIXME - "UPDATE tests - SET status=CASE WHEN (SELECT fail_count FROM tests WHERE id=?) > 0 - THEN 'FAIL' - WHEN (SELECT pass_count FROM tests WHERE id=?) > 0 AND - (SELECT status FROM tests WHERE id=?) NOT IN ('WARN','FAIL') - THEN 'PASS' - ELSE status - END WHERE id=?;" - test-id test-id test-id test-id)) + (let ((tdb (open-run-close db:open-test-db-by-test-id db test-id)) + (fail-count 0) + (pass-count 0)) + (if tdb + (begin + (sqlite3:for-each-row + (lambda (fcount pcount) + (set! fail-count fcount) + (set! pass-count pcount)) + tdb + "SELECT (SELECT count(id) FROM test_data WHERE test_id=? AND status like 'fail') AS fail_count, + (SELECT count(id) FROM test_data WHERE test_id=? AND status like 'pass') AS pass_count;" + test-id test-id) + (sqlite3:finalize! tdb) + + ;; Now rollup the counts to the central megatest.db + (rdb:pass-fail-counts test-id fail-count pass-count) + ;; (sqlite3:execute db "UPDATE tests SET fail_count=?,pass_count=? WHERE id=?;" + ;; fail-count pass-count test-id) + + (thread-sleep! 10) ;; play nice with the queue by ensuring the rollup is at least 10s later than the set + + ;; if the test is not FAIL then set status based on the fail and pass counts. + (rdb:test-rollup-test_data-pass-fail test-id) + ;; (sqlite3:execute + ;; db ;;; NOTE: Should this be WARN,FAIL? A WARN is not a FAIL????? BUG FIXME + ;; "UPDATE tests + ;; SET status=CASE WHEN (SELECT fail_count FROM tests WHERE id=?) > 0 + ;; THEN 'FAIL' + ;; WHEN (SELECT pass_count FROM tests WHERE id=?) > 0 AND + ;; (SELECT status FROM tests WHERE id=?) NOT IN ('WARN','FAIL') + ;; THEN 'PASS' + ;; ELSE status + ;; END WHERE id=?;" + ;; test-id test-id test-id test-id) + )))) (define (db:get-prev-tol-for-test db test-id category variable) ;; Finish me? (values #f #f #f)) @@ -944,18 +1354,23 @@ (define (db:step-get-time-as-string vec) (seconds->time-string (db:step-get-event_time vec))) ;; db-get-test-steps-for-run (define (db:get-steps-for-test db test-id) - (let ((res '())) - (sqlite3:for-each-row - (lambda (id test-id stepname state status event-time logfile) - (set! res (cons (vector id test-id stepname state status event-time (if (string? logfile) logfile "")) res))) - db - "SELECT id,test_id,stepname,state,status,event_time,logfile FROM test_steps WHERE test_id=? ORDER BY id ASC;" ;; event_time DESC,id ASC; - test-id) - (reverse res))) + (let* ((tdb (db:open-test-db-by-test-id db test-id)) + (res '())) + (if tdb + (begin + (sqlite3:for-each-row + (lambda (id test-id stepname state status event-time logfile) + (set! res (cons (vector id test-id stepname state status event-time (if (string? logfile) logfile "")) res))) + tdb + "SELECT id,test_id,stepname,state,status,event_time,logfile FROM test_steps WHERE test_id=? ORDER BY id ASC;" ;; event_time DESC,id ASC; + test-id) + (sqlite3:finalize! tdb) + (reverse res)) + '()))) ;; get a pretty table to summarize steps ;; (define (db:get-steps-table db test-id) (let ((steps (db:get-steps-for-test db test-id))) @@ -1020,10 +1435,11 @@ ;; 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 ;; Note: mode 'normal means that tests must be COMPLETED and ok (i.e. PASS, WARN, CHECK or WAIVED) ;; mode 'toplevel means that tests must be COMPLETED only +;; mode 'itemmatch means that tests items must be COMPLETED and (PASS|WARN|WAIVED|CHECK) [[ NB// NOT IMPLEMENTED YET ]] ;; (define (db:get-prereqs-not-met db run-id waitons ref-item-path #!key (mode 'normal)) (if (or (not waitons) (null? waitons)) '() @@ -1031,11 +1447,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 (rdb:get-tests-for-run db run-id waitontest-name #f '() '())) + (let ((tests (db: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) @@ -1062,29 +1478,30 @@ (set! result (append (if (null? tests) (list waitontest-name) tests) result))) ;; if the test is not found then clearly the waiton is not met... ;; (if (not ever-seen)(set! result (cons waitontest-name result))))) (if (not ever-seen) (set! result (append (if (null? tests)(list waitontest-name) tests) result))))) - waitons) - (delete-duplicates result)))) + waitons) + (delete-duplicates result)))) -(define (db:teststep-set-status! db test-id teststep-name state-in status-in item-path comment logfile) +(define (db:teststep-set-status! db test-id teststep-name state-in status-in comment logfile) (debug:print 4 "test-id: " test-id " teststep-name: " teststep-name) - (let* ((state (check-valid-items "state" state-in)) + (let* ((tdb (db:open-test-db-by-test-id db test-id)) + (state (check-valid-items "state" state-in)) (status (check-valid-items "status" status-in))) (if (or (not state)(not status)) (debug:print 0 "WARNING: Invalid " (if status "status" "state") " value \"" (if status state-in status-in) "\", update your validvalues section in megatest.config")) - (mutex-lock! *incoming-mutex*) - (set! *incoming-data* (cons (vector 'step-status - (current-seconds) - ;; FIXME - this should not update the logfile unless it is specified. - (list test-id teststep-name state-in status-in (current-seconds) (if comment comment "") (if logfile logfile ""))) - *incoming-data*)) - (mutex-unlock! *incoming-mutex*) - (if (not *cache-on*)(db:write-cached-data db)) - #t)) + (if tdb + (begin + (sqlite3:execute + tdb + "INSERT OR REPLACE into test_steps (test_id,stepname,state,status,event_time,comment,logfile) VALUES(?,?,?,?,?,?,?);" + test-id teststep-name state-in status-in (current-seconds) (if comment comment "") (if logfile logfile "")) + (sqlite3:finalize! tdb) + #t) + #f))) ;;====================================================================== ;; Extract ods file from the db ;;====================================================================== @@ -1212,203 +1629,55 @@ ;;====================================================================== ;; REMOTE DB ACCESS VIA RPC ;;====================================================================== -(define (rdb:set-tests-state-status db run-id testnames currstate currstatus newstate newstatus) - (if *runremote* - (let ((host (vector-ref *runremote* 0)) - (port (vector-ref *runremote* 1))) - ((rpc:procedure 'rdb:set-tests-state-status host port) - run-id testnames currstate currstatus newstate newstatus)) - (db:set-tests-state-status db run-id testnames currstate currstatus newstate newstatus))) - -(define (rdb:teststep-set-status! db test-id teststep-name state-in status-in itemdat comment logfile) - (let ((item-path (item-list->path itemdat))) - (if *runremote* - (let ((host (vector-ref *runremote* 0)) - (port (vector-ref *runremote* 1))) - ((rpc:procedure 'rdb:teststep-set-status! host port) - test-id teststep-name state-in status-in item-path comment logfile)) - (db:teststep-set-status! db test-id teststep-name state-in status-in item-path comment logfile)))) - -(define (rdb:test-update-meta-info db test-id minutes cpuload diskfree tmpfree) - (if *runremote* - (let ((host (vector-ref *runremote* 0)) - (port (vector-ref *runremote* 1))) - ((rpc:procedure 'rdb:test-update-meta-info host port) - test-id minutes cpuload diskfree tmpfree)) - (db:test-update-meta-info db test-id minutes cpuload diskfree tmpfree))) - -(define (rdb:test-set-state-status-by-run-id-testname db run-id test-name item-path status state) - (if *runremote* - (let ((host (vector-ref *runremote* 0)) - (port (vector-ref *runremote* 1))) - ((rpc:procedure 'rdb:test-set-state-status-by-run-id-testname host port) - run-id test-name item-path status state)) - (db:test-set-state-status-by-run-id-testname db run-id test-name item-path status state))) - -(define (rdb:csv->test-data db test-id csvdata) - (if *runremote* - (let ((host (vector-ref *runremote* 0)) - (port (vector-ref *runremote* 1))) - ((rpc:procedure 'rdb:csv->test-data host port) - test-id csvdata)) - (db:csv->test-data db test-id csvdata))) - -(define (rdb:roll-up-pass-fail-counts db run-id test-name item-path status) - (if *runremote* - (let ((host (vector-ref *runremote* 0)) - (port (vector-ref *runremote* 1))) - ((rpc:procedure 'rdb:roll-up-pass-fail-counts host port) - run-id test-name item-path status)) - (db:roll-up-pass-fail-counts db run-id test-name item-path status))) - -(define (rdb:test-set-comment db test-id comment) - (if *runremote* - (let ((host (vector-ref *runremote* 0)) - (port (vector-ref *runremote* 1))) - ((rpc:procedure 'rdb:test-set-comment host port) - test-id comment)) - (db:test-set-comment db test-id comment))) - -(define (rdb:test-set-log! db test-id logf) - (if *runremote* - (let ((host (vector-ref *runremote* 0)) - (port (vector-ref *runremote* 1))) - ((rpc:procedure 'rdb:test-set-log! host port) test-id logf)) - (db:test-set-log! db test-id 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 #!key (not-in #t)) - (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 not-in: not-in)) - (db:get-tests-for-run db run-id testpatt itempatt states statuses not-in: not-in))) - -(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 'rpc:get-test-data-by-id host port) - test-id)) - (db:get-test-data-by-id db test-id))) - -(define (rdb:get-keys db) - (if *runremote* - (let ((host (vector-ref *runremote* 0)) - (port (vector-ref *runremote* 1))) - (if *db-keys* *db-keys* - (let ((keys ((rpc:procedure 'rdb:get-keys host port)))) - (set! *db-keys* keys) - keys))) - (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 db 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 db 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 db 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))) - -(define (rdb:delete-test-records db test-id) - (if *runremote* - (let ((host (vector-ref *runremote* 0)) - (port (vector-ref *runremote* 1))) - ((rpc:procedure 'rdb:delete-test-records host port) test-id)) - (db:delete-test-records db test-id))) - -(define (rdb:test-data-rollup db test-id status) - (if *runremote* - (let ((host (vector-ref *runremote* 0)) - (port (vector-ref *runremote* 1))) - ((rpc:procedure 'rdb:test-data-rollup host port) test-id status)) - (db:test-data-rollup db test-id status))) - -(define (rdb:test-get-paths-matching db keynames target fname) - (if *runremote* - (let ((host (vector-ref *runremote* 0)) - (port (vector-ref *runremote* 1))) - ((rpc:procedure 'rdb:test-get-paths-matching host port) keynames target fname)) - (db:test-get-paths-matching db keynames target fname))) - - +(define (rdb:open-run-close procname . remargs) + (if *runremote* + (let ((host (vector-ref *runremote* 0)) + (port (vector-ref *runremote* 1))) + (apply (rpc:procedure 'rdb:open-run-close host port) procname remargs)) + (apply open-run-close (eval procname) remargs))) + +(define (rdb:test-set-status-state test-id status state msg) + (if *runremote* + (let ((host (vector-ref *runremote* 0)) + (port (vector-ref *runremote* 1))) + (handle-exceptions + exn + (begin + (debug:print 0 "EXCEPTION: rpc call failed?") + (debug:print 0 " " ((condition-property-accessor 'exn 'message) exn)) + (print-call-chain) + (cdb:test-set-status-state test-id status state msg)) + ((rpc:procedure 'cdb:test-set-status-state host port) test-id status state msg))) + (cdb:test-set-status-state test-id status state msg))) + +(define (rdb:test-rollup-test_data-pass-fail test-id) + (if *runremote* + (let ((host (vector-ref *runremote* 0)) + (port (vector-ref *runremote* 1))) + ((rpc:procedure 'cdb:test-rollup-test_data-pass-fail host port) test-id)) + (cdb:test-rollup-test_data-pass-fail test-id))) + +(define (rdb:pass-fail-counts test-id fail-count pass-count) + (if *runremote* + (let ((host (vector-ref *runremote* 0)) + (port (vector-ref *runremote* 1))) + ((rpc:procedure 'cdb:pass-fail-counts host port) test-id fail-count pass-count)) + (cdb:pass-fail-counts test-id fail-count pass-count))) + +;; currently forces a flush of the queue +(define (rdb:tests-register-test db run-id test-name item-path) + (if *runremote* + (let ((host (vector-ref *runremote* 0)) + (port (vector-ref *runremote* 1))) + ((rpc:procedure 'cdb:tests-register-test host port) db run-id test-name item-path force-write: #t)) + (cdb:tests-register-test db run-id test-name item-path force-write: #t))) + +(define (rdb:flush-queue) + (if *runremote* + (let ((host (vector-ref *runremote* 0)) + (port (vector-ref *runremote* 1))) + ((rpc:procedure 'cdb:flush-queue host port))) + (cdb:flush-queue))) + Index: db_records.scm ================================================================== --- db_records.scm +++ db_records.scm @@ -14,20 +14,21 @@ (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-fullname vec) (conc (db:test-get-testname vec) "/" (db:test-get-item-path vec))) -;; (define-inline (db:test-get-value vec) (printable (vector-ref vec 15))) -;; (define-inline (db:test-get-expected_value vec)(printable (vector-ref vec 16))) -;; (define-inline (db:test-get-tol vec) (printable (vector-ref vec 17))) -;; (define-inline (db:test-get-units vec) (printable (vector-ref vec 15))) ;; 18))) -(define-inline (db:test-get-first_err vec) (printable (vector-ref vec 15))) ;; 19))) -(define-inline (db:test-get-first_warn vec) (printable (vector-ref vec 16))) ;; 20))) + +(define-inline (db:test-get-first_err vec) (printable (vector-ref vec 15))) +(define-inline (db:test-get-first_warn vec) (printable (vector-ref vec 16))) +(define-inline (db:test-set-cpuload! vec val)(vector-set! vec 7 val)) +(define-inline (db:test-set-diskfree! vec val)(vector-set! vec 8 val)) (define-inline (db:test-set-testname! vec val)(vector-set! vec 2 val)) (define-inline (db:test-set-state! vec val)(vector-set! vec 3 val)) (define-inline (db:test-set-status! vec val)(vector-set! vec 4 val)) +(define-inline (db:test-set-run_duration! vec val)(vector-set! vec 12 val)) +(define-inline (db:test-set-final_logf! vec val)(vector-set! vec 13 val)) ;; get rows and header from (define-inline (db:get-header vec)(vector-ref vec 0)) (define-inline (db:get-rows vec)(vector-ref vec 1)) @@ -66,10 +67,22 @@ (define-inline (db:test-data-get-tol vec) (vector-ref vec 6)) (define-inline (db:test-data-get-units vec) (vector-ref vec 7)) (define-inline (db:test-data-get-comment vec) (vector-ref vec 8)) (define-inline (db:test-data-get-status vec) (vector-ref vec 9)) (define-inline (db:test-data-get-type vec) (vector-ref vec 10)) + +(define-inline (db:test-data-set-id! vec val)(vector-set! vec 0 val)) +(define-inline (db:test-data-set-test_id! vec val)(vector-set! vec 1 val)) +(define-inline (db:test-data-set-category! vec val)(vector-set! vec 2 val)) +(define-inline (db:test-data-set-variable! vec val)(vector-set! vec 3 val)) +(define-inline (db:test-data-set-value! vec val)(vector-set! vec 4 val)) +(define-inline (db:test-data-set-expected! vec val)(vector-set! vec 5 val)) +(define-inline (db:test-data-set-tol! vec val)(vector-set! vec 6 val)) +(define-inline (db:test-data-set-units! vec val)(vector-set! vec 7 val)) +(define-inline (db:test-data-set-comment! vec val)(vector-set! vec 8 val)) +(define-inline (db:test-data-set-status! vec val)(vector-set! vec 9 val)) +(define-inline (db:test-data-set-type! vec val)(vector-set! vec 10 val)) ;;====================================================================== ;; S T E P S ;;====================================================================== ;; Run steps ADDED docs/plan.txt Index: docs/plan.txt ================================================================== --- /dev/null +++ docs/plan.txt @@ -0,0 +1,13 @@ + +Move test specific db to test dir +================================= + +. Create teststats.db +. Redirect test run stats to teststats.db +. Redirect test steps data to teststats.db +. Redirect test_data to teststats.db +. Direct dboard to get stats from teststats.db +. Redirect kill requests to teststats.db +. Kill requests need to kill all processes in the tree +. Roll up overall stats to megatest.db every five minutes or when test done +. Add any necessary tests Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -40,16 +40,23 @@ ;; given an exit code and whether or not logpro was used calculate OK/BAD ;; return #t if we are ok, #f otherwise (define (steprun-good? logpro exitcode) (or (eq? exitcode 0) (and logpro (eq? exitcode 2)))) + +;; if handed a string, process it, else look for MT_CMDINFO +(define (launch:get-cmdinfo-assoc-list #!key (encoded-cmd #f)) + (let ((enccmd (if encoded-cmd encoded-cmd (getenv "MT_CMDINFO")))) + (if enccdm + (read (open-input-string (base64:base64-decode enccmd))) + '()))) (define (launch:execute encoded-cmd) (let* ((cmdinfo (read (open-input-string (base64:base64-decode encoded-cmd))))) (setenv "MT_CMDINFO" encoded-cmd) (if (list? cmdinfo) ;; ((testpath /tmp/mrwellan/jazzmind/src/example_run/tests/sqlitespeed) - ;; (test-name sqlitespeed) (runscript runscript.rb) (db-host localhost) (run-id 1)) + ;; (test-name sqlitespeed) (runscript runscript.rb) (db-host localhost) (run-id 1)) (let* ((testpath (assoc/default 'testpath cmdinfo)) (top-path (assoc/default 'toppath cmdinfo)) (work-area (assoc/default 'work-area cmdinfo)) (test-name (assoc/default 'test-name cmdinfo)) (runscript (assoc/default 'runscript cmdinfo)) @@ -63,11 +70,10 @@ (set-vars (assoc/default 'set-vars cmdinfo)) ;; pre-overrides from -setvar (runname (assoc/default 'runname cmdinfo)) (megatest (assoc/default 'megatest cmdinfo)) (mt-bindir-path (assoc/default 'mt-bindir-path cmdinfo)) (fullrunscript (if runscript (conc testpath "/" runscript) #f)) - (db #f) (rollup-status 0)) (debug:print 2 "Exectuing " test-name " (id: " test-id ") on " (get-host-name)) ;; apply pre-overrides before other variables. The pre-override vars must not ;; clobbers things from the official sources such as megatest.config and runconfigs.config @@ -91,50 +97,46 @@ (if mt-bindir-path (setenv "PATH" (conc (getenv "PATH") ":" mt-bindir-path))) (change-directory top-path) (if (not (setup-for-run)) (begin (debug:print 0 "Failed to setup, exiting") + ;; (sqlite3:finalize! db) + ;; (sqlite3:finalize! tdb) (exit 1))) - (change-directory *toppath*) - ;; now can find our db - (set! db (open-db)) - (if (not (args:get-arg "-server")) - (server:client-setup db)) - ;; (set! *cache-on* #t) - (set-megatest-env-vars db run-id) ;; these may be needed by the launching process + ;; Can setup as client for server mode now + (server:client-setup) + + (change-directory *toppath*) + (open-run-close set-megatest-env-vars #f run-id) ;; these may be needed by the launching process (change-directory work-area) - (set-run-config-vars db run-id) + + (open-run-close set-run-config-vars #f run-id) ;; environment overrides are done *before* the remaining critical envars. (alist->env-vars env-ovrd) - (set-megatest-env-vars db run-id) + (open-run-close set-megatest-env-vars #f run-id) (set-item-env-vars itemdat) (save-environment-as-files "megatest") - (test-set-meta-info db run-id test-name itemdat) - (test-set-status! db test-id "REMOTEHOSTSTART" "n/a" (args:get-arg "-m") #f) + (open-run-close test-set-meta-info #f test-id run-id test-name itemdat 0) + (tests:test-set-status! test-id "REMOTEHOSTSTART" "n/a" (args:get-arg "-m") #f) (if (args:get-arg "-xterm") (set! fullrunscript "xterm") (if (and fullrunscript (not (file-execute-access? fullrunscript))) (system (conc "chmod ug+x " fullrunscript)))) ;; We are about to actually kick off the test ;; so this is a good place to remove the records for ;; any previous runs ;; (db:test-remove-steps db run-id testname itemdat) - ;; from here on out we will open and close the db - ;; on every access to reduce the probablitiy of - ;; contention or stuck access on nfs. - (sqlite3:finalize! db) - (let* ((m (make-mutex)) (kill-job? #f) (exit-info (vector #t #t #t)) (job-thread #f) (runit (lambda () ;; (let-values ;; (((pid exit-status exit-code) ;; (run-n-wait fullrunscript))) - + (tests:test-set-status! test-id "RUNNING" "n/a" #f #f) ;; if there is a runscript do it first (if fullrunscript (let ((pid (process-run fullrunscript))) (let loop ((i 0)) (let-values @@ -152,14 +154,11 @@ ))))) ;; then, if runscript ran ok (or did not get called) ;; do all the ezsteps (if any) (if ezsteps (let* ((testconfig (read-config (conc work-area "/testconfig") #f #t environ-patt: "pre-launch-env-vars")) ;; FIXME??? is allow-system ok here? - (ezstepslst (hash-table-ref/default testconfig "ezsteps" '())) - (db (open-db))) - (if (not (args:get-arg "-server")) - (server:client-setup db)) + (ezstepslst (hash-table-ref/default testconfig "ezsteps" '()))) (if (not (file-exists? ".ezsteps"))(create-directory ".ezsteps")) ;; if ezsteps was defined then we are sure to have at least one step but check anyway (if (not (> (length ezstepslst) 0)) (debug:print 0 "ERROR: ezsteps defined but ezstepslst is zero length") (let loop ((ezstep (car ezstepslst)) @@ -189,11 +188,11 @@ ;; call the command using mt_ezstep (set! script (conc "mt_ezstep " stepname " " (if prevstep prevstep "-") " " stepcmd)) (debug:print 4 "script: " script) - (rdb:teststep-set-status! db test-id stepname "start" "-" itemdat #f #f) + (open-run-close db:teststep-set-status! #f test-id stepname "start" "-" #f #f) ;; now launch (let ((pid (process-run script))) (let processloop ((i 0)) (let-values (((pid-val exit-status exit-code)(process-wait pid #t))) (mutex-lock! m) @@ -206,14 +205,14 @@ (thread-sleep! 2) (processloop (+ i 1)))) )) (let ((exinfo (vector-ref exit-info 2)) (logfna (if logpro-used (conc stepname ".html") ""))) - ;; testing if procedures called in a remote call cause problems (ans: no or so I suspect) - (rdb:teststep-set-status! db test-id stepname "end" exinfo itemdat #f logfna)) + ;; testing if procedures called in a remote call cause problems (ans: no or so I suspect) + (open-run-close db:teststep-set-status! #f test-id stepname "end" exinfo #f logfna)) (if logpro-used - (rdb:test-set-log! db test-id (conc stepname ".html"))) + (open-run-close db:test-set-log! #f test-id (conc stepname ".html"))) ;; set the test final status (let* ((this-step-status (cond ((and (eq? (vector-ref exit-info 2) 2) logpro-used) 'warn) ((eq? (vector-ref exit-info 2) 0) 'pass) (else 'fail))) @@ -231,23 +230,23 @@ " next-status: " next-status " rollup-status: " rollup-status) (case next-status ((warn) (set! rollup-status 2) ;; NB// test-set-status! does rdb calls under the hood - (test-set-status! db test-id "RUNNING" "WARN" - (if (eq? this-step-status 'warn) "Logpro warning found" #f) - #f)) + (tests:test-set-status! test-id "RUNNING" "WARN" + (if (eq? this-step-status 'warn) "Logpro warning found" #f) + #f)) ((pass) - (test-set-status! db test-id "RUNNING" "PASS" #f #f)) + (tests:test-set-status! test-id "RUNNING" "PASS" #f #f)) (else ;; 'fail (set! rollup-status 1) ;; force fail - (test-set-status! db test-id "RUNNING" "FAIL" (conc "Failed at step " stepname) #f) + (tests:test-set-status! test-id "RUNNING" "FAIL" (conc "Failed at step " stepname) #f) )))) (if (and (steprun-good? logpro-used (vector-ref exit-info 2)) (not (null? tal))) (loop (car tal) (cdr tal) stepname))) - (debug:print 4 "WARNING: a prior step failed, stopping at " ezstep)))))))) + (debug:print 4 "WARNING: a prior step failed, stopping at " ezstep)))))))) (monitorjob (lambda () (let* ((start-seconds (current-seconds)) (calc-minutes (lambda () (inexact->exact (round @@ -254,20 +253,13 @@ (- (current-seconds) start-seconds))))) (kill-tries 0)) (let loop ((minutes (calc-minutes))) - (let* ((db (open-db)) - (cpuload (get-cpu-load)) - (diskfree (get-df (current-directory))) - (tmpfree (get-df "/tmp"))) - (if (not (args:get-arg "-server")) - (server:client-setup db)) - (if (not cpuload) (begin (debug:print 0 "WARNING: CPULOAD not found.") (set! cpuload "n/a"))) - (if (not diskfree) (begin (debug:print 0 "WARNING: DISKFREE not found.") (set! diskfree "n/a"))) - (set! kill-job? (test-get-kill-request db run-id test-name itemdat)) - (rdb:test-update-meta-info db test-id minutes cpuload diskfree tmpfree) + (begin + (set! kill-job? (open-run-close test-get-kill-request #f test-id)) ;; run-id test-name itemdat)) + (open-run-close test-set-meta-info #f test-id run-id test-name itemdat minutes) (if kill-job? (begin (mutex-lock! m) (let* ((pid (vector-ref exit-info 0))) (if (number? pid) @@ -286,65 +278,55 @@ (system (conc "kill -9 " p-id)))))) (car processes)) (system (conc "kill -9 " pid)))) (begin (debug:print 0 "WARNING: Request received to kill job but problem with process, attempting to kill manager process") - (test-set-status! db test-id "KILLED" "FAIL" - (args:get-arg "-m") #f) - (sqlite3:finalize! db) + (tests:test-set-status! test-id "KILLED" "FAIL" + (args:get-arg "-m") #f) + (sqlite3:finalize! tdb) (exit 1)))) (set! kill-tries (+ 1 kill-tries)) (mutex-unlock! m))) - (sqlite3:finalize! db) + ;; (sqlite3:finalize! db) (thread-sleep! (+ 10 (random 10))) ;; add some jitter to the call home time to spread out the db accesses (loop (calc-minutes))))))) (th1 (make-thread monitorjob)) (th2 (make-thread runit))) (set! job-thread th2) (thread-start! th1) (thread-start! th2) (thread-join! th2) (mutex-lock! m) - (set! db (open-db)) - (if (not (args:get-arg "-server")) - (server:client-setup db)) (let* ((item-path (item-list->path itemdat)) - (testinfo (rdb:get-test-info db run-id test-name item-path))) + (testinfo (open-run-close db:get-test-info-by-id #f test-id))) ;; )) ;; run-id test-name item-path))) (if (not (equal? (db:test-get-state testinfo) "COMPLETED")) (begin (debug:print 2 "Test NOT logged as COMPLETED, (state=" (db:test-get-state testinfo) "), updating result, rollup-status is " rollup-status) - (test-set-status! db test-id - (if kill-job? "KILLED" "COMPLETED") - ;; Old logic: - ;; (if (vector-ref exit-info 1) ;; look at the exit-status, #t means it at least ran - ;; (if (and (not kill-job?) - ;; (eq? (vector-ref exit-info 2) 0)) ;; we can now use rollup-status instead - ;; "PASS" - ;; "FAIL") - ;; "FAIL") - ;; New logic based on rollup-status - (cond - ((not (vector-ref exit-info 1)) "FAIL") ;; job failed to run - ((eq? rollup-status 0) - ;; if the current status is AUTO the defer to the calculated value (i.e. leave this AUTO) - (if (equal? (db:test-get-status testinfo) "AUTO") "AUTO" "PASS")) - ((eq? rollup-status 1) "FAIL") - ((eq? rollup-status 2) - ;; if the current status is AUTO the defer to the calculated value but qualify (i.e. make this AUTO-WARN) - (if (equal? (db:test-get-status testinfo) "AUTO") "AUTO-WARN" "WARN")) - (else "FAIL")) - (args:get-arg "-m") #f))) + (tests:test-set-status! test-id + (if kill-job? "KILLED" "COMPLETED") + (cond + ((not (vector-ref exit-info 1)) "FAIL") ;; job failed to run + ((eq? rollup-status 0) + ;; if the current status is AUTO the defer to the calculated value (i.e. leave this AUTO) + (if (equal? (db:test-get-status testinfo) "AUTO") "AUTO" "PASS")) + ((eq? rollup-status 1) "FAIL") + ((eq? rollup-status 2) + ;; if the current status is AUTO the defer to the calculated value but qualify (i.e. make this AUTO-WARN) + (if (equal? (db:test-get-status testinfo) "AUTO") "AUTO-WARN" "WARN")) + (else "FAIL")) + (args:get-arg "-m") #f))) ;; for automated creation of the rollup html file this is a good place... (if (not (equal? item-path "")) - (tests:summarize-items db run-id test-name #f)) ;; don't force - just update if no + (open-run-close tests:summarize-items #f run-id test-name #f)) ;; don't force - just update if no ) (mutex-unlock! m) ;; (exec-results (cmd-run->list fullrunscript)) ;; (list ">" (conc test-name "-run.log")))) ;; (success exec-results)) ;; (eq? (cadr exec-results) 0))) (debug:print 2 "Output from running " fullrunscript ", pid " (vector-ref exit-info 0) " in work area " work-area ":\n====\n exit code " (vector-ref exit-info 2) "\n" "====\n") - (sqlite3:finalize! db) + ;; (sqlite3:finalize! db) + ;; (sqlite3:finalize! tdb) (if (not (vector-ref exit-info 1)) (exit 4))))))) ;; set up the very basics needed for doing anything here. (define (setup-for-run) @@ -353,11 +335,12 @@ ;; pass on that idea for now ;; special case (set! *configinfo* (find-and-read-config (if (args:get-arg "-config")(args:get-arg "-config") "megatest.config") environ-patt: "env-override" - given-toppath: (get-environment-variable "MT_RUN_AREA_HOME"))) + given-toppath: (get-environment-variable "MT_RUN_AREA_HOME") + pathenvvar: "MT_RUN_AREA_HOME")) (set! *configdat* (if (car *configinfo*)(car *configinfo*) #f)) (set! *toppath* (if (car *configinfo*)(cadr *configinfo*) #f)) (if *toppath* (setenv "MT_RUN_AREA_HOME" *toppath*) ;; to be deprecated (debug:print 0 "ERROR: failed to find the top path to your run setup.")) @@ -401,11 +384,11 @@ ;; ;; All log file links should be stored relative to the top of link path ;; ;; - [ - ] ;; -(define (create-work-area db run-id test-src-path disk-path testname itemdat) +(define (create-work-area db run-id test-id test-src-path disk-path testname itemdat) (let* ((run-info (db:get-run-info db run-id)) (item-path (item-list->path itemdat)) (runname (db:get-value-by-header (db:get-row run-info) (db:get-header run-info) "runname")) @@ -423,18 +406,18 @@ (toptest-path (conc disk-path "/" testtop-base)) (test-path (conc disk-path "/" test-base)) ;; ensure this exists first as links to subtests must be created there (linktree (let ((rd (config-lookup *configdat* "setup" "linktree"))) - (if rd rd (conc *toppath* "/runs")))) + (if rd rd (conc *toppath* "/runs")))) (lnkbase (conc linktree "/" target "/" runname)) (lnkpath (conc lnkbase "/" testname)) (lnkpathf (conc lnkpath (if not-iterated "" "/") item-path))) ;; Update the rundir path in the test record for all - (db:test-set-rundir! db run-id testname item-path lnkpathf) + (db:test-set-rundir-by-test-id! db test-id lnkpathf) (debug:print 2 "INFO:\n lnkbase=" lnkbase "\n lnkpath=" lnkpath "\n toptest-path=" toptest-path "\n test-path=" test-path) (if (not (file-exists? linktree)) (begin (debug:print 0 "WARNING: linktree did not exist! Creating it now at " linktree) @@ -449,11 +432,11 @@ ;; again. ;; NB - This is not working right - some top tests are not getting the path set!!! (if (not (hash-table-ref/default *toptest-paths* testname #f)) - (let* ((testinfo (db:get-test-info db run-id testname item-path)) + (let* ((testinfo (db:get-test-info-by-id db test-id)) ;; run-id testname item-path)) (curr-test-path (if testinfo (db:test-get-rundir testinfo) #f))) (hash-table-set! *toptest-paths* testname curr-test-path) (db:test-set-rundir! db run-id testname "" lnkpath) ;; toptest-path) (if (or (not curr-test-path) (not (directory-exists? toptest-path))) @@ -468,10 +451,12 @@ ;; level (if (not not-iterated) ;; i.e. iterated (let ((iterated-parent (pathname-directory (conc lnkpath "/" item-path)))) (debug:print 2 "INFO: Creating iterated parent " iterated-parent) (create-directory iterated-parent #t))) + + (if (symbolic-link? lnkpath) (delete-file lnkpath)) (if (not (or (file-exists? lnkpath) (symbolic-link? lnkpath))) (create-symbolic-link toptest-path lnkpath)) ;; The toptest path has been created, the link to the test in the linktree has @@ -483,12 +468,14 @@ (create-directory test-path #t) ;; (system (conc "mkdir -p " test-path)) (debug:print 2 " - creating link from: " test-path "\n" " to: " lnktarget) ;; (create-directory lnkpath #t) ;; (system (conc "mkdir -p " lnkpath)) - (if (not (file-exists? lnktarget)) - (create-symbolic-link test-path lnktarget)))) + + ;; If there is already a symlink delete it and recreate it. + (if (symbolic-link? lnktarget) (delete-file lnktarget)) + (if (not (file-exists? lnktarget)) (create-symbolic-link test-path lnktarget)))) ;; I suspect this section was deleting test directories under some ;; wierd sitations? This doesn't make sense - reenabling the rm -f ;; I honestly don't remember *why* this chunk was needed... ;; (let ((testlink (conc lnkpath "/" testname))) @@ -515,16 +502,16 @@ ;; (launch-test db (cadr status) test-conf)) (define (launch-test db run-id runname test-conf keyvallst test-name test-path itemdat params) (change-directory *toppath*) (alist->env-vars ;; consolidate this code with the code in megatest.scm for "-execute" (list ;; (list "MT_TEST_RUN_DIR" work-area) - (list "MT_RUN_AREA_HOME" *toppath*) - (list "MT_TEST_NAME" test-name) - ;; (list "MT_ITEM_INFO" (conc itemdat)) - (list "MT_RUNNAME" runname) - ;; (list "MT_TARGET" mt_target) - )) + (list "MT_RUN_AREA_HOME" *toppath*) + (list "MT_TEST_NAME" test-name) + ;; (list "MT_ITEM_INFO" (conc itemdat)) + (list "MT_RUNNAME" runname) + ;; (list "MT_TARGET" mt_target) + )) (let* ((useshell (config-lookup *configdat* "jobtools" "useshell")) (launcher (config-lookup *configdat* "jobtools" "launcher")) (runscript (config-lookup test-conf "setup" "runscript")) (ezsteps (> (length (hash-table-ref/default test-conf "ezsteps" '())) 0)) ;; don't send all the steps, could be big (diskspace (config-lookup test-conf "requirements" "diskspace")) @@ -549,12 +536,12 @@ (diskpath #f) (cmdparms #f) (fullcmd #f) ;; (define a (with-output-to-string (lambda ()(write x)))) (mt-bindir-path #f) (item-path (item-list->path itemdat)) - (testinfo (rdb:get-test-info db run-id test-name item-path)) - (test-id (db:test-get-id testinfo)) + (test-id (open-run-close db:get-test-id db run-id test-name item-path)) + (testinfo (open-run-close db:get-test-info-by-id db test-id)) (mt_target (string-intersperse (map cadr keyvallst) "/")) (debug-param (if (args:get-arg "-debug")(list "-debug" (args:get-arg "-debug")) '()))) (if hosts (set! hosts (string-split hosts))) ;; set the megatest to be called on the remote host (if (not remote-megatest)(set! remote-megatest local-megatest)) ;; "megatest")) @@ -561,11 +548,11 @@ (set! mt-bindir-path (pathname-directory remote-megatest)) (if launcher (set! launcher (string-split launcher))) ;; set up the run work area for this test (set! diskpath (get-best-disk *configdat*)) (if diskpath - (let ((dat (create-work-area db run-id test-path diskpath test-name itemdat))) + (let ((dat (open-run-close create-work-area db run-id test-id test-path diskpath test-name itemdat))) (set! work-area (car dat)) (set! toptest-work-area (cadr dat)) (debug:print 2 "INFO: Using work area " work-area)) (begin (set! work-area (conc test-path "/tmp_run")) @@ -587,12 +574,14 @@ (list 'env-ovrd (hash-table-ref/default *configdat* "env-override" '())) (list 'set-vars (if params (hash-table-ref/default params "-setvars" #f))) (list 'runname runname) (list 'mt-bindir-path mt-bindir-path))))))) ;; (string-intersperse keyvallst " ")))) ;; clean out step records from previous run if they exist - (db:delete-test-step-records db run-id test-name itemdat) + (debug:print 4 "INFO: FIXMEEEEE!!!! This can be removed some day, perhaps move all test records to the test db?") + (open-run-close db:delete-test-step-records db test-id) (change-directory work-area) ;; so that log files from the launch process don't clutter the test dir + (tests:test-set-status! test-id "LAUNCHED" "n/a" #f #f) ;; (if launch-results launch-results "FAILED")) (cond ((and launcher hosts) ;; must be using ssh hostname (set! fullcmd (append launcher (car hosts)(list remote-megatest test-sig "-execute" cmdparms) debug-param))) ;; (set! fullcmd (append launcher (car hosts)(list remote-megatest test-sig "-execute" cmdparms)))) (launcher @@ -602,11 +591,10 @@ (if (not useshell)(debug:print 0 "WARNING: internal launching will not work well without \"useshell yes\" in your [jobtools] section")) (set! fullcmd (append (list remote-megatest test-sig "-execute" cmdparms) debug-param (list (if useshell "&" "")))))) ;; (set! fullcmd (list remote-megatest test-sig "-execute" cmdparms (if useshell "&" ""))))) (if (args:get-arg "-xterm")(set! fullcmd (append fullcmd (list "-xterm")))) (debug:print 1 "Launching " work-area) - (test-set-status! db test-id "LAUNCHED" "n/a" #f #f) ;; (if launch-results launch-results "FAILED")) ;; set pre-launch-env-vars before launching, keep the vars in prevvals and put the envionment back when done (debug:print 4 "fullcmd: " fullcmd) (let* ((commonprevvals (alist->env-vars (hash-table-ref/default *configdat* "env-override" '()))) (testprevvals (alist->env-vars @@ -633,11 +621,11 @@ (debug:print 2 "Launching completed, updating db") (debug:print 2 "Launch results: " launch-results) (if (not launch-results) (begin (print "ERROR: Failed to run " (string-intersperse fullcmd " ") ", exiting now") - (sqlite3:finalize! db) + ;; (sqlite3:finalize! db) ;; good ole "exit" seems not to work ;; (_exit 9) ;; but this hack will work! Thanks go to Alan Post of the Chicken email list ;; NB// Is this still needed? Should be safe to go back to "exit" now? (process-signal (current-process-id) signal/kill) Index: megatest-version.scm ================================================================== --- megatest-version.scm +++ megatest-version.scm @@ -1,7 +1,7 @@ ;; Always use two digit decimal ;; 1.01, 1.02...1.10,1.11 ... 1.99,2.00.. (declare (unit megatest-version)) -(define megatest-version 1.4403) +(define megatest-version 1.4611) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -26,10 +26,11 @@ (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") +(include "megatest-fossil-hash.scm") (define help (conc " Megatest, documentation at http://www.kiatoa.com/fossils/megatest version " megatest-version " license GPL, Copyright Matt Welland 2006-2012 @@ -111,11 +112,12 @@ Examples # Get test path, use '.' to get a single path or a specific path/file pattern megatest -test-files 'logs/*.log' -target ubuntu/n%/no% :runname w49% -testpatt test_mt% -Called as " (string-intersperse (argv) " "))) +Called as " (string-intersperse (argv) " ") " +Built from " megatest-fossil-hash )) ;; -gui : start a gui interface ;; -config fname : override the runconfig file with fname ;; process args @@ -204,14 +206,19 @@ ;;====================================================================== ;; Misc setup stuff ;;====================================================================== (set! *verbosity* (cond - ((args:get-arg "-debug")(string->number (args:get-arg "-debug"))) + ((string? (args:get-arg "-debug"))(string->number (args:get-arg "-debug"))) ((args:get-arg "-v") 2) ((args:get-arg "-q") 0) (else 1))) + +(if (not (number? *verbosity*)) + (begin + (print "ERROR: Invalid debug value " (args:get-arg "-debug")) + (exit))) ;;====================================================================== ;; Misc general calls ;;====================================================================== @@ -224,11 +231,11 @@ ;; Remove old run(s) ;;====================================================================== ;; since several actions can be specified on the command line the removal ;; is done first -(define (operate-on db action) +(define (operate-on action) (cond ((not (args:get-arg ":runname")) (debug:print 0 "ERROR: Missing required parameter for " action ", you must specify the run name pattern with :runname patt") (exit 2)) ((not (args:get-arg "-testpatt")) @@ -241,118 +248,111 @@ (if (not (car *configinfo*)) (begin (debug:print 0 "ERROR: Attempted " action "on test(s) but run area config file not found") (exit 1)) ;; put test parameters into convenient variables - (runs:operate-on db - action + (runs:operate-on action (args:get-arg ":runname") (args:get-arg "-testpatt") (args:get-arg "-itempatt") state: (args:get-arg ":state") status: (args:get-arg ":status") new-state-status: (args:get-arg "-set-state-status"))) - (sqlite3:finalize! db) (set! *didsomething* #t)))) (if (args:get-arg "-remove-runs") (general-run-call "-remove-runs" "remove runs" - (lambda (db target runname keys keynames keyvallst) - (operate-on db 'remove-runs)))) + (lambda (target runname keys keynames keyvallst) + (operate-on 'remove-runs)))) (if (args:get-arg "-set-state-status") (general-run-call "-set-state-status" "set state and status" - (lambda (db target runname keys keynames keyvallst) - (operate-on db 'set-state-status)))) + (lambda (target runname keys keynames keyvallst) + (operate-on 'set-state-status)))) ;;====================================================================== ;; Query runs ;;====================================================================== (if (args:get-arg "-list-runs") - (let* ((db (begin - (setup-for-run) - (open-db))) - (runpatt (args:get-arg "-list-runs")) - (testpatt (args:get-arg "-testpatt")) - (itempatt (args:get-arg "-itempatt")) - (runsdat (rdb:get-runs db runpatt #f #f '())) - (runs (db:get-rows runsdat)) - (header (db:get-header runsdat)) - (keys (rdb:get-keys db)) - (keynames (map key:get-fieldname keys))) - (if (not (args:get-arg "-server")) - (server:client-setup db)) - ;; Each run - (for-each - (lambda (run) - (debug:print 1 "Run: " - (string-intersperse (map (lambda (x) - (db:get-value-by-header run header x)) - keynames) "/") - "/" - (db:get-value-by-header run header "runname") - " status: " (db:get-value-by-header run header "state")) - (let ((run-id (db:get-value-by-header run header "id"))) - (let ((tests (rdb:get-tests-for-run db run-id testpatt itempatt '() '()))) - ;; Each test - (for-each - (lambda (test) - (format #t - " Test: ~25a State: ~15a Status: ~15a Runtime: ~5@as Time: ~22a Host: ~10a\n" - (conc (db:test-get-testname test) - (if (equal? (db:test-get-item-path test) "") - "" - (conc "(" (db:test-get-item-path test) ")"))) - (db:test-get-state test) - (db:test-get-status test) - (db:test-get-run_duration test) - (db:test-get-event_time test) - (db:test-get-host test)) - (if (not (or (equal? (db:test-get-status test) "PASS") - (equal? (db:test-get-status test) "WARN") - (equal? (db:test-get-state test) "NOT_STARTED"))) - (begin - (print " cpuload: " (db:test-get-cpuload test) - "\n diskfree: " (db:test-get-diskfree test) - "\n uname: " (db:test-get-uname test) - "\n rundir: " (db:test-get-rundir test) - ) - ;; Each test - (let ((steps (db:get-steps-for-test db (db:test-get-id test)))) - (for-each - (lambda (step) - (format #t - " Step: ~20a State: ~10a Status: ~10a Time ~22a\n" - (db:step-get-stepname step) - (db:step-get-state step) - (db:step-get-status step) - (db:step-get-event_time step))) - steps))))) - tests)))) - runs) - (set! *didsomething* #t) - )) + (if (setup-for-run) + (let* ((db #f) + (runpatt (args:get-arg "-list-runs")) + (testpatt (args:get-arg "-testpatt")) + (itempatt (args:get-arg "-itempatt")) + (runsdat (open-run-close db:get-runs db runpatt #f #f '())) + (runs (db:get-rows runsdat)) + (header (db:get-header runsdat)) + (keys (open-run-close db:get-keys db)) + (keynames (map key:get-fieldname keys))) + ;; Each run + (for-each + (lambda (run) + (debug:print 1 "Run: " + (string-intersperse (map (lambda (x) + (db:get-value-by-header run header x)) + keynames) "/") + "/" + (db:get-value-by-header run header "runname") + " status: " (db:get-value-by-header run header "state")) + (let ((run-id (open-run-close db:get-value-by-header run header "id"))) + (let ((tests (open-run-close db:get-tests-for-run db run-id testpatt itempatt '() '()))) + ;; Each test + (for-each + (lambda (test) + (format #t + " Test: ~25a State: ~15a Status: ~15a Runtime: ~5@as Time: ~22a Host: ~10a\n" + (conc (db:test-get-testname test) + (if (equal? (db:test-get-item-path test) "") + "" + (conc "(" (db:test-get-item-path test) ")"))) + (db:test-get-state test) + (db:test-get-status test) + (db:test-get-run_duration test) + (db:test-get-event_time test) + (db:test-get-host test)) + (if (not (or (equal? (db:test-get-status test) "PASS") + (equal? (db:test-get-status test) "WARN") + (equal? (db:test-get-state test) "NOT_STARTED"))) + (begin + (print " cpuload: " (db:test-get-cpuload test) + "\n diskfree: " (db:test-get-diskfree test) + "\n uname: " (db:test-get-uname test) + "\n rundir: " (db:test-get-rundir test) + ) + ;; Each test + (let ((steps (open-run-close db:get-steps-for-test db (db:test-get-id test)))) + (for-each + (lambda (step) + (format #t + " Step: ~20a State: ~10a Status: ~10a Time ~22a\n" + (db:step-get-stepname step) + (db:step-get-state step) + (db:step-get-status step) + (db:step-get-event_time step))) + steps))))) + tests)))) + runs) + (set! *didsomething* #t) + ))) ;;====================================================================== ;; Start the server - can be done in conjunction with -runall or -runtests (one day...) ;;====================================================================== -(if (and (args:get-arg "-server") - (not (or (args:get-arg "-runall") - (args:get-arg "-runtests")))) +(if (args:get-arg "-server") (let* ((toppath (setup-for-run)) (db (if toppath (open-db) #f))) (debug:print 0 "INFO: Starting the standalone server") (if db (let* ((host:port (db:get-var db "SERVER")) ;; this doen't support multiple servers BUG!!!! (th2 (server:start db (args:get-arg "-server"))) (th3 (make-thread (lambda () - (server:keep-running db))))) + (server:keep-running db host:port))))) (thread-start! th3) (thread-join! th3)) (debug:print 0 "ERROR: Failed to setup for megatest")))) ;;====================================================================== @@ -376,17 +376,12 @@ ;; run all tests are are Not COMPLETED and PASS or CHECK (if (args:get-arg "-runall") (general-run-call "-runall" "run all tests" - (lambda (db target runname keys keynames keyvallst) -;; (let ((flags (make-hash-table))) -;; (for-each (lambda (parm) -;; (hash-table-set! flags parm (args:get-arg parm))) -;; (list "-rerun" "-force" "-itempatt")) - (runs:run-tests db - target + (lambda (target runname keys keynames keyvallst) + (runs:run-tests target runname (args:get-arg "-runtests") user args:arg-hash)))) ;; ) @@ -409,13 +404,12 @@ (if (args:get-arg "-runtests") (general-run-call "-runtests" "run a test" - (lambda (db target runname keys keynames keyvallst) - (runs:run-tests db - target + (lambda (target runname keys keynames keyvallst) + (runs:run-tests target runname (args:get-arg "-runtests") user args:arg-hash)))) @@ -425,13 +419,12 @@ (if (args:get-arg "-rollup") (general-run-call "-rollup" "rollup tests" - (lambda (db target runname keys keynames keyvallst) - (runs:rollup-run db - keys + (lambda (target runname keys keynames keyvallst) + (runs:rollup-run keys (keys->alist keys "na") (args:get-arg ":runname") user)))) ;;====================================================================== @@ -440,12 +433,12 @@ (if (or (args:get-arg "-lock")(args:get-arg "-unlock")) (general-run-call (if (args:get-arg "-lock") "-lock" "-unlock") "lock/unlock tests" - (lambda (db target runname keys keynames keyvallst) - (runs:handle-locking db + (lambda (target runname keys keynames keyvallst) + (runs:handle-locking target keys (args:get-arg ":runname") (args:get-arg "-lock") (args:get-arg "-unlock") @@ -478,28 +471,26 @@ (exit 1))) (if (not (setup-for-run)) (begin (debug:print 0 "Failed to setup, giving up on -test-paths or -test-files, exiting") (exit 1))) - (set! db (open-db)) - (if (not (args:get-arg "-server")) - (server:client-setup db)) (let* ((itempatt (args:get-arg "-itempatt")) - (keys (rdb:get-keys db)) + (keys (open-run-close db:get-keys db)) (keynames (map key:get-fieldname keys)) - (paths (rdb:test-get-paths-matching db keynames target (args:get-arg "-test-files")))) + (paths (open-run-close db:test-get-paths-matching db keynames target (args:get-arg "-test-files")))) (set! *didsomething* #t) (for-each (lambda (path) (print path)) paths))) ;; else do a general-run-call (general-run-call "-test-files" "Get paths to test" - (lambda (db target runname keys keynames keyvallst) - (let* ((itempatt (args:get-arg "-itempatt")) - (paths (rdb:test-get-paths-matching db keynames target (args:get-arg "-test-files")))) + (lambda (target runname keys keynames keyvallst) + (let* ((db #f) + (itempatt (args:get-arg "-itempatt")) + (paths (open-run-close db:test-get-paths-matching db keynames target (args:get-arg "-test-files")))) (for-each (lambda (path) (print path)) paths)))))) ;;====================================================================== @@ -528,28 +519,26 @@ (exit 1))) (if (not (setup-for-run)) (begin (debug:print 0 "Failed to setup, giving up on -archive, exiting") (exit 1))) - (set! db (open-db)) - (if (not (args:get-arg "-server")) - (server:client-setup db)) (let* ((itempatt (args:get-arg "-itempatt")) - (keys (rdb:get-keys db)) + (keys (open-run-close db:get-keys db)) (keynames (map key:get-fieldname keys)) - (paths (db:test-get-paths-matching db keynames target))) + (paths (open-run-close db:test-get-paths-matching db keynames target))) (set! *didsomething* #t) (for-each (lambda (path) (print path)) paths))) ;; else do a general-run-call (general-run-call "-test-paths" "Get paths to tests" - (lambda (db target runname keys keynames keyvallst) - (let* ((itempatt (args:get-arg "-itempatt")) - (paths (db:test-get-paths-matching db keynames target))) + (lambda (target runname keys keynames keyvallst) + (let* ((db #f) + (itempatt (args:get-arg "-itempatt")) + (paths (open-run-close db:test-get-paths-matching db keynames target))) (for-each (lambda (path) (print path)) paths)))))) ;;====================================================================== @@ -558,17 +547,18 @@ (if (args:get-arg "-extract-ods") (general-run-call "-extract-ods" "Make ods spreadsheet" - (lambda (db target runname keys keynames keyvallst) - (let ((outputfile (args:get-arg "-extract-ods")) + (lambda (target runname keys keynames keyvallst) + (let ((db #f) + (outputfile (args:get-arg "-extract-ods")) (runspatt (args:get-arg ":runname")) (pathmod (args:get-arg "-pathmod")) (keyvalalist (keys->alist keys "%"))) (debug:print 2 "Extract ods, outputfile: " outputfile " runspatt: " runspatt " keyvalalist: " keyvalalist) - (db:extract-ods-file db outputfile keyvalalist (if runspatt runspatt "%") pathmod))))) + (open-run-close db:extract-ods-file db outputfile keyvalalist (if runspatt runspatt "%") pathmod))))) ;;====================================================================== ;; execute the test ;; - gets called on remote host ;; - receives info from the -execute param @@ -606,19 +596,16 @@ (change-directory testpath) (if (not (setup-for-run)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) - (set! db (open-db)) - (if (not (args:get-arg "-server")) - (server:client-setup db)) (if (and state status) - (rdb:teststep-set-status! db test-id step state status itemdat (args:get-arg "-m") logfile) + (open-run-close db:teststep-set-status! db test-id step state status (args:get-arg "-m") logfile) (begin (debug:print 0 "ERROR: You must specify :state and :status with every call to -step") (exit 6))) - (sqlite3:finalize! db) + (if db (sqlite3:finalize! db)) (set! *didsomething* #t)))) (if (or (args:get-arg "-setlog") ;; since setting up is so costly lets piggyback on -test-status (args:get-arg "-set-toplog") (args:get-arg "-test-status") @@ -645,28 +632,29 @@ (change-directory testpath) (if (not (setup-for-run)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) - (set! db (open-db)) - (if (not (args:get-arg "-server")) - (server:client-setup db)) + + ;; can setup as client for server mode now + (server:client-setup) + (if (args:get-arg "-load-test-data") ;; has sub commands that are rdb: - (db:load-test-data db test-id)) + (open-run-close db:load-test-data db test-id)) (if (args:get-arg "-setlog") (let ((logfname (args:get-arg "-setlog"))) - (rdb:test-set-log! db test-id logfname))) + (open-run-close db:test-set-log! db test-id logfname))) (if (args:get-arg "-set-toplog") - (rtests:test-set-toplog! db run-id test-name (args:get-arg "-set-toplog"))) + (open-run-close tests:test-set-toplog! db run-id test-name (args:get-arg "-set-toplog"))) (if (args:get-arg "-summarize-items") - (tests:summarize-items db run-id test-name #t)) ;; do force here + (open-run-close tests:summarize-items db run-id test-name #t)) ;; do force here (if (args:get-arg "-runstep") (if (null? remargs) (begin (debug:print 0 "ERROR: nothing specified to run!") - (sqlite3:finalize! db) + (if db (sqlite3:finalize! db)) (exit 6)) (let* ((stepname (args:get-arg "-runstep")) (logprofile (args:get-arg "-logpro")) (logfile (conc stepname ".log")) (cmd (if (null? remargs) #f (car remargs))) @@ -679,23 +667,17 @@ (else ">&"))) (fullcmd (conc "(" (string-intersperse (cons cmd params) " ") ") " redir " " logfile))) ;; mark the start of the test - (rdb:teststep-set-status! db test-id stepname "start" "n/a" itemdat (args:get-arg "-m") logfile) - ;; close the db - ;; (sqlite3:finalize! db) + (open-run-close db:teststep-set-status! db test-id stepname "start" "n/a" (args:get-arg "-m") logfile) ;; run the test step (debug:print 2 "INFO: Running \"" fullcmd "\"") (change-directory startingdir) (set! exitstat (system fullcmd)) ;; cmd params)) (set! *globalexitstatus* exitstat) (change-directory testpath) - ;; re-open the db - ;; (set! db (open-db)) - ;; (if (not (args:get-arg "-server")) - ;; (server:client-setup db)) ;; run logpro if applicable ;; (process-run "ls" (list "/foo" "2>&1" "blah.log")) (if logprofile (let* ((htmllogfile (conc stepname ".html")) (oldexitstat exitstat) (cmd (string-intersperse (list "logpro" logprofile htmllogfile "<" logfile ">" (conc stepname "_logpro.log")) " "))) @@ -702,19 +684,14 @@ (debug:print 2 "INFO: running \"" cmd "\"") (change-directory startingdir) (set! exitstat (system cmd)) (set! *globalexitstatus* exitstat) ;; no necessary (change-directory testpath) - (rdb:test-set-log! db test-id htmllogfile))) + (open-run-close db:test-set-log! db test-id htmllogfile))) (let ((msg (args:get-arg "-m"))) - (rdb:teststep-set-status! db test-id stepname "end" exitstat itemdat msg logfile)) - ;; (sqlite3:finalize! db) - ;;(if (not (eq? exitstat 0)) - ;; (exit 254)) ;; (exit exitstat) doesn't work?!? - ;; open the db - ;; mark the end of the test - ))) + (open-run-close db:teststep-set-status! db test-id stepname "end" exitstat msg logfile)) + ))) (if (or (args:get-arg "-test-status") (args:get-arg "-set-values")) (let ((newstatus (cond ((number? status) (if (equal? status 0) "PASS" "FAIL")) ((and (string? status) @@ -731,15 +708,17 @@ (if (and (args:get-arg "-test-status") (or (not state) (not status))) (begin (debug:print 0 "ERROR: You must specify :state and :status with every call to -test-status\n" help) - (sqlite3:finalize! db) + ;; (sqlite3:finalize! db) (exit 6))) - (let ((msg (args:get-arg "-m"))) - (rtests:test-set-status! db test-id state newstatus msg otherdata)))) - (sqlite3:finalize! db) + (let* ((msg (args:get-arg "-m")) + (numoth (length (hash-table-keys otherdata)))) + ;; Convert to rpc inside the tests:test-set-status! call, not here + (tests:test-set-status! test-id state newstatus msg otherdata)))) + (if db (sqlite3:finalize! db)) (set! *didsomething* #t)))) ;;====================================================================== ;; Various helper commands can go below here ;;====================================================================== @@ -749,16 +728,13 @@ (keys #f)) (if (not (setup-for-run)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) - (set! db (open-db)) - (if (not (args:get-arg "-server")) - (server:client-setup db)) - (set! keys (rdb:get-keys db)) + (set! keys (open-run-close db:get-keys db)) (debug:print 1 "Keys: " (string-intersperse (map key:get-fieldname keys) ", ")) - (sqlite3:finalize! db) + (if db (sqlite3:finalize! db)) (set! *didsomething* #t))) (if (args:get-arg "-gui") (begin (debug:print 0 "Look at the dashboard for now") @@ -783,14 +759,11 @@ (begin (if (not (setup-for-run)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) - ;; now can find our db - (set! db (open-db)) - (patch-db db) - (sqlite3:finalize! db) + (open-run-close patch-db #f) (set! *didsomething* #t))) ;;====================================================================== ;; Update the tests meta data from the testconfig files ;;====================================================================== @@ -800,15 +773,11 @@ (if (not (setup-for-run)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) ;; now can find our db - (set! db (open-db)) - (if (not (args:get-arg "-server")) - (server:client-setup db)) - (runs:update-all-test_meta db) - (sqlite3:finalize! db) + (open-run-close runs:update-all-test_meta db) (set! *didsomething* #t))) ;;====================================================================== ;; Start a repl ;;====================================================================== @@ -818,11 +787,11 @@ (db (if toppath (open-db) #f))) (if db (begin (set! *db* db) (if (not (args:get-arg "-server")) - (server:client-setup db)) + (server:client-setup)) (import readline) (import apropos) (gnu-history-install-file-manager (string-append (or (get-environment-variable "HOME") ".") "/.megatest_history")) @@ -835,10 +804,12 @@ ;;====================================================================== (if (not *didsomething*) (debug:print 0 help)) +;; (if *runremote* (rpc:close-all-connections!)) + (if (not (eq? *globalexitstatus* 0)) (if (or (args:get-arg "-runtests")(args:get-arg "-runall")) (begin (debug:print 0 "NOTE: Subprocesses with non-zero exit code detected: " *globalexitstatus*) (exit 0)) Index: runconfig.scm ================================================================== --- runconfig.scm +++ runconfig.scm @@ -11,12 +11,12 @@ (include "common_records.scm") (define (setup-env-defaults db fname run-id already-seen #!key (environ-patt #f)) - (let* ((keys (rdb:get-keys db)) - (keyvals (rdb:get-key-vals db run-id)) + (let* ((keys (db:get-keys db)) + (keyvals (db:get-key-vals db run-id)) (thekey (string-intersperse (map (lambda (x)(if x x "-na-")) keyvals) "/")) ;; Why was system disallowed in the reading of the runconfigs file? ;; NOTE: Should be setting env vars based on (target|default) (confdat (read-config fname #f #t environ-patt: environ-patt sections: (list "default" thekey))) (whatfound (make-hash-table)) Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -62,46 +62,69 @@ (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 ")"))))) +;; Awful. Please FIXME +(define *env-vars-by-run-id* (make-hash-table)) +(define *current-run-name* #f) (define (set-megatest-env-vars db run-id) - (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)) - db - (conc "SELECT " (key:get-fieldname key) " FROM runs WHERE id=?;") - run-id)) - keys) + (let ((keys (db:get-keys db)) + (vals (hash-table-ref/default *env-vars-by-run-id* run-id #f))) + ;; get the info from the db and put it in the cache + (if (not vals) + (let ((ht (make-hash-table))) + (hash-table-set! *env-vars-by-run-id* run-id ht) + (set! vals ht) + (for-each + (lambda (key) + (sqlite3:for-each-row + (lambda (val) + (hash-table-set! vals key val)) + db + (conc "SELECT " (key:get-fieldname key) " FROM runs WHERE id=?;") + run-id)) + keys))) + ;; from the cached data set the vars + (hash-table-for-each + vals + (lambda (key val) + (debug:print 2 "setenv " (key:get-fieldname key) " " val) + (setenv (key:get-fieldname key) val))) (alist->env-vars (hash-table-ref/default *configdat* "env-override" '())) ;; Lets use this as an opportunity to put MT_RUNNAME in the environment - (sqlite3:for-each-row - (lambda (runname) - (setenv "MT_RUNNAME" runname)) - db - "SELECT runname FROM runs WHERE id=?;" - run-id) + (if (not *current-run-name*) + (sqlite3:for-each-row + (lambda (runname) + (set! *current-run-name* runname)) + + db + "SELECT runname FROM runs WHERE id=?;" + run-id)) + (setenv "MT_RUNNAME" *current-run-name*) + (setenv "MT_RUN_AREA_HOME" *toppath*) )) (define (set-item-env-vars itemdat) (for-each (lambda (item) (debug:print 2 "setenv " (car item) " " (cadr item)) (setenv (car item) (cadr item))) itemdat)) +(define *last-num-running-tests* 0) (define (runs:can-run-more-tests db test-record) (let* ((tconfig (tests:testqueue-get-testconfig test-record)) (jobgroup (config-lookup tconfig "requirements" "jobgroup")) (num-running (db:get-count-tests-running db)) (num-running-in-jobgroup (db:get-count-tests-running-in-jobgroup db jobgroup)) (max-concurrent-jobs (config-lookup *configdat* "setup" "max_concurrent_jobs")) (job-group-limit (config-lookup *configdat* "jobgroups" jobgroup))) - (debug:print 2 "max-concurrent-jobs: " max-concurrent-jobs ", num-running: " num-running) + (if (not (eq? *last-num-running-tests* num-running)) + (begin + (debug:print 2 "max-concurrent-jobs: " max-concurrent-jobs ", num-running: " num-running) + (set! *last-num-running-tests* num-running))) (if (not (eq? 0 *globalexitstatus*)) #f (let ((can-not-run-more (cond ;; if max-concurrent-jobs is set and the number running is greater ;; than it than cannot run more jobs @@ -158,26 +181,27 @@ (debug:print 0 "ERROR: Called without all necessary keys") #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 user flags) - (let* ((keys (rdb:get-keys db)) +(define (runs:run-tests target runname test-patts user flags) + (let* ((db #f) + (keys (open-run-close db:get-keys db)) (keyvallst (keys:target->keyval keys target)) - (run-id (runs:register-run db keys keyvallst runname "new" "n/a" user)) ;; test-name))) + (run-id (open-run-close 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)) (test-names '()) (runconfigf (conc *toppath* "/runconfigs.config")) (required-tests '()) (test-records (make-hash-table))) - (set-megatest-env-vars db run-id) ;; these may be needed by the launching process + (open-run-close set-megatest-env-vars db run-id) ;; these may be needed by the launching process (if (file-exists? runconfigf) - (setup-env-defaults db runconfigf run-id *already-seen-runconfig-info* "pre-launch-env-vars") + (open-run-close setup-env-defaults db runconfigf run-id *already-seen-runconfig-info* "pre-launch-env-vars") (debug:print 0 "WARNING: You do not have a run config file: " runconfigf)) ;; look up all tests matching the comma separated list of globs in ;; test-patts (using % as wildcard) (for-each @@ -201,23 +225,26 @@ (begin ;; have to delete test records where NOT_STARTED since they can cause -keepgoing to ;; get stuck due to becoming inaccessible from a failed test. I.e. if test B depends ;; on test A but test B reached the point on being registered as NOT_STARTED and test ;; A failed for some reason then on re-run using -keepgoing the run can never complete. - (db:delete-tests-in-state db run-id "NOT_STARTED") - (rdb:set-tests-state-status db run-id test-names #f "FAIL" "NOT_STARTED" "FAIL"))) + (open-run-close db:delete-tests-in-state db run-id "NOT_STARTED") + (open-run-close db:set-tests-state-status db run-id test-names #f "FAIL" "NOT_STARTED" "FAIL"))) + ;; from here on out the db will be opened and closed on every call runs:run-tests-queue + ;; (sqlite3:finalize! db) ;; now add non-directly referenced dependencies (i.e. waiton) (if (not (null? test-names)) (let loop ((hed (car test-names)) (tal (cdr test-names))) ;; 'return-procs tells the config reader to prep running system but return a proc + (debug:print 4 "INFO: hed=" hed " at top of loop") (let* ((config (tests:get-testconfig hed 'return-procs)) (waitons (if config (string-split (let ((w (config-lookup config "requirements" "waiton"))) (if w w ""))) (begin (debug:print 0 "ERROR: non-existent required test \"" hed "\"") - (sqlite3:finalize! db) + (if db (sqlite3:finalize! db)) (exit 1))))) ;; check for hed in waitons => this would be circular, remove it and issue an ;; error (if (member hed waitons) (begin @@ -270,260 +297,331 @@ (loop (car remtests)(cdr remtests))))))) (if (not (null? required-tests)) (debug:print 1 "INFO: Adding " required-tests " to the run queue")) ;; NOTE: these are all parent tests, items are not expanded yet. - (runs:run-tests-queue db run-id runname test-records keyvallst flags) - (if *rpc:listener* (server:keep-running db)) + (debug:print 4 "INFO: test-records=" (hash-table->alist test-records)) + (runs:run-tests-queue run-id runname test-records keyvallst flags) (debug:print 4 "INFO: All done by here"))) +(define (runs:calc-fails prereqs-not-met) + (filter (lambda (test) + (and (vector? test) ;; not (string? test)) + (equal? (db:test-get-state test) "COMPLETED") + (not (member (db:test-get-status test) + '("PASS" "WARN" "CHECK" "WAIVED"))))) + prereqs-not-met)) + +(define (runs:calc-not-completed prereqs-not-met) + (filter + (lambda (t) + (or (not (vector? t)) + (not (equal? "COMPLETED" (db:test-get-state t))))) + prereqs-not-met)) + +(define (runs:pretty-string lst) + (map (lambda (t) + (if (not (vector? t)) + (conc t) + (conc (db:test-get-testname t) ":" (db:test-get-state t) "/" (db:test-get-status t)))) + lst)) + +(define (runs:make-full-test-name testname itempath) + (if (equal? itempath "") testname (conc testname "/" itempath))) + ;; test-records is a hash table testname:item_path => vector < testname testconfig waitons priority items-info ... > -(define (runs:run-tests-queue db run-id runname test-records keyvallst flags) +(define (runs:run-tests-queue run-id runname test-records keyvallst flags) ;; At this point the list of parent tests is expanded ;; NB// Should expand items here and then insert into the run queue. (debug:print 5 "test-records: " test-records ", keyvallst: " keyvallst " flags: " (hash-table->alist flags)) (let ((sorted-test-names (tests:sort-by-priority-and-waiton test-records)) - (item-patts (hash-table-ref/default flags "-itempatt" #f))) + (item-patts (hash-table-ref/default flags "-itempatt" #f)) + (test-registery (make-hash-table)) + (num-retries 0) + (max-retries (config-lookup *configdat* "setup" "maxretries"))) + (set! max-retries (if (and max-retries (string->number max-retries))(string->number max-retries) 100)) (if (not (null? sorted-test-names)) (let loop ((hed (car sorted-test-names)) - (tal (cdr sorted-test-names))) - (thread-sleep! 0.1) ;; give other applications some time with the db + (tal (cdr sorted-test-names)) + (reruns '())) + (if (not (null? reruns))(debug:print 4 "INFO: reruns=" reruns)) + ;; (print "Top of loop, hed=" hed ", tal=" tal " ,reruns=" reruns) (let* ((test-record (hash-table-ref test-records hed)) + (test-name (tests:testqueue-get-testname test-record)) (tconfig (tests:testqueue-get-testconfig test-record)) (testmode (let ((m (config-lookup tconfig "requirements" "mode"))) (if m (string->symbol m) 'normal))) (waitons (tests:testqueue-get-waitons test-record)) (priority (tests:testqueue-get-priority test-record)) (itemdat (tests:testqueue-get-itemdat test-record)) ;; itemdat can be a string, list or #f (items (tests:testqueue-get-items test-record)) (item-path (item-list->path itemdat)) - (newtal (append tal (list hed))) - (calc-fails (lambda (prereqs-not-met) - (filter (lambda (test) - (debug:print 9 "test: " test) - (and (vector? test) ;; not (string? test)) - (equal? (db:test-get-state test) "COMPLETED") - (not (member (db:test-get-status test) - '("PASS" "WARN" "CHECK" "WAIVED"))))) - prereqs-not-met))) - (calc-not-completed (lambda (prereqs-not-met) - (filter - (lambda (t) - (or (not (vector? t)) - (not (equal? "COMPLETED" (db:test-get-state t))))) - prereqs-not-met))) - (pretty-string (lambda (lst) - (map (lambda (t) - (if (string? t) - t - (conc (db:test-get-testname t) ":" (db:test-get-state t) "/" (db:test-get-status t)))) - lst)))) + (newtal (append tal (list hed)))) + (debug:print 6 - "itemdat: " itemdat - "\n items: " items - "\n item-path: " item-path - "\n waitons: " waitons) + "test-name: " test-name + "\n hed: " hed + "\n itemdat: " itemdat + "\n items: " items + "\n item-path: " item-path + "\n waitons: " waitons + "\n num-retries: " num-retries + "\n tal: " tal + "\n reruns: " reruns) ;; check for hed in waitons => this would be circular, remove it and issue an ;; error - (if (member hed waitons) + (if (member test-name waitons) (begin - (debug:print 0 "ERROR: test " hed " has listed itself as a waiton, please correct this!") + (debug:print 0 "ERROR: test " test-name " has listed itself as a waiton, please correct this!") (set! waiton (filter (lambda (x)(not (equal? x hed))) waitons)))) - (cond + (cond ;; OUTER COND ((not items) ;; when false the test is ok to be handed off to launch (but not before) - (let* ((have-resources (runs:can-run-more-tests db test-record)) ;; look at the test jobgroup and tot jobs running - (prereqs-not-met (db:get-prereqs-not-met db run-id waitons item-path mode: testmode)) - (fails (calc-fails prereqs-not-met)) - (non-completed (calc-not-completed prereqs-not-met))) + (let* ((have-resources (open-run-close runs:can-run-more-tests #f test-record)) ;; look at the test jobgroup and tot jobs running + (prereqs-not-met (open-run-close db:get-prereqs-not-met #f run-id waitons item-path mode: testmode)) + (fails (runs:calc-fails prereqs-not-met)) + (non-completed (runs:calc-not-completed prereqs-not-met))) (debug:print 8 "INFO: have-resources: " have-resources " prereqs-not-met: " (string-intersperse (map (lambda (t) - (conc (db:test-get-state t)"/"(db:test-get-status t))) + (if (vector? t) + (conc (db:test-get-state t) "/" (db:test-get-status t)) + (conc " WARNING: t is not a vector=" t ))) prereqs-not-met) ", ") " fails: " fails) + (debug:print 4 "INFO: hed=" hed) + ;; Don't know at this time if the test have been launched at some time in the past ;; i.e. is this a re-launch? - (cond + + (cond ;; INNER COND #1 for a launchable test + ;; Check item path against item-patts + ((and (not (patt-list-match item-path item-patts)) + (not (equal? item-path ""))) + ;; else the run is stuck, temporarily or permanently + ;; but should check if it is due to lack of resources vs. prerequisites + (debug:print 1 "INFO: Skipping " (tests:testqueue-get-testname test-record) " " item-path " as it doesn't match " item-patts) + (thread-sleep! *global-delta*) + (if (not (null? tal)) + (loop (car tal)(cdr tal) reruns))) + ((not (hash-table-ref/default test-registery (runs:make-full-test-name test-name item-path) #f)) + (open-run-close db:tests-register-test #f run-id test-name item-path) + (hash-table-set! test-registery (runs:make-full-test-name test-name item-path) #t) + (thread-sleep! *global-delta*) + (loop (car newtal)(cdr newtal) reruns)) + ((not have-resources) ;; simply try again after waiting a second + (thread-sleep! (+ 1 *global-delta*)) + (debug:print 1 "INFO: no resources to run new tests, waiting ...") + ;; could have done hed tal here but doing car/cdr of newtal to rotate tests + (loop (car newtal)(cdr newtal) reruns)) ((and have-resources (or (null? prereqs-not-met) (and (eq? testmode 'toplevel) (null? non-completed)))) - ;; no loop here, just drop though and use the loop at the bottom - (if (patt-list-match item-path item-patts) - (run:test db run-id runname keyvallst test-record flags #f) - (debug:print 1 "INFO: Skipping " (tests:testqueue-get-testname test-record) " " item-path " as it doesn't match " item-patts)) - ;; else the run is stuck, temporarily or permanently - ;; but should check if it is due to lack of resources vs. prerequisites - ) - ((not have-resources) ;; simply try again after waiting a second - (thread-sleep! 1.0) - (debug:print 1 "INFO: no resources to run new tests, waiting ...") - ;; could have done hed tal here but doing car/cdr of newtal to rotate tests - (loop (car newtal)(cdr newtal))) + (run:test run-id runname keyvallst test-record flags #f) + (thread-sleep! *global-delta*) + (if (not (null? tal)) + (loop (car tal)(cdr tal) reruns))) (else ;; must be we have unmet prerequisites (debug:print 4 "FAILS: " fails) ;; If one or more of the prereqs-not-met are FAIL then we can issue ;; a message and drop hed from the items to be processed. (if (null? fails) (begin ;; couldn't run, take a breather (debug:print 4 "INFO: Shouldn't really get here, race condition? Unable to launch more tests at this moment, killing time ...") - (thread-sleep! 0.1) ;; long sleep here - no resources, may as well be patient + (thread-sleep! (+ 1 *global-delta*)) ;; long sleep here - no resources, may as well be patient ;; we made new tal by sticking hed at the back of the list - (loop (car newtal)(cdr newtal))) + (loop (car newtal)(cdr newtal) reruns)) ;; the waiton is FAIL so no point in trying to run hed ever again (if (not (null? tal)) - (begin - (debug:print 1 "WARN: Dropping test " (db:test-get-testname hed) "/" (db:test-get-item-path hed) - " from the launch list as it has prerequistes that are FAIL") - (loop (car tal)(cdr tal))))))))) + (if (vector? hed) + (begin (debug:print 1 "WARN: Dropping test " (db:test-get-testname hed) "/" (db:test-get-item-path hed) + " from the launch list as it has prerequistes that are FAIL") + (thread-sleep! *global-delta*) + (loop (car tal)(cdr tal) (cons hed reruns))) + (begin + (debug:print 1 "WARN: Test not processed correctly. Could be a race condition in your test implementation? " hed) ;; " as it has prerequistes that are FAIL. (NOTE: hed is not a vector)") + (thread-sleep! *global-delta*) + (loop hed tal reruns))))))))) ;; END OF INNER COND ;; case where an items came in as a list been processed ((and (list? items) ;; thus we know our items are already calculated (not itemdat)) ;; and not yet expanded into the list of things to be done (if (and (>= *verbosity* 1) (> (length items) 0) (> (length (car items)) 0)) (pp items)) - ;; (if (>= *verbosity* 5) - ;; (begin - ;; (print "items: ") (pp (item-assoc->item-list items)) - ;; (print "itemstable: ")(pp (item-table->item-list itemstable)))) (for-each (lambda (my-itemdat) (let* ((new-test-record (let ((newrec (make-tests:testqueue))) (vector-copy! test-record newrec) newrec)) (my-item-path (item-list->path my-itemdat))) (if (patt-list-match my-item-path item-patts) ;; yes, we want to process this item, NOTE: Should not need this check here! - (let ((newtestname (conc hed "/" my-item-path))) ;; test names are unique on testname/item-path + (let ((newtestname (runs:make-full-test-name hed my-item-path))) ;; test names are unique on testname/item-path (tests:testqueue-set-items! new-test-record #f) (tests:testqueue-set-itemdat! new-test-record my-itemdat) (tests:testqueue-set-item_path! new-test-record my-item-path) (hash-table-set! test-records newtestname new-test-record) (set! tal (cons newtestname tal)))))) ;; since these are itemized create new test names testname/itempath items) (if (not (null? tal)) - (loop (car tal)(cdr tal)))) + (begin + (thread-sleep! *global-delta*) + (debug:print 4 "INFO: End of items list, looping with next") + (loop (car tal)(cdr tal) reruns)))) ;; if items is a proc then need to run items:get-items-from-config, get the list and loop ;; - but only do that if resources exist to kick off the job ((or (procedure? items)(eq? items 'have-procedure)) - (let ((can-run-more (runs:can-run-more-tests db test-record))) + (let ((can-run-more (open-run-close runs:can-run-more-tests #f test-record))) (if can-run-more - (let* ((prereqs-not-met (db:get-prereqs-not-met db run-id waitons item-path mode: testmode)) - (fails (calc-fails prereqs-not-met)) - (non-completed (calc-not-completed prereqs-not-met))) + (let* ((prereqs-not-met (open-run-close db:get-prereqs-not-met #f run-id waitons item-path mode: testmode)) + (fails (runs:calc-fails prereqs-not-met)) + (non-completed (runs:calc-not-completed prereqs-not-met))) (debug:print 8 "INFO: can-run-more: " can-run-more - "\n prereqs-not-met: " (pretty-string prereqs-not-met) - "\n non-completed: " (pretty-string non-completed) - "\n fails: " (pretty-string fails) + "\n testname: " hed + "\n prereqs-not-met: " (runs:pretty-string prereqs-not-met) + "\n non-completed: " (runs:pretty-string non-completed) + "\n fails: " (runs:pretty-string fails) "\n testmode: " testmode - "\n (eq? testmode 'toplevel) " (eq? testmode 'toplevel) - "\n (null? non-completed) " (null? non-completed)) - (cond + "\n num-retries: " num-retries + "\n (eq? testmode 'toplevel): " (eq? testmode 'toplevel) + "\n (null? non-completed): " (null? non-completed) + "\n reruns: " reruns) + + (cond ;; INNER COND #2 ((or (null? prereqs-not-met) ;; all prereqs met, fire off the test ;; or, if it is a 'toplevel test and all prereqs not met are COMPLETED then launch (and (eq? testmode 'toplevel) (null? non-completed))) (let ((test-name (tests:testqueue-get-testname test-record))) (setenv "MT_TEST_NAME" test-name) ;; (setenv "MT_RUNNAME" runname) - (set-megatest-env-vars db run-id) ;; these may be needed by the launching process + (open-run-close set-megatest-env-vars #f run-id) ;; these may be needed by the launching process (let ((items-list (items:get-items-from-config tconfig))) (if (list? items-list) (begin (tests:testqueue-set-items! test-record items-list) - (loop hed tal)) + (thread-sleep! *global-delta*) + (loop hed tal reruns)) (begin (debug:print 0 "ERROR: The proc from reading the setup did not yield a list - please report this") (exit 1)))))) ((null? fails) - (loop (car newtal)(cdr newtal))) ;; an issue with prereqs not yet met? + (debug:print 4 "INFO: fails is null, moving on in the queue but keeping " hed " for now") + (thread-sleep! *global-delta*) + (loop (car newtal)(cdr newtal) reruns)) ;; an issue with prereqs not yet met? ((and (not (null? fails))(eq? testmode 'normal)) (debug:print 1 "INFO: test " hed " (mode=" testmode ") has failed prerequisite(s); " (string-intersperse (map (lambda (t)(conc (db:test-get-testname t) ":" (db:test-get-state t)"/"(db:test-get-status t))) fails) ", ") ", removing it from to-do list") (if (not (null? tal)) - (loop (car tal)(cdr tal)))) + (begin + (thread-sleep! *global-delta*) + (loop (car tal)(cdr tal)(cons hed reruns))))) (else (debug:print 8 "ERROR: No handler for this condition.") - ;; "\n hed: " hed - ;; "\n fails: " (string-intersperse (map db:test-get-testname fails) ",") - ;; "\n testmode: " testmode - ;; "\n prereqs-not-met: " (pretty-string prereqs-not-met) - ;; "\n items: " items) - (loop (car newtal)(cdr newtal))))) + (thread-sleep! *global-delta*) + (loop (car newtal)(cdr newtal) reruns)))) ;; END OF IF CAN RUN MORE + ;; if can't run more just loop with next possible test - (loop (car newtal)(cdr newtal))))) + (begin + (debug:print 4 "INFO: processing the case with a lambda for items or 'have-procedure. Moving through the queue without dropping " hed) + (thread-sleep! (+ 1 *global-delta*)) + (loop (car newtal)(cdr newtal) reruns))))) ;; END OF (or (procedure? items)(eq? items 'have-procedure)) ;; this case should not happen, added to help catch any bugs ((and (list? items) itemdat) (debug:print 0 "ERROR: Should not have a list of items in a test and the itemspath set - please report this") - (exit 1)))) - - ;; we get here on "drop through" - loop for next test in queue - (if (null? tal) - (begin - ;; FIXME!!!! THIS SHOULD NOT REQUIRE AN EXIT!!!!!!! - (debug:print 1 "INFO: All tests launched") - (thread-sleep! 0.5) - ;; FIXME! This harsh exit should not be necessary.... - (if (not *runremote*)(exit)) ;; - #f) ;; return a #f as a hint that we are done - ;; Here we need to check that all the tests remaining to be run are eligible to run - ;; and are not blocked by failed - (let ((newlst (tests:filter-non-runnable db run-id tal test-records))) ;; i.e. not FAIL, WAIVED, INCOMPLETE, PASS, KILLED, - (thread-sleep! 0.1) + (exit 1)) + ((not (null? reruns)) + (let* ((newlst (open-run-close tests:filter-non-runnable #f run-id tal test-records)) ;; i.e. not FAIL, WAIVED, INCOMPLETE, PASS, KILLED, + (junked (lset-difference equal? tal newlst))) + (debug:print 4 "INFO: full drop through, if reruns is less than 100 we will force retry them, reruns=" reruns ", tal=" tal) + (if (< num-retries max-retries) + (set! newlst (append reruns newlst))) + (set! num-retries (+ num-retries 1)) + (thread-sleep! *global-delta*) (if (not (null? newlst)) - (loop (car newlst)(cdr newlst))))))))) + ;; since reruns have been tacked on to newlst create new reruns from junked + (loop (car newlst)(cdr newlst)(delete-duplicates junked))))) + ((not (null? tal)) + (debug:print 4 "INFO: I'm pretty sure I shouldn't get here.")) + (else + (debug:print 4 "INFO: Exiting loop with...\n hed=" hed "\n tal=" tal "\n reruns=" reruns)) + )))) ;; LET* ((test-record + + ;; we get here on "drop through" - loop for next test in queue + ;; FIXME!!!! THIS SHOULD NOT REQUIRE AN EXIT!!!!!!! + + (debug:print 1 "INFO: All tests launched") + (thread-sleep! 0.5) + ;; FIXME! This harsh exit should not be necessary.... + ;; (if (not *runremote*)(exit)) ;; + #f)) ;; return a #f as a hint that we are done + ;; Here we need to check that all the tests remaining to be run are eligible to run + ;; and are not blocked by failed + ;; parent-test is there as a placeholder for when parent-tests can be run as a setup step -(define (run:test db run-id runname keyvallst test-record flags parent-test) +(define (run:test run-id runname keyvallst test-record flags parent-test) ;; All these vars might be referenced by the testconfig file reader (let* ((test-name (tests:testqueue-get-testname test-record)) (test-waitons (tests:testqueue-get-waitons test-record)) (test-conf (tests:testqueue-get-testconfig test-record)) (itemdat (tests:testqueue-get-itemdat test-record)) (test-path (conc *toppath* "/tests/" test-name)) ;; could use tests:get-testconfig here ... (force (hash-table-ref/default flags "-force" #f)) (rerun (hash-table-ref/default flags "-rerun" #f)) (keepgoing (hash-table-ref/default flags "-keepgoing" #f)) - (item-path "")) - (debug:print 5 + (item-path "") + (db #f)) + (debug:print 4 "test-config: " (hash-table->alist test-conf) "\n itemdat: " itemdat ) ;; setting itemdat to a list if it is #f (if (not itemdat)(set! itemdat '())) (set! item-path (item-list->path itemdat)) - (debug:print 2 "Attempting to launch test " test-name "/" item-path) + (debug:print 2 "Attempting to launch test " test-name (if (equal? item-path "/") "/" item-path)) (setenv "MT_TEST_NAME" test-name) ;; (setenv "MT_RUNNAME" runname) - (set-megatest-env-vars db run-id) ;; these may be needed by the launching process + (open-run-close set-megatest-env-vars db run-id) ;; these may be needed by the launching process (change-directory *toppath*) ;; Here is where the test_meta table is best updated ;; Yes, another use of a global for caching. Need a better way? (if (not (hash-table-ref/default *test-meta-updated* test-name #f)) (begin (hash-table-set! *test-meta-updated* test-name #t) - (runs:update-test_meta db test-name test-conf))) + (open-run-close 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)) - (test-id #f)) + (test-id (open-run-close db:get-test-id db run-id test-name item-path)) + (testdat (open-run-close db:get-test-info-by-id db test-id))) (if (not testdat) (begin ;; ensure that the path exists before registering the test ;; NOPE: Cannot! Don't know yet which disk area will be assigned.... ;; (system (conc "mkdir -p " new-test-path)) - (rtests:register-test db run-id test-name item-path) - (set! testdat (db:get-test-info db run-id test-name item-path)))) + ;; + ;; (open-run-close tests:register-test db run-id test-name item-path) + ;; + ;; NB// for the above line. I want the test to be registered long before this routine gets called! + ;; + (set! test-id (open-run-close db:get-test-id db run-id test-name item-path)) + (if (not test-id) + (begin + (debug:print 2 "WARN: Test not pre-created? test-name=" test-name ", item-path=" item-path ", run-id=" run-id) + (open-run-close db:tests-register-test #f run-id test-name item-path) + (set! test-id (open-run-close db:get-test-id db run-id test-name item-path)))) + (debug:print 4 "INFO: test-id=" test-id ", run-id=" run-id ", test-name=" test-name ", item-path=\"" item-path "\"") + (set! testdat (open-run-close db:get-test-info-by-id db test-id)))) (set! test-id (db:test-get-id testdat)) (change-directory test-path) (case (if force ;; (args:get-arg "-force") 'NOT_STARTED (if testdat @@ -568,11 +666,11 @@ (debug:print 1 "NOTE: Not starting test " new-test-name " as it is state \"" (test:get-state testdat) "\" and status \"" (test:get-status testdat) "\", use -rerun \"" (test:get-status testdat) "\" or -force to override")) ;; NOTE: No longer be checking prerequisites here! Will never get here unless prereqs are ;; already met. - (if (not (launch-test db run-id runname test-conf keyvallst test-name test-path itemdat flags)) + (if (not (launch-test #f run-id runname test-conf keyvallst test-name test-path itemdat flags)) (begin (print "ERROR: Failed to launch the test. Exiting as soon as possible") (set! *globalexitstatus* 1) ;; (process-signal (current-process-id) signal/kill)))))) ((KILLED) @@ -581,11 +679,11 @@ (if (> (- (current-seconds)(+ (db:test-get-event_time testdat) (db:test-get-run_duration testdat))) 600) ;; i.e. no update for more than 600 seconds (begin (debug:print 0 "WARNING: Test " test-name " appears to be dead. Forcing it to state INCOMPLETE and status STUCK/DEAD") - (test-set-status! db test-id "INCOMPLETE" "STUCK/DEAD" "Test is stuck or dead" #f)) + (tests:test-set-status! test-id "INCOMPLETE" "STUCK/DEAD" "Test is stuck or dead" #f)) (debug:print 2 "NOTE: " test-name " is already running"))) (else (debug:print 0 "ERROR: Failed to launch test " new-test-name ". Unrecognised state " (test:get-state testdat))))))) ;;====================================================================== ;; END OF NEW STUFF @@ -603,13 +701,14 @@ ;; 'remove-runs ;; 'set-state-status ;; ;; NB// should pass in keys? ;; -(define (runs:operate-on db action runnamepatt testpatt itempatt #!key (state #f)(status #f)(new-state-status #f)) - (let* ((keys (rdb:get-keys db)) - (rundat (runs:get-runs-by-patt db keys runnamepatt)) +(define (runs:operate-on action runnamepatt testpatt itempatt #!key (state #f)(status #f)(new-state-status #f)) + (let* ((db #f) + (keys (open-run-close db:get-keys db)) + (rundat (open-run-close runs:get-runs-by-patt db keys runnamepatt)) (header (vector-ref rundat 0)) (runs (vector-ref rundat 1)) (states (if state (string-split state ",") '())) (statuses (if status (string-split status ",") '())) (state-status (if (string? new-state-status) (string-split new-state-status ",") '(#f #f)))) @@ -620,11 +719,11 @@ (db:get-value-by-header run header (vector-ref k 0))) keys) "/")) (dirs-to-remove (make-hash-table))) (let* ((run-id (db:get-value-by-header run header "id")) (run-state (db:get-value-by-header run header "state")) (tests (if (not (equal? run-state "locked")) - (rdb:get-tests-for-run db (db:get-value-by-header run header "id") + (open-run-close db:get-tests-for-run db (db:get-value-by-header run header "id") testpatt itempatt states statuses not-in: #f sort-by: (case action ((remove-runs) 'rundir) (else 'event_time))) @@ -642,15 +741,17 @@ (print "INFO: action not recognised " action))) (for-each (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))) + (run-dir (db:test-get-rundir test)) + (test-id (db:test-get-id test))) + ;; (tdb (db:open-test-db run-dir))) (debug:print 1 " " (db:test-get-testname test) " id: " (db:test-get-id test) " " item-path " action: " action) (case action - ((remove-runs) - (rdb:delete-test-records db (db:test-get-id test)) + ((remove-runs) ;; the tdb is for future possible. + (open-run-close db:delete-test-records db #f (db:test-get-id test)) (debug:print 1 "INFO: Attempting to remove dir " run-dir) (if (and (> (string-length run-dir) 5) (file-exists? run-dir)) ;; bad heuristic but should prevent /tmp /home etc. (let* ((realpath (resolve-pathname run-dir))) (debug:print 1 "INFO: Real path of is " realpath) @@ -668,23 +769,27 @@ (debug:print 0 "ERROR: refusing to remove " run-dir " as it is neither a symlink nor a directory") )))) (debug:print 0 "WARNING: directory already removed " run-dir))) ((set-state-status) (debug:print 2 "INFO: new state " (car state-status) ", new status " (cadr state-status)) - (db:test-set-state-status-by-id db (db:test-get-id test) (car state-status)(cadr state-status) #f))))) + (open-run-close db:test-set-state-status-by-id db (db:test-get-id test) (car state-status)(cadr state-status) #f))))) tests))) ;; remove the run if zero tests remain (if (eq? action 'remove-runs) - (let ((remtests (rdb:get-tests-for-run db (db:get-value-by-header run header "id") #f #f '() '()))) + (let ((remtests (open-run-close db:get-tests-for-run db (db:get-value-by-header run header "id") #f #f '("DELETED") '("n/a") not-in: #t))) (if (null? remtests) ;; no more tests remaining (let* ((dparts (string-split lasttpath "/")) (runpath (conc "/" (string-intersperse (take dparts (- (length dparts) 1)) "/")))) - (debug:print 1 "Removing run: " runkey " " (db:get-value-by-header run header "runname")) - (db:delete-run db run-id) + (debug:print 1 "Removing run: " runkey " " (db:get-value-by-header run header "runname") " and related record") + (open-run-close db:delete-run db run-id) + ;; This is a pretty good place to purge old DELETED tests + (open-run-close db:delete-tests-for-run db run-id) + (open-run-close db:delete-old-deleted-test-records db) + (open-run-close db:set-var db "DELETED_TESTS" (current-seconds)) ;; need to figure out the path to the run dir and remove it if empty ;; (if (null? (glob (conc runpath "/*"))) ;; (begin ;; (debug:print 1 "Removing run dir " runpath) ;; (system (conc "rmdir -p " runpath)))) @@ -716,26 +821,25 @@ (keys #f)) (if (not (setup-for-run)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) - (set! db (open-db)) (if (args:get-arg "-server") - (server:start db (args:get-arg "-server")) - (if (not (or (args:get-arg "-runall") - (args:get-arg "-runtests"))) - (server:client-setup db))) - (set! keys (rdb:get-keys db)) + (open-run-close server:start db (args:get-arg "-server")) + (if (not (or (args:get-arg "-runall") ;; runall and runtests are allowed to be servers + (args:get-arg "-runtests"))) + (server:client-setup))) + (set! keys (open-run-close 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) (keys:target-set-args keys (args:get-arg "-reqtarg") args:arg-hash) (begin (debug:print 0 "ERROR: [" (args:get-arg "-reqtarg") "] not found in " runconfigf) - (sqlite3:finalize! db) + (if db (sqlite3:finalize! db)) (exit 1)))) (if (args:get-arg "-target") (keys:target-set-args keys (args:get-arg "-target" args:arg-hash) args:arg-hash))) (if (not (car *configinfo*)) (begin @@ -743,54 +847,55 @@ (exit 1)) ;; Extract out stuff needed in most or many calls ;; here then call proc (let* ((keynames (map key:get-fieldname keys)) (keyvallst (keys->vallist keys #t))) - (proc db target runname keys keynames keyvallst))) + (proc target runname keys keynames keyvallst))) (if th1 (thread-join! th1)) - (sqlite3:finalize! db) + (if db (sqlite3:finalize! db)) (set! *didsomething* #t)))))) ;;====================================================================== ;; Lock/unlock runs ;;====================================================================== -(define (runs:handle-locking db target keys runname lock unlock user) - (let* ((rundat (runs:get-runs-by-patt db keys runname)) +(define (runs:handle-locking target keys runname lock unlock user) + (let* ((db #f) + (rundat (open-run-close runs:get-runs-by-patt db keys runname)) (header (vector-ref rundat 0)) (runs (vector-ref rundat 1))) (for-each (lambda (run) (let ((run-id (db:get-value-by-header run header "id"))) (if (or lock (and unlock (begin (print "Do you really wish to unlock run " run-id "?\n y/n: ") (equal? "y" (read-line))))) - (db:lock/unlock-run db run-id lock unlock user) + (open-run-close db:lock/unlock-run db run-id lock unlock user) (debug:print 0 "INFO: Skipping lock/unlock on " run-id)))) runs))) ;;====================================================================== ;; 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 (open-run-close db:testmeta-get-record db test-name))) (if (not currrecord) (begin (set! currrecord (make-vector 10 #f)) - (db:testmeta-add-record db test-name))) + (open-run-close db: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))) ;; (debug:print 5 "idx: " idx " fld: " fld " val: " val) (if (and val (not (equal? (vector-ref currrecord idx) val))) (begin (print "Updating " test-name " " fld " to " val) - (db:testmeta-update-field db test-name fld val))))) + (open-run-close db:testmeta-update-field db test-name fld val))))) '(("author" 2)("owner" 3)("description" 4)("reviewed" 5)("tags" 9))))) ;; Update test_meta for all tests (define (runs:update-all-test_meta db) (let ((test-names (get-all-legal-tests))) @@ -799,22 +904,23 @@ (let* ((test-path (conc *toppath* "/tests/" test-name)) (test-configf (conc test-path "/testconfig")) (testexists (and (file-exists? test-configf)(file-read-access? test-configf))) ;; read configs with tricks turned off (i.e. no system) (test-conf (if testexists (read-config test-configf #f #f)(make-hash-table)))) - (runs:update-test_meta db test-name test-conf))) + ;; use the open-run-close instead of passing in db + (runs:update-test_meta #f test-name test-conf))) test-names))) ;; This could probably be refactored into one complex query ... -(define (runs:rollup-run db keys keyvallst runname user) ;; was target, now keyvallst +(define (runs:rollup-run keys keyvallst runname user) ;; was target, now keyvallst (debug:print 4 "runs:rollup-run, keys: " keys " keyvallst: " keyvallst " :runname " runname " user: " user) - (let* (; (keyvalllst (keys:target->keyval keys target)) - (new-run-id (runs:register-run db keys keyvallst runname "new" "n/a" user)) - (prev-tests (test:get-matching-previous-test-run-records db new-run-id "%" "%")) - (curr-tests (rdb:get-tests-for-run db new-run-id "%" "%" '() '())) + (let* ((db #f) ;; (keyvalllst (keys:target->keyval keys target)) + (new-run-id (open-run-close runs:register-run db keys keyvallst runname "new" "n/a" user)) + (prev-tests (open-run-close test:get-matching-previous-test-run-records db new-run-id "%" "%")) + (curr-tests (open-run-close db:get-tests-for-run db new-run-id "%" "%" '() '())) (curr-tests-hash (make-hash-table))) - (db:update-run-event_time db new-run-id) + (open-run-close db:update-run-event_time db new-run-id) ;; index the already saved tests by testname and itemdat in curr-tests-hash (for-each (lambda (testdat) (let* ((testname (db:test-get-testname testdat)) (item-path (db:test-get-item-path testdat)) @@ -828,33 +934,35 @@ (lambda (testdat) (let* ((testname (db:test-get-testname testdat)) (item-path (db:test-get-item-path testdat)) (full-name (conc testname "/" item-path)) (prev-test-dat (hash-table-ref/default curr-tests-hash full-name #f)) - (test-steps (db:get-steps-for-test db (db:test-get-id testdat))) + (test-steps (open-run-close db:get-steps-for-test db (db:test-get-id testdat))) (new-test-record #f)) ;; replace these with insert ... select (apply sqlite3:execute db (conc "INSERT OR REPLACE INTO tests (run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment) " "VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?);") new-run-id (cddr (vector->list testdat))) - (set! new-testdat (car (rdb:get-tests-for-run db new-run-id testname item-path '() '()))) + (set! new-testdat (car (open-run-close db:get-tests-for-run db new-run-id testname item-path '() '()))) (hash-table-set! curr-tests-hash full-name new-testdat) ;; this could be confusing, which record should go into the lookup table? ;; Now duplicate the test steps (debug:print 4 "Copying records in test_steps from test_id=" (db:test-get-id testdat) " to " (db:test-get-id new-testdat)) - (sqlite3:execute - db - (conc "INSERT OR REPLACE INTO test_steps (test_id,stepname,state,status,event_time,comment) " - "SELECT " (db:test-get-id new-testdat) ",stepname,state,status,event_time,comment FROM test_steps WHERE test_id=?;") - (db:test-get-id testdat)) - ;; Now duplicate the test data - (debug:print 4 "Copying records in test_data from test_id=" (db:test-get-id testdat) " to " (db:test-get-id new-testdat)) - (sqlite3:execute - db - (conc "INSERT OR REPLACE INTO test_data (test_id,category,variable,value,expected,tol,units,comment) " - "SELECT " (db:test-get-id new-testdat) ",category,variable,value,expected,tol,units,comment FROM test_data WHERE test_id=?;") - (db:test-get-id testdat)) + (open-run-close + (lambda () + (sqlite3:execute + db + (conc "INSERT OR REPLACE INTO test_steps (test_id,stepname,state,status,event_time,comment) " + "SELECT " (db:test-get-id new-testdat) ",stepname,state,status,event_time,comment FROM test_steps WHERE test_id=?;") + (db:test-get-id testdat)) + ;; Now duplicate the test data + (debug:print 4 "Copying records in test_data from test_id=" (db:test-get-id testdat) " to " (db:test-get-id new-testdat)) + (sqlite3:execute + db + (conc "INSERT OR REPLACE INTO test_data (test_id,category,variable,value,expected,tol,units,comment) " + "SELECT " (db:test-get-id new-testdat) ",category,variable,value,expected,tol,units,comment FROM test_data WHERE test_id=?;") + (db:test-get-id testdat)))) )) prev-tests))) Index: server.scm ================================================================== --- server.scm +++ server.scm @@ -27,293 +27,181 @@ (define (server:autoremote procstr params) (handle-exceptions exn (begin (debug:print 1 "Remote failed for " proc " " params) - (apply (eval (string->symbol proc)) params)) - (if *runremote* - (apply (eval (string->symbol (conc "remote:" procstr))) params) - (eval (string->symbol procstr) params)))) + (apply (eval (string->symbol procstr)) params)) + ;; (if *runremote* + ;; (apply (eval (string->symbol (conc "remote:" procstr))) params) + (apply (eval (string->symbol procstr)) params))) (define (server:start db hostn) (debug:print 0 "Attempting to start the server ...") - (let* ((rpc:listener (server:find-free-port-and-open (rpc:default-server-port))) - (th1 (make-thread - (cute (rpc:make-server rpc:listener) "rpc:server") - 'rpc:server)) - (th2 (make-thread (lambda ()(db:updater db)))) - (hostname (if (string=? "-" hostn) - (get-host-name) - hostn)) - (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) - (set! *cache-on* #t) - - ;; can use this to run most anything at the remote - (rpc:publish-procedure! - 'remote:run - (lambda (procstr . params) - (server:autoremote procstr params))) - - ;;====================================================================== - ;; db specials here - ;;====================================================================== - ;; ** set-tests-state-status - (rpc:publish-procedure! - 'rdb:set-tests-state-status - (lambda (run-id testnames currstate currstatus newstate newstatus) - (set! *last-db-access* (current-seconds)) - (db:set-tests-state-status db run-id testnames currstate currstatus newstate newstatus))) - - (rpc:publish-procedure! - 'rdb:teststep-set-status! - (lambda (test-id teststep-name state-in status-in item-path comment logfile) - (set! *last-db-access* (current-seconds)) - (db:teststep-set-status! db test-id teststep-name state-in status-in item-path comment logfile))) - - (rpc:publish-procedure! - 'rdb:test-update-meta-info - (lambda (run-id testname item-path minutes cpuload diskfree tmpfree) - (set! *last-db-access* (current-seconds)) - (db:test-update-meta-info db run-id testname item-path minutes cpuload diskfree tmpfree))) - - (rpc:publish-procedure! - 'rdb:test-set-state-status-by-run-id-testname - (lambda (run-id test-name item-path status state) - (set! *last-db-access* (current-seconds)) - (db:test-set-state-status-by-run-id-testname db run-id test-name item-path status state))) - - (rpc:publish-procedure! - 'rdb:csv->test-data - (lambda (test-id csvdata) - (set! *last-db-access* (current-seconds)) - (db:csv->test-data db test-id csvdata))) - - (rpc:publish-procedure! - 'rdb:roll-up-pass-fail-counts - (lambda (run-id test-name item-path status) - (set! *last-db-access* (current-seconds)) - (db:roll-up-pass-fail-counts db run-id test-name item-path status))) - - (rpc:publish-procedure! - 'rdb:test-set-comment - (lambda (run-id test-name item-path comment) - (set! *last-db-access* (current-seconds)) - (db:test-set-comment db run-id test-name item-path comment))) - - (rpc:publish-procedure! - 'rdb:test-set-log! - (lambda (test-id logf) - (set! *last-db-access* (current-seconds)) - (db:test-set-log! db test-id logf))) - - (rpc:publish-procedure! - 'rdb:get-test-data-by-id - (lambda (test-id) - (set! *last-db-access* (current-seconds)) - (db:get-test-data-by-id db test-id))) - - (rpc:publish-procedure! - 'serve:get-toppath - (lambda () - (set! *last-db-access* (current-seconds)) - *toppath*)) - - (rpc:publish-procedure! - 'serve:login - (lambda (toppath) - (set! *last-db-access* (current-seconds)) - (if (equal? *toppath* toppath) - (begin - (debug:print 2 "INFO: login successful") - #t) - #f))) - - (rpc:publish-procedure! - 'rdb:get-runs - (lambda (runnamepatt numruns startrunoffset keypatts) - (set! *last-db-access* (current-seconds)) - (db:get-runs db runnamepatt numruns startrunoffset keypatts))) - - (rpc:publish-procedure! - 'rdb:get-tests-for-run - (lambda (run-id testpatt itempatt states statuses) - (set! *last-db-access* (current-seconds)) - (db:get-tests-for-run db run-id testpatt itempatt states statuses))) - - (rpc:publish-procedure! - 'rdb:get-keys - (lambda () - (set! *last-db-access* (current-seconds)) - (db:get-keys db))) - - (rpc:publish-procedure! - 'rdb:get-num-runs - (lambda (runpatt) - (set! *last-db-access* (current-seconds)) - (db:get-num-runs db runpatt))) - - (rpc:publish-procedure! - 'rdb:test-set-state-status-by-id - (lambda (test-id newstate newstatus newcomment) - (set! *last-db-access* (current-seconds)) - (db:test-set-state-status-by-id db test-id newstate newstatus newcomment))) - - (rpc:publish-procedure! - 'rdb:get-key-val-pairs - (lambda (run-id) - (set! *last-db-access* (current-seconds)) - (db:get-key-val-pairs db run-id))) - - (rpc:publish-procedure! - 'rdb:get-key-vals - (lambda (run-id) - (set! *last-db-access* (current-seconds)) - (db:get-key-vals db run-id))) - - (rpc:publish-procedure! - 'rdb:testmeta-get-record - (lambda (run-id) - (set! *last-db-access* (current-seconds)) - (db:testmeta-get-record db run-id))) - - (rpc:publish-procedure! - 'rdb:get-test-data-by-id - (lambda (test-id) - (set! *last-db-access* (current-seconds)) - (db:get-test-data-by-id db test-id))) - - (rpc:publish-procedure! - 'rdb:get-run-info - (lambda (run-id) - (set! *last-db-access* (current-seconds)) - (db:get-run-info db run-id))) - - (rpc:publish-procedure! - 'rdb:get-steps-for-test - (lambda (test-id) - (set! *last-db-access* (current-seconds)) - (db:get-steps-for-test db test-id))) - - (rpc:publish-procedure! - 'rdb:get-steps-table - (lambda (test-id) - (set! *last-db-access* (current-seconds)) - (db:get-steps-table db test-id))) - - (rpc:publish-procedure! - 'rdb:read-test-data - (lambda (test-id categorypatt) - (set! *last-db-access* (current-seconds)) - (db:read-test-data db test-id categorypatt))) - - (rpc:publish-procedure! - 'rdb:get-test-info - (lambda (run-id testname item-path) - (set! *last-db-access* (current-seconds)) - (db:get-test-info db run-id testname item-path))) - - (rpc:publish-procedure! - 'rdb:delete-test-records - (lambda (test-id) - (set! *last-db-access* (current-seconds)) - (db:delete-test-records db test-id))) - - (rpc:publish-procedure! - 'rtests:register-test - (lambda (run-id test-name item-path) - (set! *last-db-access* (current-seconds)) - (tests:register-test db run-id test-name item-path))) - - (rpc:publish-procedure! - 'rdb:test-data-rollup - (lambda (test-id status) - (set! *last-db-access* (current-seconds)) - (db:test-data-rollup db test-id status))) - - (rpc:publish-procedure! - 'rtests:test-set-status! - (lambda (test-id state status comment dat) - (set! *last-db-access* (current-seconds)) - (test-set-status! db test-id state status comment dat))) - - (rpc:publish-procedure! - 'rtests:test-set-toplog! - (lambda (run-id test-name logf) - (set! *last-db-access* (current-seconds)) - (test-set-toplog! db run-id test-name logf))) - - (rpc:publish-procedure! - 'db:test-get-paths-matching - (lambda (keynames target) - (set! *last-db-access* (current-seconds)) - (db:test-get-paths-matching db keynames target))) - - ;;====================================================================== - ;; end of publish-procedure section - ;;====================================================================== - - (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) - (thread-start! th2) - ;; (thread-join! th2) - ;; return th2 for the calling process to do a join with - th2 - )) ;; rpc:server))) - -(define (server:keep-running db) + (let ((host:port (db:get-var db "SERVER"))) ;; do whe already have a server running? + (if host:port + (set! *runremote* (let* ((lst (string-split host:port ":")) + (port (if (> (length lst) 1) + (string->number (cadr lst)) + #f))) + (if port (vector (car lst) port) #f))) + (let* ((rpc:listener (server:find-free-port-and-open (rpc:default-server-port))) + (th1 (make-thread + (cute (rpc:make-server rpc:listener) "rpc:server") + 'rpc:server)) + (th2 (make-thread (lambda ()(db:updater)))) + (hostname (if (string=? "-" hostn) + (get-host-name) + hostn)) + (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) + (set! *cache-on* #t) + + ;; can use this to run most anything at the remote + (rpc:publish-procedure! + 'remote:run + (lambda (procstr . params) + (server:autoremote procstr params))) + + (rpc:publish-procedure! + 'server:login + (lambda (toppath) + (set! *last-db-access* (current-seconds)) + (if (equal? *toppath* toppath) + (begin + (debug:print 2 "INFO: login successful") + #t) + #f))) + + ;;====================================================================== + ;; db specials here + ;;====================================================================== + ;; remote call to open-run-close + (rpc:publish-procedure! + 'rdb:open-run-close + (lambda (procname . remargs) + (debug:print 4 "INFO: Remote call of rdb:open-run-close " procname " " remargs) + (set! *last-db-access* (current-seconds)) + (apply open-run-close (eval procname) remargs))) + + (rpc:publish-procedure! + 'cdb:test-set-status-state + (lambda (test-id status state msg) + (debug:print 4 "INFO: Remote call of cdb:test-set-status-state test-id=" test-id ", status=" status ", state=" state ", msg=" msg) + (cdb:test-set-status-state test-id status state msg))) + + (rpc:publish-procedure! + 'cdb:test-rollup-test_data-pass-fail + (lambda (test-id) + (debug:print 4 "INFO: Remote call of cdb:test-rollup-test_data-pass-fail " test-id) + (cdb:test-rollup-test_data-pass-fail test-id))) + + (rpc:publish-procedure! + 'cdb:pass-fail-counts + (lambda (test-id fail-count pass-count) + (debug:print 4 "INFO: Remote call of cdb:pass-fail-counts " test-id " passes: " pass-count " fails: " fail-count) + (cdb:pass-fail-counts test-id fail-count pass-count))) + + (rpc:publish-procedure! + 'cdb:tests-register-test + (lambda (db run-id test-name item-path) + (debug:print 4 "INFO: Remote call of cdb:tests-register-test " run-id " testname: " test-name " item-path: " item-path) + (cdb:tests-register-test db run-id test-name item-path))) + + (rpc:publish-procedure! + 'cdb:flush-queue + (lambda () + (debug:print 4 "INFO: Remote call of cdb:flush-queue") + (cdb:flush-queue))) + + ;;====================================================================== + ;; end of publish-procedure section + ;;====================================================================== + + (set! *rpc:listener* rpc:listener) + (on-exit (lambda () + (open-run-close + (lambda (db . params) + (sqlite3:execute db "DELETE FROM metadat WHERE var='SERVER' and val=?;" host:port)) + #f ;; for db + #f) ;; for a param + (let loop ((n 0)) + (let ((queue-len 0)) + (thread-sleep! (random 5)) + (mutex-lock! *incoming-mutex*) + (set! queue-len (length *incoming-data*)) + (mutex-unlock! *incoming-mutex*) + (if (> queue-len 0) + (begin + (debug:print 0 "INFO: Queue not flushed, waiting ...") + (loop (+ n 1))))) + ))) + (thread-start! th1) + (debug:print 0 "Server started...") + (thread-start! th2) + ;; (thread-join! th2) + ;; return th2 for the calling process to do a join with + th2 + )))) ;; rpc:server))) + +(define (server:keep-running db host:port) ;; if none running or if > 20 seconds since ;; server last used then start shutdown (let loop ((count 0)) (thread-sleep! 20) ;; no need to do this very often (let ((numrunning (db:get-count-tests-running db))) (if (or (not (> numrunning 0)) - (> *last-db-access* (+ (current-seconds) 20))) + (> *last-db-access* (+ (current-seconds) 60))) (begin (debug:print 0 "INFO: Starting to shutdown the server side") - (sqlite3:execute db "DELETE FROM metadat WHERE var='SERVER'"); ;; AND val like ?;" - ;; host:port) ;; need to delete only *my* server entry (future use) + ;; need to delete only *my* server entry (future use) + (sqlite3:execute db "DELETE FROM metadat WHERE var='SERVER' AND val like ?;" host:port) (thread-sleep! 10) + (debug:print 0 "INFO: Max cached queries was " *max-cache-size*) (debug:print 0 "INFO: Server shutdown complete. Exiting") - (exit)))) + (exit)) + (debug:print 0 "INFO: Server continuing, tests running: " numrunning ", seconds since last db access: " (- (current-seconds) *last-db-access*)) + )) (loop (+ 1 count)))) (define (server:find-free-port-and-open port) (handle-exceptions exn (begin (print "Failed to bind to port " (rpc:default-server-port) ", trying next port") (server:find-free-port-and-open (+ port 1))) (rpc:default-server-port port) - (tcp-listen (rpc:default-server-port)))) + (tcp-read-timeout 120000) + (tcp-listen (rpc:default-server-port) ))) -(define (server:client-setup db) +(define (server:client-setup) (if *runremote* (begin (debug:print 0 "ERROR: Attempt to connect to server but already connected") #f) - (let* ((hostinfo (db:get-var db "SERVER")) - (hostdat (if hostinfo (string-split hostinfo ":"))) - (host (if hostinfo (car hostdat))) + (let* ((hostinfo (open-run-close db:get-var #f "SERVER")) + (hostdat (if hostinfo (string-split hostinfo ":") #f)) + (host (if hostinfo (car hostdat) #f)) (port (if (and hostinfo (> (length hostdat) 1))(cadr hostdat) #f))) (if (and port (string->number port)) (let ((portn (string->number port))) (debug:print 2 "INFO: Setting up to connect to host " host ":" port) (handle-exceptions exn (begin - (print "Exception: " exn) + (debug:print 0 "ERROR: Failed to open a connection to the server at host: " host " port: " port) + (debug:print 0 " EXCEPTION: " ((condition-property-accessor 'exn 'message) exn)) + ;; (open-run-close + ;; (lambda (db . param) + ;; (sqlite3:execute db "DELETE FROM metadat WHERE var='SERVER'")) + ;; #f) (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*)) + ((rpc:procedure 'server: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) Index: tests.scm ================================================================== --- tests.scm +++ tests.scm @@ -27,22 +27,10 @@ (include "key_records.scm") (include "db_records.scm") (include "run_records.scm") (include "test_records.scm") -(define (tests:register-test db run-id test-name item-path) - (let ((item-paths (if (equal? item-path "") - (list item-path) - (list item-path "")))) - (for-each - (lambda (pth) - (sqlite3:execute db "INSERT OR IGNORE INTO tests (run_id,testname,event_time,item_path,state,status) VALUES (?,?,strftime('%s','now'),?,'NOT_STARTED','n/a');" - run-id - test-name - pth)) - item-paths ))) - ;; get the previous record for when this test was run where all keys match but runname ;; returns #f if no such test found, returns a single test record if found (define (test:get-previous-test-run-record db run-id test-name item-path) (let* ((keys (db:get-keys db)) (selstr (string-intersperse (map (lambda (x)(vector-ref x 0)) keys) ",")) @@ -104,11 +92,11 @@ (debug:print 4 "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals ", previous run ids found: " prev-run-ids) (if (null? prev-run-ids) '() ;; no previous runs? return null (let loop ((hed (car prev-run-ids)) (tal (cdr prev-run-ids))) - (let ((results (rdb:get-tests-for-run db hed test-name item-path '() '()))) + (let ((results (db:get-tests-for-run db hed test-name item-path '() '()))) (debug:print 4 "Got tests for run-id " run-id ", test-name " test-name ", item-path " item-path " results: " (intersperse results "\n")) ;; Keep only the youngest of any test/item combination (for-each (lambda (testdat) @@ -122,22 +110,24 @@ results) (if (null? tal) (map cdr (hash-table->alist tests-hash)) ;; return a list of the most recent tests (loop (car tal)(cdr tal)))))))))) -;; -(define (test-set-status! db test-id state status comment dat) - (let* ((real-status status) +;; Do not rpc this one, do the underlying calls!!! +(define (tests:test-set-status! test-id state status comment dat) + (debug:print 4 "INFO: tests:test-set-status! test-id=" test-id ", state=" state ", status=" status ", dat=" dat) + (let* ((db #f) + (real-status status) (otherdat (if dat dat (make-hash-table))) - (testdat (db:get-test-data-by-id db test-id)) + (testdat (open-run-close db:get-test-info-by-id db test-id)) (run-id (db:test-get-run_id testdat)) (test-name (db:test-get-testname testdat)) (item-path (db:test-get-item-path testdat)) ;; before proceeding we must find out if the previous test (where all keys matched except runname) ;; was WAIVED if this test is FAIL (waived (if (equal? status "FAIL") - (let ((prev-test (test:get-previous-test-run-record db run-id test-name item-path))) + (let ((prev-test (open-run-close test:get-previous-test-run-record db run-id test-name item-path))) (if prev-test ;; true if we found a previous test in this run series (let ((prev-status (db:test-get-status prev-test)) (prev-state (db:test-get-state prev-test)) (prev-comment (db:test-get-comment prev-test))) (debug:print 4 "prev-status " prev-status ", prev-state " prev-state ", prev-comment " prev-comment) @@ -150,16 +140,16 @@ (if waived (set! real-status "WAIVED")) (debug:print 4 "real-status " real-status ", waived " waived ", status " status) ;; update the primary record IF state AND status are defined (if (and state status) - (rdb:test-set-state-status-by-run-id-testname db run-id test-name item-path real-status state)) - + (rdb:test-set-status-state test-id real-status state #f)) + ;; if status is "AUTO" then call rollup (note, this one modifies data in test ;; run area, do not rpc it (yet) (if (and test-id state status (equal? status "AUTO")) - (db:test-data-rollup db test-id status)) + (db:test-data-rollup #f test-id status)) ;; add metadata (need to do this way to avoid SQL injection issues) ;; :first_err ;; (let ((val (hash-table-ref/default otherdat ":first_err" #f))) @@ -189,24 +179,24 @@ expected "," tol "," units "," dcomment ",," ;; extra comma for status type ))) - (rdb:csv->test-data db test-id + (open-run-close db:csv->test-data db test-id dat)))) ;; need to update the top test record if PASS or FAIL and this is a subtest - (rdb:roll-up-pass-fail-counts db run-id test-name item-path status) + (open-run-close db:roll-up-pass-fail-counts db run-id test-name item-path status) (if (or (and (string? comment) (string-match (regexp "\\S+") comment)) waived) (let ((cmt (if waived waived comment))) - (rdb:test-set-comment db test-id cmt))) + (open-run-close db:test-set-comment db test-id cmt))) )) -(define (test-set-toplog! db run-id test-name logf) +(define (tests:test-set-toplog! db run-id test-name logf) (sqlite3:execute db "UPDATE tests SET final_logf=? WHERE run_id=? AND testname=? AND item_path='';" logf run-id test-name)) (define (tests:summarize-items db run-id test-name force) ;; if not force then only update the record if one of these is true: @@ -213,10 +203,11 @@ ;; 1. logf is "log/final.log ;; 2. logf is same as outputfilename (let ((outputfilename (conc "megatest-rollup-" test-name ".html")) (orig-dir (current-directory)) (logf #f)) + ;; This query finds the path and changes the directory to it for the test (sqlite3:for-each-row (lambda (path final_logf) (set! logf final_logf) (if (directory? path) (begin @@ -287,11 +278,11 @@ "ItemStateStatusComment" outtxt "") (release-dot-lock outputfilename))) (close-output-port oup) (change-directory orig-dir) - (test-set-toplog! db run-id test-name outputfilename) + (tests:test-set-toplog! db run-id test-name outputfilename) ))))) (define (get-all-legal-tests) (let* ((tests (glob (conc *toppath* "/tests/*"))) (res '())) @@ -364,11 +355,12 @@ (test-name (tests:testqueue-get-testname test-record)) (itemdat (tests:testqueue-get-itemdat test-record)) (item-path (tests:testqueue-get-item_path test-record)) (waitons (tests:testqueue-get-waitons test-record)) (keep-test #t) - (tdat (db:get-test-info db run-id test-name item-path))) + (test-id (db:get-test-id db run-id test-name item-path)) + (tdat (db:get-test-info-by-id db test-id))) (if tdat (begin ;; Look at the test state and status (if (or (member (db:test-get-status tdat) '("PASS" "WARN" "WAIVED" "CHECK")) @@ -379,11 +371,12 @@ ;; examine waitons for any fails. If it is FAIL or INCOMPLETE then eliminate this test ;; from the runnable list (if keep-test (for-each (lambda (waiton) ;; for now we are waiting only on the parent test - (let ((wtdat (db:get-test-info db run-id waiton ""))) + (let* ((parent-test-id (db:get-test-id db run-id waiton "")) + (wtdat (db:get-test-info-by-id db test-id))) (if (or (member (db:test-get-status wtdat) '("FAIL" "KILLED")) (member (db:test-get-state wtdat) '("INCOMPETE"))) (set! keep-test #f)))) ;; no point in running this one again @@ -396,29 +389,50 @@ ;; test steps ;;====================================================================== ;; teststep-set-status! used to be here -(define (test-get-kill-request db run-id test-name itemdat) - (let* ((item-path (item-list->path itemdat)) - (testdat (db:get-test-info db run-id test-name item-path))) +(define (test-get-kill-request db test-id) ;; run-id test-name itemdat) + (let* (;; (item-path (item-list->path itemdat)) + (testdat (db:get-test-info-by-id db test-id))) ;; run-id test-name item-path))) (equal? (test:get-state testdat) "KILLREQ"))) -(define (test-set-meta-info db run-id testname itemdat) - (let ((item-path (item-list->path itemdat)) - (cpuload (get-cpu-load)) - (hostname (get-host-name)) - (diskfree (get-df (current-directory))) - (uname (get-uname "-srvpio"))) - (sqlite3:execute db "UPDATE tests SET host=?,cpuload=?,diskfree=?,uname=? WHERE run_id=? AND testname=? AND item_path=?;" - hostname - cpuload - diskfree - uname - run-id - testname - item-path))) +(define (test:tdb-get-rundat-count tdb) + (if tdb + (let ((res 0)) + (sqlite3:for-each-row + (lambda (count) + (set! res count)) + tdb + "SELECT count(id) FROM test_rundat;") + res)) + 0) + +(define (test-set-meta-info db test-id run-id testname itemdat minutes) + (let* ((tdb (db:open-test-db-by-test-id db test-id)) + (num-records (test:tdb-get-rundat-count tdb)) + (item-path (item-list->path itemdat)) + (cpuload (get-cpu-load)) + (diskfree (get-df (current-directory)))) + (if (eq? (modulo num-records 10) 0) ;; every ten records update central + (begin + (sqlite3:execute db "UPDATE tests SET cpuload=?,diskfree=? WHERE run_id=? AND testname=? AND item_path=?;" + cpuload + diskfree + run-id + testname + item-path) + (if minutes (sqlite3:execute db "UPDATE tests SET run_duration=? WHERE id=?;" minutes test-id)) + (if (eq? num-records 0) + (let ((uname (get-uname "-srvpio")) + (hostname (get-host-name))) + (sqlite3:execute db "UPDATE tests SET uname=?,host=? WHERE run_id=? AND testname=? AND item_path=?;" + uname hostname run-id testname item-path))))) + + (sqlite3:execute tdb "INSERT INTO test_rundat (update_time,cpuload,diskfree,run_duration) VALUES (strftime('%s','now'),?,?,?);" + cpuload diskfree minutes))) + ;;====================================================================== ;; A R C H I V I N G ;;====================================================================== @@ -426,30 +440,5 @@ #f) (define (test:archive-tests db keynames target) #f) -;;====================================================================== -;; R P C -;;====================================================================== - -(define (rtests:register-test db run-id test-name item-path) - (if *runremote* - (let ((host (vector-ref *runremote* 0)) - (port (vector-ref *runremote* 1))) - ((rpc:procedure 'rtests:register-test host port) run-id test-name item-path)) - (tests:register-test db run-id test-name item-path))) - -(define (rtests:test-set-status! db test-id state status comment dat) - (if *runremote* - (let ((host (vector-ref *runremote* 0)) - (port (vector-ref *runremote* 1))) - ((rpc:procedure 'rtests:test-set-status! host port) test-id state status comment dat)) - (test-set-status! db test-id state status comment dat))) - -(define (rtests:test-set-toplog! db run-id test-name logf) - (if *runremote* - (let ((host (vector-ref *runremote* 0)) - (port (vector-ref *runremote* 1))) - ((rpc:procedure 'rtests:test-set-toplog! host port) run-id test-name logf)) - (test-set-toplog! db run-id test-name logf))) - Index: tests/Makefile ================================================================== --- tests/Makefile +++ tests/Makefile @@ -7,35 +7,45 @@ IPADDR := "-" # Set SERVER to "-server -" SERVER := DEBUG := 1 -all : test1 test 2 test3 +all : test1 test2 test3 test4 test5 test1 : cleanprep + rm -f simplerun/megatest.db + rm -rf simplelinks/ simpleruns/ mkdir -p simplelinks simpleruns + cd simplerun;cp ../../*_records.scm .;perl -pi.bak -e 's/define-inline/define/' *_records.scm cd simplerun;echo '(load "../tests.scm")' | $(MEGATEST) -repl -debug $(DEBUG) test2 : fullprep - cd fullrun;$(MEGATEST) -runtests ez_pass -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_a $(SERVER) + cd fullrun;$(MEGATEST) -runtests ez_pass,runfirst -reqtarg ubuntu/nfs/none -itempatt a/1 :runname $(RUNNAME)_a $(SERVER) test3 : fullprep cd fullrun;$(MEGATEST) -runtests runfirst -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_b $(SERVER) -debug 10 test4 : fullprep - cd fullrun;$(MEGATEST) -runall -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_b -m "This is a comment specific to a run" -v $(SERVER) + cd fullrun;$(MEGATEST) $(SERVER) & + cd fullrun;sleep 5;$(MEGATEST) -debug $(DEBUG) -runall -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_b -m "This is a comment specific to a run" -v +# NOTE: Only one instance can be a server test5 : fullprep - cd fullrun;$(MEGATEST) -runall -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_aa -v $(SERVER) 2&>1 aa.log & - cd fullrun;$(MEGATEST) -runall -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_ab -v $(SERVER) 2&>1 ab.log & - cd fullrun;$(MEGATEST) -runall -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_ac -v $(SERVER) 2&>1 ac.log & - cd fullrun;$(MEGATEST) -runall -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_ad -v $(SERVER) 2&>1 ad.log & + cd fullrun;$(MEGATEST) $(SERVER) & + cd fullrun;sleep 10;$(MEGATEST) -runall -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_aa -debug $(DEBUG) > aa.log 2> aa.log & + cd fullrun;sleep 10;$(MEGATEST) -runall -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_ab -debug $(DEBUG) > ab.log 2> ab.log & + cd fullrun;sleep 10;$(MEGATEST) -runall -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_ac -debug $(DEBUG) > ac.log 2> ac.log & + cd fullrun;sleep 10;$(MEGATEST) -runall -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_ad -debug $(DEBUG) > ad.log 2> ad.log & +# cd fullrun;sleep 10;$(MEGATEST) -runall -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_ae -debug $(DEBUG) > ae.log 2> ae.log & +# cd fullrun;sleep 10;$(MEGATEST) -runall -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_af -debug $(DEBUG) > af.log 2> af.log & + +test6: fullprep cd fullrun;$(MEGATEST) -runtests runfirst -itempatt %/1 -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_itempatt -v cd fullrun;$(MEGATEST) -runtests runfirst -itempatt %blahha% -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_itempatt -debug 10 cleanprep : ../*.scm Makefile */*.config - sqlite3 megatest.db "delete from metadat where var='SERVER';" + # if [ -e fullrun/megatest.db ]; then sqlite3 fullrun/megatest.db "delete from metadat where var='SERVER';";fi mkdir -p /tmp/mt_runs /tmp/mt_links cd ..;make install touch cleanprep fullprep : cleanprep Index: tests/fullrun/megatest.config ================================================================== --- tests/fullrun/megatest.config +++ tests/fullrun/megatest.config @@ -6,14 +6,20 @@ # refareas can be searched to find previous runs # the path points to where megatest.db exists [refareas] area1 /tmp/oldarea/megatest -[include config/mt_include_1.config] +[include #{getenv MT_RUN_AREA_HOME}/config/mt_include_1.config] [setup] -synchronous yes +# FULL or 2, NORMAL or 1, OFF or 0 +synchronous OFF +# Throttle roughly scales the db access milliseconds to seconds delay +throttle 0.2 +# Max retries allows megatest to re-check that a tests status has changed +# as tests can have transient FAIL status occasionally +maxretries 500 [validvalues] state start end status pass fail n/a 0 1 running @@ -29,10 +35,11 @@ WACKYVAR3 #{getenv USER} WACKYVAR4 #{scheme (+ 5 6 7)} WACKYVAR5 #{getenv sysname}/#{getenv fsname}/#{getenv datapath} WACKYVAR6 #{scheme (args:get-arg "-target")} PREDICTABLE the_ans +MRAH MT_RUN_AREA_HOME=#{getenv MT_RUN_AREA_HOME} # XTERM [system xterm] # RUNDEAD [system exit 56] ## disks are: Index: tests/simplerun/megatest.config ================================================================== --- tests/simplerun/megatest.config +++ tests/simplerun/megatest.config @@ -5,11 +5,11 @@ [setup] # Adjust max_concurrent_jobs to limit how much you load your machines max_concurrent_jobs 50 # This is your link path, you can move it but it is generally better to keep it stable -linktree ../simplelinks +linktree #{shell realpath #{getenv PWD}/../simplelinks} # Valid values for state and status for steps, NB// It is not recommended you use this [validvalues] state start end completed @@ -22,6 +22,6 @@ [env-override] EXAMPLE_VAR example value # As you run more tests you may need to add additional disks, the names are arbitrary but must be unique [disks] -disk0 ../simpleruns +disk0 #{shell realpath #{getenv PWD}/../simpleruns} Index: tests/simplerun/tests/test1/step1.sh ================================================================== --- tests/simplerun/tests/test1/step1.sh +++ tests/simplerun/tests/test1/step1.sh @@ -1,3 +1,4 @@ #!/usr/bin/env bash # Run your step here +echo Got here! Index: tests/simplerun/tests/test1/step2.sh ================================================================== --- tests/simplerun/tests/test1/step2.sh +++ tests/simplerun/tests/test1/step2.sh @@ -1,3 +1,5 @@ #!/usr/bin/env bash # Run your step here +echo Got here eh! + Index: tests/simplerun/tests/test1/testconfig ================================================================== --- tests/simplerun/tests/test1/testconfig +++ tests/simplerun/tests/test1/testconfig @@ -3,16 +3,16 @@ step1 step1.sh step2 step2.sh # Test requirements are specified here [requirements] -waiton setup +# waiton setup priority 0 # Iteration for your tests are controlled by the items section [items] -PARTOFDAY morning noon afternoon evening night +# PARTOFDAY morning noon afternoon evening night # test_meta is a section for storing additional data on your test [test_meta] author matt owner matt Index: tests/tests.scm ================================================================== --- tests/tests.scm +++ tests/tests.scm @@ -1,8 +1,16 @@ (require-extension test) (define test-work-dir (current-directory)) + +;; read in all the _record files +(let ((files (glob "*_records.scm"))) + (for-each + (lambda (file) + (print "Loading " file) + (load file)) + files)) (define conffile #f) (test "Read a config" #t (hash-table? (read-config "test.config" #f #f))) (test "Read a config that doesn't exist" #t (hash-table? (read-config "nada.config" #f #f))) @@ -52,13 +60,20 @@ (test "get all legal tests" (list "test1" "test2") (sort (get-all-legal-tests) string<=?)) (test "register-test, test info" "NOT_STARTED" (begin - (tests:register-test *db* 1 "nada" "") + (rdb:tests-register-test *db* 1 "nada" "") + ;; (rdb:flush-queue) (vector-ref (db:get-test-info *db* 1 "nada" "") 3))) +(test #f "NOT_STARTED" + (begin + (rdb:tests-register-test #f 1 "nada" "") + ;; (rdb:flush-queue) + (vector-ref (open-run-close db:get-test-info #f 1 "nada" "") 3))) + (test "get-keys" "SYSTEM" (vector-ref (car (db:get-keys *db*)) 0));; (key:get-fieldname (car (sort (db-get-keys *db*)(lambda (a b)(string>=? (vector-ref a 0)(vector-ref b 0))))))) (define remargs (args:get-args '("bar" "foo" ":runname" "bob" ":sysname" "ubuntu" ":fsname" "nfs" ":datapath" "blah/foo" "nada") (list ":runname" ":state" ":status") @@ -102,39 +117,155 @@ ;; force keepgoing ; (hash-table-set! args:arg-hash "-keepgoing" #t) (hash-table-set! args:arg-hash "-itempatt" "%") (hash-table-set! args:arg-hash "-testpatt" "%") +(hash-table-set! args:arg-hash "-target" "ubuntu/r1.2") (test "Setup for a run" #t (begin (setup-for-run) #t)) +(define *tdb* #f) + +(define testdbpath (conc "/tmp/" (getenv "USER") "/megatest_testing")) +(system (conc "rm -f " testdbpath "/testdat.db;mkdir -p " testdbpath)) + +(print "Using " testdbpath " for test db") +(test #f #t (let ((db (open-test-db testdbpath))) + (set! *tdb* db) + (sqlite3#database? db))) +(sqlite3#finalize! *tdb*) ;; (test "Remove the rollup run" #t (begin (remove-runs) #t)) - +(define tconfig #f) +(test "get a testconfig" #t (let ((tconf (tests:get-testconfig "test1" 'return-procs))) + (set! tconfig tconf) + (hash-table? tconf))) +(db:clean-all-caches) +;; (set! *verbosity* 20) (test "Run a test" #t (general-run-call "-runtests" - "run a test" - (lambda (db keys keynames keyvallst) - (let ((test-names '("runfirst"))) - (run-tests db test-names))))) + "run a test" + (lambda (target runname keys keynames keyvallst) + (let ((test-patts "test%")) + ;; (runs:run-tests target runname test-patts user (make-hash-table)) + (run:test 1 ;; run-id + (args:get-arg ":runname") + (keys:target->keyval keys target) + (vector + "test1" ;; testname + tconfig ;; testconfig + '() ;; waitons + 0 ;; priority + #f ;; items + #f ;; itemsdat + #f ;; spare + ) + args:arg-hash ;; flags (e.g. -itemspatt) + #f))))) + +(test "cache is coherent" #t (let ((cached-info (db:get-test-info-cached-by-id db 2)) + (non-cached (db:get-test-info-not-cached-by-id db 2))) + (print "\nCached: " cached-info) + (print "Noncached: " non-cached) + (equal? cached-info non-cached))) (change-directory test-work-dir) (test "Add a step" #t (begin - (teststep-set-status! db 1 "runfirst" "firststep" "start" 0 '() "This is a comment") + (db:teststep-set-status! db 2 "step1" "start" 0 "This is a comment" "mylogfile.html") (sleep 2) - (teststep-set-status! db 1 "runfirst" "firststep" "end" "pass" '() "This is a different comment") - (set! test-id (db:test-get-id (car (db-get-tests-for-run db 1 "runfirst" "")))) + (db:teststep-set-status! db 2 "step1" "end" "pass" "This is a different comment" "finallogfile.html") + (set! test-id (db:test-get-id (car (db:get-tests-for-run db 1 "test1" "" '() '())))) (number? test-id))) -(test "Get nice table for steps" "2.0s" +(test "Get rundir" #t (let ((rundir (db:test-get-rundir-from-test-id db test-id))) + (print "Rundir" rundir) + (string? rundir))) +(test "Create a test db" "../simpleruns/key1/key2/myrun/test1/testdat.db" (let ((tdb (db:open-test-db-by-test-id db test-id))) + (sqlite3#finalize! tdb) + (file-exists? "../simpleruns/key1/key2/myrun/test1/testdat.db"))) +(test "Get steps for test" #t (> (length (db:get-steps-for-test db test-id)) 0)) +(test "Get nice table for steps" "2s" (begin - (vector-ref (hash-table-ref (db:get-steps-table db test-id) "firststep") 4))) + (vector-ref (hash-table-ref (db:get-steps-table db test-id) "step1") 4))) + +;;====================================================================== +;; R E M O T E C A L L S +;;====================================================================== -(hash-table-set! args:arg-hash ":runname" "rollup") +;; start a server process +(set! *verbosity* 10) +(define server-pid (process-run "../../bin/megatest" (list "-server" "-" "-debug" (conc *verbosity*)))) +(sleep 2) +(define start-wait (current-seconds)) +(server:client-setup) +(print "Starting intensive cache and rpc test") +(for-each (lambda (params) + ;;; (rdb:tests-register-test #f 1 (conc "test" (random 20)) "") + (apply rdb:test-set-status-state test-id params) + (rdb:pass-fail-counts test-id (random 100) (random 100)) + (rdb:test-rollup-test_data-pass-fail test-id) + (thread-sleep! 0.01)) ;; cache ordering granularity is at the second level. Should really be at the ms level + '(("COMPLETED" "PASS" #f) + ("NOT_STARTED" "FAIL" "Just testing") + ("NOT_STARTED" "FAIL" "Just testing") + ("NOT_STARTED" "FAIL" "Just testing") + ("COMPLETED" "PASS" #f) + ("NOT_STARTED" "FAIL" "Just testing") + ("KILLED" "UNKNOWN" "More testing") + ("NOT_STARTED" "FAIL" "Just testing") + ("NOT_STARTED" "FAIL" "Just testing") + ("COMPLETED" "PASS" #f) + ("NOT_STARTED" "FAIL" "Just testing") + ("NOT_STARTED" "FAIL" "Just testing") + ("KILLED" "UNKNOWN" "More testing") + ("NOT_STARTED" "FAIL" "Just testing") + ("COMPLETED" "PASS" #f) + ("NOT_STARTED" "FAIL" "Just testing") + ("KILLED" "UNKNOWN" "More testing") + ("NOT_STARTED" "FAIL" "Just testing") + ("NOT_STARTED" "FAIL" "Just testing") + ("COMPLETED" "PASS" #f) + ("NOT_STARTED" "FAIL" "Just testing") + ("NOT_STARTED" "FAIL" "Just testing") + ("KILLED" "UNKNOWN" "More testing") + ("NOT_STARTED" "FAIL" "Just testing") + ("COMPLETED" "PASS" #f) + ("NOT_STARTED" "FAIL" "Just testing") + ("NOT_STARTED" "FAIL" "Just testing") + ("KILLED" "UNKNOWN" "More testing") + ("NOT_STARTED" "FAIL" "Just testing") + ("NOT_STARTED" "FAIL" "Just testing") + ("COMPLETED" "PASS" #f) + ("NOT_STARTED" "FAIL" "Just testing") + ("KILLED" "UNKNOWN" "More testing") + ("NOT_STARTED" "FAIL" "Just testing") + ("NOT_STARTED" "FAIL" "Just testing") + ("COMPLETED" "PASS" #f) + ("NOT_STARTED" "FAIL" "Just testing") + ("KILLED" "UNKNOWN" "More testing") + ("KILLED" "UNKNOWN" "More testing") + )) +;; now set all tests to completed +(rdb:flush-queue) +(let ((tests (open-run-close db:get-tests-for-run #f 1 "%" "%" '() '()))) + (print "Setting " (length tests) " to COMPLETED/PASS") + (for-each + (lambda (test) + (rdb:test-set-status-state (db:test-get-id test) "COMPLETED" "PASS" "Forced pass")) + tests)) -(test "Remove the rollup run" #t (begin (remove-runs) #t)) +(print "Waiting for server to be done, should be about 20 seconds") +(process-wait server-pid) +(test "Server wait time" #t (let ((run-delta (- (current-seconds) start-wait))) + (print "Server ran for " run-delta " seconds") + (> run-delta 20))) + (test "Rollup the run(s)" #t (begin - (runs:rollup-run db keys) + (runs:rollup-run keys (keys->alist keys "na") "rollup" "matt") #t)) +(hash-table-set! args:arg-hash ":runname" "%") + +(test "Remove the rollup run" #t (begin (operate-on 'remove-runs))) + ;; ADD ME!!!! (db:get-prereqs-not-met *db* 1 '("runfirst") "" mode: 'normal) ;; ADD ME!!!! (rdb:get-tests-for-run *db* 1 "runfirst" #f '() '())