Index: .fossil-settings/ignore-glob ================================================================== --- .fossil-settings/ignore-glob +++ .fossil-settings/ignore-glob @@ -1,5 +1,6 @@ +altdb.scm utils/build/* *~ *.o bin/* megatest.db Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -8,11 +8,11 @@ process.scm runs.scm tasks.scm tests.scm genexample.scm \ http-transport.scm nmsg-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 \ rmt.scm api.scm tdb.scm \ - portlogger.scm archive.scm + portlogger.scm archive.scm env.scm # Eggs to install (straightforward ones) EGGS=matchable readline apropos base64 regex-literals format regex-case test coops trace csv \ dot-locking posix-utils posix-extras directory-utils hostinfo tcp-server rpc csv-xml fmt \ json md5 awful http-client spiffy uri-common intarweb spiffy-request-vars \ @@ -60,11 +60,12 @@ tests.o runs.o dashboard.o dashboard-tests.o dashboard-main.o : run_records.scm db.o ezsteps.o keys.o launch.o megatest.o monitor.o runs-for-ref.o runs.o tests.o : key_records.scm tests.o tasks.o dashboard-tasks.o : task_records.scm runs.o : test_records.scm megatest.o : megatest-fossil-hash.scm -client.scm common.scm configf.scm dashboard-guimonitor.scm dashboard-tests.scm dashboard.scm db.scm dcommon.scm ezsteps.scm fs-transport.scm http-transport.scm index-tree.scm items.scm keys.scm launch.scm megatest.scm monitor.scm mt.scm newdashboard.scm runconfig.scm runs.scm server.scm tdb.scm tests.scm tree.scm zmq-transport.scm : common_records.scm +client.scm common.scm configf.scm dashboard-guimonitor.scm dashboard-tests.scm dashboard.scm db.scm dcommon.scm ezsteps.scm fs-transport.scm http-transport.scm index-tree.scm items.scm keys.scm launch.scm megatest.scm monitor.scm mt.scm newdashboard.scm runconfig.scm runs.scm server.scm tdb.scm tests.scm tree.scm : common_records.scm rpc-transport.scm +common_records.scm : altdb.scm # Temporary while transitioning to new routine # runs.o : run-tests-queue-classic.scm run-tests-queue-new.scm megatest-fossil-hash.scm : $(SRCFILES) megatest.scm *_records.scm @@ -164,20 +165,20 @@ $(MTQA_FOSSIL) : fossil clone https://www.kiatoa.com/fossils/megatest_qa $(MTQA_FOSSIL) clean : - rm -f $(OFILES) $(GOFILES) megatest dboard dboard.o megatest.o dashboard.o + rm -f $(OFILES) $(GOFILES) megatest dboard dboard.o megatest.o dashboard.o megatest-fossil-hash.* altdb.scm # Deploy section (not complete yet) # $(DEPLOYHELPERS) : utils/mt_* $(INSTALL) $< $@ chmod a+X $@ deploytarg/apropos.so : Makefile - chicken-install -p deploytarg -deploy $(EGGS) + chicken-install -p deploytarg -deploy -keep-installed $(EGGS) # 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 # deploytarg/libsqlite3.so : @@ -203,18 +204,50 @@ # DATASHAREO=configf.o common.o process.o tree.o dcommon.o margs.o launch.o gutils.o db.o synchash.o server.o \ # megatest-version.o tdb.o ods.o mt.o keys.o datashare-testing/sd : datashare.scm $(OFILES) csc datashare.scm $(OFILES) -o datashare-testing/sd +datashare-testing/sdat: sharedat.scm $(OFILES) + csc sharedat.scm $(OFILES) -o datashare-testing/sdat + sd : datashare-testing/sd mkdir -p /tmp/$(USER)/datashare/disk1 /tmp/$(USER)/basepath xterm : sd (export BASEPATH=/tmp/$(USER)/basepath ; export PATH="$(PWD)/datashare-testing:$(PATH)" ; xterm &) + +datashare-testing/spublish : spublish.scm $(OFILES) + csc spublish.scm $(OFILES) -o datashare-testing/spublish + +datashare-testing/sretrieve : sretrieve.scm megatest-version.o margs.o configf.o process.o + csc sretrieve.scm megatest-version.o margs.o configf.o process.o -o datashare-testing/sretrieve + +sretrieve/sretrieve : datashare-testing/sretrieve + csc -deploy -deployed sretrieve.scm megatest-version.o margs.o configf.o + chicken-install -keep-installed $(PROXY) -deploy -prefix sretrieve defstruct srfi-18 format sql-de-lite \ + srfi-1 posix regex regex-case srfi-69 + +# base64 dot-locking \ +# csv-xml z3 # "(define (toplevel-command . a) #f)" +# if egrep 'version.*3.0' $(shell dirname $(shell dirname $(shell which csi)))/lib/chicken/7/readline.setup-info;then \ + readline-fix.scm : - if egrep 'version.*3.0' $(shell dirname $(shell dirname $(shell which csi)))/lib/chicken/7/readline.setup-info;then \ - echo "(use-legacy-bindings)" > readline-fix.scm; \ + if [[ $(shell chicken-status | grep readline | awk '{print $4}' | cut -d. -f1) -gt 3 ]];then \ + echo "(define *use-new-readline* #f)" > readline-fix.scm; \ else \ - echo "" > readline-fix.scm;\ + echo "(define *use-new-readline* #t)" > readline-fix.scm;\ + fi + +altdb.scm : + echo ";; optional alternate db setup" > altdb.scm + echo "(define *available-db* (make-hash-table))" >> altdb.scm + if csi -ne '(use mysql-client)';then \ + echo "(use mysql-client)(hash-table-set! *available-db* 'mysql #t)" >> altdb.scm; \ + fi + if csi -ne '(use postgresql)';then \ + echo "(use postgresql)(hash-table-set! *available-db* 'postgresql #t)" >> altdb.scm;\ fi + +portlogger-example : portlogger-example.scm api.o archive.o client.o common.o configf.o daemon.o dashboard-tests.o db.o dcommon.o ezsteps.o filedb.o genexample.o gutils.o http-transport.o items.o keys.o launch.o lock-queue.o margs.o megatest-version.o mt.o nmsg-transport.o ods.o portlogger.o process.o rmt.o rpc-transport.o runconfig.o runs.o sdb.o server.o synchash.o tasks.o tdb.o tests.o tree.o + csc portlogger-example.scm api.o archive.o client.o common.o configf.o daemon.o dashboard-tests.o db.o dcommon.o ezsteps.o filedb.o genexample.o gutils.o http-transport.o items.o keys.o launch.o lock-queue.o margs.o megatest-version.o mt.o nmsg-transport.o ods.o portlogger.o process.o rmt.o rpc-transport.o runconfig.o runs.o sdb.o server.o synchash.o tasks.o tdb.o tests.o tree.o Index: TODO ================================================================== --- TODO +++ TODO @@ -1,8 +1,12 @@ TODO ==== + +. Dashboard should resist running from non-homehost + + Migration to inmem db plus per run db ------------------------------------- . Re-work the dbstruct data structure? Index: api.scm ================================================================== --- api.scm +++ api.scm @@ -47,10 +47,11 @@ get-prev-run-ids get-run-ids-matching-target get-runs-by-patt get-steps-data get-steps-for-test + read-test-data login testmeta-get-record have-incompletes? synchash-get )) @@ -110,11 +111,11 @@ (define (api:execute-requests dbstruct dat) (handle-exceptions exn (let ((call-chain (get-call-chain))) (print-call-chain (current-error-port)) - (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 #f " message: " ((condition-property-accessor 'exn 'message) exn)) (vector #f (vector exn call-chain dat))) ;; return some stuff for debug if an exception happens (if (not (vector? dat)) ;; it is an error to not receive a vector (vector #f #f "remote must be called with a vector") (vector ;; return a vector + the returned data structure #t @@ -147,10 +148,12 @@ ((register-run) (apply db:register-run dbstruct params)) ((set-tests-state-status) (apply db:set-tests-state-status dbstruct params)) ((delete-run) (apply db:delete-run dbstruct params)) ((lock/unlock-run) (apply db:lock/unlock-run dbstruct params)) ((update-run-event_time) (apply db:update-run-event_time dbstruct params)) + ((update-run-stats) (apply db:update-run-stats dbstruct params)) + ((set-var) (apply db:set-var dbstruct params)) ;; STEPS ((teststep-set-status!) (apply db:teststep-set-status! dbstruct params)) ;; TEST DATA @@ -205,10 +208,11 @@ ((test-get-top-process-pid) (apply db:test-get-top-process-pid 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)) ((get-count-tests-running-for-run-id) (apply db:get-count-tests-running-for-run-id dbstruct params)) ((synchash-get) (apply synchash:server-get dbstruct params)) + ((get-raw-run-stats) (apply db:get-raw-run-stats dbstruct params)) ;; RUNS ((get-run-info) (apply db:get-run-info dbstruct params)) ((get-run-status) (apply db:get-run-status dbstruct params)) ((set-run-status) (apply db:set-run-status dbstruct params)) @@ -220,15 +224,20 @@ ((get-all-run-ids) (db:get-all-run-ids dbstruct)) ((get-prev-run-ids) (apply db:get-prev-run-ids dbstruct params)) ((get-run-ids-matching-target) (apply db:get-run-ids-matching-target dbstruct params)) ((get-runs-by-patt) (apply db:get-runs-by-patt dbstruct params)) ((get-run-name-from-id) (apply db:get-run-name-from-id dbstruct params)) + ((get-main-run-stats) (apply db:get-main-run-stats dbstruct params)) + ((get-var) (apply db:get-var dbstruct params)) ;; STEPS ((get-steps-data) (apply db:get-steps-data dbstruct params)) ((get-steps-for-test) (apply db:get-steps-for-test dbstruct params)) + ;; TEST DATA + ((read-test-data) (apply db:read-test-data dbstruct params)) + ;; MISC ((have-incompletes?) (apply db:have-incompletes? dbstruct params)) ((login) (apply db:login dbstruct params)) ((general-call) (let ((stmtname (car params)) (run-id (cadr params)) Index: archive.scm ================================================================== --- archive.scm +++ archive.scm @@ -115,15 +115,15 @@ (compress (or (configf:lookup *configdat* "archive" "compress") "9")) (linktree (configf:lookup *configdat* "setup" "linktree"))) (if (not archive-dir) ;; no archive disk found, this is fatal (begin - (debug:print 0 "FATAL: No archive disks found. Please add disks with at least " min-space " MB space to the [archive-disks] section of megatest.config") - (debug:print 0 " use [archive] minspace to specify minimum available space") - (debug:print 0 " disks: " (string-intersperse (map cadr (archive:get-archive-disks)) "\n ")) + (debug:print 0 #f "FATAL: No archive disks found. Please add disks with at least " min-space " MB space to the [archive-disks] section of megatest.config") + (debug:print 0 #f " use [archive] minspace to specify minimum available space") + (debug:print 0 #f " disks: " (string-intersperse (map cadr (archive:get-archive-disks)) "\n ")) (exit 1)) - (debug:print-info 0 "Using path " archive-dir " for archiving")) + (debug:print-info 0 #f "Using path " archive-dir " for archiving")) ;; from the test info bin the path to the test by stem ;; (for-each (lambda (test-dat) @@ -151,15 +151,15 @@ partial-path-index) #f))) (cond (toplevel/children - (debug:print 0 "WARNING: cannot archive " test-name " with id " test-id " as it is a toplevel test with children")) + (debug:print 0 #f "WARNING: cannot archive " test-name " with id " test-id " as it is a toplevel test with children")) ((not (file-exists? test-path)) - (debug:print 0 "WARNING: Cannot archive " test-name "/" item-path " as path " test-path " does not exist")) + (debug:print 0 #f "WARNING: Cannot archive " test-name "/" item-path " as path " test-path " does not exist")) (else - (debug:print 0 + (debug:print 0 #f "From test-dat=" test-dat " derived the following:\n" "test-partial-path = " test-partial-path "\n" "test-path = " test-path "\n" "test-physical-path = " test-physical-path "\n" "partial-path-index = " partial-path-index "\n" @@ -169,11 +169,11 @@ test-path)))) tests) ;; for each disk-group (for-each (lambda (disk-group) - (debug:print 0 "Processing disk-group " disk-group) + (debug:print 0 #f "Processing disk-group " disk-group) (let* ((test-paths (hash-table-ref disk-groups disk-group)) ;; ((string-intersperse (map cadr (rmt:get-key-val-pairs 1)) "-") (bup-init-params (list "-d" archive-dir "init")) (bup-index-params (append (list "-d" archive-dir "index") test-paths)) (bup-save-params (append (list "-d" archive-dir "save" ;; (conc "--strip-path=" linktree) @@ -185,19 +185,19 @@ (if (not (file-exists? archive-dir)) (create-directory archive-dir #t)) (if (not (file-exists? (conc archive-dir "/HEAD"))) (begin ;; replace this with jobrunner stuff enventually - (debug:print-info 0 "Init bup in " archive-dir) + (debug:print-info 0 #f "Init bup in " archive-dir) ;; (mutex-lock! bup-mutex) (run-n-wait bup-exe params: bup-init-params print-cmd: print-prefix) ;; (mutex-unlock! bup-mutex) )) - (debug:print-info 0 "Indexing data to be archived") + (debug:print-info 0 #f "Indexing data to be archived") ;; (mutex-lock! bup-mutex) (run-n-wait bup-exe params: bup-index-params print-cmd: print-prefix) - (debug:print-info 0 "Archiving data with bup") + (debug:print-info 0 #f "Archiving data with bup") (run-n-wait bup-exe params: bup-save-params print-cmd: print-prefix) ;; (mutex-unlock! bup-mutex) (for-each (lambda (test-dat) (let ((test-id (db:test-get-id test-dat)) @@ -254,11 +254,11 @@ prev-test-physical-path (file-exists? prev-test-physical-path)) ;; what to do? abort or clean up or link it in? (let* ((base (pathname-directory prev-test-physical-path)) (dirn (pathname-file prev-test-physical-path)) (newn (conc base "/." dirn))) - (debug:print 0 "ERROR: the old directory " prev-test-physical-path ", still exists! Moving it to " newn) + (debug:print 0 #f "ERROR: the old directory " prev-test-physical-path ", still exists! Moving it to " newn) (rename-file prev-test-physical-path newn))) (if (and archive-path ;; no point in proceeding if there is no actual archive (not toplevel/children)) (begin @@ -276,17 +276,17 @@ ;; DO BUP RESTORE (let* ((new-test-dat (rmt:get-test-info-by-id run-id test-id)) (new-test-path (if (vector? new-test-dat ) (db:test-get-rundir new-test-dat) (begin - (debug:print 0 "ERROR: unable to get data for run-id=" run-id ", test-id=" test-id) + (debug:print 0 #f "ERROR: unable to get data for run-id=" run-id ", test-id=" test-id) (exit 1)))) ;; new-test-path won't work - must use best-disk instead? Nope, new-test-path but tack on /.. (bup-restore-params (list "-d" archive-path "restore" "-C" (conc new-test-path "/..") archive-internal-path))) - (debug:print-info 0 "Restoring archived data to " new-test-physical-path " from archive in " archive-path " ... " archive-internal-path) + (debug:print-info 0 #f "Restoring archived data to " new-test-physical-path " from archive in " archive-path " ... " archive-internal-path) ;; (mutex-lock! bup-mutex) (run-n-wait bup-exe params: bup-restore-params print-cmd: #f) ;; (mutex-unlock! bup-mutex) (mt:test-set-state-status-by-id run-id test-id "COMPLETED" #f #f))) - (debug:print 0 "ERROR: No archive path in the record for run-id=" run-id " test-id=" test-id)))) + (debug:print 0 #f "ERROR: No archive path in the record for run-id=" run-id " test-id=" test-id)))) (filter vector? tests)))) Index: client.scm ================================================================== --- client.scm +++ client.scm @@ -64,17 +64,17 @@ ;; ((rpc) (rpc:login-no-auto-client-setup server-info run-id)) ;; ((http) (rmt:login-no-auto-client-setup server-info run-id)) ;; (else (rpc:login-no-auto-client-setup server-info run-id)))) ;; ;; (define (client:setup-rpc run-id) -;; (debug:print 0 "INFO: client:setup remaining-tries=" remaining-tries) +;; (debug:print 0 #f "INFO: client:setup remaining-tries=" remaining-tries) ;; (if (<= remaining-tries 0) ;; (begin -;; (debug:print 0 "ERROR: failed to start or connect to server for run-id " run-id) +;; (debug:print 0 #f "ERROR: failed to start or connect to server for run-id " run-id) ;; (exit 1)) ;; (let ((host-info (hash-table-ref/default *runremote* run-id #f))) -;; (debug:print-info 0 "client:setup host-info=" host-info ", remaining-tries=" remaining-tries) +;; (debug:print-info 0 #f "client:setup host-info=" host-info ", remaining-tries=" remaining-tries) ;; (if host-info ;; (let* ((iface (car host-info)) ;; (port (cadr host-info)) ;; (start-res (client:connect iface port)) ;; ;; (ping-res (server:ping-server run-id iface port)) @@ -83,11 +83,11 @@ ;; (begin ;; (hash-table-set! *runremote* run-id start-res) ;; start-res) ;; return the server info ;; (if (member remaining-tries '(3 4 6)) ;; (begin ;; login failed -;; (debug:print 25 "INFO: client:setup start-res=" start-res ", run-id=" run-id ", server-dat=" host-info) +;; (debug:print 25 #f "INFO: client:setup start-res=" start-res ", run-id=" run-id ", server-dat=" host-info) ;; (hash-table-delete! *runremote* run-id) ;; (open-run-close tasks:server-force-clean-run-record ;; tasks:open-db ;; run-id ;; (car host-info) @@ -94,16 +94,16 @@ ;; (cadr host-info) ;; " client:setup (host-info=#t)") ;; (thread-sleep! 5) ;; (client:setup run-id remaining-tries: 10)) ;; (- remaining-tries 1))) ;; (begin -;; (debug:print 25 "INFO: client:setup failed to connect, start-res=" start-res ", run-id=" run-id ", host-info=" host-info) +;; (debug:print 25 #f "INFO: client:setup failed to connect, start-res=" start-res ", run-id=" run-id ", host-info=" host-info) ;; (thread-sleep! 5) ;; (client:setup run-id remaining-tries: (- remaining-tries 1)))))) ;; ;; YUK: rename server-dat here ;; (let* ((server-dat (open-run-close tasks:get-server tasks:open-db run-id))) -;; (debug:print-info 0 "client:setup server-dat=" server-dat ", remaining-tries=" remaining-tries) +;; (debug:print-info 0 #f "client:setup server-dat=" server-dat ", remaining-tries=" remaining-tries) ;; (if server-dat ;; (let* ((iface (tasks:hostinfo-get-interface server-dat)) ;; (port (tasks:hostinfo-get-port server-dat)) ;; (start-res (http-transport:client-connect iface port)) ;; ;; (ping-res (server:ping-server run-id iface port)) @@ -112,11 +112,11 @@ ;; (begin ;; (hash-table-set! *runremote* run-id start-res) ;; start-res) ;; (if (member remaining-tries '(2 5)) ;; (begin ;; login failed -;; (debug:print 25 "INFO: client:setup start-res=" start-res ", run-id=" run-id ", server-dat=" server-dat) +;; (debug:print 25 #f "INFO: client:setup start-res=" start-res ", run-id=" run-id ", server-dat=" server-dat) ;; (hash-table-delete! *runremote* run-id) ;; (open-run-close tasks:server-force-clean-run-record ;; tasks:open-db ;; run-id ;; (tasks:hostinfo-get-interface server-dat) @@ -125,21 +125,21 @@ ;; (thread-sleep! 2) ;; (server:try-running run-id) ;; (thread-sleep! 10) ;; give server a little time to start up ;; (client:setup run-id remaining-tries: 10)) ;; (- remaining-tries 1))) ;; (begin -;; (debug:print 25 "INFO: client:setup start-res=" start-res ", run-id=" run-id ", server-dat=" server-dat) +;; (debug:print 25 #f "INFO: client:setup start-res=" start-res ", run-id=" run-id ", server-dat=" server-dat) ;; (thread-sleep! 5) ;; (client:setup run-id remaining-tries: (- remaining-tries 1)))))) ;; (begin ;; no server registered ;; (if (eq? remaining-tries 2) ;; (begin ;; ;; (open-run-close tasks:server-clean-out-old-records-for-run-id tasks:open-db run-id " client:setup (server-dat=#f)") ;; (client:setup run-id remaining-tries: 10)) ;; (begin ;; (thread-sleep! 2) -;; (debug:print 25 "INFO: client:setup start-res (not defined here), run-id=" run-id ", server-dat=" server-dat) +;; (debug:print 25 #f "INFO: client:setup start-res (not defined here), run-id=" run-id ", server-dat=" server-dat) ;; (if (< (open-run-close tasks:num-in-available-state tasks:open-db run-id) 3) ;; (begin ;; ;; (open-run-close tasks:server-clean-out-old-records-for-run-id tasks:open-db run-id " client:setup (server-dat=#f)") ;; (server:try-running run-id))) ;; (thread-sleep! 10) ;; give server a little time to start up @@ -156,11 +156,11 @@ ;; client:setup ;; ;; lookup_server, need to remove *runremote* stuff ;; (define (client:setup-http run-id #!key (remaining-tries 10) (failed-connects 0)) - (debug:print-info 2 "client:setup remaining-tries=" remaining-tries) + (debug:print-info 2 #f "client:setup remaining-tries=" remaining-tries) (let* ((tdbdat (tasks:open-db))) (if (<= remaining-tries 0) (begin (debug:print 0 "ERROR: failed to start or connect to server for run-id " run-id) (exit 1)) @@ -216,14 +216,14 @@ (define (client:setup-nmsg run-id #!key (remaining-tries 10) (failed-connects 0)) (debug:print-info 2 "client:setup remaining-tries=" remaining-tries) (let* ((tdbdat (tasks:open-db))) (if (<= remaining-tries 0) (begin - (debug:print 0 "ERROR: failed to start or connect to server for run-id " run-id) + (debug:print 0 #f "ERROR: failed to start or connect to server for run-id " run-id) (exit 1)) (let* ((server-dat (tasks:get-server (db:delay-if-busy tdbdat) run-id))) - (debug:print-info 4 "client:setup server-dat=" server-dat ", remaining-tries=" remaining-tries) + (debug:print-info 4 #f "client:setup server-dat=" server-dat ", remaining-tries=" remaining-tries) (if server-dat (let* ((iface (tasks:hostinfo-get-interface server-dat)) (hostname (tasks:hostinfo-get-hostname server-dat)) (port (tasks:hostinfo-get-port server-dat)) (start-res (case *transport-type* @@ -237,14 +237,14 @@ #f)))))) (if (and start-res ping-res) (begin (hash-table-set! *runremote* run-id start-res) - (debug:print-info 2 "connected to " (http-transport:server-dat-make-url start-res)) + (debug:print-info 2 #f "connected to " (http-transport:server-dat-make-url start-res)) start-res) (begin ;; login failed but have a server record, clean out the record and try again - (debug:print-info 0 "client:setup, login failed, will attempt to start server ... start-res=" start-res ", run-id=" run-id ", server-dat=" server-dat) + (debug:print-info 0 #f "client:setup, login failed, will attempt to start server ... start-res=" start-res ", run-id=" run-id ", server-dat=" server-dat) (case *transport-type* ((http)(http-transport:close-connections run-id))) (hash-table-delete! *runremote* run-id) (tasks:kill-server-run-id run-id) (tasks:server-force-clean-run-record (db:delay-if-busy tdbdat) @@ -259,11 +259,11 @@ (thread-sleep! 5) ;; give server a little time to start up (client:setup run-id remaining-tries: (- remaining-tries 1)) ))) (begin ;; no server registered (let ((num-available (tasks:num-in-available-state (db:dbdat-get-db tdbdat) run-id))) - (debug:print-info 0 "client:setup, no server registered, remaining-tries=" remaining-tries " num-available=" num-available) + (debug:print-info 0 #f "client:setup, no server registered, remaining-tries=" remaining-tries " num-available=" num-available) (if (< num-available 2) (server:try-running run-id)) (thread-sleep! (+ 5 (random (- 20 remaining-tries)))) ;; give server a little time to start up, randomize a little to avoid start storms. (client:setup run-id remaining-tries: (- remaining-tries 1))))))))) @@ -276,18 +276,18 @@ ;; (define (client:signal-handler signum) ;; (signal-mask! signum) ;; (set! *time-to-exit* #t) ;; (handle-exceptions ;; exn -;; (debug:print " ... exiting ...") +;; (debug:print 0 #f " ... exiting ...") ;; (let ((th1 (make-thread (lambda () ;; "") ;; do nothing for now (was 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.") +;; (debug:print 0 #f "ERROR: Received ^C, attempting clean exit. Please be patient and wait a few seconds before hitting ^C again.") ;; (thread-sleep! 1) ;; give the flush one second to do it's stuff -;; (debug:print 0 " Done.") +;; (debug:print 0 #f " Done.") ;; (exit 4)) ;; "exit on ^C timer"))) ;; (thread-start! th2) ;; (thread-start! th1) ;; (thread-join! th2)))) @@ -298,10 +298,10 @@ ;; ;; ;; (define (client:launch run-id) ;; (set-signal-handler! signal/int client:signal-handler) ;; (set-signal-handler! signal/term client:signal-handler) ;; (if (client:setup run-id) -;; (debug:print-info 2 "connected as client") +;; (debug:print-info 2 #f "connected as client") ;; (begin -;; (debug:print 0 "ERROR: Failed to connect as client") +;; (debug:print 0 #f "ERROR: Failed to connect as client") ;; (exit)))) ;; Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -34,23 +34,27 @@ (define getenv get-environment-variable) (define (safe-setenv key val) (if (and (string? val)(string? key)) (handle-exceptions exn - (debug:print 0 "ERROR: bad value for setenv, key=" key ", value=" val) + (debug:print 0 #f "ERROR: bad value for setenv, key=" key ", value=" val) (setenv key val)) - (debug:print 0 "ERROR: bad value for setenv, key=" key ", value=" val))) + (debug:print 0 #f "ERROR: bad value for setenv, key=" key ", value=" val))) (define home (getenv "HOME")) (define user (getenv "USER")) ;; GLOBAL GLETCHES (define *db-keys* #f) -(define *configinfo* #f) -(define *configdat* #f) -(define *toppath* #f) + +(define *configinfo* #f) ;; raw results from setup, includes toppath and table from megatest.config +(define *runconfigdat* #f) ;; run configs data +(define *configdat* #f) ;; megatest.config data +(define *configstatus* #f) ;; status of data; 'fulldata : all processing done, #f : no data yet, 'partialdata : partial read done +(define *toppath* #f) (define *already-seen-runconfig-info* #f) + (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 (define *write-frequency* (make-hash-table)) ;; run-id => (vector (current-seconds) 0)) @@ -125,10 +129,96 @@ ;; Generic string database (define sdb:qry #f) ;; (make-sdb:qry)) ;; 'init #f) ;; Generic path database (define *fdb* #f) + +;;====================================================================== +;; V E R S I O N +;;====================================================================== + +(define (common:get-full-version) + (conc megatest-version "-" megatest-fossil-hash)) + +(define (common:version-signature) + (conc megatest-version "-" (substring megatest-fossil-hash 0 4))) + +;; from metadat lookup MEGATEST_VERSION +;; +(define (common:get-last-run-version) + (rmt:get-var "MEGATEST_VERSION")) + +(define (common:set-last-run-version) + (rmt:set-var "MEGATEST_VERSION" (common:version-signature))) + +(define (common:version-changed?) + (not (equal? (common:get-last-run-version) + (common:version-signature)))) + +;; Move me elsewhere ... +;; +(define (common:cleanup-db) + (db:multi-db-sync + #f ;; do all run-ids + ;; 'new2old + 'killservers + 'dejunk + ;; 'adj-testids + ;; 'old2new + 'new2old) + (if (common:version-changed?) + (common:set-last-run-version))) + +(define (common:exit-on-version-changed) + (if (common:version-changed?) + (let ((mtconf (conc (get-environment-variable "MT_RUN_AREA_HOME") "/megatest.config"))) + (debug:print 0 #f + "ERROR: Version mismatch!\n" + " expected: " (common:version-signature) "\n" + " got: " (common:get-last-run-version)) + (if (and (file-exists? mtconf) + (eq? (current-user-id)(file-owner mtconf))) ;; safe to run -cleanup-db + (begin + (debug:print 0 #f " I see you are the owner of megatest.config, attempting to cleanup and reset to new version") + (handle-exceptions + exn + (begin + (debug:print 0 #f "Failed to switch versions.") + (debug:print 0 #f " message: " ((condition-property-accessor 'exn 'message) exn)) + (print-call-chain (current-error-port)) + (exit 1)) + (common:cleanup-db))) + (begin + (debug:print 0 #f " to switch versions you can run: \"megatest -cleanup-db\"") + (exit 1)))))) + +;;====================================================================== +;; S P A R S E A R R A Y S +;;====================================================================== + +(define (make-sparse-array) + (let ((a (make-sparse-vector))) + (sparse-vector-set! a 0 (make-sparse-vector)) + a)) + +(define (sparse-array? a) + (and (sparse-vector? a) + (sparse-vector? (sparse-vector-ref a 0)))) + +(define (sparse-array-ref a x y) + (let ((row (sparse-vector-ref a x))) + (if row + (sparse-vector-ref row y) + #f))) + +(define (sparse-array-set! a x y val) + (let ((row (sparse-vector-ref a x))) + (if row + (sparse-vector-set! row y val) + (let ((new-row (make-sparse-vector))) + (sparse-vector-set! a x new-row) + (sparse-vector-set! new-row y val))))) ;;====================================================================== ;; L O C K E R S A N D B L O C K E R S ;;====================================================================== @@ -146,10 +236,27 @@ val)) ;;====================================================================== ;; U S E F U L S T U F F ;;====================================================================== + +;; convert things to an alist or assoc list, #f gets converted to "" +;; +(define (common:to-alist dat) + (cond + ((list? dat) (map common:to-alist dat)) + ((vector? dat) + (map common:to-alist (vector->list dat))) + ((pair? dat) + (cons (common:to-alist (car dat)) + (common:to-alist (cdr dat)))) + ((hash-table? dat) + (map common:to-alist (hash-table->alist dat))) + (else + (if dat + dat + "")))) (define (common:low-noise-print waitval . keys) (let* ((key (string-intersperse (map conc keys) "-" )) (lasttime (hash-table-ref/default *common:denoise* key 0)) (currtime (current-seconds))) @@ -166,11 +273,11 @@ (handle-exceptions exn (handle-exceptions exn (begin - (debug:print 0 "ERROR: received bad encoded string \"" instr "\", message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 #f "ERROR: received bad encoded string \"" instr "\", message: " ((condition-property-accessor 'exn 'message) exn)) (print-call-chain (current-error-port)) #f) (read (open-input-string (base64:base64-decode instr)))) (read (open-input-string (z3:decode-buffer (base64:base64-decode instr)))))) @@ -188,13 +295,15 @@ (let ((key-string (conc (get-host-name) "-" (current-process-id)))) (with-output-to-file fname (lambda () (print key-string))) (thread-sleep! 0.25) - (with-input-from-file fname - (lambda () - (equal? key-string (read-line))))))) + (if (file-exists? fname) + (with-input-from-file fname + (lambda () + (equal? key-string (read-line)))) + #f)))) (define (common:simple-file-release-lock fname) (delete-file* fname)) ;;====================================================================== @@ -252,13 +361,13 @@ ;;====================================================================== (define (common:legacy-sync-recommended) (or (args:get-arg "-runtests") (args:get-arg "-server") - (args:get-arg "-set-run-status") + ;; (args:get-arg "-set-run-status") (args:get-arg "-remove-runs") - (args:get-arg "-get-run-status") + ;; (args:get-arg "-get-run-status") )) (define (common:legacy-sync-required) (configf:lookup *configdat* "setup" "megatest-db")) @@ -266,17 +375,18 @@ (let ((no-hurry (if *time-to-exit* ;; hurry up #f (begin (set! *time-to-exit* #t) #t)))) - (debug:print-info 4 "starting exit process, finalizing databases.") + (debug:print-info 4 #f "starting exit process, finalizing databases.") (if (and no-hurry (debug:debug-mode 18)) (rmt:print-db-stats)) (let ((th1 (make-thread (lambda () ;; thread for cleaning up, give it five seconds (let ((run-ids (hash-table-keys *db-local-sync*))) (if (and (not (null? run-ids)) - (configf:lookup *configdat* "setup" "megatest-db")) + (or (common:legacy-sync-recommended) + (configf:lookup *configdat* "setup" "megatest-db"))) (if no-hurry (db:multi-db-sync run-ids 'new2old)))) (if *dbstruct-db* (db:close-all *dbstruct-db*)) (if *inmemdb* (db:close-all *inmemdb*)) (if (and *megatest-db* (sqlite3:database? *megatest-db*)) @@ -290,31 +400,31 @@ (begin (sqlite3:interrupt! db) (sqlite3:finalize! db #t) (vector-set! *task-db* 0 #f)))))) "Cleanup db exit thread")) (th2 (make-thread (lambda () - (debug:print 4 "Attempting clean exit. Please be patient and wait a few seconds...") + (debug:print 4 #f "Attempting clean exit. Please be patient and wait a few seconds...") (if no-hurry (thread-sleep! 5) ;; give the clean up few seconds to do it's stuff (thread-sleep! 2)) - (debug:print 4 " ... done") + (debug:print 4 #f " ... done") ) "clean exit"))) (thread-start! th1) (thread-start! th2) (thread-join! th1)))) (define (std-signal-handler signum) ;; (signal-mask! signum) (set! *time-to-exit* #t) - (debug:print 0 "ERROR: Received signal " signum " exiting promptly") + (debug:print 0 #f "ERROR: Received signal " signum " exiting promptly") ;; (std-exit-procedure) ;; shouldn't need this since we are exiting and it will be called anyway (exit)) (set-signal-handler! signal/int std-signal-handler) ;; ^C (set-signal-handler! signal/term std-signal-handler) -(set-signal-handler! signal/stop std-signal-handler) ;; ^Z +;; (set-signal-handler! signal/stop std-signal-handler) ;; ^Z NO, do NOT handle ^Z! ;;====================================================================== ;; M I S C U T I L S ;;====================================================================== @@ -338,13 +448,10 @@ ((d) (* 24 60 60)) (else 0)))))))))) parts) time-secs)) -(define (common:version-signature) - (conc megatest-version "-" (substring megatest-fossil-hash 0 4))) - ;; one-of args defined (define (args-defined? . param) (let ((res #f)) (for-each (lambda (arg) @@ -363,30 +470,37 @@ (define (any->number-if-possible val) (let ((num (any->number val))) (if num num val))) (define (patt-list-match item patts) - (debug:print-info 8 "patt-list-match item=" item " patts=" patts) + (debug:print-info 8 #f "patt-list-match item=" item " patts=" patts) (if (and item patts) ;; here we are filtering for matches with item patterns (let ((res #f)) ;; look through all the item-patts if defined, format is patt1,patt2,patt3 ... wildcard is % (for-each (lambda (patt) (let ((modpatt (string-substitute "%" ".*" patt #t))) - (debug:print-info 10 "patt " patt " modpatt " modpatt) + (debug:print-info 10 #f "patt " patt " modpatt " modpatt) (if (string-match (regexp modpatt) item) (set! res #t)))) (string-split patts ",")) res) #t)) ;; (map print (map car (hash-table->alist (read-config "runconfigs.config" #f #t)))) (define (common:get-runconfig-targets #!key (configf #f)) - (sort (map car (hash-table->alist - (or configf - (read-config "runconfigs.config" - #f #t)))) - stringalist + (or configf + (read-config (conc *toppath* "/runconfigs.config") + #f #t) + (make-hash-table)))) + string curr-rownum rownum) curr-rownum rownum) (if (> curr-colnum colnum) curr-colnum colnum) )))))) ;;====================================================================== -;; System stuff +;; S Y S T E M S T U F F ;;====================================================================== ;; return a nice clean pathname made absolute -(define (nice-path dir) - (normalize-pathname (if (absolute-pathname? dir) - dir - (conc (current-directory) "/" dir)))) +(define (common:nice-path dir) + (let ((match (string-match "^(~[^\\/]*)(\\/.*|)$" dir))) + (if match ;; using ~ for home? + (common:nice-path (conc (common:read-link-f (cadr match)) "/" (caddr match))) + (normalize-pathname (if (absolute-pathname? dir) + dir + (conc (current-directory) "/" dir)))))) + +;; make "nice-path" available in config files and the repl +(define nice-path common:nice-path) + +(define (common:read-link-f path) + (handle-exceptions + exn + (begin + (debug:print 0 #f "ERROR: command \"/bin/readlink -f " path "\" failed.") + path) ;; just give up + (with-input-from-pipe + (conc "/bin/readlink -f " path) + (lambda () + (read-line))))) (define (get-cpu-load) (car (common:get-cpu-load))) -;; (let* ((load-res (cmd-run->list "uptime")) +;; (let* ((load-res (process:cmd-run->list "uptime")) ;; (load-rx (regexp "load average:\\s+(\\d+)")) ;; (cpu-load #f)) ;; (for-each (lambda (l) ;; (let ((match (string-search load-rx l))) ;; (if match @@ -551,25 +697,25 @@ ;; (define (common:get-cpu-load) (with-input-from-file "/proc/loadavg" (lambda ()(list (read)(read)(read))))) -(define (common:wait-for-cpuload maxload numcpus waitdelay #!key (count 1000)) +(define (common:wait-for-cpuload maxload numcpus waitdelay #!key (count 1000) (msg #f)) (let* ((loadavg (common:get-cpu-load)) (first (car loadavg)) (next (cadr loadavg)) (adjload (* maxload numcpus)) (loadjmp (- first next))) (cond ((and (> first adjload) (> count 0)) - (debug:print-info 0 "waiting " waitdelay " seconds due to load " first " exceeding max of " adjload) + (debug:print-info 0 #f "waiting " waitdelay " seconds due to load " first " exceeding max of " adjload (if msg msg "")) (thread-sleep! waitdelay) (common:wait-for-cpuload maxload numcpus waitdelay count: (- count 1))) ((and (> loadjmp numcpus) (> count 0)) - (debug:print-info 0 "waiting " waitdelay " seconds due to load jump " loadjmp " > numcpus " numcpus) + (debug:print-info 0 #f "waiting " waitdelay " seconds due to load jump " loadjmp " > numcpus " numcpus (if msg msg "")) (thread-sleep! waitdelay) (common:wait-for-cpuload maxload numcpus waitdelay count: (- count 1)))))) (define (common:get-num-cpus) (with-input-from-file "/proc/cpuinfo" @@ -581,22 +727,28 @@ (loop (if (string-match "^processor\\s+:\\s+\\d+$" inl) (+ numcpu 1) numcpu) (read-line))))))) +;; wait for normalized cpu load to drop below maxload +;; +(define (common:wait-for-normalized-load maxload #!key (msg #f)) + (let ((num-cpus (common:get-num-cpus))) + (common:wait-for-cpuload maxload num-cpus 15 msg: msg))) + (define (get-uname . params) - (let* ((uname-res (cmd-run->list (conc "uname " (if (null? params) "-a" (car params))))) + (let* ((uname-res (process:cmd-run->list (conc "uname " (if (null? params) "-a" (car params))))) (uname #f)) (if (null? (car uname-res)) "unknown" (caar uname-res)))) ;; for reasons I don't understand multiple calls to real-path in parallel threads ;; must be protected by mutexes ;; (define (common:real-path inpath) - ;; (cmd-run-with-stderr->list "readlink" "-f" inpath)) ;; cmd . params) + ;; (process:cmd-run-with-stderr->list "readlink" "-f" inpath)) ;; cmd . params) ;; (let-values ;; (((inp oup pid) (process "readlink" (list "-f" inpath)))) ;; (with-input-from-port inp ;; (let loop ((inl (read-line)) ;; (res #f)) @@ -615,12 +767,25 @@ ;;====================================================================== (define (common:get-disk-space-used fpath) (with-input-from-pipe (conc "/usr/bin/du -s " fpath) read)) +;; given path get free space, allows override in [setup] +;; with free-space-script /path/to/some/script.sh +;; (define (get-df path) - (let* ((df-results (cmd-run->list (conc "df " path))) + (if (configf:lookup *configdat* "setup" "free-space-script") + (with-input-from-pipe + (conc (configf:lookup *configdat* "setup" "free-space-script") " " path) + (lambda () + (let ((res (read-line))) + (if (string? res) + (string->number res))))) + (get-unix-df path))) + +(define (get-unix-df path) + (let* ((df-results (process:cmd-run->list (conc "df " path))) (space-rx (regexp "([0-9]+)\\s+([0-9]+)%")) (freespc #f)) ;; (write df-results) (for-each (lambda (l) (let ((match (string-search space-rx l))) @@ -628,10 +793,39 @@ (let ((newval (string->number (cadr match)))) (if (number? newval) (set! freespc newval)))))) (car df-results)) freespc)) + +;; check space in dbdir +;; returns: ok/not dbspace required-space +;; +(define (common:check-db-dir-space) + (let* ((dbdir (db:get-dbdir)) + (dbspace (if (directory? dbdir) + (get-df dbdir) + 0)) + (required (string->number + (or (configf:lookup *configdat* "setup" "dbdir-space-required") + "100000")))) + (list (> dbspace required) + dbspace + required + dbdir))) + +;; check available space in dbdir, exit if insufficient +;; +(define (common:check-db-dir-and-exit-if-insufficient) + (let* ((spacedat (common:check-db-dir-space)) + (is-ok (car spacedat)) + (dbspace (cadr spacedat)) + (required (caddr spacedat)) + (dbdir (cadddr spacedat))) + (if (not is-ok) + (begin + (debug:print 0 #f "ERROR: Insufficient space in " dbdir ", require " required ", have " dbspace ", exiting now.") + (exit 1))))) ;; paths is list of lists ((name path) ... ) ;; (define (common:get-disk-with-most-free-space disks minsize) (let ((best #f) @@ -639,20 +833,20 @@ (for-each (lambda (disk-num) (let* ((dirpath (cadr (assoc disk-num disks))) (freespc (cond ((not (directory? dirpath)) - (if (common:low-noise-print 50 "disks not a dir " disk-num) - (debug:print 0 "WARNING: disk " disk-num " at path " dirpath " is not a directory - ignoring it.")) + (if (common:low-noise-print 300 "disks not a dir " disk-num) + (debug:print 0 #f "WARNING: disk " disk-num " at path \"" dirpath "\" is not a directory - ignoring it.")) -1) ((not (file-write-access? dirpath)) - (if (common:low-noise-print 50 "disks not writeable " disk-num) - (debug:print 0 "WARNING: disk " disk-num " at path " dirpath " is not writeable - ignoring it.")) + (if (common:low-noise-print 300 "disks not writeable " disk-num) + (debug:print 0 #f "WARNING: disk " disk-num " at path \"" dirpath "\" is not writeable - ignoring it.")) -1) ((not (eq? (string-ref dirpath 0) #\/)) - (if (common:low-noise-print 50 "disks not a proper path " disk-num) - (debug:print 0 "WARNING: disk " disk-num " at path " dirpath " is not a fully qualified path - ignoring it.")) + (if (common:low-noise-print 300 "disks not a proper path " disk-num) + (debug:print 0 #f "WARNING: disk " disk-num " at path \"" dirpath "\" is not a fully qualified path - ignoring it.")) -1) (else (get-df dirpath))))) (if (> freespc bestsize) (begin @@ -667,11 +861,16 @@ ;; E N V I R O N M E N T V A R S ;;====================================================================== (define (save-environment-as-files fname #!key (ignorevars (list "USER" "HOME" "DISPLAY" "LS_COLORS" "XKEYSYMDB" "EDITOR" "MAKEFLAGS" "MAKEF" "MAKEOVERRIDES"))) (let ((envvars (get-environment-variables)) - (whitesp (regexp "[^a-zA-Z0-9_\\-:,.\\/%$]"))) + (whitesp (regexp "[^a-zA-Z0-9_\\-:,.\\/%$]")) + (mungeval (lambda (val) + (cond + ((eq? val #t) "") ;; convert #t to empty string + ((eq? val #f) #f) ;; convert #f to itself (still thinking about this one + (else val))))) (with-output-to-file (conc fname ".csh") (lambda () (for-each (lambda (keyval) (let* ((key (car keyval)) (val (cdr keyval)) @@ -679,11 +878,11 @@ "\"" ""))) (print (if (member key ignorevars) "# setenv " "setenv ") - key " " delim val delim))) + key " " delim (mungeval val) delim))) envvars))) (with-output-to-file (conc fname ".sh") (lambda () (for-each (lambda (keyval) (let* ((key (car keyval)) @@ -692,11 +891,11 @@ "\"" ""))) (print (if (member key ignorevars) "# export " "export ") - key "=" delim val delim))) + key "=" delim (mungeval val) delim))) envvars))))) ;; set some env vars from an alist, return an alist with original values ;; (("VAR" "value") ...) (define (alist->env-vars lst) @@ -739,11 +938,11 @@ (lambda (var val) (setenv var val))) vars)) ;;====================================================================== -;; time and date nice to have stuff +;; T I M E A N D D A T E ;;====================================================================== (define (seconds->hr-min-sec secs) (let* ((hrs (quotient secs 3600)) (min (quotient (- secs (* hrs 3600)) 60)) @@ -782,11 +981,11 @@ ((7 8 9) 3) ((10 11 12) 4) (else #f))) ;;====================================================================== -;; Colors +;; C O L O R S ;;====================================================================== (define (common:name->iup-color name) (case (string->symbol (string-downcase name)) ((red) "223 33 49") @@ -1031,20 +1230,20 @@ (tal (cdr launchers))) (let ((patt (car hed)) (host-type (cadr hed))) (if (tests:match patt testname itempath) (begin - (debug:print-info 0 "Have flexi-launcher match for " testname "/" itempath " = " host-type) + (debug:print-info 2 #f "Have flexi-launcher match for " testname "/" itempath " = " host-type) (let ((launcher (configf:lookup configdat "host-types" host-type))) (if launcher launcher (begin - (debug:print-info 0 "WARNING: no launcher found for host-type " host-type) + (debug:print-info 0 #f "WARNING: no launcher found for host-type " host-type) (if (null? tal) fallback-launcher (loop (car tal)(cdr tal))))))) ;; no match, try again (if (null? tal) fallback-launcher (loop (car tal)(cdr tal)))))))) fallback-launcher))) Index: common_records.scm ================================================================== --- common_records.scm +++ common_records.scm @@ -8,10 +8,12 @@ ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. ;;====================================================================== ;; (use trace) + +(include "altdb.scm") ;; Some of these routines use: ;; ;; http://www.cs.toronto.edu/~gfb/scheme/simple-macros.html ;; @@ -79,32 +81,31 @@ (not (getenv "MT_DEBUG_MODE"))) (setenv "MT_DEBUG_MODE" (if (list? *verbosity*) (string-intersperse (map conc *verbosity*) ",") (conc *verbosity*)))))) - -(define (debug:print n . params) +(define (debug:print n e . params) (if (debug:debug-mode n) - (with-output-to-port (current-error-port) + (with-output-to-port (or e (current-error-port)) (lambda () (if *logging* (db:log-event (apply conc params)) ;; (apply print "pid:" (current-process-id) " " params) (apply print params) ))))) -(define (debug:print-info n . params) +(define (debug:print-info n e . params) (if (debug:debug-mode n) - (with-output-to-port (current-error-port) + (with-output-to-port (or e (current-error-port)) (lambda () - (let ((res (format#format #f "INFO: (~a) ~a" n (apply conc params)))) - (if *logging* - (db:log-event res) - ;; (apply print "pid:" (current-process-id) " " "INFO: (" n ") " params) ;; res) - (apply print "INFO: (" n ") " params) ;; res) - )))))) + (if *logging* + (let ((res (format#format #f "INFO: (~a) ~a" n (apply conc params)))) + (db:log-event res)) + ;; (apply print "pid:" (current-process-id) " " "INFO: (" n ") " params) ;; res) + (apply print "INFO: (" n ") " params) ;; res) + ))))) ;; if a value is printable (i.e. string or number) return the value ;; else return an empty string (define-inline (printable val) (if (or (number? val)(string? val)) val "")) Index: configf.scm ================================================================== --- configf.scm +++ configf.scm @@ -11,13 +11,12 @@ ;;====================================================================== ;; Config file handling ;;====================================================================== -(use regex regex-case directory-utils) +(use regex regex-case) ;; directory-utils) (declare (unit configf)) -(declare (uses common)) (declare (uses process)) (include "common_records.scm") ;; return list (path fullpath configname) @@ -36,18 +35,25 @@ (let ((remcwd (take dir (- (length dir) 1)))) (if (null? remcwd) (list #f #f #f) ;; #f #f) (loop remcwd))))))))) -(define (config:assoc-safe-add alist key val) +(define (config:assoc-safe-add alist key val #!key (metadata #f)) (let ((newalist (filter (lambda (x)(not (equal? key (car x)))) alist))) - (append newalist (list (list key val))))) + (append newalist (list (if metadata + (list key val metadata) + (list key val)))))) (define (config:eval-string-in-environment str) - (let ((cmdres (cmd-run->list (conc "echo " str)))) - (if (null? cmdres) "" - (caar cmdres)))) + (handle-exceptions + exn + (begin + (debug:print 0 #f "ERROR: problem evaluating \"" str "\" in the shell environment") + #f) + (let ((cmdres (process:cmd-run->list (conc "echo " str)))) + (if (null? cmdres) "" + (caar cmdres))))) ;;====================================================================== ;; Make the regexp's needed globally available ;;====================================================================== @@ -62,21 +68,24 @@ (define configf:settings (regexp "^\\[configf:settings\\s+(\\S+)\\s+(\\S+)]\\s*$")) ;; read a line and process any #{ ... } constructs (define configf:var-expand-regex (regexp "^(.*)#\\{(scheme|system|shell|getenv|get|runconfigs-get|rget)\\s+([^\\}\\{]*)\\}(.*)")) -(define (configf:process-line l ht allow-system) + +(define (configf:process-line l ht allow-system #!key (linenum #f)) (let loop ((res l)) (if (string? res) (let ((matchdat (string-search configf:var-expand-regex res))) (if matchdat (let* ((prestr (list-ref matchdat 1)) (cmdtype (list-ref matchdat 2)) ;; eval, system, shell, getenv (cmd (list-ref matchdat 3)) (poststr (list-ref matchdat 4)) (result #f) - (fullcmd (case (string->symbol cmdtype) + (start-time (current-seconds)) + (cmdsym (string->symbol cmdtype)) + (fullcmd (case cmdsym ((scheme)(conc "(lambda (ht)" cmd ")")) ((system)(conc "(lambda (ht)(system \"" cmd "\"))")) ((shell) (conc "(lambda (ht)(shell \"" cmd "\"))")) ((getenv)(conc "(lambda (ht)(get-environment-variable \"" cmd "\"))")) ((get) @@ -88,46 +97,48 @@ ((rget) (conc "(lambda (ht)(runconfigs-get ht \"" cmd "\"))")) (else "(lambda (ht)(print \"ERROR\") \"ERROR\")")))) ;; (print "fullcmd=" fullcmd) (handle-exceptions exn - (debug:print 0 "ERROR: failed to process config input \"" l "\"") + (begin + (debug:print 0 #f "WARNING: failed to process config input \"" l "\"") + (debug:print 0 #f " message: " ((condition-property-accessor 'exn 'message) exn)) + ;; (print "exn=" (condition->list exn)) + (set! result (conc "#{( " cmdtype ") " cmd"}"))) (if (or allow-system (not (member cmdtype '("system" "shell")))) (with-input-from-string fullcmd (lambda () (set! result ((eval (read)) ht)))) (set! result (conc "#{(" cmdtype ") " cmd "}")))) + (case cmdsym + ((system shell scheme) + (let ((delta (- (current-seconds) start-time))) + (if (> delta 2) + (debug:print-info 0 #f "for line \"" l "\"\n command: " cmd " took " delta " seconds to run with output:\n " result) + (debug:print-info 9 #f "for line \"" l "\"\n command: " cmd " took " delta " seconds to run with output:\n " result))))) (loop (conc prestr result poststr))) res)) res))) ;; Run a shell command and return the output as a string (define (shell cmd) - (let* ((output (cmd-run->list cmd)) + (let* ((output (process:cmd-run->list cmd)) (res (car output)) (status (cadr output))) (if (equal? status 0) (let ((outres (string-intersperse res "\n"))) - (debug:print-info 4 "shell result:\n" outres) + (debug:print-info 4 #f "shell result:\n" outres) outres) (begin (with-output-to-port (current-error-port) (lambda () (print "ERROR: " cmd " returned bad exit code " status))) "")))) -;; Lookup a value in runconfigs based on -reqtarg or -target -(define (runconfigs-get config var) - (let ((targ (common:args-get-target))) ;; (or (args:get-arg "-reqtarg")(args:get-arg "-target")(getenv "MT_TARGET")))) - (if targ - (or (configf:lookup config targ var) - (configf:lookup config "default" var)) - (configf:lookup config "default" var)))) - ;; this was inline but I'm pretty sure that is a hold over from when it was *very* simple ... ;; (define (configf:read-line p ht allow-processing settings) (let loop ((inl (read-line p))) (let ((cont-line (and (string? inl) @@ -150,111 +161,139 @@ (configf:process-line inl ht allow-processing))))) (if (and (string? res) (not (equal? (hash-table-ref/default settings "trim-trailing-spaces" "no") "no"))) (string-substitute "\\s+$" "" res) res)))))) - + +(define (calc-allow-system allow-system section sections) + (if sections + (and (or (equal? "default" section) + (member section sections)) + allow-system) ;; account for sections and return allow-system as it might be a symbol such as return-strings + allow-system)) + ;; read a config file, returns hash table of alists ;; read a config file, returns hash table of alists ;; adds to ht if given (must be #f otherwise) ;; envion-patt is a regex spec that identifies sections that will be eval'd ;; in the environment on the fly ;; sections: #f => get all, else list of sections to gather -(define (read-config path ht allow-system #!key (environ-patt #f)(curr-section #f)(sections #f)(settings (make-hash-table))) - (debug:print-info 5 "read-config " path " allow-system " allow-system " environ-patt " environ-patt " curr-section: " curr-section " sections: " sections " pwd: " (current-directory)) - (debug:print 9 "START: " path) +;; post-section-procs alist of section-pattern => proc, where: (proc section-name next-section-name ht curr-path) +;; +(define (read-config path ht allow-system #!key (environ-patt #f)(curr-section #f)(sections #f)(settings (make-hash-table))(keep-filenames #f)(post-section-procs '())) + (debug:print-info 5 #f "read-config " path " allow-system " allow-system " environ-patt " environ-patt " curr-section: " curr-section " sections: " sections " pwd: " (current-directory)) + (debug:print 9 #f "START: " path) (if (not (file-exists? path)) (begin - (debug:print-info 1 "read-config - file not found " path " current path: " (current-directory)) + (debug:print-info 1 #f "read-config - file not found " path " current path: " (current-directory)) ;; WARNING: This is a risky change but really, we should not return an empty hash table if no file read? #f) ;; (if (not ht)(make-hash-table) ht)) (let ((inp (open-input-file path)) - (res (if (not ht)(make-hash-table) ht))) - (let loop ((inl (configf:read-line inp res allow-system settings)) ;; (read-line inp)) + (res (if (not ht)(make-hash-table) ht)) + (metapath (if (or (debug:debug-mode 9) + keep-filenames) + path #f))) + (let loop ((inl (configf:read-line inp res (calc-allow-system allow-system curr-section sections) settings)) ;; (read-line inp)) (curr-section-name (if curr-section curr-section "default")) (var-flag #f);; turn on for key-var-pr and cont-ln-rx, turn off elsewhere (lead #f)) - (debug:print-info 8 "curr-section-name: " curr-section-name " var-flag: " var-flag "\n inl: \"" inl "\"") + (debug:print-info 8 #f "curr-section-name: " curr-section-name " var-flag: " var-flag "\n inl: \"" inl "\"") (if (eof-object? inl) (begin (close-input-port inp) (hash-table-delete! res "") ;; we are using "" as a dumping ground and must remove it before returning the ht - (debug:print 9 "END: " path) + (debug:print 9 #f "END: " path) res) (regex-case inl - (configf:comment-rx _ (loop (configf:read-line inp res allow-system settings) curr-section-name #f #f)) - (configf:blank-l-rx _ (loop (configf:read-line inp res allow-system settings) curr-section-name #f #f)) + (configf:comment-rx _ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)) + (configf:blank-l-rx _ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)) (configf:settings ( x setting val ) (begin (hash-table-set! settings setting val) - (loop (configf:read-line inp res allow-system settings) curr-section-name #f #f))) + (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))) (configf:include-rx ( x include-file ) (let* ((curr-conf-dir (pathname-directory path)) (full-conf (if (absolute-pathname? include-file) include-file - (nice-path + (common:nice-path (conc (if curr-conf-dir curr-conf-dir ".") "/" include-file))))) (if (file-exists? full-conf) (begin ;; (push-directory conf-dir) - (debug:print 9 "Including: " full-conf) - (read-config full-conf res allow-system environ-patt: environ-patt curr-section: curr-section-name sections: sections settings: settings) + (debug:print 9 #f "Including: " full-conf) + (read-config full-conf res allow-system environ-patt: environ-patt curr-section: curr-section-name sections: sections settings: settings keep-filenames: keep-filenames) ;; (pop-directory) - (loop (configf:read-line inp res allow-system settings) curr-section-name #f #f)) + (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)) (begin - (debug:print '(2 9) "INFO: include file " include-file " not found (called from " path ")") - (debug:print 2 " " full-conf) - (loop (configf:read-line inp res allow-system settings) curr-section-name #f #f))))) - (configf:section-rx ( x section-name ) (loop (configf:read-line inp res allow-system settings) - ;; if we have the sections list then force all settings into "" and delete it later? - (if (or (not sections) - (member section-name sections)) - section-name "") ;; stick everything into "" - #f #f)) - (configf:key-sys-pr ( x key cmd ) (if allow-system - (let ((alist (hash-table-ref/default res curr-section-name '())) + (debug:print '(2 9) #f "INFO: include file " include-file " not found (called from " path ")") + (debug:print 2 #f " " full-conf) + (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))))) + (configf:section-rx ( x section-name ) (begin + ;; call post-section-procs + (for-each + (lambda (dat) + (let ((patt (car dat)) + (proc (cdr dat))) + (if (string-match patt curr-section-name) + (proc curr-section-name section-name res path)))) + post-section-procs) + (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) + ;; if we have the sections list then force all settings into "" and delete it later? + (if (or (not sections) + (member section-name sections)) + section-name "") ;; stick everything into "" + #f #f))) + (configf:key-sys-pr ( x key cmd ) (if (calc-allow-system allow-system curr-section-name sections) + (let ((alist (hash-table-ref/default res curr-section-name '())) (val-proc (lambda () - (let* ((cmdres (cmd-run->list cmd)) - (status (cadr cmdres)) - (res (car cmdres))) - (debug:print-info 4 "" inl "\n => " (string-intersperse res "\n")) + (let* ((start-time (current-seconds)) + (cmdres (process:cmd-run->list cmd)) + (delta (- (current-seconds) start-time)) + (status (cadr cmdres)) + (res (car cmdres))) + (debug:print-info 4 #f "" inl "\n => " (string-intersperse res "\n")) (if (not (eq? status 0)) (begin - (debug:print 0 "ERROR: problem with " inl ", return code " status - " output: " cmdres) - (exit 1))) + (debug:print 0 #f "ERROR: problem with " inl ", return code " status + " output: " cmdres))) + (if (> delta 2) + (debug:print-info 0 #f "for line \"" inl "\"\n command: " cmd " took " delta " seconds to run with output:\n " res) + (debug:print-info 9 #f "for line \"" inl "\"\n command: " cmd " took " delta " seconds to run with output:\n " res)) (if (null? res) "" (string-intersperse res " ")))))) (hash-table-set! res curr-section-name (config:assoc-safe-add alist key - (case allow-system + (case (calc-allow-system allow-system curr-section-name sections) ((return-procs) val-proc) ((return-string) cmd) - (else (val-proc))))) - (loop (configf:read-line inp res allow-system settings) curr-section-name #f #f)) - (loop (configf:read-line inp res allow-system settings) curr-section-name #f #f))) + (else (val-proc))) + metadata: metapath)) + (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)) + (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))) + (configf:key-no-val ( x key val) (let* ((alist (hash-table-ref/default res curr-section-name '())) + (fval (or (if (string? val) val #f) ""))) ;; fval should be either "" or " " (one or more spaces) + (debug:print 10 #f " setting: [" curr-section-name "] " key " = #t") + (safe-setenv key fval) + (hash-table-set! res curr-section-name + (config:assoc-safe-add alist key fval metadata: metapath)) + (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name key #f))) (configf:key-val-pr ( x key unk1 val unk2 ) (let* ((alist (hash-table-ref/default res curr-section-name '())) (envar (and environ-patt (string-search (regexp environ-patt) curr-section-name))) (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 (safe-setenv key realval)) - (debug:print 10 " setting: [" curr-section-name "] " key " = " val) - (hash-table-set! res curr-section-name - (config:assoc-safe-add alist key realval)) - (loop (configf:read-line inp res allow-system settings) curr-section-name key #f))) - (configf:key-no-val ( x key val) (let* ((alist (hash-table-ref/default res curr-section-name '()))) - (debug:print 10 " setting: [" curr-section-name "] " key " = #t") - (hash-table-set! res curr-section-name - (config:assoc-safe-add alist key #t)) - (loop (configf:read-line inp res allow-system settings) curr-section-name key #f))) + (debug:print-info 6 #f "read-config env setting, envar: " envar " realval: " realval " val: " val " key: " key " curr-section-name: " curr-section-name) + (if envar (safe-setenv key realval)) + (debug:print 10 #f " setting: [" curr-section-name "] " key " = " val) + (hash-table-set! res curr-section-name + (config:assoc-safe-add alist key realval metadata: metapath)) + (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name key #f))) ;; if a continued line (configf:cont-ln-rx ( x whsp val ) (let ((alist (hash-table-ref/default res curr-section-name '()))) (if var-flag ;; if set to a string then we have a continued var (let ((newval (conc (config-lookup res curr-section-name var-flag) "\n" @@ -263,26 +302,32 @@ (string-substitute (regexp lead) "" whsp) "") val))) ;; (print "val: " val "\nnewval: \"" newval "\"\nvarflag: " var-flag) (hash-table-set! res curr-section-name - (config:assoc-safe-add alist var-flag newval)) - (loop (configf:read-line inp res allow-system settings) curr-section-name var-flag (if lead lead whsp))) - (loop (configf:read-line inp res allow-system settings) curr-section-name #f #f)))) - (else (debug:print 0 "ERROR: problem parsing " path ",\n \"" inl "\"") + (config:assoc-safe-add alist var-flag newval metadata: metapath)) + (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name var-flag (if lead lead whsp))) + (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)))) + (else (debug:print 0 #f "ERROR: problem parsing " path ",\n \"" inl "\"") (set! var-flag #f) - (loop (configf:read-line inp res allow-system settings) curr-section-name #f #f)))))))) + (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)))))))) ;; pathenvvar will set the named var to the path of the config (define (find-and-read-config fname #!key (environ-patt #f)(given-toppath #f)(pathenvvar #f)) (let* ((curr-dir (current-directory)) (configinfo (find-config fname toppath: given-toppath)) (toppath (car configinfo)) - (configfile (cadr configinfo))) + (configfile (cadr configinfo)) + (set-fields (lambda (curr-section next-section ht path) + (let ((field-names (if ht (keys:config-get-fields ht) '())) + (target (or (getenv "MT_TARGET")(args:get-arg "-reqtarg")(args:get-arg "-target")))) + (debug:print-info 9 #f "set-fields with field-names=" field-names " target=" target " curr-section=" curr-section " next-section=" next-section " path=" path " ht=" ht) + (if (not (null? field-names))(keys:target-set-args field-names target #f)))))) (if toppath (change-directory toppath)) (if (and toppath pathenvvar)(setenv pathenvvar toppath)) - (let ((configdat (if configfile (read-config configfile #f #t environ-patt: environ-patt) #f))) ;; (make-hash-table)))) + (let ((configdat (if configfile + (read-config configfile #f #t environ-patt: environ-patt post-section-procs: (list (cons "^fields$" set-fields)) #f)))) (if toppath (change-directory curr-dir)) (list configdat toppath configfile fname)))) (define (config-lookup cfgdat section var) (if (hash-table? cfgdat) @@ -422,13 +467,13 @@ (set! new #f)) ((not (equal? newval val)) (hash-table-set! sechash key newval) (set! new (conc key " " newval))) (else - (debug:print 0 "ERROR: problem parsing line number " lnum "\"" hed "\""))))) + (debug:print 0 #f "ERROR: problem parsing line number " lnum "\"" hed "\""))))) (else - (debug:print 0 "ERROR: Problem parsing line num " lnum " :\n " hed ))) + (debug:print 0 #f "ERROR: Problem parsing line num " lnum " :\n " hed ))) (if (not (null? tal)) (loop (car tal)(cdr tal)(if new (append res (list new)) res)(+ lnum 1))) ;; drop to here when done processing, res contains modified list of lines (set! fdat res))) @@ -534,5 +579,22 @@ (define (configf:write-alist cdat fname) (with-output-to-file fname (lambda () (pp (configf:config->alist cdat))))) + +;; convert hierarchial list to ini format +;; +(define (configf:config->ini data) + (map + (lambda (section) + (let ((section-name (car section)) + (section-dat (cdr section))) + (print "\n[" section-name "]") + (map (lambda (dat-pair) + (let* ((var (car dat-pair)) + (val (cadr dat-pair)) + (fname (if (> (length dat-pair) 2)(caddr dat-pair) #f))) + (if fname (print "# " var "=>" fname)) + (print var " " val))) + section-dat))) ;; (print "section-dat: " section-dat)) + (hash-table->alist data))) Index: dashboard-tests.scm ================================================================== --- dashboard-tests.scm +++ dashboard-tests.scm @@ -194,16 +194,16 @@ (apply iup:vbox ; #:expand "YES" ;; The heading labels (append (map (lambda (val) (iup:label val ; #:expand "HORIZONTAL" )) (list "Hostname: " - "Uname -a: " "Disk free: " "CPU Load: " "Run duration: " "Logfile: " - "Top process id: ")) + "Top process id: " + "Uname -a: ")) (iup:label "" #:expand "VERTICAL"))) (apply iup:vbox ; #:expand "YES" (list ;; NOTE: Yes, the host can change! (store-label "HostName" @@ -235,11 +235,11 @@ ;; if there is a submegatest create a button to launch dashboard in that area ;; (define (submegatest-panel dbstruct keydat testdat runname testconfig) (let* ((subarea (configf:lookup testconfig "setup" "submegatest")) (area-exists (and subarea (file-exists? subarea)))) - (debug:print-info 0 "Megatest subarea=" subarea ", area-exists=" area-exists) + ;; (debug:print-info 0 #f "Megatest subarea=" subarea ", area-exists=" area-exists) (if subarea (iup:frame #:title "Megatest Run Info" ; #:expand "YES" (iup:button "Launch Dashboard" @@ -418,22 +418,22 @@ ;;====================================================================== (define (examine-test run-id test-id) ;; run-id run-key origtest) (let* ((db-path (db:dbfile-path run-id)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/db/" run-id ".db")) (dbstruct (make-dbr:dbstruct path: (db:dbfile-path #f) ;; (configf:lookup *configdat* "setup" "linktree") local: #t)) - (testdat (db:get-test-info-by-id dbstruct run-id test-id)) + (testdat (rmt:get-test-info-by-id run-id test-id)) ;; (db:get-test-info-by-id dbstruct run-id test-id)) (db-mod-time 0) ;; (file-modification-time db-path)) (last-update 0) ;; (current-seconds)) (request-update #t)) (if (not testdat) (begin - (debug:print 2 "ERROR: No test data found for test " test-id ", exiting") + (debug:print 2 #f "ERROR: No test data found for test " test-id ", exiting") (exit 1)) (let* (;; (run-id (if testdat (db:test-get-run_id testdat) #f)) (test-registry (tests:get-all)) - (keydat (if testdat (db:get-key-val-pairs dbstruct run-id) #f)) - (rundat (if testdat (db:get-run-info dbstruct run-id) #f)) + (keydat (if testdat (rmt:get-key-val-pairs run-id) #f)) + (rundat (if testdat (rmt:get-run-info run-id) #f)) (runname (if testdat (db:get-value-by-header (db:get-rows rundat) (db:get-header rundat) "runname") #f)) ;; (tdb (tdb:open-test-db-by-test-id-local dbstruct run-id test-id)) ;; These next two are intentional bad values to ensure errors if they should not @@ -441,16 +441,16 @@ (logfile "/this/dir/better/not/exist") (rundir (if testdat (db:test-get-rundir testdat) logfile)) ;; (testdat-path (conc rundir "/testdat.db")) ;; this gets recalculated until found - (teststeps (if testdat (tests:get-compressed-steps dbstruct run-id test-id) '())) + (teststeps (if testdat (tests:get-compressed-steps run-id test-id) '())) (testfullname (if testdat (db:test-get-fullname testdat) "Gathering data ...")) (testname (if testdat (db:test-get-testname testdat) "n/a")) ;; (tests:get-testconfig testdat testname 'return-procs)) (testmeta (if testdat - (let ((tm (db:testmeta-get-record dbstruct testname))) + (let ((tm (rmt:testmeta-get-record testname))) (if tm tm (make-db:testmeta))) (make-db:testmeta))) (keystring (string-intersperse (map (lambda (keyval) @@ -471,11 +471,11 @@ (testconfig (begin ;; (runs:set-megatest-env-vars run-id inrunname: runname testname: test-name itempath: item-path) (runs:set-megatest-env-vars run-id inkeyvals: keydat inrunname: runname intarget: keystring testname: testname itempath: item-path) ;; these may be needed by the launching process (handle-exceptions exn - #f + (tests:get-testconfig (db:test-get-testname testdat) test-registry #f) (tests:get-testconfig (db:test-get-testname testdat) test-registry #t)))) (viewlog (lambda (x) (if (file-exists? logfile) ;(system (conc "firefox " logfile "&")) (dashboard-tests:run-html-viewer logfile) @@ -511,22 +511,22 @@ request-update)) (newtestdat (if need-update ;; NOTE: BUG HIDER, try to eliminate this exception handler (handle-exceptions exn - (debug:print-info 0 "test db access issue in examine test for run-id " run-id ", test-id " test-id ": " ((condition-property-accessor 'exn 'message) exn)) - (db:get-test-info-by-id dbstruct run-id test-id ))))) - ;; (debug:print-info 0 "need-update= " need-update " curr-mod-time = " curr-mod-time) + (debug:print-info 0 #f "test db access issue in examine test for run-id " run-id ", test-id " test-id ": " ((condition-property-accessor 'exn 'message) exn)) + (rmt:get-test-info-by-id run-id test-id ))))) + ;; (debug:print-info 0 #f "need-update= " need-update " curr-mod-time = " curr-mod-time) (cond ((and need-update newtestdat) (set! testdat newtestdat) - (set! teststeps (tests:get-compressed-steps dbstruct run-id test-id)) + (set! teststeps (tests:get-compressed-steps run-id test-id)) (set! logfile (conc (db:test-get-rundir testdat) "/" (db:test-get-final_logf testdat))) (set! rundir ;; (filedb:get-path *fdb* (db:test-get-rundir testdat)) ;; ) (set! testfullname (db:test-get-fullname testdat)) - ;; (debug:print 0 "INFO: teststeps=" (intersperse teststeps "\n ")) + ;; (debug:print 0 #f "INFO: teststeps=" (intersperse teststeps "\n ")) ;; I don't see why this was implemented this way. Please comment it ... ;; (if (eq? curr-mod-time db-mod-time) ;; do only once if same ;; (set! db-mod-time (+ curr-mod-time 1)) ;; (set! db-mod-time curr-mod-time)) @@ -579,11 +579,11 @@ (command-proc (lambda (command-text-box) (let* ((cmd (iup:attribute command-text-box "VALUE")) (fullcmd (conc (dtests:get-pre-command) cmd (dtests:get-post-command)))) - (debug:print-info 02 "Running command: " fullcmd) + (debug:print-info 02 #f "Running command: " fullcmd) (common:without-vars fullcmd "MT_.*")))) (command-text-box (iup:textbox #:expand "HORIZONTAL" #:font "Courier New, -10" #:action (lambda (obj cnum val) @@ -596,11 +596,11 @@ ;; (lambda (x) ;; (let* ((cmd (iup:attribute command-text-box "VALUE")) ;; (fullcmd (conc (dtests:get-pre-command) ;; cmd ;; (dtests:get-post-command)))) - ;; (debug:print-info 02 "Running command: " fullcmd) + ;; (debug:print-info 02 #f "Running command: " fullcmd) ;; (common:without-vars fullcmd "MT_.*"))))) (kill-jobs (lambda (x) (iup:attribute-set! command-text-box "VALUE" (conc "megatest -target " keystring " -runname " runname @@ -611,10 +611,11 @@ command-text-box "VALUE" (conc "megatest -target " keystring " -runname " runname " -run -testpatt " (conc testname "/" (if (equal? item-path "") "%" item-path)) + " -clean-cache" )))) (remove-test (lambda (x) (iup:attribute-set! command-text-box "VALUE" (conc "megatest -remove-runs -target " keystring " -runname " runname @@ -629,10 +630,11 @@ item-path)) ";megatest -target " keystring " -runname " runname " -run -preclean -testpatt " (conc testname "/" (if (equal? item-path "") "%" item-path)) + " -clean-cache" ))) (common:without-vars (conc (dtests:get-pre-command) cmd (dtests:get-post-command)) @@ -691,13 +693,13 @@ ;; Replace here with matrix (let ((steps-matrix (iup:matrix #:font "Courier New, -8" #:expand "YES" #:scrollbar "YES" - #:numcol 6 - #:numlin 30 - #:numcol-visible 6 + #:numcol 7 + #:numlin 100 + #:numcol-visible 7 #:numlin-visible 5 #:click-cb (lambda (obj lin col status) ;; (if (equal? col 6) (let* ((mtrx-rc (conc lin ":" 6)) (fname (iup:attribute obj mtrx-rc))) ;; col)))) @@ -718,10 +720,11 @@ (iup:attribute-set! steps-matrix "WIDTH3" "50") (iup:attribute-set! steps-matrix "0:4" "Status") (iup:attribute-set! steps-matrix "WIDTH4" "50") (iup:attribute-set! steps-matrix "0:5" "Duration") (iup:attribute-set! steps-matrix "0:6" "Log File") + (iup:attribute-set! steps-matrix "0:7" "Comment") (iup:attribute-set! steps-matrix "ALIGNMENT1" "ALEFT") ;; (iup:attribute-set! steps-matrix "FIXTOTEXT" "C1") (iup:attribute-set! steps-matrix "RESIZEMATRIX" "YES") (let ((proc (lambda (testdat) @@ -740,11 +743,11 @@ #:font "Courier New, -10" #:size "100x100"))) (hash-table-set! widgets "Test Data" (lambda (testdat) ;; (let* ((currval (iup:attribute test-data "VALUE")) ;; "TITLE")) - (fmtstr "~10a~10a~10a~10a~7a~7a~6a~6a~a") ;; category,variable,value,expected,tol,units,type,comment + (fmtstr "~10a~10a~10a~10a~7a~7a~6a~7a~a") ;; category,variable,value,expected,tol,units,type,comment (newval (string-intersperse (append (list (format #f fmtstr "Category" "Variable" "Value" "Expected" "Tol" "Status" "Units" "Type" "Comment") (format #f fmtstr "========" "========" "=====" "========" "===" "======" "=====" "====" "=======")) @@ -757,11 +760,11 @@ (db:test-data-get-tol x) (db:test-data-get-status x) (db:test-data-get-units x) (db:test-data-get-type x) (db:test-data-get-comment x))) - (db:read-test-data dbstruct run-id test-id "%"))) + (rmt:read-test-data run-id test-id "%"))) "\n"))) (if (not (equal? currval newval)) (iup:attribute-set! test-data "VALUE" newval ))))) ;; "TITLE" newval))))) test-data)) ;;(dashboard:run-controls) Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -1,7 +1,7 @@ ;;====================================================================== -;; Copyright 2006-2012, Matthew Welland. +;; Copyright 2006-2016, 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 @@ -14,11 +14,11 @@ (import (prefix iup iup:)) (use canvas-draw) (import canvas-draw-iup) -(use sqlite3 srfi-1 posix regex regex-case srfi-69) +(use sqlite3 srfi-1 posix regex regex-case srfi-69 defstruct sparse-vectors) (import (prefix sqlite3 sqlite3:)) (declare (uses common)) (declare (uses margs)) (declare (uses keys)) @@ -41,13 +41,13 @@ (include "db_records.scm") (include "run_records.scm") (include "megatest-fossil-hash.scm") (define help (conc -"Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest + "Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest version " megatest-version " - license GPL, Copyright (C) Matt Welland 2012-2014 + license GPL, Copyright (C) Matt Welland 2012-2016 Usage: dashboard [options] -h : this help -server host:port : connect to host:port instead of db access -test run-id,test-id : control test identified by testid @@ -71,77 +71,177 @@ "-use-server" "-guimonitor" "-main" "-v" "-q" - ) + "-use-local" + ) args:arg-hash 0)) (if (args:get-arg "-h") (begin (print help) (exit))) -(if (not (launch:setup-for-run)) +(if (not (launch:setup)) (begin (print "Failed to find megatest.config, exiting") (exit 1))) -(define *useserver* (or (args:get-arg "-use-server") - (configf:lookup *configdat* "dashboard" "use-server"))) +;; create a stuct for all the miscellaneous state +;; +(defstruct d:alldat + allruns + allruns-by-id + buttondat + curr-tab-num + dbdir + dbfpath + dbkeys + dblocal + filters-changed + header + hide-empty-runs + hide-not-hide ;; toggle for hide/not hide + hide-not-hide-button + hide-not-hide-tabs + item-test-names + keys + last-db-update + num-tests + numruns + please-update + ro + searchpatts + start-run-offset + start-test-offset + state-ignore-hash + status-ignore-hash + tot-runs + update-mutex + updaters + updating + useserver + ) -(define *dbdir* (db:dbfile-path #f)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db")) -(define *dbstruct-local* (make-dbr:dbstruct path: *dbdir* - local: #t)) -(define *db-file-path* (db:dbfile-path 0)) +(define *alldat* (make-d:alldat + header: #f + allruns: '() + allruns-by-id: (make-hash-table) + buttondat: (make-hash-table) + searchpatts: (make-hash-table) + numruns: 16 + last-db-update: 0 + please-update: #t + updating: #f + update-mutex: (make-mutex) + item-test-names: '() + num-tests: 15 + start-run-offset: 0 + start-test-offset: 0 + status-ignore-hash: (make-hash-table) + state-ignore-hash: (make-hash-table) + hide-empty-runs: #f + hide-not-hide: #t + hide-not-hide-button: #f + hide-not-hide-tabs: #f + curr-tab-num: 0 + updaters: (make-hash-table) + filters-changed: #f + )) + +;; data for runs, tests etc +;; +(defstruct d:rundat + ;; new system + runs-index ;; target/runname => colnum + tests-index ;; testname/itempath => rownum + matrix-dat ;; vector of vectors rows/cols + ) + +(define (d:rundat-make-init) + (make-d:rundat + runs-index: (make-hash-table) + tests-index: (make-hash-table) + matrix-dat: (make-sparse-array))) + +(defstruct d:testdat + id ;; testid + state ;; test state + status ;; test status + ) + +(define (d:rundat-get-col-num dat target runname force-set) + (let* ((runs-index (d:rundat-runs-index dat)) + (col-name (conc target "/" runname)) + (res (hash-table-ref/default runs-index col-name #f))) + (if res + res + (if force-set + (let ((max-col-num (+ 1 (apply max -1 (hash-table-values runs-index))))) + (hash-table-set! runs-index col-name max-col-num) + max-col-num))))) + +(define (d:rundat-get-row-num dat testname itempath force-set) + (let* ((tests-index (d:rundat-runs-index dat)) + (row-name (conc testname "/" itempath)) + (res (hash-table-ref/default runs-index row-name #f))) + (if res + res + (if force-set + (let ((max-row-num (+ 1 (apply max -1 (hash-table-values tests-index))))) + (hash-table-set! runs-index row-name max-row-num) + max-row-num))))) + +;; default is to NOT set the cell if the column and row names are not pre-existing +;; +(define (d:rundat-set-test-cell dat target runname testname itempath test-id state status #!key (force-set #f)) + (let* ((col-num (d:rundat-get-col-num dat target runname force-set)) + (row-num (d:rundat-get-row-num dat testname itempath force-set))) + (if (and row-num col-num) + (let ((tdat (d:testdat + id: test-id + state: state + status: status))) + (sparse-array-set! (d:rundat-matrix-dat dat) col-num row-num tdat) + tdat) + #f))) + + + + + +(d:alldat-useserver-set! *alldat* (cond + ((args:get-arg "-use-local") #f) + ((configf:lookup *configdat* "dashboard" "use-server") + (let ((ans (config:lookup *configdat* "dashboard" "use-server"))) + (if (equal? ans "yes") #t #f))) + (else #t))) +(define *dashboard-mode* (string->symbol (or (configf:lookup *configdat* "dashboard" "mode") "dashboard"))) + +(d:alldat-dbdir-set! *alldat* (db:dbfile-path #f)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db")) +(d:alldat-dblocal-set! *alldat* (make-dbr:dbstruct path: (d:alldat-dbdir *alldat*) + local: #t)) +(d:alldat-dbfpath-set! *alldat* (db:dbfile-path 0)) ;; HACK ALERT: this is a hack, please fix. -(define *read-only* (not (file-read-access? *db-file-path*))) - -(define toplevel #f) -(define dlg #f) -(define max-test-num 0) -(define *keys* (if *useserver* - (rmt:get-keys) - (db:get-keys *dbstruct-local*))) - -(define *dbkeys* (append *keys* (list "runname"))) - -(define *header* #f) -(define *allruns* '()) -(define *allruns-by-id* (make-hash-table)) ;; -(define *runchangerate* (make-hash-table)) - -(define *buttondat* (make-hash-table)) ;; -(define *alltestnamelst* '()) -(define *searchpatts* (make-hash-table)) -(define *num-runs* 8) -(define *tot-run-count* (if *useserver* - (rmt:get-num-runs "%") - (db:get-num-runs *dbstruct-local* "%"))) - -;; (define *tot-run-count* (db:get-num-runs *dbstruct-local* "%")) - -;; Update management -;; -(define *last-update* (current-seconds)) -(define *last-db-update-time* 0) -(define *please-update-buttons* #t) -(define *delayed-update* 0) -(define *update-is-running* #f) -(define *update-mutex* (make-mutex)) - -(define *all-item-test-names* '()) -(define *num-tests* 15) -(define *start-run-offset* 0) -(define *start-test-offset* 0) -(define *examine-test-dat* (make-hash-table)) +(d:alldat-ro-set! *alldat* (not (file-read-access? (d:alldat-dbfpath *alldat*)))) + +(d:alldat-keys-set! *alldat* (if (d:alldat-useserver *alldat*) + (rmt:get-keys) + (db:get-keys (d:alldat-dblocal *alldat*)))) +(d:alldat-dbkeys-set! *alldat* (append (d:alldat-keys *alldat*) (list "runname"))) +(d:alldat-tot-runs-set! *alldat* (if (d:alldat-useserver *alldat*) + (rmt:get-num-runs "%") + (db:get-num-runs (d:alldat-dblocal *alldat*) "%"))) +;; (define *exit-started* #f) -(define *status-ignore-hash* (make-hash-table)) -(define *state-ignore-hash* (make-hash-table)) +;; *updaters* (make-hash-table)) +;; sorting global data (would apply to many testsuites so leave it global for now) +;; (define *tests-sort-options* (vector (vector "Sort +a" 'testname "ASC") (vector "Sort -a" 'testname "DESC") (vector "Sort +t" 'event_time "ASC") (vector "Sort -t" 'event_time "DESC") (vector "Sort +s" 'statestatus "ASC") @@ -169,18 +269,10 @@ 3))) (define (get-curr-sort) (vector-ref *tests-sort-options* *tests-sort-reverse*)) -(define *hide-empty-runs* #f) -(define *hide-not-hide* #t) ;; toggle for hide/not hide -(define *hide-not-hide-button* #f) -(define *hide-not-hide-tabs* #f) - -(define *current-tab-number* 0) -(define *updaters* (make-hash-table)) - (debug:setup) (define uidat #f) (define-inline (dboard:uidat-get-keycol vec)(vector-ref vec 0)) @@ -214,91 +306,141 @@ (let* ((c1 (map string->number (string-split color1))) (c2 (map string->number (string-split color2))) (delta (map (lambda (a b)(abs (- a b))) c1 c2))) (null? (filter (lambda (x)(> x 3)) delta)))) -;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") ) -(define (update-rundat runnamepatt numruns testnamepatt keypatts) - (let* ((referenced-run-ids '()) - (allruns (if *useserver* - (rmt:get-runs runnamepatt numruns *start-run-offset* keypatts) - (db:get-runs *dbstruct-local* runnamepatt numruns ;; (+ numruns 1) ;; (/ numruns 2)) - *start-run-offset* keypatts))) - (header (db:get-header allruns)) - (runs (db:get-rows allruns)) - (result '()) - (maxtests 0) - (states (hash-table-keys *state-ignore-hash*)) - (statuses (hash-table-keys *status-ignore-hash*)) +(define (dboard:compare-tests test1 test2) + (let* ((test-name1 (db:test-get-testname test1)) + (item-path1 (db:test-get-item-path test1)) + (eventtime1 (db:test-get-event_time test1)) + (test-name2 (db:test-get-testname test2)) + (item-path2 (db:test-get-item-path test2)) + (eventtime2 (db:test-get-event_time test2)) + (same-name (equal? test-name1 test-name2)) + (test1-top (equal? item-path1 "")) + (test2-top (equal? item-path2 "")) + (test1-older (> eventtime1 eventtime2)) + (same-time (equal? eventtime1 eventtime2))) + (if same-name + (if same-time + (string>? item-path1 item-path2) + test1-older) + (if same-time + (string>? test-name1 test-name2) + test1-older)))) + +;; This is roughly the same as dboard:get-tests-dat, should merge them if possible +;; +(define (dboard:get-tests-for-run-duplicate data run-id run testnamepatt key-vals) + (let* ((states (hash-table-keys (d:alldat-state-ignore-hash data))) + (statuses (hash-table-keys (d:alldat-status-ignore-hash data))) (sort-info (get-curr-sort)) (sort-by (vector-ref sort-info 1)) (sort-order (vector-ref sort-info 2)) (bubble-type (if (member sort-order '(testname)) 'testname - 'itempath))) + 'itempath)) + (prev-dat (let ((rec (hash-table-ref/default (d:alldat-allruns-by-id data) run-id #f))) + (if rec rec (vector run '() key-vals -100)))) ;; -100 is before time began + (prev-tests (vector-ref prev-dat 1)) + (last-update (vector-ref prev-dat 3)) + (tmptests (if (d:alldat-useserver data) + (rmt:get-tests-for-run run-id testnamepatt states statuses + #f #f + (d:alldat-hide-not-hide data) + sort-by + sort-order + 'shortlist + (if (d:alldat-filters-changed data) + 0 + last-update) + *dashboard-mode*) ;; use dashboard mode + (db:get-tests-for-run (d:alldat-dblocal data) run-id testnamepatt states statuses + #f #f + (d:alldat-hide-not-hide data) + sort-by + sort-order + 'shortlist + (if (d:alldat-filters-changed data) + 0 + last-update) + *dashboard-mode*))) + (tests (let ((newdat (filter + (lambda (x) + (not (equal? (db:test-get-state x) "DELETED"))) ;; remove deleted tests but do it after merging + (delete-duplicates (if (d:alldat-filters-changed data) + tmptests + (append tmptests prev-tests)) + (lambda (a b) + (eq? (db:test-get-id a)(db:test-get-id b))))))) + (if (eq? *tests-sort-reverse* 3) ;; +event_time + (sort newdat dboard:compare-tests) + newdat)))) + (vector-set! prev-dat 3 (- (current-seconds) 2)) ;; go back two seconds in time to ensure all changes are captured. + ;; (debug:print 0 #f "(dboard:get-tests-for-run-duplicate: filters-changed=" (d:alldat-filters-changed data) " last-update=" last-update " got " (length tmptests) " test records for run " run-id) + tests)) + +;; create a virtual table of all the tests +;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") ) +(define (update-rundat data runnamepatt numruns testnamepatt keypatts) + (let* ((referenced-run-ids '()) + (allruns (if (d:alldat-useserver data) + (rmt:get-runs runnamepatt numruns (d:alldat-start-run-offset data) keypatts) + (db:get-runs (d:alldat-dblocal data) runnamepatt numruns ;; (+ numruns 1) ;; (/ numruns 2)) + (d:alldat-start-run-offset data) keypatts))) + (header (db:get-header allruns)) + (runs (db:get-rows allruns)) + (result '()) + (maxtests 0)) ;; ;; trim runs to only those that are changing often here ;; (for-each (lambda (run) (let* ((run-id (db:get-value-by-header run header "id")) - (tests (if *useserver* - (rmt:get-tests-for-run run-id testnamepatt states statuses - #f #f - *hide-not-hide* - sort-by - sort-order - 'shortlist) - (db:get-tests-for-run *dbstruct-local* run-id testnamepatt states statuses - #f #f - *hide-not-hide* - sort-by - sort-order - 'shortlist))) - ;; NOTE: bubble-up also sets the global *all-item-test-names* - ;; (tests (bubble-up tmptests priority: bubble-type)) - (key-vals (if *useserver* + (key-vals (if (d:alldat-useserver data) (rmt:get-key-vals run-id) - (db:get-key-vals *dbstruct-local* run-id)))) + (db:get-key-vals (d:alldat-dblocal data) run-id))) + (tests (dboard:get-tests-for-run-duplicate data run-id run testnamepatt key-vals))) + ;; NOTE: bubble-up also sets the global (d:alldat-item-test-names data) + ;; (tests (bubble-up tmptests priority: bubble-type)) ;; NOTE: 11/01/2013 This routine is *NOT* getting called excessively. - ;; (debug:print 0 "Getting data for run " run-id " with key-vals=" key-vals) + ;; (debug:print 0 #f "Getting data for run " run-id " with key-vals=" key-vals) ;; Not sure this is needed? - (set! referenced-run-ids (cons run-id referenced-run-ids)) - (if (> (length tests) maxtests) - (set! maxtests (length tests))) - (if (or (not *hide-empty-runs*) ;; this reduces the data burden when set - (not (null? tests))) - (let ((dstruct (vector run tests key-vals))) - ;; - ;; compare the tests with the tests in *allruns-by-id* same run-id - ;; if different then increment value in *runchangerate* - ;; - (hash-table-set! *allruns-by-id* run-id dstruct) - (set! result (cons dstruct result)))))) + (if (not (null? tests)) + (begin + (set! referenced-run-ids (cons run-id referenced-run-ids)) + (if (> (length tests) maxtests) + (set! maxtests (length tests))) + (if (or (not (d:alldat-hide-empty-runs data)) ;; this reduces the data burden when set + (not (null? tests))) + (let ((dstruct (vector run tests key-vals (- (current-seconds) 10)))) + (hash-table-set! (d:alldat-allruns-by-id data) run-id dstruct) + (set! result (cons dstruct result)))))))) runs) - (set! *header* header) - (set! *allruns* result) - (debug:print-info 6 "*allruns* has " (length *allruns*) " runs") + (d:alldat-header-set! data header) + (d:alldat-allruns-set! data result) + (debug:print-info 6 #f "(d:alldat-allruns data) has " (length (d:alldat-allruns data)) " runs") maxtests)) (define *collapsed* (make-hash-table)) -; (define *row-lookup* (make-hash-table)) ;; testname => (rownum lableobj) + ; (define *row-lookup* (make-hash-table)) ;; testname => (rownum lableobj) (define (toggle-hide lnum) ; fulltestname) (let* ((btn (vector-ref (dboard:uidat-get-lftcol uidat) lnum)) (fulltestname (iup:attribute btn "TITLE")) (parts (string-split fulltestname "(")) (basetestname (if (null? parts) "" (car parts)))) - ;(print "Toggling " basetestname " currently " (hash-table-ref/default *collapsed* basetestname #f)) + ;(print "Toggling " basetestname " currently " (hash-table-ref/default *collapsed* basetestname #f)) (if (hash-table-ref/default *collapsed* basetestname #f) (begin - ;(iup:attribute-set! btn "FGCOLOR" "0 0 0") + ;(iup:attribute-set! btn "FGCOLOR" "0 0 0") (hash-table-delete! *collapsed* basetestname)) (begin - ;(iup:attribute-set! btn "FGCOLOR" "0 192 192") + ;(iup:attribute-set! btn "FGCOLOR" "0 192 192") (hash-table-set! *collapsed* basetestname #t))))) - + (define blank-line-rx (regexp "^\\s*$")) (define (run-item-name->vectors lst) (map (lambda (x) (let ((splst (string-split x "(")) @@ -333,11 +475,11 @@ (map (lambda (x) (if (equal? (vector-ref x 1) "") (vector-ref x 0) (conc (vector-ref x 0) "(" (vector-ref x 1) ")"))) vlst2))) - + (define (update-labels uidat) (let* ((rown 0) (keycol (dboard:uidat-get-keycol uidat)) (lftcol (dboard:uidat-get-lftcol uidat)) (numcols (vector-length lftcol)) @@ -403,30 +545,30 @@ (hash-table-set! tests tname (cons testdat (hash-table-ref/default tests tname '()))) ;; This is item, append it (hash-table-set! tests tname (append (hash-table-ref/default tests tname '())(list testdat)))))) test-dats) ;; Set all tests with items - (set! *all-item-test-names* (append (if (null? tnames) - '() - (filter (lambda (tname) - (let ((tlst (hash-table-ref tests tname))) - (and (list tlst) - (> (length tlst) 1)))) - tnames)) - *all-item-test-names*)) + (d:alldat-item-test-names-set! *alldat* (append (if (null? tnames) + '() + (filter (lambda (tname) + (let ((tlst (hash-table-ref tests tname))) + (and (list tlst) + (> (length tlst) 1)))) + tnames)) + (d:alldat-item-test-names *alldat*))) (let loop ((hed (car tnames)) (tal (cdr tnames)) (res '())) (let ((newres (append res (hash-table-ref tests hed)))) (if (null? tal) newres (loop (car tal)(cdr tal) newres)))))))) - + (define (update-buttons uidat numruns numtests) - (let* ((runs (if (> (length *allruns*) numruns) - (take-right *allruns* numruns) - (pad-list *allruns* numruns))) + (let* ((runs (if (> (length (d:alldat-allruns *alldat*)) numruns) + (take-right (d:alldat-allruns *alldat*) numruns) + (pad-list (d:alldat-allruns *alldat*) numruns))) (lftcol (dboard:uidat-get-lftcol uidat)) (tableheader (dboard:uidat-get-header uidat)) (table (dboard:uidat-get-runsvec uidat)) (coln 0)) (set! *alltestnamelst* '()) @@ -434,36 +576,36 @@ (for-each (lambda (rundat) (if (vector? rundat) (let* ((testdat (vector-ref rundat 1)) (testnames (map test:test-get-fullname testdat))) - (if (not (and *hide-empty-runs* + (if (not (and (d:alldat-hide-empty-runs *alldat*) (null? testnames))) (for-each (lambda (testname) (if (not (member testname *alltestnamelst*)) (begin (set! *alltestnamelst* (append *alltestnamelst* (list testname)))))) testnames))))) runs) (set! *alltestnamelst* (collapse-rows *alltestnamelst*)) ;;; argh. please clean up this sillyness - (set! *alltestnamelst* (let ((xl (if (> (length *alltestnamelst*) *start-test-offset*) - (drop *alltestnamelst* *start-test-offset*) + (set! *alltestnamelst* (let ((xl (if (> (length *alltestnamelst*) (d:alldat-start-test-offset *alldat*)) + (drop *alltestnamelst* (d:alldat-start-test-offset *alldat*)) '()))) - (append xl (make-list (- *num-tests* (length xl)) "")))) + (append xl (make-list (- (d:alldat-num-tests *alldat*) (length xl)) "")))) (update-labels uidat) (for-each (lambda (rundat) (if (not rundat) ;; handle padded runs ;; ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration - (set! rundat (vector (make-vector 20 #f) '() (map (lambda (x) "") *keys*))));; 3))) + (set! rundat (vector (make-vector 20 #f) '() (map (lambda (x) "") (d:alldat-keys *alldat*)))));; 3))) (let* ((run (vector-ref rundat 0)) (testsdat (vector-ref rundat 1)) (key-val-dat (vector-ref rundat 2)) - (run-id (db:get-value-by-header run *header* "id")) + (run-id (db:get-value-by-header run (d:alldat-header *alldat*) "id")) (key-vals (append key-val-dat - (list (let ((x (db:get-value-by-header run *header* "runname"))) + (list (let ((x (db:get-value-by-header run (d:alldat-header *alldat*) "runname"))) (if x x ""))))) (run-key (string-intersperse key-vals "\n"))) ;; fill in the run header key values (let ((rown 0) @@ -478,11 +620,11 @@ ;; For this run now fill in the buttons for each test (let ((rown 0) (columndat (vector-ref table coln))) (for-each (lambda (testname) - (let ((buttondat (hash-table-ref/default *buttondat* (mkstr coln rown) #f))) + (let ((buttondat (hash-table-ref/default (d:alldat-buttondat *alldat*) (mkstr coln rown) #f))) (if buttondat (let* ((test (let ((matching (filter (lambda (x)(equal? (test:test-get-fullname x) testname)) testsdat))) (if (null? matching) @@ -523,29 +665,31 @@ (define (mkstr . x) (string-intersperse (map conc x) ",")) (define (set-bg-on-filter) (let ((search-changed (not (null? (filter (lambda (key) - (not (equal? (hash-table-ref *searchpatts* key) "%"))) - (hash-table-keys *searchpatts*))))) - (state-changed (not (null? (hash-table-keys *state-ignore-hash*)))) - (status-changed (not (null? (hash-table-keys *status-ignore-hash*))))) - (iup:attribute-set! *hide-not-hide-tabs* "BGCOLOR" + (not (equal? (hash-table-ref (d:alldat-searchpatts *alldat*) key) "%"))) + (hash-table-keys (d:alldat-searchpatts *alldat*)))))) + (state-changed (not (null? (hash-table-keys (d:alldat-state-ignore-hash *alldat*))))) + (status-changed (not (null? (hash-table-keys (d:alldat-status-ignore-hash *alldat*)))))) + (iup:attribute-set! (d:alldat-hide-not-hide-tabs *alldat*) "BGCOLOR" (if (or search-changed state-changed status-changed) "190 180 190" "190 190 190" - )))) + )) + (d:alldat-filters-changed-set! *alldat* #t))) (define (update-search x val) - (hash-table-set! *searchpatts* x val) + (hash-table-set! (d:alldat-searchpatts *alldat*) x val) + (d:alldat-filters-changed-set! *alldat* #t) (set-bg-on-filter)) (define (mark-for-update) - (set! *last-db-update-time* 0) - (set! *delayed-update* 1)) + (d:alldat-filters-changed-set! *alldat* #t) + (d:alldat-last-db-update-set! *alldat* 0)) ;;====================================================================== ;; R U N C O N T R O L ;;====================================================================== @@ -591,13 +735,13 @@ (iup:attribute-set! lb "VALUE" newval) newval)))))) (define (dashboard:update-target-selector key-lbs #!key (action-proc #f)) (let* ((runconf-targs (common:get-runconfig-targets)) - (db-target-dat (if *useserver* + (db-target-dat (if (d:alldat-useserver *alldat*) (rmt:get-targets) - (db:get-targets *dbstruct-local*))) + (db:get-targets (d:alldat-dblocal *alldat*)))) (header (vector-ref db-target-dat 0)) (db-targets (vector-ref db-target-dat 1)) (all-targets (append db-targets (map (lambda (x) (list->vector @@ -673,25 +817,27 @@ (if targ-list (string-intersperse targ-list "/") "no-target-selected"))) (run-name (dboard:data-get-run-name *data*)) (states-str (if (or (not states) (null? states)) "" - (conc " :state " (string-intersperse states ",")))) + (conc " -state " (string-intersperse states ",")))) (statuses-str (if (or (not statuses) (null? statuses)) "" - (conc " :status " (string-intersperse statuses ",")))) + (conc " -status " (string-intersperse statuses ",")))) (full-cmd "megatest")) (case (string->symbol cmd) - ((runtests) + ((run) (set! full-cmd (conc full-cmd - " -runtests " + " -run" + " -testpatt " test-patt " -target " target " -runname " run-name + " -clean-cache" ))) ((remove-runs) (set! full-cmd (conc full-cmd " -remove-runs -runname " run-name @@ -705,29 +851,27 @@ (else (set! full-cmd " no valid command "))) (iup:attribute-set! cmd-tb "VALUE" full-cmd))) ;; Display the tests as rows of boxes on the test/task pane ;; -(define (dashboard:draw-tests cnv xadj yadj tests-draw-state sorted-testnames) +(define (dashboard:draw-tests cnv xadj yadj tests-draw-state sorted-testnames test-records) (canvas-clear! cnv) (canvas-font-set! cnv "Helvetica, -10") (let-values (((sizex sizey sizexmm sizeymm) (canvas-size cnv)) ((originx originy) (canvas-origin cnv))) - ;; (print "originx: " originx " originy: " originy) - ;; (canvas-origin-set! cnv 0 (- (/ sizey 2))) - (if (hash-table-ref/default tests-draw-state 'first-time #t) - (begin - (hash-table-set! tests-draw-state 'first-time #f) - (hash-table-set! tests-draw-state 'scalef 8) - (hash-table-set! tests-draw-state 'tests-info (make-hash-table)) - (hash-table-set! tests-draw-state 'selected-tests (make-hash-table)) - ;; set these - (hash-table-set! tests-draw-state 'test-browse-xoffset 20) ;; (- 0 (* (/ sizex 2) (* 8 xadj)))) - (hash-table-set! tests-draw-state 'test-browse-yoffset 20) ;; (- 0 (* (/ sizey 2) (* 8 (- 1 yadj))))))) - (dcommon:initial-draw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames)) - (dcommon:redraw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames)) - )) + ;; (print "originx: " originx " originy: " originy) + ;; (canvas-origin-set! cnv 0 (- (/ sizey 2))) + (if (hash-table-ref/default tests-draw-state 'first-time #t) + (begin + (hash-table-set! tests-draw-state 'first-time #f) + (hash-table-set! tests-draw-state 'scalef 1) + (hash-table-set! tests-draw-state 'tests-info (make-hash-table)) + (hash-table-set! tests-draw-state 'selected-tests (make-hash-table)) + ;; set these + (dcommon:initial-draw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames test-records)) + (dcommon:redraw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames test-records)) + )) ;;====================================================================== ;; R U N C O N T R O L S ;;====================================================================== ;; @@ -737,30 +881,34 @@ (let* ((targets (make-hash-table)) (test-records (make-hash-table)) (all-tests-registry (tests:get-all)) ;; (tests:get-valid-tests *toppath* '())) (test-names (hash-table-keys all-tests-registry)) (sorted-testnames #f) - (action "-runtests") + (action "-run") (cmdln "") (runlogs (make-hash-table)) (key-listboxes #f) (updater-for-runs #f) (update-keyvals (lambda () (let ((targ (map (lambda (x) (iup:attribute x "VALUE")) - (car (dashboard:update-target-selector key-listboxes))))) + (car (dashboard:update-target-selector key-listboxes)))) + (curr-runname (dboard:data-get-run-name *data*))) (dboard:data-set-target! *data* targ) (if updater-for-runs (updater-for-runs)) + (if (or (not (equal? curr-runname (dboard:data-get-run-name *data*))) + (equal? (dboard:data-get-run-name *data*) "")) + (dboard:data-set-run-name! *data* curr-runname)) (dashboard:update-run-command)))) (tests-draw-state (make-hash-table)) ;; use for keeping state of the test canvas (test-patterns-textbox #f)) (hash-table-set! tests-draw-state 'first-time #t) - (hash-table-set! tests-draw-state 'scalef 8) + ;; (hash-table-set! tests-draw-state 'scalef 1) (tests:get-full-data test-names test-records '() all-tests-registry) (set! sorted-testnames (tests:sort-by-priority-and-waiton test-records)) - ;; refer to *keys*, *dbkeys* for keys + ;; refer to (d:alldat-keys *alldat*), (d:alldat-dbkeys *alldat*) for keys (iup:vbox ;; The command line display/exectution control (iup:frame #:title "Command to be exectuted" (iup:hbox @@ -796,11 +944,11 @@ ;; Command to run (iup:frame #:title "Set the action to take" (iup:hbox ;; (iup:label "Command to run" #:expand "HORIZONTAL" #:size "70x" #:alignment "LEFT:ACENTER") - (let* ((cmds-list '("runtests" "remove-runs" "set-state-status" "lock-runs" "unlock-runs")) + (let* ((cmds-list '("run" "remove-runs" "set-state-status" "lock-runs" "unlock-runs")) (lb (iup:listbox #:expand "HORIZONTAL" #:dropdown "YES" #:action (lambda (obj val index lbstate) ;; (print obj " " val " " index " " lbstate) (dboard:data-set-command! *data* val) @@ -816,29 +964,31 @@ (tb (iup:textbox #:expand "HORIZONTAL" #:action (lambda (obj val txt) ;; (print "obj: " obj " val: " val " unk: " unk) (dboard:data-set-run-name! *data* txt) ;; (iup:attribute obj "VALUE")) (dashboard:update-run-command)) - #:value default-run-name)) + #:value (or default-run-name (dboard:data-get-run-name *data*)))) (lb (iup:listbox #:expand "HORIZONTAL" #:dropdown "YES" #:action (lambda (obj val index lbstate) - (iup:attribute-set! tb "VALUE" val) - (dboard:data-set-run-name! *data* val) - (dashboard:update-run-command)))) + (if (not (equal? val "")) + (begin + (iup:attribute-set! tb "VALUE" val) + (dboard:data-set-run-name! *data* val) + (dashboard:update-run-command)))))) (refresh-runs-list (lambda () (let* ((target (dboard:data-get-target-string *data*)) - (runs-for-targ (if *useserver* - (rmt:get-runs-by-patt *keys* "%" target #f #f #f) - (db:get-runs-by-patt *dbstruct-local* *keys* "%" target #f #f #f))) + (runs-for-targ (if (d:alldat-useserver *alldat*) + (rmt:get-runs-by-patt (d:alldat-keys *alldat*) "%" target #f #f #f) + (db:get-runs-by-patt (d:alldat-dblocal *alldat*) (d:alldat-keys *alldat*) "%" target #f #f #f))) (runs-header (vector-ref runs-for-targ 0)) (runs-dat (vector-ref runs-for-targ 1)) (run-names (cons default-run-name (map (lambda (x) (db:get-value-by-header x runs-header "runname")) runs-dat)))) - (iup:attribute-set! lb "REMOVEITEM" "ALL") + ;; (iup:attribute-set! lb "REMOVEITEM" "ALL") (iuplistbox-fill-list lb run-names selected-item: default-run-name))))) (set! updater-for-runs refresh-runs-list) (refresh-runs-list) (dboard:data-set-run-name! *data* default-run-name) (iup:hbox @@ -888,11 +1038,11 @@ (dashboard:text-list-toggle-box (map cadr *common:std-statuses*) ;; '("PASS" "FAIL" "n/a" "CHECK" "WAIVED" "SKIP" "DELETED" "STUCK/DEAD") (lambda (all) (dboard:data-set-statuses! *data* all) (dashboard:update-run-command)))))))) - + (iup:frame #:title "Tests and Tasks" (let* ((updater #f) (last-xadj 0) (last-yadj 0) @@ -901,69 +1051,74 @@ (iup:canvas #:action (make-canvas-action (lambda (cnv xadj yadj) (if (not updater) (set! updater (lambda (xadj yadj) ;; (print "cnv: " cnv " xadj: " xadj " yadj: " yadj) - (dashboard:draw-tests cnv xadj yadj tests-draw-state sorted-testnames) + (dashboard:draw-tests cnv xadj yadj tests-draw-state sorted-testnames test-records) (set! last-xadj xadj) (set! last-yadj yadj)))) (updater xadj yadj) (set! the-cnv cnv) )) ;; Following doesn't work #:wheel-cb (lambda (obj step x y dir) ;; dir is 4 for up and 5 for down. I think. - (let ((xadj last-xadj) - (yadj (+ last-yadj (if (> step 0) - -0.01 - 0.01)))) - ;; (print "step: " step " x: " x " y: " y " dir: \"" dir "\"") - ;; (print "the-cnv: " the-cnv " obj: " obj " xadj: " xadj " yadj: " yadj " dir: " dir) + (let ((scalef (hash-table-ref tests-draw-state 'scalef))) + (hash-table-set! tests-draw-state 'scalef (+ scalef + (if (> step 0) + (* scalef 0.01) + (* scalef -0.01)))) (if the-cnv - (dashboard:draw-tests the-cnv xadj yadj tests-draw-state sorted-testnames)) - (set! last-xadj xadj) - (set! last-yadj yadj) + (dashboard:draw-tests the-cnv last-xadj last-yadj tests-draw-state sorted-testnames test-records)) )) ;; #:size "50x50" #:expand "YES" #:scrollbar "YES" #:posx "0.5" #:posy "0.5" #:button-cb (lambda (obj btn pressed x y status) - ;; (print "obj: " obj) - (let ((tests-info (hash-table-ref tests-draw-state 'tests-info)) - (selected-tests (hash-table-ref tests-draw-state 'selected-tests))) - ;; (print "x\ty\tllx\tlly\turx\tury") + ;; (print "obj: " obj ", pressed " pressed ", status " status) + ; (print "canvas-origin: " (canvas-origin the-cnv)) + ;; (let-values (((xx yy)(canvas-origin the-cnv))) + ;; (canvas-transform-set! the-cnv #f) + ;; (print "canvas-origin: " xx " " yy " click at " x " " y)) + (let* ((tests-info (hash-table-ref tests-draw-state 'tests-info)) + (selected-tests (hash-table-ref tests-draw-state 'selected-tests)) + (scalef (hash-table-ref tests-draw-state 'scalef)) + (sizey (hash-table-ref tests-draw-state 'sizey)) + (xoffset (dcommon:get-xoffset tests-draw-state #f #f)) + (yoffset (dcommon:get-yoffset tests-draw-state #f #f)) + (new-y (- sizey y))) + ;; (print "xoffset=" xoffset ", yoffset=" yoffset) + ;; (print "\tx\ty\tllx\tlly\turx\tury") (for-each (lambda (test-name) (let* ((rec-coords (hash-table-ref tests-info test-name)) - (llx (list-ref rec-coords 0)) - (urx (list-ref rec-coords 1)) - (lly (list-ref rec-coords 2)) - (ury (list-ref rec-coords 3))) - ;; (print x "\t" y "\t" llx "\t" lly "\t" urx "\t" ury "\t" test-name " " + (llx (dcommon:x->canvas (list-ref rec-coords 0) scalef xoffset)) + (lly (dcommon:y->canvas (list-ref rec-coords 1) scalef yoffset)) + (urx (dcommon:x->canvas (list-ref rec-coords 2) scalef xoffset)) + (ury (dcommon:y->canvas (list-ref rec-coords 3) scalef yoffset))) + ;; (if (eq? pressed 1) + ;; (print "\tx=" x "\ty=" y "\tnew-y=" new-y "\tllx=" llx "\tlly=" lly "\turx=" urx "\tury=" ury "\t" test-name " ")) (if (and (eq? pressed 1) - (> x llx) - (> y lly) - (< x urx) - (< y ury)) + (>= x llx) + (>= new-y lly) + (<= x urx) + (<= new-y ury)) (let ((patterns (string-split (iup:attribute test-patterns-textbox "VALUE")))) (let* ((selected (not (member test-name patterns))) (newpatt-list (if selected (cons test-name patterns) (delete test-name patterns))) (newpatt (string-intersperse newpatt-list "\n"))) - ;; (if cnv-obj - ;; (dashboard:draw-tests cnv-obj 0 0 tests-draw-state sorted-testnames)) (iup:attribute-set! obj "REDRAW" "ALL") (hash-table-set! selected-tests test-name selected) (iup:attribute-set! test-patterns-textbox "VALUE" newpatt) (dboard:data-set-test-patts! *data* (dboard:lines->test-patt newpatt)) (dashboard:update-run-command) (if updater (updater last-xadj last-yadj))))))) (hash-table-keys tests-info))))))) canvas-obj))) - ;; (print "obj: " obj " btn: " btn " pressed: " pressed " x: " x " y: " y " status: " status)) - + (iup:frame #:title "Logs" ;; To be replaced with tabs (let ((logs-tb (iup:textbox #:expand "YES" #:multiline "YES"))) (dboard:data-set-logs-textbox! *data* logs-tb) @@ -998,12 +1153,13 @@ ;;====================================================================== ;; S U M M A R Y ;;====================================================================== ;; ;; General info about the run(s) and megatest area -(define (dashboard:summary db) - (let ((rawconfig (read-config (conc *toppath* "/megatest.config") #f #f))) ;; changed to #f since I want #{} to be expanded by [system ...] to NOT be expanded. WAS: 'return-string))) +(define (dashboard:summary data) + (let* ((db (d:alldat-dblocal data)) + (rawconfig (read-config (conc *toppath* "/megatest.config") #f #f))) ;; changed to #f since I want #{} to be expanded by [system ...] to NOT be expanded. WAS: 'return-string))) (iup:vbox (iup:split #:value 500 (iup:frame #:title "General Info" @@ -1035,73 +1191,101 @@ ;; R U N ;;====================================================================== ;; ;; display and manage a single run at a time -(define (tree-path->run-id path) +(define (tree-path->run-id data path) (if (not (null? path)) - (hash-table-ref/default (dboard:data-get-path-run-ids *data*) path #f) + (hash-table-ref/default (d:data-path-run-ids data) path #f) #f)) (define dashboard:update-run-summary-tab #f) +(define dashboard:update-new-view-tab #f) + +(define (dboard:get-tests-dat data run-id last-update) + (let ((tdat (if run-id + (if (d:alldat-useserver data) + (rmt:get-tests-for-run run-id + (hash-table-ref/default (d:alldat-searchpatts data) "test-name" "%/%") + (hash-table-keys (d:alldat-state-ignore-hash data)) ;; '() + (hash-table-keys (d:alldat-status-ignore-hash data)) ;; '() + #f #f + (d:alldat-hide-not-hide data) + #f #f + "id,testname,item_path,state,status" + (if (d:alldat-filters-changed data) + 0 + last-update) + *dashboard-mode*) ;; get 'em all + (db:get-tests-for-run db run-id + (hash-table-ref/default (d:alldat-searchpatts data) "test-name" "%/%") + (hash-table-keys (d:alldat-state-ignore-hash data)) ;; '() + (hash-table-keys (d:alldat-status-ignore-hash data)) ;; '() + #f #f + (d:alldat-hide-not-hide data) + #f #f + "id,testname,item_path,state,status" + (if (d:alldat-filters-changed data) + 0 + last-update) + *dashboard-mode*)) + '()))) ;; get 'em all + (debug:print 0 #f "dboard:get-tests-dat: got " (length tdat) " test records for run " run-id) + (sort tdat (lambda (a b) + (let* ((aval (vector-ref a 2)) + (bval (vector-ref b 2)) + (anum (string->number aval)) + (bnum (string->number bval))) + (if (and anum bnum) + (< anum bnum) + (string<= aval bval))))))) -;; (define (tests window-id) -(define (dashboard:one-run db) +;; This is the Run Summary tab +;; +(define (dashboard:one-run db data ddata) (let* ((tb (iup:treebox #:value 0 #:name "Runs" #:expand "YES" #:addexpanded "NO" #:selection-cb (lambda (obj id state) ;; (print "obj: " obj ", id: " id ", state: " state) (let* ((run-path (tree:node->path obj id)) - (run-id (tree-path->run-id (cdr run-path)))) + (run-id (tree-path->run-id ddata (cdr run-path)))) (if (number? run-id) (begin - (dboard:data-set-curr-run-id! *data* run-id) + (d:data-curr-run-id-set! ddata run-id) (dashboard:update-run-summary-tab)) - (debug:print 0 "ERROR: tree-path->run-id returned non-number " run-id))) - ;; (print "path: " (tree:node->path obj id) " run-id: " run-id) - ))) + (debug:print 0 #f "ERROR: tree-path->run-id returned non-number " run-id))) + ;; (print "path: " (tree:node->path obj id) " run-id: " run-id) + ))) (cell-lookup (make-hash-table)) (run-matrix (iup:matrix #:expand "YES" #:click-cb (lambda (obj lin col status) (let* ((toolpath (car (argv))) (key (conc lin ":" col)) (test-id (hash-table-ref/default cell-lookup key -1)) - (cmd (conc toolpath " -test " (dboard:data-get-curr-run-id *data*) "," test-id "&"))) + (cmd (conc toolpath " -test " (d:data-curr-run-id ddata) "," test-id "&"))) (system cmd))))) (updater (lambda () - (let* ((runs-dat (db:get-runs-by-patt db *keys* "%" #f #f #f #f)) + (let* ((runs-dat (if (d:alldat-useserver data) + (rmt:get-runs-by-patt (d:alldat-keys data) "%" #f #f #f #f) + (db:get-runs-by-patt db (d:alldat-keys data) "%" #f #f #f #f))) (runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records - (run-id (dboard:data-get-curr-run-id *data*)) - (tests-dat (let ((tdat (db:get-tests-for-run db run-id - (hash-table-ref/default *searchpatts* "test-name" "%/%") - (hash-table-keys *state-ignore-hash*) ;; '() - (hash-table-keys *status-ignore-hash*) ;; '() - #f #f - *hide-not-hide* - #f #f - "id,testname,item_path,state,status"))) ;; get 'em all - (sort tdat (lambda (a b) - (let* ((aval (vector-ref a 2)) - (bval (vector-ref b 2)) - (anum (string->number aval)) - (bnum (string->number bval))) - (if (and anum bnum) - (< anum bnum) - (string<= aval bval))))))) + (run-id (d:data-curr-run-id ddata)) + (last-update 0) ;; fix me + (tests-dat (dboard:get-tests-dat data run-id last-update)) (tests-mindat (dcommon:minimize-test-data tests-dat)) (indices (common:sparse-list-generate-index tests-mindat)) ;; proc: set-cell)) (row-indices (cadr indices)) (col-indices (car indices)) (max-row (if (null? row-indices) 1 (common:max (map cadr row-indices)))) (max-col (if (null? col-indices) 1 (common:max (map cadr col-indices)))) - (max-visible (max (- *num-tests* 15) 3)) ;; *num-tests* is proportional to the size of the window + (max-visible (max (- (d:alldat-num-tests data) 15) 3)) ;; (d:alldat-num-tests data) is proportional to the size of the window (numrows 1) (numcols 1) (changed #f) (runs-hash (let ((ht (make-hash-table))) (for-each (lambda (run) @@ -1114,31 +1298,32 @@ (record-b (hash-table-ref runs-hash b)) (time-a (db:get-value-by-header record-a runs-header "event_time")) (time-b (db:get-value-by-header record-b runs-header "event_time"))) (< time-a time-b)))))) + (d:alldat-filters-changed-set! data #f) ;; (iup:attribute-set! tb "VALUE" "0") ;; (iup:attribute-set! tb "NAME" "Runs") ;; Update the runs tree (for-each (lambda (run-id) (let* ((run-record (hash-table-ref/default runs-hash run-id #f)) (key-vals (map (lambda (key)(db:get-value-by-header run-record runs-header key)) - *keys*)) + (d:alldat-keys data))) (run-name (db:get-value-by-header run-record runs-header "runname")) (col-name (conc (string-intersperse key-vals "\n") "\n" run-name)) (run-path (append key-vals (list run-name))) (existing (tree:find-node tb run-path))) - (if (not (hash-table-ref/default (dboard:data-get-path-run-ids *data*) run-path #f)) + (if (not (hash-table-ref/default (d:data-path-run-ids ddata) run-path #f)) (begin - (hash-table-set! (dboard:data-get-run-keys *data*) run-id run-path) + (hash-table-set! (d:data-run-keys ddata) run-id run-path) ;; (iup:attribute-set! (dboard:data-get-runs-matrix *data*) ;; (conc rownum ":" colnum) col-name) ;; (hash-table-set! runid-to-col run-id (list colnum run-record)) ;; Here we update the tests treebox and tree keys (tree:add-node tb "Runs" run-path ;; (append key-vals (list run-name)) userdata: (conc "run-id: " run-id)) - (hash-table-set! (dboard:data-get-path-run-ids *data*) run-path run-id) + (hash-table-set! (d:data-path-run-ids ddata) run-path run-id) ;; (set! colnum (+ colnum 1)) )))) run-ids) (iup:attribute-set! run-matrix "CLEARVALUE" "ALL") ;; NOTE: Was CONTENTS (iup:attribute-set! run-matrix "CLEARATTRIB" "CONTENTS") @@ -1194,21 +1379,289 @@ (iup:attribute-set! run-matrix "FITTOTEXT" (conc "C" num)))))) col-indices) (if changed (iup:attribute-set! run-matrix "REDRAW" "ALL")))))) (set! dashboard:update-run-summary-tab updater) - (dboard:data-set-runs-tree! *data* tb) + (d:data-runs-tree-set! ddata tb) + (iup:split + tb + run-matrix))) + +;; This is the New View tab +;; +(define (dashboard:new-view db data ddata) + (let* ((tb (iup:treebox + #:value 0 + #:name "Runs" + #:expand "YES" + #:addexpanded "NO" + #:selection-cb + (lambda (obj id state) + ;; (print "obj: " obj ", id: " id ", state: " state) + (let* ((run-path (tree:node->path obj id)) + (run-id (tree-path->run-id ddata (cdr run-path)))) + (if (number? run-id) + (begin + (d:data-curr-run-id-set! ddata run-id) + (dashboard:update-new-view-tab)) + (debug:print 0 #f "ERROR: tree-path->run-id returned non-number " run-id))) + ;; (print "path: " (tree:node->path obj id) " run-id: " run-id) + ))) + (cell-lookup (make-hash-table)) + (run-matrix (iup:matrix + #:expand "YES" + #:click-cb + (lambda (obj lin col status) + (let* ((toolpath (car (argv))) + (key (conc lin ":" col)) + (test-id (hash-table-ref/default cell-lookup key -1)) + (cmd (conc toolpath " -test " (d:data-curr-run-id ddata) "," test-id "&"))) + (system cmd))))) + (updater (lambda () + (let* ((runs-dat (if (d:alldat-useserver data) + (rmt:get-runs-by-patt (d:alldat-keys data) "%" #f #f #f #f) + (db:get-runs-by-patt db (d:alldat-keys data) "%" #f #f #f #f))) + (runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records + (run-id (d:data-curr-run-id ddata)) + (last-update 0) ;; fix me + (tests-dat (dboard:get-tests-dat data run-id last-update)) + (tests-mindat (dcommon:minimize-test-data tests-dat)) + (indices (common:sparse-list-generate-index tests-mindat)) ;; proc: set-cell)) + (row-indices (cadr indices)) + (col-indices (car indices)) + (max-row (if (null? row-indices) 1 (common:max (map cadr row-indices)))) + (max-col (if (null? col-indices) 1 (common:max (map cadr col-indices)))) + (max-visible (max (- (d:alldat-num-tests data) 15) 3)) ;; (d:alldat-num-tests data) is proportional to the size of the window + (numrows 1) + (numcols 1) + (changed #f) + (runs-hash (let ((ht (make-hash-table))) + (for-each (lambda (run) + (hash-table-set! ht (db:get-value-by-header run runs-header "id") run)) + (vector-ref runs-dat 1)) + ht)) + (run-ids (sort (filter number? (hash-table-keys runs-hash)) + (lambda (a b) + (let* ((record-a (hash-table-ref runs-hash a)) + (record-b (hash-table-ref runs-hash b)) + (time-a (db:get-value-by-header record-a runs-header "event_time")) + (time-b (db:get-value-by-header record-b runs-header "event_time"))) + (< time-a time-b)))))) + + ;; (iup:attribute-set! tb "VALUE" "0") + ;; (iup:attribute-set! tb "NAME" "Runs") + ;; Update the runs tree + (for-each (lambda (run-id) + (let* ((run-record (hash-table-ref/default runs-hash run-id #f)) + (key-vals (map (lambda (key)(db:get-value-by-header run-record runs-header key)) + (d:alldat-keys data))) + (run-name (db:get-value-by-header run-record runs-header "runname")) + (col-name (conc (string-intersperse key-vals "\n") "\n" run-name)) + (run-path (append key-vals (list run-name))) + (existing (tree:find-node tb run-path))) + (if (not (hash-table-ref/default (d:data-path-run-ids ddata) run-path #f)) + (begin + (hash-table-set! (d:data-run-keys ddata) run-id run-path) + ;; (iup:attribute-set! (dboard:data-get-runs-matrix *data*) + ;; (conc rownum ":" colnum) col-name) + ;; (hash-table-set! runid-to-col run-id (list colnum run-record)) + ;; Here we update the tests treebox and tree keys + (tree:add-node tb "Runs" run-path ;; (append key-vals (list run-name)) + userdata: (conc "run-id: " run-id)) + (hash-table-set! (d:data-path-run-ids ddata) run-path run-id) + ;; (set! colnum (+ colnum 1)) + )))) + run-ids) + (iup:attribute-set! run-matrix "CLEARVALUE" "ALL") ;; NOTE: Was CONTENTS + (iup:attribute-set! run-matrix "CLEARATTRIB" "CONTENTS") + (iup:attribute-set! run-matrix "RESIZEMATRIX" "YES") + (iup:attribute-set! run-matrix "NUMCOL" max-col ) + (iup:attribute-set! run-matrix "NUMLIN" (if (< max-row max-visible) max-visible max-row)) ;; min of 20 + ;; (iup:attribute-set! run-matrix "NUMCOL_VISIBLE" max-col) + ;; (iup:attribute-set! run-matrix "NUMLIN_VISIBLE" (if (> max-row max-visible) max-visible max-row)) + + ;; Row labels + (for-each (lambda (ind) + (let* ((name (car ind)) + (num (cadr ind)) + (key (conc num ":0"))) + (if (not (equal? (iup:attribute run-matrix key) name)) + (begin + (set! changed #t) + (iup:attribute-set! run-matrix key name))))) + row-indices) + + ;; Cell contents + (for-each (lambda (entry) + (let* ((row-name (cadr entry)) + (col-name (car entry)) + (valuedat (caddr entry)) + (test-id (list-ref valuedat 0)) + (test-name row-name) ;; (list-ref valuedat 1)) + (item-path col-name) ;; (list-ref valuedat 2)) + (state (list-ref valuedat 1)) + (status (list-ref valuedat 2)) + (value (gutils:get-color-for-state-status state status)) + (row-num (cadr (assoc row-name row-indices))) + (col-num (cadr (assoc col-name col-indices))) + (key (conc row-num ":" col-num))) + (hash-table-set! cell-lookup key test-id) + (if (not (equal? (iup:attribute run-matrix key) (cadr value))) + (begin + (set! changed #t) + (iup:attribute-set! run-matrix key (cadr value)) + (iup:attribute-set! run-matrix (conc "BGCOLOR" key) (car value)))))) + tests-mindat) + + ;; Col labels - do after setting Cell contents so they are accounted for in the size calc. + + (for-each (lambda (ind) + (let* ((name (car ind)) + (num (cadr ind)) + (key (conc "0:" num))) + (if (not (equal? (iup:attribute run-matrix key) name)) + (begin + (set! changed #t) + (iup:attribute-set! run-matrix key name) + (iup:attribute-set! run-matrix "FITTOTEXT" (conc "C" num)))))) + col-indices) + (if changed (iup:attribute-set! run-matrix "REDRAW" "ALL")))))) + + (set! dashboard:update-new-view-tab updater) + (d:data-runs-tree-set! ddata tb) (iup:split tb run-matrix))) ;;====================================================================== ;; R U N S ;;====================================================================== -(define (make-dashboard-buttons db nruns ntests keynames) - (let* ((nkeys (length keynames)) +(define (dboard:make-controls data) + (iup:hbox + (iup:vbox + (iup:frame + #:title "filter test and items" + (iup:hbox + (iup:vbox + (iup:textbox #:size "120x15" #:fontsize "10" #:value "%" + #:action (lambda (obj unk val) + (mark-for-update) + (update-search "test-name" val))) + (iup:hbox + (iup:button "Quit" #:action (lambda (obj) + ;; (if (d:alldat-dblocal data) (db:close-all (d:alldat-dblocal data))) + (exit))) + (iup:button "Refresh" #:action (lambda (obj) + (mark-for-update))) + (iup:button "Collapse" #:action (lambda (obj) + (let ((myname (iup:attribute obj "TITLE"))) + (if (equal? myname "Collapse") + (begin + (for-each (lambda (tname) + (hash-table-set! *collapsed* tname #t)) + (d:alldat-item-test-names data)) + (iup:attribute-set! obj "TITLE" "Expand")) + (begin + (for-each (lambda (tname) + (hash-table-delete! *collapsed* tname)) + (hash-table-keys *collapsed*)) + (iup:attribute-set! obj "TITLE" "Collapse")))) + (mark-for-update)))) + ) + (iup:vbox + ;; (iup:button "Sort -t" #:action (lambda (obj) + ;; (next-sort-option) + ;; (iup:attribute-set! obj "TITLE" (vector-ref (vector-ref *tests-sort-options* *tests-sort-reverse*) 0)) + ;; (mark-for-update))) + + (let* ((hide #f) + (show #f) + (hide-empty #f) + (sel-color "180 100 100") + (nonsel-color "170 170 170") + (cmds-list '("+testname" "-testname" "+event_time" "-event_time" "+statestatus" "-statestatus")) + (sort-lb (iup:listbox #:expand "HORIZONTAL" + #:dropdown "YES" + #:action (lambda (obj val index lbstate) + (set! *tests-sort-reverse* index) + (mark-for-update)))) + (default-cmd (car (list-ref *tests-sort-type-index* *tests-sort-reverse*)))) + (iuplistbox-fill-list sort-lb cmds-list selected-item: default-cmd) + + (set! hide-empty (iup:button "HideEmpty" + #:expand "YES" + #:action (lambda (obj) + (d:alldat-hide-empty-runs-set! data (not (d:alldat-hide-empty-runs data))) + (iup:attribute-set! obj "TITLE" (if (d:alldat-hide-empty-runs data) "+HideE" "-HideE")) + (mark-for-update)))) + (set! hide (iup:button "Hide" + #:expand "YES" + #:action (lambda (obj) + (d:alldat-hide-not-hide-set! data #t) ;; (not (d:alldat-hide-not-hide data))) + ;; (iup:attribute-set! obj "TITLE" (if (d:alldat-hide-not-hide data) "HideTests" "NotHide")) + (iup:attribute-set! hide "BGCOLOR" sel-color) + (iup:attribute-set! show "BGCOLOR" nonsel-color) + (mark-for-update)))) + (set! show (iup:button "Show" + #:expand "YES" + #:action (lambda (obj) + (d:alldat-hide-not-hide-set! data #f) ;; (not (d:alldat-hide-not-hide data))) + (iup:attribute-set! show "BGCOLOR" sel-color) + (iup:attribute-set! hide "BGCOLOR" nonsel-color) + (mark-for-update)))) + (iup:attribute-set! hide "BGCOLOR" sel-color) + (iup:attribute-set! show "BGCOLOR" nonsel-color) + ;; (d:alldat-hide-not-hide-button-set! data hideit) ;; never used, can eliminate ... + (iup:vbox + (iup:hbox hide show) + hide-empty sort-lb))) + ))) + (iup:frame + #:title "state/status filter" + (iup:vbox + (apply + iup:hbox + (map (lambda (status) + (iup:toggle (conc status " ") + #:action (lambda (obj val) + (mark-for-update) + (if (eq? val 1) + (hash-table-set! (d:alldat-status-ignore-hash data) status #t) + (hash-table-delete! (d:alldat-status-ignore-hash data) status)) + (set-bg-on-filter)))) + (map cadr *common:std-statuses*))) ;; '("PASS" "FAIL" "WARN" "CHECK" "WAIVED" "STUCK/DEAD" "n/a" "SKIP"))) + (apply + iup:hbox + (map (lambda (state) + (iup:toggle (conc state " ") + #:action (lambda (obj val) + (mark-for-update) + (if (eq? val 1) + (hash-table-set! (d:alldat-state-ignore-hash data) state #t) + (hash-table-delete! (d:alldat-state-ignore-hash data) state)) + (set-bg-on-filter)))) + (map cadr *common:std-states*))) ;; '("RUNNING" "COMPLETED" "INCOMPLETE" "LAUNCHED" "NOT_STARTED" "KILLED" "DELETED"))) + (iup:valuator #:valuechanged_cb (lambda (obj) + (let ((val (inexact->exact (round (/ (string->number (iup:attribute obj "VALUE")) 10)))) + (oldmax (string->number (iup:attribute obj "MAX"))) + (maxruns (d:alldat-tot-runs data))) + (d:alldat-start-run-offset-set! data val) + (mark-for-update) + (debug:print 6 #f "(d:alldat-start-run-offset data) " (d:alldat-start-run-offset data) " maxruns: " maxruns ", val: " val " oldmax: " oldmax) + (iup:attribute-set! obj "MAX" (* maxruns 10)))) + #:expand "HORIZONTAL" + #:max (* 10 (length (d:alldat-allruns data))) + #:min 0 + #:step 0.01))) + ;(iup:button "inc rows" #:action (lambda (obj)(d:alldat-num-tests-set! data (+ (d:alldat-num-tests data) 1)))) + ;(iup:button "dec rows" #:action (lambda (obj)(d:alldat-num-tests-set! data (if (> (d:alldat-num-tests data) 0)(- (d:alldat-num-tests data) 1) 0)))) + )) + +(define (make-dashboard-buttons data nruns ntests keynames runs-sum-dat new-view-dat) + (let* ((db (d:alldat-dblocal data)) + (nkeys (length keynames)) (runsvec (make-vector nruns)) (header (make-vector nruns)) (lftcol (make-vector ntests)) (keycol (make-vector ntests)) (controls '()) @@ -1216,111 +1669,11 @@ (hdrlst '()) (bdylst '()) (result '()) (i 0)) ;; controls (along bottom) - (set! controls - (iup:hbox - (iup:vbox - (iup:frame - #:title "filter test and items" - (iup:hbox - (iup:textbox #:size "120x15" #:fontsize "10" #:value "%" - #:action (lambda (obj unk val) - (mark-for-update) - (update-search "test-name" val))) - ;;(iup:textbox #:size "60x15" #:fontsize "10" #:value "%" - ;; #:action (lambda (obj unk val) - ;; (mark-for-update) - ;; (update-search "item-name" val)) - )) - (iup:vbox - (iup:hbox - (let* ((cmds-list '("+testname" "-testname" "+event_time" "-event_time" "+statestatus" "-statestatus")) - (lb (iup:listbox #:expand "HORIZONTAL" - #:dropdown "YES" - #:action (lambda (obj val index lbstate) - (set! *tests-sort-reverse* index) - (mark-for-update)))) - (default-cmd (car (list-ref *tests-sort-type-index* *tests-sort-reverse*)))) - (iuplistbox-fill-list lb cmds-list selected-item: default-cmd) - (mark-for-update) - ;; (set! *tests-sort-reverse* *tests-sort-reverse*0) - lb) - ;; (iup:button "Sort -t" #:action (lambda (obj) - ;; (next-sort-option) - ;; (iup:attribute-set! obj "TITLE" (vector-ref (vector-ref *tests-sort-options* *tests-sort-reverse*) 0)) - ;; (mark-for-update))) - (iup:button "HideEmpty" #:action (lambda (obj) - (set! *hide-empty-runs* (not *hide-empty-runs*)) - (iup:attribute-set! obj "TITLE" (if *hide-empty-runs* "+HideE" "-HideE")) - (mark-for-update))) - (let ((hideit (iup:button "HideTests" #:action (lambda (obj) - (set! *hide-not-hide* (not *hide-not-hide*)) - (iup:attribute-set! obj "TITLE" (if *hide-not-hide* "HideTests" "NotHide")) - (mark-for-update))))) - (set! *hide-not-hide-button* hideit) - hideit)) - (iup:hbox - (iup:button "Quit" #:action (lambda (obj) - ;; (if *dbstruct-local* (db:close-all *dbstruct-local*)) - (exit))) - (iup:button "Refresh" #:action (lambda (obj) - (mark-for-update))) - (iup:button "Collapse" #:action (lambda (obj) - (let ((myname (iup:attribute obj "TITLE"))) - (if (equal? myname "Collapse") - (begin - (for-each (lambda (tname) - (hash-table-set! *collapsed* tname #t)) - *all-item-test-names*) - (iup:attribute-set! obj "TITLE" "Expand")) - (begin - (for-each (lambda (tname) - (hash-table-delete! *collapsed* tname)) - (hash-table-keys *collapsed*)) - (iup:attribute-set! obj "TITLE" "Collapse")))) - (mark-for-update)))))) - (iup:frame - #:title "state/status filter" - (iup:vbox - (apply - iup:hbox - (map (lambda (status) - (iup:toggle status #:action (lambda (obj val) - (mark-for-update) - (if (eq? val 1) - (hash-table-set! *status-ignore-hash* status #t) - (hash-table-delete! *status-ignore-hash* status)) - (set-bg-on-filter)))) - (map cadr *common:std-statuses*))) ;; '("PASS" "FAIL" "WARN" "CHECK" "WAIVED" "STUCK/DEAD" "n/a" "SKIP"))) - (apply - iup:hbox - (map (lambda (state) - (iup:toggle state #:action (lambda (obj val) - (mark-for-update) - (if (eq? val 1) - (hash-table-set! *state-ignore-hash* state #t) - (hash-table-delete! *state-ignore-hash* state)) - (set-bg-on-filter)))) - (map cadr *common:std-states*))) ;; '("RUNNING" "COMPLETED" "INCOMPLETE" "LAUNCHED" "NOT_STARTED" "KILLED" "DELETED"))) - (iup:valuator #:valuechanged_cb (lambda (obj) - (let ((val (inexact->exact (round (/ (string->number (iup:attribute obj "VALUE")) 10)))) - (oldmax (string->number (iup:attribute obj "MAX"))) - (maxruns *tot-run-count*)) - (set! *start-run-offset* val) - (mark-for-update) - (debug:print 6 "*start-run-offset* " *start-run-offset* " maxruns: " maxruns ", val: " val " oldmax: " oldmax) - (iup:attribute-set! obj "MAX" (* maxruns 10)))) - #:expand "HORIZONTAL" - #:max (* 10 (length *allruns*)) - #:min 0 - #:step 0.01))) - ;(iup:button "inc rows" #:action (lambda (obj)(set! *num-tests* (+ *num-tests* 1)))) - ;(iup:button "dec rows" #:action (lambda (obj)(set! *num-tests* (if (> *num-tests* 0)(- *num-tests* 1) 0)))) - ) - ) + (set! controls (dboard:make-controls data)) ;; create the left most column for the run key names and the test names (set! lftlst (list (iup:hbox (iup:label) ;; (iup:valuator) (apply iup:vbox @@ -1342,13 +1695,13 @@ (set! lftlst (append lftlst (list (iup:hbox #:expand "HORIZONTAL" (iup:valuator #:valuechanged_cb (lambda (obj) (let ((val (string->number (iup:attribute obj "VALUE"))) (oldmax (string->number (iup:attribute obj "MAX"))) (newmax (* 10 (length *alltestnamelst*)))) - (set! *please-update-buttons* #t) - (set! *start-test-offset* (inexact->exact (round (/ val 10)))) - (debug:print 6 "*start-test-offset* " *start-test-offset* " val: " val " newmax: " newmax " oldmax: " oldmax) + (d:alldat-please-update-set! data #t) + (d:alldat-start-test-offset-set! *alldat* (inexact->exact (round (/ val 10)))) + (debug:print 6 #f "(d:alldat-start-test-offset *alldat*) " (d:alldat-start-test-offset *alldat*) " val: " val " newmax: " newmax " oldmax: " oldmax) (if (< val 10) (iup:attribute-set! obj "MAX" newmax)) )) #:expand "VERTICAL" #:orientation "VERTICAL" @@ -1401,17 +1754,17 @@ #:size "60x15" #:expand "HORIZONTAL" #:fontsize "10" #:action (lambda (x) (let* ((toolpath (car (argv))) - (buttndat (hash-table-ref *buttondat* button-key)) + (buttndat (hash-table-ref (d:alldat-buttondat *alldat*) button-key)) (test-id (db:test-get-id (vector-ref buttndat 3))) (run-id (db:test-get-run_id (vector-ref buttndat 3))) (cmd (conc toolpath " -test " run-id "," test-id "&"))) ;(print "Launching " cmd) (system cmd)))))) - (hash-table-set! *buttondat* button-key (vector 0 "100 100 100" button-key #f #f)) + (hash-table-set! (d:alldat-buttondat *alldat*) button-key (vector 0 "100 100 100" button-key #f #f)) (vector-set! testvec testnum butn) (loop runnum (+ testnum 1) testvec (cons butn res)))))) ;; now assemble the hdrlst and bdylst and kick off the dialog (iup:show (iup:dialog @@ -1423,114 +1776,124 @@ (list (iup:vbox ;; the header (apply iup:hbox (reverse hdrlst)) (apply iup:hbox (reverse bdylst)))))) - controls)) + ;; controls + )) + ;; (data (d:data-init (make-d:data))) (tabs (iup:tabs #:tabchangepos-cb (lambda (obj curr prev) - (set! *please-update-buttons* #t) - (set! *current-tab-number* curr)) - (dashboard:summary db) + (d:alldat-please-update-set! *alldat* #t) + (d:alldat-curr-tab-num-set! *alldat* curr)) + (dashboard:summary *alldat*) runs-view - (dashboard:one-run db) + (dashboard:one-run db data runs-sum-dat) + ;; (dashboard:new-view db data new-view-dat) (dashboard:run-controls) ))) ;; (set! (iup:callback tabs tabchange-cb:) (lambda (a b c)(print "SWITCHED TO TAB: " a " " b " " c))) (iup:attribute-set! tabs "TABTITLE0" "Summary") (iup:attribute-set! tabs "TABTITLE1" "Runs") (iup:attribute-set! tabs "TABTITLE2" "Run Summary") (iup:attribute-set! tabs "TABTITLE3" "Run Control") + ;; (iup:attribute-set! tabs "TABTITLE3" "New View") + ;; (iup:attribute-set! tabs "TABTITLE4" "Run Control") (iup:attribute-set! tabs "BGCOLOR" "190 190 190") - (set! *hide-not-hide-tabs* tabs) - tabs))) + (d:alldat-hide-not-hide-tabs-set! *alldat* tabs) + (iup:vbox + tabs + controls)))) (vector keycol lftcol header runsvec))) (if (or (args:get-arg "-rows") (get-environment-variable "DASHBOARDROWS" )) (begin - (set! *num-tests* (string->number (or (args:get-arg "-rows") - (get-environment-variable "DASHBOARDROWS")))) - (update-rundat "%" *num-runs* "%/%" '())) - (set! *num-tests* (min (max (update-rundat "%" *num-runs* "%/%" '()) 8) 20))) + (d:alldat-num-tests-set! *alldat* (string->number + (or (args:get-arg "-rows") + (get-environment-variable "DASHBOARDROWS")))) + (update-rundat *alldat* "%" (d:alldat-numruns *alldat*) "%/%" '())) + (d:alldat-num-tests-set! *alldat* (min (max (update-rundat *alldat* "%" (d:alldat-numruns *alldat*) "%/%" '()) 8) 20))) (define *tim* (iup:timer)) (define *ord* #f) (iup:attribute-set! *tim* "TIME" 300) (iup:attribute-set! *tim* "RUN" "YES") ;; Move this stuff to db.scm? I'm not sure that is the right thing to do... ;; -(define *last-db-update-time* (file-modification-time *db-file-path*)) ;; (conc *toppath* "/db/main.db"))) +(d:alldat-last-db-update-set! *alldat* (file-modification-time (d:alldat-dbfpath *alldat*))) ;; (conc *toppath* "/db/main.db"))) (define *last-recalc-ended-time* 0) (define (dashboard:been-changed) - (> (file-modification-time *db-file-path*) *last-db-update-time*)) + (> (file-modification-time (d:alldat-dbfpath *alldat*)) (d:alldat-last-db-update *alldat*))) (define (dashboard:set-db-update-time) - (set! *last-db-update-time* (file-modification-time *db-file-path*))) + (d:alldat-last-db-update-set! *alldat* (file-modification-time (d:alldat-dbfpath *alldat*)))) (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) (> (current-seconds)(+ last-db-update-time 1))))) -(define *monitor-db-path* (conc *dbdir* "/monitor.db")) +(define *monitor-db-path* (conc (d:alldat-dbdir *alldat*) "/monitor.db")) (define *last-monitor-update-time* 0) ;; Force creation of the db in case it isn't already there. (tasks:open-db) (define (dashboard:get-youngest-run-db-mod-time) (handle-exceptions exn (begin - (debug:print 0 "WARNING: error in accessing databases in get-youngest-run-db-mod-time: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 #f "WARNING: error in accessing databases in get-youngest-run-db-mod-time: " ((condition-property-accessor 'exn 'message) exn)) (current-seconds)) ;; something went wrong - just print an error and return current-seconds (apply max (map (lambda (filen) (file-modification-time filen)) - (glob (conc *dbdir* "/*.db")))))) + (glob (conc (d:alldat-dbdir *alldat*) "/*.db")))))) (define (dashboard:run-update x) - (let* ((modtime (dashboard:get-youngest-run-db-mod-time)) ;; (file-modification-time *db-file-path*)) + (let* ((modtime (dashboard:get-youngest-run-db-mod-time)) ;; (file-modification-time (d:alldat-dbfpath *alldat*))) (monitor-modtime (if (file-exists? *monitor-db-path*) (file-modification-time *monitor-db-path*) -1)) (run-update-time (current-seconds)) - (recalc (dashboard:recalc modtime *please-update-buttons* *last-db-update-time*))) - (if (and (eq? *current-tab-number* 0) + (recalc (dashboard:recalc modtime (d:alldat-please-update *alldat*) (d:alldat-last-db-update *alldat*)))) + (if (and (eq? (d:alldat-curr-tab-num *alldat*) 0) (or (> monitor-modtime *last-monitor-update-time*) (> (- run-update-time *last-monitor-update-time*) 5))) ;; update every 1/2 minute just in case (begin (set! *last-monitor-update-time* run-update-time) ;; monitor-modtime) (if dashboard:update-servers-table (dashboard:update-servers-table)))) (if recalc (begin - (case *current-tab-number* + (case (d:alldat-curr-tab-num *alldat*) ((0) (if dashboard:update-summary-tab (dashboard:update-summary-tab))) ((1) ;; The runs table is active - (update-rundat (hash-table-ref/default *searchpatts* "runname" "%") *num-runs* - (hash-table-ref/default *searchpatts* "test-name" "%/%") - ;; (hash-table-ref/default *searchpatts* "item-name" "%") + (update-rundat *alldat* (hash-table-ref/default (d:alldat-searchpatts *alldat*) "runname" "%") (d:alldat-numruns *alldat*) + (hash-table-ref/default (d:alldat-searchpatts *alldat*) "test-name" "%/%") + ;; (hash-table-ref/default (d:alldat-searchpatts *alldat*) "item-name" "%") (let ((res '())) (for-each (lambda (key) (if (not (equal? key "runname")) - (let ((val (hash-table-ref/default *searchpatts* key #f))) + (let ((val (hash-table-ref/default (d:alldat-searchpatts *alldat*) key #f))) (if val (set! res (cons (list key val) res)))))) - *dbkeys*) + (d:alldat-dbkeys *alldat*)) res)) - (update-buttons uidat *num-runs* *num-tests*)) + (update-buttons uidat (d:alldat-numruns *alldat*) (d:alldat-num-tests *alldat*))) ((2) (dashboard:update-run-summary-tab)) + ((3) + (dashboard:update-new-view-tab)) (else - (let ((updater (hash-table-ref/default *updaters* *current-tab-number* #f))) + (let ((updater (hash-table-ref/default (d:alldat-updaters *alldat*) + (d:alldat-curr-tab-num *alldat*) #f))) (if updater (updater))))) - (set! *please-update-buttons* #f) - (set! *last-db-update-time* modtime) - (set! *last-update* run-update-time) + (d:alldat-please-update-set! *alldat* #f) + (d:alldat-last-db-update-set! *alldat* modtime) (set! *last-recalc-ended-time* (current-milliseconds)))))) ;;====================================================================== ;; The heavy lifting starts here ;;====================================================================== @@ -1538,73 +1901,70 @@ ;; ease debugging by loading ~/.dashboardrc (let ((debugcontrolf (conc (get-environment-variable "HOME") "/.dashboardrc"))) (if (file-exists? debugcontrolf) (load debugcontrolf))) -(cond - ((args:get-arg "-run") - (let ((runid (string->number (args:get-arg "-run")))) - (if runid - (begin - (lambda (x) - (on-exit std-exit-procedure) - (examine-run *dbstruct-local* runid))) - (begin - (print "ERROR: runid is not a number " (args:get-arg "-run")) - (exit 1))))) - ((args:get-arg "-test") ;; run-id,test-id - (let* ((dat (let ((d (map string->number (string-split (args:get-arg "-test") ",")))) - (if (> (length d) 1) - d - (list #f #f)))) - (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 run-id,test-id. " (args:get-arg "-test")) - (exit 1))))) - ((args:get-arg "-guimonitor") - (gui-monitor *dbstruct-local*)) - (else - (set! uidat (make-dashboard-buttons *dbstruct-local* *num-runs* *num-tests* *dbkeys*)) - (iup:callback-set! *tim* - "ACTION_CB" - (lambda (x) - (let ((update-is-running #f)) - (mutex-lock! *update-mutex*) - (set! update-is-running *update-is-running*) - (if (not update-is-running) - (set! *update-is-running* #t)) - (mutex-unlock! *update-mutex*) - (if (not update-is-running) - (begin - (dashboard:run-update x) - (mutex-lock! *update-mutex*) - (set! *update-is-running* #f) - (mutex-unlock! *update-mutex*)))) - 1)))) - -(let ((th1 (make-thread (lambda () - (thread-sleep! 1) - (set! *please-update-buttons* #t) - (dashboard:run-update 1)) "update buttons once")) - ;; need to wait for first *update-is-running* #t - ;; (let loop () - ;; (mutex-lock! *update-mutex*) - ;; (if *update-is-running* - ;; (begin - ;; (set! *please-update-buttons* #t) - ;; (mark-for-update) - ;; (print "Did redraw trigger")) "First update after startup") - ;; (mutex-unlock! *update-mutex*) - ;; (thread-sleep! 1) - ;; (if (not *please-update-buttons*) - ;; (loop)))))) - (th2 (make-thread iup:main-loop "Main loop"))) - (thread-start! th1) - (thread-start! th2) - (thread-join! th2)) - -;; (iup:main-loop)(db:close-all *dbstruct-local*) +(define (main) + (common:exit-on-version-changed) + (let* ((runs-sum-dat (d:data-init (make-d:data))) ;; data for run-summary tab + (new-view-dat (d:data-init (make-d:data))) + (data *alldat*)) + (cond + ((args:get-arg "-run") + (let ((runid (string->number (args:get-arg "-run")))) + (if runid + (begin + (lambda (x) + (on-exit std-exit-procedure) + (examine-run (d:alldat-dblocal data) runid))) + (begin + (print "ERROR: runid is not a number " (args:get-arg "-run")) + (exit 1))))) + ((args:get-arg "-test") ;; run-id,test-id + (let* ((dat (let ((d (map string->number (string-split (args:get-arg "-test") ",")))) + (if (> (length d) 1) + d + (list #f #f)))) + (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 #f "INFO: tried to open test with invalid run-id,test-id. " (args:get-arg "-test")) + (exit 1))))) + ((args:get-arg "-guimonitor") + (gui-monitor (d:alldat-dblocal data))) + (else + (set! uidat (make-dashboard-buttons data ;; (d:alldat-dblocal data) + (d:alldat-numruns data) + (d:alldat-num-tests data) + (d:alldat-dbkeys data) + runs-sum-dat new-view-dat)) + (iup:callback-set! *tim* + "ACTION_CB" + (lambda (x) + (let ((update-is-running #f)) + (mutex-lock! (d:alldat-update-mutex data)) + (set! update-is-running (d:alldat-updating data)) + (if (not update-is-running) + (d:alldat-updating-set! data #t)) + (mutex-unlock! (d:alldat-update-mutex data)) + (if (not update-is-running) + (begin + (dashboard:run-update x) + (mutex-lock! (d:alldat-update-mutex data)) + (d:alldat-updating-set! data #f) + (mutex-unlock! (d:alldat-update-mutex data))))) + 1)))) + + (let ((th1 (make-thread (lambda () + (thread-sleep! 1) + (d:alldat-please-update-set! data #t) + (dashboard:run-update 1)) "update buttons once")) + (th2 (make-thread iup:main-loop "Main loop"))) + (thread-start! th1) + (thread-start! th2) + (thread-join! th2)))) + +(main) ADDED datashare-testing/.spublish.config Index: datashare-testing/.spublish.config ================================================================== --- /dev/null +++ datashare-testing/.spublish.config @@ -0,0 +1,8 @@ +[settings] +target-dir #{scheme (create-directory "/tmp/#{getenv USER}/target" #t)} +allowed-users matt mrwellan pjhatwal +allowed-chars [0-9a-zA-Z\-\.]+ +admins matt + +[database] +location /tmp/#{getenv USER} ADDED datashare-testing/.sretrieve.config Index: datashare-testing/.sretrieve.config ================================================================== --- /dev/null +++ datashare-testing/.sretrieve.config @@ -0,0 +1,8 @@ +[settings] +base-dir /tmp/delme_data +allowed-users matt +allowed-chars [0-9a-zA-Z\-\.]+ +allowed-sub-paths [0-9a-zA-Z\-\.]+ +[database] +location #{scheme (create-directory "/tmp/#{getenv USER}" #t)} + ADDED datashare-testing/NOTES Index: datashare-testing/NOTES ================================================================== --- /dev/null +++ datashare-testing/NOTES @@ -0,0 +1,3 @@ +To test sretrieve first publish megatest as v1.60 at least twice to get +iterations 0 and 1 + ADDED datashare-testing/megatest.config Index: datashare-testing/megatest.config ================================================================== --- /dev/null +++ datashare-testing/megatest.config @@ -0,0 +1,4 @@ + +[v1.60] +status released +iteration 1 ADDED datashare-testing/packages.config Index: datashare-testing/packages.config ================================================================== --- /dev/null +++ datashare-testing/packages.config @@ -0,0 +1,4 @@ + +[v1.60] +status released +iteration 1 Index: datashare.scm ================================================================== --- datashare.scm +++ datashare.scm @@ -231,11 +231,11 @@ (dbexists (file-exists? dbpath)) (handler (make-busy-timeout 136000))) (handle-exceptions exn (begin - (debug:print 2 "ERROR: problem accessing db " dbpath + (debug:print 2 #f "ERROR: problem accessing db " dbpath ((condition-property-accessor 'exn 'message) exn)) (exit)) (set! db (sqlite3:open-database dbpath))) (if *db-write-access* (sqlite3:set-busy-handler! db handler)) (if (not dbexists) Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -36,20 +36,27 @@ ;;====================================================================== ;; SQLITE3 HELPERS ;;====================================================================== +(define (db:general-sqlite-error-dump exn stmt run-id params) + (let ((err-status ((condition-property-accessor 'sqlite3 'status #f) exn))) + ;; check for (exn sqlite3) ((condition-property-accessor 'exn 'message) exn) + (print "err-status: " err-status) + (debug:print 0 #f "ERROR: query " stmt " failed, params: " params ", error: " ((condition-property-accessor 'exn 'message) exn)) + (print-call-chain (current-error-port)))) + ;; convert to -inline (define (db:first-result-default db stmt default . params) (handle-exceptions exn (let ((err-status ((condition-property-accessor 'sqlite3 'status #f) exn))) ;; check for (exn sqlite3) ((condition-property-accessor 'exn 'message) exn) (if (eq? err-status 'done) default (begin - (debug:print 0 "ERROR: query " stmt " failed, params: " params ", error: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 #f "ERROR: query " stmt " failed, params: " params ", error: " ((condition-property-accessor 'exn 'message) exn)) (print-call-chain (current-error-port)) default))) (apply sqlite3:first-result db stmt params))) ;; Get/open a database @@ -104,11 +111,11 @@ (db (db:dbdat-get-db dbdat))) (db:delay-if-busy dbdat) (handle-exceptions exn (begin - (debug:print 0 "ERROR: sqlite3 issue in db:with-db, dbstruct=" dbstruct ", run-id=" run-id ", proc=" proc ", params=" params " error: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 #f "ERROR: sqlite3 issue in db:with-db, dbstruct=" dbstruct ", run-id=" run-id ", proc=" proc ", params=" params " error: " ((condition-property-accessor 'exn 'message) exn)) (print-call-chain (current-error-port))) (let ((res (apply proc db params))) (if (vector? dbstruct)(db:done-with dbstruct run-id r/w)) res)))) @@ -138,24 +145,27 @@ ;; NB// #f => return dbdir only ;; (was planned to be; zeroth db with name=main.db) ;; (define (db:dbfile-path run-id) - (let* ((dbdir (or (configf:lookup *configdat* "setup" "dbdir") - (conc (configf:lookup *configdat* "setup" "linktree") "/.db"))) + (let* ((dbdir (db:get-dbdir)) (fname (if run-id (if (eq? run-id 0) "main.db" (conc run-id ".db")) #f))) (handle-exceptions exn (begin - (debug:print 0 "ERROR: Couldn't create path to " dbdir) + (debug:print 0 #f "ERROR: Couldn't create path to " dbdir) (exit 1)) (if (not (directory? dbdir))(create-directory dbdir #t))) (if fname (conc dbdir "/" fname) dbdir))) + +(define (db:get-dbdir) + (or (configf:lookup *configdat* "setup" "dbdir") + (conc (configf:lookup *configdat* "setup" "linktree") "/.db"))) (define (db:set-sync db) (let ((syncprag (configf:lookup *configdat* "setup" "sychronous"))) (sqlite3:execute db (conc "PRAGMA synchronous = " (or syncprag 1) ";")))) @@ -182,11 +192,11 @@ (db:set-sync db) ;; (sqlite3:execute db "PRAGMA synchronous = 0;") (if (not file-exists)(initproc db)) ;; (release-dot-lock fname) db) (begin - (debug:print 2 "WARNING: opening db in non-writable dir " fname) + (debug:print 2 #f "WARNING: opening db in non-writable dir " fname) (sqlite3:open-database fname))))) ;; ) ;; This routine creates the db. It is only called if the db is not already opened ;; (define (db:open-rundb dbstruct run-id #!key (attemptnum 0)(do-not-open #f)) ;; (conc *toppath* "/megatest.db") (car *configinfo*))) @@ -208,11 +218,11 @@ (handle-exceptions exn (begin ;; (release-dot-lock dbpath) (if (> attemptnum 2) - (debug:print 0 "ERROR: tried twice, cannot create/initialize db for run-id " run-id ", at path " dbpath) + (debug:print 0 #f "ERROR: tried twice, cannot create/initialize db for run-id " run-id ", at path " dbpath) (db:open-rundb dbstruct run-id attemptnum (+ attemptnum 1)))) (db:initialize-run-id-db db) (sqlite3:execute db "INSERT OR IGNORE INTO tests (id,run_id,testname,event_time,item_path,state,status) VALUES (?,?,'bogustest',strftime('%s','now'),'nowherepath','DELETED','n/a');" @@ -309,11 +319,11 @@ (maindb (dbr:dbstruct-get-main dbstruct)) (refdb (dbr:dbstruct-get-refdb dbstruct)) (olddb (dbr:dbstruct-get-olddb dbstruct)) ;; (runid (dbr:dbstruct-get-run-id dbstruct)) ) - (debug:print-info 4 "Syncing for run-id: " run-id) + (debug:print-info 4 #f "Syncing for run-id: " run-id) ;; (mutex-lock! *http-mutex*) (if (eq? run-id 0) ;; runid equal to 0 is main.db (if maindb (if (or (not (number? mtime)) @@ -329,11 +339,11 @@ 0)) (begin ;; this can occur when using local access (i.e. not in a server) ;; need a flag to turn it off. ;; - (debug:print 3 "WARNING: call to sync main.db to megatest.db but main not initialized") + (debug:print 3 #f "WARNING: call to sync main.db to megatest.db but main not initialized") 0)) ;; any other runid is a run (if (or (not (number? mtime)) (not (number? stime)) (> mtime stime) @@ -376,39 +386,11 @@ (let ((locdbs (dbr:dbstruct-get-locdbs dbstruct))) (if (hash-table? locdbs) (for-each (lambda (run-id) (db:close-run-db dbstruct run-id)) - (hash-table-keys locdbs)))) - - ;; (let* ((local (dbr:dbstruct-get-local dbstruct)) - ;; (rundb (db:dbdat-get-db (dbr:dbstruct-get-rundb dbstruct)))) - ;; (if local - ;; (for-each - ;; (lambda (dbdat) - ;; (let ((db (db:dbdat-get-db dbdat))) - ;; (if (sqlite3:database? db) - ;; (begin - ;; (sqlite3:interrupt! db) - ;; (sqlite3:finalize! db #t))))) - ;; ;; TODO: Come back to this and rework to delete from hashtable when finalized - ;; (hash-table-values (dbr:dbstruct-get-locdbs dbstruct)))) - ;; (thread-sleep! 3) - ;; (if (and rundb - ;; (sqlite3:database? rundb)) - ;; (handle-exceptions - ;; exn - ;; (begin - ;; (debug:print 0 "WARNING: database files may not have been closed correctly. Consider running -cleanup-db") - ;; (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) - ;; (debug:print 0 " db: " rundb) - ;; (print-call-chain (current-error-port)) - ;; #f) - ;; (sqlite3:interrupt! rundb) - ;; (sqlite3:finalize! rundb #t)))) - ;; ;; (mutex-unlock! *db-sync-mutex*) - ) + (hash-table-keys locdbs))))) (define (db:open-inmem-db) (let* ((db (sqlite3:open-database ":memory:")) (handler (make-busy-timeout 3600))) (sqlite3:set-busy-handler! db handler) @@ -499,16 +481,16 @@ (dbdir (pathname-directory dbpath)) (fname (pathname-strip-directory dbpath)) (fnamejnl (conc fname "-journal")) (tmpname (conc fname "." (current-process-id))) (tmpjnl (conc fnamejnl "." (current-process-id)))) - (debug:print 0 "ERROR: " fname " appears corrupted. Making backup \"old/" fname "\"") + (debug:print 0 #f "ERROR: " fname " appears corrupted. Making backup \"old/" fname "\"") (system (conc "cd " dbdir ";mkdir -p old;cat " fname " > old/" tmpname)) (system (conc "rm -f " dbpath)) (if (file-exists? fnamejnl) (begin - (debug:print 0 "ERROR: " fnamejnl " found, moving it to old dir as " tmpjnl) + (debug:print 0 #f "ERROR: " fnamejnl " found, moving it to old dir as " tmpjnl) (system (conc "cd " dbdir ";mkdir -p old;cat " fnamejnl " > old/" tmpjnl)) (system (conc "rm -f " dbdir "/" fnamejnl)))) ;; attempt to recreate database (system (conc "cd " dbdir ";sqlite3 old/" tmpname " .dump | sqlite3 " fname)))) @@ -517,14 +499,14 @@ ;; (define (db:repair-db dbdat #!key (numtries 1)) (let* ((dbpath (db:dbdat-get-path dbdat)) (dbdir (pathname-directory dbpath)) (fname (pathname-strip-directory dbpath))) - (debug:print-info 0 "Checking db " dbpath " for errors.") + (debug:print-info 0 #f "Checking db " dbpath " for errors.") (cond ((not (file-write-access? dbdir)) - (debug:print 0 "WARNING: can't write to " dbdir ", can't fix " fname) + (debug:print 0 #f "WARNING: can't write to " dbdir ", can't fix " fname) #f) ;; handle special cases, megatest.db and monitor.db ;; ;; NOPE: apply this same approach to all db files @@ -535,12 +517,12 @@ (begin ;; (db:move-and-recreate-db dbdat) (if (> numtries 0) (db:repair-db dbdat numtries: (- numtries 1)) #f) - (debug:print 0 "FATAL: file " dbpath " was found corrupted, an attempt to fix has been made but you must start over.") - (debug:print 0 + (debug:print 0 #f "FATAL: file " dbpath " was found corrupted, an attempt to fix has been made but you must start over.") + (debug:print 0 #f " check the following:\n" " 1. full directories, look in ~/ /tmp and " dbdir "\n" " 2. write access to " dbdir "\n\n" " if the automatic recovery failed you may be able to recover data by doing \"" (if (member fname '("megatest.db" "monitor.db")) @@ -573,22 +555,22 @@ (mutex-lock! *db-sync-mutex*) (handle-exceptions exn (begin (mutex-unlock! *db-sync-mutex*) - (debug:print 0 "EXCEPTION: database probably overloaded or unreadable in db:sync-tables.") + (debug:print 0 #f "EXCEPTION: database probably overloaded or unreadable in db:sync-tables.") (print-call-chain (current-error-port)) - (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 #f " message: " ((condition-property-accessor 'exn 'message) exn)) (print "exn=" (condition->list exn)) - (debug:print 0 " status: " ((condition-property-accessor 'sqlite3 'status) exn)) - (debug:print 0 " src db: " (db:dbdat-get-path fromdb)) + (debug:print 0 #f " status: " ((condition-property-accessor 'sqlite3 'status) exn)) + (debug:print 0 #f " src db: " (db:dbdat-get-path fromdb)) (for-each (lambda (dbdat) (let ((dbpath (db:dbdat-get-path dbdat))) - (debug:print 0 " dbpath: " dbpath) + (debug:print 0 #f " dbpath: " dbpath) (if (not (db:repair-db dbdat)) (begin - (debug:print 0 "ERROR: Failed to rebuild " dbpath ", exiting now.") + (debug:print 0 #f "ERROR: Failed to rebuild " dbpath ", exiting now.") (exit))))) (cons todb slave-dbs)) 0) ;; (if *server-run* ;; we are inside a server, throw a sync-failed error @@ -599,16 +581,16 @@ ;; (set! *time-to-exit* #t) ;; let watch dog know that it is time to die. ;; (tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "shutting-down") ;; (portlogger:open-run-close portlogger:set-port port "released") ;; (exit 1))) (cond - ((not fromdb) (debug:print 3 "WARNING: db:sync-tables called with fromdb missing") -1) - ((not todb) (debug:print 3 "WARNING: db:sync-tables called with todb missing") -2) + ((not fromdb) (debug:print 3 #f "WARNING: db:sync-tables called with fromdb missing") -1) + ((not todb) (debug:print 3 #f "WARNING: db:sync-tables called with todb missing") -2) ((not (sqlite3:database? (db:dbdat-get-db fromdb))) - (debug:print 0 "ERROR: db:sync-tables called with fromdb not a database " fromdb) -3) + (debug:print 0 #f "ERROR: db:sync-tables called with fromdb not a database " fromdb) -3) ((not (sqlite3:database? (db:dbdat-get-db todb))) - (debug:print 0 "ERROR: db:sync-tables called with todb not a database " todb) -4) + (debug:print 0 #f "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)) @@ -652,11 +634,12 @@ ;; tack on remaining records in fromdat (if (not (null? fromdat)) (set! fromdats (cons fromdat fromdats))) - (debug:print-info 4 "found " totrecords " records to sync") + (if (common:low-noise-print 120 "sync-records") + (debug:print-info 4 #f "found " totrecords " records to sync")) ;; read the target table (sqlite3:for-each-row (lambda (a . b) (hash-table-set! todat a (apply vector a b))) @@ -695,19 +678,19 @@ fromdats) (sqlite3:finalize! stmth))) (append (list todb) slave-dbs)))) tbls) (let* ((runtime (- (current-milliseconds) start-time)) - (should-print (common:low-noise-print 30 "db sync" (> runtime 500)))) ;; low and high sync times treated as separate. - (if should-print (debug:print 0 "INFO: db sync, total run time " runtime " ms")) + (should-print (common:low-noise-print 120 "db sync" (> runtime 500)))) ;; low and high sync times treated as separate. + (if should-print (debug:print 3 #f "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) - (if should-print (debug:print 0 (format #f " ~10a ~5a" tblname count)))))) + (if should-print (debug:print 0 #f (format #f " ~10a ~5a" tblname count)))))) (sort (hash-table->alist numrecs)(lambda (a b)(> (cdr a)(cdr b)))))) tot-count))) (mutex-unlock! *db-sync-mutex*))) ;; options: @@ -720,11 +703,11 @@ ;; 'closeall - close all opened dbs ;; ;; run-ids: '(1 2 3 ...) or #f (for all) ;; (define (db:multi-db-sync run-ids . options) - (let* ((toppath (launch:setup-for-run)) + (let* ((toppath (launch:setup)) (dbstruct (if toppath (make-dbr:dbstruct path: toppath) #f)) (mtdb (if toppath (db:open-megatest-db))) (allow-cleanup (if run-ids #f #t)) (run-ids (if run-ids run-ids @@ -764,72 +747,136 @@ (for-each (lambda (run-id) (db:delay-if-busy mtdb) (let ((testrecs (db:get-all-tests-info-by-run-id mtdb run-id)) (dbstruct (if toppath (make-dbr:dbstruct path: toppath local: #t) #f))) - (debug:print 0 "INFO: Propagating " (length testrecs) " records for run-id=" run-id " to run specific db") + (debug:print 0 #f "INFO: Propagating " (length testrecs) " records for run-id=" run-id " to run specific db") (db:replace-test-records dbstruct run-id testrecs) (sqlite3:finalize! (db:dbdat-get-db (dbr:dbstruct-get-rundb dbstruct))))) run-ids))) ;; now ensure all newdb data are synced to megatest.db ;; do not use the run-ids list passed in to the function ;; (if (member 'new2old options) (let* ((maindb (make-dbr:dbstruct path: toppath local: #t)) - (src-run-ids (db:get-all-run-ids (db:dbdat-get-db (db:get-db maindb 0)))) + (src-run-ids (if run-ids run-ids (db:get-all-run-ids (db:dbdat-get-db (db:get-db maindb 0))))) (all-run-ids (sort (delete-duplicates (cons 0 src-run-ids)) <)) (count 1) (total (length all-run-ids)) (dead-runs '())) (for-each (lambda (run-id) - (debug:print 0 "Processing run " (if (eq? run-id 0) " main.db " run-id) ", " count " of " total) + (debug:print 0 #f "Processing run " (if (eq? run-id 0) " main.db " run-id) ", " count " of " total) (set! count (+ count 1)) (let* ((fromdb (if toppath (make-dbr:dbstruct path: toppath local: #t) #f)) (frundb (db:dbdat-get-db (db:get-db fromdb run-id)))) ;; (db:delay-if-busy frundb) ;; (db:delay-if-busy mtdb) ;; (db:clean-up frundb) (if (eq? run-id 0) - (begin + (let ((maindb (db:dbdat-get-db (db:get-db fromdb #f)))) (db:sync-tables (db:sync-main-list dbstruct) (db:get-db fromdb #f) mtdb) - (set! dead-runs (db:clean-up-maindb (db:get-db fromdb #f)))) + (set! dead-runs (db:clean-up-maindb (db:get-db fromdb #f))) + ;; + ;; Feb 18, 2016: add field last_update to runs table + ;; + ;; remove all these some time after september 2016 (added in v1.6031 + ;; + (handle-exceptions + exn + (if (string-match ".*duplicate.*" ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 #f "Column last_update already added to runs table") + (db:general-sqlite-error-dump exn "alter table runs ..." run-id "none")) + (sqlite3:execute + maindb + "ALTER TABLE runs ADD COLUMN last_update INTEGER DEFAULT 0")) + ;; these schema changes don't need exception handling + (sqlite3:execute + maindb + "CREATE TRIGGER IF NOT EXISTS update_runs_trigger AFTER UPDATE ON runs + FOR EACH ROW + BEGIN + UPDATE runs SET last_update=(strftime('%s','now')) + WHERE id=old.id; + END;") + (sqlite3:execute maindb "CREATE TABLE IF NOT EXISTS run_stats ( + id INTEGER PRIMARY KEY, + run_id INTEGER, + state TEXT, + status TEXT, + count INTEGER, + last_update INTEGER DEFAULT (strftime('%s','now')))") + (sqlite3:execute maindb "CREATE TRIGGER IF NOT EXISTS update_run_stats_trigger AFTER UPDATE ON run_stats + FOR EACH ROW + BEGIN + UPDATE run_stats SET last_update=(strftime('%s','now')) + WHERE id=old.id; + END;") + ) (begin ;; NB// must sync first to ensure deleted tests get marked as such in megatest.db (db:sync-tables db:sync-tests-only (db:get-db fromdb run-id) mtdb) (db:clean-up-rundb (db:get-db fromdb run-id)) - )))) + ;; + ;; Feb 18, 2016: add field last_update to tests, test_steps and test_data + ;; + ;; remove this some time after September 2016 (added in version v1.6031 + ;; + (for-each + (lambda (table-name) + (handle-exceptions + exn + (if (string-match ".*duplicate.*" ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 #f "Column last_update already added to " table-name " table") + (db:general-sqlite-error-dump exn "alter table " table-name " ..." #f "none")) + (sqlite3:execute + frundb + (conc "ALTER TABLE " table-name " ADD COLUMN last_update INTEGER DEFAULT 0"))) + (sqlite3:execute + frundb + (conc "DROP TRIGGER IF EXISTS update_" table-name "_trigger;")) + (sqlite3:execute + frundb + (conc "CREATE TRIGGER IF NOT EXISTS update_" table-name "_trigger AFTER UPDATE ON " table-name " + FOR EACH ROW + BEGIN + UPDATE " table-name " SET last_update=(strftime('%s','now')) + WHERE id=old.id; + END;")) + ) + '("tests" "test_steps" "test_data")))))) all-run-ids) ;; removed deleted runs (let ((dbdir (tasks:get-task-db-path))) (for-each (lambda (run-id) (let ((fullname (conc dbdir "/" run-id ".db"))) (if (file-exists? fullname) (begin - (debug:print 0 "Removing database file for deleted run " fullname) + (debug:print 0 #f "Removing database file for deleted run " fullname) (delete-file fullname))))) dead-runs)))) + ;; (db:close-all dbstruct) ;; (sqlite3:finalize! mdb) )) ;; 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) + (debug:print-info 11 #f "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 ((pair? idb) (db:dbdat-get-db idb)) ((sqlite3:database? idb) idb) - ((not idb) (debug:print 0 "ERROR: cannot open-run-close with #f anymore")) + ((not idb) (debug:print 0 #f "ERROR: cannot open-run-close with #f anymore")) ((procedure? idb) (idb)) - (else (debug:print 0 "ERROR: cannot open-run-close with #f anymore")))) + (else (debug:print 0 #f "ERROR: cannot open-run-close with #f anymore")))) (res #f)) (set! res (apply proc db params)) (if (not idb)(sqlite3:finalize! dbstruct)) - (debug:print-info 11 "open-run-close-no-exception-handling END" ) + (debug:print-info 11 #f "open-run-close-no-exception-handling END" ) res) #f)) (define (open-run-close-exception-handling proc idb . params) (handle-exceptions @@ -838,17 +885,17 @@ (err-status ((condition-property-accessor 'sqlite3 'status #f) exn))) (case err-status ((busy) (thread-sleep! sleep-time)) (else - (debug:print 0 "EXCEPTION: database probably overloaded or unreadable.") - (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 #f "EXCEPTION: database probably overloaded or unreadable.") + (debug:print 0 #f " message: " ((condition-property-accessor 'exn 'message) exn)) (print "exn=" (condition->list exn)) - (debug:print 0 " status: " ((condition-property-accessor 'sqlite3 'status) exn)) + (debug:print 0 #f " status: " ((condition-property-accessor 'sqlite3 'status) exn)) (print-call-chain (current-error-port)) (thread-sleep! sleep-time) - (debug:print-info 0 "trying db call one more time....this may never recover, if necessary kill process " (current-process-id) " on host " (get-host-name) " to clean up"))) + (debug:print-info 0 #f "trying db call one more time....this may never recover, if necessary kill process " (current-process-id) " on host " (get-host-name) " to clean up"))) (apply open-run-close-exception-handling proc idb params)) (apply open-run-close-no-exception-handling proc idb params))) ;; (define open-run-close (define open-run-close open-run-close-exception-handling) @@ -888,11 +935,31 @@ owner TEXT DEFAULT '', event_time TIMESTAMP DEFAULT (strftime('%s','now')), comment TEXT DEFAULT '', fail_count INTEGER DEFAULT 0, pass_count INTEGER DEFAULT 0, + last_update INTEGER DEFAULT (strftime('%s','now')), CONSTRAINT runsconstraint UNIQUE (runname" (if havekeys "," "") keystr "));")) + (sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_runs_trigger AFTER UPDATE ON runs + FOR EACH ROW + BEGIN + UPDATE runs SET last_update=(strftime('%s','now')) + WHERE id=old.id; + END;") + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS run_stats ( + id INTEGER PRIMARY KEY, + run_id INTEGER, + state TEXT, + status TEXT, + count INTEGER, + last_update INTEGER DEFAULT (strftime('%s','now')))") + (sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_run_stats_trigger AFTER UPDATE ON run_stats + FOR EACH ROW + BEGIN + UPDATE run_stats SET last_update=(strftime('%s','now')) + WHERE id=old.id; + END;") (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_meta ( id INTEGER PRIMARY KEY, testname TEXT DEFAULT '', author TEXT DEFAULT '', owner TEXT DEFAULT '', @@ -948,12 +1015,12 @@ (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"))))) + (sqlite3:execute db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" "MEGATEST_VERSION" (common:version-signature)) + (debug:print-info 11 #f "db:initialize END"))))) ;;====================================================================== ;; R U N S P E C I F I C D B ;;====================================================================== @@ -981,31 +1048,37 @@ 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=archive block id where test data can be found + last_update INTEGER DEFAULT (strftime('%s','now')), CONSTRAINT testsconstraint UNIQUE (run_id, testname, item_path));") (sqlite3:execute db "CREATE INDEX IF NOT EXISTS tests_index ON tests (run_id, testname, item_path);") + (sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_tests_trigger AFTER UPDATE ON tests + FOR EACH ROW + BEGIN + UPDATE tests SET last_update=(strftime('%s','now')) + WHERE id=old.id; + END;") (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_steps (id INTEGER PRIMARY KEY, test_id INTEGER, stepname TEXT, state TEXT DEFAULT 'NOT_STARTED', status TEXT DEFAULT 'n/a', event_time TIMESTAMP, comment TEXT DEFAULT '', logfile TEXT DEFAULT '', + last_update INTEGER DEFAULT (strftime('%s','now')), CONSTRAINT test_steps_constraint UNIQUE (test_id,stepname,state));") - ;; (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 INDEX IF NOT EXISTS teststeps_index ON tests (run_id, testname, item_path);") + (sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_teststeps_trigger AFTER UPDATE ON test_steps + FOR EACH ROW + BEGIN + UPDATE test_steps SET last_update=(strftime('%s','now')) + WHERE id=old.id; + END;") (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_data (id INTEGER PRIMARY KEY, test_id INTEGER, category TEXT DEFAULT '', variable TEXT, value REAL, @@ -1013,13 +1086,19 @@ tol REAL, units TEXT, comment TEXT DEFAULT '', status TEXT DEFAULT 'n/a', type TEXT DEFAULT '', + last_update INTEGER DEFAULT (strftime('%s','now')), CONSTRAINT test_data_constraint UNIQUE (test_id,category,variable));") - ;; Why use FULL here? This data is not that critical - ;; (sqlite3:execute db "PRAGMA synchronous = FULL;") + (sqlite3:execute db "CREATE INDEX IF NOT EXISTS test_data_index ON test_data (test_id);") + (sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_test_data_trigger AFTER UPDATE ON test_data + FOR EACH ROW + BEGIN + UPDATE test_data SET last_update=(strftime('%s','now')) + WHERE id=old.id; + 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, @@ -1229,11 +1308,11 @@ (if (and (equal? uname "n/a") (equal? item-path "")) ;; this is a toplevel test ;; what to do with toplevel? call rollup? (begin (set! toplevels (cons (list test-id run-dir uname testname item-path run-id) toplevels)) - (debug:print-info 0 "Found old toplevel test in RUNNING state, test-id=" test-id)) + (debug:print-info 0 #f "Found old toplevel test in RUNNING state, test-id=" test-id)) (set! incompleted (cons (list test-id run-dir uname testname item-path run-id) incompleted)))) db "SELECT id,rundir,uname,testname,item_path FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > (run_duration + ?) AND state IN ('RUNNING','REMOTEHOSTSTART');" run-id deadtime) @@ -1249,11 +1328,11 @@ (set! oldlaunched (cons (list test-id run-dir uname testname item-path run-id) oldlaunched)))) db "SELECT id,rundir,uname,testname,item_path FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > 86400 AND state IN ('LAUNCHED');" run-id) - (debug:print-info 18 "Found " (length oldlaunched) " old LAUNCHED items, " (length toplevels) " old LAUNCHED toplevel tests and " (length incompleted) " tests marked RUNNING but apparently dead.") + (debug:print-info 18 #f "Found " (length oldlaunched) " old LAUNCHED items, " (length toplevels) " old LAUNCHED toplevel tests and " (length incompleted) " tests marked RUNNING but apparently dead.") (if (and (null? incompleted) (null? oldlaunched) (null? toplevels)) #f #t))) @@ -1288,11 +1367,11 @@ (if (and (equal? uname "n/a") (equal? item-path "")) ;; this is a toplevel test ;; what to do with toplevel? call rollup? (begin (set! toplevels (cons (list test-id run-dir uname testname item-path run-id) toplevels)) - (debug:print-info 0 "Found old toplevel test in RUNNING state, test-id=" test-id)) + (debug:print-info 0 #f "Found old toplevel test in RUNNING state, test-id=" test-id)) (set! incompleted (cons (list test-id run-dir uname testname item-path run-id) incompleted)))) db "SELECT id,rundir,uname,testname,item_path FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > (run_duration + ?) AND state IN ('RUNNING','REMOTEHOSTSTART');" run-id deadtime) @@ -1308,11 +1387,11 @@ (set! oldlaunched (cons (list test-id run-dir uname testname item-path run-id) oldlaunched)))) db "SELECT id,rundir,uname,testname,item_path FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > 86400 AND state IN ('LAUNCHED');" run-id) - (debug:print-info 18 "Found " (length oldlaunched) " old LAUNCHED items, " (length toplevels) " old LAUNCHED toplevel tests and " (length incompleted) " tests marked RUNNING but apparently dead.") + (debug:print-info 18 #f "Found " (length oldlaunched) " old LAUNCHED items, " (length toplevels) " old LAUNCHED toplevel tests and " (length incompleted) " tests marked RUNNING but apparently dead.") ;; These are defunct tests, do not do all the overhead of set-state-status. Force them to INCOMPLETE. ;; (db:delay-if-busy dbdat) (let* (;; (min-incompleted (filter (lambda (x) @@ -1324,11 +1403,11 @@ ;; incompleted)) (min-incompleted-ids (map car incompleted)) ;; do 'em all (all-ids (append min-incompleted-ids (map car oldlaunched)))) (if (> (length all-ids) 0) (begin - (debug:print 0 "WARNING: Marking test(s); " (string-intersperse (map conc all-ids) ", ") " as INCOMPLETE") + (debug:print 0 #f "WARNING: Marking test(s); " (string-intersperse (map conc all-ids) ", ") " as INCOMPLETE") (sqlite3:execute db (conc "UPDATE tests SET state='INCOMPLETE' WHERE id IN (" (string-intersperse (map conc all-ids) ",") ");"))))) @@ -1357,11 +1436,11 @@ ;; 2. Look at run records ;; a. If have tests that are not deleted, set state='unknown' ;; b. .... ;; (define (db:clean-up dbdat) - ;; (debug:print 0 "WARNING: db clean up not fully ported to v1.60, cleanup action will be on megatest.db") + ;; (debug:print 0 #f "WARNING: db clean up not fully ported to v1.60, cleanup action will be on megatest.db") (let* ((db (db:dbdat-get-db dbdat)) (count-stmt (sqlite3:prepare db "SELECT (SELECT count(id) FROM tests)+(SELECT count(id) FROM runs);")) (statements (map (lambda (stmt) (sqlite3:prepare db stmt)) @@ -1380,15 +1459,15 @@ (db:delay-if-busy dbdat) (sqlite3:with-transaction db (lambda () (sqlite3:for-each-row (lambda (tot) - (debug:print-info 0 "Records count before clean: " tot)) + (debug:print-info 0 #f "Records count before clean: " tot)) count-stmt) (map sqlite3:execute statements) (sqlite3:for-each-row (lambda (tot) - (debug:print-info 0 "Records count after clean: " tot)) + (debug:print-info 0 #f "Records count after clean: " tot)) count-stmt))) (map sqlite3:finalize! statements) (sqlite3:finalize! count-stmt) ;; (db:find-and-mark-incomplete db) (db:delay-if-busy dbdat) @@ -1404,11 +1483,11 @@ ;; 2. Look at run records ;; a. If have tests that are not deleted, set state='unknown' ;; b. .... ;; (define (db:clean-up-rundb dbdat) - ;; (debug:print 0 "WARNING: db clean up not fully ported to v1.60, cleanup action will be on megatest.db") + ;; (debug:print 0 #f "WARNING: db clean up not fully ported to v1.60, cleanup action will be on megatest.db") (let* ((db (db:dbdat-get-db dbdat)) (count-stmt (sqlite3:prepare db "SELECT (SELECT count(id) FROM tests);")) (statements (map (lambda (stmt) (sqlite3:prepare db stmt)) @@ -1421,15 +1500,15 @@ (db:delay-if-busy dbdat) (sqlite3:with-transaction db (lambda () (sqlite3:for-each-row (lambda (tot) - (debug:print-info 0 "Records count before clean: " tot)) + (debug:print-info 0 #f "Records count before clean: " tot)) count-stmt) (map sqlite3:execute statements) (sqlite3:for-each-row (lambda (tot) - (debug:print-info 0 "Records count after clean: " tot)) + (debug:print-info 0 #f "Records count after clean: " tot)) count-stmt))) (map sqlite3:finalize! statements) (sqlite3:finalize! count-stmt) ;; (db:find-and-mark-incomplete db) (db:delay-if-busy dbdat) @@ -1445,11 +1524,11 @@ ;; 2. Look at run records ;; a. If have tests that are not deleted, set state='unknown' ;; b. .... ;; (define (db:clean-up-maindb dbdat) - ;; (debug:print 0 "WARNING: db clean up not fully ported to v1.60, cleanup action will be on megatest.db") + ;; (debug:print 0 #f "WARNING: db clean up not fully ported to v1.60, cleanup action will be on megatest.db") (let* ((db (db:dbdat-get-db dbdat)) (count-stmt (sqlite3:prepare db "SELECT (SELECT count(id) FROM runs);")) (statements (map (lambda (stmt) (sqlite3:prepare db stmt)) @@ -1468,15 +1547,15 @@ (db:delay-if-busy dbdat) (sqlite3:with-transaction db (lambda () (sqlite3:for-each-row (lambda (tot) - (debug:print-info 0 "Records count before clean: " tot)) + (debug:print-info 0 #f "Records count before clean: " tot)) count-stmt) (map sqlite3:execute statements) (sqlite3:for-each-row (lambda (tot) - (debug:print-info 0 "Records count after clean: " tot)) + (debug:print-info 0 #f "Records count after clean: " tot)) count-stmt))) (map sqlite3:finalize! statements) (sqlite3:finalize! count-stmt) ;; (db:find-and-mark-incomplete db) (db:delay-if-busy dbdat) @@ -1488,43 +1567,40 @@ ;;====================================================================== ;; returns number if string->number is successful, string otherwise ;; also updates *global-delta* ;; -;; 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) + (let* ((res #f) (dbdat (db:get-db dbstruct #f)) (db (db:dbdat-get-db dbdat))) - (db:delay-if-busy dbdat) (sqlite3:for-each-row (lambda (val) (set! res val)) db "SELECT val FROM metadat WHERE var=?;" var) ;; convert to number if can (if (string? res) (let ((valnum (string->number res))) (if valnum (set! res valnum)))) - ;; scale by 10, average with current value. - (set! *global-delta* (/ (+ *global-delta* (* (- (current-milliseconds) start-ms) - (if throttle throttle 0.01))) - 2)) - (if (> (abs (- *last-global-delta-printed* *global-delta*)) 0.08) ;; don't print all the time, only if it changes a bit - (begin - (debug:print-info 4 "launch throttle factor=" *global-delta*) - (set! *last-global-delta-printed* *global-delta*))) res)) + +;; This was part of db:get-var. It was used to estimate the load on +;; the database files. +;; +;; 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 4 #f "launch throttle factor=" *global-delta*) +;; (set! *last-global-delta-printed* *global-delta*))) (define (db:set-var dbstruct var val) - (let ((dbdat (db:get-db dbstruct #f)) - (db (db:dbdat-get-db dbdat))) - (db:delay-if-busy dbdat) + (let* ((dbdat (db:get-db dbstruct #f)) + (db (db:dbdat-get-db dbdat))) (sqlite3:execute db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" var val))) (define (db:del-var dbstruct var) ;; (db:delay-if-busy) (db:with-db dbstruct #f #t @@ -1633,12 +1709,12 @@ (andstr (if (> (length keys) 0) " AND " "")) (valslots (keys->valslots keys)) ;; ?,?,? ... (allvals (append (list runname state status user) (map cadr keyvals))) (qryvals (append (list runname) (map cadr keyvals))) (key=?str (string-intersperse (map (lambda (k)(conc k "=?")) keys) " AND "))) - (debug:print 3 "keys: " keys " allvals: " allvals " keyvals: " keyvals " key=?str is " key=?str) - (debug:print 2 "NOTE: using target " (string-intersperse (map cadr keyvals) "/") " for this run") + (debug:print 3 #f "keys: " keys " allvals: " allvals " keyvals: " keyvals " key=?str is " key=?str) + (debug:print 2 #f "NOTE: using target " (string-intersperse (map cadr keyvals) "/") " for this run") (if (and runname (null? (filter (lambda (x)(not x)) keyvals))) ;; there must be a better way to "apply and" (let ((res #f)) (db:delay-if-busy dbdat) (apply sqlite3:execute db (conc "INSERT OR IGNORE INTO runs (runname,state,status,owner,event_time" comma keystr ") VALUES (?,?,?,?,strftime('%s','now')" comma valslots ");") allvals) @@ -1646,18 +1722,18 @@ (apply sqlite3:for-each-row (lambda (id) (set! res id)) db (let ((qry (conc "SELECT id FROM runs WHERE (runname=? " andstr key=?str ");"))) - ;(debug:print 4 "qry: " qry) + ;(debug:print 4 #f "qry: " qry) qry) qryvals) (db:delay-if-busy dbdat) (sqlite3:execute db "UPDATE runs SET state=?,status=?,event_time=strftime('%s','now') WHERE id=? AND state='deleted';" state status res) res) (begin - (debug:print 0 "ERROR: Called without all necessary keys") + (debug:print 0 #f "ERROR: Called without all necessary keys") #f)))) ;; replace header and keystr with a call to runs:get-std-run-fields ;; ;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") ) @@ -1687,22 +1763,24 @@ (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) + (debug:print-info 11 #f "db:get-runs START qrystr: " qrystr " keypatts: " keypatts " offset: " offset " limit: " count) (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) + (debug:print-info 11 #f "db:get-runs END qrystr: " qrystr " keypatts: " keypatts " offset: " offset " limit: " count) (vector header res))) +;; TODO: Switch this to use max(update_time) from each run db? Then if using a server there is no disk traffic (using inmem db) +;; (define (db:get-changed-run-ids since-time) (let* ((dbdir (db:dbfile-path #f)) ;; (configf:lookup *configdat* "setup" "dbdir")) (alldbs (glob (conc dbdir "/[0-9]*.db"))) (changed (filter (lambda (dbfile) (> (file-modification-time dbfile) since-time)) @@ -1711,59 +1789,14 @@ (map (lambda (dbfile) (let* ((res (string-match ".*\\/(\\d)*\\.db" dbfile))) (if res (string->number (cadr res)) (begin - (debug:print 2 "WARNING: Failed to process " dbfile " for run-id") + (debug:print 2 #f "WARNING: Failed to process " dbfile " for run-id") 0)))) changed)))) -;; 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-rows runinfo)) -;; to extract info from the structure returned -;; -;; NOTE: THIS IS COMPLETELY UNFINISHED. IT GOES WITH rmt:get-get-paths-matching-keynames -;; -;; (define (db:get-run-ids-matching dbstruct keynames target res) -;; ;; (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 "") -;; (runwildtype (if (substring-index "%" runnamepatt) "like" "glob")) -;; (qry-str #f) -;; (keyvals (if targpatt (keys:target->keyval keys targpatt) '()))) -;; (for-each (lambda (keyval) -;; (let* ((key (car keyval)) -;; (patt (cadr keyval)) -;; (fulkey (conc ":" key)) -;; (wildtype (if (substring-index "%" patt) "like" "glob"))) -;; (if patt -;; (set! key-patt (conc key-patt " AND " key " " wildtype " '" patt "'")) -;; (begin -;; (debug:print 0 "ERROR: searching for runs with no pattern set for " fulkey) -;; (exit 6))))) -;; keyvals) -;; (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) -;; (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))) - ;; Get all targets from the db ;; (define (db:get-targets dbstruct) (let* ((res '()) (keys (db:get-keys dbstruct)) @@ -1783,11 +1816,11 @@ (begin (hash-table-set! seen targ #t) (set! res (cons (apply vector targ) res)))))) db qrystr) - (debug:print-info 11 "db:get-targets END qrystr: " qrystr ) + (debug:print-info 11 #f "db:get-targets END qrystr: " qrystr ) (vector header res))))) ;; just get count of runs (define (db:get-num-runs dbstruct runpatt) (db:with-db @@ -1794,18 +1827,73 @@ dbstruct #f #f (lambda (db) (let ((numruns 0)) - (debug:print-info 11 "db:get-num-runs START " runpatt) + (debug:print-info 11 #f "db:get-num-runs START " runpatt) (sqlite3:for-each-row (lambda (count) (set! numruns count)) db "SELECT COUNT(id) FROM runs WHERE runname LIKE ? AND state != 'deleted';" runpatt) - (debug:print-info 11 "db:get-num-runs END " runpatt) + (debug:print-info 11 #f "db:get-num-runs END " runpatt) numruns)))) + +;; (sqlite3#fold-row proc3670 init3671 db-or-stmt3672 . params3673)> +;; +(define (db:get-raw-run-stats dbstruct run-id) + (db:with-db + dbstruct + run-id + #f + (lambda (db) + (sqlite3:fold-row + (lambda (res state status count) + (cons (list state status count) res)) + '() + db + "SELECT state,status,count(id) AS count FROM tests WHERE run_id=? AND NOT(uname='n/a' AND item_path='') GROUP BY state,status;;" + run-id)))) + +;; Update run_stats for given run_id +;; input data is a list (state status count) +;; +(define (db:update-run-stats dbstruct run-id stats) + (db:with-db + dbstruct + #f + #f + (lambda (db) + ;; remove previous data + (let* ((stmt1 (sqlite3:prepare db "DELETE FROM run_stats WHERE run_id=? AND state=? AND status=?;")) + (stmt2 (sqlite3:prepare db "INSERT INTO run_stats (run_id,state,status,count) VALUES (?,?,?,?);")) + (res + (sqlite3:with-transaction + db + (lambda () + (for-each + (lambda (dat) + (sqlite3:execute stmt1 run-id (car dat)(cadr dat)) + (apply sqlite3:execute stmt2 run-id dat)) + stats))))) + (sqlite3:finalize! stmt1) + (sqlite3:finalize! stmt2) + res)))) + +(define (db:get-main-run-stats dbstruct run-id) + (db:with-db + dbstruct + #f ;; this data comes from main + #f + (lambda (db) + (sqlite3:fold-row + (lambda (res state status count) + (cons (list state status count) res)) + '() + db + "SELECT state,status,count FROM run_stats WHERE run_id=? AND run_id IN (SELECT id FROM runs WHERE state NOT IN ('DELETED','deleted'));" + run-id)))) (define (db:get-all-run-ids dbstruct) (db:with-db dbstruct #f @@ -1890,18 +1978,18 @@ (fulkey (conc ":" key)) (wildtype (if (substring-index "%" patt) "like" "glob"))) (if patt (set! key-patt (conc key-patt " AND " key " " wildtype " '" patt "'")) (begin - (debug:print 0 "ERROR: searching for runs with no pattern set for " fulkey) + (debug:print 0 #f "ERROR: searching for runs with no pattern set for " fulkey) (exit 6))))) keyvals) (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) + (debug:print-info 4 #f "runs:get-runs-by-patt qry=" 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))) @@ -1920,19 +2008,19 @@ (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) + (debug:print-info 11 #f "db:get-run-info run-id: " run-id " header: " header " keystr: " keystr) (db:delay-if-busy dbdat) (sqlite3:for-each-row (lambda (a . x) (set! res (apply vector a x))) db (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) + (debug:print-info 11 #f "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 dbstruct run-id comment) @@ -1977,11 +2065,11 @@ "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'),?);" user (conc newlockval " " run-id)) - (debug:print-info 1 "" newlockval " run number " run-id))))) + (debug:print-info 1 #f "" newlockval " run number " run-id))))) (define (db:set-run-status dbstruct run-id status msg) (let* ((dbdat (db:get-db dbstruct #f)) (db (db:dbdat-get-db dbdat))) (db:delay-if-busy dbdat) @@ -2074,14 +2162,17 @@ ;; 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 dbstruct run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals) +;; mode: +;; 'dashboard - use state = 'COMPLETED' AND status in ( statuses ) OR state in ( states ) +;; +(define (db:get-tests-for-run dbstruct run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals last-update mode) (if (not (number? run-id)) (begin ;; no need to treat this as an error by default - (debug:print 4 "WARNING: call to db:get-tests-for-run with bad run-id=" run-id) + (debug:print 4 #f "WARNING: call to db:get-tests-for-run with bad run-id=" run-id) ;; (print-call-chain (current-error-port)) '()) (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") @@ -2089,37 +2180,58 @@ (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 ('") + (if (eq? mode 'dashboard) + " IN ('" + (if not-in + " NOT IN ('" + " IN ('")) (string-intersperse states "','") "')"))) (statuses-qry (if (null? statuses) #f (conc " status " - (if not-in - " NOT IN ('" - " IN ('") + (if (eq? mode 'dashboard) + " IN ('" + (if not-in + " NOT IN ('" + " IN ('") ) (string-intersperse statuses "','") "')"))) + (interim-qry (conc " AND " (if not-in "NOT " "") "( state='COMPLETED' " (if statuses-qry (conc " AND " statuses-qry " ) ") " ) ") + (if states-qry + (conc (if not-in " AND " " OR ") states-qry ) ;; " ) ") + ""))) (states-statuses-qry (cond ((and states-qry statuses-qry) - (conc " AND ( " states-qry " AND " statuses-qry " ) ")) + (case mode + ((dashboard) + (if not-in + (conc " AND (state='COMPLETED' AND status NOT IN ('" (string-intersperse statuses "','") "')) " + " OR (state != 'COMPLETED' AND state NOT IN ('" (string-intersperse states "','") "')) ") + (conc " AND (state='COMPLETED' AND status IN ('" (string-intersperse statuses "','") "')) " + " OR (state NOT IN ('COMPLETED','DELETED') AND state IN ('" (string-intersperse states "','") "')) "))) + (else (conc " AND ( " states-qry " AND " statuses-qry " ) ")))) (states-qry - (conc " AND " states-qry)) + (case mode + ((dashboard) (conc " AND " (if not-in "NOT " "") " state IN ('" (string-intersperse states "','") "') ")) ;; interim-qry) + (else (conc " AND " states-qry)))) (statuses-qry - (conc " AND " statuses-qry)) + (case mode + ((dashboard) (conc " AND " (if not-in "NOT " "") " status IN ('" (string-intersperse statuses "','") "') ")) ;; interim-qry) + (else (conc " AND " statuses-qry)))) (else ""))) (tests-match-qry (tests:match->sqlqry testpatt)) (qry (conc "SELECT " qryvalstr - " FROM tests WHERE run_id=? AND state != 'DELETED' " + " FROM tests WHERE run_id=? " + (if last-update " " " AND state != 'DELETED' ") ;; if using last-update we want deleted tests? states-statuses-qry (if tests-match-qry (conc " AND (" tests-match-qry ") ") "") + (if last-update (conc " AND last_update >= " last-update " ") "") (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 ") @@ -2129,11 +2241,11 @@ (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) + (debug:print-info 8 #f "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))) @@ -2161,11 +2273,11 @@ (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) + (debug:print-info 8 #f "db:get-tests-for-run qry=" qry) (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 @@ -2188,20 +2300,13 @@ test-id))) res)) ;; get a useful subset of the tests data (used in dashboard ;; use db:mintest-get-{id ,run_id,testname ...} -;; -(define (db:get-tests-for-runs-mindata dbstruct run-ids testpatt states statuses not-in) - (debug:print 0 "ERROR: BROKN!") - ;; (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")) -) - -;; get a useful subset of the tests data (used in dashboard ;; (define (db:get-tests-for-run-mindata dbstruct run-id testpatt states statuses not-in) - (db:get-tests-for-run dbstruct run-id testpatt states statuses #f #f not-in #f #f "id,run_id,testname,state,status,event_time,item_path")) + (db:get-tests-for-run dbstruct run-id testpatt states statuses #f #f not-in #f #f "id,run_id,testname,state,status,event_time,item_path" #f)) ;; do not use. ;; (define (db:get-tests-for-runs dbstruct run-ids testpatt states statuses #!key (not-in #f)(qryvals #f)) ;; (db:delay-if-busy) @@ -2208,11 +2313,11 @@ (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)))) + (db:get-tests-for-run dbstruct run-id testpatt states statuses #f #f not-in #f #f qryvals #f 'normal)))) (if run-ids run-ids (db:get-all-run-ids dbstruct))) res)) @@ -2243,11 +2348,11 @@ ;; set tests with state currstate and status currstatus to newstate and newstatus ;; use currstate = #f and or currstatus = #f to apply to any state or status respectively ;; WARNING: SQL injection risk. NB// See new but not yet used "faster" version below ;; ;; AND NOT (item_path='' AND testname in (SELECT DISTINCT testname FROM tests WHERE testname=? AND item_path != ''));"))) -;; (debug:print 0 "QRY: " qry) +;; (debug:print 0 #f "QRY: " qry) ;; (db:delay-if-busy) ;; ;; NB// This call only operates on toplevel tests. Consider replacing it with more general call ;; (define (db:set-tests-state-status dbstruct run-id testnames currstate currstatus newstate newstatus) @@ -2471,17 +2576,17 @@ (db:with-db dbstruct run-id #t (lambda (db) (let* ((qmarks (string-intersperse (make-list (length db:test-record-fields) "?") ",")) (qrystr (conc "INSERT OR REPLACE INTO tests (" db:test-record-qry-selector ") VALUES (" qmarks ");")) (qry (sqlite3:prepare db qrystr))) - (debug:print 0 "INFO: migrating test records for run with id " run-id) + (debug:print 0 #f "INFO: migrating test records for run with id " run-id) (sqlite3:with-transaction db (lambda () (for-each (lambda (rec) - ;; (debug:print 0 "INFO: Inserting values: " (string-intersperse (map conc (vector->list rec)) ",") "\n") + ;; (debug:print 0 #f "INFO: Inserting values: " (string-intersperse (map conc (vector->list rec)) ",") "\n") (apply sqlite3:execute qry (vector->list rec))) testrecs))) (sqlite3:finalize! qry))))) ;; map a test-id into the proper range @@ -2499,17 +2604,17 @@ new-id) ;; if test-id-found then need to try again (if test-id-found (loop (+ new-id 1)) (begin - (debug:print-info 0 "New test id " new-id " selected for test with id " test-id) + (debug:print-info 0 #f "New test id " new-id " selected for test with id " test-id) (sqlite3:execute mtdb "UPDATE tests SET id=? WHERE id=?;" new-id test-id))))))) ;; move test ids into the 30k * run_id range ;; (define (db:prep-megatest.db-adj-test-ids mtdb run-id testrecs) - (debug:print-info 0 "Adjusting test ids in megatest.db for run " run-id) + (debug:print-info 0 #f "Adjusting test ids in megatest.db for run " run-id) (let ((min-test-id (* run-id 30000))) (for-each (lambda (testrec) (let* ((test-id (vector-ref testrec (db:field->number "id" db:test-record-fields)))) (db:adj-test-id (db:dbdat-get-db mtdb) min-test-id test-id))) @@ -2613,14 +2718,14 @@ run-id #f (lambda (db) (let* ((res '())) (sqlite3:for-each-row - (lambda (id test-id stepname state status event-time logfile) - (set! res (cons (vector id test-id stepname state status event-time (if (string? logfile) logfile "")) res))) + (lambda (id test-id stepname state status event-time logfile comment) + (set! res (cons (vector id test-id stepname state status event-time (if (string? logfile) logfile "") comment) 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; + "SELECT id,test_id,stepname,state,status,event_time,logfile,comment 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 dbstruct run-id test-id) (db:with-db @@ -2663,21 +2768,100 @@ ;; Now rollup the counts to the central megatest.db (db:general-call dbdat '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 dbdat 'test_data-pf-rollup (list test-id test-id test-id test-id)))) -;; NOT USED!? +;; each section is a rule except "final" which is the final result +;; +;; [rule-5] +;; operator in +;; section LogFileBody +;; desc Output voltage +;; status OK +;; expected 1.9 +;; measured 1.8 +;; type +/- +;; tolerance 0.1 +;; pass 1 +;; fail 0 +;; +;; [final] +;; exit-code 6 +;; exit-status SKIP +;; message If flagged we are asking for this to exit with code 6 ;; +;; recorded in steps table: +;; category: stepname +;; variable: rule-N +;; value: measured +;; expected: expected +;; tol: tolerance +;; units: - +;; comment: desc or message +;; status: status +;; type: type +;; +(define (db:logpro-dat->csv dat stepname) + (let ((res '())) + (for-each + (lambda (entry-name) + (if (equal? entry-name "final") + (set! res (append + res + (list + (list stepname + entry-name + (configf:lookup dat entry-name "exit-code") ;; 0 ;; Value + 0 ;; 1 ;; Expected + 0 ;; 2 ;; Tolerance + "n/a" ;; 3 ;; Units + (configf:lookup dat entry-name "message") ;; 4 ;; Comment + (configf:lookup dat entry-name "exit-status") ;; 5 ;; Status + "logpro" ;; 6 ;; Type + )))) + (let* ((value (or (configf:lookup dat entry-name "measured") "n/a")) + (expected (or (configf:lookup dat entry-name "expected") "n/a")) + (tolerance (or (configf:lookup dat entry-name "tolerance") "n/a")) + (comment (or (configf:lookup dat entry-name "comment") + (configf:lookup dat entry-name "desc") "n/a")) + (status (or (configf:lookup dat entry-name "status") "n/a")) + (type (or (configf:lookup dat entry-name "expected") "n/a"))) + (set! res (append + res + (list (list stepname + entry-name + value ;; 0 + expected ;; 1 + tolerance ;; 2 + "n/a" ;; 3 Units + comment ;; 4 + status ;; 5 + type ;; 6 + ))))))) + (hash-table-keys dat)) + res)) + +;; $MT_MEGATEST -load-test-data << EOF +;; foo,bar, 1.2, 1.9, > +;; foo,rab, 1.0e9, 10e9, 1e9 +;; foo,bla, 1.2, 1.9, < +;; foo,bal, 1.2, 1.2, < , ,Check for overload +;; foo,alb, 1.2, 1.2, <= , Amps,This is the high power circuit test +;; foo,abl, 1.2, 1.3, 0.1 +;; foo,bra, 1.2, pass, silly stuff +;; faz,bar, 10, 8mA, , ,"this is a comment" +;; EOF + (define (db:csv->test-data dbstruct run-id test-id csvdata) - (debug:print 4 "test-id " test-id ", csvdata: " csvdata) + (debug:print 4 #f "test-id " test-id ", csvdata: " csvdata) (let* ((dbdat (db:get-db dbstruct run-id)) (db (db:dbdat-get-db dbdat)) (csvlist (csv->list (make-csv-reader (open-input-string csvdata) '((strip-leading-whitespace? #t) (strip-trailing-whitespace? #t)))))) ;; (csv->list csvdata))) - (for-each + (for-each (lambda (csvrow) (let* ((padded-row (take (append csvrow (list #f #f #f #f #f #f #f #f #f)) 9)) (category (list-ref padded-row 0)) (variable (list-ref padded-row 1)) (value (any->number-if-possible (list-ref padded-row 2))) @@ -2690,11 +2874,11 @@ (string-match (regexp "^n/a$") s))) #f s))) ;; if specified on the input then use, else calculate (type (list-ref padded-row 8))) ;; look up expected,tol,units from previous best fit test if they are all either #f or '' - (debug:print 4 "BEFORE: category: " category " variable: " variable " value: " value + (debug:print 4 #f "BEFORE: category: " category " variable: " variable " value: " value ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment " type: " type) (if (and (or (not expected)(equal? expected "")) (or (not tol) (equal? expected "")) (or (not units) (equal? expected ""))) @@ -2701,28 +2885,28 @@ (let-values (((new-expected new-tol new-units)(tdb:get-prev-tol-for-test #f test-id category variable))) (set! expected new-expected) (set! tol new-tol) (set! units new-units))) - (debug:print 4 "AFTER: category: " category " variable: " variable " value: " value + (debug:print 4 #f "AFTER: category: " category " variable: " variable " value: " value ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment) ;; calculate status if NOT specified (if (and (not status)(number? expected)(number? value)) ;; need expected and value to be numbers (if (number? tol) ;; if tol is a number then we do the standard comparison (let* ((max-val (+ expected tol)) (min-val (- expected tol)) (result (and (>= value min-val)(<= value max-val)))) - (debug:print 4 "max-val: " max-val " min-val: " min-val " result: " result) + (debug:print 4 #f "max-val: " max-val " min-val: " min-val " result: " result) (set! status (if result "pass" "fail"))) (set! status ;; NB// need to assess each one (i.e. not return operator since need to act if not valid op. (case (string->symbol tol) ;; tol should be >, <, >=, <= ((>) (if (> value expected) "pass" "fail")) ((<) (if (< value expected) "pass" "fail")) ((>=) (if (>= value expected) "pass" "fail")) ((<=) (if (<= value expected) "pass" "fail")) (else (conc "ERROR: bad tol comparator " tol)))))) - (debug:print 4 "AFTER2: category: " category " variable: " variable " value: " value + (debug:print 4 #f "AFTER2: category: " category " variable: " variable " value: " value ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment) (db:delay-if-busy dbdat) (sqlite3:execute db "INSERT OR REPLACE INTO test_data (test_id,category,variable,value,expected,tol,units,comment,status,type) VALUES (?,?,?,?,?,?,?,?,?,?);" test-id category variable value expected tol units (if comment comment "") status type))) csvlist))) @@ -2755,11 +2939,11 @@ keynames (string-split target "/")) " AND ")) ;; (testqry (tests:match->sqlqry testpatt)) (runsqry (sqlite3:prepare db (conc "SELECT id FROM runs WHERE " keystr " AND runname LIKE '" runname "';")))) - ;; (debug:print 8 "db:test-get-paths-matching-keynames-target-new\n runsqry=" runsqry "\n tstsqry=" testqry) + ;; (debug:print 8 #f "db:test-get-paths-matching-keynames-target-new\n runsqry=" runsqry "\n tstsqry=" testqry) (sqlite3:for-each-row (lambda (rid) (set! row-ids (cons rid row-ids))) runsqry) (sqlite3:finalize! runsqry) @@ -2825,11 +3009,11 @@ (base64:base64-decode (string-substitute (regexp "_") "=" msg #t))) (lambda ()(deserialize))) (begin - (debug:print 0 "ERROR: reception failed. Received " msg " but cannot translate it.") + (debug:print 0 #f "ERROR: reception failed. Received " msg " but cannot translate it.") msg))) ;; crude reply for when things go awry ((zmq nmsg)(with-input-from-string msg (lambda ()(deserialize)))) (else msg))) (define (db:test-set-status-state dbstruct run-id test-id status state msg) @@ -2882,12 +3066,12 @@ ;; (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))) ;; ) + (debug:print 2 #f "Found path: " path) + (debug:print 2 #f "No such path: " path))) ;; ) db "SELECT rundir,final_logf FROM tests WHERE testname=? AND item_path='';" test-name) res)))) @@ -3137,17 +3321,17 @@ (set! prev-run-ids (cons id prev-run-ids))) db (conc "SELECT id FROM runs WHERE " qrystr " AND id != ?;") (append keyvals (list run-id))) ;; collect all matching tests for the runs then ;; extract the most recent test and return that. - (debug:print 4 "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals + (debug:print 4 #f "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 dbstruct 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 + (let ((results (db:get-tests-for-run dbstruct hed (conc test-name "/" item-path) '() '() #f #f #f #f #f #f #f 'normal))) + (debug:print 4 #f "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) (let* ((full-testname (conc (db:test-get-testname testdat) "/" (db:test-get-item-path testdat))) @@ -3170,11 +3354,11 @@ (db (db:dbdat-get-db dbdat)) ;; we'll return this so (db:delay--if-busy can be called inline (dbfj (conc dbpath "-journal"))) (if (handle-exceptions exn (begin - (debug:print-info 0 "WARNING: failed to test for existance of " dbfj) + (debug:print-info 0 #f "WARNING: failed to test for existance of " dbfj) (thread-sleep! 1) (db:delay-if-busy count (- count 1))) (file-exists? dbfj)) (case count ((6) @@ -3194,11 +3378,11 @@ (db:delay-if-busy count: 1)) ((1) (thread-sleep! 6.4) (db:delay-if-busy count: 0)) (else - (debug:print-info 0 "delaying db access due to high database load.") + (debug:print-info 0 #f "delaying db access due to high database load.") (thread-sleep! 12.8)))) db) "bogus result from db:delay-if-busy"))) (define (db:test-get-records-for-index-file dbstruct run-id test-name) @@ -3220,11 +3404,11 @@ ;; Tests meta data ;;====================================================================== ;; read the record given a testname (define (db:testmeta-get-record dbstruct testname) - (let ((res #f)) + (let ((res #f)) (db:with-db dbstruct #f #f (lambda (db) @@ -3271,24 +3455,24 @@ ;; patha and pathb must be strings or this will fail ;; ;; path-b is waiting on path-a ;; (define (db:compare-itempaths test-b-name path-a path-b itemmaps ) - (debug:print-info 6 "ITEMMAPS: " itemmaps) + (debug:print-info 6 #f "ITEMMAPS: " itemmaps) (let* ((itemmap (tests:lookup-itemmap itemmaps test-b-name))) (if itemmap (let ((path-b-mapped (db:multi-pattern-apply path-b itemmap))) - (debug:print-info 6 "ITEMMAP is " itemmap ", path: " path-b ", mapped path: " path-b-mapped) + (debug:print-info 6 #f "ITEMMAP is " itemmap ", path: " path-b ", mapped path: " path-b-mapped) (equal? path-a path-b-mapped)) (equal? path-b path-a)))) ;; A routine to convert test/itempath using a itemmap ;; NOTE: to process only an itempath (i.e. no prepended testname) ;; just call db:multi-pattern-apply ;; (define (db:convert-test-itempath path-in itemmap) - (debug:print-info 6 "ITEMMAP is " itemmap) + (debug:print-info 6 #f "ITEMMAP is " itemmap) (let* ((path-parts (string-split path-in "/")) (test-name (if (null? path-parts) "" (car path-parts))) (item-path (string-intersperse (if (null? path-parts) '() (cdr path-parts)) "/"))) (conc test-name "/" (db:multi-pattern-apply item-path itemmap)))) @@ -3309,11 +3493,11 @@ (patt (car parts)) (repl (if (> (length parts) 1)(cadr parts) "")) (newr (if (and patt repl) (string-substitute patt repl res) (begin - (debug:print 0 "WARNING: itemmap has problem \"" itemmap "\", patt: " patt ", repl: " repl) + (debug:print 0 #f "WARNING: itemmap has problem \"" itemmap "\", patt: " patt ", repl: " repl) res)))) (if (null? tal) newr (loop (car tal)(cdr tal) newr))))))) @@ -3404,10 +3588,12 @@ (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 '()) + (dbdat (db:get-db dbstruct #f)) + (db (db:dbdat-get-db dbdat)) (windows (and pathmod (substring-index "\\" pathmod))) (tempdir (conc "/tmp/" (current-user-name) "/" runspatt "_" (random 10000) "_" (current-process-id))) (runsheader (append (list "Run Id" "Runname") ; 0 1 (map car keypatt-alist) ; + N = length keypatt-alist (list "Testname" ; 2 @@ -3442,11 +3628,11 @@ tm.owner,reviewed, diskfree,uname,rundir, host,cpuload FROM tests AS t JOIN runs AS r ON t.run_id=r.id JOIN test_meta AS tm ON tm.testname=t.testname WHERE runname LIKE ? AND " keyqry ";"))) - (debug:print 2 "Using " tempdir " for constructing the ods file. keyqry: " keyqry " keystr: " keysstr " with keys: " (map cadr keypatt-alist) + (debug:print 2 #f "Using " tempdir " for constructing the ods file. keyqry: " keyqry " keystr: " keysstr " with keys: " (map cadr keypatt-alist) "\n mainqry: " mainqry) ;; "Expected Value" ;; "Value Found" ;; "Tolerance" (apply sqlite3:for-each-row @@ -3466,11 +3652,11 @@ (testname (vector-ref vb (+ 2 numkeys))) (item-path (vector-ref vb (+ 3 numkeys))) (final-log (vector-ref vb (+ 7 numkeys))) (run-dir (vector-ref vb (+ 18 numkeys))) (log-fpath (conc run-dir "/" final-log))) ;; (string-intersperse keyvals "/") "/" testname "/" item-path "/" - (debug:print 4 "log: " log-fpath " exists: " (file-exists? log-fpath)) + (debug:print 4 #f "log: " log-fpath " exists: " (file-exists? log-fpath)) (vector-set! vb (+ 7 numkeys) (if (file-exists? log-fpath) (let ((newpath (conc pathmod "/" (string-intersperse keyvals "/") "/" runname "/" testname "/" (if (string=? item-path "") "" (conc "/" item-path)) @@ -3484,11 +3670,11 @@ (vector->list vb)) b))))) db mainqry runspatt (map cadr keypatt-alist)) - (debug:print 2 "Found " (length test-ids) " records") + (debug:print 2 #f "Found " (length test-ids) " records") (set! results (list (cons "Runs" results))) ;; now, for each test, collect the test_data info and add a new sheet (for-each (lambda (test-id) (let ((test-data (list testdata-header)) @@ -3510,35 +3696,14 @@ (ods:list->ods tempdir (if (string-match (regexp "^[/~]+.*") outputfile) ;; full path? outputfile (begin - (debug:print 0 "WARNING: path given, " outputfile " is relative, prefixing with current directory") + (debug:print 0 #f "WARNING: path given, " outputfile " is relative, prefixing with current directory") (conc (current-directory) "/" outputfile))) results) ;; brutal clean up (system "rm -rf tempdir"))) ;; (db:extract-ods-file db "outputfile.ods" '(("sysname" "%")("fsname" "%")("datapath" "%")) "%") -;; This is a list of all procs that write to the db -;; -;; (define *db:all-write-procs* -;; (list -;; db:set-var -;; db:del-var -;; db:register-run -;; db:set-comment-for-run -;; db:delete-run -;; db:update-run-event_time -;; db:lock/unlock-run -;; db:delete-test-step-records -;; db:delete-test-records -;; db:delete-tests-for-run -;; db:delete-old-deleted-test-records -;; db:set-tests-state-status -;; db:test-set-state-status-by-id -;; db:test-set-state-status-by-run-id-testname -;; db:testmeta-add-record -;; db:csv->test-data -;; )) Index: db_records.scm ================================================================== --- db_records.scm +++ db_records.scm @@ -186,17 +186,19 @@ (define-inline (tdb:step-get-stepname vec) (vector-ref vec 2)) (define-inline (tdb:step-get-state vec) (vector-ref vec 3)) (define-inline (tdb:step-get-status vec) (vector-ref vec 4)) (define-inline (tdb:step-get-event_time vec) (vector-ref vec 5)) (define-inline (tdb:step-get-logfile vec) (vector-ref vec 6)) +(define-inline (tdb:step-get-comment vec) (vector-ref vec 7)) (define-inline (tdb:step-set-id! vec val)(vector-set! vec 0 val)) (define-inline (tdb:step-set-test_id! vec val)(vector-set! vec 1 val)) (define-inline (tdb:step-set-stepname! vec val)(vector-set! vec 2 val)) (define-inline (tdb:step-set-state! vec val)(vector-set! vec 3 val)) (define-inline (tdb:step-set-status! vec val)(vector-set! vec 4 val)) (define-inline (tdb:step-set-event_time! vec val)(vector-set! vec 5 val)) (define-inline (tdb:step-set-logfile! vec val)(vector-set! vec 6 val)) +(define-inline (tdb:step-set-comment! vec vak)(vector-set! vec 7 val)) ;; The steps table (define (make-db:steps-table)(make-vector 5)) (define-inline (tdb:steps-table-get-stepname vec) (vector-ref vec 0)) Index: dcommon.scm ================================================================== --- dcommon.scm +++ dcommon.scm @@ -11,11 +11,11 @@ (use format) (require-library iup) (import (prefix iup iup:)) (use canvas-draw) -(use regex) +(use regex defstruct) (declare (unit dcommon)) (declare (uses megatest-version)) (declare (uses gutils)) @@ -63,10 +63,15 @@ (define (dboard:data-get-target-string vec) (let ((targ (dboard:data-get-target vec))) (if (list? targ)(string-intersperse targ "/") "no-target-specified"))) (define (dboard:data-get-run-name vec) (vector-ref vec 19)) (define (dboard:data-get-runs-listbox vec) (vector-ref vec 20)) + +(defstruct d:data runs tests runs-matrix tests-tree run-keys + curr-test-ids updaters path-run-ids curr-run-id runs-tree test-patts + states statuses logs-textbox command command-tb target run-name + runs-listbox) (define (dboard:data-set-runs! vec val)(vector-set! vec 0 val)) (define (dboard:data-set-tests! vec val)(vector-set! vec 1 val)) (define (dboard:data-set-runs-matrix! vec val)(vector-set! vec 2 val)) (define (dboard:data-set-tests-tree! vec val)(vector-set! vec 3 val)) @@ -98,10 +103,16 @@ ;; Look up test-ids by (key1 key2 ... testname [itempath]) (dboard:data-set-path-test-ids! *data* (make-hash-table)) ;; Look up run-ids by ?? (dboard:data-set-path-run-ids! *data* (make-hash-table)) + +(define (d:data-init dat) + (d:data-run-keys-set! dat (make-hash-table)) + (d:data-curr-test-ids-set! dat (make-hash-table)) + (d:data-path-run-ids-set! dat (make-hash-table)) + dat) ;;====================================================================== ;; D O T F I L E ;;====================================================================== @@ -175,11 +186,11 @@ )) (runid-to-col (hash-table-ref *cachedata* "runid-to-col")) (testname-to-row (hash-table-ref *cachedata* "testname-to-row")) (colnum 1) (rownum 0)) ;; rownum = 0 is the header -;; (debug:print 0 "test-ids " test-ids ", tests-detail-changes " tests-detail-changes) +;; (debug:print 0 #f "test-ids " test-ids ", tests-detail-changes " tests-detail-changes) ;; tests related stuff ;; (all-testnames (delete-duplicates (map db:test-get-testname test-changes)))) ;; Given a run-id and testname/item_path calculate a cell R:C @@ -251,11 +262,11 @@ (tree:add-node (dboard:data-get-tests-tree *data*) "Runs" test-path userdata: (conc "test-id: " test-id)) (let ((node-num (tree:find-node tb (cons "Runs" test-path))) (color (car (gutils:get-color-for-state-status state status)))) - (debug:print 0 "node-num: " node-num ", color: " color) + (debug:print 0 #f "node-num: " node-num ", color: " color) (iup:attribute-set! tb (conc "COLOR" node-num) color)) (hash-table-set! (dboard:data-get-path-test-ids *data*) test-path test-id) (if (not rownum) (let ((rownums (hash-table-values testname-to-row))) (set! rownum (if (null? rownums) @@ -265,11 +276,11 @@ ;; create the label (iup:attribute-set! (dboard:data-get-runs-matrix *data*) (conc rownum ":" 0) dispname) )) ;; set the cell text and color - ;; (debug:print 2 "rownum:colnum=" rownum ":" colnum ", state=" status) + ;; (debug:print 2 #f "rownum:colnum=" rownum ":" colnum ", state=" status) (iup:attribute-set! (dboard:data-get-runs-matrix *data*) (conc rownum ":" colnum) (if (member state '("ARCHIVED" "COMPLETED")) status state)) @@ -282,12 +293,12 @@ (let ((updater (hash-table-ref/default (dboard:data-get-updaters *data*) window-id #f))) (if updater (updater (hash-table-ref/default data get-details-sig #f)))) (iup:attribute-set! (dboard:data-get-runs-matrix *data*) "REDRAW" "ALL") - ;; (debug:print 2 "run-changes: " run-changes) - ;; (debug:print 2 "test-changes: " test-changes) + ;; (debug:print 2 #f "run-changes: " run-changes) + ;; (debug:print 2 #f "test-changes: " test-changes) (list run-changes all-test-changes))) ;;====================================================================== ;; TESTS DATA ;;====================================================================== @@ -352,11 +363,11 @@ #:alignment1 "ALEFT" #:expand "YES" ;; "HORIZONTAL" #:numcol 1 #:numlin (length key-vals) #:numcol-visible 1 - #:numlin-visible (length key-vals) + #:numlin-visible (min 10 (length key-vals)) #:scrollbar "YES"))) (iup:attribute-set! section-matrix "0:0" varcolname) (iup:attribute-set! section-matrix "0:1" valcolname) (iup:attribute-set! section-matrix "WIDTH1" "200") ;; fill in keys @@ -407,11 +418,11 @@ (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 (apply max (map cadr col-indices)))) - (max-visible (max (- *num-tests* 15) 3)) + (max-visible (max (- (d:alldat-num-tests *alldat*) 15) 3)) (max-col-vis (if (> max-col 10) 10 max-col)) (numrows 1) (numcols 1)) (iup:attribute-set! stats-matrix "CLEARVALUE" "CONTENTS") (iup:attribute-set! stats-matrix "NUMCOL" max-col ) @@ -579,86 +590,290 @@ ;;====================================================================== ;; CANVAS STUFF FOR TESTS ;;====================================================================== -(define (dcommon:draw-test cnv x y w h name selected) - (let* ((llx x) - (lly y) - (urx (+ x w)) - (ury (+ y h))) - (canvas-text! cnv (+ llx 5)(+ lly 5) name) ;; (conc testname " (" xtorig "," ytorig ")")) +(define (dcommon:draw-test cnv xoffset yoffset scalef x y w h name selected) + (let* ((llx (dcommon:x->canvas x scalef xoffset)) + (lly (dcommon:y->canvas y scalef yoffset)) + (urx (dcommon:x->canvas (+ x w) scalef xoffset)) + (ury (dcommon:y->canvas (+ y h) scalef yoffset))) + (canvas-text! cnv (+ llx 5)(+ lly 5) name) (canvas-rectangle! cnv llx urx lly ury) (if selected (canvas-box! cnv llx (+ llx 5) lly (+ lly 5))))) -(define (dcommon:initial-draw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames) - (let* ((scalef (hash-table-ref/default tests-draw-state 'scalef 8)) - (test-browse-xoffset (hash-table-ref tests-draw-state 'test-browse-xoffset)) - (test-browse-yoffset (hash-table-ref tests-draw-state 'test-browse-yoffset)) - (xtorig (+ test-browse-xoffset (* (/ sizex 2) scalef (- 0.5 xadj)))) ;; (- xadj 1)))) - (ytorig (+ test-browse-yoffset (* (/ sizey 2) scalef (- yadj 0.5)))) - (boxw 90) ;; default, overriden by length estimate below - (boxh 25) - (gapx 20) - (gapy 30) - (tests-hash (hash-table-ref tests-draw-state 'tests-info)) - (selected-tests (hash-table-ref tests-draw-state 'selected-tests ))) - (hash-table-set! tests-draw-state 'xtorig xtorig) - (hash-table-set! tests-draw-state 'ytorig ytorig) - (let ((longest-str (if (null? sorted-testnames) " " (car (sort sorted-testnames (lambda (a b)(>= (string-length a)(string-length b)))))))) - (let-values (((x-max y-max) (canvas-text-size cnv longest-str))) - (if (> x-max boxw)(set! boxw (+ 10 x-max))))) - ;; (print "sizex: " sizex " sizey: " sizey " font: " (canvas-font cnv) " originx: " originx " originy: " originy " xtorig: " xtorig " ytorig: " ytorig " xadj: " xadj " yadj: " yadj) - (if (not (null? sorted-testnames)) - (let loop ((hed (car (reverse sorted-testnames))) - (tal (cdr (reverse sorted-testnames))) - (llx xtorig) - (lly ytorig) - (urx (+ xtorig boxw)) - (ury (+ ytorig boxh))) +(define (dcommon:draw-arrow cnv test-box-center waiton-center) + (let* ((test-box-center-x (vector-ref test-box-center 0)) + (test-box-center-y (vector-ref test-box-center 1)) + (waiton-center-x (vector-ref waiton-center 0)) + (waiton-center-y (vector-ref waiton-center 1)) + (delta-y (- waiton-center-y test-box-center-y)) + (delta-x (- waiton-center-x test-box-center-x)) + (abs-delta-x (abs delta-x)) + (abs-delta-y (abs delta-y)) + (use-delta-x (> abs-delta-x abs-delta-y)) ;; use the larger one + (delta-ratio (if use-delta-x + (if (> abs-delta-x 0) + (/ abs-delta-y abs-delta-x) + 1) + (if (> abs-delta-y 0) + (/ abs-delta-x abs-delta-y) + 1))) + (x-adj (if use-delta-x + 8 + (* delta-ratio 8))) + (y-adj (if use-delta-x + (* x-adj delta-ratio) + 8)) + (new-waiton-x (inexact->exact + (round (if (> delta-x 0) ;; have positive x + (- waiton-center-x x-adj) + (+ waiton-center-x x-adj))))) + (new-waiton-y (inexact->exact + (round (if (> delta-y 0) + (- waiton-center-y y-adj) + (+ waiton-center-y y-adj)))))) + ;; (canvas-line-width-set! cnv 5) + (canvas-line! cnv + test-box-center-x + test-box-center-y + new-waiton-x + new-waiton-y + ) + (canvas-mark! cnv new-waiton-x new-waiton-y))) + +(define (dcommon:get-box-center box) + (let* ((llx (list-ref box 0)) + (lly (list-ref box 1)) + (boxw (list-ref box 4)) + (boxh (list-ref box 5))) + (vector (+ llx (/ boxw 2)) + (+ lly (/ boxh 2))))) + +(define-inline (num->int num) + (inexact->exact (round num))) + +(define (dcommon:draw-edges cnv xoffset yoffset scalef edges) + (for-each + (lambda (e) + (let loop ((x1 (car e)) + (y1 (cadr e)) + (x2 #f) + (y2 #f) + (tal (cddr e))) + (if (and x1 y1 x2 y2) + (canvas-line! + cnv + (num->int (dcommon:x->canvas x1 scalef xoffset)) + (num->int (dcommon:y->canvas y1 scalef yoffset)) + (num->int (dcommon:x->canvas x2 scalef xoffset)) + (num->int (dcommon:y->canvas y2 scalef yoffset)))) ;; (num->int x1)(num->int y1)(num->int x2)(num->int y2))) + (if (< (length tal) 2) + (canvas-mark! cnv + (num->int (dcommon:x->canvas x1 scalef xoffset)) + (num->int (dcommon:y->canvas y1 scalef yoffset))) ;; (num->int x1)(num->int y1)) + (loop (car tal)(cadr tal) x1 y1 (cddr tal))))) + ;; (map (lambda (e)(map (lambda (x)(num->int (* x scalef))) e)) edges))) + edges)) + + +(define (dcommon:draw-arrows cnv testname tests-hash test-records) + (let* ((test-box-info (hash-table-ref tests-hash testname)) + (test-box-center (dcommon:get-box-center test-box-info)) + (test-record (hash-table-ref test-records testname)) + (waitons (vector-ref test-record 2))) + (for-each + (lambda (waiton) + (let* ((waiton-box-info (hash-table-ref/default tests-hash waiton #f)) + (waiton-center (dcommon:get-box-center (or waiton-box-info test-box-info)))) + (dcommon:draw-arrow cnv test-box-center waiton-center))) + waitons) + ;; (debug:print 0 #f "test-box-info=" test-box-info) + ;; (debug:print 0 #f "test-record=" test-record) + )) + +(define (dcommon:estimate-scale sizex sizey originx originy nodes) + ;; (print "sizex: " sizex " sizey: " sizey " originx: " originx " originy: " originy " nodes: " nodes) + (let* ((maxx 1) + (maxy 1)) + (for-each + (lambda (node) + (if (equal? (car node) "node") + (let ((x (string->number (list-ref node 2))) + (y (string->number (list-ref node 3)))) + (if (and x (> x maxx))(set! maxx x)) + (if (and y (> y maxy))(set! maxy y))))) + nodes) + (let ((scalex (/ sizex maxx)) + (scaley (/ sizey maxy))) + ;; (print "maxx: " maxx " maxy: " maxy " scalex: " scalex " scaley: " scaley) + (min scalex scaley)))) + +(define (dcommon:get-xoffset tests-draw-state sizex-in xadj-in) + (let ((xadj (or xadj-in (hash-table-ref/default tests-draw-state 'xadj 0))) + (sizex (or sizex-in (hash-table-ref/default tests-draw-state 'sizex 500)))) + (hash-table-set! tests-draw-state 'xadj xadj) ;; for use in de-scaling when handling mouse clicks + (hash-table-set! tests-draw-state 'sizex sizex) + (* (/ sizex 2) (- 0.5 xadj)))) + +(define (dcommon:get-yoffset tests-draw-state sizey-in yadj-in) + (let ((yadj (or yadj-in (hash-table-ref/default tests-draw-state 'yadj 0))) + (sizey (or sizey-in (hash-table-ref/default tests-draw-state 'sizey 500)))) + (hash-table-set! tests-draw-state 'yadj yadj) ;; for use in de-scaling when handling mouse clicks + (hash-table-set! tests-draw-state 'sizey sizey) + (* (/ sizey 2) (- yadj 0.5)))) + +(define (dcommon:x->canvas x scalef xoffset) + (+ xoffset (* x scalef))) + +(define (dcommon:y->canvas y scalef yoffset) + (+ yoffset (* y scalef))) + +;; sizex, sizey - canvas size +;; originx, originy - canvas origin +;; +(define (dcommon:initial-draw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames test-records) + (let* ((dot-data ;; (map cdr (filter + ;; (lambda (x)(equal? "node" (car x))) + (map string-split (tests:lazy-dot test-records "plain" sizex sizey))) ;; (tests:easy-dot test-records "plain"))) + (xoffset (dcommon:get-xoffset tests-draw-state sizex xadj)) + (yoffset (dcommon:get-yoffset tests-draw-state sizey yadj)) + (no-dot (configf:lookup *configdat* "setup" "nodot")) + (boxh 15) + (boxw 10) + (margin 5) + (tests-info (hash-table-ref tests-draw-state 'tests-info)) + (selected-tests (hash-table-ref tests-draw-state 'selected-tests )) + (scalef (if no-dot + 1 + (dcommon:estimate-scale sizex sizey originx originy dot-data))) + (sorted-testnames (if no-dot + (sort sorted-testnames string>=?) + sorted-testnames)) + (curr-x 0) ;; NB// NOT screen units + (curr-y (/ (- sizey boxh margin) scalef)) ;; used when no-dot + (scaled-sizex (/ sizex scalef))) + + (hash-table-set! tests-draw-state 'scalef scalef) + + (let ((longest-str (if (null? sorted-testnames) " " (car (sort sorted-testnames (lambda (a b)(>= (string-length a)(string-length b)))))))) + (let-values (((x-max y-max) (canvas-text-size cnv longest-str))) + (if (> x-max boxw)(set! boxw (+ 10 x-max))))) + ;; (print "sizex: " sizex " sizey: " sizey " font: " (canvas-font cnv) " originx: " originx " originy: " originy " xtorig: " xtorig " ytorig: " ytorig " xadj: " xadj " yadj: " yadj) + (if (not (null? sorted-testnames)) + (let loop ((hed (car (reverse sorted-testnames))) + (tal (cdr (reverse sorted-testnames)))) + (let* ((nodedat (if no-dot + #f + (let ((tmpres (filter (lambda (x) + (if (and (not (null? x)) + (equal? (car x) "node")) + (equal? hed (cadr x)) + #f)) + dot-data))) + (if (null? tmpres) + ;; llx lly boxw boxh + (list "0" "1" "1" (conc (length tal)) "2" "0.5") ;; return some placeholder junk if no dat found + (car tmpres))))) + (edgedat (if no-dot + '() + (let ((edges (filter (lambda (x) ;; filter for edge + (if (and (not (null? x)) + (equal? (car x) "edge")) + (equal? hed (cadr x)) + #f)) + dot-data))) + (map (lambda (inlst) + (dcommon:process-polyline + (map (lambda (instr) + (string->number instr)) ;; convert to number and scale + (let ((il (cddddr inlst))) + (take il (- (length il) 2)))) + (lambda (x y) + (list (+ x 0) ;; xtorig) + (+ y 0))) ;; ytorig))) + #f #f)) ;; process polyline + edges)))) + (llx (if no-dot + curr-x + (string->number (list-ref nodedat 2)))) + (lly (if no-dot + curr-y + (string->number (list-ref nodedat 3)))) + (boxw (if no-dot + boxw + (string->number (list-ref nodedat 4)))) + (boxh (if no-dot + boxh + (string->number (list-ref nodedat 5)))) + (urx (+ llx boxw)) + (ury (+ lly boxh))) + + ;; if we are in no-dot mode then increment curr-x and curr-y as needed + (if no-dot + (begin + (cond + ((< curr-x (- scaled-sizex boxw boxw margin)) + (set! curr-x (+ curr-x boxw margin))) + ((> curr-x (- scaled-sizex boxw boxw margin)) + (set! curr-x 0) + (set! curr-y (- curr-y (+ boxh margin))))))) ; (print "hed " hed " llx " llx " lly " lly " urx " urx " ury " ury) - (dcommon:draw-test cnv llx lly boxw boxh hed (hash-table-ref/default selected-tests hed #f)) - ;; data used by mouse click calc. keep the wacky order for now. - (hash-table-set! tests-hash hed (list llx urx (- sizey ury)(- sizey lly) lly boxw boxh)) - ;; (list llx lly boxw boxh)) ;; NB// Swap ury and lly - (if (not (null? tal)) - ;; leave a column of space to the right to list items - (let ((have-room - (if #t ;; put "auto" here where some form of auto rearanging can be done - (> (* 3 (+ boxw gapx)) (- urx xtorig)) - (< urx (- sizex boxw gapx boxw))))) ;; is there room for another column? - (loop (car tal) - (cdr tal) - (if have-room (+ llx boxw gapx) xtorig) ;; have room, - (if have-room lly (+ lly boxh gapy)) - (if have-room (+ urx boxw gapx) (+ xtorig boxw)) - (if have-room ury (+ ury boxh gapy))))))))) - -(define (dcommon:redraw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames) - (let* ((scalef (hash-table-ref/default tests-draw-state 'scalef 8)) - (test-browse-xoffset (hash-table-ref tests-draw-state 'test-browse-xoffset)) - (test-browse-yoffset (hash-table-ref tests-draw-state 'test-browse-yoffset)) - (xtorig (+ test-browse-xoffset (* (/ sizex 2) scalef (- 0.5 xadj)))) ;; (- xadj 1)))) - (ytorig (+ test-browse-yoffset (* (/ sizey 2) scalef (- yadj 0.5)))) - (xdelta (- (hash-table-ref tests-draw-state 'xtorig) xtorig)) - (ydelta (- (hash-table-ref tests-draw-state 'ytorig) ytorig)) - (tests-hash (hash-table-ref tests-draw-state 'tests-info)) - (selected-tests (hash-table-ref tests-draw-state 'selected-tests ))) - (hash-table-set! tests-draw-state 'xtorig xtorig) - (hash-table-set! tests-draw-state 'ytorig ytorig) + (dcommon:draw-test cnv xoffset yoffset scalef llx lly boxw boxh hed (hash-table-ref/default selected-tests hed #f)) + ;; (dcommon:draw-arrows cnv testname tests-info test-records)) + (dcommon:draw-edges cnv xoffset yoffset scalef edgedat) + + ;; data used by mouse click calc. keep the wacky order for now. + (hash-table-set! tests-info hed (list llx lly urx ury boxw boxh edgedat)) + (if (not (null? tal)) + (loop (car tal) + (cdr tal)))))) + )) + +;; per-point-proc required, remainder optional +;; +(define (dcommon:process-polyline line per-point-proc per-segment-proc last-segment-proc) + (if (< (length line) 2) + '() + (let loop ((x1 (car line)) + (y1 (cadr line)) + (x2 #f) + (y2 #f) + (tal (cddr line)) + (res '())) + (if (and x1 y1 x2 y2 per-segment-proc) + (per-segment-proc x1 y1 x2 y2)) + (if (< (length tal) 2) + (begin + (if last-segment-proc (last-segment-proc x1 y1 x2 y2)) + (append res (per-point-proc x1 y1))) + (loop (car tal)(cadr tal) x1 y1 (cddr tal) (append res (per-point-proc x1 y1))))))) + +(define (dcommon:redraw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames test-records) + (let* ((scalef (hash-table-ref tests-draw-state 'scalef)) + (xoffset (dcommon:get-xoffset tests-draw-state sizex xadj)) + (yoffset (dcommon:get-yoffset tests-draw-state sizey yadj)) + (tests-info (hash-table-ref tests-draw-state 'tests-info)) + (selected-tests (hash-table-ref tests-draw-state 'selected-tests ))) (if (not (null? sorted-testnames)) (let loop ((hed (car (reverse sorted-testnames))) (tal (cdr (reverse sorted-testnames)))) - (let* ((tvals (hash-table-ref tests-hash hed)) - (llx (+ xdelta (list-ref tvals 0))) - (lly (+ ydelta (list-ref tvals 4))) - (boxw (list-ref tvals 5)) - (boxh (list-ref tvals 6)) + (let* ((tvals (hash-table-ref tests-info hed)) + (llx (list-ref tvals 0)) + (lly (list-ref tvals 1)) + (boxw (list-ref tvals 4)) + (boxh (list-ref tvals 5)) + (edges (map (lambda (pline) + (dcommon:process-polyline pline + (lambda (x1 y1) + (list x1 y1)) + #f #f)) + (list-ref tvals 6))) (urx (+ llx boxw)) (ury (+ lly boxh))) - (dcommon:draw-test cnv llx lly boxw boxh hed (hash-table-ref/default selected-tests hed #f)) - (hash-table-set! tests-hash hed (list llx urx (- sizey ury)(- sizey lly) lly boxw boxh)) + (dcommon:draw-test cnv xoffset yoffset scalef llx lly boxw boxh hed (hash-table-ref/default selected-tests hed #f)) + (dcommon:draw-edges cnv xoffset yoffset scalef edges) (if (not (null? tal)) ;; leave a column of space to the right to list items (loop (car tal) (cdr tal)))))))) @@ -665,11 +880,12 @@ ;;====================================================================== ;; S T E P S ;;====================================================================== (define (dcommon:populate-steps teststeps steps-matrix) - (let ((max-row 0)) + (let ((max-row 0) + (max-col 7)) (if (null? teststeps) (iup:attribute-set! steps-matrix "CLEARVALUE" "CONTENTS") (let loop ((hed (car teststeps)) (tal (cdr teststeps)) (rownum 1) @@ -676,30 +892,30 @@ (colnum 1)) (if (> rownum max-row)(set! max-row rownum)) (let ((val (vector-ref hed (- colnum 1))) (mtrx-rc (conc rownum ":" colnum))) (iup:attribute-set! steps-matrix mtrx-rc (if val (conc val) "")) - (if (< colnum 6) + (if (< colnum max-col) (loop hed tal rownum (+ colnum 1)) (if (not (null? tal)) (loop (car tal)(cdr tal)(+ rownum 1) 1)))))) (if (> max-row 0) (begin ;; we are going to speculatively clear rows until we find a row that is already cleared (let loop ((rownum (+ max-row 1)) (colnum 0) (deleted #f)) - ;; (debug:print-info 0 "cleaning " rownum ":" colnum) - (let* ((next-row (if (eq? colnum 6) (+ rownum 1) rownum)) - (next-col (if (eq? colnum 6) 1 (+ colnum 1))) + ;; (debug:print-info 0 #f "cleaning " rownum ":" colnum) + (let* ((next-row (if (eq? colnum max-col) (+ rownum 1) rownum)) + (next-col (if (eq? colnum max-col) 1 (+ colnum 1))) (mtrx-rc (conc rownum ":" colnum)) (curr-val (iup:attribute steps-matrix mtrx-rc))) - ;; (debug:print-info 0 "cleaning " rownum ":" colnum " currval= " curr-val) + ;; (debug:print-info 0 #f "cleaning " rownum ":" colnum " currval= " curr-val) (if (and (string? curr-val) (not (equal? curr-val ""))) (begin (iup:attribute-set! steps-matrix mtrx-rc "") (loop next-row next-col #t)) - (if (eq? colnum 6) ;; not done, didn't get a full blank row + (if (eq? colnum max-col) ;; not done, didn't get a full blank row (if deleted (loop next-row next-col #f)) ;; exit on this not met (loop next-row next-col deleted))))) (iup:attribute-set! steps-matrix "REDRAW" "ALL"))))) ADDED debugger.scm Index: debugger.scm ================================================================== --- /dev/null +++ debugger.scm @@ -0,0 +1,73 @@ +(use iup) + +(define *debugger-control* #f) +(define *debugger-rownum* 0) +(define *debugger-matrix* #f) +(define *debugger* #f) + +(define (debugger) + (if (not *debugger*) + (set! *debugger* + (thread-start! + (make-thread + (lambda () + (show + (dialog + (let ((pause #f) + (mtrx (matrix + #:expand "YES" + #:numlin 30 + #:numcol 3 + #:numlin-visible 20 + #:numcol-visible 2 + #:alignment1 "ALEFT" + ))) + (set! pause (button "Pause" + #:action (lambda (obj) + (set! *debugger-control* (not *debugger-control*)) + (attribute-set! pause "BGCOLOR" (if *debugger-control* + "200 0 0" + "0 0 200"))))) + (set! *debugger-matrix* mtrx) + (attribute-set! mtrx "WIDTH1" "300") + (vbox + mtrx + (hbox + pause))))) + (main-loop))))))) + +(define (debugger-start #!key (start 2)) + (set! *debugger-rownum* start)) + +(define (debugger-trace-var varname varval) + (let ((oldval (attribute *debugger-matrix* (conc *debugger-rownum* ":1"))) + (newval (conc varval))) + (if (not (equal? oldval newval)) + (begin + ;; (print "DEBUG: " varname " = " newval) + (attribute-set! *debugger-matrix* (conc *debugger-rownum* ":0") varname) + (attribute-set! *debugger-matrix* (conc *debugger-rownum* ":1") (conc varval)) + ;; (attribute-set! *debugger-matrix* "FITTOTEXT" "C1") + )) + (set! *debugger-rownum* (+ *debugger-rownum* 1)))) + + +(define (debugger-pauser) + (debugger) + (attribute-set! *debugger-matrix* "REDRAW" "ALL") + (let loop () + (if *debugger-control* + (begin + (print "PAUSED!") + (thread-sleep! 1) + (loop)) + ;;(thread-sleep! 0.01) + ))) + +;; ;; lets use the debugger eh? +;; (debugger-start) +;; (debugger-trace-var "can-run-more" can-run-more) +;; (debugger-trace-var "hed" hed) +;; (debugger-trace-var "prereqs-not-met" (runs:pretty-string prereqs-not-met)) +;; (debugger-pauser) + Index: docs/manual/Makefile ================================================================== --- docs/manual/Makefile +++ docs/manual/Makefile @@ -1,8 +1,8 @@ ASCPATH = $(shell which asciidoc) -EXEPATH = $(shell realpath $(ASCPATH)) +EXEPATH = $(shell readlink -f $(ASCPATH)) BINPATH = $(shell dirname $(EXEPATH)) DISPATH = $(shell dirname $(BINPATH)) # broad_goals.csv needed_features.csv : tables/*.dat # ./refdb2csv tables Index: docs/manual/megatest_manual.html ================================================================== --- docs/manual/megatest_manual.html +++ docs/manual/megatest_manual.html @@ -1,10 +1,10 @@ - + The Megatest Users Manual