Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -4,13 +4,13 @@ INSTALL=install SRCFILES = common.scm items.scm launch.scm \ ods.scm runconfig.scm server.scm configf.scm \ db.scm keys.scm margs.scm megatest-version.scm \ process.scm runs.scm tasks.scm tests.scm genexample.scm \ - fs-transport.scm http-transport.scm \ + fs-transport.scm http-transport.scm filedb.scm \ client.scm gutils.scm synchash.scm daemon.scm mt.scm dcommon.scm \ - tree.scm ezsteps.scm lock-queue.scm sdb.scm filedb.scm \ + tree.scm ezsteps.scm lock-queue.scm sdb.scm \ rmt.scm api.scm tdb.scm GUISRCF = dashboard-tests.scm dashboard-guimonitor.scm OFILES = $(SRCFILES:%.scm=%.o) @@ -105,10 +105,14 @@ chmod a+x $@ $(PREFIX)/bin/nbfind : utils/nbfind $(INSTALL) $< $@ chmod a+x $@ + +$(PREFIX)/bin/loadrunner : utils/loadrunner + $(INSTALL) $< $@ + chmod a+x $@ $(PREFIX)/bin/refdb : refdb $(INSTALL) $< $@ chmod a+x $@ @@ -126,11 +130,11 @@ $(INSTALL) dboard $(PREFIX)/bin/dboard utils/mk_wrapper $(PREFIX) dboard > $(PREFIX)/bin/dashboard chmod a+x $(PREFIX)/bin/dashboard install : bin $(PREFIX)/bin/mtest $(PREFIX)/bin/megatest $(PREFIX)/bin/dboard $(PREFIX)/bin/dashboard $(HELPERS) $(PREFIX)/bin/nbfake \ - $(PREFIX)/bin/nbfind $(PREFIX)/bin/newdboard $(PREFIX)/bin/refdb $(PREFIX)/bin/mt_xterm $(PREFIX)/bin/revtagfsl + $(PREFIX)/bin/nbfind $(PREFIX)/bin/loadrunner $(PREFIX)/bin/newdboard $(PREFIX)/bin/refdb $(PREFIX)/bin/mt_xterm $(PREFIX)/bin/revtagfsl deploytarg/apropos.so : Makefile for i in apropos base64 canvas-draw csv-xml directory-utils dot-locking extras fmt format hostinfo http-client intarweb json md5 message-digest posix posix-extras readline regex regex-case s11n spiffy spiffy-request-vars sqlite3 srfi-1 srfi-18 srfi-69 tcp test uri-common check-errors synch matchable sql-null tcp-server rpc blob-utils string-utils variable-item defstruct uri-generic sendfile opensll openssl lookup-table list-utils stack; do \ chicken-install -prefix deploytarg -deploy $$i;done Index: api.scm ================================================================== --- api.scm +++ api.scm @@ -13,65 +13,68 @@ (declare (uses rmt)) (declare (uses db)) ;; These are called by the server on recipt of /api calls -(define (api:execute-requests db cmd params) +(define (api:execute-requests dbstruct cmd params) (case (string->symbol cmd) ;; KEYS - ((get-key-val-pairs) (apply db:get-key-val-pairs db params)) - ((get-keys) (db:get-keys db)) + ((get-key-val-pairs) (apply db:get-key-val-pairs dbstruct params)) + ((get-keys) (db:get-keys dbstruct)) ;; TESTS ;; json doesn't do vectors, convert to list - ((get-test-info-by-id) (apply db:get-test-info-by-id db params)) - ((test-get-rundir-from-test-id) (apply db:test-get-rundir-from-test-id db params)) - ((test-set-state-status-by-id) (apply db:test-set-state-status-by-id db params)) - ((get-count-tests-running) (db:get-count-tests-running db)) - ((get-count-tests-running-in-jobgroup) (apply db:get-count-tests-running-in-jobgroup db params)) - ((delete-test-records) (apply db:delete-test-records db params)) - ((delete-old-deleted-test-records) (db:delete-old-deleted-test-records db)) - ((test-set-status-state) (apply db:test-set-status-state db params)) - ((get-previous-test-run-record) (apply db:get-previous-test-run-record db params)) - ((get-matching-previous-test-run-records)(apply db:get-matching-previous-test-run-records db params)) - ((db:test-get-logfile-info) (apply db:test-get-logfile-info db params)) - ((test-get-records-for-index-file (apply db:test-get-records-for-index-file db params))) - ((get-testinfo-state-status) (apply db:get-testinfo-state-status db params)) - ((test-get-paths-matching-keynames-target-new) (apply db:test-get-paths-matching-keynames-target-new db params)) - ((get-prereqs-not-met) (apply db:get-prereqs-not-met db params)) - ((roll-up-pass-fail-counts) (apply db:roll-up-pass-fail-counts db params)) - ((update-fail-pass-counts) (apply db:general-call db 'update-pass-fail-counts params)) - ((get-count-tests-running-for-run-id) (apply db:get-count-tests-running-for-run-id db params)) + ((get-test-info-by-id) (apply db:get-test-info-by-id dbstruct params)) + ((test-get-rundir-from-test-id) (apply db:test-get-rundir-from-test-id dbstruct params)) + ((test-set-state-status-by-id) (apply db:test-set-state-status-by-id dbstruct params)) + ((get-count-tests-running) (apply db:get-count-tests-running dbstruct params)) + ((get-count-tests-running-in-jobgroup) (apply db:get-count-tests-running-in-jobgroup dbstruct params)) + ((delete-test-records) (apply db:delete-test-records dbstruct params)) + ((delete-old-deleted-test-records) (apply db:delete-old-deleted-test-records dbstruct params)) + ((test-set-status-state) (apply db:test-set-status-state dbstruct params)) + ((get-previous-test-run-record) (apply db:get-previous-test-run-record dbstruct params)) + ((get-matching-previous-test-run-records)(apply db:get-matching-previous-test-run-records dbstruct params)) + ((db:test-get-logfile-info) (apply db:test-get-logfile-info dbstruct params)) + ((test-get-records-for-index-file (apply db:test-get-records-for-index-file dbstruct params))) + ((get-testinfo-state-status) (apply db:get-testinfo-state-status dbstruct params)) + ((test-get-paths-matching-keynames-target-new) (apply db:test-get-paths-matching-keynames-target-new dbstruct params)) + ((get-prereqs-not-met) (apply db:get-prereqs-not-met dbstruct params)) + ((roll-up-pass-fail-counts) (apply db:roll-up-pass-fail-counts dbstruct params)) + ((update-fail-pass-counts) (apply db:general-call dbstruct 'update-pass-fail-counts params)) + ((get-count-tests-running-for-run-id) (apply db:get-count-tests-running-for-run-id dbstruct params)) ;; RUNS - ((get-run-info) (apply db:get-run-info db params)) - ((register-run) (apply db:register-run db params)) - ((set-tests-state-status) (apply db:set-tests-state-status db params)) - ((get-tests-for-run) (apply db:get-tests-for-run db params)) - ((get-test-id) (apply db:get-test-id-not-cached db params)) - ((get-tests-for-runs-mindata) (apply db:get-tests-for-runs-mindata db params)) - ((get-run-name-from-id) (apply db:get-run-name-from-id db params)) - ((delete-run) (apply db:delete-run db params)) - ((get-runs) (apply db:get-runs db params)) - ((get-runs-by-patt) (apply db:get-runs-by-patt db params)) - ((lock/unlock-run) (apply db:lock/unlock-run db params)) - ((update-run-event_time) (apply db:update-run-event_time db params)) + ((get-run-info) (apply db:get-run-info dbstruct params)) + ((register-run) (apply db:register-run dbstruct params)) + ((set-tests-state-status) (apply db:set-tests-state-status dbstruct params)) + ((get-tests-for-run) (apply db:get-tests-for-run dbstruct params)) + ((get-test-id) (apply db:get-test-id dbstruct params)) + ((get-tests-for-runs-mindata) (apply db:get-tests-for-runs-mindata dbstruct params)) + ((get-run-name-from-id) (apply db:get-run-name-from-id dbstruct params)) + ((delete-run) (apply db:delete-run dbstruct params)) + ((get-runs) (apply db:get-runs dbstruct params)) + ((get-runs-by-patt) (apply db:get-runs-by-patt dbstruct params)) + ((lock/unlock-run) (apply db:lock/unlock-run dbstruct params)) + ((update-run-event_time) (apply db:update-run-event_time dbstruct params)) ;; STEPS - ((teststep-set-status!) (apply db:teststep-set-status! db params)) + ((teststep-set-status!) (apply db:teststep-set-status! dbstruct params)) ;; TEST DATA - ((test-data-rollup) (apply db:test-data-rollup db params)) - ((csv->test-data) (apply db:csv->test-data db params)) - ((get-steps-data) (apply db:get-steps-data db params)) + ((test-data-rollup) (apply db:test-data-rollup dbstruct params)) + ((csv->test-data) (apply db:csv->test-data dbstruct params)) + ((get-steps-data) (apply db:get-steps-data dbstruct params)) ;; MISC - ((login) (apply db:login db params)) + ((login) (apply db:login dbstruct params)) ((general-call) (let ((stmtname (car params)) - (realparams (cdr params))) - (db:general-call db stmtname realparams))) - ((sync-inmem->db) (db:sync-back)) + (run-id (cadr params)) + (realparams (cddr params))) + (db:with-db dbstruct run-id #t ;; these are all for modifying the db + (lambda (db) + (db:general-call db stmtname realparams))))) + ((sync-inmem->db) (db:sync-touched dbstruct force-sync: #t)) ((kill-server) (db:sync-tables (db:tbls *inmemdb*) *inmemdb* *db*) ;; (db:sync-to *inmemdb* *db*) (let ((hostname (car *runremote*)) (port (cadr *runremote*)) (pid (if (null? params) #f (car params))) @@ -85,29 +88,30 @@ (thread-sleep! 3) (if pid (process-signal pid signal/kill) (thread-start! th1)) '(#t "exit process started"))) + ((sdb-qry) (apply sdb:qry params)) ;; TESTMETA - ((testmeta-get-record) (apply db:testmeta-get-record db params)) - ((testmeta-add-record) (apply db:testmeta-add-record db params)) - ((testmeta-update-field) (apply db:testmeta-update-field db params)) + ((testmeta-get-record) (apply db:testmeta-get-record dbstruct params)) + ((testmeta-add-record) (apply db:testmeta-add-record dbstruct params)) + ((testmeta-update-field) (apply db:testmeta-update-field dbstruct params)) (else (list "ERROR" 0)))) ;; http-server send-response ;; api:process-request ;; db:* ;; ;; NB// Runs on the server as part of the server loop ;; -(define (api:process-request db $) ;; the $ is the request vars proc +(define (api:process-request dbstruct $) ;; the $ is the request vars proc (let* ((cmd ($ 'cmd)) (paramsj ($ 'params)) (params (db:string->obj paramsj)) ;; (rmt:json-str->dat paramsj)) - (res (api:execute-requests db cmd params))) + (res (api:execute-requests dbstruct cmd params))) ;; This can be here but needs controls to ensure it doesn't run more than every 4 seconds ;; (rmt:dat->json-str ;; (if (or (string? res) ;; (list? res) Index: client.scm ================================================================== --- client.scm +++ client.scm @@ -57,30 +57,35 @@ (if (not (setup-for-run)) (begin (debug:print 0 "ERROR: failed to find megatest.config, exiting") (exit)))) (push-directory *toppath*) ;; This is probably NOT needed + ;; clients get the sdb:qry proc created here + ;; (if (not sdb:qry) + ;; (begin + ;; (set! sdb:qry (make-sdb:qry (conc *toppath* "/db/strings.db"))) ;; we open the normalization helpers here + ;; (sdb:qry 'setup #f))) + (debug:print-info 11 "*transport-type* is " *transport-type* ", *runremote* is " *runremote*) (let* ((hostinfo (open-run-close tasks:get-best-server tasks:open-db))) (debug:print-info 11 "CLIENT SETUP, hostinfo=" hostinfo) (set! *transport-type* (if hostinfo (string->symbol (tasks:hostinfo-get-transport hostinfo)) 'fs)) (debug:print-info 11 "Using transport type of " *transport-type* (if hostinfo (conc " to connect to " hostinfo) "")) (case *transport-type* - ((fs)(if (not *megatest-db*)(set! *megatest-db* (open-db)))) + ;; ((fs)(if (not *megatest-db*)(set! *megatest-db* (open-db)))) ((http) (http-transport:client-connect (tasks:hostinfo-get-interface hostinfo) (tasks:hostinfo-get-port hostinfo))) ((zmq) (zmq-transport:client-connect (tasks:hostinfo-get-interface hostinfo) (tasks:hostinfo-get-port hostinfo) (tasks:hostinfo-get-pubport hostinfo))) (else ;; default to fs - (debug:print 0 "ERROR: unrecognised transport type " *transport-type* " attempting to continue with fs") - (set! *transport-type* 'fs) - (set! *megatest-db* (open-db)))) + (debug:print 0 "ERROR: unrecognised transport type " *transport-type* " exiting now.") + (exit))) (pop-directory))) ;; client:signal-handler (define (client:signal-handler signum) (handle-exceptions Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -38,10 +38,13 @@ (define *waiting-queue* (make-hash-table)) (define *test-meta-updated* (make-hash-table)) (define *globalexitstatus* 0) ;; attempt to work around possible thread issues (define *passnum* 0) ;; when running track calls to run-tests or similar +;; DATABASE +(define *open-dbs* (vector #f (make-hash-table))) ;; megatestdb run-id-dbs + ;; SERVER (define *my-client-signature* #f) (define *transport-type* 'fs) (define *megatest-db* #f) (define *rpc:listener* #f) ;; if set up for server communication this will hold the tcp port @@ -90,10 +93,15 @@ (set! *test-ids* (make-hash-table)) (set! *test-info* (make-hash-table)) (set! *run-info-cache* (make-hash-table)) (set! *env-vars-by-run-id* (make-hash-table)) (set! *test-id-cache* (make-hash-table))) + +;; Generic string database (normalization of sorts) +(define sdb:qry #f) ;; (make-sdb:qry)) ;; 'init #f) +;; Generic path database (normalization of sorts) +(define *fdb* #f) ;;====================================================================== ;; S T A T E S A N D S T A T U S E S ;;====================================================================== @@ -338,11 +346,11 @@ "unknown" (caar uname-res)))) (define (save-environment-as-files fname #!key (ignorevars (list "DISPLAY" "LS_COLORS" "XKEYSYMDB" "EDITOR"))) (let ((envvars (get-environment-variables)) - (whitesp (regexp "[^a-zA-Z0-9_\\-:;,.\\/%$]"))) + (whitesp (regexp "[^a-zA-Z0-9_\\-:,.\\/%$]"))) (with-output-to-file (conc fname ".csh") (lambda () (for-each (lambda (key) (if (not (member key ignorevars)) (let* ((val (cdr key)) Index: configf.scm ================================================================== --- configf.scm +++ configf.scm @@ -218,16 +218,16 @@ (realval (if envar (config:eval-string-in-environment val) val))) (debug:print-info 6 "read-config env setting, envar: " envar " realval: " realval " val: " val " key: " key " curr-section-name: " curr-section-name) (if envar - (if (and envar - (string? realval) - (not (string-search (integer->char 0) realval))) - ;; (debug:print-info 4 "read-config key=" key ", val=" val ", realval=" realval) - (setenv key realval) - (debug:print 0 "ERROR: bad value for setenv, key=" key ", value=" realval))) + (if (and (string? realval)(string? key)) + (handle-exceptions + exn + (debug:print 0 "ERROR: bad value for setenv, key=" key ", value=" realval) + (setenv key realval)) + (debug:print 0 "ERROR: bad value for setenv, key=" key ", value=" realval))) (hash-table-set! res curr-section-name (config:assoc-safe-add alist key realval)) (loop (configf:read-line inp res allow-system) curr-section-name key #f))) (configf:key-no-val ( x key val) (let* ((alist (hash-table-ref/default res curr-section-name '()))) (hash-table-set! res curr-section-name Index: dashboard-tests.scm ================================================================== --- dashboard-tests.scm +++ dashboard-tests.scm @@ -24,11 +24,14 @@ (declare (unit dashboard-tests)) (declare (uses common)) (declare (uses db)) (declare (uses gutils)) +(declare (uses rmt)) (declare (uses ezsteps)) +;; (declare (uses sdb)) +;; (declare (uses filedb)) (include "common_records.scm") (include "db_records.scm") (include "run_records.scm") @@ -73,11 +76,18 @@ lbl) (store-label "testcomment" (iup:label "TestComment " #:expand "HORIZONTAL") (lambda (testdat) - (db:test-get-comment testdat))) + (let ((newcomment (db:test-get-comment testdat))) + (if *dashboard-comment-share-slot* + (if (not (equal? (iup:attribute *dashboard-comment-share-slot* "VALUE") + newcomment)) + (iup:attribute-set! *dashboard-comment-slot* + "VALUE" + newcomment))) + newcomment))) (store-label "testid" (iup:label "TestId " #:expand "HORIZONTAL") (lambda (testdat) (db:test-get-id testdat))) @@ -180,15 +190,18 @@ (iup:label "" #:expand "VERTICAL"))) (apply iup:vbox ; #:expand "YES" (list ;; NOTE: Yes, the host can change! (store-label "HostName" - (iup:label (db:test-get-host testdat) #:expand "HORIZONTAL") + (iup:label ;; (sdb:qry 'getstr + (db:test-get-host testdat) ;; ) + #:expand "HORIZONTAL") (lambda (testdat)(db:test-get-host testdat))) (store-label "Uname" (iup:label " " #:expand "HORIZONTAL") - (lambda (testdat)(db:test-get-uname testdat))) + (lambda (testdat) ;; (sdb:qry 'getstr + (db:test-get-uname testdat))) ;; ) (store-label "DiskFree" (iup:label (conc (db:test-get-diskfree testdat)) #:expand "HORIZONTAL") (lambda (testdat)(conc (db:test-get-diskfree testdat)))) (store-label "CPULoad" (iup:label (conc (db:test-get-cpuload testdat)) #:expand "HORIZONTAL") @@ -209,35 +222,41 @@ (color (car (gutils:get-color-for-state-status state status)))) ((vector-ref *state-status* 0) state color) ((vector-ref *state-status* 1) status color))) (define *dashboard-test-db* #t) +(define *dashboard-comment-share-slot* #f) ;;====================================================================== ;; Set fields ;;====================================================================== -(define (set-fields-panel db test-id testdat #!key (db #f)) +(define (set-fields-panel dbstruct run-id test-id testdat #!key (db #f)) (let ((newcomment #f) (newstatus #f) - (newstate #f)) + (newstate #f) + (wtxtbox #f)) (iup:frame #:title "Set fields" (iup:vbox (iup:hbox (iup:label "Comment:") - (iup:textbox #:action (lambda (val a b) - (db:test-set-state-status-by-id db test-id #f #f b) - ;; IDEA: Just set a variable with the proc to call? - (set! newcomment b)) - #:value (db:test-get-comment testdat) - #:expand "HORIZONTAL")) + (let ((txtbox (iup:textbox #:action (lambda (val a b) + (rmt:test-set-state-status-by-id run-id test-id #f #f b) + ;; IDEA: Just set a variable with the proc to call? + (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"))) + (set! wtxtbox txtbox) + txtbox)) + (apply iup:hbox (iup:label "STATE:" #:size "30x") (let* ((btns (map (lambda (state) (let ((btn (iup:button state #:expand "HORIZONTAL" #:size "50x" #:font "Courier New, -10" #:action (lambda (x) - (db:test-set-state-status-by-id db test-id state #f #f) + (rmt:test-set-state-status-by-id run-id test-id state #f #f) (db:test-set-state! testdat state))))) btn)) (map cadr *common:std-states*)))) ;; (list "COMPLETED" "NOT_STARTED" "RUNNING" "REMOTEHOSTSTART" "LAUNCHED" "KILLED" "KILLREQ")))) (vector-set! *state-status* 0 (lambda (state color) @@ -255,12 +274,20 @@ (let ((btn (iup:button status #:expand "HORIZONTAL" #:size "50x" #:font "Courier New, -10" #:action (lambda (x) (let ((t (iup:attribute x "TITLE"))) (if (equal? t "WAIVED") - (iup:show (dashboard-tests:waiver testdat (lambda (c) - (set! newcomment c)))) + (iup:show (dashboard-tests:waiver testdat + (if wtxtbox (iup:attribute wtxtbox "VALUE") #f) + (lambda (c) + (set! newcomment c) + (if wtxtbox + (begin + (iup:attribute-set! wtxtbox "VALUE" c) + (if (not *dashboard-comment-share-slot*) + (set! *dashboard-comment-share-slot* wtxtbox))) + )))) (begin (open-run-close db:test-set-state-status-by-id db test-id #f status #f) (db:test-set-status! testdat status)))))))) btn)) (map cadr *common:std-statuses*)))) ;; (list "PASS" "WARN" "FAIL" "CHECK" "n/a" "WAIVED" "SKIP")))) @@ -307,21 +334,21 @@ ;; #:expand "HORIZONTAL" ;; #:action (lambda (obj) ;; (print "Refresh test data " stepname)) ))) -(define (dashboard-tests:waiver testdat cmtcmd) +(define (dashboard-tests:waiver testdat ovrdval cmtcmd) (let* ((wpatt (configf:lookup *configdat* "setup" "waivercommentpatt")) (wregx (if (string? wpatt)(regexp wpatt) #f)) (wmesg (iup:label (if wpatt (conc "Comment must match pattern " wpatt) ""))) (comnt (iup:textbox #:action (lambda (val a b) (if wpatt (if (string-match wregx b) (iup:attribute-set! wmesg "TITLE" (conc "Comment matches " wpatt)) (iup:attribute-set! wmesg "TITLE" (conc "Comment does not match " wpatt)) ))) - #:value (db:test-get-comment testdat) + #:value (if ovrdval ovrdval (db:test-get-comment testdat)) #:expand "HORIZONTAL")) (dlog #f)) (set! dlog (iup:dialog ;; #:close_cb (lambda (a)(exit)) ; #:expand "YES" #:title "SET WAIVER" (iup:vbox ; #:expand "YES" @@ -411,12 +438,12 @@ ((eq? (tdb:step-get-event_time a)(tdb:step-get-event_time b)) (< (tdb:step-get-id a) (tdb:step-get-id b))) (else #f))))) res)) -(define (dashboard-tests:get-compressed-steps db test-id) - (let* ((steps-data (db:get-steps-for-test db test-id)) +(define (dashboard-tests:get-compressed-steps dbstruct run-id test-id) + (let* ((steps-data (db:get-steps-for-test dbstruct run-id test-id)) (comprsteps (dashboard-tests:process-steps-table steps-data))) ;; (open-run-close db:get-steps-table #f test-id work-area: work-area))) (map (lambda (x) ;; take advantage of the \n on time->string (vector (vector-ref x 0) @@ -441,38 +468,38 @@ (string (file-modification-time (conc *toppath* "/megatest.db")) *last-db-update-time*)) + (> (file-modification-time (conc *toppath* "/db/main.db")) *last-db-update-time*)) (define (dashboard:set-db-update-time) - (set! *last-db-update-time* (file-modification-time (conc *toppath* "/megatest.db")))) + (set! *last-db-update-time* (file-modification-time (conc *toppath* "/db/main.db")))) (define (dashboard:recalc modtime please-update-buttons last-db-update-time) (or please-update-buttons (and (> (current-milliseconds)(+ *last-recalc-ended-time* 150)) (> modtime last-db-update-time) @@ -1488,22 +1491,25 @@ (let ((runid (string->number (args:get-arg "-run")))) (if runid (begin (lambda (x) (on-exit (lambda () - (if *db* (sqlite3:finalize! *db*)))) + (if *db* (db:close-all *db*)))) (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 (and (number? testid) - (>= testid 0)) - (examine-test testid) + ((args:get-arg "-test") ;; run-id,test-id + (let* ((dat (map string->number (string-split (args:get-arg "-test") ","))) + (run-id (car dat)) + (test-id (cadr dat))) + (if (and (number? run-id) + (number? test-id) + (>= test-id 0)) + (examine-test run-id test-id) (begin - (debug:print 3 "INFO: tried to open test with invalid test-id. " (args:get-arg "-test")) + (debug:print 3 "INFO: tried to open test with invalid run-id,test-id. " (args:get-arg "-test")) (exit 1))))) ((args:get-arg "-guimonitor") (gui-monitor *db*)) (else (set! uidat (make-dashboard-buttons *db* *num-runs* *num-tests* *dbkeys*)) @@ -1523,6 +1529,6 @@ (set! *update-is-running* #f) (mutex-unlock! *update-mutex*)))) 1)))) (iup:main-loop) -(sqlite3:finalize! *db*) +(db:close-all *db*) Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -28,89 +28,280 @@ (declare (uses keys)) (declare (uses ods)) (declare (uses fs-transport)) (declare (uses client)) (declare (uses mt)) -(declare (uses filedb)) +;; (declare (uses sdb)) +;; (declare (uses filedb)) (include "common_records.scm") (include "db_records.scm") (include "key_records.scm") (include "run_records.scm") -;; timestamp type (val1 val2 ...) -;; type: meta-info, step -(define *incoming-writes* '()) -(define *completed-writes* (make-hash-table)) -(define *incoming-last-time* (current-seconds)) -(define *incoming-mutex* (make-mutex)) -(define *completed-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-info 9 "db:set-sync, setting pragma synchronous to " val) - (sqlite3:execute db (conc "PRAGMA synchronous = '" val "';")))))) - -(define (open-db) ;; (conc *toppath* "/megatest.db") (car *configinfo*))) - (if (not *toppath*) - (if (not (setup-for-run)) - (begin - (debug:print 0 "ERROR: Attempted to open db when not in megatest area. Exiting.") - (exit)))) - (let* ((dbpath (conc *toppath* "/megatest.db")) ;; fname) - (dbexists (file-exists? dbpath)) - (db (sqlite3:open-database dbpath)) ;; (never-give-up-open-db dbpath)) +(define *rundb-mutex* (make-mutex)) ;; prevent problems opening/closing rundb's +(define *number-of-writes* 0) +(define *number-non-write-queries* 0) + +;; Get/open a database +;; if run-id => get run specific db +;; if #f => get main db +;; if db already open - return inmem +;; if db not open, open inmem, rundb and sync then return inmem +;; inuse gets set automatically for rundb's +;; +(define (db:get-db dbstruct run-id) + (if (sqlite3:database? dbstruct) ;; pass sqlite3 databases on through + dbstruct + (begin + (mutex-lock! *rundb-mutex*) + (let ((db (if run-id + (db:open-rundb dbstruct run-id) + (db:open-main dbstruct)))) + ;; db prunning would go here + (mutex-unlock! *rundb-mutex*) + db)))) + +;; mod-read: +;; 'mod modified data +;; 'read read data +;; +(define (db:done-with dbstruct run-id mod-read) + (if (not (sqlite3:database? dbstruct)) + (begin + (mutex-lock! *rundb-mutex*) + (if (eq? mod-read 'mod) + (dbr:dbstruct-set-runvec-val! dbstruct run-id 'mtime (current-milliseconds)) + (dbr:dbstruct-set-runvec-val! dbstruct run-id 'rtime (current-milliseconds))) + (dbr:dbstruct-set-runvec-val! dbstruct run-id 'inuse #f) + (mutex-unlock! *rundb-mutex*)))) + +;; (db:with-db dbstruct run-id sqlite3:exec "select blah from blaz;") +;; r/w is a flag to indicate if the db is modified by this query #t = yes, #f = no +;; +(define (db:with-db dbstruct run-id r/w proc . params) + (let* ((db (db:get-db dbstruct run-id))) + (let ((res (apply proc db params))) + (db:done-with dbstruct run-id r/w) + res))) + +;;====================================================================== +;; K E E P F I L E D B I N dbstruct +;;====================================================================== + +;; (define (db:get-filedb dbstruct run-id) +;; (let ((db (vector-ref dbstruct 2))) +;; (if db +;; db +;; (let ((fdb (filedb:open-db (conc *toplevel* "/db/files.db")))) +;; (vector-set! dbstruct 2 fdb) +;; fdb)))) +;; +;; ;; Can also be used to save arbitrary strings +;; ;; +;; (define (db:save-path dbstruct path) +;; (let ((fdb (db:get-filedb dbstruct))) +;; (filedb:register-path fdb path))) +;; +;; ;; Use to get a path. To get an arbitrary string see next define +;; ;; +;; (define (db:get-path dbstruct id) +;; (let ((fdb (db:get-filedb dbstruct))) +;; (filedb:get-path db id))) + +;; This routine creates the db. It is only called if the db is not already opened +;; +(define (db:open-rundb dbstruct run-id) ;; (conc *toppath* "/megatest.db") (car *configinfo*))) + (let ((rdb (dbr:dbstruct-get-runvec-val dbstruct run-id 'inmem))) ;; dbr:dbstruct-get-runvec-val + (if rdb + rdb + (let* ((local (dbr:dbstruct-get-local dbstruct)) + (toppath (dbr:dbstruct-get-path dbstruct)) + (dbpath (conc toppath "/db/" run-id ".db")) + (dbexists (file-exists? dbpath)) + (inmem (if local #f (db:open-inmem-db))) + (db (sqlite3:open-database dbpath)) + (write-access (file-write-access? dbpath)) + (handler (make-busy-timeout 136000))) + (if (and dbexists (not write-access)) + (set! *db-write-access* #f)) ;; only unset so other db's also can use this control + (if write-access + (begin + (if (not dbexists) + (begin + (db:initialize-run-id-db db) + ;; (sdb:initialize db) + )) ;; add strings db to rundb, not in use yet + (sqlite3:set-busy-handler! db handler) + (sqlite3:execute db "PRAGMA synchronous = 1;"))) ;; was 0 but 0 is a gamble + (dbr:dbstruct-set-runvec-val! dbstruct run-id 'rundb db) + (dbr:dbstruct-set-runvec-val! dbstruct run-id 'inuse #t) + (if local + (begin + (dbr:dbstruct-set-runvec-val! dbstruct run-id 'inmem db) ;; direct access ... + db) + (begin + (dbr:dbstruct-set-runvec-val! dbstruct run-id 'inmem inmem) + (db:sync-tables db:sync-tests-only db inmem) + inmem)))))) + +;; This routine creates the db. It is only called if the db is not already opened +;; +(define (db:open-main dbstruct) ;; (conc *toppath* "/megatest.db") (car *configinfo*))) + (let ((mdb (dbr:dbstruct-get-main dbstruct))) + (if mdb + mdb + (let* ((toppath (dbr:dbstruct-get-path dbstruct)) + (dbpath (let ((dbdir (conc *toppath* "/db"))) ;; use this opportunity to create our db dir + (if (not (directory-exists? dbdir)) + (create-direcory dbdir)) + (conc *toppath* "/db/main.db"))) + (dbexists (file-exists? dbpath)) + (db (sqlite3:open-database dbpath)) + (write-access (file-write-access? dbpath)) + (handler (make-busy-timeout 136000))) + (if (and dbexists (not write-access)) + (set! *db-write-access* #f)) + (if write-access + (begin + (sqlite3:set-busy-handler! db handler) + (sqlite3:execute db "PRAGMA synchronous = 0;"))) + (if (not dbexists) + (db:initialize-main-db db)) + (dbr:dbstruct-set-main! dbstruct db) + db)))) + +;; Make the dbstruct, setup up auxillary db's and call for main db at least once +;; +(define (db:setup #!key (local #f)) + (let ((dbstruct (make-dbr:dbstruct path: *toppath* local: local))) + (db:get-db dbstruct #f) ;; force one call to main + ;; (if (not sdb:qry) + ;; (begin + ;; (set! sdb:qry (make-sdb:qry (conc *toppath* "/db/strings.db"))) ;; we open the normalization helpers here + ;; (sdb:qry 'setup #f) + ;; ;; Initialize with some known needed strings, NOTE: set this up to only execute on first db initialization + ;; (for-each + ;; (lambda (str) + ;; (sdb:qry 'get-id str)) + ;; (list "" "logs/final.log")))) + ;; (set! *fdb* (filedb:open-db (conc *toppath* "/db/paths.db"))) + dbstruct)) + +;; Open the classic megatest.db file in toppath +;; +(define (db:open-megatest-db) + (let* ((dbpath (conc *toppath* "/megatest.db")) + (dbexists (file-exists? dbpath)) + (db (sqlite3:open-database dbpath)) (write-access (file-write-access? dbpath)) - (handler (make-busy-timeout (if (args:get-arg "-override-timeout") - (string->number (args:get-arg "-override-timeout")) - 136000)))) ;; 136000))) ;; 136000 = 2.2 minutes - (if (and dbexists - (not write-access)) - (set! *db-write-access* write-access)) ;; only unset so other db's also can use this control - (debug:print-info 11 "open-db, dbpath=" dbpath " argv=" (argv)) - (if write-access (sqlite3:set-busy-handler! db handler)) + (handler (make-busy-timeout 136000))) + (if (and dbexists (not write-access)) + (set! *db-write-access* #f)) + (if write-access + (begin + (sqlite3:set-busy-handler! db handler) + (sqlite3:execute db "PRAGMA synchronous = 0;"))) (if (not dbexists) - (db:initialize db)) - ;; Moving db:set-sync to a call in run.scm - it is a persistent value and only needs to be set once - ;; (db:set-sync db) + (begin + (db:initialize-main-db db) + (db:initialize-run-id-db db))) db)) -(define (open-in-mem-db) - (let* ((path (configf:lookup *configdat* "setup" "tmpdb")) - (fname (if path (conc path "/temp-megatest.db") #f)) - (exists (and path (file-exists? fname))) - (db (if path - (begin - (create-directory path #t) - (sqlite3:open-database fname)) - (sqlite3:open-database ":memory:"))) +;; sync all touched runs to disk +(define (db:sync-touched dbstruct #!key (force-sync #f)) + (let ((tot-synced 0)) + (for-each + (lambda (runvec) + (let ((mtime (vector-ref runvec (dbr:dbstruct-field-name->num 'mtime))) + (stime (vector-ref runvec (dbr:dbstruct-field-name->num 'stime))) + (rundb (vector-ref runvec (dbr:dbstruct-field-name->num 'rundb))) + (inmem (vector-ref runvec (dbr:dbstruct-field-name->num 'inmem)))) + (if (or (> mtime stime) force-sync) + (let ((num-synced (db:sync-tables db:sync-tests-only inmem rundb))) + (set! tot-synced (+ tot-synced num-synced)) + (vector-set! runvec (dbr:dbstruct-field-name->num 'stime) (current-milliseconds)))))) + (hash-table-values (vector-ref dbstruct 1))) + tot-synced)) + +;; close all opened run-id dbs +(define (db:close-all dbstruct) + ;; finalize main.db + (db:sync-touched dbstruct force-sync: #t) + (sqlite3:finalize! (db:get-db dbstruct #f)) + (for-each + (lambda (runvec) + (let ((rundb (vector-ref runvec (dbr:dbstruct-field-name->num 'rundb)))) + (if (sqlite3:database? rundb) + (sqlite3:finalize! rundb) + (debug:print 0 "WARNING: attempting to close databases but got " rundb " instead of a database")))) + (hash-table-values (vector-ref dbstruct 1))) + ;; (sdb:qry 'finalize! #f) + ) + ;; (filedb:finalize-db! *fdb*)) + +(define (db:open-inmem-db) + (let* ((db (sqlite3:open-database ":memory:")) (handler (make-busy-timeout 3600))) - (if (or (not path) - (not exists)) - (db:initialize db)) + (db:initialize-run-id-db db) + ;; (sdb:initialize db) ;; for future use (sqlite3:set-busy-handler! db handler) db)) -;; (define (db:sync-table tblname fields fromdb todb) +;; just tests, test_steps and test_data tables +(define db:sync-tests-only + (list + ;; (list "strs" + ;; '("id" #f) + ;; '("str" #f)) + (list "tests" + '("id" #f) + '("run_id" #f) + '("testname" #f) + '("host" #f) + '("cpuload" #f) + '("diskfree" #f) + '("uname" #f) + '("rundir" #f) + '("shortdir" #f) + '("item_path" #f) + '("state" #f) + '("status" #f) + '("attemptnum" #f) + '("final_logf" #f) + '("logdat" #f) + '("run_duration" #f) + '("comment" #f) + '("event_time" #f) + '("fail_count" #f) + '("pass_count" #f) + '("archived" #f)) + (list "test_steps" + '("id" #f) + '("test_id" #f) + '("stepname" #f) + '("state" #f) + '("status" #f) + '("event_time" #f) + '("comment" #f) + '("logfile" #f)) + (list "test_data" + '("id" #f) + '("test_id" #f) + '("category" #f) + '("variable" #f) + '("value" #f) + '("expected" #f) + '("tol" #f) + '("units" #f) + '("comment" #f) + '("status" #f) + '("type" #f)))) -(define (db:tbls db) +;; needs db to get keys, this is for syncing all tables +;; +(define (db:sync-main-list db) (let ((keys (db:get-keys db))) (list (list "keys" '("id" #f) '("fieldname" #f) @@ -119,41 +310,10 @@ (append (list "runs" '("id" #f)) (map (lambda (k)(list k #f)) (append keys (list "runname" "state" "status" "owner" "event_time" "comment" "fail_count" "pass_count")))) - (list "tests" - '("id" #f) - '("run_id" #f) - '("testname" #f) - '("host" #f) - '("cpuload" #f) - '("diskfree" #f) - '("uname" #f) - '("rundir" #f) - '("shortdir" #f) - '("item_path" #f) - '("state" #f) - '("status" #f) - '("attemptnum" #f) - '("final_logf" #f) - '("logdat" #f) - '("run_duration" #f) - '("comment" #f) - '("event_time" #f) - '("fail_count" #f) - '("pass_count" #f) - '("archived" #f)) - (list "test_steps" - '("id" #f) - '("test_id" #f) - '("stepname" #f) - '("state" #f) - '("status" #f) - '("event_time" #f) - '("comment" #f) - '("logfile" #f)) (list "test_meta" '("id" #f) '("testname" #f) '("owner" #f) '("description" #f) @@ -164,214 +324,110 @@ '("tags" #f) '("jobgroup" #f))))) ;; tbls is ( ("tablename" ( "field1" [#f|proc1] ) ( "field2" [#f|proc2] ) .... ) ) (define (db:sync-tables tbls fromdb todb) - (let ((stmts (make-hash-table)) ;; table-field => stmt - (all-stmts '()) ;; ( ( stmt1 value1 ) ( stml2 value2 )) - (numrecs (make-hash-table)) - (start-time (current-milliseconds))) - (for-each ;; table - (lambda (tabledat) - (let* ((tablename (car tabledat)) - (fields (cdr tabledat)) - (num-fields (length fields)) - (field->num (make-hash-table)) - (num->field (apply vector (map car fields))) - (full-sel (conc "SELECT " (string-intersperse (map car fields) ",") - " FROM " tablename ";")) - (full-ins (conc "INSERT OR REPLACE INTO " tablename " ( " (string-intersperse (map car fields) ",") " ) " - " VALUES ( " (string-intersperse (make-list num-fields "?") ",") " );")) - (fromdat '()) - (todat (make-hash-table)) - (count 0)) - - ;; set up the field->num table - (for-each - (lambda (field) - (hash-table-set! field->num field count) - (set! count (+ count 1))) - fields) - - ;; read the source table - (sqlite3:for-each-row - (lambda (a . b) - (set! fromdat (cons (apply vector a b) fromdat))) - fromdb - full-sel) - - ;; read the target table - (sqlite3:for-each-row - (lambda (a . b) - (hash-table-set! todat a (apply vector a b))) - todb - full-sel) - - ;; first pass implementation, just insert all changed rows - (let ((stmth (sqlite3:prepare todb full-ins))) - (sqlite3:with-transaction - todb - (lambda () - (for-each ;; - (lambda (fromrow) - (let* ((a (vector-ref fromrow 0)) - (curr (hash-table-ref/default todat a #f)) - (same #t)) - (let loop ((i 0)) - (if (or (not curr) - (not (equal? (vector-ref fromrow i)(vector-ref curr i)))) - (set! same #f)) - (if (and same - (< i (- num-fields 1))) - (loop (+ i 1)))) - (if (not same) - (begin - (apply sqlite3:execute stmth (vector->list fromrow)) - (hash-table-set! numrecs tablename (+ 1 (hash-table-ref/default numrecs tablename 0))))))) - fromdat))) - (sqlite3:finalize! stmth)))) - tbls) - (let ((runtime (- (current-milliseconds) start-time))) - (debug:print 0 "INFO: db sync, total run time " runtime " ms") - (for-each - (lambda (dat) - (let ((tblname (car dat)) - (count (cdr dat))) - (if (> count 0) - (debug:print 0 (format #f " ~10a ~5a" tblname count))))) - (sort (hash-table->alist numrecs)(lambda (a b)(> (cdr a)(cdr b)))))))) - -;; (define (db:sync-to fromdb todb) -;; ;; strategy -;; ;; 1. Get all run-ids -;; ;; 2. For each run-id -;; ;; a. Sync that run in a transaction -;; (let ((trecchgd 0) -;; (rrecchgd 0) -;; (tmrecchgd 0)) -;; -;; ;; First sync test_meta data -;; (let ((tmgetstmt (sqlite3:prepare todb "SELECT id,testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags,jobgroup FROM test_meta WHERE id=?;")) -;; (tmputstmt (sqlite3:prepare todb "INSERT OR REPLACE INTO test_meta (id,testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags,jobgroup) -;; VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?);")) -;; (tmdats (db:testmeta-get-all fromdb))) -;; ;; (debug:print 7 "Updating as many as " (length tdats) " records for run " run-id) -;; (for-each -;; (lambda (tmdat) ;; iterate over tests -;; (let ((testm-id (vector-ref tmdat 0))) -;; (sqlite3:with-transaction -;; todb -;; (lambda () -;; (let ((curr-tmdat #f)) -;; (sqlite3:for-each-row -;; (lambda (a . b) -;; (set! curr-tmdat (apply vector a b))) -;; tmgetstmt testm-id) -;; (if (not (equal? curr-tmdat tmdat)) ;; something changed -;; (begin -;; (debug:print 0 " test-id: " testm-id -;; "\ncurr-tdat: " curr-tmdat -;; "\n tdat: " tmdat) -;; (apply sqlite3:execute tmputstmt (vector->list tmdat)) -;; (set! tmrecchgd (+ tmrecchgd 1))))))))) -;; tmdats) -;; (sqlite3:finalize! tmgetstmt) -;; (sqlite3:finalize! tmputstmt)) -;; -;; ;; First sync tests data -;; (let ((run-ids (db:get-all-run-ids fromdb)) -;; (tgetstmt (sqlite3:prepare todb "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=?;")) -;; (tputstmt (sqlite3:prepare todb "INSERT OR REPLACE INTO tests (id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment) -;; VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ? );"))) -;; (for-each -;; (lambda (run-id) -;; (let ((tdats (db:get-all-tests-info-by-run-id fromdb run-id))) -;; ;; (debug:print 7 "Updating as many as " (length tdats) " records for run " run-id) -;; (for-each -;; (lambda (tdat) ;; iterate over tests -;; (let ((test-id (vector-ref tdat 0))) -;; (sqlite3:with-transaction -;; todb -;; (lambda () -;; (let ((curr-tdat #f)) -;; (sqlite3:for-each-row -;; (lambda (a . b) -;; (set! curr-tdat (apply vector a b))) -;; tgetstmt -;; test-id) -;; (if (not (equal? curr-tdat tdat)) ;; something changed -;; (begin -;; (debug:print 0 " test-id: " test-id -;; "\ncurr-tdat: " curr-tdat -;; "\n tdat: " tdat) -;; (apply sqlite3:execute tputstmt (vector->list tdat)) -;; (set! trecchgd (+ trecchgd 1))))))))) -;; tdats))) -;; run-ids) -;; (sqlite3:finalize! tgetstmt) -;; (sqlite3:finalize! tputstmt)) -;; -;; ;; Next sync runs table -;; (let* ((rdats '()) -;; (keys (db:get-keys fromdb)) -;; (rstdfields (conc "id," (string-intersperse keys ",") ",runname,state,status,owner,event_time,comment,fail_count,pass_count")) -;; (rnumfields (length (string-split rstdfields ","))) -;; (runslots (string-intersperse (make-list rnumfields "?") ",")) -;; (rgetstmt (sqlite3:prepare todb (conc "SELECT " rstdfields " FROM runs WHERE id=?;"))) -;; (rputstmt (sqlite3:prepare todb (conc "INSERT OR REPLACE INTO runs (" rstdfields ") VALUES ( " runslots " );")))) -;; ;; first collect all the source run data -;; (sqlite3:for-each-row -;; (lambda (a . b) -;; (set! rdats (cons (apply vector a b) rdats))) -;; fromdb -;; (conc "SELECT " rstdfields " FROM runs;")) -;; (sqlite3:with-transaction -;; todb -;; (lambda () -;; (for-each -;; (lambda (rdat) -;; (let ((run-id (vector-ref rdat 0)) -;; (curr-rdat #f)) -;; ;; first get the current value of the equivalent row from the target -;; ;; read, then insert/overwrite if different -;; (sqlite3:for-each-row -;; (lambda (a . b) -;; (set! curr-rdat (apply vector a b))) -;; rgetstmt -;; run-id) -;; (if (not (equal? curr-rdat rdat)) -;; (begin -;; (debug:print 0 " run-id: " run-id -;; "\ncurr-rdat: " curr-rdat -;; "\n rdat: " rdat) -;; (set! rrecchgd (+ rrecchgd 1)) -;; (apply sqlite3:execute rputstmt (vector->list rdat)))))) -;; rdats))) -;; (sqlite3:finalize! rgetstmt) -;; (sqlite3:finalize! rputstmt)) -;; -;; (if (> rrecchgd 0) (debug:print 0 "synced " rrecchgd " changed records in runs table")) -;; (if (> trecchgd 0) (debug:print 0 "synced " trecchgd " changed records in tests table")) -;; (if (> tmrecchgd 0) (debug:print 0 "sync'd " tmrecchgd " changed records in test_meta table")) -;; (+ rrecchgd trecchgd tmrecchgd))) - -(define (db:sync-back) - (db:sync-tables (db:tbls *inmemdb*) *inmemdb* *db*)) ;; (db:sync-to *inmemdb* *db*)) + (cond + ((not fromdb) (debug:print 0 "ERROR: db:sync-tables called with fromdb missing") -1) + ((not todb) (debug:print 0 "ERROR: db:sync-tables called with todb missing") -2) + ((not (sqlite3:database? fromdb)) + (debug:print 0 "ERROR: db:sync-tables called with fromdb not a database " fromdb) -3) + ((not (sqlite3:database? todb)) + (debug:print 0 "ERROR: db:sync-tables called with todb not a database " todb) -4) + (else + (let ((stmts (make-hash-table)) ;; table-field => stmt + (all-stmts '()) ;; ( ( stmt1 value1 ) ( stml2 value2 )) + (numrecs (make-hash-table)) + (start-time (current-milliseconds)) + (tot-count 0)) + (for-each ;; table + (lambda (tabledat) + (let* ((tablename (car tabledat)) + (fields (cdr tabledat)) + (num-fields (length fields)) + (field->num (make-hash-table)) + (num->field (apply vector (map car fields))) + (full-sel (conc "SELECT " (string-intersperse (map car fields) ",") + " FROM " tablename ";")) + (full-ins (conc "INSERT OR REPLACE INTO " tablename " ( " (string-intersperse (map car fields) ",") " ) " + " VALUES ( " (string-intersperse (make-list num-fields "?") ",") " );")) + (fromdat '()) + (todat (make-hash-table)) + (count 0)) + + ;; set up the field->num table + (for-each + (lambda (field) + (hash-table-set! field->num field count) + (set! count (+ count 1))) + fields) + + ;; read the source table + (sqlite3:for-each-row + (lambda (a . b) + (set! fromdat (cons (apply vector a b) fromdat))) + fromdb + full-sel) + + (debug:print 0 "INFO: found " (length fromdat) " records to sync") + + ;; read the target table + (sqlite3:for-each-row + (lambda (a . b) + (hash-table-set! todat a (apply vector a b))) + todb + full-sel) + + ;; first pass implementation, just insert all changed rows + (let ((stmth (sqlite3:prepare todb full-ins))) + (sqlite3:with-transaction + todb + (lambda () + (for-each ;; + (lambda (fromrow) + (let* ((a (vector-ref fromrow 0)) + (curr (hash-table-ref/default todat a #f)) + (same #t)) + (let loop ((i 0)) + (if (or (not curr) + (not (equal? (vector-ref fromrow i)(vector-ref curr i)))) + (set! same #f)) + (if (and same + (< i (- num-fields 1))) + (loop (+ i 1)))) + (if (not same) + (begin + (apply sqlite3:execute stmth (vector->list fromrow)) + (hash-table-set! numrecs tablename (+ 1 (hash-table-ref/default numrecs tablename 0))))))) + fromdat))) + (sqlite3:finalize! stmth)))) + tbls) + (let ((runtime (- (current-milliseconds) start-time))) + (debug:print 0 "INFO: db sync, total run time " runtime " ms") + (for-each + (lambda (dat) + (let ((tblname (car dat)) + (count (cdr dat))) + (set! tot-count (+ tot-count count)) + (if (> count 0) + (debug:print 0 (format #f " ~10a ~5a" tblname count))))) + (sort (hash-table->alist numrecs)(lambda (a b)(> (cdr a)(cdr b)))))) + tot-count)))) ;; keeping it around for debugging purposes only (define (open-run-close-no-exception-handling proc idb . params) (debug:print-info 11 "open-run-close-no-exception-handling START given a db=" (if idb "yes " "no ") ", params=" params) (if (or *db-write-access* (not (member proc *db:all-write-procs*))) - (let* ((db (cond - ((sqlite3:database? idb) idb) - ((not idb) (open-db)) - ((procedure? idb) (idb)) - (else (open-db)))) + (let* ((db (cond + ((sqlite3:database? idb) idb) + ((not idb) (debug:print 0 "ERROR: cannot open-run-close with #f anymore")) + ((procedure? idb) (idb)) + (else (debug:print 0 "ERROR: cannot open-run-close with #f anymore")))) (res #f)) (set! res (apply proc db params)) - (if (not idb)(sqlite3:finalize! db)) + (if (not idb)(sqlite3:finalize! dbstruct)) (debug:print-info 11 "open-run-close-no-exception-handling END" ) res) #f)) (define (open-run-close-exception-handling proc idb . params) @@ -384,37 +440,16 @@ (thread-sleep! (random 120)) (debug:print-info 0 "trying db call one more time....") (apply open-run-close-no-exception-handling proc idb params)) (apply open-run-close-no-exception-handling proc idb params))) -;; (define open-run-close open-run-close-exception-handling) -(define open-run-close open-run-close-no-exception-handling) - -(define *global-delta* 0) -(define *last-global-delta-printed* 0) - -(define (open-run-close-measure proc idb . params) - (debug:print-info 11 "open-run-close-measure START, idb=" idb ", params=" 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-info 1 "launch throttle factor=" *global-delta*) - (set! *last-global-delta-printed* *global-delta*))) - (debug:print-info 11 "open-run-close-measure END" ) - res)) - -(define (db:initialize db) - (debug:print-info 11 "db:initialize START") +;; (define open-run-close +(define open-run-close ;; (if (debug:debug-mode 2) + open-run-close-no-exception-handling) + ;; open-run-close-exception-handling)) + +(define (db:initialize-main-db db) (let* ((configdat (car *configinfo*)) ;; tut tut, global warning... (keys (keys:config-get-fields configdat)) (havekeys (> (length keys) 0)) (keystr (keys->keystr keys)) (fieldstr (keys->key/field keys))) @@ -426,40 +461,65 @@ (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;") - (db:set-sync db) (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 "TEXT")) keys) (sqlite3:execute db (conc - "CREATE TABLE IF NOT EXISTS runs (id INTEGER PRIMARY KEY, " - fieldstr (if havekeys "," "") - "runname TEXT DEFAULT 'norun'," - "state TEXT DEFAULT ''," - "status TEXT DEFAULT ''," - "owner TEXT DEFAULT ''," - "event_time TIMESTAMP DEFAULT (strftime('%s','now'))," - "comment TEXT DEFAULT ''," - "fail_count INTEGER DEFAULT 0," - "pass_count INTEGER DEFAULT 0," - "CONSTRAINT runsconstraint UNIQUE (runname" (if havekeys "," "") keystr "));")) + "CREATE TABLE IF NOT EXISTS runs (id INTEGER PRIMARY KEY, \n " + fieldstr (if havekeys "," "") " + runname TEXT DEFAULT 'norun', + state TEXT DEFAULT '', + status TEXT DEFAULT '', + owner TEXT DEFAULT '', + event_time TIMESTAMP DEFAULT (strftime('%s','now')), + comment TEXT DEFAULT '', + fail_count INTEGER DEFAULT 0, + pass_count INTEGER DEFAULT 0, + CONSTRAINT runsconstraint UNIQUE (runname" (if havekeys "," "") keystr "));")) + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_meta ( + id INTEGER PRIMARY KEY, + testname TEXT DEFAULT '', + author TEXT DEFAULT '', + owner TEXT DEFAULT '', + description TEXT DEFAULT '', + reviewed TIMESTAMP, + iterated TEXT DEFAULT '', + avg_runtime REAL, + avg_disk REAL, + tags TEXT DEFAULT '', + jobgroup TEXT DEFAULT 'default', + CONSTRAINT test_meta_constraint UNIQUE (testname));") (sqlite3:execute db (conc "CREATE INDEX runs_index ON runs (runname" (if havekeys "," "") keystr ");")) - (sqlite3:execute db - "CREATE TABLE IF NOT EXISTS tests + ;; (sqlite3:execute db "CREATE VIEW runs_tests AS SELECT * FROM runs INNER JOIN tests ON runs.id=tests.run_id;") + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS extradat (id INTEGER PRIMARY KEY, run_id INTEGER, key TEXT, val TEXT);") + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS metadat (id INTEGER PRIMARY KEY, var TEXT, val TEXT, + CONSTRAINT metadat_constraint UNIQUE (var));") + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS access_log (id INTEGER PRIMARY KEY, user TEXT, accessed TIMESTAMP, args TEXT);") + ;; Must do this *after* running patch db !! No more. + ;; cannot use db:set-var since it will deadlock, hardwire the code here + (sqlite3:execute db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" "MEGATEST_VERSION" megatest-version) + (debug:print-info 11 "db:initialize END"))) + +;;====================================================================== +;; R U N S P E C I F I C D B +;;====================================================================== + +(define (db:initialize-run-id-db db) + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS tests (id INTEGER PRIMARY KEY, run_id INTEGER DEFAULT -1, testname TEXT DEFAULT 'noname', host TEXT DEFAULT 'n/a', cpuload REAL DEFAULT -1, diskfree INTEGER DEFAULT -1, uname TEXT DEFAULT 'n/a', - rundir TEXT DEFAULT 'n/a', - shortdir TEXT DEFAULT '', + rundir TEXT DEFAULT '/tmp/badname', + shortdir TEXT DEFAULT '/tmp/badname', item_path TEXT DEFAULT '', state TEXT DEFAULT 'NOT_STARTED', status TEXT DEFAULT 'FAIL', attemptnum INTEGER DEFAULT 0, final_logf TEXT DEFAULT 'logs/final.log', @@ -468,14 +528,12 @@ comment TEXT DEFAULT '', event_time TIMESTAMP DEFAULT (strftime('%s','now')), fail_count INTEGER DEFAULT 0, pass_count INTEGER DEFAULT 0, archived INTEGER DEFAULT 0, -- 0=no, 1=in progress, 2=yes - CONSTRAINT testsconstraint UNIQUE (run_id, testname, item_path) - );") + CONSTRAINT testsconstraint UNIQUE (run_id, testname, item_path));") (sqlite3:execute db "CREATE INDEX tests_index ON tests (run_id, testname, item_path);") - (sqlite3:execute db "CREATE VIEW runs_tests AS SELECT * FROM runs INNER JOIN tests ON runs.id=tests.run_id;") (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_steps (id INTEGER PRIMARY KEY, test_id INTEGER, stepname TEXT, state TEXT DEFAULT 'NOT_STARTED', @@ -482,26 +540,19 @@ status TEXT DEFAULT 'n/a', event_time TIMESTAMP, comment TEXT DEFAULT '', logfile TEXT DEFAULT '', CONSTRAINT test_steps_constraint UNIQUE (test_id,stepname,state));") - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS extradat (id INTEGER PRIMARY KEY, run_id INTEGER, key TEXT, val TEXT);") - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS metadat (id INTEGER PRIMARY KEY, var TEXT, val TEXT, - CONSTRAINT metadat_constraint UNIQUE (var));") - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS access_log (id INTEGER PRIMARY KEY, user TEXT, accessed TIMESTAMP, args TEXT);") - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_meta (id INTEGER PRIMARY KEY, - testname TEXT DEFAULT '', - author TEXT DEFAULT '', - owner TEXT DEFAULT '', - description TEXT DEFAULT '', - reviewed TIMESTAMP DEFAULT (strftime('%s','now')), - iterated TEXT DEFAULT '', - avg_runtime REAL DEFAULT -1, - avg_disk REAL DEFAULT -1, - tags TEXT DEFAULT '', - jobgroup TEXT DEFAULT 'default', - CONSTRAINT test_meta_constraint UNIQUE (testname));") +;; (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_data +;; (id INTEGER PRIMARY KEY, +;; reviewed TIMESTAMP DEFAULT (strftime('%s','now')), +;; iterated TEXT DEFAULT '', +;; avg_runtime REAL DEFAULT -1, +;; avg_disk REAL DEFAULT -1, +;; tags TEXT DEFAULT '', +;; jobgroup TEXT DEFAULT 'default', +;; CONSTRAINT test_meta_constraint UNIQUE (testname));") (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_data (id INTEGER PRIMARY KEY, test_id INTEGER, category TEXT DEFAULT '', variable TEXT, value REAL, @@ -510,23 +561,28 @@ units TEXT, comment TEXT DEFAULT '', status TEXT DEFAULT 'n/a', type TEXT DEFAULT '', CONSTRAINT test_data_constraint UNIQUE (test_id,category,variable));") - ;; Must do this *after* running patch db !! No more. - (db:set-var db "MEGATEST_VERSION" megatest-version) - (debug:print-info 11 "db:initialize END") - )) + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_rundat ( + id INTEGER PRIMARY KEY, + test_id INTEGER, + update_time TIMESTAMP, + cpuload INTEGER DEFAULT -1, + diskfree INTEGER DEFAULT -1, + diskusage INTGER DEFAULT -1, + run_duration INTEGER DEFAULT 0);") + db) ;;====================================================================== ;; L O G G I N G D B ;;====================================================================== (define (open-logging-db) ;; (conc *toppath* "/megatest.db") (car *configinfo*))) (let* ((dbpath (conc (if *toppath* (conc *toppath* "/") "") "logging.db")) ;; fname) (dbexists (file-exists? dbpath)) - (db (sqlite3:open-database dbpath)) ;; (never-give-up-open-db dbpath)) + (db (sqlite3:open-database dbpath)) (handler (make-busy-timeout (if (args:get-arg "-override-timeout") (string->number (args:get-arg "-override-timeout")) 136000)))) ;; 136000))) (sqlite3:set-busy-handler! db handler) (if (not dbexists) @@ -535,13 +591,10 @@ (sqlite3:execute db (conc "PRAGMA synchronous = 0;")))) db)) (define (db:log-local-event . loglst) (let ((logline (apply conc loglst))) - ;; (pwd (current-directory)) - ;; (cmdline (string-intersperse (argv) " ")) - ;; (pid (current-process-id))) (db:log-event logline))) (define (db:log-event logline) (let ((db (open-logging-db))) (sqlite3:execute db "INSERT INTO log (logline,pwd,cmdline,pid) VALUES (?,?,?,?);" @@ -551,93 +604,12 @@ (current-process-id)) (sqlite3:finalize! db) logline)) ;;====================================================================== -;; TODO: -;; put deltas into an assoc list with version numbers -;; apply all from last to current +;; D B U T I L S ;;====================================================================== -(define (patch-db db) - (handle-exceptions - exn - (begin - (print "Exception: " exn) - (print "ERROR: Possible out of date schema, attempting to add table metadata...") - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS metadat (id INTEGER, var TEXT, val TEXT, - CONSTRAINT metadat_constraint UNIQUE (var));") - (if (not (db:get-var db "MEGATEST_VERSION")) - (db:set-var db "MEGATEST_VERSION" 1.17))) - (let ((mver (db:get-var db "MEGATEST_VERSION")) - (test-meta-def "CREATE TABLE IF NOT EXISTS test_meta (id INTEGER PRIMARY KEY, - testname TEXT DEFAULT '', - author TEXT DEFAULT '', - owner TEXT DEFAULT '', - description TEXT DEFAULT '', - reviewed TIMESTAMP, - iterated TEXT DEFAULT '', - avg_runtime REAL, - avg_disk REAL, - tags TEXT DEFAULT '', - CONSTRAINT test_meta_constraint UNIQUE (testname));")) - (print "Current schema version: " mver " current megatest version: " megatest-version) - (cond - ((not mver) - (print "Adding megatest-version to metadata") ;; Need to recreate the table - (sqlite3:execute db "DROP TABLE IF EXISTS metadat;") - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS metadat (id INTEGER, var TEXT, val TEXT, - CONSTRAINT metadat_constraint UNIQUE (var));") - (db:set-var db "MEGATEST_VERSION" 1.17) - (patch-db)) - ((< mver 1.21) - (sqlite3:execute db "DROP TABLE IF EXISTS metadat;") - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS metadat (id INTEGER, var TEXT, val TEXT, - CONSTRAINT metadat_constraint UNIQUE (var));") - (db:set-var db "MEGATEST_VERSION" 1.21) ;; set before, just in case the changes are already applied - (sqlite3:execute db test-meta-def) - ;(for-each - ; (lambda (stmt) - ; (sqlite3:execute db stmt)) - ; (list - ; "ALTER TABLE tests ADD COLUMN first_err TEXT;" - ; "ALTER TABLE tests ADD COLUMN first_warn TEXT;" - ; )) - (patch-db)) - ((< mver 1.24) - (db:set-var db "MEGATEST_VERSION" 1.24) - (sqlite3:execute db "DROP TABLE IF EXISTS test_data;") - (sqlite3:execute db "DROP TABLE IF EXISTS test_meta;") - (sqlite3:execute db test-meta-def) - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_data (id INTEGER PRIMARY KEY, - test_id INTEGER, - category TEXT DEFAULT '', - variable TEXT, - value REAL, - expected REAL, - tol REAL, - units TEXT, - comment TEXT DEFAULT '', - status TEXT DEFAULT 'n/a', - CONSTRAINT test_data UNIQUE (test_id,category,variable));") - (print "WARNING: Table test_data and test_meta were recreated. Please do megatest -update-meta") - (patch-db)) - ((< mver 1.27) - (db:set-var db "MEGATEST_VERSION" 1.27) - (sqlite3:execute db "ALTER TABLE test_data ADD COLUMN type TEXT DEFAULT '';") - (patch-db)) - ((< mver 1.29) - (db:set-var db "MEGATEST_VERSION" 1.29) - (sqlite3:execute db "ALTER TABLE test_steps ADD COLUMN logfile TEXT DEFAULT '';") - (sqlite3:execute db "ALTER TABLE tests ADD COLUMN shortdir TEXT DEFAULT '';")) - ((< mver 1.36) - (db:set-var db "MEGATEST_VERSION" 1.36) - (sqlite3:execute db "ALTER TABLE test_meta ADD COLUMN jobgroup TEXT DEFAULT 'default';")) - ((< mver 1.37) - (db:set-var db "MEGATEST_VERSION" 1.37) - (sqlite3:execute db "ALTER TABLE tests ADD COLUMN archived INTEGER DEFAULT 0;")) - ((< mver megatest-version) - (db:set-var db "MEGATEST_VERSION" megatest-version)))))) ;;====================================================================== ;; M A I N T E N A N C E ;;====================================================================== @@ -705,12 +677,16 @@ ;; b. If test dir gone, delete the test record ;; 2. Look at run records ;; a. If have tests that are not deleted, set state='unknown' ;; b. .... ;; -(define (db:clean-up db) - (let ((count-stmt (sqlite3:prepare db "SELECT (SELECT count(id) FROM tests)+(SELECT count(id) FROM runs);")) +(define (db:clean-up dbstruct) + + (debug:print 0 "ERROR: db clean up not ported yet") + + (let* ((db (db:get-db dbstruct #f)) + (count-stmt (sqlite3:prepare db "SELECT (SELECT count(id) FROM tests)+(SELECT count(id) FROM runs);")) (statements (map (lambda (stmt) (sqlite3:prepare db stmt)) (list ;; delete all tests that belong to runs that are 'deleted' @@ -738,25 +714,28 @@ (sqlite3:finalize! count-stmt) (db:find-and-mark-incomplete db) (sqlite3:execute db "VACUUM;"))) ;;====================================================================== -;; meta get and set vars +;; M E T A G E T A N D S E T V A R S ;;====================================================================== ;; returns number if string->number is successful, string otherwise ;; also updates *global-delta* -(define (db:get-var db var) - (debug:print-info 11 "db:get-var START " var) +;; +;; Operates on megatestdb +;; +(define (db:get-var dbstruct var) (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) + (db:get-db dbstruct #f) + "SELECT val FROM metadat WHERE var=?;" var) ;; convert to number if can (if (string? res) (let ((valnum (string->number res))) (if valnum (set! res valnum)))) ;; scale by 10, average with current value. @@ -765,38 +744,35 @@ 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-info 4 "launch throttle factor=" *global-delta*) (set! *last-global-delta-printed* *global-delta*))) - (debug:print-info 11 "db:get-var END " var " val=" res) res)) -(define (db:set-var db var val) - (debug:print-info 11 "db:set-var START " var " " val) - (sqlite3:execute db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" var val) - (debug:print-info 11 "db:set-var END " var " " val)) - -(define (db:del-var db var) - (debug:print-info 11 "db:del-var START " var) - (sqlite3:execute db "DELETE FROM metadat WHERE var=?;" var) - (debug:print-info 11 "db:del-var END " var)) +(define (db:set-var dbstruct var val) + (sqlite3:execute (db:get-db dbstruct #f) "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" var val)) + +(define (db:del-var dbstruct var) + (sqlite3:execute (db:get-db dbstruct #f) "DELETE FROM metadat WHERE var=?;" var)) ;; 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 ;; why get the keys from the db? why not get from the *configdat* ;; using keys:config-get-fields? -(define (db:get-keys db) +(define (db:get-keys dbstruct) (if *db-keys* *db-keys* (let ((res '())) - (sqlite3:for-each-row - (lambda (key) - (set! res (cons key res))) - db - "SELECT fieldname FROM keys ORDER BY id DESC;") + (db:with-db dbstruct #f #f + (lambda (db) + (sqlite3:for-each-row + (lambda (key) + (set! res (cons key res))) + (db:get-db dbstruct #f) + "SELECT fieldname FROM keys ORDER BY id DESC;"))) (set! *db-keys* res) res))) ;; (define (db:get-value-by-header row header field) @@ -811,26 +787,26 @@ ;;====================================================================== ;; R U N S ;;====================================================================== -(define (db:get-run-name-from-id db run-id) +(define (db:get-run-name-from-id dbstruct run-id) (let ((res #f)) (sqlite3:for-each-row (lambda (runname) (set! res runname)) - db + (db:get-db dbstruct #f) "SELECT runname FROM runs WHERE id=?;" run-id) res)) -(define (db:get-run-key-val db run-id key) +(define (db:get-run-key-val dbstruct run-id key) (let ((res #f)) (sqlite3:for-each-row (lambda (val) (set! res val)) - db + (db:get-db dbstruct #f) (conc "SELECT " key " FROM runs WHERE id=?;") run-id) res)) ;; keys list to key1,key2,key3 ... @@ -853,13 +829,14 @@ patts)) comparator))) ;; register a test run with the db -(define (db:register-run db keyvals runname state status user) +(define (db:register-run dbstruct keyvals runname state status user) (debug:print 3 "runs:register-run runname: " runname " state: " state " status: " status " user: " user) - (let* ((keys (map car keyvals)) + (let* ((db (db:get-db dbstruct #f)) + (keys (map car keyvals)) (keystr (keys->keystr keys)) (comma (if (> (length keys) 0) "," "")) (andstr (if (> (length keys) 0) " AND " "")) (valslots (keys->valslots keys)) ;; ?,?,? ... (allvals (append (list runname state status user) (map cadr keyvals))) @@ -883,65 +860,58 @@ res) (begin (debug:print 0 "ERROR: Called without all necessary keys") #f)))) -(define (db:get-all-run-ids db) - (let ((res '())) - (sqlite3:for-each-row - (lambda (run-id) - (set! res (cons run-id res))) - db - "SELECT DISTINCT run_id FROM tests;") - res)) - ;; replace header and keystr with a call to runs:get-std-run-fields ;; ;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") ) ;; runpatts: patt1,patt2 ... ;; -(define (db:get-runs db runpatt count offset keypatts) +(define (db:get-runs dbstruct runpatt count offset keypatts) (let* ((res '()) - (keys (db:get-keys db)) + (keys (db:get-keys dbstruct)) (runpattstr (db:patt->like "runname" runpatt)) (remfields (list "id" "runname" "state" "status" "owner" "event_time")) (header (append keys remfields)) (keystr (conc (keys->keystr keys) "," - (string-intersperse remfields ","))) + (string-intersperse remfields ","))) (qrystr (conc "SELECT " keystr " FROM runs WHERE (" runpattstr ") " ;; runname LIKE ? " - ;; Generate: " AND x LIKE 'keypatt' ..." - (if (null? keypatts) "" - (conc " AND " + ;; 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 "))) - " AND state != 'deleted' ORDER BY event_time DESC " - (if (number? count) - (conc " LIMIT " count) - "") - (if (number? offset) - (conc " OFFSET " offset) - "")))) + " AND state != 'deleted' ORDER BY event_time DESC " + (if (number? count) + (conc " LIMIT " count) + "") + (if (number? offset) + (conc " OFFSET " offset) + "")))) (debug:print-info 11 "db:get-runs START qrystr: " qrystr " keypatts: " keypatts " offset: " offset " limit: " count) - (sqlite3:for-each-row - (lambda (a . x) - (set! res (cons (apply vector a x) res))) - db - qrystr - ) + (db:with-db dbstruct #f #f + (lambda (db) + (sqlite3:for-each-row + (lambda (a . x) + (set! res (cons (apply vector a x) res))) + db + qrystr + ))) (debug:print-info 11 "db:get-runs END qrystr: " qrystr " keypatts: " keypatts " offset: " offset " limit: " count) (vector header res))) ;; Get all targets from the db ;; -(define (db:get-targets db) +(define (db:get-targets dbstruct) (let* ((res '()) - (keys (db:get-keys db)) + (keys (db:get-keys dbstruct)) (header keys) ;; (map key:get-fieldname keys)) (keystr (keys->keystr keys)) (qrystr (conc "SELECT " keystr " FROM runs;")) (seen (make-hash-table))) (sqlite3:for-each-row @@ -949,56 +919,70 @@ (let ((targ (cons a x))) (if (not (hash-table-ref/default seen targ #f)) (begin (hash-table-set! seen targ #t) (set! res (cons (apply vector targ) res)))))) - db + (db:get-db dbstruct #f) qrystr) (debug:print-info 11 "db:get-targets END qrystr: " qrystr ) (vector header res))) ;; just get count of runs -(define (db:get-num-runs db runpatt) +(define (db:get-num-runs dbstruct runpatt) (let ((numruns 0)) (debug:print-info 11 "db:get-num-runs START " runpatt) (sqlite3:for-each-row (lambda (count) (set! numruns count)) - db + (db:get-db dbstruct #f) "SELECT COUNT(id) FROM runs WHERE runname LIKE ? AND state != 'deleted';" runpatt) (debug:print-info 11 "db:get-num-runs END " runpatt) numruns)) ;; get some basic run stats ;; ;; ( (runname (( state count ) ... )) ;; ( ... -(define (db:get-run-stats db) +(define (db:get-run-stats dbstruct) (let ((totals (make-hash-table)) - (res '())) + (res '()) + (runs-info '())) + ;; First get all the runname/run-ids (sqlite3:for-each-row - (lambda (runname state count) - (let* ((stateparts (string-split state "|")) - (newstate (conc (car stateparts) "\n" (cadr stateparts)))) - (hash-table-set! totals newstate (+ (hash-table-ref/default totals newstate 0) count)) - (set! res (cons (list runname newstate count) res)))) - db - "SELECT runname,t.state||'|'||t.status AS s,count(t.id) FROM runs AS r INNER JOIN tests AS t ON r.id=t.run_id GROUP BY s,runname ORDER BY r.event_time,s DESC;" ) + (lambda (run-id runname) + (set! runs-info (cons (list run-id runname) runs-info))) + (db:get-db dbstruct #f) + "SELECT id,runname FROM runs;") + ;; for each run get stats data + (for-each + (lambda (run-info) + (let ((run-id (car run-info)) + (run-name (cadr run-info))) + (sqlite3:for-each-row + (lambda (state count) + (if (string? state) + (let* ((stateparts (string-split state "|")) + (newstate (conc (car stateparts) "\n" (cadr stateparts)))) + (hash-table-set! totals newstate (+ (hash-table-ref/default totals newstate 0) count)) + (set! res (cons (list run-name newstate count) res))))) + (db:get-db dbstruct run-id) + "SELECT state||'|'||status AS s,count(id) FROM tests AS t ORDER BY s DESC;" ) ;; (set! res (reverse res)) (for-each (lambda (state) (set! res (cons (list "Totals" state (hash-table-ref totals state)) res))) - (sort (hash-table-keys totals) string>=)) + (sort (hash-table-keys totals) string>=)))) + runs-info) res)) ;; db:get-runs-by-patt ;; get runs by list of criteria ;; register a test run with the db ;; ;; Use: (db-get-value-by-header (db:get-header runinfo)(db:get-row runinfo)) ;; to extract info from the structure returned ;; -(define (db:get-runs-by-patt db keys runnamepatt targpatt offset limit) ;; test-name) +(define (db:get-runs-by-patt dbstruct keys runnamepatt targpatt offset limit) ;; test-name) (let* ((tmp (runs:get-std-run-fields keys '("id" "runname" "state" "status" "owner" "event_time"))) (keystr (car tmp)) (header (cadr tmp)) (res '()) (key-patt "") @@ -1019,67 +1003,76 @@ (set! qry-str (conc "SELECT " keystr " FROM runs WHERE state != 'deleted' AND runname " runwildtype " ? " key-patt " ORDER BY event_time " (if limit (conc " LIMIT " limit) "") (if offset (conc " OFFSET " offset) "") ";")) (debug:print-info 4 "runs:get-runs-by-patt qry=" qry-str " " runnamepatt) - (sqlite3:for-each-row - (lambda (a . r) - (set! res (cons (list->vector (cons a r)) res))) - db - qry-str - runnamepatt) + (db:with-db dbstruct #f #f ;; reads db, does not write to it. + (lambda (db) + (sqlite3:for-each-row + (lambda (a . r) + (set! res (cons (list->vector (cons a r)) res))) + (db:get-db dbstruct #f) + qry-str + runnamepatt))) (vector header res))) ;; use (get-value-by-header (db:get-header runinfo)(db:get-row runinfo)) -(define (db:get-run-info db run-id) +(define (db:get-run-info dbstruct run-id) ;;(if (hash-table-ref/default *run-info-cache* run-id #f) ;; (hash-table-ref *run-info-cache* run-id) (let* ((res (vector #f #f #f #f)) - (keys (db:get-keys db)) + (keys (db:get-keys dbstruct)) (remfields (list "id" "runname" "state" "status" "owner" "event_time")) (header (append keys remfields)) (keystr (conc (keys->keystr keys) "," (string-intersperse remfields ",")))) (debug:print-info 11 "db:get-run-info run-id: " run-id " header: " header " keystr: " keystr) (sqlite3:for-each-row (lambda (a . x) (set! res (apply vector a x))) - db + (db:get-db dbstruct #f) (conc "SELECT " keystr " FROM runs WHERE id=? AND state != 'deleted';") run-id) (debug:print-info 11 "db:get-run-info run-id: " run-id " header: " header " keystr: " keystr) (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)) +(define (db:set-comment-for-run dbstruct run-id comment) + (sqlite3:execute (db:get-db dbstruct #f) "UPDATE runs SET comment=? WHERE id=?;" comment ;; (sdb:qry 'getid comment) + run-id)) ;; does not (obviously!) removed dependent data. But why not!!? -(define (db:delete-run db run-id) +(define (db:delete-run dbstruct run-id) ;; First set any related tests to DELETED - (let ((stmt1 (sqlite3:prepare db "UPDATE tests SET state='DELETED',comment='' WHERE run_id=?;")) - (stmt2 (sqlite3:prepare db "UPDATE runs SET state='deleted',comment='' WHERE id=?;"))) - (sqlite3:with-transaction - db (lambda () - (sqlite3:execute stmt1 run-id) - (sqlite3:execute stmt2 run-id))) - (sqlite3:finalize! stmt1) - (sqlite3:finalize! stmt2))) - -(define (db:update-run-event_time db run-id) - (sqlite3:execute db "UPDATE runs SET event_time=strftime('%s','now') WHERE id=?;" run-id)) - -(define (db:lock/unlock-run db run-id lock unlock user) + (let ((db (db:get-db dbstruct run-id))) + (sqlite3:execute db "UPDATE tests SET state='DELETED',comment='';") + (sqlite3:execute db "DELETE FROM test_steps;") + (sqlite3:execute db "DELETE FROM test_data;") + (sqlite3:execute (db:get-db dbstruct #f) "UPDATE runs SET state='deleted',comment='' WHERE id=?;" run-id))) + +(define (db:update-run-event_time dbstruct run-id) + (sqlite3:execute (db:get-db dbstruct #f) "UPDATE runs SET event_time=strftime('%s','now') WHERE id=?;" run-id)) + +(define (db:lock/unlock-run dbstruct run-id lock unlock user) (let ((newlockval (if lock "locked" (if unlock "unlocked" "locked")))) ;; semi-failsafe - (sqlite3:execute db "UPDATE runs SET state=? WHERE id=?;" newlockval run-id) - (sqlite3:execute db "INSERT INTO access_log (user,accessed,args) VALUES(?,strftime('%s','now'),?);" + (sqlite3:execute (db:get-db dbstruct #f) "UPDATE runs SET state=? WHERE id=?;" newlockval run-id) + (sqlite3:execute (db:get-db dbstruct #f) "INSERT INTO access_log (user,accessed,args) VALUES(?,strftime('%s','now'),?);" user (conc newlockval " " run-id)) (debug:print-info 1 "" newlockval " run number " run-id))) + +(define (db:get-all-run-ids dbstruct) + (let ((res '())) + (sqlite3:for-each-row + (lambda (run-id) + (set! res (cons run-id res))) + (db:get-db dbstruct #f) + "SELECT id FROM runs;") + (reverse res))) (define (db:get-run-ids db) (let ((res '())) (sqlite3:for-each-row (lambda (id) @@ -1091,54 +1084,49 @@ ;; K E Y S ;;====================================================================== ;; get key val pairs for a given run-id ;; ( (FIELDNAME1 keyval1) (FIELDNAME2 keyval2) ... ) -(define (db:get-key-val-pairs db run-id) - (let* ((keys (db:get-keys db)) +(define (db:get-key-val-pairs dbstruct run-id) + (let* ((keys (db:get-keys dbstruct)) (res '())) - (debug:print-info 11 "db:get-key-val-pairs START keys: " keys " run-id: " run-id) (for-each (lambda (key) (let ((qry (conc "SELECT " key " FROM runs WHERE id=?;"))) ;; (debug:print 0 "qry: " qry) (sqlite3:for-each-row (lambda (key-val) (set! res (cons (list key key-val) res))) - db qry run-id))) + (db:get-db dbstruct #f) qry run-id))) keys) - (debug:print-info 11 "db:get-key-val-pairs END keys: " keys " run-id: " run-id) (reverse res))) ;; get key vals for a given run-id -(define (db:get-key-vals db run-id) +(define (db:get-key-vals dbstruct run-id) (let ((mykeyvals (hash-table-ref/default *keyvals* run-id #f))) (if mykeyvals mykeyvals - (let* ((keys (db:get-keys db)) + (let* ((keys (db:get-keys dbstruct)) (res '())) - (debug:print-info 11 "db:get-key-vals START keys: " keys " run-id: " run-id) (for-each (lambda (key) (let ((qry (conc "SELECT " 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))) + (db:get-db dbstruct #f) qry run-id))) keys) - (debug:print-info 11 "db:get-key-vals END keys: " keys " run-id: " run-id) (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) +(define (db:get-target dbstruct run-id) (let ((mytarg (hash-table-ref/default *target* run-id #f))) (if mytarg mytarg - (let* ((keyvals (db:get-key-vals db run-id)) + (let* ((keyvals (db:get-key-vals dbstruct run-id)) (thekey (string-intersperse (map (lambda (x)(if x x "-na-")) keyvals) "/"))) (hash-table-set! *target* run-id thekey) thekey)))) ;;====================================================================== @@ -1147,72 +1135,79 @@ ;; 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 -(define (db:get-tests-for-run db run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals) - (let* ((qryvalstr (case qryvals - ((shortlist) "id,run_id,testname,item_path,state,status") - ((#f) "id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment") - (else qryvals))) - (res '()) - ;; if states or statuses are null then assume match all when not-in is false - (states-qry (if (null? states) - #f - (conc " state " - (if not-in - " NOT IN ('" - " IN ('") - (string-intersperse states "','") - "')"))) - (statuses-qry (if (null? statuses) - #f - (conc " status " - (if not-in - " NOT IN ('" - " IN ('") - (string-intersperse statuses "','") - "')"))) - (states-statuses-qry - (cond - ((and states-qry statuses-qry) - (conc " AND ( " states-qry " AND " statuses-qry " ) ")) - (states-qry - (conc " AND " states-qry)) - (statuses-qry - (conc " AND " statuses-qry)) - (else ""))) - (tests-match-qry (tests:match->sqlqry testpatt)) - (qry (conc "SELECT " qryvalstr - " FROM tests WHERE run_id=? AND state != 'DELETED' " - states-statuses-qry - (if tests-match-qry (conc " AND (" tests-match-qry ") ") "") - (case sort-by - ((rundir) " ORDER BY length(rundir) ") - ((testname) (conc " ORDER BY testname " (if sort-order (conc sort-order ",") "") " item_path ")) - ((statestatus) (conc " ORDER BY state " (if sort-order (conc sort-order ",") "") " status ")) - ((event_time) " ORDER BY event_time ") - (else (if (string? sort-by) - (conc " ORDER BY " sort-by " ") - " "))) - (if sort-order sort-order " ") - (if limit (conc " LIMIT " limit) " ") - (if offset (conc " OFFSET " offset) " ") - ";" - ))) - (debug:print-info 8 "db:get-tests-for-run qry=" qry) - (sqlite3:for-each-row - (lambda (a . b) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment) - (set! res (cons (apply vector a b) res))) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment) res))) - db - qry - run-id - ) - (case qryvals - ((shortlist)(map db:test-short-record->norm res)) - ((#f) res) - (else res)))) +(define (db:get-tests-for-run dbstruct run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals) + (if (not (number? run-id)) + (begin + (debug:print 0 "ERROR: call to db:get-tests-for-run with bad run-id=" run-id) + (print-call-chain) + '()) + (let* ((qryvalstr (case qryvals + ((shortlist) "id,run_id,testname,item_path,state,status") + ((#f) db:test-record-qry-selector) ;; "id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment") + (else qryvals))) + (res '()) + ;; if states or statuses are null then assume match all when not-in is false + (states-qry (if (null? states) + #f + (conc " state " + (if not-in + " NOT IN ('" + " IN ('") + (string-intersperse states "','") + "')"))) + (statuses-qry (if (null? statuses) + #f + (conc " status " + (if not-in + " NOT IN ('" + " IN ('") + (string-intersperse statuses "','") + "')"))) + (states-statuses-qry + (cond + ((and states-qry statuses-qry) + (conc " AND ( " states-qry " AND " statuses-qry " ) ")) + (states-qry + (conc " AND " states-qry)) + (statuses-qry + (conc " AND " statuses-qry)) + (else ""))) + (tests-match-qry (tests:match->sqlqry testpatt)) + (qry (conc "SELECT " qryvalstr + " FROM tests WHERE run_id=? AND state != 'DELETED' " + states-statuses-qry + (if tests-match-qry (conc " AND (" tests-match-qry ") ") "") + (case sort-by + ((rundir) " ORDER BY length(rundir) ") + ((testname) (conc " ORDER BY testname " (if sort-order (conc sort-order ",") "") " item_path ")) + ((statestatus) (conc " ORDER BY state " (if sort-order (conc sort-order ",") "") " status ")) + ((event_time) " ORDER BY event_time ") + (else (if (string? sort-by) + (conc " ORDER BY " sort-by " ") + " "))) + (if sort-order sort-order " ") + (if limit (conc " LIMIT " limit) " ") + (if offset (conc " OFFSET " offset) " ") + ";" + ))) + (debug:print-info 8 "db:get-tests-for-run run-id=" run-id ", qry=" qry) + (db:with-db dbstruct run-id #f + (lambda (db) + (sqlite3:for-each-row + (lambda (a . b) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment) + (set! res (cons (apply vector a b) res))) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment) res))) + db + qry + run-id + ))) + (case qryvals + ((shortlist)(map db:test-short-record->norm res)) + ((#f) res) + (else res))))) (define (db:test-short-record->norm inrec) ;; "id,run_id,testname,item_path,state,status" ;; "id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment (vector (vector-ref inrec 0) ;; id @@ -1223,310 +1218,300 @@ -1 "" -1 -1 "" "-" (vector-ref inrec 3) ;; item-path -1 "-" "-")) -(define (db:get-tests-for-run-state-status db run-id testpatt) +(define (db:get-tests-for-run-state-status dbstruct run-id testpatt) (let* ((res '()) (tests-match-qry (tests:match->sqlqry testpatt)) (qry (conc "SELECT id,testname,item_path,state,status FROM tests WHERE run_id=? " (if tests-match-qry (conc " AND (" tests-match-qry ") ") "")))) (debug:print-info 8 "db:get-tests-for-run qry=" qry) - (sqlite3:for-each-row - (lambda (id testname item-path state status) - ;; id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment - (set! res (cons (vector id run-id testname state status -1 "" -1 -1 "" "-" item-path -1 "-" "-") res))) - db - qry - run-id) + (db:with-db dbstruct run-id #f + (lambda (db) + (sqlite3:for-each-row + (lambda (id testname item-path state status) + ;; id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment + (set! res (cons (vector id run-id testname state status -1 "" -1 -1 "" "-" item-path -1 "-" "-") res))) + db + qry + run-id))) res)) -(define (db:get-testinfo-state-status db test-id) +(define (db:get-testinfo-state-status dbstruct run-id test-id) (let ((res #f)) - (sqlite3:for-each-row - (lambda (run-id testname item-path state status) - ;; id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment - (set! res (vector test-id run-id testname state status -1 "" -1 -1 "" "-" item-path -1 "-" "-"))) - db - "SELECT run_id,testname,item_path,state,status FROM tests WHERE id=?;" - test-id) + (db:with-db dbstruct run-id #f + (lambda (db) + (sqlite3:for-each-row + (lambda (run-id testname item-path state status) + ;; id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment + (set! res (vector test-id run-id testname state status -1 "" -1 -1 "" "-" item-path -1 "-" "-"))) + db + "SELECT run_id,testname,item_path,state,status FROM tests WHERE id=?;" + test-id))) res)) ;; get a useful subset of the tests data (used in dashboard ;; use db:mintests-get-{id ,run_id,testname ...} -(define (db:get-tests-for-runs-mindata db run-ids testpatt states status not-in) - (db:get-tests-for-runs db run-ids testpatt states status not-in: not-in qryvals: "id,run_id,testname,state,status,event_time,item_path")) +(define (db:get-tests-for-runs-mindata dbstruct run-ids testpatt states statuses not-in) + (db:get-tests-for-runs dbstruct run-ids testpatt states statuses not-in: not-in qryvals: "id,run_id,testname,state,status,event_time,item_path")) + +(define (db:get-tests-for-runs dbstruct run-ids testpatt states statuses #!key (not-in #f)(qryvals #f)) + (let ((res '())) + (for-each + (lambda (run-id) + (set! res (append + res + (db:get-tests-for-run dbstruct run-id testpatt states statuses #f #f not-in #f #f qryvals)))) + (if run-ids + run-ids + (db:get-all-run-ids dbstruct))) + res)) - -;; NB // This is get tests for "runs" (note the plural!!) +;; Convert calling routines to get list of run-ids and loop, do not use the get-tests-for-runs ;; -;; 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 -;; run-ids is a list of run-ids or a single number or #f for all runs -(define (db:get-tests-for-runs db run-ids testpatt states statuses - #!key (not-in #t) - (sort-by #f) - (qryvals "id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment")) ;; 'rundir 'event_time - (let* ((res '()) - ;; if states or statuses are null then assume match all when not-in is false - (states-qry (if (null? states) - #f - (conc " state " - (if not-in "NOT" "") - " IN ('" - (string-intersperse states "','") - "')"))) - (statuses-qry (if (null? statuses) - #f - (conc " status " - (if not-in "NOT" "") - " IN ('" - (string-intersperse statuses "','") - "')"))) - (tests-match-qry (tests:match->sqlqry testpatt)) - (qry (conc "SELECT " qryvals - " FROM tests WHERE state != 'DELETED' " - (if run-ids - (if (list? run-ids) - (conc "AND run_id IN (" (string-intersperse (map conc run-ids) ",") ") ") - (conc "AND run_id=" run-ids " ")) - " ") ;; #f => run-ids don't filter on run-ids - (if states-qry (conc " AND " states-qry) "") - (if statuses-qry (conc " AND " statuses-qry) "") - (if tests-match-qry (conc " AND (" tests-match-qry ") ") "") - (case sort-by - ((rundir) " ORDER BY length(rundir) DESC;") - ((event_time) " ORDER BY event_time ASC;") - (else ";")) - ))) - (debug:print-info 8 "db:get-tests-for-runs qry=" qry) - (sqlite3:for-each-row - (lambda (a . b) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment) - (set! res (cons (apply vector a b) res))) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment) res))) - db - qry - ) - res)) - -(define (db:delete-test-records db test-id) - (db:general-call db 'delete-test-step-records (list test-id)) - (db:general-call db 'delete-test-data-records (list test-id)) - (sqlite3:execute db "UPDATE tests SET state='DELETED',status='n/a',comment='' 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_timelist rec)) ", ")) + (apply sqlite3:execute qry (vector->list rec))) + testrecs) + (sqlite3:finalize! qry))))) + + +;; Get test data using test_id +(define (db:get-test-info-by-id dbstruct run-id test-id) + (let ((db (db:get-db dbstruct run-id)) + (res #f)) + (sqlite3:for-each-row + (lambda (id run-id testname state status event-time host cpuload diskfree uname rundir-id item-path run_duration final-logf-id comment short-dir-id) + ;; 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-id item-path run_duration final-logf-id comment short-dir-id))) + (db:get-db dbstruct run-id) + (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE id=?;") + test-id) + res)) + +;; Use db:test-get* to access +;; Get test data using test_ids. NB// Only works within a single run!! +;; +(define (db:get-test-info-by-ids dbstruct run-id test-ids) + (let ((db (db:get-db dbstruct run-id)) + (res '())) + (sqlite3:for-each-row + (lambda (id run-id testname state status event-time host cpuload diskfree uname rundir-id item-path run_duration final-logf-id comment short-dir-id) + ;; 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 + (set! res (cons (vector id run-id testname state status event-time host cpuload diskfree uname rundir-id item-path run_duration final-logf-id comment short-dir-id) + res))) + (db:get-db dbstruct run-id) + (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE id in (" + (string-intersperse (map conc test-ids) ",") ");")) + res)) + +(define (db:get-test-info dbstruct run-id testname item-path) + (let ((db (db:get-db dbstruct run-id)) + (res #f)) + (sqlite3:for-each-row + (lambda (a . b) + (set! res (apply vector a b))) + (db:get-db dbstruct run-id) + (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE testname=? AND item_path=?;") + test-name item-path) + res)) + +(define (db:test-get-rundir-from-test-id dbstruct run-id test-id) + (let ((db (db:get-db dbstruct run-id)) + (res #f)) + (sqlite3:for-each-row + (lambda (tpath) + (set! res tpath)) + (db:get-db dbstruct run-id) + "SELECT rundir FROM tests WHERE id=?;" + test-id) + res)) ;;====================================================================== ;; S T E P S ;;====================================================================== -(define (db:teststep-set-status! db test-id teststep-name state-in status-in comment logfile) - (sqlite3:execute - db - "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 ""))) +(define (db:teststep-set-status! dbstruct run-id test-id teststep-name state-in status-in comment logfile) + (let ((db (db:get-db dbstruct run-id))) + (sqlite3:execute + db + "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) + ;; (sdb:qry 'getid + (if comment comment "") ;; ) + ;; (sdb:qry 'getid + (if logfile logfile "")))) ;; ) ;; db-get-test-steps-for-run -(define (db:get-steps-for-test db test-id) - (let* ((res '())) +(define (db:get-steps-for-test dbstruct run-id test-id) + (let* ((db (db:get-db dbstruct run-id)) + (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 status != 'DELETED' AND test_id=? ORDER BY id ASC;" ;; event_time DESC,id ASC; test-id) (reverse res))) -(define (db:get-steps-data db test-id) - (let ((res '())) +(define (db:get-steps-data dbstruct run-id test-id) + (let ((db (db:get-db dbstruct run-id)) + (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 status != 'DELETED' AND test_id=? ORDER BY id ASC;" ;; event_time DESC,id ASC; @@ -1540,12 +1525,13 @@ ;; 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) - (let ((fail-count 0) +(define (db:test-data-rollup dbstruct run-id test-id status) + (let ((db (db:get-db dbstruct run-id)) + (fail-count 0) (pass-count 0)) (sqlite3:for-each-row (lambda (fcount pcount) (set! fail-count fcount) (set! pass-count pcount)) @@ -1556,13 +1542,14 @@ ;; Now rollup the counts to the central megatest.db (db:general-call db 'pass-fail-counts (list pass-count fail-count test-id)) ;; if the test is not FAIL then set status based on the fail and pass counts. (db:general-call db 'test_data-pf-rollup (list test-id test-id test-id test-id)))) -(define (db:csv->test-data db test-id csvdata) +(define (db:csv->test-data dbstruct run-id test-id csvdata) (debug:print 4 "test-id " test-id ", csvdata: " csvdata) - (let ((csvlist (csv->list (make-csv-reader + (let ((db (db:get-db dbstruct run-id)) + (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) @@ -1617,107 +1604,36 @@ ;;====================================================================== ;; Misc. test related queries ;;====================================================================== -;; MUST BE CALLED local! -(define (db:test-get-paths-matching db keynames target fnamepatt #!key (res '())) - ;; BUG: Move the values derived from args to parameters and push to megatest.scm - (let* ((testpatt (if (args:get-arg "-testpatt")(args:get-arg "-testpatt") "%")) - (statepatt (if (args:get-arg ":state") (args:get-arg ":state") "%")) - (statuspatt (if (args:get-arg ":status") (args:get-arg ":status") "%")) - (runname (if (args:get-arg ":runname") (args:get-arg ":runname") "%")) - (paths-from-db (rmt:test-get-paths-matching-keynames-target-new keynames target res - testpatt - statepatt - statuspatt - runname))) - (if fnamepatt - (apply append - (map (lambda (p) - (if (directory-exists? p) - (glob (conc p "/" fnamepatt)) - '())) - paths-from-db)) - paths-from-db))) - -(define (db:test-get-paths-matching-keynames-target db keynames target res - #!key - (testpatt "%") - (statepatt "%") - (statuspatt "%") - (runname "%")) - (let* ((keystr (string-intersperse - (map (lambda (key val) - (conc "r." key " like '" val "'")) - keynames - (string-split target "/")) - " AND ")) - (testqry (tests:match->sqlqry testpatt)) - (qrystr (conc "SELECT t.rundir FROM tests AS t INNER JOIN runs AS r ON t.run_id=r.id WHERE " - keystr " AND r.runname LIKE '" runname "' AND " testqry - " AND t.state LIKE '" statepatt "' AND t.status LIKE '" statuspatt - "' ORDER BY t.event_time ASC;"))) - (sqlite3:for-each-row - (lambda (p) - (set! res (cons p res))) - db - qrystr) - res)) - -(define (db:test-get-paths-matching-keynames-target-new db keynames target res - testpatt - statepatt - statuspatt - runname) +(define (db:test-get-paths-matching-keynames-target-new dbstruct keynames target res testpatt statepatt statuspatt runname) (let* ((row-ids '()) (keystr (string-intersperse (map (lambda (key val) (conc key " like '" val "'")) keynames (string-split target "/")) " AND ")) (testqry (tests:match->sqlqry testpatt)) - (rqry (conc "SELECT id FROM runs WHERE " keystr " AND runname LIKE '" runname "';")) - (runsqry (sqlite3:prepare db rqry)) - (tqry (conc "SELECT rundir FROM tests WHERE run_id=? AND " testqry " AND state LIKE '" statepatt "' AND status LIKE '" statuspatt "' ORDER BY event_time ASC;")) - (tstsqry (sqlite3:prepare db tqry))) - (debug:print 8 "db:test-get-paths-matching-keynames-target-new\n rqry=" rqry "\n tqry=" tqry) + (runsqry (sqlite3:prepare (db:get-db dbstruct #f)(conc "SELECT id FROM runs WHERE " keystr " AND runname LIKE '" runname "';"))) + (tstsqry (conc "SELECT rundir FROM tests WHERE " testqry " AND state LIKE '" statepatt "' AND status LIKE '" statuspatt "' ORDER BY event_time ASC;"))) + (debug:print 8 "db:test-get-paths-matching-keynames-target-new\n runsqry=" runsqry "\n tstsqry=" tstsqry) (sqlite3:for-each-row (lambda (rid) (set! row-ids (cons rid row-ids))) runsqry) (sqlite3:finalize! runsqry) (for-each (lambda (rid) (sqlite3:for-each-row (lambda (p) (set! res (cons p res))) - tstsqry rid)) + (db:get-db dbstruct rid) + tstsqry)) row-ids) - (sqlite3:finalize! tstsqry) res)) -;; look through tests from matching runs for a file -(define (db:test-get-first-path-matching db keynames target fname) - ;; [refpaths] is the section where references to other megatest databases are stored - (let ((mt-paths (configf:get-section "refpaths")) - (res (db:test-get-paths-matching db keynames target fname))) - (let loop ((pathdat (if (null? paths) #f (car mt-paths))) - (tal (if (null? paths) '()(cdr mt-paths)))) - (if (not (null? res)) - (car res) ;; return first found - (if path - (let* ((db (open-db path: (cadr pathdat))) - (newres (db:test-get-paths-matching db keynames target fname))) - (debug:print-info 4 "Trying " (car pathdat) " at " (cadr pathdat)) - (sqlite3:finalize! db) - (if (not (null? newres)) - (car newres) - (if (null? tal) - #f - (loop (car tal)(cdr tal)))))))))) - ;;====================================================================== ;; QUEUE UP META, TEST STATUS AND STEPS REMOTE ACCESS ;;====================================================================== ;; NOTE: Can remove the regex and base64 encoding for zmq @@ -1744,40 +1660,46 @@ (lambda ()(deserialize))) (vector #f #f #f))) ;; crude reply for when things go awry ((zmq)(with-input-from-string msg (lambda ()(deserialize)))) (else msg))) -(define (db:test-set-status-state db test-id status state msg) +(define (db:test-set-status-state dbstruct run-id test-id status state msg) + (let ((db (db:get-db dbstruct run-id))) (if (member state '("LAUNCHED" "REMOTEHOSTSTART")) (db:general-call db 'set-test-start-time (list test-id))) (if msg (db:general-call db 'state-status-msg (list state status msg test-id)) - (db:general-call db 'state-status (list state status test-id)))) + (db:general-call db 'state-status (list state status test-id))))) -(define (db:roll-up-pass-fail-counts db run-id test-name item-path status) +(define (db:roll-up-pass-fail-counts dbstruct run-id test-name item-path status) (if (and (not (equal? item-path "")) (member status '("PASS" "WARN" "FAIL" "WAIVED" "RUNNING" "CHECK" "SKIP"))) - (begin - (db:general-call db 'update-pass-fail-counts (list run-id test-name run-id test-name run-id test-name)) + (let ((db (db:get-db dbstruct run-id))) + (db:general-call db 'update-pass-fail-counts (list test-name test-name test-name)) (if (equal? status "RUNNING") - (db:general-call db 'top-test-set-running (list run-id test-name)) - (db:general-call db 'top-test-set-per-pf-counts (list run-id test-name run-id test-name run-id test-name))) + (db:general-call db 'top-test-set-running (list test-name)) + (db:general-call db 'top-test-set-per-pf-counts (list test-name test-name test-name))) #f) #f)) -(define (db:test-get-logfile-info db run-id test-name) +(define (db:tests-register-test dbstruct run-id test-name item-path) + (sqlite3:execute (db:get-db dbstruct run-id) 'register-test run-id test-name item-path)) + +(define (db:test-get-logfile-info dbstruct run-id test-name) (let ((res #f)) (sqlite3:for-each-row (lambda (path final_logf) + ;; (let ((path (sdb:qry 'getstr path-id)) + ;; (final_logf (sdb:qry 'getstr final_logf-id))) (set! logf final_logf) (set! res (list path final_logf)) (if (directory? path) (debug:print 2 "Found path: " path) - (debug:print 2 "No such path: " path))) - db - "SELECT rundir,final_logf FROM tests WHERE run_id=? AND testname=? AND item_path='';" - run-id test-name) + (debug:print 2 "No such path: " path))) ;; ) + (db:get-db dbstruct run-id) + "SELECT rundir,final_logf FROM tests WHERE testname=? AND item_path='';" + test-name) res)) ;;====================================================================== ;; A G R E G A T E D T R A N S A C T I O N D B W R I T E S ;;====================================================================== @@ -1788,61 +1710,66 @@ ;; TESTS '(register-test "INSERT OR IGNORE INTO tests (run_id,testname,event_time,item_path,state,status) VALUES (?,?,strftime('%s','now'),?,'NOT_STARTED','n/a');") ;; Test state and status '(set-test-state "UPDATE tests SET state=? WHERE id=?;") '(set-test-status "UPDATE tests SET state=? WHERE id=?;") - '(state-status "UPDATE tests SET state=?,status=? WHERE id=?;") - '(state-status-msg "UPDATE tests SET state=?,status=?,comment=? WHERE id=?;") + '(state-status "UPDATE tests SET state=?,status=? WHERE id=?;") ;; DONE + '(state-status-msg "UPDATE tests SET state=?,status=?,comment=? WHERE id=?;") ;; DONE ;; Test comment '(set-test-comment "UPDATE tests SET comment=? WHERE id=?;") - '(set-test-start-time "UPDATE tests SET event_time=strftime('%s','now') WHERE id=?;") + '(set-test-start-time "UPDATE tests SET event_time=strftime('%s','now') WHERE id=?;") ;; DONE '(pass-fail-counts "UPDATE tests SET pass_count=?,fail_count=? WHERE id=?;") ;; test_data-pf-rollup is used to set a tests PASS/FAIL based on the pass/fail info from the steps '(test_data-pf-rollup "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-set-log "UPDATE tests SET final_logf=? WHERE id=?;") - '(test-set-rundir-by-test-id "UPDATE tests SET rundir=? WHERE id=?") - '(test-set-rundir "UPDATE tests SET rundir=? WHERE run_id=? AND testname=? AND item_path=?;") - '(delete-tests-in-state "DELETE FROM tests WHERE state=? AND run_id=?;") + END WHERE id=?;") ;; DONE + '(test-set-log "UPDATE tests SET final_logf=? WHERE id=?;") ;; DONE + ;; '(test-set-rundir-by-test-id "UPDATE tests SET rundir=? WHERE id=?") ;; DONE + ;; '(test-set-rundir "UPDATE tests SET rundir=? AND testname=? AND item_path=?;") ;; DONE + '(test-set-rundir-shortdir "UPDATE tests SET rundir=?,shortdir=? WHERE testname=? AND item_path=?;") + '(delete-tests-in-state "DELETE FROM tests WHERE state=?;") ;; DONE '(tests:test-set-toplog "UPDATE tests SET final_logf=? WHERE run_id=? AND testname=? AND item_path='';") - '(update-cpuload-diskfree "UPDATE tests SET cpuload=?,diskfree=? WHERE id=?;") - '(update-uname-host "UPDATE tests SET uname=?,host=? WHERE id=?;") + '(update-cpuload-diskfree "UPDATE tests SET cpuload=?,diskfree=? WHERE id=?;") ;; DONE + '(update-uname-host "UPDATE tests SET uname=?,host=? WHERE id=?;") ;; DONE '(update-test-state "UPDATE tests SET state=? WHERE state=? AND run_id=? AND testname=? AND NOT (item_path='' AND testname IN (SELECT DISTINCT testname FROM tests WHERE testname=? AND item_path != ''));") '(update-test-status "UPDATE tests SET status=? WHERE status like ? AND run_id=? AND testname=? AND NOT (item_path='' AND testname IN (SELECT DISTINCT testname FROM tests WHERE testname=? AND item_path != ''));") ;; stuff for roll-up-pass-fail-counts '(update-pass-fail-counts "UPDATE tests - SET fail_count=(SELECT count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND status IN ('FAIL','CHECK')), - pass_count=(SELECT count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND status IN ('PASS','WARN','WAIVED')) - WHERE run_id=? AND testname=? AND item_path='';") - '(top-test-set-running "UPDATE tests SET state='RUNNING' WHERE run_id=? AND testname=? AND item_path='';") + SET fail_count=(SELECT count(id) FROM tests WHERE testname=? AND item_path != '' AND status IN ('FAIL','CHECK')), + pass_count=(SELECT count(id) FROM tests WHERE testname=? AND item_path != '' AND status IN ('PASS','WARN','WAIVED')) + WHERE testname=? AND item_path='';") ;; DONE + '(top-test-set-running "UPDATE tests SET state='RUNNING' WHERE testname=? AND item_path='';") ;; DONE '(top-test-set-per-pf-counts "UPDATE tests SET state=CASE WHEN (SELECT count(id) FROM tests - WHERE run_id=? AND testname=? + WHERE testname=? AND item_path != '' AND state in ('RUNNING','NOT_STARTED','LAUNCHED','REMOTEHOSTSTART')) > 0 THEN 'RUNNING' ELSE 'COMPLETED' END, status=CASE WHEN fail_count > 0 THEN 'FAIL' WHEN pass_count > 0 AND fail_count=0 THEN 'PASS' WHEN (SELECT count(id) FROM tests - WHERE run_id=? AND testname=? + WHERE testname=? AND item_path != '' AND status = 'SKIP') > 0 THEN 'SKIP' ELSE 'UNKNOWN' END - WHERE run_id=? AND testname=? AND item_path='';") + WHERE testname=? AND item_path='';") ;; DONE ;; STEPS '(delete-test-step-records "UPDATE test_steps SET status='DELETED' WHERE id=?;") '(delete-test-data-records "UPDATE test_data SET status='DELETED' WHERE id=?;") ;; using status since no state field )) + +(define (db:lookup-query qry-name) + (let ((q (alist-ref qry-name db:queries))) + (if q (car q) #f))) ;; do not run these as part of the transaction (define db:special-queries '(rollup-tests-pass-fail ;; db:roll-up-pass-fail-counts ;; WHY NOT!? login @@ -1851,49 +1778,35 @@ sync set-verbosity killserver )) -(define (db:login db calling-path calling-version client-signature) +(define (db:login dbstruct calling-path calling-version client-signature) (if (and (equal? calling-path *toppath*) (equal? megatest-version calling-version)) (begin (hash-table-set! *logged-in-clients* client-signature (current-seconds)) '(#t "successful login")) ;; path matches - pass! Should vet the caller at this time ... (list #f (conc "Login failed due to mismatch paths: " calling-path ", " *toppath*)))) -(define (db:process-write db request-item) - (let ((stmt-key (vector-ref request-item 0)) - (query (vector-ref request-item 1)) - (params (vector-ref request-item 2)) - (queryh (sqlite3:prepare db query))) - (apply sqlite3:execute stmt params) - #f)) - -(define *db:process-queue-mutex* (make-mutex)) - -(define *number-of-writes* 0) -(define *writes-total-delay* 0) -(define *total-non-write-delay* 0) -(define *number-non-write-queries* 0) - (define (db:general-call db stmtname params) (let ((query (let ((q (alist-ref (if (string? stmtname) (string->symbol stmtname) stmtname) db:queries))) - (if q (car q) #f)))) + (if q (car q) #f)))) (apply sqlite3:execute db query params) #t)) ;; 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 ;; ;; Run this server-side ;; -(define (db:get-previous-test-run-record db run-id test-name item-path) - (let* ((keys (db:get-keys db)) +(define (db:get-previous-test-run-record dbstruct run-id test-name item-path) + (let* ((db (db:get-db dbstruct #f)) ;; + (keys (db:get-keys db)) (selstr (string-intersperse keys ",")) (qrystr (string-intersperse (map (lambda (x)(conc x "=?")) keys) " AND ")) (keyvals #f)) ;; first look up the key values from the run selected by run-id (sqlite3:for-each-row @@ -1927,12 +1840,13 @@ ;; NB// Merge this with test:get-previous-test-run-records? This one looks for all matching tests ;; can use wildcards. Also can likely be factored in with get test paths? ;; ;; Run this remotely!! ;; -(define (db:get-matching-previous-test-run-records db run-id test-name item-path) - (let* ((keys (db:get-keys db)) +(define (db:get-matching-previous-test-run-records dbstruct run-id test-name item-path) + (let* ((db (db:get-db dbstruct #f)) + (keys (db:get-keys db)) (selstr (string-intersperse (map (lambda (x)(vector-ref x 0)) keys) ",")) (qrystr (string-intersperse (map (lambda (x)(conc (vector-ref x 0) "=?")) keys) " AND ")) (keyvals #f) (tests-hash (make-hash-table))) ;; first look up the key values from the run selected by run-id @@ -1954,11 +1868,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 (db:get-tests-for-run db hed (conc test-name "/" item-path) '() '() #f #f #f #f #f #f))) + (let ((results (db:get-tests-for-run dbstruct run-id hed (conc test-name "/" item-path) '() '() #f #f #f #f #f #f))) (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) @@ -1972,48 +1886,51 @@ 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 (db:test-get-records-for-index-file db run-id test-name) +(define (db:test-get-records-for-index-file dbstruct run-id test-name) (let ((res '())) (sqlite3:for-each-row - (lambda (id itempath state status run_duration logf comment) + (lambda (id itempath state status run_duration logf-id comment-id) + (let ((logf (db:get-string dbstruct logf-id)) + (comment (db:get-string dbstruct comment-id))) (set! res (cons (vector id itempath state status run_duration logf comment) res))) - db - "SELECT id,item_path,state,status,run_duration,final_logf,comment FROM tests WHERE run_id=? AND testname=? AND item_path != '';" - run-id test-name) - res)) + (db:get-db dbstruct run-id) + "SELECT id,item_path,state,status,run_duration,final_logf,comment FROM tests WHERE testname=? AND item_path != '';" + test-name) + res))) ;;====================================================================== ;; Tests meta data ;;====================================================================== ;; read the record given a testname -(define (db:testmeta-get-record db testname) +(define (db:testmeta-get-record dbstruct testname) (let ((res #f)) (sqlite3:for-each-row - (lambda (id testname author owner description reviewed iterated avg_runtime avg_disk tags) - (set! res (vector id testname author owner description reviewed iterated avg_runtime avg_disk tags))) - db "SELECT id,testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags FROM test_meta WHERE testname=?;" + (lambda (id testname author owner description reviewed iterated avg_runtime avg_disk tags jobgroup) + (set! res (vector id testname author owner description reviewed iterated avg_runtime avg_disk tags jobgroup))) + (db:get-db dbstruct #f) + "SELECT id,testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags,jobgroup FROM test_meta WHERE testname=?;" testname) res)) ;; create a new record for a given testname -(define (db:testmeta-add-record db testname) - (sqlite3:execute db "INSERT OR IGNORE INTO test_meta (testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags) VALUES (?,'','','','','','','','');" testname)) +(define (db:testmeta-add-record dbstruct testname) + (sqlite3:execute (db:get-db dbstruct #f) "INSERT OR IGNORE INTO test_meta (testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags) VALUES (?,'','','','','','','','');" testname)) ;; update one of the testmeta fields -(define (db:testmeta-update-field db testname field value) - (sqlite3:execute db (conc "UPDATE test_meta SET " field "=? WHERE testname=?;") value testname)) +(define (db:testmeta-update-field dbstruct testname field value) + (sqlite3:execute (db:get-db dbstruct #f) (conc "UPDATE test_meta SET " field "=? WHERE testname=?;") value testname)) -(define (db:testmeta-get-all db) +(define (db:testmeta-get-all dbstruct) (let ((res '())) (sqlite3:for-each-row (lambda (a . b) (set! res (cons (apply vector a b) res))) - db + (db:get-db dbstruct run-id) "SELECT id,testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags,jobgroup FROM test_meta;") res)) ;;====================================================================== ;; M I S C M A N A G E M E N T I T E M S @@ -2026,11 +1943,11 @@ ;; ;; Note: mode 'normal means that tests must be COMPLETED and ok (i.e. PASS, WARN, CHECK, SKIP or WAIVED) ;; mode 'toplevel means that tests must be COMPLETED only ;; mode 'itemmatch or 'itemwait 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 mode) +(define (db:get-prereqs-not-met dbstruct run-id waitons ref-item-path mode) (if (or (not waitons) (null? waitons)) '() (let* ((unmet-pre-reqs '()) (result '())) @@ -2037,11 +1954,11 @@ (for-each (lambda (waitontest-name) ;; by getting the tests with matching name we are looking only at the matching test ;; and related sub items ;; next should be using mt:get-tests-for-run? - (let ((tests (db:get-tests-for-run-state-status db run-id waitontest-name)) + (let ((tests (db:get-tests-for-run-state-status dbstruct run-id waitontest-name)) (ever-seen #f) (parent-waiton-met #f) (item-waiton-met #f)) (for-each (lambda (test) @@ -2094,14 +2011,16 @@ (delete-duplicates result)))) ;;====================================================================== ;; Extract ods file from the db ;;====================================================================== + +;; NOT REWRITTEN YET!!!!! ;; runspatt is a comma delimited list of run patterns ;; keypatt-alist must contain *all* keys with an associated pattern: '( ("KEY1" "%") .. ) -(define (db:extract-ods-file db outputfile keypatt-alist runspatt pathmod) +(define (db:extract-ods-file dbstruct outputfile keypatt-alist runspatt pathmod) (let* ((keysstr (string-intersperse (map car keypatt-alist) ",")) (keyqry (string-intersperse (map (lambda (p)(conc (car p) " LIKE ? ")) keypatt-alist) " AND ")) (numkeys (length keypatt-alist)) (test-ids '()) (windows (and pathmod (substring-index "\\" pathmod))) Index: db_records.scm ================================================================== --- db_records.scm +++ db_records.scm @@ -1,5 +1,85 @@ +;;====================================================================== +;; dbstruct +;;====================================================================== + +;; +;; -path-|-megatest.db +;; |-db-|-main.db +;; |-monitor.db +;; |-sdb.db +;; |-fdb.db +;; |-1.db +;; |-.db +(define (make-dbr:dbstruct #!key (path #f)(local #f)) + (vector + #f ;; the main db (contains runs, test_meta etc.) NOT CACHED IN MEM + (make-hash-table) ;; run-id => [ rundb inmemdb last-mod last-read last-sync ] + #f ;; the global string db (use for state, status etc.) + path ;; path to database files/megatest area + local)) ;; read-only local access + +;; +;; Accessors for a dbstruct +;; +;; get and set main db +(define-inline (dbr:dbstruct-get-main vec) (vector-ref vec 0)) +(define-inline (dbr:dbstruct-set-main! vec db)(vector-set! vec 0 db)) +;; get the runs hash +(define-inline (dbr:dbstruct-get-dbhash vec) (vector-ref vec 1)) +;; the string db +(define-inline (dbr:dbstruct-get-strdb vec) (vector-ref vec 2)) +(define-inline (dbr:dbstruct-set-strdb! vec db)(vector-set! vec 2 db)) +;; path +(define-inline (dbr:dbstruct-get-path vec) (vector-ref vec 3)) +(define-inline (dbr:dbstruct-set-path! vec path)(vector-set! vec 3)) +;; local +(define-inline (dbr:dbstruct-get-local vec) (vector-ref vec 4)) +(define-inline (dbr:dbstruct-set-local! vec val)(vector-set! vec 4 val)) + +;; get a rundb vector, create it if not already existing +(define (dbr:dbstruct-get-rundb-rec vec run-id) + (let* ((dbhash (dbr:dbstruct-get-dbhash vec)) ;; get the runs hash + (runvec (hash-table-ref/default dbhash run-id #f))) ;; get the vector for run-id + (if (vector? runvec) + runvec ;; rundb inmemdb last-mod last-read last-sync in-use + (let ((nvec (vector #f #f -1 -1 -1 #f))) + (hash-table-set! dbhash run-id nvec) + nvec)))) + +;; [ rundb inmemdb last-mod last-read last-sync ] +(define-inline (dbr:dbstruct-field-name->num field-name) + (case field-name + ((rundb) 0) ;; the on-disk db + ((inmem) 1) ;; the in-memory db + ((mtime) 2) ;; last modification time + ((rtime) 3) ;; last read time + ((stime) 4) ;; last sync time + ((inuse) 5) ;; is the db currently in use, #t yes, #f no. + (else -1))) + +;; get/set rundb fields +(define (dbr:dbstruct-get-runvec-val vec run-id field-name) + (let ((runvec (dbr:dbstruct-get-rundb-rec vec run-id)) + (fieldnum (dbr:dbstruct-field-name->num field-name))) + ;; (vector-set! runvec (dbr:dbstruct-field-name->num 'inuse) #t) + (vector-ref runvec fieldnum))) + +(define (dbr:dbstruct-set-runvec-val! vec run-id field-name val) + (let ((runvec (dbr:dbstruct-get-rundb-rec vec run-id))) + (vector-set! runvec (dbr:dbstruct-field-name->num field-name) val))) + +;; get/set inmemdb +(define (dbr:dbstruct-get-inmemdb vec run-id) + (let ((runvec (dbr:dbstruct-get-rundb-rec vec run-id))) + (vector-ref runvec 1))) + +(define (dbr:dbstruct-set-inmemdb! vec run-id inmemdb) + (let ((runvec (dbr:dbstruct-get-rundb-rec vec run-id))) + (vector-set! runvec 1 inmemdb))) + + (define (make-db:test)(make-vector 20)) (define-inline (db:test-get-id vec) (vector-ref vec 0)) (define-inline (db:test-get-run_id vec) (vector-ref vec 1)) (define-inline (db:test-get-testname vec) (vector-ref vec 2)) (define-inline (db:test-get-state vec) (vector-ref vec 3)) @@ -7,10 +87,11 @@ (define-inline (db:test-get-event_time vec) (vector-ref vec 5)) (define-inline (db:test-get-host vec) (vector-ref vec 6)) (define-inline (db:test-get-cpuload vec) (vector-ref vec 7)) (define-inline (db:test-get-diskfree vec) (vector-ref vec 8)) (define-inline (db:test-get-uname vec) (vector-ref vec 9)) +;; (define-inline (db:test-get-rundir vec) (sdb:qry 'getstr (vector-ref vec 10))) (define-inline (db:test-get-rundir vec) (vector-ref vec 10)) (define-inline (db:test-get-item-path vec) (vector-ref vec 11)) (define-inline (db:test-get-run_duration vec) (vector-ref vec 12)) (define-inline (db:test-get-final_logf vec) (vector-ref vec 13)) (define-inline (db:test-get-comment vec) (vector-ref vec 14)) Index: dcommon.scm ================================================================== --- dcommon.scm +++ dcommon.scm @@ -375,15 +375,15 @@ (iup:attribute-set! general-matrix "3:0" "Version") (iup:attribute-set! general-matrix "3:1" megatest-version) general-matrix)) -(define (dcommon:run-stats db) +(define (dcommon:run-stats dbstruct) (let* ((stats-matrix (iup:matrix expand: "YES")) (changed #f) (updater (lambda () - (let* ((run-stats (db:get-run-stats db)) + (let* ((run-stats (db:get-run-stats dbstruct)) (indices (common:sparse-list-generate-index run-stats)) ;; proc: set-cell)) (row-indices (car indices)) (col-indices (cadr indices)) (max-row (if (null? row-indices) 1 (apply max (map cadr row-indices)))) (max-col (if (null? col-indices) 1 Index: ezsteps.scm ================================================================== --- ezsteps.scm +++ ezsteps.scm @@ -16,24 +16,28 @@ (declare (unit ezsteps)) (declare (uses db)) (declare (uses common)) (declare (uses items)) (declare (uses runconfig)) +;; (declare (uses sdb)) +;; (declare (uses filedb)) (include "common_records.scm") (include "key_records.scm") (include "db_records.scm") (include "run_records.scm") (define (ezsteps:run-from testdat start-step-name run-one) - (let* ((test-run-dir (db:test-get-rundir testdat)) + (let* ((test-run-dir ;; (filedb:get-path *fdb* + (db:test-get-rundir testdat)) ;; ) (testconfig (read-config (conc test-run-dir "/testconfig") #f #t environ-patt: "pre-launch-env-vars")) (ezstepslst (hash-table-ref/default testconfig "ezsteps" '())) (run-mutex (make-mutex)) (rollup-status 0) (exit-info (vector #t #t #t)) (test-id (db:test-get-id testdat)) + (run-id (db:test-get-run_id testdat)) (test-name (db:test-get-testname testdat)) (kill-job #f)) ;; for future use (on re-factoring with launch.scm code (let loop ((count 5)) (if (file-exists? test-run-dir) (push-directory test-run-dir) @@ -77,11 +81,11 @@ ;; call the command using mt_ezstep (set! script (conc "mt_ezstep " stepname " " (if prevstep prevstep "-") " " stepcmd)) (debug:print 4 "script: " script) - (rmt:teststep-set-status! #f test-id stepname "start" "-" #f #f) + (rmt:teststep-set-status! run-id 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! run-mutex) @@ -94,11 +98,11 @@ (thread-sleep! 1) (processloop (+ i 1)))) )) (let ((exinfo (vector-ref exit-info 2)) (logfna (if logpro-used (conc stepname ".html") ""))) - (rmt:teststep-set-status! #f test-id stepname "end" exinfo #f logfna)) + (rmt:teststep-set-status! run-id test-id stepname "end" exinfo #f logfna)) (if logpro-used (rmt:test-set-log! 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) @@ -136,11 +140,11 @@ (debug:print 4 "WARNING: a prior step failed, stopping at " ezstep))) ;; Once done with step/steps update the test record ;; (let* ((item-path (db:test-get-item-path testdat)) ;; (item-list->path itemdat)) - (testinfo (cdb:get-test-info-by-id *runremote* test-id))) ;; refresh the testdat, call it iteminfo in case need prev/curr + (testinfo (rmt:get-testinfo-by-id run-id test-id))) ;; refresh the testdat, call it iteminfo in case need prev/curr ;; Am I completed? (if (equal? (db:test-get-state testinfo) "RUNNING") ;; (not (equal? (db:test-get-state testinfo) "COMPLETED")) (let ((new-state (if kill-job "KILLED" "COMPLETED") ;; (if (eq? (vector-ref exit-info 2) 0) ;; exited with "good" status ;; "COMPLETED" ;; (db:test-get-state testinfo))) ;; else preseve the state as set within the test Index: filedb.scm ================================================================== --- filedb.scm +++ filedb.scm @@ -23,11 +23,11 @@ (filedb:fdb-set-db! fdb db) (filedb:fdb-set-dbpath! fdb dbpath) (filedb:fdb-set-pathcache! fdb (make-hash-table)) (filedb:fdb-set-idcache! fdb (make-hash-table)) (filedb:fdb-set-partcache! fdb (make-hash-table)) - ;(sqlite3:set-busy-timeout! db 1000000) + (sqlite3:set-busy-handler! db (make-busy-timeout 136000)) (if (not dbexists) (begin (sqlite3:execute db "PRAGMA synchronous = OFF;") (sqlite3:execute db "CREATE TABLE names (id INTEGER PRIMARY KEY,name TEST);") ;; for future use - change path in paths table to path_id (sqlite3:execute db "CREATE INDEX name_index ON names (name);") @@ -40,12 +40,20 @@ gid INTEGER DEFAULT -1, size INTEGER DEFAULT -1, mtime INTEGER DEFAULT -1);") (sqlite3:execute db "CREATE INDEX path_index ON paths (path,parent_id);") (sqlite3:execute db "CREATE TABLE bases (id INTEGER PRIMARY KEY,base TEXT, updated TIMESTAMP);"))) + ;; close the sqlite3 db and open it as needed + (filedb:finalize-db! fdb) + (filedb:fdb-set-db! fdb #f) fdb)) +(define (filedb:reopen-db fdb) + (let ((db (sqlite3:open-database (filedb:fdb-get-dbpath fdb)))) + (filedb:fdb-set-db! fdb db) + (sqlite3:set-busy-handler! db (make-busy-timeout 136000)))) + (define (filedb:finalize-db! fdb) (sqlite3:finalize! (filedb:fdb-get-db fdb))) (define (filedb:get-current-time-string) (string-chomp (time->string (seconds->local-time (current-seconds))))) @@ -108,10 +116,11 @@ (define (filedb:register-path fdb path #!key (save-stat #f)) (let* ((db (filedb:fdb-get-db fdb)) (pathcache (filedb:fdb-get-pathcache fdb)) (stat (if save-stat (file-stat path #t))) (id (hash-table-ref/default pathcache path #f))) + (if (not db)(filedb:reopen-db fdb)) (if id id (let ((plist (string-split path "/"))) (let loop ((head (car plist)) (tail (cdr plist)) (parent 0)) @@ -214,10 +223,11 @@ (define (filedb:get-path fdb id) (let* ((db (filedb:fdb-get-db fdb)) (idcache (filedb:fdb-get-idcache fdb)) (path (hash-table-ref/default idcache id #f))) + (if (not db)(filedb:reopen-db fdb)) (if path path (let loop ((curr-id id) (path "")) (let ((path-record (filedb:get-path-record fdb curr-id))) (if (not path-record) #f ;; this id has no path Index: http-transport.scm ================================================================== --- http-transport.scm +++ http-transport.scm @@ -181,10 +181,13 @@ ;;====================================================================== ;; C L I E N T S ;;====================================================================== (define *http-mutex* (make-mutex)) + +;; NOTE: Large block of code from 32436b426188080f72fceb6894af541fbad9921e removed here +;; I'm pretty sure it is defunct. ;; This next block all imported en-mass from the api branch (define *http-requests-in-progress* 0) (define *http-connections-next-cleanup* (current-seconds)) @@ -426,18 +429,19 @@ (let loop ((count 0)) ;; Use this opportunity to sync the inmemdb to db (let ((start-time (current-milliseconds)) (sync-time #f) (rem-time #f)) - (if *inmemdb* (db:sync-tables (db:tbls *inmemdb*) *inmemdb* *db*)) ;; (db:sync-to *inmemdb* *db*)) + (if *inmemdb* (db:sync-touched *inmemdb* force-sync: #t)) (set! sync-time (- (current-milliseconds) start-time)) - (debug:print 0 "SYNC: time= " sync-time) - (set! rem-time (quotient (- 4000 sync-time) 1000)) - (if (and (< rem-time 4) + (set! rem-time (/ (- 4000 sync-time) 1000)) + (debug:print 0 "SYNC: time= " sync-time ", rem-time=" rem-time) + (if (and (<= rem-time 4) (> rem-time 0)) - (thread-sleep! rem-time))) - + (thread-sleep! rem-time) + (thread-sleep! 4))) ;; fallback for if the math is changed ... + ;; (thread-sleep! 4) ;; no need to do this very often (if (< count 1) ;; 3x3 = 9 secs aprox (loop (+ count 1))) @@ -457,13 +461,16 @@ ;; NOTE: Get rid of this mechanism! It really is not needed... ;; (open-run-close tasks:server-update-heartbeat tasks:open-db spid) (tasks:server-update-heartbeat tdb spid) ;; (if ;; (or (> numrunning 0) ;; stay alive for two days after last access + + ;; Transfer *last-db-access* to last-access to use in checking that we are still alive (mutex-lock! *heartbeat-mutex*) (set! last-access *last-db-access*) (mutex-unlock! *heartbeat-mutex*) + ;; (debug:print 11 "last-access=" last-access ", server-timeout=" server-timeout) (if (and *server-run* (> (+ last-access server-timeout) (current-seconds))) (begin @@ -471,11 +478,11 @@ (loop 0)) (begin (debug:print-info 0 "Starting to shutdown the server.") ;; need to delete only *my* server entry (future use) (set! *time-to-exit* #t) - (if *inmemdb* (db:sync-tables (db:tbls *inmemdb*) *inmemdb* *db*)) ;; (db:sync-to *inmemdb* *db*)) + (if *inmemdb* (db:sync-touched *inmemdb* force-sync: #t)) (open-run-close tasks:server-deregister-self tasks:open-db (get-host-name)) (thread-sleep! 1) (debug:print-info 0 "Max cached queries was " *max-cache-size*) (debug:print-info 0 "Number of cached writes " *number-of-writes*) (debug:print-info 0 "Average cached write time " @@ -514,49 +521,26 @@ (http-transport:run (if (args:get-arg "-server") (args:get-arg "-server") "-"))) "Server run")) (th3 (make-thread http-transport:keep-running "Keep running"))) -;; (th1 (make-thread server:write-queue-handler "write queue"))) - (set! *cache-on* #t) - (set! *db* (open-db)) - (set! *inmemdb* (open-in-mem-db)) - (db:sync-tables (db:tbls *db*) *db* *inmemdb*) ;; (db:sync-to *db* *inmemdb*) - + ;; Database connection + (set! *inmemdb* (db:setup)) (thread-start! th2) (thread-start! th3) - ;; (thread-start! th1) (set! *didsomething* #t) (thread-join! th2)) (debug:print 0 "ERROR: Failed to setup for megatest"))) + ;; (sdb:qry 'finalize) (exit))) -;; (use trace) -;; (trace http-transport:keep-running -;; tasks:server-update-heartbeat -;; tasks:server-get-server-id) -;; tasks:get-best-server -;; http-transport:run -;; http-transport:launch -;; http-transport:try-start-server -;; http-transport:client-send-receive -;; http-transport:make-server-url -;; tasks:server-register -;; tasks:server-delete -;; start-server -;; hostname->ip -;; with-input-from-request -;; tasks:server-deregister-self) - (define (http-transport:server-signal-handler signum) (handle-exceptions exn (debug:print " ... exiting ...") (let ((th1 (make-thread (lambda () (thread-sleep! 1)) - ;; (if (not *received-response*) - ;; (receive-message* *runremote*))) ;; flush out last call if applicable "eat response")) (th2 (make-thread (lambda () (debug:print 0 "ERROR: Received ^C, attempting clean exit. Please be patient and wait a few seconds before hitting ^C again.") (thread-sleep! 3) ;; give the flush three seconds to do it's stuff (debug:print 0 " Done.") Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -11,19 +11,21 @@ ;;====================================================================== ;; launch a task - this runs on the originating host, tests themselves ;; ;;====================================================================== -(use regex regex-case base64 sqlite3 srfi-18) +(use regex regex-case base64 sqlite3 srfi-18 directory-utils posix-extras) (import (prefix base64 base64:)) (import (prefix sqlite3 sqlite3:)) (declare (unit launch)) (declare (uses common)) (declare (uses configf)) (declare (uses db)) +;; (declare (uses sdb)) (declare (uses tdb)) +;; (declare (uses filedb)) (include "common_records.scm") (include "key_records.scm") (include "db_records.scm") @@ -149,11 +151,11 @@ (save-environment-as-files "megatest") ;; open-run-close not needed for test-set-meta-info (tests:set-full-meta-info test-id run-id 0 work-area) ;; (tests:test-set-status! test-id "REMOTEHOSTSTART" "n/a" (args:get-arg "-m") #f) - (tests:test-force-state-status! test-id "REMOTEHOSTSTART" "n/a") + (tests:test-force-state-status! run-id test-id "REMOTEHOSTSTART" "n/a") (thread-sleep! 0.3) ;; NFS slowness has caused grief here (if (args:get-arg "-xterm") (set! fullrunscript "xterm") (if (and fullrunscript (not (file-execute-access? fullrunscript))) @@ -177,11 +179,11 @@ ;; any of the other stuff that tests:test-set-status! does. Let's just ;; force RUNNING/n/a (thread-sleep! 0.3) - (tests:test-force-state-status! test-id "RUNNING" "n/a") + (tests:test-force-state-status! run-id test-id "RUNNING" "n/a") (thread-sleep! 0.3) ;; NFS slowness has caused grief here ;; if there is a runscript do it first (if fullrunscript (let ((pid (process-run fullrunscript))) @@ -235,11 +237,11 @@ ;; call the command using mt_ezstep (set! script (conc "mt_ezstep " stepname " " (if prevstep prevstep "-") " " stepcmd)) (debug:print 4 "script: " script) - (rmt:teststep-set-status! test-id stepname "start" "-" #f #f) + (rmt:teststep-set-status! run-id 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) @@ -252,13 +254,13 @@ (thread-sleep! 2) (processloop (+ i 1)))) )) (let ((exinfo (vector-ref exit-info 2)) (logfna (if logpro-used (conc stepname ".html") ""))) - (rmt:teststep-set-status! test-id stepname "end" exinfo #f logfna)) + (rmt:teststep-set-status! run-id test-id stepname "end" exinfo #f logfna)) (if logpro-used - (rmt:test-set-log! test-id (conc stepname ".html"))) + (rmt:test-set-log! run-id 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))) @@ -282,18 +284,18 @@ " 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 - (tests:test-set-status! test-id next-state "WARN" + (tests:test-set-status! run-id test-id next-state "WARN" (if (eq? this-step-status 'warn) "Logpro warning found" #f) #f)) ((pass) - (tests:test-set-status! test-id next-state "PASS" #f #f)) + (tests:test-set-status! run-id test-id next-state "PASS" #f #f)) (else ;; 'fail (set! rollup-status 1) ;; force fail, this used to be next-state but that doesn't make sense. should always be "COMPLETED" - (tests:test-set-status! test-id "COMPLETED" "FAIL" (conc "Failed at step " stepname) #f) + (tests:test-set-status! run-id test-id "COMPLETED" "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)))))))) @@ -307,11 +309,11 @@ start-seconds))))) (kill-tries 0)) (tests:set-full-meta-info test-id run-id (calc-minutes) work-area) (let loop ((minutes (calc-minutes))) (begin - (set! kill-job? (or (test-get-kill-request test-id) ;; run-id test-name itemdat)) + (set! kill-job? (or (test-get-kill-request run-id test-id) ;; run-id test-name itemdat)) (and runtlim (let* ((run-seconds (- (current-seconds) start-seconds)) (time-exceeded (> run-seconds runtlim))) (if time-exceeded (begin (debug:print-info 0 "KILLING TEST DUE TO TIME LIMIT EXCEEDED! Runtime=" run-seconds " seconds, limit=" runtlim) @@ -343,11 +345,11 @@ ;; (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") - (tests:test-set-status! test-id "KILLED" "FAIL" + (tests:test-set-status! run-id test-id "KILLED" "FAIL" (args:get-arg "-m") #f) (exit 1) ;; IS THIS NECESSARY OR WISE??? ))) (set! kill-tries (+ 1 kill-tries)) (mutex-unlock! m))) @@ -354,11 +356,11 @@ (if keep-going (begin (thread-sleep! 3) ;; (+ 3 (random 6))) ;; add some jitter to the call home time to spread out the db accesses (if keep-going (loop (calc-minutes))))))) - (tests:update-central-meta-info test-id (get-cpu-load) (get-df (current-directory))(calc-minutes) #f #f)))) ;; NOTE: Checking twice for keep-going is intentional + (tests:update-central-meta-info run-id test-id (get-cpu-load) (get-df (current-directory))(calc-minutes) #f #f)))) ;; NOTE: Checking twice for keep-going is intentional (th1 (make-thread monitorjob "monitor job")) (th2 (make-thread runit "run job"))) (set! job-thread th2) (thread-start! th1) (thread-start! th2) @@ -367,11 +369,11 @@ (thread-join! th1) (thread-sleep! 1) ;; give thread th1 a chance to be done TODO: Verify this is needed. At 0.1 I was getting fail to stop, increased to total of 1.1 sec. (mutex-lock! m) (let* ((item-path (item-list->path itemdat)) ;; only state and status needed - use lazy routine - (testinfo (rmt:get-testinfo-state-status test-id))) ;;;(cdb:get-test-info-by-id *runremote* test-id))) ;; )) ;; run-id test-name item-path))) + (testinfo (rmt:get-testinfo-state-status run-id test-id))) ;;;(cdb:get-test-info-by-id *runremote* test-id))) ;; )) ;; run-id test-name item-path))) ;; Am I completed? (if (member (db:test-get-state testinfo) '("REMOTEHOSTSTART" "RUNNING")) ;; NOTE: It should *not* be REMOTEHOSTSTART but for reasons I don't yet understand it sometimes gets stuck in that state ;; (not (equal? (db:test-get-state testinfo) "COMPLETED")) (let ((new-state (if kill-job? "KILLED" "COMPLETED") ;; (if (eq? (vector-ref exit-info 2) 0) ;; exited with "good" status ;; "COMPLETED" ;; (db:test-get-state testinfo))) ;; else preseve the state as set within the test @@ -385,11 +387,12 @@ ((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")))) ;; (db:test-get-status testinfo))) (debug:print-info 1 "Test exited in state=" (db:test-get-state testinfo) ", setting state/status based on exit code of " (vector-ref exit-info 1) " and rollup-status of " rollup-status) - (tests:test-set-status! test-id + (tests:test-set-status! run-id + test-id new-state new-status (args:get-arg "-m") #f) ;; need to update the top test record if PASS or FAIL and this is a subtest ;; NO NEED TO CALL roll-up-pass-fail-counts HERE, THIS IS DONE IN roll-up-pass-fail-counts called by tests:test-set-status! @@ -497,11 +500,12 @@ (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 - (rmt:general-call 'test-set-rundir-by-test-id lnkpathf test-id) + ;; (cdb:test-set-rundir-by-test-id *runremote* test-id (filedb:register-path *fdb* lnkpathf)) + (rmt:general-call 'test-set-rundir-shortdir run-id lnkpathf test-path testname item-path) (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) @@ -514,25 +518,10 @@ ;; update the toptest record with its location rundir, cache the path ;; This wass highly inefficient, one db write for every subtest, potentially ;; thousands of unnecessary updates, cache the fact it was set and don't set it ;; 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 (rmt:get-test-info-by-id 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) - ;; NB// Was this for the test or for the parent in an iterated test? - (rmt:general-call 'test-set-rundir lnkpath run-id testname "") ;; toptest-path) - (if (or (not curr-test-path) - (not (directory-exists? toptest-path))) - (begin - (debug:print-info 2 "Creating " toptest-path " and link " lnkpath) - (create-directory toptest-path #t) - (hash-table-set! *toptest-paths* testname toptest-path))))) - ;; Now create the link from the test path to the link tree, however ;; if the test is iterated it is necessary to create the parent path ;; to the iteration. use pathname-directory to trim the path by one ;; level (if (not not-iterated) ;; i.e. iterated @@ -560,10 +549,39 @@ (begin (debug:print 0 "ERROR: Failed to create symlink " lnkpath ((condition-property-accessor 'exn 'message) exn) ", exiting") (exit 1)) (create-symbolic-link toptest-path lnkpath))) + ;; NB - This was not working right - some top tests are not getting the path set!!! + ;; + ;; Do the setting of this record after the paths are created so that the shortdir can + ;; be set to the real directory location. This is safer for future clean up if the link + ;; tree is damaged or lost. + ;; + (if (not (hash-table-ref/default *toptest-paths* testname #f)) + (let* ((testinfo (rmt:get-test-info-by-id run-id test-id)) ;; run-id testname item-path)) + (curr-test-path (if testinfo ;; (filedb:get-path *fdb* + ;; (db:get-path dbstruct + ;; (rmt:sdb-qry 'getstr + (db:test-get-rundir testinfo) ;; ) ;; ) + #f))) + (hash-table-set! *toptest-paths* testname curr-test-path) + ;; NB// Was this for the test or for the parent in an iterated test? + ;;(cdb:test-set-rundir! *runremote* run-id testname "" (filedb:register-path *fdb* lnkpath)) ;; toptest-path) + (rmt:general-call 'test-set-rundir-shortdir run-id lnkpath + (if (file-exists? lnkpath) + (resolve-pathname lnkpath) + lnkpath) + testname "") + ;; (rmt:general-call 'test-set-rundir run-id lnkpath testname "") ;; toptest-path) + (if (or (not curr-test-path) + (not (directory-exists? toptest-path))) + (begin + (debug:print-info 2 "Creating " toptest-path " and link " lnkpath) + (create-directory toptest-path #t) + (hash-table-set! *toptest-paths* testname toptest-path))))) + ;; The toptest path has been created, the link to the test in the linktree has ;; been created. Now, if this is an iterated test the real test dir must be created (if (not not-iterated) ;; this is an iterated test (let ((lnktarget (conc lnkpath "/" item-path))) (debug:print 2 "Setting up sub test run area") @@ -657,11 +675,11 @@ (cmdparms #f) (fullcmd #f) ;; (define a (with-output-to-string (lambda ()(write x)))) (mt-bindir-path #f) (item-path (item-list->path itemdat)) ;; (test-id (cdb:remote-run db:get-test-id #f run-id test-name item-path)) - (testinfo (rmt:get-test-info-by-id test-id)) + (testinfo (rmt:get-test-info-by-id run-id test-id)) (mt_target (string-intersperse (map cadr keyvals) "/")) (debug-param (append (if (args:get-arg "-debug") (list "-debug" (args:get-arg "-debug")) '()) (if (args:get-arg "-logging")(list "-logging") '())))) (setenv "MT_ITEMPATH" item-path) (if hosts (set! hosts (string-split hosts))) @@ -704,11 +722,11 @@ (list 'mt-bindir-path mt-bindir-path))))))) ;; clean out step records from previous run if they exist ;; (debug:print-info 4 "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")) + (tests:test-set-status! run-id 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 Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -25,10 +25,12 @@ (declare (uses client)) (declare (uses tests)) (declare (uses genexample)) (declare (uses daemon)) (declare (uses db)) +;; (declare (uses sdb)) +;; (declare (uses filedb)) (declare (uses tdb)) (declare (uses mt)) (declare (uses api)) (define *db* #f) ;; this is only for the repl, do not use in general!!!! @@ -239,10 +241,14 @@ "-rollup" "-update-meta" "-gen-megatest-area" "-mark-incompletes" + "-convert-to-norm" + "-convert-to-old" + "-import-megatest.db" + "-logging" "-v" ;; verbose 2, more than normal (normal is 1) "-q" ;; quiet 0, errors/warnings only ) args:arg-hash @@ -349,14 +355,15 @@ (if (null? (lset-intersection equal? (hash-table-keys args:arg-hash) '("-list-servers" "-stop-server" - "-show-cmdinfo"))) + "-show-cmdinfo" + "-list-runs"))) (if (setup-for-run) (begin - + ;; (set! *fdb* (filedb:open-db (conc *toppath* "/db/paths.db"))) ;; if not list or kill then start a client (if appropriate) (if (or (args-defined? "-h" "-version" "-gen-megatest-area" "-gen-megatest-test") (eq? (length (hash-table-keys args:arg-hash)) 0)) (debug:print-info 1 "Server connection not needed") ;; ok, so lets connect to the server @@ -377,38 +384,17 @@ (debug:print 2 "chosen-transport: " chosen-transport " have; config=" transport-from-config ", cmdln=" transport-from-cmdln ", cmdinfo=" transport-from-cmdinfo) (case chosen-transport ((http) (set! *transport-type 'http) (server:ensure-running) + ;; Get rid of this + (client:launch)) (else ;; (fs) + (debug:print 0 "ERROR: Should NOT be getting here! fs transport is no longer supported") (set! *transport-type* 'fs) - (set! *megatest-db* (open-db)))))))))) -;; (cond -;; ;; command line overrides other mechanisms -;; (transport-from-cmdln -;; (if (equal? transport-from-cmdln "fs") -;; (set! *transport-type* 'fs) -;; (begin -;; (server:ensure-running) -;; (client:launch)))) -;; ;; cmdinfo is second priority -;; (transport-from-cmdinfo -;; (if (equal? transport-from-cmdinfo "fs") -;; (set! *transport-type* 'fs) -;; (begin -;; (server:ensure-running) -;; (client:launch)))) -;; ;; config file is next highest priority for determinining transport -;; (transport-from-config -;; (if (equal? transport-from-config "fs") -;; (set! *transport-type* 'fs) -;; (begin -;; (server:ensure-running) -;; (client:launch)))) -;; (else -;; (set! *transport-type* 'fs))))))))) + (set! *megatest-db* (make-dbr:dbstruct path: *toppath* local: #t)))))))))) (if (or (args:get-arg "-list-servers") (args:get-arg "-stop-server")) (let ((tl (setup-for-run))) (if tl @@ -430,11 +416,11 @@ (pubport (vector-ref server 5)) (start-time (vector-ref server 6)) (priority (vector-ref server 7)) (state (vector-ref server 8)) (mt-ver (vector-ref server 9)) - (last-update (vector-ref server 10)) ;; (open-run-close tasks:server-alive? tasks:open-db #f hostname: hostname port: port)) + (last-update (vector-ref server 10)) (transport (vector-ref server 11)) (killed #f) (status (< last-update 20))) ;; (zmq-sockets (if status (server:client-connect hostname port) #f))) ;; no need to login as status of #t indicates we are connecting to correct @@ -579,19 +565,22 @@ ;; NOTE: list-runs and list-db-targets operate on local db!!! ;; (if (or (args:get-arg "-list-runs") (args:get-arg "-list-db-targets")) (if (setup-for-run) - (let* ((db (open-db)) + (let* ((dbstruct (make-dbr:dbstruct path: *toppath* local: #t)) (runpatt (args:get-arg "-list-runs")) (testpatt (if (args:get-arg "-testpatt") (args:get-arg "-testpatt") "%")) - (runsdat (db:get-runs db runpatt #f #f '())) + (keys (db:get-keys dbstruct)) + ;; (runsdat (db:get-runs dbstruct runpatt #f #f '())) + (runsdat (db:get-runs-by-patt dbstruct keys runpatt (or (args:get-arg "-target") + (args:get-arg "-reqtarg")) #f #f)) + ;; (cdb:remote-run db:get-runs #f runpatt #f #f '())) (runs (db:get-rows runsdat)) (header (db:get-header runsdat)) - (keys (db:get-keys db)) (db-targets (args:get-arg "-list-db-targets")) (seen (make-hash-table))) ;; Each run (for-each (lambda (run) @@ -604,11 +593,11 @@ (hash-table-set! seen targetstr #t) ;; (print "[" targetstr "]")))) (print targetstr)))) (if (not db-targets) (let* ((run-id (db:get-value-by-header run header "id")) - (tests (db:get-tests-for-run db run-id testpatt '() '() #f #f #f 'testname 'asc #f))) + (tests (db:get-tests-for-run dbstruct run-id testpatt '() '() #f #f #f 'testname 'asc #f))) (print "Run: " targetstr "/" (db:get-value-by-header run header "runname") " status: " (db:get-value-by-header run header "state") " run-id: " run-id ", number tests: " (length tests)) (for-each (lambda (test) @@ -627,16 +616,18 @@ (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) + "\n uname: " ;; (sdb:qry 'getstr + (db:test-get-uname test) ;; ) + "\n rundir: " ;; (sdb:qry 'getstr ;; (filedb:get-path *fdb* + (db:test-get-rundir test) ;; ) ) ;; Each test ;; DO NOT remote run - (let ((steps (db:get-steps-for-test db (db:test-get-id test)))) + (let ((steps (db:get-steps-for-test dbstruct run-id (db:test-get-id test)))) (for-each (lambda (step) (format #t " Step: ~20a State: ~10a Status: ~10a Time ~22a\n" (tdb:step-get-stepname step) @@ -644,11 +635,12 @@ (tdb:step-get-status step) (tdb:step-get-event_time step))) steps))))) tests))))) runs) - (set! *didsomething* #t)))) + (db:close-all dbstruct) + (set! *didsomething* #t)))) ;;====================================================================== ;; full run ;;====================================================================== @@ -752,11 +744,10 @@ (test-name (assoc/default 'test-name cmdinfo)) (runscript (assoc/default 'runscript cmdinfo)) (db-host (assoc/default 'db-host cmdinfo)) (run-id (assoc/default 'run-id cmdinfo)) (itemdat (assoc/default 'itemdat cmdinfo)) - (db #f) (state (args:get-arg ":state")) (status (args:get-arg ":status")) (target (args:get-arg "-target")) (toppath (assoc/default 'toppath cmdinfo))) (change-directory toppath) @@ -770,11 +761,11 @@ (begin (debug:print 0 "Failed to setup, giving up on -test-paths or -test-files, exiting") (exit 1))) (let* ((keys (rmt:get-keys)) ;; db:test-get-paths must not be run remote - (paths (db:test-get-paths-matching db keys target (args:get-arg "-test-files")))) + (paths (tests:test-get-paths-matching keys target (args:get-arg "-test-files")))) (set! *didsomething* #t) (for-each (lambda (path) (print path)) paths))) ;; else do a general-run-call @@ -782,11 +773,11 @@ "-test-files" "Get paths to test" (lambda (target runname keys keyvals) (let* ((db #f) ;; DO NOT run remote - (paths (db:test-get-paths-matching db keys target (args:get-arg "-test-files")))) + (paths (tests:test-get-paths-matching keys target (args:get-arg "-test-files")))) (for-each (lambda (path) (print path)) paths)))))) ;;====================================================================== @@ -804,11 +795,10 @@ (test-name (assoc/default 'test-name cmdinfo)) (runscript (assoc/default 'runscript cmdinfo)) (db-host (assoc/default 'db-host cmdinfo)) (run-id (assoc/default 'run-id cmdinfo)) (itemdat (assoc/default 'itemdat cmdinfo)) - (db (open-db)) (state (args:get-arg ":state")) (status (args:get-arg ":status")) (target (args:get-arg "-target"))) (change-directory testpath) ;; (set! *runremote* runremote) @@ -819,30 +809,27 @@ (exit 1))) (if (not (setup-for-run)) (begin (debug:print 0 "Failed to setup, giving up on -archive, exiting") (exit 1))) - (let* ((keys (db:get-keys db)) - ;; DO NOT run remote - (paths (db:test-get-paths-matching db keys target))) + (let* ((keys (rmt:get-keys)) + (paths (tests:test-get-paths-matching keys target))) (set! *didsomething* #t) (for-each (lambda (path) (print path)) paths)) - (if (sqlite3:database? db)(sqlite3:finalize! db))) + ;; (if (sqlite3:database? db)(sqlite3:finalize! db)) + ) ;; else do a general-run-call (general-run-call "-test-paths" "Get paths to tests" (lambda (target runname keys keyvals) - (let* ((db (open-db)) - ;; DO NOT run remote - (paths (db:test-get-paths-matching db keys target))) + (let* ((paths (tests:test-get-paths-matching keys target))) (for-each (lambda (path) (print path)) - paths) - (sqlite3:finalize! db)))))) + paths)))))) ;;====================================================================== ;; Extract a spreadsheet from the runs database ;;====================================================================== @@ -849,18 +836,18 @@ (if (args:get-arg "-extract-ods") (general-run-call "-extract-ods" "Make ods spreadsheet" (lambda (target runname keys keyvals) - (let ((db (open-db)) + (let ((dbstruct (make-dbr:dbstruct path: *toppath* local: #t)) (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 " keyvals: " keyvals) - (db:extract-ods-file db outputfile keyvals (if runspatt runspatt "%") pathmod) - (sqlite3:finalize! db) + (db:extract-ods-file dbstruct outputfile keyvals (if runspatt runspatt "%") pathmod) + (db:close-all dbstruct) (set! *didsomething* #t))))) ;;====================================================================== ;; execute the test ;; - gets called on remote host @@ -902,11 +889,11 @@ (if (not (setup-for-run)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) (if (and state status) - (rmt:teststep-set-status! test-id step state status msg logfile) + (rmt:teststep-set-status! run-id test-id step state status msg logfile) (begin (debug:print 0 "ERROR: You must specify :state and :status with every call to -step") (exit 6)))))) (if (args:get-arg "-step") @@ -961,14 +948,15 @@ ;; (client:setup) (if (args:get-arg "-load-test-data") ;; has sub commands that are rdb: ;; DO NOT put this one into either cdb:remote-run or open-run-close - (tdb:load-test-data test-id)) + (tdb:load-test-data run-id test-id)) (if (args:get-arg "-setlog") (let ((logfname (args:get-arg "-setlog"))) - (rmt:test-set-log! test-id logfname))) + ;; (cdb:test-set-log! *runremote* test-id (sdb:qry 'getid logfname)))) + (rmt:test-set-log! run-id test-id logfname))) (if (args:get-arg "-set-toplog") ;; DO NOT run remote (tests:test-set-toplog! run-id test-name (args:get-arg "-set-toplog"))) (if (args:get-arg "-summarize-items") ;; DO NOT run remote @@ -992,11 +980,11 @@ (else ">&"))) (fullcmd (conc "(" (string-intersperse (cons cmd params) " ") ") " redir " " logfile))) ;; mark the start of the test - (rmt:teststep-set-status! test-id stepname "start" "n/a" (args:get-arg "-m") logfile) + (rmt:teststep-set-status! run-id test-id stepname "start" "n/a" (args:get-arg "-m") logfile) ;; run the test step (debug:print-info 2 "Running \"" fullcmd "\" in directory \"" startingdir) (change-directory startingdir) (set! exitstat (system fullcmd)) (set! *globalexitstatus* exitstat) @@ -1009,13 +997,14 @@ (debug:print-info 2 "running \"" cmd "\"") (change-directory startingdir) (set! exitstat (system cmd)) (set! *globalexitstatus* exitstat) ;; no necessary (change-directory testpath) - (rmt:test-set-log! test-id htmllogfile))) + ;; (cdb:test-set-log! *runremote* test-id (sdb:qry 'getid htmllogfile)))) + (rmt:test-set-log! run-id test-id htmllogfile))) (let ((msg (args:get-arg "-m"))) - (rmt:teststep-set-status! test-id stepname "end" exitstat msg logfile)) + (rmt:teststep-set-status! run-id 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")) @@ -1038,11 +1027,11 @@ (if (sqlite3:database? db)(sqlite3:finalize! db)) (exit 6))) (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 work-area: work-area)))) + (tests:test-set-status! run-id test-id state newstatus msg otherdata work-area: work-area)))) (if (sqlite3:database? db)(sqlite3:finalize! db)) (set! *didsomething* #t)))) ;;====================================================================== ;; Various helper commands can go below here @@ -1143,26 +1132,75 @@ ;;====================================================================== (if (or (args:get-arg "-repl") (args:get-arg "-load")) (let* ((toppath (setup-for-run)) - (db (if toppath (open-db) #f))) - (if db + (dbstruct (if toppath (make-dbr:dbstruct path: toppath local: #t) #f))) + (if dbstruct (begin - (set! *db* db) + (set! *db* dbstruct) (set! *client-non-blocking-mode* #t) (import readline) (import apropos) + ;; (import (prefix sqlite3 sqlite3:)) ;; doesn't work ... (gnu-history-install-file-manager (string-append (or (get-environment-variable "HOME") ".") "/.megatest_history")) (current-input-port (make-gnu-readline-port "megatest> ")) (if (args:get-arg "-repl") (repl) - (load (args:get-arg "-load")))) + (load (args:get-arg "-load"))) + (db:close-all dbstruct)) (exit)) (set! *didsomething* #t))) + +;; Not converted to use dbstruct yet +;; +(if (args:get-arg "-convert-to-norm") + (let* ((toppath (setup-for-run)) + (dbstruct (if toppath (make-dbr:dbstruct path: toppath local: #t)))) + (for-each + (lambda (field) + (let ((dat '())) + (debug:print-info 0 "Getting data for field " field) + (sqlite3:for-each-row + (lambda (id val) + (set! dat (cons (list id val) dat))) + (get-db db run-id) + (conc "SELECT id," field " FROM tests;")) + (debug:print-info 0 "found " (length dat) " items for field " field) + (let ((qry (sqlite3:prepare db (conc "UPDATE tests SET " field "=? WHERE id=?;")))) + (for-each + (lambda (item) + (let ((newval ;; (sdb:qry 'getid + (cadr item))) ;; ) + (if (not (equal? newval (cadr item))) + (debug:print-info 0 "Converting " (cadr item) " to " newval " for test #" (car item))) + (sqlite3:execute qry newval (car item)))) + dat) + (sqlite3:finalize! qry)))) + (db:close-all dbstruct) + (list "uname" "rundir" "final_logf" "comment")) + (set! *didsomething* #t))) + +(if (args:get-arg "-import-megatest.db") + (let* ((toppath (setup-for-run)) + (dbstruct (if toppath (make-dbr:dbstruct path: toppath) #f)) + (mtdb (if toppath (db:open-megatest-db))) + (run-ids (if toppath (db:get-run-ids mtdb)))) + ;; sync runs, test_meta etc. + (db:sync-tables (db:sync-main-list mtdb) mtdb (db:get-db dbstruct #f)) + (for-each + (lambda (run-id) + (let ((testrecs (db:get-all-tests-info-by-run-id mtdb run-id))) + (debug:print 0 "INFO: Updating " (length testrecs) " records for run-id=" run-id) + (db:replace-test-records dbstruct run-id testrecs))) + run-ids) + (set! *didsomething* #t) + (db:close-all dbstruct))) + + ;;====================================================================== ;; Exit and clean up ;;====================================================================== @@ -1171,10 +1209,13 @@ ;; this is the socket if we are a client ;; (if (and *runremote* ;; (socket? *runremote*)) ;; (close-socket *runremote*)) +;; (if sdb:qry (sdb:qry 'finalize #f)) +;; (if *fdb* (filedb:finalize-db! *fdb*)) + (if (not *didsomething*) (debug:print 0 help)) ;; (if *runremote* (rpc:close-all-connections!)) Index: mt.scm ================================================================== --- mt.scm +++ mt.scm @@ -18,10 +18,11 @@ (declare (uses runconfig)) (declare (uses tests)) (declare (uses server)) (declare (uses runs)) (declare (uses rmt)) +;; (declare (uses filedb)) (include "common_records.scm") (include "key_records.scm") (include "db_records.scm") (include "run_records.scm") @@ -96,13 +97,13 @@ result) (let ((newres (rmt:get-prereqs-not-met run-id waitons ref-item-path mode: mode))) (hash-table-set! *pre-reqs-met-cache* key (vector (current-seconds) newres)) newres)))) +(define (mt:get-run-stats dbstruct run-id) ;; Get run stats from local access, move this ... but where? -(define (mt:get-run-stats) - (db:get-run-stats #f)) + (db:get-run-stats dbstruct run-id)) (define (mt:discard-blocked-tests run-id failed-test tests test-records) (if (null? tests) tests (begin @@ -124,18 +125,20 @@ ;;====================================================================== ;; T R I G G E R S ;;====================================================================== -(define (mt:process-triggers test-id newstate newstatus) - (let* ((test-dat (rmt:get-test-info-by-id test-id)) - (test-rundir (db:test-get-rundir test-dat)) +(define (mt:process-triggers run-id test-id newstate newstatus) + (let* ((test-dat (rmt:get-test-info-by-id run-id test-id)) + (test-rundir ;; (rmt:sdb-qry 'getstr ;; (filedb:get-path *fdb* + (db:test-get-rundir test-dat)) ;; ) ;; ) (test-name (db:test-get-testname test-dat)) (tconfig #f) (state (if newstate newstate (db:test-get-state test-dat))) (status (if newstatus newstatus (db:test-get-status test-dat)))) - (if (and (file-exists? test-rundir) + (if (and test-rundir ;; #f means no dir set yet + (file-exists? test-rundir) (directory? test-rundir)) (begin (push-directory test-rundir) (set! tconfig (mt:lazy-read-test-config test-name)) (pop-directory) @@ -157,31 +160,23 @@ ;;====================================================================== ;; S T A T E A N D S T A T U S F O R T E S T S ;;====================================================================== ;; speed up for common cases with a little logic -(define (mt:test-set-state-status-by-id test-id newstate newstatus newcomment) +(define (mt:test-set-state-status-by-id run-id test-id newstate newstatus newcomment) (cond ((and newstate newstatus newcomment) - (rmt:general-call 'state-status-msg newstate newstatus newcomment test-id)) + (rmt:general-call 'state-status-msg run-id newstate newstatus newcomment test-id)) ((and newstate newstatus) - (rmt:general-call 'state-status newstate newstatus test-id)) + (rmt:general-call 'state-status run-id newstate newstatus test-id)) (else - (if newstate (rmt:general-call 'set-test-state newstate test-id)) - (if newstatus (rmt:general-call 'set-test-status newstatus test-id)) - (if newcomment (rmt:general-call 'set-test-comment newcomment test-id)))) - (mt:process-triggers test-id newstate newstatus) + (if newstate (rmt:general-call 'set-test-state run-id newstate test-id)) + (if newstatus (rmt:general-call 'set-test-status run-id newstatus test-id)) + (if newcomment (rmt:general-call 'set-test-comment run-id newcomment test-id)))) + (mt:process-triggers run-id test-id newstate newstatus) #t) -(define (mt:lazy-get-test-info-by-id test-id) - (let* ((tdat (hash-table-ref/default *test-info* test-id #f))) - (if (and tdat - (< (current-seconds)(+ (vector-ref tdat 0) 10))) - (vector-ref tdat 1) - ;; no need to update *test-info* as that is done in cdb:get-test-info-by-id - (cdb:get-test-info-by-id *runremote* test-id)))) - (define (mt:lazy-read-test-config test-name) (let ((tconf (hash-table-ref/default *testconfigs* test-name #f))) (if tconf tconf (let ((test-dirs (tests:get-tests-search-path *configdat*))) Index: newdashboard.scm ================================================================== --- newdashboard.scm +++ newdashboard.scm @@ -568,13 +568,13 @@ (iup:attribute-set! tabtop "TABTITLE4" "runconfigs.config") tabtop))) (define *current-window-id* 0) -(define (newdashboard) +(define (newdashboard dbstruct) (let* ((data (make-hash-table)) - (keys (cdb:remote-run db:get-keys #f)) + (keys (db:get-keys dbstruct)) (runname "%") (testpatt "%") (keypatts (map (lambda (k)(list k "%")) keys)) (states '()) (statuses '()) Index: rmt.scm ================================================================== --- rmt.scm +++ rmt.scm @@ -81,16 +81,22 @@ (define (rmt:kill-server) (rmt:send-receive 'kill-server '())) ;; hand off a call to one of the db:queries statements -(define (rmt:general-call stmtname . params) - (rmt:send-receive 'general-call (append (list stmtname) params))) +;; added run-id to make looking up the correct db possible +;; +(define (rmt:general-call stmtname run-id . params) + (rmt:send-receive 'general-call (append (list stmtname run-id) params))) (define (rmt:sync-inmem->db) (rmt:send-receive 'sync-inmem->db '())) +(define (rmt:sdb-qry qry val) + ;; add caching if qry is 'getid or 'getstr + (rmt:send-receive 'sdb-qry (list qry val))) + ;;====================================================================== ;; K E Y S ;;====================================================================== (define (rmt:get-key-val-pairs run-id) @@ -104,41 +110,51 @@ ;;====================================================================== (define (rmt:get-test-id run-id testname item-path) (rmt:send-receive 'get-test-id (list run-id testname item-path))) -(define (rmt:get-test-info-by-id test-id) - (rmt:send-receive 'get-test-info-by-id (list test-id))) +(define (rmt:get-test-info-by-id run-id test-id) + (if (and (number? run-id)(number? test-id)) + (rmt:send-receive 'get-test-info-by-id (list run-id test-id)) + (begin + (debug:print 0 "ERROR: Bad data handed to rmt:get-test-info-by-id run-id=" run-id ", test-id=" test-id) + (print-call-chain) + #f))) -(define (rmt:test-get-rundir-from-test-id test-id) - (rmt:send-receive 'test-get-rundir-from-test-id (list test-id))) +(define (rmt:test-get-rundir-from-test-id run-id test-id) + (rmt:send-receive 'test-get-rundir-from-test-id (list run-id test-id))) -(define (rmt:open-test-db-by-test-id test-id #!key (work-area #f)) +(define (rmt:open-test-db-by-test-id run-id test-id #!key (work-area #f)) (let* ((test-path (if (string? work-area) work-area - (rmt:test-get-rundir-from-test-id test-id)))) + (rmt:test-get-rundir-from-test-id run-id test-id)))) (debug:print 3 "TEST PATH: " test-path) (open-test-db test-path))) ;; WARNING: This currently bypasses the transaction wrapped writes system -(define (rmt:test-set-state-status-by-id test-id newstate newstatus newcomment) - (rmt:send-receive 'test-set-state-status-by-id (list test-id newstate newstatus newcomment))) +(define (rmt:test-set-state-status-by-id run-id test-id newstate newstatus newcomment) + (rmt:send-receive 'test-set-state-status-by-id (list run-id test-id newstate newstatus newcomment))) (define (rmt:set-tests-state-status run-id testnames currstate currstatus newstate newstatus) (rmt:send-receive 'set-tests-state-status (list run-id testnames currstate currstatus newstate newstatus))) (define (rmt:get-tests-for-run run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals) - (rmt:send-receive 'get-tests-for-run (list run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals))) + (if (number? run-id) + (rmt:send-receive 'get-tests-for-run (list run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals)) + (begin + (debug:print "ERROR: rmt:get-tests-for-run called with bad run-id=" run-id) + (print-call-chain) + '()))) (define (rmt:get-tests-for-runs-mindata run-ids testpatt states status not-in) (rmt:send-receive 'get-tests-for-runs-mindata (list run-ids testpatt states status not-in))) -(define (rmt:delete-test-records test-id) - (rmt:send-receive 'delete-test-records (list test-id))) +(define (rmt:delete-test-records run-id test-id) + (rmt:send-receive 'delete-test-records (list run-id test-id))) -(define (rmt:test-set-status-state test-id status state msg) - (rmt:send-receive 'test-set-status-state (list test-id status state msg))) +(define (rmt:test-set-status-state run-id test-id status state msg) + (rmt:send-receive 'test-set-status-state (list run-id test-id status state msg))) (define (rmt:get-previous-test-run-record run-id test-name item-path) (rmt:send-receive 'get-previous-test-run-record (list run-id test-name item-path))) (define (rmt:get-matching-previous-test-run-records run-id test-name item-path) @@ -148,15 +164,15 @@ (rmt:send-receive 'test-get-logfile-info (list run-id test-name))) (define (rmt:test-get-records-for-index-file run-id test-name) (rmt:send-receive 'test-get-records-for-index-file (list run-id test-name))) -(define (rmt:get-testinfo-state-status test-id) - (rmt:send-receive 'get-testinfo-state-status (list test-id))) +(define (rmt:get-testinfo-state-status run-id test-id) + (rmt:send-receive 'get-testinfo-state-status (list run-id test-id))) -(define (rmt:test-set-log! test-id logf) - (if (string? logf)(rmt:general-call 'test-set-log logf test-id))) +(define (rmt:test-set-log! run-id test-id logf) + (if (string? logf)(rmt:general-call 'test-set-log run-id logf test-id))) (define (rmt:test-get-paths-matching-keynames-target-new keynames target res testpatt statepatt statuspatt runname) (rmt:send-receive 'test-get-paths-matching-keynames-target-new (list keynames target res testpatt statepatt statuspatt runname))) (define (rmt:get-prereqs-not-met run-id waitons ref-item-path #!key (mode 'normal)) @@ -165,21 +181,21 @@ (define (rmt:get-count-tests-running-for-run-id run-id) (rmt:send-receive 'get-count-tests-running-for-run-id (list run-id))) ;; Statistical queries -(define (rmt:get-count-tests-running) - (rmt:send-receive 'get-count-tests-running '())) +(define (rmt:get-count-tests-running run-id) + (rmt:send-receive 'get-count-tests-running (list run-id))) -(define (rmt:get-count-tests-running-in-jobgroup jobgroup) - (rmt:send-receive 'get-count-tests-running-in-jobgroup (list jobgroup))) +(define (rmt:get-count-tests-running-in-jobgroup run-id jobgroup) + (rmt:send-receive 'get-count-tests-running-in-jobgroup (list run-id jobgroup))) (define (rmt:roll-up-pass-fail-counts run-id test-name item-path status) (rmt:send-receive 'roll-up-pass-fail-counts (list run-id test-name item-path status))) (define (rmt:update-pass-fail-counts run-id test-name) - (rmt:general-call 'update-fail-pass-counts run-id test-name run-id test-name run-id test-name)) + (rmt:general-call 'update-fail-pass-counts (list run-id test-name run-id test-name run-id test-name))) ;;====================================================================== ;; R U N S ;;====================================================================== @@ -224,17 +240,17 @@ ;; 2. Continue as above ;; (define (rmt:get-steps-for-test test-id) (rmt:send-receive 'get-steps-data (list test-id))) -(define (rmt:teststep-set-status! test-id teststep-name state-in status-in comment logfile) +(define (rmt:teststep-set-status! run-id test-id teststep-name state-in status-in comment logfile) (let* ((state (items:check-valid-items "state" state-in)) (status (items:check-valid-items "status" status-in))) (if (or (not state)(not status)) (debug:print 3 "WARNING: Invalid " (if status "status" "state") " value \"" (if status state-in status-in) "\", update your validvalues section in megatest.config")) - (rmt:send-receive 'teststep-set-status! (list test-id teststep-name state-in status-in comment logfile)))) + (rmt:send-receive 'teststep-set-status! (list run-id test-id teststep-name state-in status-in comment logfile)))) (define (rmt:get-steps-for-test test-id) (rmt:send-receive 'get-steps-for-test (list test-id))) ;;====================================================================== @@ -254,10 +270,10 @@ (rmt:send-receive 'testmeta-get-record (list testname))) (define (rmt:testmeta-update-field test-name fld val) (rmt:send-receive 'testmeta-update-field (list test-name fld val))) -(define (rmt:test-data-rollup test-id status) - (rmt:send-receive 'test-data-rollup (list test-id status))) +(define (rmt:test-data-rollup run-id test-id status) + (rmt:send-receive 'test-data-rollup (list run-id test-id status))) -(define (rmt:csv->test-data test-id csvdata) - (rmt:send-receive 'csv->test-data (list test-id csvdata))) +(define (rmt:csv->test-data run-id test-id csvdata) + (rmt:send-receive 'csv->test-data (list run-id test-id csvdata))) Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -19,10 +19,11 @@ (declare (uses items)) (declare (uses runconfig)) (declare (uses tests)) (declare (uses server)) (declare (uses mt)) +;; (declare (uses filedb)) (include "common_records.scm") (include "key_records.scm") (include "db_records.scm") (include "run_records.scm") @@ -57,15 +58,10 @@ (runconfig #f) (serverdat (if (args:get-arg "-server") *runremote* #f)) ;; to be used later (transport (or (args:get-arg "-transport") 'http)) - (db (if (and mconfig - (or (args:get-arg "-server") - (eq? transport 'fs))) - (open-db) - #f)) (run-id #f)) ;; Set all the environment vars we know so far, start with keys (for-each (lambda (keyval) (setenv (car keyval)(cadr keyval))) keyvals) @@ -163,17 +159,20 @@ (begin (hash-table-set! *runs:denoise* key currtime) #t) #f))) -(define (runs:can-run-more-tests jobgroup max-concurrent-jobs) +(define (runs:can-run-more-tests run-id jobgroup max-concurrent-jobs) (thread-sleep! (cond ((> *runs:can-run-more-tests-count* 20) 2);; obviously haven't had any work to do for a while (else 0))) - (let* ((num-running (rmt:get-count-tests-running)) - (num-running-in-jobgroup (rmt:get-count-tests-running-in-jobgroup jobgroup)) - (job-group-limit (config-lookup *configdat* "jobgroups" jobgroup))) + (let* ((num-running (rmt:get-count-tests-running run-id)) + (num-running-in-jobgroup (rmt:get-count-tests-running-in-jobgroup run-id jobgroup)) + (job-group-limit (let ((jobg-count (config-lookup *configdat* "jobgroups" jobgroup))) + (if (string? jobg-count) + (string->number jobg-count) + jobg-count)))) (if (> (+ num-running num-running-in-jobgroup) 0) (set! *runs:can-run-more-tests-count* (+ *runs:can-run-more-tests-count* 1))) (if (not (eq? *last-num-running-tests* num-running)) (begin (debug:print 2 "max-concurrent-jobs: " max-concurrent-jobs ", num-running: " num-running) @@ -190,12 +189,13 @@ #t) ;; if job-group-limit is set and number of jobs in the group is greater ;; than the limit then cannot run more jobs of this kind ((and job-group-limit (>= num-running-in-jobgroup job-group-limit)) - (debug:print 1 "WARNING: number of jobs " num-running-in-jobgroup - " in " jobgroup " exceeded, will not run " (tests:testqueue-get-testname test-record)) + (if (runs:lownoise (conc "maxjobgroup " jobgroup) 60) + (debug:print 1 "WARNING: number of jobs " num-running-in-jobgroup + " in jobgroup \"" jobgroup "\" exceeds limit of " job-group-limit)) #t) (else #f)))) (list (not can-not-run-more) num-running num-running-in-jobgroup max-concurrent-jobs job-group-limit))))) ;; test-names: Comma separated patterns same as test-patts but used in selection @@ -213,13 +213,10 @@ (test-records (make-hash-table)) (all-tests-registry (tests:get-all)) ;; (tests:get-valid-tests (make-hash-table) test-search-path)) ;; all valid tests to check waiton names (all-test-names (hash-table-keys all-tests-registry)) (test-names (tests:filter-test-names all-test-names test-patts))) - ;; Update the synchronous setting in the db based on the default or what is set by the user - ;; This is done once here on a call to run tests rather than on every call to open-db - (set-megatest-env-vars run-id inkeys: keys inrunname: runname) ;; these may be needed by the launching process (if (file-exists? runconfigf) (setup-env-defaults runconfigf run-id *already-seen-runconfig-info* keyvals "pre-launch-env-vars") (debug:print 0 "WARNING: You do not have a run config file: " runconfigf)) @@ -384,11 +381,11 @@ (define runs:nothing-left-in-queue-count 0) (define (runs:expand-items hed tal reg reruns regfull newtal jobgroup max-concurrent-jobs run-id waitons item-path testmode test-record can-run-more items runname tconfig reglen test-registry test-records) (let* ((loop-list (list hed tal reg reruns)) - (prereqs-not-met (rmt:get-prereqs-not-met run-id waitons item-path mode: testmode)) ;; (mt:lazy-get-prereqs-not-met run-id waitons item-path mode: testmode)) + (prereqs-not-met (rmt:get-prereqs-not-met run-id waitons item-path testmode)) (fails (runs:calc-fails prereqs-not-met)) (non-completed (runs:calc-not-completed prereqs-not-met))) (debug:print-info 4 "START OF INNER COND #2 " "\n can-run-more: " can-run-more "\n testname: " hed @@ -583,17 +580,17 @@ (else (conc t)))) inlst)) (define (runs:process-expanded-tests hed tal reg reruns reglen regfull test-record runname test-name item-path jobgroup max-concurrent-jobs run-id waitons item-path testmode test-patts required-tests test-registry registry-mutex flags keyvals run-info newtal all-tests-registry) - (let* ((run-limits-info (runs:can-run-more-tests jobgroup max-concurrent-jobs)) ;; look at the test jobgroup and tot jobs running + (let* ((run-limits-info (runs:can-run-more-tests run-id jobgroup max-concurrent-jobs)) ;; look at the test jobgroup and tot jobs running (have-resources (car run-limits-info)) (num-running (list-ref run-limits-info 1)) (num-running-in-jobgroup (list-ref run-limits-info 2)) (max-concurrent-jobs (list-ref run-limits-info 3)) (job-group-limit (list-ref run-limits-info 4)) - (prereqs-not-met (rmt:get-prereqs-not-met run-id waitons item-path mode: testmode)) ;; (mt:lazy-get-prereqs-not-met run-id waitons item-path mode: testmode)) + (prereqs-not-met (rmt:get-prereqs-not-met run-id waitons item-path testmode)) (fails (runs:calc-fails prereqs-not-met)) (non-completed (runs:calc-not-completed prereqs-not-met)) (loop-list (list hed tal reg reruns))) (debug:print-info 4 "have-resources: " have-resources " prereqs-not-met: (" (string-intersperse @@ -629,20 +626,20 @@ ;; ((not (hash-table-ref/default test-registry (runs:make-full-test-name test-name item-path) #f)) (debug:print-info 4 "Pre-registering test " test-name "/" item-path " to create placeholder" ) (if (eq? *transport-type* 'fs) ;; no point in parallel registration if use fs (begin - (rmt:general-call 'register-test run-id test-name item-path) + (rmt:general-call 'register-test run-id run-id test-name item-path) (hash-table-set! test-registry (runs:make-full-test-name test-name item-path) 'done)) (let ((th (make-thread (lambda () (mutex-lock! registry-mutex) (hash-table-set! test-registry (runs:make-full-test-name test-name item-path) 'start) (mutex-unlock! registry-mutex) ;; If haven't done it before register a top level test if this is an itemized test (if (not (eq? (hash-table-ref/default test-registry (runs:make-full-test-name test-name "") #f) 'done)) - (rmt:general-call 'register-test run-id test-name "")) - (rmt:general-call 'register-test run-id test-name item-path) + (rmt:general-call 'register-test run-id run-id test-name "")) + (rmt:general-call 'register-test run-id run-id test-name item-path) (mutex-lock! registry-mutex) (hash-table-set! test-registry (runs:make-full-test-name test-name item-path) 'done) (mutex-unlock! registry-mutex)) (conc test-name "/" item-path)))) (thread-start! th))) @@ -797,11 +794,11 @@ ;; (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)) - (jobgroup (config-lookup tconfig "requirements" "jobgroup")) + (jobgroup (config-lookup tconfig "test_meta" "jobgroup")) (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 @@ -821,11 +818,11 @@ ;; Ensure all top level tests get registered. This way they show up as "NOT_STARTED" on the dashboard ;; and it is clear they *should* have run but did not. (if (not (hash-table-ref/default test-registry (runs:make-full-test-name test-name "") #f)) (begin - (rmt:general-call 'register-test run-id test-name "") + (rmt:general-call 'register-test run-id run-id test-name "") (hash-table-set! test-registry (runs:make-full-test-name test-name "") 'done))) ;; Fast skip of tests that are already "COMPLETED" - NO! Cannot do that as the items may not have been expanded yet :( ;; (if (member (hash-table-ref/default test-registry tfullname #f) @@ -937,11 +934,11 @@ ;; 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 ;; EXPAND ITEMS ((or (procedure? items)(eq? items 'have-procedure)) - (let ((can-run-more (runs:can-run-more-tests jobgroup max-concurrent-jobs))) + (let ((can-run-more (runs:can-run-more-tests run-id jobgroup max-concurrent-jobs))) (if (and (list? can-run-more) (car can-run-more)) (let ((loop-list (runs:expand-items hed tal reg reruns regfull newtal jobgroup max-concurrent-jobs run-id waitons item-path testmode test-record can-run-more items runname tconfig reglen test-registry test-records))) (if loop-list (apply loop loop-list))) @@ -1044,11 +1041,11 @@ (runs:update-test_meta test-name test-conf))) ;; itemdat => ((ripeness "overripe") (temperature "cool") (season "summer")) (let* ((new-test-path (string-intersperse (cons test-path (map cadr itemdat)) "/")) (test-id (rmt:get-test-id run-id test-name item-path)) - (testdat (if test-id (rmt:get-test-info-by-id test-id) #f))) + (testdat (if test-id (rmt:get-test-info-by-id run-id test-id) #f))) (if (not testdat) (let loop () ;; 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)) @@ -1059,14 +1056,14 @@ ;; (if (not test-id)(set! test-id (rmt:get-test-id-cached 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) - (rmt:general-call 'register-test run-id test-name item-path) + (rmt:general-call 'register-test run-id run-id test-name item-path) (set! test-id (rmt:get-test-id run-id test-name item-path)))) (debug:print-info 4 "test-id=" test-id ", run-id=" run-id ", test-name=" test-name ", item-path=\"" item-path "\"") - (set! testdat (rmt:get-test-info-by-id test-id)) + (set! testdat (rmt:get-test-info-by-id run-id test-id)) (if (not testdat) (begin (debug:print-info 0 "WARNING: server is overloaded, trying again in one second") (thread-sleep! 1) (loop))))) @@ -1132,20 +1129,21 @@ (cond ;; Have to check for skip conditions. This one skips if there are same-named tests ;; currently running ((and skip-check (configf:lookup test-conf "skip" "prevrunning")) + ;; run-ids = #f means *all* runs (let ((running-tests (rmt:get-tests-for-runs-mindata #f full-test-name '("RUNNING" "REMOTEHOSTSTART" "LAUNCHED") '() #f))) (if (not (null? running-tests)) ;; have to skip (set! skip-test "Skipping due to previous tests running")))) ((and skip-check (configf:lookup test-conf "skip" "fileexists")) (if (file-exists? (configf:lookup test-conf "skip" "fileexists")) (set! skip-test (conc "Skipping due to existance of file " (configf:lookup test-conf "skip" "fileexists")))))) (if skip-test (begin - (mt:test-set-state-status-by-id test-id "COMPLETED" "SKIP" skip-test) + (mt:test-set-state-status-by-id run-id test-id "COMPLETED" "SKIP" skip-test) (debug:print-info 1 "SKIPPING Test " full-test-name " due to " skip-test)) (if (not (launch-test test-id run-id run-info keyvals runname test-conf test-name test-path itemdat flags)) (begin (print "ERROR: Failed to launch the test. Exiting as soon as possible") (set! *globalexitstatus* 1) ;; @@ -1257,29 +1255,33 @@ action) ((run-wait) (debug:print 1 "Waiting for run " runkey ", run=" runnamepatt " to complete")) (else (debug:print-info 0 "action not recognised " action))) - (let ((sorted-tests (sort tests (lambda (a b)(let ((dira (db:test-get-rundir a)) - (dirb (db:test-get-rundir b))) + (let ((sorted-tests (sort tests (lambda (a b)(let ((dira ;; (rmt:sdb-qry 'getstr + (db:test-get-rundir a)) ;; ) ;; (filedb:get-path *fdb* (db:test-get-rundir a))) + (dirb ;; (rmt:sdb-qry 'getstr + (db:test-get-rundir b))) ;; ) ;; ((filedb:get-path *fdb* (db:test-get-rundir b)))) (if (and (string? dira)(string? dirb)) (> (string-length dira)(string-length dirb)) #f))))) (test-retry-time (make-hash-table)) (allow-run-time 10)) ;; seconds to allow for killing tests before just brutally killing 'em (let loop ((test (car sorted-tests)) (tal (cdr sorted-tests))) (let* ((test-id (db:test-get-id test)) - (new-test-dat (rmt:get-test-info-by-id test-id))) + (new-test-dat (rmt:get-test-info-by-id run-id test-id))) (if (not new-test-dat) (begin (debug:print 0 "ERROR: We have a test-id of " test-id " but no record was found. NOTE: No locking of records is done between processes, do not simultaneously remove the same run from two processes!") (if (not (null? tal)) (loop (car tal)(cdr tal)))) (let* ((item-path (db:test-get-item-path new-test-dat)) (test-name (db:test-get-testname new-test-dat)) - (run-dir (db:test-get-rundir new-test-dat)) ;; run dir is from the link tree + (run-dir ;;(filedb:get-path *fdb* + ;; (rmt:sdb-qry 'getid + (db:test-get-rundir new-test-dat)) ;; ) ;; run dir is from the link tree (real-dir (if (file-exists? run-dir) (resolve-pathname run-dir) #f)) (test-state (db:test-get-state new-test-dat)) (test-fulln (db:test-get-fullname new-test-dat))) @@ -1296,21 +1298,21 @@ ;; This test is not in a correct state for cleaning up. Let's try some graceful shutdown steps first ;; Set the test to "KILLREQ" and wait five seconds then try again. Repeat up to five times then give ;; up and blow it away. (begin (debug:print 0 "WARNING: could not gracefully remove test " test-fulln ", tried to kill it to no avail. Forcing state to FAILEDKILL and continuing") - (mt:test-set-state-status-by-id (db:test-get-id test) "FAILEDKILL" "n/a" #f) + (mt:test-set-state-status-by-id run-id (db:test-get-id test) "FAILEDKILL" "n/a" #f) (thread-sleep! 1)) (begin - (mt:test-set-state-status-by-id (db:test-get-id test) "KILLREQ" "n/a" #f) + (mt:test-set-state-status-by-id run-id (db:test-get-id test) "KILLREQ" "n/a" #f) (thread-sleep! 1))) ;; NOTE: This is suboptimal as the testdata will be used later and the state/status may have changed ... (if (null? tal) (loop new-test-dat tal) (loop (car tal)(append tal (list new-test-dat))))) (begin - (mt:test-set-state-status-by-id (db:test-get-id test) "REMOVING" "LOCKED" #f) + (mt:test-set-state-status-by-id run-id (db:test-get-id test) "REMOVING" "LOCKED" #f) (debug:print-info 1 "Attempting to remove " (if real-dir (conc " dir " real-dir " and ") "") " link " run-dir) (if (and real-dir (> (string-length real-dir) 5) (file-exists? real-dir)) ;; bad heuristic but should prevent /tmp /home etc. (begin ;; let* ((realpath (resolve-pathname run-dir))) @@ -1338,16 +1340,16 @@ (if run-dir (debug:print 0 "WARNING: not removing " run-dir " as it either doesn't exist or is not a symlink") (debug:print 0 "NOTE: the run dir for this test is undefined. Test may have already been deleted.")) )) ;; Only delete the records *after* removing the directory. If things fail we have a record - (rmt:delete-test-records (db:test-get-id test)) + (rmt:delete-test-records (db:test-get-run_id test)(db:test-get-id test)) (if (not (null? tal)) (loop (car tal)(cdr tal)))))) ((set-state-status) (debug:print-info 2 "new state " (car state-status) ", new status " (cadr state-status)) - (mt:test-set-state-status-by-id (db:test-get-id test) (car state-status)(cadr state-status) #f) + (mt:test-set-state-status-by-id run-id (db:test-get-id test) (car state-status)(cadr state-status) #f) (if (not (null? tal)) (loop (car tal)(cdr tal)))) ((run-wait) (debug:print-info 2 "still waiting, " (length tests) " tests still running") (thread-sleep! 10) @@ -1459,11 +1461,11 @@ ;; Update the test_meta table for this test (define (runs:update-test_meta test-name test-conf) (let ((currrecord (rmt:testmeta-get-record test-name))) (if (not currrecord) (begin - (set! currrecord (make-vector 10 #f)) + (set! currrecord (make-vector 11 #f)) (rmt:testmeta-add-record test-name))) (for-each (lambda (key) (let* ((idx (cadr key)) (fld (car key)) @@ -1471,11 +1473,11 @@ ;; (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) (rmt:testmeta-update-field test-name fld val))))) - '(("author" 2)("owner" 3)("description" 4)("reviewed" 5)("tags" 9))))) + '(("author" 2)("owner" 3)("description" 4)("reviewed" 5)("tags" 9)("jobgroup" 10))))) ;; Update test_meta for all tests (define (runs:update-all-test_meta db) (let ((test-names (tests:get-all))) ;; (tests:get-valid-tests))) (for-each Index: sdb.scm ================================================================== --- sdb.scm +++ sdb.scm @@ -20,27 +20,20 @@ (import (prefix base64 base64:)) (declare (unit sdb)) ;; -(define (sdb:open) ;; (conc *toppath* "/megatest.db") (car *configinfo*))) - (if (not *toppath*) - (if (not (setup-for-run)) - (begin - (debug:print 0 "ERROR: Attempted to open db when not in megatest area. Exiting.") - (exit)))) - (let* ((dbpath (conc *toppath* "/db/sdb.db")) ;; fname) - (dbexists (let ((fe (file-exists? dbpath))) +(define (sdb:open fname) + (let* ((dbpath (pathname-directory fname)) + (dbexists (let ((fe (file-exists? fname))) (if fe fe (begin - (create-directory (conc *toppath* "/db") #t) + (create-directory dbpath #t) #f)))) - (sdb (sqlite3:open-database dbpath)) - (handler (make-busy-timeout (if (args:get-arg "-override-timeout") - (string->number (args:get-arg "-override-timeout")) - 136000)))) + (sdb (sqlite3:open-database fname)) + (handler (make-busy-timeout 136000))) (sqlite3:set-busy-handler! sdb handler) (if (not dbexists) (sdb:initialize sdb)) (sqlite3:execute sdb "PRAGMA synchronous = 1;") sdb)) @@ -48,11 +41,11 @@ (define (sdb:initialize sdb) (sqlite3:execute sdb "CREATE TABLE IF NOT EXISTS strs (id INTEGER PRIMARY KEY, str TEXT, CONSTRAINT str UNIQUE (str));") - (sqlite3:execute sdb "CREATE INDEX strindx ON strs (str);")) + (sqlite3:execute sdb "CREATE INDEX IF NOT EXISTS strindx ON strs (str);")) ;; (define sumup (let ((a 0))(lambda (x)(set! a (+ x a)) a))) (define (sdb:register-string sdb str) (sqlite3:execute sdb "INSERT OR IGNORE INTO strs (str) VALUES (?);" str)) @@ -77,26 +70,38 @@ (hash-table-set! id-cache id str)) sdb "SELECT str FROM strs WHERE id=?;" id)) str)) -(define sdb:qry +;; Numbers get passed though in both directions +;; +(define (make-sdb:qry fname) (let ((sdb #f) (scache (make-hash-table)) (icache (make-hash-table))) (lambda (cmd var) - (if (not sdb)(set! sdb (sdb:open))) (case cmd - ((init) (if (not sdb)(set! sdb (sdb:open)))) - ((finalize!) (if sdb (sqlite3:finalize! sdb))) - ((getid) (let ((id (sdb:string->id sdb scache var))) + ((setup) (set! sdb (if (not sdb) + (sdb:open (if var var fname))))) + ((setdb) (set! sdb var)) + ((getdb) sdb) + ((finalize) (if sdb + (begin + (sqlite3:finalize! sdb) + (set! sdb #f)))) + ((getid) (let ((id (if (or (number? var) + (string->number var)) + var + (sdb:string->id sdb scache var)))) (if id id (begin (sdb:register-string sdb var) (sdb:string->id sdb scache var))))) ((getstr) (if (or (number? var) (string->number var)) (sdb:id->string sdb icache var) var)) + ((passid) var) + ((passstr) var) (else #f))))) Index: server.scm ================================================================== --- server.scm +++ server.scm @@ -51,13 +51,13 @@ (debug:print 0 "ERROR: cannot find megatest.config, exiting") (exit)))) (debug:print-info 2 "Starting server using " transport " transport") (set! *transport-type* transport) (case transport - ((fs) (exit)) ;; there is no "fs" server transport - ((http) (http-transport:launch)) - ((zmq) (zmq-transport:launch)) + ;; ((fs) (exit)) ;; there is no "fs" server transport + ((fs http) (http-transport:launch)) + ((zmq) (zmq-transport:launch)) (else (debug:print "WARNING: unrecognised transport " transport) (exit)))) ;;====================================================================== Index: tdb.scm ================================================================== --- tdb.scm +++ tdb.scm @@ -97,22 +97,22 @@ (rmt:test-get-rundir-from-test-id test-id)))) (debug:print 3 "TEST PATH: " test-path) (open-test-db test-path))) ;; find and open the testdat.db file for an existing test -(define (tdb:open-test-db-by-test-id-local test-id #!key (work-area #f)) +(define (tdb:open-test-db-by-test-id-local dbstruct run-id test-id #!key (work-area #f)) (let* ((test-path (if work-area work-area - (open-run-close db:test-get-rundir-from-test-id #f test-id)))) + (db:test-get-rundir-from-test-id dbstruct run-id test-id)))) (debug:print 3 "TEST PATH: " test-path) (open-test-db test-path))) ;; find and open the testdat.db file for an existing test -(define (tdb:open-run-close-db-by-test-id-local test-id work-area proc . params) +(define (tdb:open-run-close-db-by-test-id-local dbstruct run-id test-id work-area proc . params) (let* ((test-path (if work-area work-area - (open-run-close db:test-get-rundir-from-test-id #f test-id))) + (db:test-get-rundir-from-test-id dbstruct run-id test-id))) (tdb (open-test-db test-path))) (apply proc tdb params))) (define (tdb:testdb-initialize db) (debug:print 11 "db:testdb-initialize START") @@ -187,20 +187,20 @@ ;; (sqlite3:finalize! tdb) ;; (reverse res)) ;; '()))) ;; NOTE: Run this local with #f for db !!! -(define (tdb:load-test-data test-id) +(define (tdb:load-test-data run-id test-id) (let loop ((lin (read-line))) (if (not (eof-object? lin)) (begin (debug:print 4 lin) - (rmt:csv->test-data test-id lin) + (rmt:csv->test-data run-id test-id lin) (loop (read-line))))) ;; roll up the current results. ;; FIXME: Add the status too - (rmt:test-data-rollup test-id #f)) + (rmt:test-data-rollup run-id test-id #f)) (define (tdb:get-prev-tol-for-test tdb test-id category variable) ;; Finish me? (values #f #f #f)) @@ -357,14 +357,14 @@ (conc (vector-ref b 2))) #f)) (stringtest-data #f test-id + ;; This was run remote, don't think that makes sense. Perhaps not, but that is the easiest path for the moment. + (rmt:csv->test-data run-id test-id dat)))) ;; need to update the top test record if PASS or FAIL and this is a subtest (if (not (equal? item-path "")) (rmt:roll-up-pass-fail-counts run-id test-name item-path status)) @@ -287,14 +289,14 @@ (if (or (and (string? comment) (string-match (regexp "\\S+") comment)) waived) (let ((cmt (if waived waived comment))) - (rmt:general-call 'set-test-comment cmt test-id))))) + (rmt:general-call 'set-test-comment run-id cmt test-id))))) (define (tests:test-set-toplog! run-id test-name logf) - (rmt:general-call 'tests:test-set-toplog logf run-id test-name)) + (rmt:general-call 'tests:test-set-toplog run-id logf run-id test-name)) (define (tests:summarize-items run-id test-id test-name force) ;; if not force then only update the record if one of these is true: ;; 1. logf is "log/final.log ;; 2. logf is same as outputfilename @@ -308,11 +310,11 @@ (directory? path)) ;; can get #f here under some wierd conditions. why, unknown ... (begin (debug:print 4 "Found path: " path) (change-directory path)) ;; (set! outputfilename (conc path "/" outputfilename))) - (print "No such path: " path)) + (debug:print 0 "ERROR: summarize-items for run-id=" run-id ", test-name=" test-name ", no such path: " path)) (debug:print 4 "summarize-items with logf " logf ", outputfilename " outputfilename " and force " force) (if (or (equal? logf "logs/final.log") (equal? logf outputfilename) force) (begin @@ -383,10 +385,33 @@ (change-directory orig-dir) ;; NB// tests:test-set-toplog! is remote internal... (tests:test-set-toplog! run-id test-name outputfilename) ))))))) +;; MUST BE CALLED local! +;; +(define (tests:test-get-paths-matching keynames target fnamepatt #!key (res '())) + ;; BUG: Move the values derived from args to parameters and push to megatest.scm + (let* ((testpatt (if (args:get-arg "-testpatt")(args:get-arg "-testpatt") "%")) + (statepatt (if (args:get-arg ":state") (args:get-arg ":state") "%")) + (statuspatt (if (args:get-arg ":status") (args:get-arg ":status") "%")) + (runname (if (args:get-arg ":runname") (args:get-arg ":runname") "%")) + (paths-from-db (rmt:test-get-paths-matching-keynames-target-new keynames target res + testpatt + statepatt + statuspatt + runname))) + (if fnamepatt + (apply append + (map (lambda (p) + (if (directory-exists? p) + (glob (conc p "/" fnamepatt)) + '())) + paths-from-db)) + paths-from-db))) + + ;;====================================================================== ;; Gather data from test/task specifications ;;====================================================================== ;; (define (tests:get-valid-tests testsdir test-patts) ;; #!key (test-names '())) @@ -464,11 +489,11 @@ (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) (test-id (rmt:get-test-id run-id test-name item-path)) - (tdat (rmt:get-testinfo-state-status test-id))) ;; (cdb:get-test-info-by-id *runremote* test-id))) + (tdat (rmt:get-testinfo-state-status run-id test-id))) ;; (cdb:get-test-info-by-id *runremote* test-id))) (if tdat (begin ;; Look at the test state and status (if (or (and (member (db:test-get-status tdat) '("PASS" "WARN" "WAIVED" "CHECK" "SKIP")) @@ -481,11 +506,11 @@ ;; from the runnable list (if keep-test (for-each (lambda (waiton) ;; for now we are waiting only on the parent test (let* ((parent-test-id (rmt:get-test-id run-id waiton "")) - (wtdat (rmt:get-testinfo-state-status test-id))) ;; (cdb:get-test-info-by-id *runremote* test-id))) + (wtdat (rmt:get-testinfo-state-status run-id test-id))) ;; (cdb:get-test-info-by-id *runremote* test-id))) (if (or (and (equal? (db:test-get-state wtdat) "COMPLETED") (member (db:test-get-status wtdat) '("FAIL"))) (member (db:test-get-status wtdat) '("KILLED")) (member (db:test-get-state wtdat) '("INCOMPETE"))) ;; (if (or (member (db:test-get-status wtdat) @@ -587,12 +612,12 @@ ;; test steps ;;====================================================================== ;; teststep-set-status! used to be here -(define (test-get-kill-request test-id) ;; run-id test-name itemdat) - (let* ((testdat (rmt:get-test-info-by-id test-id))) +(define (test-get-kill-request run-id test-id) ;; run-id test-name itemdat) + (let* ((testdat (rmt:get-test-info-by-id run-id test-id))) (and testdat (equal? (test:get-state testdat) "KILLREQ")))) (define (test:tdb-get-rundat-count tdb) (if tdb @@ -603,30 +628,31 @@ tdb "SELECT count(id) FROM test_rundat;") res)) 0) -(define (tests:update-central-meta-info test-id cpuload diskfree minutes uname hostname) - (rmt:general-call 'update-cpuload-diskfree cpuload diskfree test-id) +(define (tests:update-central-meta-info run-id test-id cpuload diskfree minutes uname hostname) + (rmt:general-call 'update-cpuload-diskfree run-id cpuload diskfree test-id) (if minutes - (rmt:general-call 'update-run-duration minutes test-id)) + (rmt:general-call 'update-run-duration run-id minutes test-id)) (if (and uname hostname) - (rmt:general-call 'update-uname-host uname hostname test-id))) + (rmt:general-call 'update-uname-host run-id uname hostname test-id))) +;; This one is for running with no db access (i.e. via rmt: internally) (define (tests:set-full-meta-info test-id run-id minutes work-area) (let* ((num-records 0) (cpuload (get-cpu-load)) (diskfree (get-df (current-directory))) (uname (get-uname "-srvpio")) (hostname (get-host-name))) - (tdb:update-testdat-meta-info test-id work-area cpuload diskfree minutes) - (tests:update-central-meta-info test-id cpuload diskfree minutes uname hostname))) + (tdb:remote-update-testdat-meta-info run-id test-id work-area cpuload diskfree minutes) + (tests:update-central-meta-info run-id test-id cpuload diskfree minutes uname hostname))) (define (tests:set-partial-meta-info test-id run-id minutes work-area) (let* ((cpuload (get-cpu-load)) (diskfree (get-df (current-directory)))) - (tdb:update-testdat-meta-info test-id work-area cpuload diskfree minutes))) + (tdb:remote-update-testdat-meta-info run-id test-id work-area cpuload diskfree minutes))) ;;====================================================================== ;; A R C H I V I N G ;;====================================================================== Index: tests/Makefile ================================================================== --- tests/Makefile +++ tests/Makefile @@ -168,11 +168,11 @@ clean : rm cleanprep kill : killall -v mtest main.sh dboard || true - rm -rf */megatest.db */logging.db */monitor.db fullrun/tmp/mt_*/* || true + rm -rf *run/db/* */megatest.db */logging.db */monitor.db fullrun/tmp/mt_*/* || true killall -v mtest dboard || true hardkill : kill sleep 2;killall -v mtest main.sh dboard -9 Index: tests/fullrun/config/mt_include_1.config ================================================================== --- tests/fullrun/config/mt_include_1.config +++ tests/fullrun/config/mt_include_1.config @@ -8,12 +8,12 @@ useshell yes # ## launcher launches jobs, the job is managed on the target host ## by megatest, comment out launcher to run local # workhosts localhost hermes # launcher exec nbfake - -launcher nbfake +# launcher nbfake +launcher loadrunner # launcher echo # launcher nbfind # launcher nodanggood Index: tests/fullrun/megatest.config ================================================================== --- tests/fullrun/megatest.config +++ tests/fullrun/megatest.config @@ -121,5 +121,9 @@ [disks] disk0 /foobarbazz [include config/mt_include_2.config] [include #{getenv USER}_testing.config] + +[jobgroups] +sqlite3 3 +blockz 5 Index: tests/fullrun/tests/blocktestxz/testconfig ================================================================== --- tests/fullrun/tests/blocktestxz/testconfig +++ tests/fullrun/tests/blocktestxz/testconfig @@ -16,5 +16,7 @@ that a test will never be run and thus remove it from\ the queue of tests to be run. tags first,single reviewed 1/1/1965 + +jobgroup blockz Index: tests/fullrun/tests/priority_1/testconfig ================================================================== --- tests/fullrun/tests/priority_1/testconfig +++ tests/fullrun/tests/priority_1/testconfig @@ -3,10 +3,11 @@ [requirements] priority 1 [test_meta] +jobgroup sqlite3 author matt owner bob description This test checks that a multi-lineitem test with mix of pass and non-fail rolls up a PASS tags first,single Index: tests/fullrun/tests/priority_2/testconfig ================================================================== --- tests/fullrun/tests/priority_2/testconfig +++ tests/fullrun/tests/priority_2/testconfig @@ -5,10 +5,11 @@ priority 2 # runtimelim 1d 1h 1m 10s runtimelim 20s [test_meta] +jobgroup sqlite3 author matt owner bob description This test checks that a multi-lineitem test with mix of pass and non-fail rolls up a PASS tags first,single Index: tests/fullrun/tests/priority_3/testconfig ================================================================== --- tests/fullrun/tests/priority_3/testconfig +++ tests/fullrun/tests/priority_3/testconfig @@ -4,10 +4,11 @@ [requirements] priority 3 [test_meta] +jobgroup sqlite3 author matt owner bob description This test checks that a multi-lineitem test with mix of pass and non-fail rolls up a PASS tags first,single Index: tests/fullrun/tests/priority_4/testconfig ================================================================== --- tests/fullrun/tests/priority_4/testconfig +++ tests/fullrun/tests/priority_4/testconfig @@ -3,10 +3,11 @@ [requirements] priority 4 [test_meta] +jobgroup sqlite3 author matt owner bob description This test checks that a multi-lineitem test with mix of pass and non-fail rolls up a PASS tags first,single Index: tests/fullrun/tests/sqlitespeed/testconfig ================================================================== --- tests/fullrun/tests/sqlitespeed/testconfig +++ tests/fullrun/tests/sqlitespeed/testconfig @@ -7,5 +7,7 @@ [items] MANYITEMS [system (env > envfile.txt;echo aa ab ac ad ae af ag ah ai)] # BORKED +[test_meta] +jobgroup sqlite3 Index: tests/fullrun/tests/test_mt_vars/currentisblah.sh ================================================================== --- tests/fullrun/tests/test_mt_vars/currentisblah.sh +++ tests/fullrun/tests/test_mt_vars/currentisblah.sh @@ -1,3 +1,3 @@ #!/usr/bin/env bash -grep CURRENT megatest.sh | grep /tmp/nada +grep -e '^export CURRENT' megatest.sh | grep /tmp/nada Index: tests/rununittest.sh ================================================================== --- tests/rununittest.sh +++ tests/rununittest.sh @@ -1,14 +1,17 @@ #!/bin/bash # Usage: rununittest.sh testname debuglevel # +# Ensure all is made +(cd ..;make && make install) + # Clean setup # rm -f simplerun/megatest.db simplerun/monitor.db simplerun/db/monitor.db -rm -rf simplelinks/ simpleruns/ +rm -rf simplelinks/ simpleruns/ simplerun/db/ mkdir -p simplelinks simpleruns (cd simplerun;cp ../../*_records.scm .;perl -pi.bak -e 's/define-inline/define/' *_records.scm) # Run the test $1 is the unit test to run cd simplerun;echo '(load "../tests.scm")' | ../../bin/megatest -repl -debug $2 $1 ADDED tests/unittests/basicserver.scm Index: tests/unittests/basicserver.scm ================================================================== --- /dev/null +++ tests/unittests/basicserver.scm @@ -0,0 +1,114 @@ +;;====================================================================== +;; S E R V E R +;;====================================================================== + +;; Run like this: +;; +;; (cd ..;make && make install) && ./rununittest.sh server 1;(cd simplerun;megatest -stop-server 0) + +(set! *transport-type* 'http) + +(test "setup for run" #t (begin (setup-for-run) + (string? (getenv "MT_RUN_AREA_HOME")))) + +(test "server-register, get-best-server" #t (let ((res #f)) + (open-run-close tasks:server-register tasks:open-db 1 "bob" 1234 100 'live 'http) + (set! res (open-run-close tasks:get-best-server tasks:open-db)) + (number? (vector-ref res 3)))) + +(test "de-register server" #f (let ((res #f)) + (open-run-close tasks:server-deregister tasks:open-db "bob" port: 1234) + (vector? (open-run-close tasks:get-best-server tasks:open-db)))) + +(define server-pid #f) + +;; Not sure how the following should work, replacing it with system of megatest -server +;; (test "launch server" #t (let ((pid (process-fork (lambda () +;; ;; (daemon:ize) +;; (server:launch 'http))))) +;; (set! server-pid pid) +;; (number? pid))) +(system "../../bin/megatest -server - -debug 22 > server.log 2> server.log &") + +(let loop ((n 10)) + (thread-sleep! 1) ;; need to wait for server to start. + (let ((res (open-run-close tasks:get-best-server tasks:open-db))) + (print "tasks:get-best-server returned " res) + (if (and (not res) + (> n 0)) + (loop (- n 1))))) + +(test "get-best-server" #t (begin + (client:launch) + (let ((dat (open-run-close tasks:get-best-server tasks:open-db))) + (vector? dat)))) + +(define *keys* (keys:config-get-fields *configdat*)) +(define *keyvals* (keys:target->keyval *keys* "a/b/c")) + +(test #f #t (string? (car *runremote*))) +(test #f '(#t "successful login") (rmt:login)) ;; *runremote* *toppath* *my-client-signature*))) + +(test #f #f (rmt:get-test-info-by-id 99)) ;; get non-existant test + +;; RUNS +(test #f 1 (rmt:register-run *keyvals* "firstrun" "new" "n/a" (current-user-name))) +(test "get run info" "firstrun" (let ((rinfo (rmt:get-run-info 1))) + (vector-ref (vector-ref rinfo 1) 3))) +(test "get runname from id" "firstrun" (rmt:get-run-name-from-id 1)) + +;; TESTS +(test "get tests (no data)" '() (rmt:get-tests-for-run 1 "%" '() '() #f #f #f #f #f #f)) +(test "register test" #t (rmt:general-call 'register-test 1 "test1" "")) +(test "get tests (some data)" 1 (length (rmt:get-tests-for-run 1 "%" '() '() #f #f #f #f #f #f))) +(test "get test id" 1 (rmt:get-test-id 1 "test1" "")) +(test "sync back" #t (> (rmt:sync-inmem->db) 0)) +(test "get test id from main" 1 (db:get-test-id *db* 1 "test1" "")) +(test "get keys" #t (list? (rmt:get-keys))) +(test "set comment" #t (begin (rmt:general-call 'set-test-comment "this is a comment" 1) #t)) +(test "get comment" "this is a comment" (let ((trec (rmt:get-test-info-by-id 1))) + (db:test-get-comment trec))) + +;; MORE RUNS +(test "get runs" #t (let* ((runs (rmt:get-runs "%" #f #f '())) + (header (vector-ref runs 0)) + (data (vector-ref runs 1))) + (and (list? header) + (list? data) + (vector? (car data))))) + +(test "get local testinfo" "test1" (vector-ref (db:get-testinfo-state-status *db* 1) 2)) +(test "get testinfo" "test1" (vector-ref (rmt:get-testinfo-state-status 1) 2)) + +;;====================================================================== +;; D B +;;====================================================================== + +(test "pass fail counts" #t (rmt:general-call 'pass-fail-counts 10 9 1)) +(test "get pass fail counts" 19 (let ((dat (rmt:get-test-info-by-id 1))) + (+ (db:test-get-pass_count dat) + (db:test-get-fail_count dat)))) + +(define testregistry (make-hash-table)) +(for-each + (lambda (tname) + (for-each + (lambda (itempath) + (let ((tkey (conc tname "/" itempath)) + (rpass (random 10)) + (rfail (random 10))) + (hash-table-set! testregistry tkey (list tname itempath)) + (rmt:general-call 'register-test 1 tname itempath) + (let* ((tid (rmt:get-test-id 1 tname itempath)) + (tdat (rmt:get-test-info-by-id tid))) + (rmt:general-call 'pass-fail-counts rpass rfail (db:test-get-id tdat)) + (let* ((resdat (rmt:get-test-info-by-id tid))) + (test "set/get pass fail counts" (list rpass rfail) + (list (db:test-get-pass_count resdat) + (db:test-get-fail_count resdat))))))) + (list "" "a" "b" "c" "d" "e" "f" "g" "h" "i" "j"))) + (list "test1" "test2" "test3" "test4" "test5")) + + +(test #f '(#t "exit process started") (rmt:kill-server)) ;; *toppath* *my-client-signature* #f))) + ADDED tests/unittests/dbrdbstruct.scm Index: tests/unittests/dbrdbstruct.scm ================================================================== --- /dev/null +++ tests/unittests/dbrdbstruct.scm @@ -0,0 +1,33 @@ +;;====================================================================== +;; S E R V E R +;;====================================================================== + +;; Run like this: +;; +;; (cd ..;make && make install) && ./rununittest.sh server 1;(cd simplerun;megatest -stop-server 0) + +(test #f #t (vector? (make-dbr:dbstruct "/tmp"))) + +(define dbstruct (make-dbr:dbstruct "/tmp")) + +(test #f #t (begin (dbr:dbstruct-set-main! dbstruct "blah") #t)) +(test #f "blah" (dbr:dbstruct-get-main dbstruct)) +(for-each + (lambda (run-id) + (test #f #t (vector? (dbr:dbstruct-get-rundb-rec dbstruct run-id)))) + (list 1 2 3 4 5 6 7 8 9 #f)) + +(test #f 0 (dbr:dbstruct-field-name->num 'rundb)) +(test #f 1 (dbr:dbstruct-field-name->num 'inmem)) +(test #f 2 (dbr:dbstruct-field-name->num 'mtime)) + +(test #f #f (dbr:dbstruct-get-runvec-val dbstruct 1 'rundb)) +(test #f #t (begin (dbr:dbstruct-set-runvec-val! dbstruct 1 'rundb "rundb") #t)) +(test #f "rundb" (dbr:dbstruct-get-runvec-val dbstruct 1 'rundb)) + +(for-each + (lambda (k) + (test #f #t (begin (dbr:dbstruct-set-runvec-val! dbstruct 1 k (conc k)) #t)) + (test #f (conc k) (dbr:dbstruct-get-runvec-val dbstruct 1 k))) + '(rundb inmem mtime rtime stime inuse)) + Index: tests/unittests/inmemdb.scm ================================================================== --- tests/unittests/inmemdb.scm +++ tests/unittests/inmemdb.scm @@ -23,11 +23,11 @@ (define *keyvals* (keys:target->keyval *keys* "a/b/c")) (test #f #t (string? (car *runremote*))) (test #f '(#t "successful login") (rmt:login)) ;; *runremote* *toppath* *my-client-signature*))) -(define inmem (open-in-mem-db)) +(define inmem (db:open-inmem-db)) (define (inmem-test t b) (test "inmem sync to" t (db:sync-to *db* inmem)) (test "inmem sync back" b (db:sync-to inmem *db*))) Index: tests/unittests/server.scm ================================================================== --- tests/unittests/server.scm +++ tests/unittests/server.scm @@ -47,28 +47,30 @@ (define *keyvals* (keys:target->keyval *keys* "a/b/c")) (test #f #t (string? (car *runremote*))) (test #f '(#t "successful login") (rmt:login)) ;; *runremote* *toppath* *my-client-signature*))) -(test #f #f (rmt:get-test-info-by-id 99)) ;; get non-existant test +(test #f #f (rmt:get-test-info-by-id 1 99)) ;; get non-existant test ;; RUNS (test #f 1 (rmt:register-run *keyvals* "firstrun" "new" "n/a" (current-user-name))) (test "get run info" "firstrun" (let ((rinfo (rmt:get-run-info 1))) (vector-ref (vector-ref rinfo 1) 3))) (test "get runname from id" "firstrun" (rmt:get-run-name-from-id 1)) ;; TESTS (test "get tests (no data)" '() (rmt:get-tests-for-run 1 "%" '() '() #f #f #f #f #f #f)) -(test "register test" #t (rmt:general-call 'register-test 1 "test1" "")) +(test "register test" #t (rmt:general-call 'register-test 1 1 "test1" "")) (test "get tests (some data)" 1 (length (rmt:get-tests-for-run 1 "%" '() '() #f #f #f #f #f #f))) (test "get test id" 1 (rmt:get-test-id 1 "test1" "")) + (test "sync back" #t (> (rmt:sync-inmem->db) 0)) (test "get test id from main" 1 (db:get-test-id *db* 1 "test1" "")) + (test "get keys" #t (list? (rmt:get-keys))) -(test "set comment" #t (begin (rmt:general-call 'set-test-comment "this is a comment" 1) #t)) -(test "get comment" "this is a comment" (let ((trec (rmt:get-test-info-by-id 1))) +(test "set comment" #t (begin (rmt:general-call 'set-test-comment 1 "this is a comment" 1) #t)) +(test "get comment" "this is a comment" (let ((trec (rmt:get-test-info-by-id 1 1))) (db:test-get-comment trec))) ;; MORE RUNS (test "get runs" #t (let* ((runs (rmt:get-runs "%" #f #f '())) (header (vector-ref runs 0)) @@ -75,12 +77,12 @@ (data (vector-ref runs 1))) (and (list? header) (list? data) (vector? (car data))))) -(test "get local testinfo" "test1" (vector-ref (db:get-testinfo-state-status *db* 1) 2)) -(test "get testinfo" "test1" (vector-ref (rmt:get-testinfo-state-status 1) 2)) +(test "get local testinfo" "test1" (vector-ref (db:get-testinfo-state-status *db* 1 1) 2)) +(test "get testinfo" "test1" (vector-ref (rmt:get-testinfo-state-status 1 1) 2)) ;;====================================================================== ;; D B ;;====================================================================== Index: utils/installall.sh ================================================================== --- utils/installall.sh +++ utils/installall.sh @@ -302,10 +302,16 @@ # disabled zmq # # CSC_OPTIONS="-I$PREFIX/include -L$CSCLIBS" $CHICKEN_INSTALL $PROX -deploy -prefix $DEPLOYTARG zmq # disabled zmq # fi # disabled zmq # fi # if zmq is in /usr/lib # disabled zmq # cd $BUILDHOME + +git clone https://bitbucket.org/DerGuteMoritz/zmq/commits/branch/3.2 zmq-3.2 +cd zmq-3.2 +chicken-install + +cd $BUILDHOME ## WEBKIT=WebKit-r131972 ## if ! [[ -e ${WEBKIT}.tar.bz2 ]] ; then ## # http://builds.nightly.webkit.org/files/trunk/src/WebKit-r131972.tar.bz2 ## wget http://builds.nightly.webkit.org/files/trunk/src/${WEBKIT}.tar.bz2 ADDED utils/loadrunner Index: utils/loadrunner ================================================================== --- /dev/null +++ utils/loadrunner @@ -0,0 +1,29 @@ +#!/bin/bash + +# load=`uptime|awk '{print $10}'|cut -d, -f1` +load=`uptime|perl -pe 's/.*: (\d+.\d+),.*/$1/'` +if which cpucheck > /dev/null;then + numcpu=`cpucheck|tail -1|awk '{print $6}'` +elif which lscpu > /dev/null;then + numcpu=`lscpu|grep "CPU.s.:"|awk '{print $2}'` +else + numcpu=2 +fi + +# NB// max_load is in units of percent. +# +lperc=`echo "100 * $load / $numcpu"|bc` +if [[ "x$MAX_ALLOWED_LOAD" == "x" ]]; then + max_load=100 +else + max_load=$MAX_ALLOWED_LOAD +fi + +if [[ $lperc -lt $max_load ]];then + echo "Load acceptable: lperc=$lperc %, max_load=$max_load %, load=$load, numcpu=$numcpu, MAX_ALLOWED_LOAD=$MAX_ALLOWED_LOAD %" + echo "Starting command: \"$@\"" + nbfake "$@" +else + # echo "Load too high: lperc=$lperc, max_load=$max_load, waiting two minutes before trying to run command: \"$@\"" + echo "nbload $@" | at now + 2 minutes 2> /dev/null +fi Index: utils/mtgetfile ================================================================== --- utils/mtgetfile +++ utils/mtgetfile @@ -18,11 +18,11 @@ ((not key-vals) "missing -target") ((not target) "missing -target") ((not scriptn) "missing file name to find") (else #f)))) (if errmsg - (begin + (begin (print "THEPATH: Missing required switch: " errmsg) (print "THEPATH: Usage: mtgetfile -target target scriptname [searchpath]") (exit))) (print "THEPATH: key-vals=" key-vals " path=" path " scriptn=" scriptn)) EOF DELETED utils/nbload Index: utils/nbload ================================================================== --- utils/nbload +++ /dev/null @@ -1,24 +0,0 @@ -#!/bin/bash - -# load=`uptime|awk '{print $10}'|cut -d, -f1` -load=`uptime|perl -pe 's/.*: (\d+.\d+),.*/$1/'` -if which cpucheck > /dev/null;then - numcpu=`cpucheck|tail -1|awk '{print $6}'` -else - numcpu=`lscpu|grep "CPU.s.:"|awk '{print $2}'` -fi - -lperc=`echo "100 * $load / $numcpu"|bc` -if [[ "x$MAX_ALLOWED_LOAD" == "x" ]]; then - max_load=50 -else - max_load=$MAX_ALLOWED_LOAD -fi -if [[ $lperc -lt $max_load ]];then - echo "$@" | at now + 0 minutes -elif [[ "x$NBLAUNCHER" == "x" ]];then - echo "nbfind $@" | at now + 2 minutes -else - $NBLAUNCHER "$@" -fi - Index: zmq-transport.scm ================================================================== --- zmq-transport.scm +++ zmq-transport.scm @@ -1,14 +1,15 @@ - +;;====================================================================== ;; 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. ;; ;; This program is distributed WITHOUT ANY WARRANTY; without even the ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. +;;====================================================================== (require-extension (srfi 18) extras tcp s11n) (use sqlite3 srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest) (import (prefix sqlite3 sqlite3:))