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 @@ -61,10 +61,11 @@ 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 : 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,11 +165,11 @@ $(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) $< $@ @@ -227,14 +228,26 @@ # 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: 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 )) @@ -106,11 +107,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 *default-log-port* " 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 @@ -226,10 +227,13 @@ ;; 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 *default-log-port* "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 *default-log-port* " use [archive] minspace to specify minimum available space") + (debug:print 0 *default-log-port* " 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 *default-log-port* "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 *default-log-port* "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 *default-log-port* "WARNING: Cannot archive " test-name "/" item-path " as path " test-path " does not exist")) (else - (debug:print 0 + (debug:print 0 *default-log-port* "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 *default-log-port* "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 *default-log-port* "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 *default-log-port* "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 *default-log-port* "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 *default-log-port* "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 *default-log-port* "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 *default-log-port* "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 *default-log-port* "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 @@ -61,17 +61,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 *default-log-port* "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 *default-log-port* "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 *default-log-port* "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)) @@ -80,11 +80,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 *default-log-port* "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) @@ -91,16 +91,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 *default-log-port* "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 *default-log-port* "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)) @@ -109,11 +109,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 *default-log-port* "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) @@ -122,21 +122,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 *default-log-port* "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 *default-log-port* "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 @@ -153,18 +153,18 @@ ;; 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 *default-log-port* "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 *default-log-port* "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 *default-log-port* "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* @@ -178,14 +178,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 *default-log-port* "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 *default-log-port* "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) @@ -200,11 +200,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 *default-log-port* "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))))))))) @@ -217,18 +217,18 @@ ;; (define (client:signal-handler signum) ;; (signal-mask! signum) ;; (set! *time-to-exit* #t) ;; (handle-exceptions ;; exn -;; (debug:print " ... exiting ...") +;; (debug:print 0 *default-log-port* " ... 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 *default-log-port* "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 *default-log-port* " Done.") ;; (exit 4)) ;; "exit on ^C timer"))) ;; (thread-start! th2) ;; (thread-start! th1) ;; (thread-join! th2)))) @@ -239,10 +239,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 *default-log-port* "connected as client") ;; (begin -;; (debug:print 0 "ERROR: Failed to connect as client") +;; (debug:print 0 *default-log-port* "ERROR: Failed to connect as client") ;; (exit)))) ;; Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -34,13 +34,13 @@ (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 *default-log-port* "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 *default-log-port* "ERROR: bad value for setenv, key=" key ", value=" val))) (define home (getenv "HOME")) (define user (getenv "USER")) ;; GLOBAL GLETCHES @@ -58,10 +58,11 @@ (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)) (define *alt-log-file* #f) ;; used by -log (define *common:denoise* (make-hash-table)) ;; for low noise printing +(define *default-log-port* (current-error-port)) ;; DATABASE (define *dbstruct-db* #f) (define *db-stats* (make-hash-table)) ;; hash of vectors < count duration-total > (define *db-stats-mutex* (make-mutex)) @@ -129,10 +130,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 *default-log-port* + "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 *default-log-port* " I see you are the owner of megatest.config, attempting to cleanup and reset to new version") + (handle-exceptions + exn + (begin + (debug:print 0 *default-log-port* "Failed to switch versions.") + (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) + (print-call-chain (current-error-port)) + (exit 1)) + (common:cleanup-db))) + (begin + (debug:print 0 *default-log-port* " 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 ;;====================================================================== @@ -187,11 +274,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 *default-log-port* "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)))))) @@ -289,11 +376,11 @@ (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 *default-log-port* "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)) @@ -312,33 +399,35 @@ (let ((db (cdr *task-db*))) (if (sqlite3:database? db) (begin (sqlite3:interrupt! db) (sqlite3:finalize! db #t) - (vector-set! *task-db* 0 #f)))))) "Cleanup db exit thread")) + (vector-set! *task-db* 0 #f))))) + (close-output-port *default-log-port*) + (set! *default-log-port* (current-error-port))) "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 *default-log-port* "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 *default-log-port* " ... 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 *default-log-port* "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 ;;====================================================================== @@ -362,13 +451,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) @@ -387,17 +473,17 @@ (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 *default-log-port* "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 *default-log-port* "patt " patt " modpatt " modpatt) (if (string-match (regexp modpatt) item) (set! res #t)))) (string-split patts ",")) res) #t)) @@ -448,11 +534,11 @@ (args:get-arg "-runtests") "%")) (testpatt (or (and (equal? args-testpatt "%") rtestpatt) args-testpatt))) - (if rtestpatt (debug:print-info 0 "TESTPATT from runconfigs: " rtestpatt)) + (if rtestpatt (debug:print-info 0 *default-log-port* "TESTPATT from runconfigs: " rtestpatt)) testpatt)) (define (common:get-linktree) (or (getenv "MT_LINKTREE") (if *configdat* @@ -482,11 +568,11 @@ (if split tlist target) (if target (begin - (debug:print 0 "ERROR: Invalid target, spaces or blanks not allowed \"" target "\", target should be: " (string-intersperse keys "/") ", have " tlist " for elements") + (debug:print 0 *default-log-port* "ERROR: Invalid target, spaces or blanks not allowed \"" target "\", target should be: " (string-intersperse keys "/") ", have " tlist " for elements") #f) #f)))) ;;====================================================================== ;; M I S C L I S T S @@ -525,11 +611,11 @@ (cdr tal)) (max hed max-val)))) ;;====================================================================== -;; Munge data into nice forms +;; M U N G E D A T A I N T O N I C E F O R M S ;;====================================================================== ;; Generate an index for a sparse list of key values ;; ( (rowname1 colname1 val1)(rowname2 colname2 val2) ) ;; @@ -555,11 +641,11 @@ (existing-coldat (assoc colkey colnames)) (curr-rownum (if existing-rowdat rownum (+ rownum 1))) (curr-colnum (if existing-coldat colnum (+ colnum 1))) (new-rownames (if existing-rowdat rownames (cons (list rowkey curr-rownum) rownames))) (new-colnames (if existing-coldat colnames (cons (list colkey curr-colnum) colnames)))) - ;; (debug:print-info 0 "Processing record: " hed ) + ;; (debug:print-info 0 *default-log-port* "Processing record: " hed ) (if proc (proc curr-rownum curr-colnum rowkey colkey value)) (if (null? tal) (list new-rownames new-colnames) (loop (car tal) (cdr tal) @@ -568,18 +654,35 @@ (if (> 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 *default-log-port* "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 (process:cmd-run->list "uptime")) ;; (load-rx (regexp "load average:\\s+(\\d+)")) @@ -606,16 +709,16 @@ (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 (if msg msg "")) + (debug:print-info 0 *default-log-port* "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 (if msg msg "")) + (debug:print-info 0 *default-log-port* "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" @@ -673,11 +776,11 @@ ;; with free-space-script /path/to/some/script.sh ;; (define (get-df path) (if (configf:lookup *configdat* "setup" "free-space-script") (with-input-from-pipe - (configf:lookup *configdat* "setup" "free-space-script") + (conc (configf:lookup *configdat* "setup" "free-space-script") " " path) (lambda () (let ((res (read-line))) (if (string? res) (string->number res))))) (get-unix-df path))) @@ -720,11 +823,11 @@ (dbspace (cadr spacedat)) (required (caddr spacedat)) (dbdir (cadddr spacedat))) (if (not is-ok) (begin - (debug:print 0 "ERROR: Insufficient space in " dbdir ", require " required ", have " dbspace ", exiting now.") + (debug:print 0 *default-log-port* "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) @@ -733,20 +836,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 *default-log-port* "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 *default-log-port* "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 *default-log-port* "WARNING: disk " disk-num " at path \"" dirpath "\" is not a fully qualified path - ignoring it.")) -1) (else (get-df dirpath))))) (if (> freespc bestsize) (begin @@ -838,11 +941,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)) @@ -853,11 +956,11 @@ (define (seconds->time-string sec) (time->string (seconds->local-time sec) "%H:%M:%S")) -(define (seconds->work-week/day-time sec) +(define (sbeconds->work-week/day-time sec) (time->string (seconds->local-time sec) "ww%V.%u %H:%M")) (define (seconds->work-week/day sec) (time->string @@ -867,11 +970,11 @@ (time->string (seconds->local-time sec) "%yww%V.%w")) (define (seconds->year-work-week/day-time sec) (time->string - (seconds->local-time sec) "%yww%V.%w %H:%M")) + (seconds->local-time sec) "%Yww%V.%w %H:%M")) (define (seconds->quarter sec) (case (string->number (time->string (seconds->local-time sec) @@ -881,11 +984,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") @@ -1130,20 +1233,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 *default-log-port* "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 *default-log-port* "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 @@ -45,11 +45,11 @@ (define (config:eval-string-in-environment str) (handle-exceptions exn (begin - (debug:print 0 "ERROR: problem evaluating \"" str "\" in the shell environment") + (debug:print 0 *default-log-port* "ERROR: problem evaluating \"" str "\" in the shell environment") #f) (let ((cmdres (process:cmd-run->list (conc "echo " str)))) (if (null? cmdres) "" (caar cmdres))))) @@ -98,12 +98,12 @@ (else "(lambda (ht)(print \"ERROR\") \"ERROR\")")))) ;; (print "fullcmd=" fullcmd) (handle-exceptions exn (begin - (debug:print 0 "WARNING: failed to process config input \"" l "\"") - (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 *default-log-port* "WARNING: failed to process config input \"" l "\"") + (debug:print 0 *default-log-port* " 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 @@ -112,12 +112,12 @@ (set! result (conc "#{(" cmdtype ") " cmd "}")))) (case cmdsym ((system shell scheme) (let ((delta (- (current-seconds) start-time))) (if (> delta 2) - (debug:print-info 0 "for line \"" l "\"\n command: " cmd " took " delta " seconds to run with output:\n " result) - (debug:print-info 9 "for line \"" l "\"\n command: " cmd " took " delta " seconds to run with output:\n " result))))) + (debug:print-info 0 *default-log-port* "for line \"" l "\"\n command: " cmd " took " delta " seconds to run with output:\n " result) + (debug:print-info 9 *default-log-port* "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 @@ -127,11 +127,11 @@ (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 *default-log-port* "shell result:\n" outres) outres) (begin (with-output-to-port (current-error-port) (lambda () (print "ERROR: " cmd " returned bad exit code " status))) @@ -179,15 +179,15 @@ ;; in the environment on the fly ;; sections: #f => get all, else list of sections to gather ;; 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 "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) + (debug:print-info 5 *default-log-port* "read-config " path " allow-system " allow-system " environ-patt " environ-patt " curr-section: " curr-section " sections: " sections " pwd: " (current-directory)) + (debug:print 9 *default-log-port* "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 *default-log-port* "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)) (metapath (if (or (debug:debug-mode 9) @@ -195,16 +195,16 @@ 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 *default-log-port* "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 *default-log-port* "END: " path) res) (regex-case inl (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)) @@ -212,25 +212,25 @@ (hash-table-set! settings setting val) (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) + (debug:print 9 *default-log-port* "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 (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) + (debug:print '(2 9) #f "INFO: include file " include-file " not found (called from " path ")") + (debug:print 2 *default-log-port* " " 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) @@ -251,18 +251,18 @@ (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 "" inl "\n => " (string-intersperse res "\n")) + (debug:print-info 4 *default-log-port* "" inl "\n => " (string-intersperse res "\n")) (if (not (eq? status 0)) (begin - (debug:print 0 "ERROR: problem with " inl ", return code " status + (debug:print 0 *default-log-port* "ERROR: problem with " inl ", return code " status " output: " cmdres))) (if (> delta 2) - (debug:print-info 0 "for line \"" inl "\"\n command: " cmd " took " delta " seconds to run with output:\n " res) - (debug:print-info 9 "for line \"" inl "\"\n command: " cmd " took " delta " seconds to run with output:\n " res)) + (debug:print-info 0 *default-log-port* "for line \"" inl "\"\n command: " cmd " took " delta " seconds to run with output:\n " res) + (debug:print-info 9 *default-log-port* "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 @@ -274,23 +274,23 @@ 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 " setting: [" curr-section-name "] " key " = #t") + (debug:print 10 *default-log-port* " 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) + (debug:print-info 6 *default-log-port* "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) + (debug:print 10 *default-log-port* " 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 '()))) @@ -305,11 +305,11 @@ ;; (print "val: " val "\nnewval: \"" newval "\"\nvarflag: " var-flag) (hash-table-set! res curr-section-name (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 "ERROR: problem parsing " path ",\n \"" inl "\"") + (else (debug:print 0 *default-log-port* "ERROR: problem parsing " path ",\n \"" inl "\"") (set! var-flag #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)) @@ -318,11 +318,11 @@ (toppath (car 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 "set-fields with field-names=" field-names " target=" target " curr-section=" curr-section " next-section=" next-section " path=" path " ht=" ht) + (debug:print-info 9 *default-log-port* "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 post-section-procs: (list (cons "^fields$" set-fields)) #f)))) @@ -467,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 *default-log-port* "ERROR: problem parsing line number " lnum "\"" hed "\""))))) (else - (debug:print 0 "ERROR: Problem parsing line num " lnum " :\n " hed ))) + (debug:print 0 *default-log-port* "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))) Index: dashboard-tests.scm ================================================================== --- dashboard-tests.scm +++ dashboard-tests.scm @@ -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 *default-log-port* "Megatest subarea=" subarea ", area-exists=" area-exists) (if subarea (iup:frame #:title "Megatest Run Info" ; #:expand "YES" (iup:button "Launch Dashboard" @@ -424,11 +424,11 @@ (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 *default-log-port* "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 (rmt:get-key-val-pairs run-id) #f)) (rundat (if testdat (rmt:get-run-info run-id) #f)) @@ -441,11 +441,11 @@ (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 #f 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 (rmt:testmeta-get-record testname))) @@ -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)) + (debug:print-info 0 *default-log-port* "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 "need-update= " need-update " curr-mod-time = " curr-mod-time) + ;; (debug:print-info 0 *default-log-port* "need-update= " need-update " curr-mod-time = " curr-mod-time) (cond ((and need-update newtestdat) (set! testdat newtestdat) - (set! teststeps (tests:get-compressed-steps #f 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 *default-log-port* "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 *default-log-port* "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 *default-log-port* "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 "========" "========" "=====" "========" "===" "======" "=====" "====" "=======")) Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -41,11 +41,11 @@ (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-2016 Usage: dashboard [options] -h : this help @@ -72,11 +72,11 @@ "-guimonitor" "-main" "-v" "-q" "-use-local" - ) + ) args:arg-hash 0)) (if (args:get-arg "-h") (begin @@ -97,10 +97,11 @@ 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 @@ -119,11 +120,11 @@ tot-runs update-mutex updaters updating useserver - ) + ) (define *alldat* (make-d:alldat header: #f allruns: '() allruns-by-id: (make-hash-table) @@ -144,37 +145,13 @@ 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 )) -;; simple two dimentional sparse array -;; -(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))))) - ;; data for runs, tests etc ;; (defstruct d:rundat ;; new system runs-index ;; target/runname => colnum @@ -238,10 +215,11 @@ ((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)) @@ -328,11 +306,11 @@ (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)))) -(define (compare-tests test1 test2) +(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)) @@ -347,104 +325,122 @@ (string>? item-path1 item-path2) test1-older) (if same-time (string>? test-name1 test-name2) test1-older)))) - -;; create a virtual table of all the tests -;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") ) -(define (update-rundat runnamepatt numruns testnamepatt keypatts) - (let* ((referenced-run-ids '()) - (allruns (if (d:alldat-useserver *alldat*) - (rmt:get-runs runnamepatt numruns (d:alldat-start-run-offset *alldat*) keypatts) - (db:get-runs (d:alldat-dblocal *alldat*) runnamepatt numruns ;; (+ numruns 1) ;; (/ numruns 2)) - (d:alldat-start-run-offset *alldat*) keypatts))) - (header (db:get-header allruns)) - (runs (db:get-rows allruns)) - (result '()) - (maxtests 0) - (states (hash-table-keys (d:alldat-state-ignore-hash *alldat*))) - (statuses (hash-table-keys (d:alldat-status-ignore-hash *alldat*))) + +;; 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 *default-log-port* "(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")) - (key-vals (if (d:alldat-useserver *alldat*) + (key-vals (if (d:alldat-useserver data) (rmt:get-key-vals run-id) - (db:get-key-vals (d:alldat-dblocal *alldat*) run-id))) - (prev-dat (let ((rec (hash-table-ref/default (d:alldat-allruns-by-id *alldat*) 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 *alldat*) - (rmt:get-tests-for-run run-id testnamepatt states statuses - #f #f - (d:alldat-hide-not-hide *alldat*) - sort-by - sort-order - 'shortlist - last-update) - (db:get-tests-for-run (d:alldat-dblocal *alldat*) run-id testnamepatt states statuses - #f #f - (d:alldat-hide-not-hide *alldat*) - sort-by - sort-order - 'shortlist - last-update))) - (tests (let ((newdat (filter - (lambda (x) - (not (equal? (db:test-get-state x) "DELETED"))) ;; remove deleted tests but do it after merging - (delete-duplicates (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 compare-tests) - newdat)))) - ;; NOTE: bubble-up also sets the global (d:alldat-item-test-names *alldat*) + (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 *default-log-port* "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 (d:alldat-hide-empty-runs *alldat*)) ;; 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 *alldat*) 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) - (d:alldat-header-set! *alldat* header) - (d:alldat-allruns-set! *alldat* result) - (debug:print-info 6 "(d:alldat-allruns *alldat*) has " (length (d:alldat-allruns *alldat*)) " runs") + (d:alldat-header-set! data header) + (d:alldat-allruns-set! data result) + (debug:print-info 6 *default-log-port* "(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 "(")) @@ -479,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)) @@ -564,11 +560,11 @@ (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 (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)) @@ -679,17 +675,20 @@ (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! (d:alldat-searchpatts *alldat*) x val) + (d:alldat-filters-changed-set! *alldat* #t) (set-bg-on-filter)) (define (mark-for-update) + (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 ;;====================================================================== @@ -818,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 @@ -855,22 +856,22 @@ (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 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)) - )) + ;; (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 ;;====================================================================== ;; @@ -880,21 +881,25 @@ (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 1) @@ -939,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) @@ -959,17 +964,19 @@ (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 (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))) @@ -977,11 +984,11 @@ (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 @@ -1031,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) @@ -1067,14 +1074,14 @@ #:scrollbar "YES" #:posx "0.5" #:posy "0.5" #:button-cb (lambda (obj btn pressed x y status) ;; (print "obj: " obj ", pressed " pressed ", status " status) - ; (print "canvas-origin: " (canvas-origin the-cnv)) + ; (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)) + ;; (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)) @@ -1107,11 +1114,11 @@ (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))) - + (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) @@ -1146,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" @@ -1189,84 +1197,95 @@ (if (not (null? path)) (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 *default-log-port* "dboard:get-tests-dat: got " (length tdat) " test records for run " run-id) + (sort tdat (lambda (a b) + (let* ((aval (vector-ref a 2)) + (bval (vector-ref b 2)) + (anum (string->number aval)) + (bnum (string->number bval))) + (if (and anum bnum) + (< anum bnum) + (string<= aval bval))))))) ;; This is the Run Summary tab ;; -(define (dashboard:one-run db data) +(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 data (cdr run-path)))) + (run-id (tree-path->run-id ddata (cdr run-path)))) (if (number? run-id) (begin - (d:data-curr-run-id-set! 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 *default-log-port* "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 data) "," test-id "&"))) + (cmd (conc toolpath " -test " (d:data-curr-run-id ddata) "," test-id "&"))) (system cmd))))) (updater (lambda () - (let* ((runs-dat (if (d:alldat-useserver *alldat*) - (rmt:get-runs-by-patt (d:alldat-keys *alldat*) "%" #f #f #f #f) - (db:get-runs-by-patt db (d:alldat-keys *alldat*) "%" #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 (d:data-curr-run-id data)) + (run-id (d:data-curr-run-id ddata)) (last-update 0) ;; fix me - (tests-dat (let ((tdat (if run-id - (if (d:alldat-useserver *alldat*) - (rmt:get-tests-for-run run-id - (hash-table-ref/default (d:alldat-searchpatts *alldat*) "test-name" "%/%") - (hash-table-keys (d:alldat-state-ignore-hash *alldat*)) ;; '() - (hash-table-keys (d:alldat-status-ignore-hash *alldat*)) ;; '() - #f #f - (d:alldat-hide-not-hide *alldat*) - #f #f - "id,testname,item_path,state,status" - last-update) ;; get 'em all - (db:get-tests-for-run db run-id - (hash-table-ref/default (d:alldat-searchpatts *alldat*) "test-name" "%/%") - (hash-table-keys (d:alldat-state-ignore-hash *alldat*)) ;; '() - (hash-table-keys (d:alldat-status-ignore-hash *alldat*)) ;; '() - #f #f - (d:alldat-hide-not-hide *alldat*) - #f #f - "id,testname,item_path,state,status" - last-update)) - '()))) ;; 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))))))) + (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 *alldat*) 15) 3)) ;; (d:alldat-num-tests *alldat*) 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) @@ -1279,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)) - (d:alldat-keys *alldat*))) + (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 data) run-path #f)) + (if (not (hash-table-ref/default (d:data-path-run-ids ddata) run-path #f)) (begin - (hash-table-set! (d:data-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! (d:data-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") @@ -1359,88 +1379,60 @@ (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) - (d:data-runs-tree-set! 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) +(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 data (cdr run-path)))) + (run-id (tree-path->run-id ddata (cdr run-path)))) (if (number? run-id) (begin - (d:data-curr-run-id-set! data 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) - ))) + (d:data-curr-run-id-set! ddata run-id) + (dashboard:update-new-view-tab)) + (debug:print 0 *default-log-port* "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 data) "," test-id "&"))) + (cmd (conc toolpath " -test " (d:data-curr-run-id ddata) "," test-id "&"))) (system cmd))))) (updater (lambda () - (let* ((runs-dat (if (d:alldat-useserver *alldat*) - (rmt:get-runs-by-patt (d:alldat-keys *alldat*) "%" #f #f #f #f) - (db:get-runs-by-patt db (d:alldat-keys *alldat*) "%" #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 (d:data-curr-run-id data)) + (run-id (d:data-curr-run-id ddata)) (last-update 0) ;; fix me - (tests-dat (let ((tdat (if run-id - (if (d:alldat-useserver *alldat*) - (rmt:get-tests-for-run run-id - (hash-table-ref/default (d:alldat-searchpatts *alldat*) "test-name" "%/%") - (hash-table-keys (d:alldat-state-ignore-hash *alldat*)) ;; '() - (hash-table-keys (d:alldat-status-ignore-hash *alldat*)) ;; '() - #f #f - (d:alldat-hide-not-hide *alldat*) - #f #f - "id,testname,item_path,state,status" - last-update) ;; get 'em all - (db:get-tests-for-run db run-id - (hash-table-ref/default (d:alldat-searchpatts *alldat*) "test-name" "%/%") - (hash-table-keys (d:alldat-state-ignore-hash *alldat*)) ;; '() - (hash-table-keys (d:alldat-status-ignore-hash *alldat*)) ;; '() - #f #f - (d:alldat-hide-not-hide *alldat*) - #f #f - "id,testname,item_path,state,status" - last-update)) - '()))) ;; 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))))))) + (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 *alldat*) 15) 3)) ;; (d:alldat-num-tests *alldat*) 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) @@ -1459,25 +1451,25 @@ ;; (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 *alldat*))) + (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 data) run-path #f)) + (if (not (hash-table-ref/default (d:data-path-run-ids ddata) run-path #f)) (begin - (hash-table-set! (d:data-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! (d:data-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") @@ -1532,22 +1524,144 @@ (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-run-summary-tab updater) - (d:data-runs-tree-set! data tb) + (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 runs-sum-dat new-view-dat) - (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 *default-log-port* "(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 '()) @@ -1555,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) - (d:alldat-hide-empty-runs-set! *alldat* (not (d:alldat-hide-empty-runs *alldat*))) - (iup:attribute-set! obj "TITLE" (if (d:alldat-hide-empty-runs *alldat*) "+HideE" "-HideE")) - (mark-for-update))) - (let ((hideit (iup:button "HideTests" #:action (lambda (obj) - (d:alldat-hide-not-hide-set! *alldat* (not (d:alldat-hide-not-hide *alldat*))) - (iup:attribute-set! obj "TITLE" (if (d:alldat-hide-not-hide *alldat*) "HideTests" "NotHide")) - (mark-for-update))))) - (d:alldat-hide-not-hide-button-set! *alldat* hideit) ;; never used, can eliminate ... - hideit)) - (iup:hbox - (iup:button "Quit" #:action (lambda (obj) - ;; (if (d:alldat-dblocal *alldat*) (db:close-all (d:alldat-dblocal *alldat*))) - (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 *alldat*)) - (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! (d:alldat-status-ignore-hash *alldat*) status #t) - (hash-table-delete! (d:alldat-status-ignore-hash *alldat*) 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! (d:alldat-state-ignore-hash *alldat*) state #t) - (hash-table-delete! (d:alldat-state-ignore-hash *alldat*) 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 *alldat*))) - (d:alldat-start-run-offset-set! *alldat* val) - (mark-for-update) - (debug:print 6 "(d:alldat-start-run-offset *alldat*) " (d:alldat-start-run-offset *alldat*) " maxruns: " maxruns ", val: " val " oldmax: " oldmax) - (iup:attribute-set! obj "MAX" (* maxruns 10)))) - #:expand "HORIZONTAL" - #:max (* 10 (length (d:alldat-allruns *alldat*))) - #:min 0 - #:step 0.01))) - ;(iup:button "inc rows" #:action (lambda (obj)(d:alldat-num-tests-set! *alldat* (+ (d:alldat-num-tests *alldat*) 1)))) - ;(iup:button "dec rows" #:action (lambda (obj)(d:alldat-num-tests-set! *alldat* (if (> (d:alldat-num-tests *alldat*) 0)(- (d:alldat-num-tests *alldat*) 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 @@ -1681,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*)))) - (d:alldat-please-update-set! *alldat* #t) + (d:alldat-please-update-set! data #t) (d:alldat-start-test-offset-set! *alldat* (inexact->exact (round (/ val 10)))) - (debug:print 6 "(d:alldat-start-test-offset *alldat*) " (d:alldat-start-test-offset *alldat*) " val: " val " newmax: " newmax " oldmax: " oldmax) + (debug:print 6 *default-log-port* "(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" @@ -1762,41 +1776,45 @@ (list (iup:vbox ;; the header (apply iup:hbox (reverse hdrlst)) (apply iup:hbox (reverse bdylst)))))) - controls)) - (data (d:data-init (make-d:data))) + ;; controls + )) + ;; (data (d:data-init (make-d:data))) (tabs (iup:tabs #:tabchangepos-cb (lambda (obj curr prev) (d:alldat-please-update-set! *alldat* #t) (d:alldat-curr-tab-num-set! *alldat* curr)) - (dashboard:summary db) + (dashboard:summary *alldat*) runs-view - (dashboard:one-run db runs-sum-dat) - (dashboard:new-view db new-view-dat) + (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" "New View") - (iup:attribute-set! tabs "TABTITLE4" "Run Control") + (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") (d:alldat-hide-not-hide-tabs-set! *alldat* tabs) - tabs))) + (iup:vbox + tabs + controls)))) (vector keycol lftcol header runsvec))) (if (or (args:get-arg "-rows") (get-environment-variable "DASHBOARDROWS" )) (begin (d:alldat-num-tests-set! *alldat* (string->number (or (args:get-arg "-rows") (get-environment-variable "DASHBOARDROWS")))) - (update-rundat "%" (d:alldat-numruns *alldat*) "%/%" '())) - (d:alldat-num-tests-set! *alldat* (min (max (update-rundat "%" (d:alldat-numruns *alldat*) "%/%" '()) 8) 20))) + (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") @@ -1826,11 +1844,11 @@ (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 *default-log-port* "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 (d:alldat-dbdir *alldat*) "/*.db")))))) @@ -1851,11 +1869,11 @@ (begin (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 (d:alldat-searchpatts *alldat*) "runname" "%") (d:alldat-numruns *alldat*) + (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")) @@ -1865,11 +1883,11 @@ res)) (update-buttons uidat (d:alldat-numruns *alldat*) (d:alldat-num-tests *alldat*))) ((2) (dashboard:update-run-summary-tab)) ((3) - (dashboard:update-run-summary-tab)) + (dashboard:update-new-view-tab)) (else (let ((updater (hash-table-ref/default (d:alldat-updaters *alldat*) (d:alldat-curr-tab-num *alldat*) #f))) (if updater (updater))))) (d:alldat-please-update-set! *alldat* #f) @@ -1884,20 +1902,22 @@ (let ((debugcontrolf (conc (get-environment-variable "HOME") "/.dashboardrc"))) (if (file-exists? debugcontrolf) (load debugcontrolf))) (define (main) - (let ((runs-sum-dat (d:data-init (make-d:data))) ;; data for run-summary tab - (new-view-dat (d:data-init (make-d:data)))) + (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 *alldat*) runid))) + (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") ",")))) @@ -1909,42 +1929,42 @@ (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")) + (debug:print 3 *default-log-port* "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 *alldat*))) + (gui-monitor (d:alldat-dblocal data))) (else - (set! uidat (make-dashboard-buttons (d:alldat-dblocal *alldat*) - (d:alldat-numruns *alldat*) - (d:alldat-num-tests *alldat*) - (d:alldat-dbkeys *alldat*) - runs-sum-dat new-view-dat)) + (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 *alldat*)) - (set! update-is-running (d:alldat-updating *alldat*)) + (mutex-lock! (d:alldat-update-mutex data)) + (set! update-is-running (d:alldat-updating data)) (if (not update-is-running) - (d:alldat-updating-set! *alldat* #t)) - (mutex-unlock! (d:alldat-update-mutex *alldat*)) + (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 *alldat*)) - (d:alldat-updating-set! *alldat* #f) - (mutex-unlock! (d:alldat-update-mutex *alldat*))))) + (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! *alldat* #t) + (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) Index: datashare-testing/.sretrieve.config ================================================================== --- datashare-testing/.sretrieve.config +++ datashare-testing/.sretrieve.config @@ -1,8 +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)} 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 *default-log-port* "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 @@ -40,11 +40,11 @@ (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 "ERROR: query " stmt " failed, params: " params ", error: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 *default-log-port* "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 @@ -52,11 +52,11 @@ (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 *default-log-port* "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 @@ -111,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 *default-log-port* "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)))) @@ -152,11 +152,11 @@ (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 *default-log-port* "ERROR: Couldn't create path to " dbdir) (exit 1)) (if (not (directory? dbdir))(create-directory dbdir #t))) (if fname (conc dbdir "/" fname) dbdir))) @@ -192,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 *default-log-port* "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*))) @@ -218,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 *default-log-port* "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');" @@ -319,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 *default-log-port* "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)) @@ -339,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 *default-log-port* "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) @@ -386,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) @@ -509,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 *default-log-port* "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 *default-log-port* "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)))) @@ -527,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 *default-log-port* "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 *default-log-port* "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 @@ -545,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 *default-log-port* "FATAL: file " dbpath " was found corrupted, an attempt to fix has been made but you must start over.") + (debug:print 0 *default-log-port* " 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")) @@ -583,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 *default-log-port* "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 *default-log-port* " 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 *default-log-port* " status: " ((condition-property-accessor 'sqlite3 'status) exn)) + (debug:print 0 *default-log-port* " 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 *default-log-port* " dbpath: " dbpath) (if (not (db:repair-db dbdat)) (begin - (debug:print 0 "ERROR: Failed to rebuild " dbpath ", exiting now.") + (debug:print 0 *default-log-port* "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 @@ -609,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 *default-log-port* "WARNING: db:sync-tables called with fromdb missing") -1) + ((not todb) (debug:print 3 *default-log-port* "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 *default-log-port* "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 *default-log-port* "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)) @@ -663,11 +635,11 @@ ;; tack on remaining records in fromdat (if (not (null? fromdat)) (set! fromdats (cons fromdat fromdats))) (if (common:low-noise-print 120 "sync-records") - (debug:print-info 4 "found " totrecords " records to sync")) + (debug:print-info 4 *default-log-port* "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))) @@ -707,18 +679,18 @@ (sqlite3:finalize! stmth))) (append (list todb) slave-dbs)))) tbls) (let* ((runtime (- (current-milliseconds) start-time)) (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 "INFO: db sync, total run time " runtime " ms")) + (if should-print (debug:print 3 *default-log-port* "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 *default-log-port* (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: @@ -775,11 +747,11 @@ (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 *default-log-port* "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 @@ -792,11 +764,11 @@ (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 *default-log-port* "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) @@ -811,11 +783,11 @@ ;; 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 "Column last_update already added to runs table") + (debug:print 0 *default-log-port* "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 @@ -844,60 +816,67 @@ (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 + ;; 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 ;; - (handle-exceptions - exn - (if (string-match ".*duplicate.*" ((condition-property-accessor 'exn 'message) exn)) - (debug:print 0 "Column last_update already added to tests table") - (db:general-sqlite-error-dump exn "alter table tests ..." #f "none")) - (sqlite3:execute - frundb - "ALTER TABLE tests ADD COLUMN last_update INTEGER DEFAULT 0")) - (sqlite3:execute - frundb - "CREATE TRIGGER IF NOT EXISTS update_tests_trigger AFTER UPDATE ON tests + (for-each + (lambda (table-name) + (handle-exceptions + exn + (if (string-match ".*duplicate.*" ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 *default-log-port* "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 tests SET last_update=(strftime('%s','now')); - END;") - )))) + 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 *default-log-port* "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 *default-log-port* "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 *default-log-port* "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 *default-log-port* "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 *default-log-port* "open-run-close-no-exception-handling END" ) res) #f)) (define (open-run-close-exception-handling proc idb . params) (handle-exceptions @@ -906,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 *default-log-port* "EXCEPTION: database probably overloaded or unreadable.") + (debug:print 0 *default-log-port* " 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 *default-log-port* " 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 *default-log-port* "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) @@ -1036,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 *default-log-port* "db:initialize END"))))) ;;====================================================================== ;; R U N S P E C I F I C D B ;;====================================================================== @@ -1087,20 +1066,19 @@ 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, @@ -1108,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, @@ -1324,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 *default-log-port* "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) @@ -1344,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 *default-log-port* "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))) @@ -1383,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 *default-log-port* "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) @@ -1403,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 *default-log-port* "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) @@ -1419,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 *default-log-port* "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) ",") ");"))))) @@ -1452,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 *default-log-port* "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)) @@ -1475,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 *default-log-port* "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 *default-log-port* "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) @@ -1499,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 *default-log-port* "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)) @@ -1516,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 *default-log-port* "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 *default-log-port* "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) @@ -1540,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 *default-log-port* "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)) @@ -1563,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 *default-log-port* "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 *default-log-port* "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) @@ -1583,35 +1567,36 @@ ;;====================================================================== ;; returns number if string->number is successful, string otherwise ;; also updates *global-delta* ;; -;; Operates on megatestdb -;; (define (db:get-var dbstruct var) (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. + 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 "launch throttle factor=" *global-delta*) +;; (debug:print-info 4 *default-log-port* "launch throttle factor=" *global-delta*) ;; (set! *last-global-delta-printed* *global-delta*))) - res)) (define (db:set-var dbstruct var val) (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))) @@ -1724,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 *default-log-port* "keys: " keys " allvals: " allvals " keyvals: " keyvals " key=?str is " key=?str) + (debug:print 2 *default-log-port* "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) @@ -1737,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 *default-log-port* "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 *default-log-port* "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 "%") ) @@ -1778,20 +1763,20 @@ (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 *default-log-port* "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 *default-log-port* "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) @@ -1804,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 *default-log-port* "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)) @@ -1876,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 *default-log-port* "db:get-targets END qrystr: " qrystr ) (vector header res))))) ;; just get count of runs (define (db:get-num-runs dbstruct runpatt) (db:with-db @@ -1887,17 +1827,17 @@ dbstruct #f #f (lambda (db) (let ((numruns 0)) - (debug:print-info 11 "db:get-num-runs START " runpatt) + (debug:print-info 11 *default-log-port* "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 *default-log-port* "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) @@ -2038,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 *default-log-port* "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 *default-log-port* "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))) @@ -2068,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 *default-log-port* "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 *default-log-port* "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) @@ -2125,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 *default-log-port* "" 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) @@ -2222,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 last-update) +;; 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 *default-log-port* "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") @@ -2237,39 +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=? " (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 " ") "") + (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 ") @@ -2279,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 *default-log-port* "db:get-tests-for-run run-id=" run-id ", qry=" qry) (db:with-db dbstruct run-id #f (lambda (db) (sqlite3:for-each-row (lambda (a . b) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment) (set! res (cons (apply vector a b) res))) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment) res))) @@ -2311,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 *default-log-port* "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 @@ -2338,17 +2300,10 @@ 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" #f)) ;; do not use. @@ -2358,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)) @@ -2393,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 *default-log-port* "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) @@ -2621,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 *default-log-port* "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 *default-log-port* "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 @@ -2649,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 *default-log-port* "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 *default-log-port* "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))) @@ -2763,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 @@ -2813,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 *default-log-port* "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))) @@ -2840,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 *default-log-port* "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 ""))) @@ -2851,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 *default-log-port* "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 *default-log-port* "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 *default-log-port* "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))) @@ -2905,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 *default-log-port* "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) @@ -2975,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 *default-log-port* "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) @@ -3032,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 *default-log-port* "Found path: " path) + (debug:print 2 *default-log-port* "No such path: " path))) ;; ) db "SELECT rundir,final_logf FROM tests WHERE testname=? AND item_path='';" test-name) res)))) @@ -3287,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 *default-log-port* "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 #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 *default-log-port* "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))) @@ -3320,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 *default-log-port* "WARNING: failed to test for existance of " dbfj) (thread-sleep! 1) (db:delay-if-busy count (- count 1))) (file-exists? dbfj)) (case count ((6) @@ -3344,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 *default-log-port* "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) @@ -3421,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 *default-log-port* "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 *default-log-port* "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 *default-log-port* "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)))) @@ -3459,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 *default-log-port* "WARNING: itemmap has problem \"" itemmap "\", patt: " patt ", repl: " repl) res)))) (if (null? tal) newr (loop (car tal)(cdr tal) newr))))))) @@ -3594,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 *default-log-port* "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 @@ -3618,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 *default-log-port* "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)) @@ -3636,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 *default-log-port* "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)) @@ -3662,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 *default-log-port* "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 @@ -186,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 *default-log-port* "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 @@ -262,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 *default-log-port* "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) @@ -276,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 *default-log-port* "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)) @@ -293,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 *default-log-port* "run-changes: " run-changes) + ;; (debug:print 2 *default-log-port* "test-changes: " test-changes) (list run-changes all-test-changes))) ;;====================================================================== ;; TESTS DATA ;;====================================================================== @@ -363,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 @@ -685,12 +685,12 @@ (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 "test-box-info=" test-box-info) - ;; (debug:print 0 "test-record=" test-record) + ;; (debug:print 0 *default-log-port* "test-box-info=" test-box-info) + ;; (debug:print 0 *default-log-port* "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) @@ -880,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) @@ -891,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 *default-log-port* "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 *default-log-port* "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) + ADDED docs/waiton-analysis.gnumeric Index: docs/waiton-analysis.gnumeric ================================================================== --- /dev/null +++ docs/waiton-analysis.gnumeric cannot compute difference between binary files Index: env.scm ================================================================== --- env.scm +++ env.scm @@ -206,6 +206,6 @@ (begin (print "# Changed vars") (map (lambda (dat)(print (car dat) " " (cdr dat))) (hash-table->alist changed))))) (else - (debug:print 0 "ERROR: No dumpmode specified, use -dumpmode [bash|csh|config]"))))) + (debug:print 0 *default-log-port* "ERROR: No dumpmode specified, use -dumpmode [bash|csh|config]"))))) Index: ezsteps.scm ================================================================== --- ezsteps.scm +++ ezsteps.scm @@ -41,14 +41,14 @@ (let loop ((count 5)) (if (file-exists? test-run-dir) (push-directory test-run-dir) (if (> count 0) (begin - (debug:print 0 "WARNING: ezsteps attempting to run but test run directory " test-run-dir " is not there. Waiting and trying again " count " more times") + (debug:print 0 *default-log-port* "WARNING: ezsteps attempting to run but test run directory " test-run-dir " is not there. Waiting and trying again " count " more times") (sleep 3) (loop (- count 1)))))) - (debug:print-info 0 "Running in directory " test-run-dir) + (debug:print-info 0 *default-log-port* "Running in directory " test-run-dir) (if (not (file-exists? ".ezsteps"))(create-directory ".ezsteps")) ;; if ezsteps was defined then we are sure to have at least one step but check anyway (if (not (> (length ezstepslst) 0)) (message-window "ERROR: You can only re-run steps defined via ezsteps") (begin @@ -72,19 +72,19 @@ (if (equal? stepname start-step-name) (set! runflag #t) ;; and continue (if (not (null? tal)) (loop (car tal)(cdr tal) stepname #f)))) - (debug:print 4 "ezsteps:\n stepname: " stepname " stepinfo: " stepinfo " stepparts: " stepparts + (debug:print 4 *default-log-port* "ezsteps:\n stepname: " stepname " stepinfo: " stepinfo " stepparts: " stepparts " stepparms: " stepparms " stepcmd: " stepcmd) (if (file-exists? (conc stepname ".logpro"))(set! logpro-used #t)) ;; call the command using mt_ezstep (set! script (conc "mt_ezstep " stepname " " (if prevstep prevstep "-") " " stepcmd)) - (debug:print 4 "script: " script) + (debug:print 4 *default-log-port* "script: " script) (rmt:teststep-set-status! run-id test-id stepname "start" "-" #f #f) ;; now launch (let ((pid (process-run script))) (let processloop ((i 0)) (let-values (((pid-val exit-status exit-code)(process-wait pid #t))) @@ -115,11 +115,11 @@ (next-status (cond ((eq? overall-status 'pass) this-step-status) ((eq? overall-status 'warn) (if (eq? this-step-status 'fail) 'fail 'warn)) (else 'fail)))) - (debug:print 4 "Exit value received: " (vector-ref exit-info 2) " logpro-used: " logpro-used + (debug:print 4 *default-log-port* "Exit value received: " (vector-ref exit-info 2) " logpro-used: " logpro-used " this-step-status: " this-step-status " overall-status: " overall-status " next-status: " next-status " rollup-status: " rollup-status) (case next-status ((warn) (set! rollup-status 2) @@ -135,11 +135,11 @@ )))) (if (and (steprun-good? logpro-used (vector-ref exit-info 2)) (not (null? tal))) (if (not run-one) ;; if we got here we completed the step, if run-one is true, stop (loop (car tal) (cdr tal) stepname runflag)))) - (debug:print 4 "WARNING: a prior step failed, stopping at " ezstep))) + (debug:print 4 *default-log-port* "WARNING: a prior step failed, stopping at " ezstep))) ;; Once done with step/steps update the test record ;; (let* ((item-path (db:test-get-item-path testdat)) ;; (item-list->path itemdat)) (testinfo (rmt:get-testinfo-by-id run-id test-id))) ;; refresh the testdat, call it iteminfo in case need prev/curr @@ -157,11 +157,11 @@ ((eq? rollup-status 1) "FAIL") ((eq? rollup-status 2) ;; if the current status is AUTO the defer to the calculated value but qualify (i.e. make this AUTO-WARN) (if (equal? (db:test-get-status testinfo) "AUTO") "AUTO-WARN" "WARN")) (else "FAIL")))) ;; (db:test-get-status testinfo))) - (debug:print-info 2 "Test NOT logged as COMPLETED, (state=" (db:test-get-state testinfo) "), updating result, rollup-status is " rollup-status) + (debug:print-info 2 *default-log-port* "Test NOT logged as COMPLETED, (state=" (db:test-get-state testinfo) "), updating result, rollup-status is " rollup-status) (tests:test-set-status! test-id new-state new-status (args:get-arg "-m") #f) ;; need to update the top test record if PASS or FAIL and this is a subtest Index: fs-transport.scm ================================================================== --- fs-transport.scm +++ fs-transport.scm @@ -37,8 +37,8 @@ ;; (define (fs:process-queue-item packet) (if (not *megatest-db*) ;; we will require that (setup-for-run) has already been called (set! *megatest-db* (open-db))) - (debug:print-info 11 "fs:process-queue-item called with packet=" packet) + (debug:print-info 11 *default-log-port* "fs:process-queue-item called with packet=" packet) (db:process-queue-item *megatest-db* packet)) Index: http-transport.scm ================================================================== --- http-transport.scm +++ http-transport.scm @@ -48,11 +48,11 @@ ;; (define *db:process-queue-mutex* (make-mutex)) (define (http-transport:run hostn run-id server-id) - (debug:print 2 "Attempting to start the server ...") + (debug:print 2 *default-log-port* "Attempting to start the server ...") (let* ((db #f) ;; (open-db)) ;; we don't want the server to be opening and closing the db unnecesarily (hostname (get-host-name)) (ipaddrstr (let ((ipstr (if (string=? "-" hostn) ;; (string-intersperse (map number->string (u8vector->list (hostname->ip hostname))) ".") (server:get-best-guess-address hostname) @@ -59,11 +59,11 @@ #f))) (if ipstr ipstr hostn))) ;; hostname))) (start-port (portlogger:open-run-close portlogger:find-port)) (link-tree-path (configf:lookup *configdat* "setup" "linktree"))) ;; (set! db *inmemdb*) - (debug:print-info 0 "portlogger recommended port: " start-port) + (debug:print-info 0 *default-log-port* "portlogger recommended port: " start-port) (root-path (if link-tree-path link-tree-path (current-directory))) ;; WARNING: SECURITY HOLE. FIX ASAP! (handle-directory spiffy-directory-listing) (handle-exception (lambda (exn chain) @@ -112,22 +112,22 @@ ;; This is recursively run by http-transport:run until sucessful ;; (define (http-transport:try-start-server run-id ipaddrstr portnum server-id) (let ((config-hostname (configf:lookup *configdat* "server" "hostname")) (tdbdat (tasks:open-db))) - (debug:print-info 0 "http-transport:try-start-server run-id=" run-id " ipaddrsstr=" ipaddrstr " portnum=" portnum " server-id=" server-id " config-hostname=" config-hostname) + (debug:print-info 0 *default-log-port* "http-transport:try-start-server run-id=" run-id " ipaddrsstr=" ipaddrstr " portnum=" portnum " server-id=" server-id " config-hostname=" config-hostname) (handle-exceptions exn (begin (print-error-message exn) (if (< portnum 64000) (begin - (debug:print 0 "WARNING: attempt to start server failed. Trying again ...") - (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) - (debug:print 0 "exn=" (condition->list exn)) + (debug:print 0 *default-log-port* "WARNING: attempt to start server failed. Trying again ...") + (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 *default-log-port* "exn=" (condition->list exn)) (portlogger:open-run-close portlogger:set-failed portnum) - (debug:print 0 "WARNING: failed to start on portnum: " portnum ", trying next port") + (debug:print 0 *default-log-port* "WARNING: failed to start on portnum: " portnum ", trying next port") (thread-sleep! 0.1) ;; get_next_port goes here (http-transport:try-start-server run-id ipaddrstr @@ -140,11 +140,11 @@ (set! *server-info* (list ipaddrstr portnum)) (tasks:server-set-interface-port (db:delay-if-busy tdbdat) server-id ipaddrstr portnum) - (debug:print 0 "INFO: Trying to start server on " ipaddrstr ":" portnum) + (debug:print 0 *default-log-port* "INFO: Trying to start server on " ipaddrstr ":" portnum) ;; This starts the spiffy server ;; NEED WAY TO SET IP TO #f TO BIND ALL ;; (start-server bind-address: ipaddrstr port: portnum) (if config-hostname ;; this is a hint to bind directly (start-server port: portnum bind-address: (if (equal? config-hostname "-") @@ -151,11 +151,11 @@ ipaddrstr config-hostname)) (start-server port: portnum)) ;; (portlogger:open-run-close portlogger:set-port portnum "released") (tasks:server-force-clean-run-record (db:delay-if-busy tdbdat) run-id ipaddrstr portnum " http-transport:try-start-server") - (debug:print 1 "INFO: server has been stopped")))) + (debug:print 1 *default-log-port* "INFO: server has been stopped")))) ;;====================================================================== ;; S E R V E R U T I L I T I E S ;;====================================================================== @@ -183,11 +183,11 @@ (mutex-lock! *http-mutex*) (set! *http-requests-in-progress* (+ 1 *http-requests-in-progress*)) ;; Use this opportunity to slow things down iff there are too many requests in flight (if (> *http-requests-in-progress* 5) (begin - (debug:print-info 0 "Whoa there buddy, ease up...") + (debug:print-info 0 *default-log-port* "Whoa there buddy, ease up...") (thread-sleep! 1))) (mutex-unlock! *http-mutex*)) (define (http-transport:dec-requests-count proc) (mutex-lock! *http-mutex*) @@ -201,11 +201,11 @@ (if (> *http-requests-in-progress* 0) (if (> etime (current-seconds)) (begin (thread-sleep! 0.05) (loop etime)) - (debug:print 0 "ERROR: requests still in progress after 5 seconds of waiting. I'm going to pass on cleaning up http connections")) + (debug:print 0 *default-log-port* "ERROR: requests still in progress after 5 seconds of waiting. I'm going to pass on cleaning up http connections")) (close-all-connections!))) (set! *http-connections-next-cleanup* (+ (current-seconds) 10)) (mutex-unlock! *http-mutex*)) (define (http-transport:inc-requests-and-prep-to-close-all-connections) @@ -216,11 +216,11 @@ ;; (define (http-transport:client-api-send-receive run-id serverdat cmd params #!key (numretries 3)) (let* ((fullurl (if (vector? serverdat) (http-transport:server-dat-get-api-req serverdat) (begin - (debug:print 0 "FATAL ERROR: http-transport:client-api-send-receive called with no server info") + (debug:print 0 *default-log-port* "FATAL ERROR: http-transport:client-api-send-receive called with no server info") (exit 1)))) (res #f) (success #t) (sparams (db:obj->string params transport: 'http))) ;; (condition-case @@ -230,20 +230,20 @@ ;; (begin ;; (mutex-unlock! *http-mutex*) ;; (thread-sleep! 1) ;; (handle-exceptions ;; exn -;; (debug:print 0 "WARNING: closing connections failed. Server at " fullurl " almost certainly dead") +;; (debug:print 0 *default-log-port* "WARNING: closing connections failed. Server at " fullurl " almost certainly dead") ;; (close-all-connections!)) -;; (debug:print 0 "WARNING: Failed to communicate with server, trying again, numretries left: " numretries) +;; (debug:print 0 *default-log-port* "WARNING: Failed to communicate with server, trying again, numretries left: " numretries) ;; (http-transport:client-api-send-receive run-id serverdat cmd sparams numretries: (- numretries 1))) ;; (begin ;; (mutex-unlock! *http-mutex*) ;; (tasks:kill-server-run-id run-id) ;; #f)) ;; (begin - (debug:print-info 11 "fullurl=" fullurl ", cmd=" cmd ", params=" params ", run-id=" run-id "\n") + (debug:print-info 11 *default-log-port* "fullurl=" fullurl ", cmd=" cmd ", params=" params ", run-id=" run-id "\n") ;; set up the http-client here (max-retry-attempts 1) ;; consider all requests indempotent (retry-request? (lambda (request) #f)) @@ -259,12 +259,12 @@ (db:string->obj (handle-exceptions exn (begin (set! success #f) - (debug:print 0 "WARNING: failure in with-input-from-request to " fullurl ".") - (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 *default-log-port* "WARNING: failure in with-input-from-request to " fullurl ".") + (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) (hash-table-delete! *runremote* run-id) ;; Killing associated server to allow clean retry.") ;; (tasks:kill-server-run-id run-id) ;; better to kill the server in the logic that called this routine? (mutex-unlock! *http-mutex*) ;;; (signal (make-composite-condition @@ -289,19 +289,19 @@ (th2 (make-thread time-out "time out"))) (thread-start! th1) (thread-start! th2) (thread-join! th1) (thread-terminate! th2) - (debug:print-info 11 "got res=" res) + (debug:print-info 11 *default-log-port* "got res=" res) (if (vector? res) (if (vector-ref res 0) res (begin ;; note: this code also called in nmsg-transport - consider consolidating it - (debug:print 0 "ERROR: error occured at server, info=" (vector-ref res 2)) - (debug:print 0 " client call chain:") + (debug:print 0 *default-log-port* "ERROR: error occured at server, info=" (vector-ref res 2)) + (debug:print 0 *default-log-port* " client call chain:") (print-call-chain (current-error-port)) - (debug:print 0 " server call chain:") + (debug:print 0 *default-log-port* " server call chain:") (pp (vector-ref res 1) (current-error-port)) (signal (vector-ref result 0)))) (signal (make-composite-condition (make-property-condition 'timeout @@ -339,11 +339,11 @@ (define (http-transport:server-dat-update-last-access vec) (if (vector? vec) (vector-set! vec 5 (current-seconds)) (begin (print-call-chain (current-error-port)) - (debug:print 0 "ERROR: call to http-transport:server-dat-update-last-access with non-vector!!")))) + (debug:print 0 *default-log-port* "ERROR: call to http-transport:server-dat-update-last-access with non-vector!!")))) ;; ;; connect ;; (define (http-transport:client-connect iface port) @@ -358,32 +358,32 @@ ;; (define (http-transport:keep-running server-id run-id) ;; if none running or if > 20 seconds since ;; server last used then start shutdown ;; This thread waits for the server to come alive - (debug:print-info 0 "Starting the sync-back, keep alive thread in server for run-id=" run-id) + (debug:print-info 0 *default-log-port* "Starting the sync-back, keep alive thread in server for run-id=" run-id) (let* ((tdbdat (tasks:open-db)) (server-start-time (current-seconds)) (server-info (let loop ((start-time (current-seconds)) (changed #t) (last-sdat "not this")) (let ((sdat #f)) (thread-sleep! 0.01) - (debug:print-info 0 "Waiting for server alive signature") + (debug:print-info 0 *default-log-port* "Waiting for server alive signature") (mutex-lock! *heartbeat-mutex*) (set! sdat *server-info*) (mutex-unlock! *heartbeat-mutex*) (if (and sdat (not changed) (> (- (current-seconds) start-time) 2)) sdat (begin - (debug:print-info 0 "Still waiting, last-sdat=" last-sdat) + (debug:print-info 0 *default-log-port* "Still waiting, last-sdat=" last-sdat) (sleep 4) (if (> (- (current-seconds) start-time) 120) ;; been waiting for two minutes (begin - (debug:print 0 "ERROR: transport appears to have died, exiting server " server-id " for run " run-id) + (debug:print 0 *default-log-port* "ERROR: transport appears to have died, exiting server " server-id " for run " run-id) (tasks:server-delete-record (db:delay-if-busy tdbdat) server-id "failed to start, never received server alive signature") (exit)) (loop start-time (equal? sdat last-sdat) sdat))))))) @@ -408,16 +408,16 @@ (http-transport:server-shutdown server-id port)) (else ;; (> bad-sync-count 0) ;; we've had a fail or two, delay and loop (thread-sleep! 5) (loop count server-state (+ bad-sync-count 1))))) ((exn) - (debug:print 0 "ERROR: error from sync code other than 'sync-failed. Attempting to gracefully shutdown the server") + (debug:print 0 *default-log-port* "ERROR: error from sync code other than 'sync-failed. Attempting to gracefully shutdown the server") (tasks:server-delete-record (db:delay-if-busy tdbdat) server-id " http-transport:keep-running crashed") (exit))) (set! sync-time (- (current-milliseconds) start-time)) (set! rem-time (quotient (- 4000 sync-time) 1000)) - (debug:print 4 "SYNC: time= " sync-time ", rem-time=" rem-time) + (debug:print 4 *default-log-port* "SYNC: time= " sync-time ", rem-time=" rem-time) (if (and (<= rem-time 4) (> rem-time 0)) (thread-sleep! rem-time) (thread-sleep! 4))) ;; fallback for if the math is changed ... @@ -449,20 +449,20 @@ (mutex-unlock! *heartbeat-mutex*) (if (or (not (equal? sdat (list iface port))) (not server-id)) (begin - (debug:print-info 0 "interface changed, refreshing iface and port info") + (debug:print-info 0 *default-log-port* "interface changed, refreshing iface and port info") (set! iface (car sdat)) (set! port (cadr sdat)))) ;; Transfer *last-db-access* to last-access to use in checking that we are still alive (mutex-lock! *heartbeat-mutex*) (set! last-access *last-db-access*) (mutex-unlock! *heartbeat-mutex*) - ;; (debug:print 11 "last-access=" last-access ", server-timeout=" server-timeout) + ;; (debug:print 11 *default-log-port* "last-access=" last-access ", server-timeout=" server-timeout) ;; ;; no_traffic, no running tests, if server 0, no running servers ;; ;; (let ((wait-on-running (configf:lookup *configdat* "server" b"wait-on-running"))) ;; wait on running tasks (if not true then exit on time out) ;; @@ -469,17 +469,17 @@ (let* ((hrs-since-start (/ (- (current-seconds) server-start-time) 3600)) (adjusted-timeout (if (> hrs-since-start 1) (- server-timeout (inexact->exact (round (* hrs-since-start 60)))) ;; subtract 60 seconds per hour server-timeout))) (if (common:low-noise-print 120 "server timeout") - (debug:print-info 0 "Adjusted server timeout: " adjusted-timeout)) + (debug:print-info 0 *default-log-port* "Adjusted server timeout: " adjusted-timeout)) (if (and *server-run* (> (+ last-access server-timeout) (current-seconds))) (begin (if (common:low-noise-print 120 "server continuing") - (debug:print-info 0 "Server continuing, seconds since last db access: " (- (current-seconds) last-access))) + (debug:print-info 0 *default-log-port* "Server continuing, seconds since last db access: " (- (current-seconds) last-access))) ;; ;; Consider implementing some smarts here to re-insert the record or kill self is ;; the db indicates so ;; ;; (if (tasks:server-am-i-the-server? tdb run-id) @@ -488,36 +488,36 @@ (loop 0 server-state bad-sync-count)) (http-transport:server-shutdown server-id port)))))) (define (http-transport:server-shutdown server-id port) (let ((tdbdat (tasks:open-db))) - (debug:print-info 0 "Starting to shutdown the server.") + (debug:print-info 0 *default-log-port* "Starting to shutdown the server.") ;; need to delete only *my* server entry (future use) (set! *time-to-exit* #t) (if *inmemdb* (db:sync-touched *inmemdb* *run-id* force-sync: #t)) ;; ;; start_shutdown ;; (tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "shutting-down") (portlogger:open-run-close portlogger:set-port port "released") (thread-sleep! 5) - (debug:print-info 0 "Max cached queries was " *max-cache-size*) - (debug:print-info 0 "Number of cached writes " *number-of-writes*) - (debug:print-info 0 "Average cached write time " + (debug:print-info 0 *default-log-port* "Max cached queries was " *max-cache-size*) + (debug:print-info 0 *default-log-port* "Number of cached writes " *number-of-writes*) + (debug:print-info 0 *default-log-port* "Average cached write time " (if (eq? *number-of-writes* 0) "n/a (no writes)" (/ *writes-total-delay* *number-of-writes*)) " ms") - (debug:print-info 0 "Number non-cached queries " *number-non-write-queries*) - (debug:print-info 0 "Average non-cached time " + (debug:print-info 0 *default-log-port* "Number non-cached queries " *number-non-write-queries*) + (debug:print-info 0 *default-log-port* "Average non-cached time " (if (eq? *number-non-write-queries* 0) "n/a (no queries)" (/ *total-non-write-delay* *number-non-write-queries*)) " ms") - (debug:print-info 0 "Server shutdown complete. Exiting") + (debug:print-info 0 *default-log-port* "Server shutdown complete. Exiting") (tasks:server-delete-record (db:delay-if-busy tdbdat) server-id " http-transport:keep-running complete") (exit))) ;; all routes though here end in exit ... ;; @@ -533,11 +533,11 @@ (begin (current-error-port *alt-log-file*) (current-output-port *alt-log-file*))))) (if (server:check-if-running run-id) (begin - (debug:print 0 "INFO: Server for run-id " run-id " already running") + (debug:print 0 *default-log-port* "INFO: Server for run-id " run-id " already running") (exit 0))) (let loop ((server-id (tasks:server-lock-slot (db:delay-if-busy tdbdat) run-id)) (remtries 4)) (if (not server-id) (if (> remtries 0) @@ -545,23 +545,23 @@ (thread-sleep! 2) (loop (tasks:server-lock-slot (db:delay-if-busy tdbdat) run-id) (- remtries 1))) (begin ;; since we didn't get the server lock we are going to clean up and bail out - (debug:print-info 2 "INFO: server pid=" (current-process-id) ", hostname=" (get-host-name) " not starting due to other candidates ahead in start queue") + (debug:print-info 2 *default-log-port* "INFO: server pid=" (current-process-id) ", hostname=" (get-host-name) " not starting due to other candidates ahead in start queue") (tasks:server-delete-records-for-this-pid (db:delay-if-busy tdbdat) " http-transport:launch") )) (let* ((th2 (make-thread (lambda () - (debug:print-info 0 "Server run thread started") + (debug:print-info 0 *default-log-port* "Server run thread started") (http-transport:run (if (args:get-arg "-server") (args:get-arg "-server") "-") run-id server-id)) "Server run")) (th3 (make-thread (lambda () - (debug:print-info 0 "Server monitor thread started") + (debug:print-info 0 *default-log-port* "Server monitor thread started") (http-transport:keep-running server-id run-id)) "Keep running"))) (thread-start! th2) (thread-sleep! 0.25) ;; give the server time to settle before starting the keep-running monitor. (thread-start! th3) @@ -583,18 +583,18 @@ (define (http-transport:server-signal-handler signum) (signal-mask! signum) (handle-exceptions exn - (debug:print " ... exiting ...") + (debug:print 0 *default-log-port* " ... exiting ...") (let ((th1 (make-thread (lambda () (thread-sleep! 1)) "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 *default-log-port* "ERROR: Received ^C, attempting clean exit. Please be patient and wait a few seconds before hitting ^C again.") (thread-sleep! 3) ;; give the flush three seconds to do it's stuff - (debug:print 0 " Done.") + (debug:print 0 *default-log-port* " Done.") (exit 4)) "exit on ^C timer"))) (thread-start! th2) (thread-start! th1) (thread-join! th2)))) ADDED inteldate.scm Index: inteldate.scm ================================================================== --- /dev/null +++ inteldate.scm @@ -0,0 +1,180 @@ +(use srfi-19) +(use test) +(use format) +(use regex) +(declare (unit inteldate)) +;; utility procedures to convert among +;; different ways to express date (inteldate, seconds since epoch, isodate) +;; +;; samples: +;; isodate -> "2016-01-01" +;; inteldate -> "16ww01.5" +;; seconds -> 1451631600 + +;; procedures provided: +;; ==================== +;; seconds->isodate +;; seconds->inteldate +;; +;; isodate->seconds +;; isodate->inteldate +;; +;; inteldate->seconds +;; inteldate->isodate + +;; srfi-19 used extensively; this doc is better tha the eggref: +;; http://srfi.schemers.org/srfi-19/srfi-19.html + +;; Author: brandon.j.barclay@intel.com 16ww18.6 + +(define (date->seconds date) + (inexact->exact + (string->number + (date->string date "~s")))) + +(define (seconds->isodate seconds) + (let* ((date (seconds->date seconds)) + (result (date->string date "~Y-~m-~d"))) + result)) + +(define (isodate->seconds isodate) + "Takes a string input of the form 'YY-MM-DD' or 'YYYY-MM-DD' and returns epoch time; for YY, assume after Y2K" + (let* ((numlist (map string->number (string-split isodate "-"))) + (raw-year (car numlist)) + (year (if (< raw-year 100) (+ raw-year 2000) raw-year)) + (month (list-ref numlist 1)) + (day (list-ref numlist 2)) + (date (make-date 0 0 0 0 day month year)) + (seconds (date->seconds date))) + + seconds)) + +;; adapted from perl Intel::WorkWeek perl module +;; intel year consists of numbered weeks starting from week 1 +;; week 1 is the week containing jan 1 of the year +;; days of week are numbered starting from 0 on sunday +;; intel year does not match calendar year in workweek 1 +;; before jan1. +(define (seconds->inteldate-values seconds) + (define (date-difference->seconds d1 d2) + (- (date->seconds d1) (date->seconds d2))) + + (let* ((thisdate (seconds->date seconds)) + (thisdow (string->number (date->string thisdate "~w"))) + + (year (date-year thisdate)) + ;; intel workweek 1 begins on sunday of week containing jan1 + (jan1 (make-date 0 0 0 0 1 1 year)) + (jan1dow (date-week-day jan1)) + (ww01 (date-subtract-duration jan1 (seconds->time (* 60 60 24 jan1dow)))) + + (ww01_delta_seconds (date-difference->seconds thisdate ww01)) + (wwnum_initial (inexact->exact (add1 (floor (/ ww01_delta_seconds 24 3600 7) )))) + + ;; we could be in ww1 of next year + (this-saturday (seconds->date + (+ seconds + (* 60 60 24 (- 6 thisdow))))) + (this-week-ends-next-year? + (> (date-year this-saturday) year)) + (intelyear + (if this-week-ends-next-year? + (add1 year) + year)) + (intelweek + (if this-week-ends-next-year? + 1 + wwnum_initial))) + (values intelyear intelweek thisdow))) + +(define (seconds->inteldate seconds) + (define (string-leftpad in width pad-char) + (let* ((unpadded-str (->string in)) + (padlen_temp (- width (string-length unpadded-str))) + (padlen (if (< padlen_temp 0) 0 padlen_temp)) + (padding + (fold conc "" + (map (lambda (x) (->string pad-char)) (iota padlen))))) + (conc padding unpadded-str))) + (define (zeropad num width) + (string-leftpad num width #:0)) + + (let-values (((intelyear intelweek day-of-week-num) + (seconds->inteldate-values seconds))) + (let ((intelyear-str + (zeropad + (->string + (if (> intelyear 1999) + (- intelyear 2000) intelyear)) + 2)) + (intelweek-str + (zeropad (->string intelweek) 2)) + (dow-str (->string day-of-week-num))) + (conc intelyear-str "ww" intelweek-str "." dow-str)))) + +(define (isodate->inteldate isodate) + (seconds->inteldate + (isodate->seconds isodate))) + +(define (inteldate->seconds inteldate) + (let ((match (string-match "^(\\d+)ww(\\d+).(\\d)$" inteldate))) + (if + (not match) + #f + (let* ( + (intelyear-raw (string->number (list-ref match 1))) + (intelyear (if (< intelyear-raw 100) + (+ intelyear-raw 2000) + intelyear-raw)) + (intelww (string->number (list-ref match 2))) + (dayofweek (string->number (list-ref match 3))) + + (day-of-seconds (* 60 60 24 )) + (week-of-seconds (* day-of-seconds 7)) + + + ;; get seconds at ww1.0 + (new-years-date (make-date 0 0 0 0 1 1 intelyear)) + (new-years-seconds + (date->seconds new-years-date)) + (new-years-dayofweek (date-week-day new-years-date)) + (ww1.0_seconds (- new-years-seconds + (* day-of-seconds + new-years-dayofweek))) + (workweek-adjustment (* week-of-seconds (sub1 intelww))) + (weekday-adjustment (* dayofweek day-of-seconds)) + + (result (+ ww1.0_seconds workweek-adjustment weekday-adjustment))) + result)))) + +(define (inteldate->isodate inteldate) + (seconds->isodate (inteldate->seconds inteldate))) + +(define (inteldate-tests) + (test-group + "date conversion tests" + (let ((test-table + '(("16ww01.5" . "2016-01-01") + ("16ww18.5" . "2016-04-29") + ("1999ww33.5" . "1999-08-13") + ("16ww18.4" . "2016-04-28") + ("16ww18.3" . "2016-04-27") + ("13ww01.0" . "2012-12-30") + ("13ww52.6" . "2013-12-28") + ("16ww53.3" . "2016-12-28")))) + (for-each + (lambda (test-pair) + (let ((inteldate (car test-pair)) + (isodate (cdr test-pair))) + (test + (conc "(isodate->inteldate "isodate ") => "inteldate) + inteldate + (isodate->inteldate isodate)) + + (test + (conc "(inteldate->isodate "inteldate ") => "isodate) + isodate + (inteldate->isodate inteldate)))) + test-table)))) + +;(inteldate-tests) Index: items.scm ================================================================== --- items.scm +++ items.scm @@ -45,26 +45,26 @@ (define (item-assoc->item-list itemsdat) (if (and itemsdat (not (null? itemsdat))) (let ((itemlst (filter (lambda (x) (list? x)) (map (lambda (x) - (debug:print 6 "item-assoc->item-list x: " x) + (debug:print 6 *default-log-port* "item-assoc->item-list x: " x) (if (< (length x) 2) (begin - (debug:print 0 "ERROR: malformed items spec " (string-intersperse x " ")) + (debug:print 0 *default-log-port* "ERROR: malformed items spec " (string-intersperse x " ")) (list (car x)'())) (let* ((name (car x)) (items (cadr x)) (ilist (list name (if (string? items) (string-split items) '())))) (if (null? ilist) - (debug:print 0 "ERROR: No items specified for " name)) + (debug:print 0 *default-log-port* "ERROR: No items specified for " name)) ilist))) itemsdat)))) (let ((debuglevel 5)) - (debug:print 5 "item-assoc->item-list: itemsdat => itemlst ") + (debug:print 5 *default-log-port* "item-assoc->item-list: itemsdat => itemlst ") (if (debug:debug-mode 5) (begin (pp itemsdat) (print " => ") (pp itemlst)))) @@ -93,11 +93,11 @@ (rowdat (cadr row))) (set! item (append item (list (if (< indx (length rowdat)) (let ((new (list rowname (list-ref rowdat indx)))) - ;; (debug:print 0 "New: " new) + ;; (debug:print 0 *default-log-port* "New: " new) (set! elflag #t) new ) ;; i.e. had at least on legit value to use (list rowname "-"))))))) newlst) @@ -121,11 +121,11 @@ (define (items:get-items-from-config tconfig) (let* ((have-items (hash-table-ref/default tconfig "items" #f)) (have-itable (hash-table-ref/default tconfig "itemstable" #f)) (items (hash-table-ref/default tconfig "items" '())) (itemstable (hash-table-ref/default tconfig "itemstable" '()))) - (debug:print 5 "items: " items " itemstable: " itemstable) + (debug:print 5 *default-log-port* "items: " items " itemstable: " itemstable) (set! items (map (lambda (item) (if (procedure? (cadr item)) (list (car item)((cadr item))) ;; evaluate the proc item)) items)) @@ -132,16 +132,16 @@ (set! itemstable (map (lambda (item) (if (procedure? (cadr item)) (list (car item)((cadr item))) ;; evaluate the proc item)) itemstable)) - (if (and have-items (null? items)) (debug:print 0 "ERROR: [items] section in testconfig but no entries defined")) - (if (and have-itable (null? itemstable))(debug:print 0 "ERROR: [itemstable] section in testconfig but no entries defined")) + (if (and have-items (null? items)) (debug:print 0 *default-log-port* "ERROR: [items] section in testconfig but no entries defined")) + (if (and have-itable (null? itemstable))(debug:print 0 *default-log-port* "ERROR: [itemstable] section in testconfig but no entries defined")) (if (or (not (null? items))(not (null? itemstable))) (append (item-assoc->item-list items) (item-table->item-list itemstable)) '(())))) ;; (pp (item-assoc->item-list itemdat)) Index: keys.scm ================================================================== --- keys.scm +++ keys.scm @@ -43,13 +43,13 @@ (for-each (lambda (key val) (setenv key val) (if ht (hash-table-set! ht (conc ":" key) val))) keys vals) - (debug:print 0 "ERROR: wrong number of values in " target ", should match " keys)) + (debug:print 0 *default-log-port* "ERROR: wrong number of values in " target ", should match " keys)) vals) - (debug:print 4 "ERROR: keys:target-set-args called with no target."))) + (debug:print 4 *default-log-port* "ERROR: keys:target-set-args called with no target."))) ;; given the keys (a list of vectors or a list of keys) and a target return a keyval list ;; keyval list ( (key1 val1) (key2 val2) ...) (define (keys:target->keyval keys target) (let* ((targlist (string-split target "/")) Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -11,12 +11,12 @@ ;;====================================================================== ;; launch a task - this runs on the originating host, tests themselves ;; ;;====================================================================== -(use regex regex-case base64 sqlite3 srfi-18 directory-utils posix-extras z3 call-with-environment-variables) -(use defstruct) +(use regex regex-case base64 sqlite3 srfi-18 directory-utils posix-extras z3 call-with-environment-variables csv) +(use defstruct pathname-expand) (import (prefix base64 base64:)) (import (prefix sqlite3 sqlite3:)) (declare (unit launch)) @@ -55,10 +55,29 @@ (common:read-encoded-string enccmd) '()))) ;; 0 1 2 3 (defstruct launch:einf (pid #t)(exit-status #t)(exit-code #t)(rollup-status 0)) + +;; return (conc status ": " comment) from the final section so that +;; the comment can be set in the step record in launch.scm +;; +(define (launch:load-logpro-dat run-id test-id stepname) + (let ((cname (conc stepname ".dat"))) + (if (file-exists? cname) + (let* ((dat (read-config cname #f #f)) + (csvr (db:logpro-dat->csv dat stepname)) + (csvt (let-values (( (fmt-cell fmt-record fmt-csv) (make-format ","))) + (fmt-csv (map list->csv-record csvr)))) + (status (configf:lookup dat "final" "exit-status")) + (msg (configf:lookup dat "final" "message"))) + (rmt:csv->test-data run-id test-id csvt) + (cond + ((equal? status "PASS") "PASS") ;; skip the message part if status is pass + (status (conc (configf:lookup dat "final" "exit-status") ": " (if msg msg "no message"))) + (else #f))) + #f))) (define (launch:runstep ezstep run-id test-id exit-info m tal testconfig) (let* ((stepname (car ezstep)) ;; do stuff to run the step (stepinfo (cadr ezstep)) (stepparts (string-match (regexp "^(\\{([^\\}]*)\\}\\s*|)(.*)$") stepinfo)) @@ -65,10 +84,11 @@ (stepparms (list-ref stepparts 2)) ;; for future use, {VAR=1,2,3}, run step for each (stepcmd (list-ref stepparts 3)) (script "") ; "#!/bin/bash\n") ;; yep, we depend on bin/bash FIXME!!!\ (logpro-file (conc stepname ".logpro")) (html-file (conc stepname ".html")) + (dat-file (conc stepname ".dat")) (tconfig-logpro (configf:lookup testconfig "logpro" stepname)) (logpro-used (file-exists? logpro-file))) (if (and tconfig-logpro (not logpro-used)) ;; no logpro file found but have a defn in the testconfig @@ -79,11 +99,11 @@ ";;") (print tconfig-logpro))) (set! logpro-used #t))) ;; NB// can safely assume we are in test-area directory - (debug:print 4 "ezsteps:\n stepname: " stepname " stepinfo: " stepinfo " stepparts: " stepparts + (debug:print 4 *default-log-port* "ezsteps:\n stepname: " stepname " stepinfo: " stepinfo " stepparts: " stepparts " stepparms: " stepparms " stepcmd: " stepcmd) ;; ;; first source the previous environment ;; (let ((prev-env (conc ".ezsteps/" prevstep (if (string-search (regexp "csh") ;; (get-environment-variable "SHELL")) ".csh" ".sh")))) @@ -91,11 +111,11 @@ ;; (set! script (conc script "source " prev-env)))) ;; call the command using mt_ezstep ;; (set! script (conc "mt_ezstep " stepname " " (if prevstep prevstep "x") " " stepcmd)) - (debug:print 4 "script: " script) + (debug:print 4 *default-log-port* "script: " script) (rmt:teststep-set-status! run-id test-id stepname "start" "-" #f #f) ;; now launch the actual process (call-with-environment-variables (list (cons "PATH" (conc (get-environment-variable "PATH") ":."))) (lambda () ;; (process-run "/bin/bash" "-c" "exec ls -l /tmp/foobar > /tmp/delme-more.log 2>&1") @@ -112,11 +132,11 @@ (if (eq? pid-val 0) (begin (thread-sleep! 2) (processloop (+ i 1)))) ))))) - (debug:print-info 0 "step " stepname " completed with exit code " (launch:einf-exit-code exit-info)) ;; (vector-ref exit-info 2)) + (debug:print-info 0 *default-log-port* "step " stepname " completed with exit code " (launch:einf-exit-code exit-info)) ;; (vector-ref exit-info 2)) ;; now run logpro if needed (if logpro-used (let ((pid (process-run (conc "logpro " logpro-file " " (conc stepname ".html") " < " stepname ".log")))) (let processloop ((i 0)) (let-values (((pid-val exit-status exit-code)(process-wait pid #t))) @@ -128,17 +148,22 @@ (mutex-unlock! m) (if (eq? pid-val 0) (begin (thread-sleep! 2) (processloop (+ i 1))))) - (debug:print-info 0 "logpro for step " stepname " exited with code " (launch:einf-exit-code exit-info))))) ;; (vector-ref exit-info 2))))) + (debug:print-info 0 *default-log-port* "logpro for step " stepname " exited with code " (launch:einf-exit-code exit-info))))) ;; (vector-ref exit-info 2))))) (let ((exinfo (launch:einf-exit-code exit-info)) ;; (vector-ref exit-info 2)) - (logfna (if logpro-used (conc stepname ".html") ""))) - (rmt:teststep-set-status! run-id test-id stepname "end" exinfo #f logfna)) - (if logpro-used - (rmt:test-set-log! run-id test-id (conc stepname ".html"))) + (logfna (if logpro-used (conc stepname ".html") "")) + (comment #f)) + (if logpro-used + (let ((datfile (conc stepname ".dat"))) + ;; load the .dat file into the test_data table if it exists + (if (file-exists? datfile) + (set! comment (launch:load-logpro-dat run-id test-id stepname))) + (rmt:test-set-log! run-id test-id (conc stepname ".html")))) + (rmt:teststep-set-status! run-id test-id stepname "end" exinfo comment logfna)) ;; set the test final status (let* ((process-exit-status (launch:einf-exit-code exit-info)) ;; (vector-ref exit-info 2)) (this-step-status (cond ((and (eq? process-exit-status 2) logpro-used) 'warn) ;; logpro 2 = warnings ((and (eq? process-exit-status 3) logpro-used) 'check) ;; logpro 3 = check @@ -160,11 +185,11 @@ (next-state ;; "RUNNING") ;; WHY WAS THIS CHANGED TO NOT USE (null? tal) ?? (cond ((null? tal) ;; more to run? "COMPLETED") (else "RUNNING")))) - (debug:print 4 "Exit value received: " (launch:einf-exit-code exit-info) " logpro-used: " logpro-used + (debug:print 4 *default-log-port* "Exit value received: " (launch:einf-exit-code exit-info) " logpro-used: " logpro-used " this-step-status: " this-step-status " overall-status: " overall-status " next-status: " next-status " rollup-status: " (launch:einf-rollup-status exit-info)) ;; (vector-ref exit-info 3)) (case next-status ((warn) (launch:einf-rollup-status-set! exit-info 2) ;; (vector-set! exit-info 3 2) ;; rollup-status @@ -202,13 +227,169 @@ (launch:einf-rollup-status-set! exit-info 1) ;; (vector-set! exit-info 3 1) ;; force fail, this used to be next-state but that doesn't make sense. should always be "COMPLETED" (tests:test-set-status! run-id test-id "COMPLETED" "FAIL" (conc "Failed at step " stepname) #f) ))) logpro-used)) +(define (launch:manage-steps run-id test-id item-path fullrunscript ezsteps test-name tconfigreg exit-info m) + ;; (let-values + ;; (((pid exit-status exit-code) + ;; (run-n-wait fullrunscript))) + ;; (tests:test-set-status! test-id "RUNNING" "n/a" #f #f) + ;; Since we should have a clean slate at this time there is no need to do + ;; any of the other stuff that tests:test-set-status! does. Let's just + ;; force RUNNING/n/a + + ;; (thread-sleep! 0.3) + (tests:test-force-state-status! run-id test-id "RUNNING" "n/a") + (rmt:roll-up-pass-fail-counts run-id test-name item-path #f "RUNNING") + ;; (thread-sleep! 0.3) ;; NFS slowness has caused grief here + + ;; if there is a runscript do it first + (if fullrunscript + (let ((pid (process-run fullrunscript))) + (rmt:test-set-top-process-pid run-id test-id pid) + (let loop ((i 0)) + (let-values + (((pid-val exit-status exit-code) (process-wait pid #t))) + (mutex-lock! m) + (launch:einf-pid-set! exit-info pid) ;; (vector-set! exit-info 0 pid) + (launch:einf-exit-status-set! exit-info exit-status) ;; (vector-set! exit-info 1 exit-status) + (launch:einf-exit-code-set! exit-info exit-code) ;; (vector-set! exit-info 2 exit-code) + (launch:einf-rollup-status-set! exit-info exit-code) ;; (vector-set! exit-info 3 exit-code) ;; rollup status + (mutex-unlock! m) + (if (eq? pid-val 0) + (begin + (thread-sleep! 2) + (loop (+ i 1))) + ))))) + ;; then, if runscript ran ok (or did not get called) + ;; do all the ezsteps (if any) + (if ezsteps + (let* ((testconfig ;; (read-config (conc work-area "/testconfig") #f #t environ-patt: "pre-launch-env-vars")) ;; FIXME??? is allow-system ok here? + ;; NOTE: it is tempting to turn off force-create of testconfig but dynamic + ;; ezstep names need a full re-eval here. + (tests:get-testconfig test-name tconfigreg #t force-create: #t)) ;; 'return-procs))) + (ezstepslst (if (hash-table? testconfig) + (hash-table-ref/default testconfig "ezsteps" '()) + #f))) + (if testconfig + (hash-table-set! *testconfigs* test-name testconfig) ;; cached for lazy reads later ... + (begin + (launch:setup) + (debug:print 0 *default-log-port* "WARNING: no testconfig found for " test-name " in search path:\n " + (string-intersperse (tests:get-tests-search-path *configdat*) "\n ")))) + ;; after all that, still no testconfig? Time to abort + (if (not testconfig) + (begin + (debug:print 0 *default-log-port* "ERROR: Failed to resolve megatest.config, runconfigs.config and testconfig issues. Giving up now") + (exit 1))) + (if (not (file-exists? ".ezsteps"))(create-directory ".ezsteps")) + ;; if ezsteps was defined then we are sure to have at least one step but check anyway + (if (not (> (length ezstepslst) 0)) + (debug:print 0 *default-log-port* "ERROR: ezsteps defined but ezstepslst is zero length") + (let loop ((ezstep (car ezstepslst)) + (tal (cdr ezstepslst)) + (prevstep #f)) + ;; check exit-info (vector-ref exit-info 1) + (if (launch:einf-exit-status exit-info) ;; (vector-ref exit-info 1) + (let ((logpro-used (launch:runstep ezstep run-id test-id exit-info m tal testconfig)) + (stepname (car ezstep))) + ;; if logpro-used read in the stepname.dat file + (if (and logpro-used (file-exists? (conc stepname ".dat"))) + (launch:load-logpro-dat run-id test-id stepname)) + (if (steprun-good? logpro-used (launch:einf-exit-code exit-info)) + (if (not (null? tal)) + (loop (car tal) (cdr tal) stepname)) + (debug:print 4 *default-log-port* "WARNING: step " (car ezstep) " failed. Stopping"))) + (debug:print 4 *default-log-port* "WARNING: a prior step failed, stopping at " ezstep))))))) + +(define (launch:monitor-job run-id test-id item-path fullrunscript ezsteps test-name tconfigreg exit-info m work-area runtlim misc-flags) + (let* ((start-seconds (current-seconds)) + (calc-minutes (lambda () + (inexact->exact + (round + (- + (current-seconds) + start-seconds))))) + (kill-tries 0)) + ;; (tests:set-full-meta-info #f test-id run-id (calc-minutes) work-area) + ;; (tests:set-full-meta-info test-id run-id (calc-minutes) work-area) + (tests:set-full-meta-info #f test-id run-id (calc-minutes) work-area 10) + (let loop ((minutes (calc-minutes)) + (cpu-load (get-cpu-load)) + (disk-free (get-df (current-directory)))) + (let ((new-cpu-load (let* ((load (get-cpu-load)) + (delta (abs (- load cpu-load)))) + (if (> delta 0.6) ;; don't bother updating with small changes + load + #f))) + (new-disk-free (let* ((df (get-df (current-directory))) + (delta (abs (- df disk-free)))) + (if (> delta 200) ;; ignore changes under 200 Meg + df + #f)))) + (set! kill-job? (or (test-get-kill-request run-id test-id) ;; run-id test-name itemdat)) + (and runtlim (let* ((run-seconds (- (current-seconds) start-seconds)) + (time-exceeded (> run-seconds runtlim))) + (if time-exceeded + (begin + (debug:print-info 0 *default-log-port* "KILLING TEST DUE TO TIME LIMIT EXCEEDED! Runtime=" run-seconds " seconds, limit=" runtlim) + #t) + #f))))) + (tests:update-central-meta-info run-id test-id new-cpu-load new-disk-free (calc-minutes) #f #f) + (if kill-job? + (begin + (mutex-lock! m) + ;; NOTE: The pid can change as different steps are run. Do we need handshaking between this + ;; section and the runit section? Or add a loop that tries three times with a 1/4 second + ;; between tries? + (let* ((pid1 (launch:einf-pid exit-info)) ;; (vector-ref exit-info 0)) + (pid2 (rmt:test-get-top-process-pid run-id test-id)) + (pids (delete-duplicates (filter number? (list pid1 pid2))))) + (if (not (null? pids)) + (begin + (for-each + (lambda (pid) + (handle-exceptions + exn + (begin + (debug:print-info 0 *default-log-port* "Unable to kill process with pid " pid ", possibly already killed.") + (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))) + (debug:print 0 *default-log-port* "WARNING: Request received to kill job " pid) ;; " (attempt # " kill-tries ")") + (debug:print-info 0 *default-log-port* "Signal mask=" (signal-mask)) + ;; (if (process:alive? pid) + ;; (begin + (map (lambda (pid-num) + (process-signal pid-num signal/term)) + (process:get-sub-pids pid)) + (thread-sleep! 5) + ;; (if (process:process-alive? pid) + (map (lambda (pid-num) + (handle-exceptions + exn + #f + (process-signal pid-num signal/kill))) + (process:get-sub-pids pid)))) + ;; (debug:print-info 0 *default-log-port* "not killing process " pid " as it is not alive")))) + pids) + (tests:test-set-status! run-id test-id "KILLED" "KILLED" (args:get-arg "-m") #f)) + (begin + (debug:print 0 *default-log-port* "ERROR: Nothing to kill, pid1=" pid1 ", pid2=" pid2) + (tests:test-set-status! run-id test-id "KILLED" "FAILED TO KILL" (args:get-arg "-m") #f) + ))) + (mutex-unlock! m) + ;; no point in sticking around. Exit now. + (exit))) + (if (hash-table-ref/default misc-flags 'keep-going #f) + (begin + (thread-sleep! 3) ;; (+ 3 (random 6))) ;; add some jitter to the call home time to spread out the db accesses + (if (hash-table-ref/default misc-flags 'keep-going #f) ;; keep originals for cpu-load and disk-free unless they change more than the allowed delta + (loop (calc-minutes) (or new-cpu-load cpu-load) (or new-disk-free disk-free))))))) + (tests:update-central-meta-info run-id test-id (get-cpu-load) (get-df (current-directory))(calc-minutes) #f #f))) ;; NOTE: Checking twice for keep-going is intentional + (define (launch:execute encoded-cmd) - - (let* ((cmdinfo (common:read-encoded-string encoded-cmd)) + (let* ((cmdinfo (common:read-encoded-string encoded-cmd)) (tconfigreg (tests:get-all))) (setenv "MT_CMDINFO" encoded-cmd) (if (list? cmdinfo) ;; ((testpath /tmp/mrwellan/jazzmind/src/example_run/tests/sqlitespeed) ;; (test-name sqlitespeed) (runscript runscript.rb) (db-host localhost) (run-id 1)) (let* ((testpath (assoc/default 'testpath cmdinfo)) ;; testpath is the test spec area @@ -241,74 +422,71 @@ (let ((fulln (conc testpath "/" runscript))) (if (and (file-exists? fulln) (file-execute-access? fulln)) fulln runscript))))) ;; assume it is on the path - ;; (rollup-status 0) - ) + ) ;; (rollup-status 0) ;; NFS might not have propagated the directory meta data to the run host - give it time if needed (let loop ((count 0)) (if (or (file-exists? top-path) (> count 10)) (change-directory top-path) (begin - (debug:print 0 "INFO: Not starting job yet - directory " top-path " not found") + (debug:print 0 *default-log-port* "INFO: Not starting job yet - directory " top-path " not found") (thread-sleep! 10) (loop (+ count 1))))) (let ((sighand (lambda (signum) ;; (signal-mask! signum) ;; to mask or not? seems to cause issues in exiting (if (eq? signum signal/stop) - (debug:print 0 "ERROR: attempt to STOP process. Exiting.")) + (debug:print 0 *default-log-port* "ERROR: attempt to STOP process. Exiting.")) (set! *time-to-exit* #t) (print "Received signal " signum ", cleaning up before exit. Please wait...") (let ((th1 (make-thread (lambda () (tests:test-force-state-status! run-id test-id "INCOMPLETE" "KILLED") (print "Killed by signal " signum ". Exiting") (thread-sleep! 1) (exit 1)))) (th2 (make-thread (lambda () (thread-sleep! 2) - (debug:print 0 "Done") + (debug:print 0 *default-log-port* "Done") (exit 4))))) (thread-start! th2) (thread-start! th1) (thread-join! th2))))) (set-signal-handler! signal/int sighand) (set-signal-handler! signal/term sighand) - (set-signal-handler! signal/stop sighand)) + ) ;; (set-signal-handler! signal/stop sighand) - ;; (set-signal-handler! signal/int (lambda () - ;; Do not run the test if it is REMOVING, RUNNING, KILLREQ or REMOTEHOSTSTART, ;; Mark the test as REMOTEHOSTSTART *IMMEDIATELY* ;; (let* ((test-info (rmt:get-test-info-by-id run-id test-id)) (test-host (db:test-get-host test-info)) (test-pid (db:test-get-process_id test-info))) (cond ((member (db:test-get-state test-info) '("INCOMPLETE" "KILLED" "UNKNOWN" "KILLREQ" "STUCK")) ;; prior run of this test didn't complete, go ahead and try to rerun - (debug:print 0 "INFO: test is INCOMPLETE or KILLED, treat this execute call as a rerun request") + (debug:print 0 *default-log-port* "INFO: test is INCOMPLETE or KILLED, treat this execute call as a rerun request") (tests:test-force-state-status! run-id test-id "REMOTEHOSTSTART" "n/a")) ;; prime it for running ((member (db:test-get-state test-info) '("RUNNING" "REMOTEHOSTSTART")) (if (process:alive-on-host? test-host test-pid) - (debug:print 0 "ERROR: test state is " (db:test-get-state test-info) " and process " test-pid " is still running on host " test-host ", cannot proceed") + (debug:print 0 *default-log-port* "ERROR: test state is " (db:test-get-state test-info) " and process " test-pid " is still running on host " test-host ", cannot proceed") (tests:test-force-state-status! run-id test-id "REMOTEHOSTSTART" "n/a"))) ((not (member (db:test-get-state test-info) '("REMOVING" "REMOTEHOSTSTART" "RUNNING" "KILLREQ"))) (tests:test-force-state-status! run-id test-id "REMOTEHOSTSTART" "n/a")) (else ;; (member (db:test-get-state test-info) '("REMOVING" "REMOTEHOSTSTART" "RUNNING" "KILLREQ")) - (debug:print 0 "ERROR: test state is " (db:test-get-state test-info) ", cannot proceed") + (debug:print 0 *default-log-port* "ERROR: test state is " (db:test-get-state test-info) ", cannot proceed") (exit)))) - (debug:print 2 "Exectuing " test-name " (id: " test-id ") on " (get-host-name)) + (debug:print 2 *default-log-port* "Exectuing " test-name " (id: " test-id ") on " (get-host-name)) (set! keys (rmt:get-keys)) ;; (runs:set-megatest-env-vars run-id inkeys: keys inkeyvals: keyvals) ;; these may be needed by the launching process ;; one of these is defunct/redundant ... (if (not (launch:setup force: #t)) (begin - (debug:print 0 "Failed to setup, exiting") + (debug:print 0 *default-log-port* "Failed to setup, exiting") ;; (sqlite3:finalize! db) ;; (sqlite3:finalize! tdb) (exit 1))) (change-directory *toppath*) @@ -325,47 +503,47 @@ (let ((var (car varval)) (val (cadr varval))) (if (and (string? var)(string? val)) (begin (setenv var (config:eval-string-in-environment val))) ;; val) - (debug:print 0 "ERROR: bad variable spec, " var "=" val)))) + (debug:print 0 *default-log-port* "ERROR: bad variable spec, " var "=" val)))) (configf:get-section rconfig section))) (list "default" target))) ;; NFS might not have propagated the directory meta data to the run host - give it time if needed (let loop ((count 0)) (if (or (file-exists? work-area) (> count 10)) (change-directory work-area) (begin - (debug:print 0 "INFO: Not starting job yet - directory " work-area " not found") + (debug:print 0 *default-log-port* "INFO: Not starting job yet - directory " work-area " not found") (thread-sleep! 10) (loop (+ count 1))))) ;; (change-directory work-area) (set! keyvals (keys:target->keyval keys target)) ;; apply pre-overrides before other variables. The pre-override vars must not ;; clobbers things from the official sources such as megatest.config and runconfigs.config (if (string? set-vars) (let ((varpairs (string-split set-vars ","))) - (debug:print 4 "varpairs: " varpairs) + (debug:print 4 *default-log-port* "varpairs: " varpairs) (map (lambda (varpair) (let ((varval (string-split varpair "="))) (if (eq? (length varval) 2) (let ((var (car varval)) (val (cadr varval))) - (debug:print 1 "Adding pre-var/val " var " = " val " to the environment") + (debug:print 1 *default-log-port* "Adding pre-var/val " var " = " val " to the environment") (setenv var val))))) varpairs))) (for-each (lambda (varval) (let ((var (car varval)) (val (cadr varval))) (if val (setenv var val) (begin - (debug:print 0 "ERROR: required variable " var " does not have a valid value. Exiting") + (debug:print 0 *default-log-port* "ERROR: required variable " var " does not have a valid value. Exiting") (exit))))) (list (list "MT_TEST_RUN_DIR" work-area) (list "MT_TEST_NAME" test-name) (list "MT_ITEM_INFO" (conc itemdat)) @@ -390,11 +568,11 @@ ;; open-run-close not needed for test-set-meta-info ;; (tests:set-full-meta-info #f test-id run-id 0 work-area) ;; (tests:set-full-meta-info test-id run-id 0 work-area) (tests:set-full-meta-info #f test-id run-id 0 work-area 10) - (thread-sleep! 0.3) ;; NFS slowness has caused grief here + ;; (thread-sleep! 0.3) ;; NFS slowness has caused grief here (if (args:get-arg "-xterm") (set! fullrunscript "xterm") (if (and fullrunscript (file-exists? fullrunscript) @@ -403,176 +581,31 @@ ;; We are about to actually kick off the test ;; so this is a good place to remove the records for ;; any previous runs ;; (db:test-remove-steps db run-id testname itemdat) - + ;; (let* ((m (make-mutex)) (kill-job? #f) (exit-info (make-launch:einf pid: #t exit-status: #t exit-code: #t rollup-status: 0)) ;; pid exit-status exit-code (i.e. process was successfully run) rollup-status (job-thread #f) - (keep-going #t) + ;; (keep-going #t) + (misc-flags (let ((ht (make-hash-table))) + (hash-table-set! ht 'keep-going #t) + ht)) (runit (lambda () - ;; (let-values - ;; (((pid exit-status exit-code) - ;; (run-n-wait fullrunscript))) - ;; (tests:test-set-status! test-id "RUNNING" "n/a" #f #f) - ;; Since we should have a clean slate at this time there is no need to do - ;; any of the other stuff that tests:test-set-status! does. Let's just - ;; force RUNNING/n/a - - - ;; (thread-sleep! 0.3) - (tests:test-force-state-status! run-id test-id "RUNNING" "n/a") - (rmt:roll-up-pass-fail-counts run-id test-name item-path #f "RUNNING") - ;; (thread-sleep! 0.3) ;; NFS slowness has caused grief here - - ;; if there is a runscript do it first - (if fullrunscript - (let ((pid (process-run fullrunscript))) - (rmt:test-set-top-process-pid run-id test-id pid) - (let loop ((i 0)) - (let-values - (((pid-val exit-status exit-code) (process-wait pid #t))) - (mutex-lock! m) - (launch:einf-pid-set! exit-info pid) ;; (vector-set! exit-info 0 pid) - (launch:einf-exit-status-set! exit-info exit-status) ;; (vector-set! exit-info 1 exit-status) - (launch:einf-exit-code-set! exit-info exit-code) ;; (vector-set! exit-info 2 exit-code) - (launch:einf-rollup-status-set! exit-info exit-code) ;; (vector-set! exit-info 3 exit-code) ;; rollup status - (mutex-unlock! m) - (if (eq? pid-val 0) - (begin - (thread-sleep! 2) - (loop (+ i 1))) - ))))) - ;; then, if runscript ran ok (or did not get called) - ;; do all the ezsteps (if any) - (if ezsteps - (let* ((testconfig ;; (read-config (conc work-area "/testconfig") #f #t environ-patt: "pre-launch-env-vars")) ;; FIXME??? is allow-system ok here? - ;; NOTE: it is tempting to turn off force-create of testconfig but dynamic - ;; ezstep names need a full re-eval here. - (tests:get-testconfig test-name tconfigreg #t force-create: #t)) ;; 'return-procs))) - (ezstepslst (if (hash-table? testconfig) - (hash-table-ref/default testconfig "ezsteps" '()) - #f))) - (if testconfig - (hash-table-set! *testconfigs* test-name testconfig) ;; cached for lazy reads later ... - (begin - (launch:setup) - (debug:print 0 "WARNING: no testconfig found for " test-name " in search path:\n " - (string-intersperse (tests:get-tests-search-path *configdat*) "\n ")))) - ;; after all that, still no testconfig? Time to abort - (if (not testconfig) - (begin - (debug:print 0 "ERROR: Failed to resolve megatest.config, runconfigs.config and testconfig issues. Giving up now") - (exit 1))) - (if (not (file-exists? ".ezsteps"))(create-directory ".ezsteps")) - ;; if ezsteps was defined then we are sure to have at least one step but check anyway - (if (not (> (length ezstepslst) 0)) - (debug:print 0 "ERROR: ezsteps defined but ezstepslst is zero length") - (let loop ((ezstep (car ezstepslst)) - (tal (cdr ezstepslst)) - (prevstep #f)) - ;; check exit-info (vector-ref exit-info 1) - (if (launch:einf-exit-status exit-info) ;; (vector-ref exit-info 1) - (let ((logpro-used (launch:runstep ezstep run-id test-id exit-info m tal testconfig))) - (if (steprun-good? logpro-used (launch:einf-exit-code exit-info)) - (if (not (null? tal)) - (loop (car tal) (cdr tal) stepname)) - (debug:print 4 "WARNING: step " (car ezstep) " failed. Stopping"))) - (debug:print 4 "WARNING: a prior step failed, stopping at " ezstep)))))))) + (launch:manage-steps run-id test-id item-path fullrunscript ezsteps test-name tconfigreg exit-info m))) (monitorjob (lambda () - (let* ((start-seconds (current-seconds)) - (calc-minutes (lambda () - (inexact->exact - (round - (- - (current-seconds) - start-seconds))))) - (kill-tries 0)) - ;; (tests:set-full-meta-info #f test-id run-id (calc-minutes) work-area) - ;; (tests:set-full-meta-info test-id run-id (calc-minutes) work-area) - (tests:set-full-meta-info #f test-id run-id (calc-minutes) work-area 10) - (let loop ((minutes (calc-minutes)) - (cpu-load (get-cpu-load)) - (disk-free (get-df (current-directory)))) - (let ((new-cpu-load (let* ((load (get-cpu-load)) - (delta (abs (- load cpu-load)))) - (if (> delta 0.6) ;; don't bother updating with small changes - load - #f))) - (new-disk-free (let* ((df (get-df (current-directory))) - (delta (abs (- df disk-free)))) - (if (> delta 200) ;; ignore changes under 200 Meg - df - #f)))) - (set! kill-job? (or (test-get-kill-request run-id test-id) ;; run-id test-name itemdat)) - (and runtlim (let* ((run-seconds (- (current-seconds) start-seconds)) - (time-exceeded (> run-seconds runtlim))) - (if time-exceeded - (begin - (debug:print-info 0 "KILLING TEST DUE TO TIME LIMIT EXCEEDED! Runtime=" run-seconds " seconds, limit=" runtlim) - #t) - #f))))) - (tests:update-central-meta-info run-id test-id new-cpu-load new-disk-free (calc-minutes) #f #f) - (if kill-job? - (begin - (mutex-lock! m) - ;; NOTE: The pid can change as different steps are run. Do we need handshaking between this - ;; section and the runit section? Or add a loop that tries three times with a 1/4 second - ;; between tries? - (let* ((pid1 (launch:einf-pid exit-info)) ;; (vector-ref exit-info 0)) - (pid2 (rmt:test-get-top-process-pid run-id test-id)) - (pids (delete-duplicates (filter number? (list pid1 pid2))))) - (if (not (null? pids)) - (begin - (for-each - (lambda (pid) - (handle-exceptions - exn - (begin - (debug:print-info 0 "Unable to kill process with pid " pid ", possibly already killed.") - (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))) - (debug:print 0 "WARNING: Request received to kill job " pid) ;; " (attempt # " kill-tries ")") - (debug:print-info 0 "Signal mask=" (signal-mask)) - ;; (if (process:alive? pid) - ;; (begin - (map (lambda (pid-num) - (process-signal pid-num signal/term)) - (process:get-sub-pids pid)) - (thread-sleep! 5) - ;; (if (process:process-alive? pid) - (map (lambda (pid-num) - (handle-exceptions - exn - #f - (process-signal pid-num signal/kill))) - (process:get-sub-pids pid)))) - ;; (debug:print-info 0 "not killing process " pid " as it is not alive")))) - pids) - (tests:test-set-status! run-id test-id "KILLED" "KILLED" (args:get-arg "-m") #f)) - (begin - (debug:print 0 "ERROR: Nothing to kill, pid1=" pid1 ", pid2=" pid2) - (tests:test-set-status! run-id test-id "KILLED" "FAILED TO KILL" (args:get-arg "-m") #f) - ))) - (mutex-unlock! m) - ;; no point in sticking around. Exit now. - (exit))) - (if keep-going - (begin - (thread-sleep! 3) ;; (+ 3 (random 6))) ;; add some jitter to the call home time to spread out the db accesses - (if keep-going ;; keep originals for cpu-load and disk-free unless they change more than the allowed delta - (loop (calc-minutes) (or new-cpu-load cpu-load) (or new-disk-free disk-free))))))) - (tests:update-central-meta-info run-id test-id (get-cpu-load) (get-df (current-directory))(calc-minutes) #f #f)))) ;; NOTE: Checking twice for keep-going is intentional + (launch:monitor-job run-id test-id item-path fullrunscript ezsteps test-name tconfigreg exit-info m work-area runtlim misc-flags))) (th1 (make-thread monitorjob "monitor job")) (th2 (make-thread runit "run job"))) (set! job-thread th2) (thread-start! th1) (thread-start! th2) (thread-join! th2) - (debug:print-info 0 "Megatest exectute of test " test-name ", item path " item-path " complete. Notifying the db ...") - (set! keep-going #f) + (debug:print-info 0 *default-log-port* "Megatest exectute of test " test-name ", item path " item-path " complete. Notifying the db ...") + (hash-table-set! misc-flags 'keep-going #f) (thread-join! th1) (thread-sleep! 1) ;; givbe thread th1 a chance to be done TODO: Verify this is needed. At 0.1 I was getting fail to stop, increased to total of 1.1 sec. (mutex-lock! m) (let* ((item-path (item-list->path itemdat)) ;; only state and status needed - use lazy routine @@ -595,11 +628,11 @@ ((eq? (launch:einf-rollup-status exit-info) 3) "CHECK") ((eq? (launch:einf-rollup-status exit-info) 4) "WAIVED") ((eq? (launch:einf-rollup-status exit-info) 5) "ABORT") ((eq? (launch:einf-rollup-status exit-info) 6) "SKIP") (else "FAIL")))) ;; (db:test-get-status testinfo))) - (debug:print-info 1 "Test exited in state=" (db:test-get-state testinfo) ", setting state/status based on exit code of " (launch:einf-exit-status exit-info) " and rollup-status of " (launch:einf-rollup-status exit-info)) + (debug:print-info 1 *default-log-port* "Test exited in state=" (db:test-get-state testinfo) ", setting state/status based on exit code of " (launch:einf-exit-status exit-info) " and rollup-status of " (launch:einf-rollup-status exit-info)) (tests:test-set-status! run-id test-id new-state new-status (args:get-arg "-m") #f) @@ -610,11 +643,11 @@ (if (not (equal? item-path "")) (tests:summarize-items run-id test-id test-name #f)) (tests:summarize-test run-id test-id) ;; don't force - just update if no (rmt:update-run-stats run-id (rmt:get-raw-run-stats run-id))) (mutex-unlock! m) - (debug:print 2 "Output from running " fullrunscript ", pid " (launch:einf-pid exit-info) " in work area " + (debug:print 2 *default-log-port* "Output from running " fullrunscript ", pid " (launch:einf-pid exit-info) " in work area " work-area ":\n====\n exit code " (launch:einf-exit-code exit-info) "\n" "====\n") (if (not (launch:einf-exit-status exit-info)) (exit 4))))))) (define (launch:cache-config) @@ -630,13 +663,13 @@ (args:get-arg ":runname") (getenv "MT_RUNNAME"))) (fulldir (conc linktree "/" target "/" runname))) - (debug:print-info 0 "Have -runtests with target=" target ", runname=" runname ", fulldir=" fulldir ", testpatt=" (or (args:get-arg "-testpatt") "%")) (if (and linktree (file-exists? linktree)) ;; can't proceed without linktree (begin + (debug:print-info 0 *default-log-port* "Have -run with target=" target ", runname=" runname ", fulldir=" fulldir ", testpatt=" (or (args:get-arg "-testpatt") "%")) (if (not (file-exists? fulldir)) (create-directory fulldir #t)) ;; need to protect with exception handler (if (and target runname (file-exists? fulldir)) @@ -643,84 +676,16 @@ (let ((tmpfile (conc fulldir "/.megatest.cfg." (current-seconds))) (targfile (conc fulldir "/.megatest.cfg-" megatest-version "-" megatest-fossil-hash)) (rconfig (conc fulldir "/.runconfig." megatest-version "-" megatest-fossil-hash))) (if (file-exists? rconfig) ;; only cache megatest.config AFTER runconfigs has been cached (begin - (debug:print-info 0 "Caching megatest.config in " fulldir "/.megatest.cfg") + (debug:print-info 0 *default-log-port* "Caching megatest.config in " tmpfile) (configf:write-alist *configdat* tmpfile) (system (conc "ln -sf " tmpfile " " targfile)))) - ))))))) - -;; set up the very basics needed for doing anything here. -;; -(define (launch:setup-old #!key (force #f)) - ;; would set values for KEYS in the environment here for better support of env-override but - ;; have chicken/egg scenario. need to read megatest.config then read it again. Going to - ;; pass on that idea for now - ;; special case - (if (or force (not (hash-table? *configdat*))) ;; no need to re-open on every call - (begin - (set! *configinfo* (or (if (get-environment-variable "MT_CMDINFO") ;; we are inside a test - do not reprocess configs - (let ((alistconfig (conc (get-environment-variable "MT_LINKTREE") "/" - (get-environment-variable "MT_TARGET") "/" - (get-environment-variable "MT_RUNNAME") "/" - ".megatest.cfg-" megatest-version "-" megatest-fossil-hash))) - (if (file-exists? alistconfig) - (list (configf:read-alist alistconfig) - (get-environment-variable "MT_RUN_AREA_HOME")) - #f)) - #f) ;; no config cached - give up - (let ((runname (or (args:get-arg "-runname")(args:get-arg ":runname")))) - (if runname (setenv "MT_RUNNAME" runname)) - (find-and-read-config - (if (args:get-arg "-config")(args:get-arg "-config") "megatest.config") - environ-patt: "env-override" - given-toppath: (get-environment-variable "MT_RUN_AREA_HOME") - pathenvvar: "MT_RUN_AREA_HOME")))) - (set! *configdat* (if (car *configinfo*)(car *configinfo*) #f)) - (set! *toppath* (if (car *configinfo*)(cadr *configinfo*) #f)) - (let* ((tmptransport (configf:lookup *configdat* "server" "transport")) - (transport (if tmptransport (string->symbol tmptransport) 'http))) - (if (member transport '(http rpc nmsg)) - (set! *transport-type* transport) - (begin - (debug:print 0 "ERROR: Unrecognised transport " transport) - (exit)))) - (let ((linktree (configf:lookup *configdat* "setup" "linktree"))) ;; link tree is critical - (if linktree - (if (not (file-exists? linktree)) - (begin - (handle-exceptions - exn - (begin - (debug:print 0 "ERROR: Something went wrong when trying to create linktree dir at " linktree) - (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) - (exit 1)) - (create-directory linktree #t)))) - (begin - (debug:print 0 "ERROR: linktree not defined in [setup] section of megatest.config") - (exit 1))) - (if linktree - (let ((dbdir (conc linktree "/.db"))) - (handle-exceptions - exn - (begin - (debug:print 0 "ERROR: failed to create the " dbdir " area for your database files") - (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))) - (if (not (directory-exists? dbdir))(create-directory dbdir))) - (setenv "MT_LINKTREE" linktree)) - (begin - (debug:print 0 "ERROR: linktree is required in your megatest.config [setup] section") - (exit 1))) - (if (and *toppath* - (directory-exists? *toppath*)) - (setenv "MT_RUN_AREA_HOME" *toppath*) - (begin - (debug:print 0 "ERROR: failed to find the top path to your Megatest area.") - (exit 1))) - ))) - *toppath*) + ))) + (debug:print-info 1 *default-log-port* "No linktree yet, no caching configs."))))) + ;; gather available information, if legit read configs in this order: ;; ;; if have cache; ;; read it a return it @@ -768,19 +733,28 @@ given-toppath: toppath pathenvvar: "MT_RUN_AREA_HOME")) (first-rundat (let ((toppath (if toppath toppath (car first-pass)))) - (read-config (conc toppath "/runconfigs.config") *runconfigdat* #t - sections: sections)))) + (read-config ;; (conc toppath "/runconfigs.config") + (conc (if (string? toppath) + toppath + (get-environment-variable "MT_RUN_AREA_HOME")) + "/runconfigs.config") + *runconfigdat* #t + sections: sections)))) (set! *runconfigdat* first-rundat) (if first-pass ;; (begin (set! *configdat* (car first-pass)) (set! *configinfo* first-pass) (set! *toppath* (or toppath (cadr first-pass))) ;; use the gathered data unless already have it (set! toppath *toppath*) + (if (not *toppath*) + (begin + (debug:print 0 *default-log-port* "ERROR: you are not in a megatest area!") + (exit 1))) (setenv "MT_RUN_AREA_HOME" *toppath*) ;; the seed read is done, now read runconfigs, cache it then read megatest.config one more time and cache it (let* ((keys (rmt:get-keys)) (key-vals (keys:target->keyval keys target)) (linktree (or (getenv "MT_LINKTREE") @@ -818,11 +792,11 @@ (set! *configdat* (car cfgdat)) (set! *runconfigdat* rdat) (set! *toppath* toppath) (set! *configstatus* 'partial)) (begin - (debug:print 0 "ERROR: No " mtconfig " file found. Giving up.") + (debug:print 0 *default-log-port* "ERROR: No " mtconfig " file found. Giving up.") (exit 2)))))) ;; additional house keeping (let* ((linktree (or (getenv "MT_LINKTREE") (if *configdat* (configf:lookup *configdat* "setup" "linktree") #f)))) (if linktree @@ -829,23 +803,23 @@ (if (not (file-exists? linktree)) (begin (handle-exceptions exn (begin - (debug:print 0 "ERROR: Something went wrong when trying to create linktree dir at " linktree) - (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 *default-log-port* "ERROR: Something went wrong when trying to create linktree dir at " linktree) + (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) (exit 1)) (create-directory linktree #t)))) (begin - (debug:print 0 "ERROR: linktree not defined in [setup] section of megatest.config") + (debug:print 0 *default-log-port* "ERROR: linktree not defined in [setup] section of megatest.config") ;; (exit 1) ))) (if (and *toppath* (directory-exists? *toppath*)) (setenv "MT_RUN_AREA_HOME" *toppath*) (begin - (debug:print 0 "ERROR: failed to find the top path to your Megatest area."))) + (debug:print 0 *default-log-port* "ERROR: failed to find the top path to your Megatest area."))) *toppath*)) (define launch:setup launch:setup-new) (define (get-best-disk confdat testconfig) @@ -857,11 +831,11 @@ (let ((res (common:get-disk-with-most-free-space disks minspace))) ;; min size of 1000, seems tad dumb (if res (cdr res) (begin (if (common:low-noise-print 20 "No valid disks or no disk with enough space") - (debug:print 0 "ERROR: No valid disks found in megatest.config. Please add some to your [disks] section and ensure the directory exists and has enough space!\n You can change minspace in the [setup] section of megatest.config. Current setting is: " minspace)) + (debug:print 0 *default-log-port* "ERROR: No valid disks found in megatest.config. Please add some to your [disks] section and ensure the directory exists and has enough space!\n You can change minspace in the [setup] section of megatest.config. Current setting is: " minspace)) (exit 1))))))) ;; Desired directory structure: ;; ;; - - -. @@ -908,22 +882,22 @@ ;; Update the rundir path in the test record for all, rundir=physical, shortdir=logical ;; rundir shortdir (rmt:general-call 'test-set-rundir-shortdir run-id lnkpathf test-path testname item-path) - (debug:print 2 "INFO:\n lnkbase=" lnkbase "\n lnkpath=" lnkpath "\n toptest-path=" toptest-path "\n test-path=" test-path) + (debug:print 2 *default-log-port* "INFO:\n lnkbase=" lnkbase "\n lnkpath=" lnkpath "\n toptest-path=" toptest-path "\n test-path=" test-path) (if (not (file-exists? linktree)) (begin - (debug:print 0 "WARNING: linktree did not exist! Creating it now at " linktree) + (debug:print 0 *default-log-port* "WARNING: linktree did not exist! Creating it now at " linktree) (create-directory linktree #t))) ;; (system (conc "mkdir -p " linktree)))) ;; create the directory for the tests dir links, this is needed no matter what... (if (and (not (directory-exists? lnkbase)) (not (file-exists? lnkbase))) (handle-exceptions exn (begin - (debug:print "ERROR: Problem creating linktree base at " lnkbase) + (debug:print 0 *default-log-port* "ERROR: Problem creating linktree base at " lnkbase) (print-error-message exn (current-error-port))) (create-directory lnkbase #t))) ;; update the toptest record with its location rundir, cache the path ;; This wass highly inefficient, one db write for every subtest, potentially @@ -934,32 +908,32 @@ ;; if the test is iterated it is necessary to create the parent path ;; to the iteration. use pathname-directory to trim the path by one ;; level (if (not not-iterated) ;; i.e. iterated (let ((iterated-parent (pathname-directory (conc lnkpath "/" item-path)))) - (debug:print-info 2 "Creating iterated parent " iterated-parent) + (debug:print-info 2 *default-log-port* "Creating iterated parent " iterated-parent) (handle-exceptions exn (begin - (debug:print 0 "ERROR: Failed to create directory " iterated-parent ((condition-property-accessor 'exn 'message) exn) ", exiting") + (debug:print 0 *default-log-port* "ERROR: Failed to create directory " iterated-parent ((condition-property-accessor 'exn 'message) exn) ", exiting") (exit 1)) (create-directory iterated-parent #t)))) (if (symbolic-link? lnkpath) (handle-exceptions exn (begin - (debug:print 0 "ERROR: Failed to remove symlink " lnkpath ((condition-property-accessor 'exn 'message) exn) ", exiting") + (debug:print 0 *default-log-port* "ERROR: Failed to remove symlink " lnkpath ((condition-property-accessor 'exn 'message) exn) ", exiting") (exit 1)) (delete-file lnkpath))) (if (not (or (file-exists? lnkpath) (symbolic-link? lnkpath))) (handle-exceptions exn (begin - (debug:print 0 "ERROR: Failed to create symlink " lnkpath ((condition-property-accessor 'exn 'message) exn) ", exiting") + (debug:print 0 *default-log-port* "ERROR: Failed to create symlink " lnkpath ((condition-property-accessor 'exn 'message) exn) ", exiting") (exit 1)) (create-symbolic-link toptest-path lnkpath))) ;; NB - This was not working right - some top tests are not getting the path set!!! ;; @@ -976,18 +950,19 @@ #f))) (hash-table-set! *toptest-paths* testname curr-test-path) ;; NB// Was this for the test or for the parent in an iterated test? (rmt:general-call 'test-set-rundir-shortdir run-id lnkpath (if (file-exists? lnkpath) - (resolve-pathname lnkpath) + ;; (resolve-pathname lnkpath) + (common:nice-path lnkpath) lnkpath) testname "") ;; (rmt:general-call 'test-set-rundir run-id lnkpath testname "") ;; toptest-path) (if (or (not curr-test-path) (not (directory-exists? toptest-path))) (begin - (debug:print-info 2 "Creating " toptest-path " and link " lnkpath) + (debug:print-info 2 *default-log-port* "Creating " toptest-path " and link " lnkpath) (handle-exceptions exn #f ;; don't care to catch and deal with errors here for now. (create-directory toptest-path #t)) (hash-table-set! *toptest-paths* testname toptest-path))))) @@ -994,27 +969,27 @@ ;; The toptest path has been created, the link to the test in the linktree has ;; been created. Now, if this is an iterated test the real test dir must be created (if (not not-iterated) ;; this is an iterated test (begin ;; (let ((lnktarget (conc lnkpath "/" item-path))) - (debug:print 2 "Setting up sub test run area") - (debug:print 2 " - creating run area in " test-path) + (debug:print 2 *default-log-port* "Setting up sub test run area") + (debug:print 2 *default-log-port* " - creating run area in " test-path) (handle-exceptions exn (begin - (debug:print 0 "ERROR: Failed to create directory " test-path ((condition-property-accessor 'exn 'message) exn) ", exiting") + (debug:print 0 *default-log-port* "ERROR: Failed to create directory " test-path ((condition-property-accessor 'exn 'message) exn) ", exiting") (exit 1)) (create-directory test-path #t)) - (debug:print 2 + (debug:print 2 *default-log-port* " - creating link from: " test-path "\n" " to: " lnktarget) ;; If there is already a symlink delete it and recreate it. (handle-exceptions exn (begin - (debug:print 0 "ERROR: Failed to re-create link " lnktarget ((condition-property-accessor 'exn 'message) exn) ", exiting") + (debug:print 0 *default-log-port* "ERROR: Failed to re-create link " lnktarget ((condition-property-accessor 'exn 'message) exn) ", exiting") (exit)) (if (symbolic-link? lnktarget) (delete-file lnktarget)) (if (not (file-exists? lnktarget)) (create-symbolic-link test-path lnktarget))))) (if (not (directory? test-path)) @@ -1032,15 +1007,15 @@ ovrcmd (conc "rsync -av" (if (debug:debug-mode 1) "" "q") " " test-src-path "/ " test-path "/" " >> " test-path "/mt_launch.log 2>> " test-path "/mt_launch.log"))) (status (system cmd))) (if (not (eq? status 0)) - (debug:print 2 "ERROR: problem with running \"" cmd "\""))) + (debug:print 2 *default-log-port* "ERROR: problem with running \"" cmd "\""))) (list lnkpathf lnkpath )) (if (and test-src-path (> remtries 0)) (begin - (debug:print 0 "ERROR: Failed to create work area at " test-path " with link at " lnktarget ", remaining attempts " remtries) + (debug:print 0 *default-log-port* "ERROR: Failed to create work area at " test-path " with link at " lnktarget ", remaining attempts " remtries) ;; (create-work-area run-id run-info keyvals test-id test-src-path disk-path testname itemdat remtries: (- remtries 1))) (list #f #f))))) ;; 1. look though disks list for disk with most space @@ -1114,11 +1089,11 @@ (if launcher (set! launcher (string-split launcher))) ;; set up the run work area for this test (if (and (args:get-arg "-preclean") ;; user has requested to preclean for this run (not (member (db:test-get-rundir testinfo)(list "n/a" "/tmp/badname")))) ;; n/a is a placeholder and thus not a read dir (begin - (debug:print-info 0 "attempting to preclean directory " (db:test-get-rundir testinfo) " for test " test-name "/" item-path) + (debug:print-info 0 *default-log-port* "attempting to preclean directory " (db:test-get-rundir testinfo) " for test " test-name "/" item-path) (runs:remove-test-directory testinfo 'remove-data-only))) ;; remove data only, do not perturb the record ;; prevent overlapping actions - set to LAUNCHED as early as possible ;; (tests:test-set-status! run-id test-id "LAUNCHED" "n/a" #f #f) ;; (if launch-results launch-results "FAILED")) @@ -1126,15 +1101,15 @@ (set! diskpath (get-best-disk *configdat* tconfig)) (if diskpath (let ((dat (create-work-area run-id run-info keyvals test-id test-path diskpath test-name itemdat))) (set! work-area (car dat)) (set! toptest-work-area (cadr dat)) - (debug:print-info 2 "Using work area " work-area)) + (debug:print-info 2 *default-log-port* "Using work area " work-area)) (begin (set! work-area (conc test-path "/tmp_run")) (create-directory work-area #t) - (debug:print 0 "WARNING: No disk work area specified - running in the test directory under tmp_run"))) + (debug:print 0 *default-log-port* "WARNING: No disk work area specified - running in the test directory under tmp_run"))) (set! cmdparms (base64:base64-encode (z3:encode-buffer (with-output-to-string (lambda () ;; (list 'hosts hosts) (write (list (list 'testpath test-path) @@ -1168,17 +1143,17 @@ ;; (set! fullcmd (append launcher (car hosts)(list remote-megatest test-sig "-execute" cmdparms)))) (launcher (set! fullcmd (append launcher (list remote-megatest "-m" test-sig "-execute" cmdparms) debug-param))) ;; (set! fullcmd (append launcher (list remote-megatest test-sig "-execute" cmdparms)))) (else - (if (not useshell)(debug:print 0 "WARNING: internal launching will not work well without \"useshell yes\" in your [jobtools] section")) + (if (not useshell)(debug:print 0 *default-log-port* "WARNING: internal launching will not work well without \"useshell yes\" in your [jobtools] section")) (set! fullcmd (append (list remote-megatest "-m" test-sig "-execute" cmdparms) debug-param (list (if useshell "&" "")))))) ;; (set! fullcmd (list remote-megatest test-sig "-execute" cmdparms (if useshell "&" ""))))) (if (args:get-arg "-xterm")(set! fullcmd (append fullcmd (list "-xterm")))) - (debug:print 1 "Launching " work-area) + (debug:print 1 *default-log-port* "Launching " work-area) ;; set pre-launch-env-vars before launching, keep the vars in prevvals and put the envionment back when done - (debug:print 4 "fullcmd: " fullcmd) + (debug:print 4 *default-log-port* "fullcmd: " fullcmd) (let* ((commonprevvals (alist->env-vars (hash-table-ref/default *configdat* "env-override" '()))) (testprevvals (alist->env-vars (hash-table-ref/default tconfig "pre-launch-env-overrides" '()))) (miscprevvals (alist->env-vars ;; consolidate this code with the code in megatest.scm for "-execute" @@ -1211,12 +1186,12 @@ (print "LAUNCHCMD: " (string-intersperse fullcmd " ")) (if (list? launch-results) (apply print launch-results) (print "NOTE: launched \"" fullcmd "\"\n but did not wait for it to proceed. Add the following to megatest.config \n[setup]\nlaunchwait yes\n if you have problems with this")) #:append)) - (debug:print 2 "Launching completed, updating db") - (debug:print 2 "Launch results: " launch-results) + (debug:print 2 *default-log-port* "Launching completed, updating db") + (debug:print 2 *default-log-port* "Launch results: " launch-results) (if (not launch-results) (begin (print "ERROR: Failed to run " (string-intersperse fullcmd " ") ", exiting now") ;; (sqlite3:finalize! db) ;; good ole "exit" seems not to work Index: lock-queue.scm ================================================================== --- lock-queue.scm +++ lock-queue.scm @@ -73,16 +73,16 @@ (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200) (handle-exceptions exn (if (> remtries 0) (begin - (debug:print 0 "WARNING: exception on lock-queue:set-state. Trying again in 30 seconds.") - (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 *default-log-port* "WARNING: exception on lock-queue:set-state. Trying again in 30 seconds.") + (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) (thread-sleep! 30) (lock-queue:set-state dbdat test-id newstate remtries: (- remtries 1))) (begin - (debug:print 0 "ERROR: Failed to set lock state for test with id " test-id ", error: " ((condition-property-accessor 'exn 'message) exn) ", giving up.") + (debug:print 0 *default-log-port* "ERROR: Failed to set lock state for test with id " test-id ", error: " ((condition-property-accessor 'exn 'message) exn) ", giving up.") #f)) (sqlite3:execute (lock-queue:db-dat-get-db dbdat) "UPDATE queue SET state=? WHERE test_id=?;" newstate test-id))) @@ -91,17 +91,17 @@ ;; (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200) (handle-exceptions exn (if (> remtries 0) (begin - (debug:print 0 "WARNING: exception on lock-queue:any-younger. Removing lockdb and trying again in 5 seconds.") - (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 *default-log-port* "WARNING: exception on lock-queue:any-younger. Removing lockdb and trying again in 5 seconds.") + (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) (thread-sleep! 5) (lock-queue:delete-lock-db dbdat) (lock-queue:any-younger? dbdat mystart test-id remtries: (- remtries 1))) (begin - (debug:print 0 "ERROR: Failed to find younger locks for test with id " test-id ", error: " ((condition-property-accessor 'exn 'message) exn) ", giving up.") + (debug:print 0 *default-log-port* "ERROR: Failed to find younger locks for test with id " test-id ", error: " ((condition-property-accessor 'exn 'message) exn) ", giving up.") #f)) (let ((res #f)) (sqlite3:for-each-row (lambda (tid) ;; Actually this should not be needed as mystart cannot be simultaneously less than and test-id same as @@ -119,12 +119,12 @@ (mklckqry (sqlite3:prepare db "INSERT INTO runlocks (test_id,run_lock) VALUES (?,'locked');"))) (let ((result (handle-exceptions exn (begin - (debug:print 0 "WARNING: failed to get queue lock. Removing lock db and returning fail") ;; Will try again in a few seconds") - (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 *default-log-port* "WARNING: failed to get queue lock. Removing lock db and returning fail") ;; Will try again in a few seconds") + (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) (thread-sleep! 10) ;; (if (> count 0) ;; #f ;; (lock-queue:get-lock dbdat test-id count: (- count 1)) - give up on retries ;; (begin ;; never recovered, remote the lock file and return #f, no lock obtained (lock-queue:delete-lock-db dbdat) @@ -151,12 +151,12 @@ (let* ((dbdat (lock-queue:open-db fname))) (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200 "lock-queue:release-lock; waiting on journal") (handle-exceptions exn (begin - (debug:print 0 "WARNING: Failed to release queue lock. Will try again in few seconds") - (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 *default-log-port* "WARNING: Failed to release queue lock. Will try again in few seconds") + (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) (thread-sleep! (/ count 10)) (if (> count 0) (begin (sqlite3:finalize! (lock-queue:db-dat-get-db dbdat)) (lock-queue:release-lock fname test-id count: (- count 1))) @@ -171,17 +171,17 @@ #f)))) (sqlite3:execute (lock-queue:db-dat-get-db dbdat) "DELETE FROM runlocks WHERE test_id=?;" test-id) (sqlite3:finalize! (lock-queue:db-dat-get-db dbdat))))) (define (lock-queue:steal-lock dbdat test-id #!key (count 10)) - (debug:print-info 0 "Attempting to steal lock at " (lock-queue:db-dat-get-path dbdat)) + (debug:print-info 0 *default-log-port* "Attempting to steal lock at " (lock-queue:db-dat-get-path dbdat)) (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200 "lock-queue:steal-lock; waiting on journal") (handle-exceptions exn (begin - (tadebug:print 0 "WARNING: Failed to steal queue lock. Will try again in few seconds") - (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 *default-log-port* "WARNING: Failed to steal queue lock. Will try again in few seconds") + (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) (thread-sleep! 10) (if (> count 0) (lock-queue:steal-lock dbdat test-id count: (- count 1)) #f)) (sqlite3:execute (lock-queue:db-dat-get-db dbdat) "DELETE FROM runlocks WHERE run_lock='locked';")) @@ -197,20 +197,20 @@ (db (lock-queue:db-dat-get-db dbdat))) ;; (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200 waiting-msg: "lock-queue:wait-turn; waiting on journal file") (handle-exceptions exn (begin - (debug:print 0 "WARNING: Failed to find out if it is ok to skip the wait queue. Will try again in few seconds") - (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 *default-log-port* "WARNING: Failed to find out if it is ok to skip the wait queue. Will try again in few seconds") + (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) (print-call-chain (current-error-port)) (thread-sleep! 10) (if (> count 0) (begin (sqlite3:finalize! db) (lock-queue:wait-turn fname test-id count: (- count 1))) (begin - (debug:print 0 "Giving up calls to lock-queue:wait-turn for test-id " test-id " at path " fname ", printing call chain") + (debug:print 0 *default-log-port* "Giving up calls to lock-queue:wait-turn for test-id " test-id " at path " fname ", printing call chain") (print-call-chain (current-error-port)) #f))) ;; wait 10 seconds and then check to see if someone is already updating the html (thread-sleep! 10) (if (not (lock-queue:any-younger? dbdat mystart test-id)) ;; no processing in flight, must try to start processing Index: megatest-version.scm ================================================================== --- megatest-version.scm +++ megatest-version.scm @@ -1,7 +1,7 @@ ;; Always use two or four digit decimal -;; 1.01, 1.02...1.10,1.11,1,1101 ... 1.99,2.00.. +;; 1.01, 1.02...1.10,1.11,1.1101 ... 1.99,2.00.. (declare (unit megatest-version)) -(define megatest-version 1.6031) +(define megatest-version 1.6102) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -82,10 +82,11 @@ -unlock : unlock run specified by target and runname -set-run-status status : sets status for run to status, requires -target and -runname -get-run-status : gets status for run specified by target and runname -run-wait : wait on run specified by target and runname -preclean : remove the existing test directory before running the test + -clean-cache : remove the cached megatest.config and runconfig.config files Selectors (e.g. use for -runtests, -remove-runs, -set-state-status, -list-runs etc.) -target key1/key2/... : run for key1, key2, etc. -reqtarg key1/key2/... : run for key1, key2, etc. but key1/key2 must be in runconfig -testpatt patt1/patt2,patt3/... : % is wildcard @@ -270,10 +271,11 @@ "-summarize-items" "-gui" "-daemonize" "-preclean" "-rerun-clean" + "-clean-cache" ;; misc "-repl" "-lock" "-unlock" @@ -322,11 +324,11 @@ (args:get-arg "-runstep") (args:get-arg "-envcap") (args:get-arg "-envdelta") ) )) - (debug:print 0 "ERROR: Unrecognised arguments: " (string-intersperse (if (list? remargs) remargs (argv)) " "))) + (debug:print 0 *default-log-port* "ERROR: Unrecognised arguments: " (string-intersperse (if (list? remargs) remargs (argv)) " "))) ;; immediately set MT_TARGET if -reqtarg or -target are available ;; (let ((targ (or (args:get-arg "-reqtarg")(args:get-arg "-target")))) (if targ (setenv "MT_TARGET" targ))) @@ -354,25 +356,25 @@ (hash-table-ref/default *db-local-sync* run-id #f)) ;; (if (> (- start-time last-write) 5) ;; every five seconds (begin ;; let ((sync-time (- (current-seconds) start-time))) (db:multi-db-sync (list run-id) 'new2old) (let ((sync-time (- (current-seconds) start-time))) - (debug:print-info 3 "Sync of newdb to olddb for run-id " run-id " completed in " sync-time " seconds") + (debug:print-info 3 *default-log-port* "Sync of newdb to olddb for run-id " run-id " completed in " sync-time " seconds") (if (common:low-noise-print 30 "sync new to old") - (debug:print-info 0 "Sync of newdb to olddb for run-id " run-id " completed in " sync-time " seconds"))) + (debug:print-info 0 *default-log-port* "Sync of newdb to olddb for run-id " run-id " completed in " sync-time " seconds"))) ;; (if (> sync-time 10) ;; took more than ten seconds, start a server for this run ;; (begin - ;; (debug:print-info 0 "Sync is taking a long time, start up a server to assist for run " run-id) + ;; (debug:print-info 0 *default-log-port* "Sync is taking a long time, start up a server to assist for run " run-id) ;; (server:kind-run run-id))))) (hash-table-delete! *db-local-sync* run-id))) (mutex-unlock! *db-multi-sync-mutex*)) (hash-table-keys *db-local-sync*)) (if (and debug-mode (> (- start-time last-time) 60)) (begin (set! last-time start-time) - (debug:print-info 4 "timestamp -> " (seconds->time-string (current-seconds)) ", time since start -> " (seconds->hr-min-sec (- (current-seconds) *time-zero*)))))) + (debug:print-info 4 *default-log-port* "timestamp -> " (seconds->time-string (current-seconds)) ", time since start -> " (seconds->hr-min-sec (- (current-seconds) *time-zero*)))))) ;; keep going unless time to exit ;; (if (not *time-to-exit*) (let delay-loop ((count 0)) @@ -381,20 +383,20 @@ (begin (thread-sleep! 1) (delay-loop (+ count 1)))) (loop))) (if (common:low-noise-print 30) - (debug:print-info 0 "Exiting watchdog timer, *time-to-exit* = " *time-to-exit*))))) + (debug:print-info 0 *default-log-port* "Exiting watchdog timer, *time-to-exit* = " *time-to-exit*))))) "Watchdog thread"))) (thread-start! *watchdog*) + (if (args:get-arg "-log") (let ((oup (open-output-file (args:get-arg "-log")))) - (debug:print-info 0 "Sending log output to " (args:get-arg "-log")) - (current-error-port oup) - (current-output-port oup))) + (debug:print-info 0 *default-log-port* "Sending log output to " (args:get-arg "-log")) + (set! *default-log-port* oup))) (if (or (args:get-arg "-h") (args:get-arg "-help") (args:get-arg "--help")) (begin @@ -403,16 +405,16 @@ (if (args:get-arg "-start-dir") (if (file-exists? (args:get-arg "-start-dir")) (change-directory (args:get-arg "-start-dir")) (begin - (debug:print 0 "ERROR: non-existant start dir " (args:get-arg "-start-dir") " specified, exiting.") + (debug:print 0 *default-log-port* "ERROR: non-existant start dir " (args:get-arg "-start-dir") " specified, exiting.") (exit 1)))) (if (args:get-arg "-version") (begin - (print megatest-version) + (print (common:version-signature)) ;; (print megatest-version) (exit))) (define *didsomething* #f) ;; Overall exit handling setup immediately @@ -450,22 +452,52 @@ (if (debug:debug-mode 3) ;; we are obviously debugging (set! open-run-close open-run-close-no-exception-handling)) (if (args:get-arg "-itempatt") (let ((newval (conc (args:get-arg "-testpatt") "/" (args:get-arg "-itempatt")))) - (debug:print 0 "WARNING: -itempatt has been deprecated, please use -testpatt testpatt/itempatt method, new testpatt is "newval) + (debug:print 0 *default-log-port* "WARNING: -itempatt has been deprecated, please use -testpatt testpatt/itempatt method, new testpatt is "newval) (hash-table-set! args:arg-hash "-testpatt" newval) (hash-table-delete! args:arg-hash "-itempatt"))) - +(if (args:get-arg "-runtests") + (debug:print 0 *default-log-port* "WARNING: \"-runtests\" is deprecated. Use \"-run\" with \"-testpatt\" instead")) (on-exit std-exit-procedure) ;;====================================================================== ;; Misc general calls ;;====================================================================== +;; handle a clean-cache request as early as possible +;; +(if (args:get-arg "-clean-cache") + (begin + (set! *didsomething* #t) ;; suppress the help output. + (if (getenv "MT_TARGET") ;; no point in trying if no target + (if (args:get-arg "-runname") + (let* ((toppath (launch:setup)) + (linktree (if toppath (configf:lookup *configdat* "setup" "linktree"))) + (runtop (conc linktree "/" (getenv "MT_TARGET") "/" (args:get-arg "-runname"))) + (files (if (file-exists? runtop) + (append (glob (conc runtop "/.megatest*")) + (glob (conc runtop "/.runconfig*"))) + '()))) + (if (null? files) + (debug:print-info 0 *default-log-port* "No cached megatest or runconfigs files found. None removed.") + (begin + (debug:print-info 0 *default-log-port* "Removing cached files:\n " (string-intersperse files "\n ")) + (for-each + (lambda (f) + (handle-exceptions + exn + (debug:print 0 *default-log-port* "WARNING: Failed to remove file " f) + (delete-file f))) + files)))) + (debug:print 0 *default-log-port* "ERROR: -clean-cache requires -runname.")) + (debug:print 0 *default-log-port* "ERROR: -clean-cache requires -target or -reqtarg")))) + + (if (args:get-arg "-env2file") (begin (save-environment-as-files (args:get-arg "-env2file")) (set! *didsomething* #t))) @@ -479,33 +511,10 @@ " => ")) (common:get-disks *configdat*)) "\n")) (set! *didsomething* #t))) -(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))))) - ;; csv processing record (define (make-refdb:csv) (vector (make-sparse-array) (make-hash-table) @@ -539,11 +548,11 @@ (current-output-port))) (res-data (configf:read-refdb input-db)) (data (car res-data)) (msg (cadr res-data))) (if (not data) - (debug:print 0 "Bad input? data=" data) ;; some error occurred + (debug:print 0 *default-log-port* "Bad input? data=" data) ;; some error occurred (with-output-to-port out-port (lambda () (case (string->symbol out-fmt) ((scheme)(pp data)) ((perl) @@ -660,18 +669,10 @@ (if (args:get-arg "-ping") (let* ((run-id (string->number (args:get-arg "-run-id"))) (host:port (args:get-arg "-ping"))) (server:ping run-id host:port))) -;; (set! *did-something* #t) -;; (begin -;; (print ((rpc:procedure 'testing (car host-port)(cadr host-port)))) -;; (case (server:get-transport) -;; ((http)(http:ping run-id host-port)) -;; ((rpc) (rpc:procedure 'server:login (car host-port)(cadr host-port));; *toppath*)) ;; (rpc-transport:ping run-id (car host-port)(cadr host-port))) -;; (else (debug:print 0 "ERROR: No transport set")(exit))))) - ;;====================================================================== ;; Capture, save and manipulate environments ;;====================================================================== ;; NOTE: Keep these above the section where the server or client code is setup @@ -707,13 +708,11 @@ (lambda () (env:print added removed changed))) (env:print added removed changed)) (env:close-database db) (set! *didsomething* #t)) - (debug:print 0 "ERROR: Parameter to -envdelta should be new=star-end"))))) - - + (debug:print 0 *default-log-port* "ERROR: Parameter to -envdelta should be new=star-end"))))) ;;====================================================================== ;; Start the server - can be done in conjunction with -runall or -runtests (one day...) ;; we start the server if not running else start the client thread ;;====================================================================== @@ -727,11 +726,11 @@ (string->number (args:get-arg "-run-id"))))) (if run-id (begin (server:launch run-id) (set! *didsomething* #t)) - (debug:print 0 "ERROR: server requires run-id be specified with -run-id"))) + (debug:print 0 *default-log-port* "ERROR: server requires run-id be specified with -run-id"))) ;; Not a server? This section will decide how to communicate ;; ;; Setup client for all expect listed here (if (null? (lset-intersection @@ -747,11 +746,11 @@ (string->number (args:get-arg "-run-id"))))) ;; (set! *fdb* (filedb:open-db (conc *toppath* "/db/paths.db"))) ;; if not list or kill then start a client (if appropriate) (if (or (args-defined? "-h" "-version" "-gen-megatest-area" "-gen-megatest-test") (eq? (length (hash-table-keys args:arg-hash)) 0)) - (debug:print-info 1 "Server connection not needed") + (debug:print-info 1 *default-log-port* "Server connection not needed") (begin ;; (if run-id ;; (client:launch run-id) ;; (client:launch 0) ;; without run-id we'll start a server for "0" #t @@ -800,14 +799,14 @@ (format #t fmtstr id mt-ver pid hostname (conc interface ":" pullport) pubport last-update (if status "alive" "dead") transport) (if (or (equal? id sid) (equal? sid 0)) ;; kill all/any (begin - (debug:print-info 0 "Attempting to stop server with pid " pid) + (debug:print-info 0 *default-log-port* "Attempting to stop server with pid " pid) (tasks:kill-server status hostname pullport pid transport))))) servers) - (debug:print-info 1 "Done with listservers") + (debug:print-info 1 *default-log-port* "Done with listservers") (set! *didsomething* #t) (exit)) ;; must do, would have to add checks to many/all calls below (exit)))) ;;====================================================================== @@ -814,21 +813,21 @@ ;; Weird special calls that need to run *after* the server has started? ;;====================================================================== (if (args:get-arg "-list-targets") (let ((targets (common:get-runconfig-targets))) - (debug:print 1 "Found "(length targets) " targets") + (debug:print 1 *default-log-port* "Found "(length targets) " targets") (case (string->symbol (or (args:get-arg "-dumpmode") "alist")) ((alist) (for-each (lambda (x) ;; (print "[" x "]")) (print x)) targets)) ((json) (json-write targets)) (else - (debug:print 0 "ERROR: dump output format " (args:get-arg "-dumpmode") " not supported for -list-targets"))) + (debug:print 0 *default-log-port* "ERROR: dump output format " (args:get-arg "-dumpmode") " not supported for -list-targets"))) (set! *didsomething* #t))) ;; cache the runconfigs in $MT_LINKTREE/$MT_TARGET/$MT_RUNNAME/.runconfig ;; (define (full-runconfigs-read) @@ -884,11 +883,11 @@ ((string=? (args:get-arg "-dumpmode") "json") (json-write data)) ((string=? (args:get-arg "-dumpmode") "ini") (configf:config->ini data)) (else - (debug:print 0 "ERROR: -dumpmode of " (args:get-arg "-dumpmode") " not recognised"))) + (debug:print 0 *default-log-port* "ERROR: -dumpmode of " (args:get-arg "-dumpmode") " not recognised"))) (set! *didsomething* #t)) (pop-directory))) (if (args:get-arg "-show-config") (let ((tl (launch:setup)) @@ -908,11 +907,11 @@ ((string=? (args:get-arg "-dumpmode") "json") (json-write data)) ((string=? (args:get-arg "-dumpmode") "ini") (configf:config->ini data)) (else - (debug:print 0 "ERROR: -dumpmode of " (args:get-arg "-dumpmode") " not recognised"))) + (debug:print 0 *default-log-port* "ERROR: -dumpmode of " (args:get-arg "-dumpmode") " not recognised"))) (set! *didsomething* #t) (pop-directory))) (if (args:get-arg "-show-cmdinfo") (if (or (args:get-arg ":value")(getenv "MT_CMDINFO")) @@ -919,11 +918,11 @@ (let ((data (common:read-encoded-string (or (args:get-arg ":value")(getenv "MT_CMDINFO"))))) (if (equal? (args:get-arg "-dumpmode") "json") (json-write data) (pp data)) (set! *didsomething* #t)) - (debug:print-info 0 "environment variable MT_CMDINFO is not set"))) + (debug:print-info 0 *default-log-port* "environment variable MT_CMDINFO is not set"))) ;;====================================================================== ;; Remove old run(s) ;;====================================================================== @@ -932,34 +931,37 @@ (define (operate-on action) (let* ((runrec (runs:runrec-make-record)) (target (common:args-get-target))) (cond ((not target) - (debug:print 0 "ERROR: Missing required parameter for " action ", you must specify -target or -reqtarg") + (debug:print 0 *default-log-port* "ERROR: Missing required parameter for " action ", you must specify -target or -reqtarg") (exit 1)) ((not (or (args:get-arg ":runname") (args:get-arg "-runname"))) - (debug:print 0 "ERROR: Missing required parameter for " action ", you must specify the run name pattern with -runname patt") + (debug:print 0 *default-log-port* "ERROR: Missing required parameter for " action ", you must specify the run name pattern with -runname patt") (exit 2)) ((not (args:get-arg "-testpatt")) - (debug:print 0 "ERROR: Missing required parameter for " action ", you must specify the test pattern with -testpatt") + (debug:print 0 *default-log-port* "ERROR: Missing required parameter for " action ", you must specify the test pattern with -testpatt") (exit 3)) (else (if (not (car *configinfo*)) (begin - (debug:print 0 "ERROR: Attempted " action "on test(s) but run area config file not found") + (debug:print 0 *default-log-port* "ERROR: Attempted " action "on test(s) but run area config file not found") (exit 1)) ;; put test parameters into convenient variables - (runs:operate-on action - target - (common:args-get-runname) ;; (or (args:get-arg "-runname")(args:get-arg ":runname")) - (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt") - state: (common:args-get-state) - status: (common:args-get-status) - new-state-status: (args:get-arg "-set-state-status"))) + (begin + ;; check for correct version, exit with message if not correct + (common:exit-on-version-changed) + (runs:operate-on action + target + (common:args-get-runname) ;; (or (args:get-arg "-runname")(args:get-arg ":runname")) + (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt") + state: (common:args-get-state) + status: (common:args-get-status) + new-state-status: (args:get-arg "-set-state-status")))) (set! *didsomething* #t))))) - + (if (args:get-arg "-remove-runs") (general-run-call "-remove-runs" "remove runs" (lambda (target runname keys keyvals) @@ -983,11 +985,11 @@ #f #f #f)) (header (vector-ref runsdat 0)) (rows (vector-ref runsdat 1))) (if (null? rows) (begin - (debug:print-info 0 "No matching run found.") + (debug:print-info 0 *default-log-port* "No matching run found.") (exit 1)) (let* ((row (car (vector-ref runsdat 1))) (run-id (db:get-value-by-header row header "id"))) (if (args:get-arg "-set-run-status") (rmt:set-run-status run-id (args:get-arg "-set-run-status") msg: (args:get-arg "-m")) @@ -1083,11 +1085,11 @@ (tal (cdr adj-tests-spec)) (idx 0)) (hash-table-set! test-field-index hed idx) (if (not (null? tal))(loop (car tal)(cdr tal)(+ idx 1)))) (begin - (debug:print 0 "ERROR: Invalid test fields specified: " (string-intersperse invalid-tests-spec ", ")) + (debug:print 0 *default-log-port* "ERROR: Invalid test fields specified: " (string-intersperse invalid-tests-spec ", ")) (exit))))) ;; Each run (for-each (lambda (run) @@ -1112,11 +1114,12 @@ ;; use qryvals if test-spec provided (if tests-spec (string-intersperse adj-tests-spec ",") ;; db:test-record-fields #f) - #f) + #f + 'normal) '()))) (case dmode ((json ods) (if runs-spec (for-each @@ -1151,13 +1154,13 @@ (for-each (lambda (test) (handle-exceptions exn (begin - (debug:print 0 "ERROR: Bad data in test record? " test) + (debug:print 0 *default-log-port* "ERROR: Bad data in test record? " test) (print "exn=" (condition->list exn)) - (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) (print-call-chain (current-error-port))) (let* ((test-id (if (member "id" tests-spec)(get-value-by-fieldname test test-field-index "id" ) #f)) ;; (db:test-get-id test)) (testname (if (member "testname" tests-spec)(get-value-by-fieldname test test-field-index "testname" ) #f)) ;; (db:test-get-testname test)) (itempath (if (member "item_path" tests-spec)(get-value-by-fieldname test test-field-index "item_path" ) #f)) ;; (db:test-get-item-path test)) (comment (if (member "comment" tests-spec)(get-value-by-fieldname test test-field-index "comment" ) #f)) ;; (db:test-get-comment test)) @@ -1297,11 +1300,11 @@ (map (lambda (field) (let ((tmp (assoc field metadat))) (if tmp (cdr tmp) ""))) metadat-fields) (begin - (debug:print 0 "WARNING: meta data for run " runname " not found") + (debug:print 0 *default-log-port* "WARNING: meta data for run " runname " not found") '())))) allrundat))) ;; '( ( "target" ( "runname" ( "data" ( "runid" ( "id . "37" ) ( ... )))) (run-pages (map (lambda (targdat) (let* ((target (car targdat)) @@ -1326,11 +1329,11 @@ (cons (conc target "/" runname) (cons (list (conc target "/" runname)) (cons '() (cons run-fields tests))))) (begin - (debug:print 0 "WARNING: run " target "/" runname " appears to have no data") + (debug:print 0 *default-log-port* "WARNING: run " target "/" runname " appears to have no data") ;; (pp rundat) '())))) runsdat) '()))) newdat)) ;; we use newdat to get target @@ -1347,11 +1350,11 @@ (let* ((tempdir (conc "/tmp/" (current-user-name) "/" (random 10000) "_" (current-process-id))) (outputfile (or (args:get-arg "-o") "out.ods")) (ouf (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 *default-log-port* "WARNING: path given, " outputfile " is relative, prefixing with current directory") (conc (current-directory) "/" outputfile))))) (create-directory tempdir #t) (ods:list->ods tempdir ouf sheets)))) ;; (system (conc "rm -rf " tempdir)) (set! *didsomething* #t)))) @@ -1513,15 +1516,15 @@ (target (args:get-arg "-target")) (toppath (assoc/default 'toppath cmdinfo))) (change-directory toppath) (if (not target) (begin - (debug:print 0 "ERROR: -target is required.") + (debug:print 0 *default-log-port* "ERROR: -target is required.") (exit 1))) (if (not (launch:setup)) (begin - (debug:print 0 "Failed to setup, giving up on -test-paths or -test-files, exiting") + (debug:print 0 *default-log-port* "Failed to setup, giving up on -test-paths or -test-files, exiting") (exit 1))) (let* ((keys (rmt:get-keys)) ;; db:test-get-paths must not be run remote (paths (tests:test-get-paths-matching keys target (args:get-arg "-test-files")))) (set! *didsomething* #t) @@ -1564,11 +1567,11 @@ (let ((dbstruct (make-dbr:dbstruct path: *toppath* local: #t)) (outputfile (args:get-arg "-extract-ods")) (runspatt (or (args:get-arg "-runname")(args:get-arg ":runname"))) (pathmod (args:get-arg "-pathmod"))) ;; (keyvalalist (keys->alist keys "%"))) - (debug:print 2 "Extract ods, outputfile: " outputfile " runspatt: " runspatt " keyvals: " keyvals) + (debug:print 2 *default-log-port* "Extract ods, outputfile: " outputfile " runspatt: " runspatt " keyvals: " keyvals) (db:extract-ods-file dbstruct outputfile keyvals (if runspatt runspatt "%") pathmod) (db:close-all dbstruct) (set! *didsomething* #t))))) ;;====================================================================== @@ -1597,21 +1600,21 @@ (if (and run-id test-id) (begin (launch:recover-test run-id test-id) (set! *didsomething* #t)) (begin - (debug:print 0 "ERROR: bad run-id or test-id, must be integers") + (debug:print 0 *default-log-port* "ERROR: bad run-id or test-id, must be integers") (exit 1))))))) ;;====================================================================== ;; Test commands (i.e. for use inside tests) ;;====================================================================== (define (megatest:step step state status logfile msg) (if (not (getenv "MT_CMDINFO")) (begin - (debug:print 0 "ERROR: MT_CMDINFO env var not set, -step must be called *inside* a megatest invoked environment!") + (debug:print 0 *default-log-port* "ERROR: MT_CMDINFO env var not set, -step must be called *inside* a megatest invoked environment!") (exit 5)) (let* ((cmdinfo (common:read-encoded-string (getenv "MT_CMDINFO"))) (transport (assoc/default 'transport cmdinfo)) (testpath (assoc/default 'testpath cmdinfo)) (test-name (assoc/default 'test-name cmdinfo)) @@ -1623,16 +1626,18 @@ (work-area (assoc/default 'work-area cmdinfo)) (db #f)) (change-directory testpath) (if (not (launch:setup)) (begin - (debug:print 0 "Failed to setup, exiting") + (debug:print 0 *default-log-port* "Failed to setup, exiting") (exit 1))) (if (and state status) - (rmt:teststep-set-status! run-id test-id step state status msg logfile) + (let ((comment (launch:load-logpro-dat run-id test-id step))) + ;; (rmt:test-set-log! run-id test-id (conc stepname ".html")))) + (rmt:teststep-set-status! run-id test-id step state status (or comment msg) logfile)) (begin - (debug:print 0 "ERROR: You must specify :state and :status with every call to -step") + (debug:print 0 *default-log-port* "ERROR: You must specify :state and :status with every call to -step") (exit 6)))))) (if (args:get-arg "-step") (begin (megatest:step @@ -1653,11 +1658,11 @@ (args:get-arg "-load-test-data") (args:get-arg "-runstep") (args:get-arg "-summarize-items")) (if (not (getenv "MT_CMDINFO")) (begin - (debug:print 0 "ERROR: MT_CMDINFO env var not set, commands -test-status, -runstep and -setlog must be called *inside* a megatest environment!") + (debug:print 0 *default-log-port* "ERROR: MT_CMDINFO env var not set, commands -test-status, -runstep and -setlog must be called *inside* a megatest environment!") (exit 5)) (let* ((startingdir (current-directory)) (cmdinfo (common:read-encoded-string (getenv "MT_CMDINFO"))) (transport (assoc/default 'transport cmdinfo)) (testpath (assoc/default 'testpath cmdinfo)) @@ -1668,17 +1673,18 @@ (test-id (assoc/default 'test-id cmdinfo)) (itemdat (assoc/default 'itemdat cmdinfo)) (work-area (assoc/default 'work-area cmdinfo)) (db #f) ;; (open-db)) (state (args:get-arg ":state")) - (status (args:get-arg ":status"))) + (status (args:get-arg ":status")) + (stepname (args:get-arg "-step"))) (if (not (launch:setup)) (begin - (debug:print 0 "Failed to setup, exiting") + (debug:print 0 *default-log-port* "Failed to setup, exiting") (exit 1))) - (if (args:get-arg "-runstep")(debug:print-info 1 "Running -runstep, first change to directory " work-area)) + (if (args:get-arg "-runstep")(debug:print-info 1 *default-log-port* "Running -runstep, first change to directory " work-area)) (change-directory work-area) ;; can setup as client for server mode now ;; (client:setup) (if (args:get-arg "-load-test-data") @@ -1695,11 +1701,11 @@ ;; DO NOT run remote (tests:summarize-items run-id test-id test-name #t)) ;; do force here (if (args:get-arg "-runstep") (if (null? remargs) (begin - (debug:print 0 "ERROR: nothing specified to run!") + (debug:print 0 *default-log-port* "ERROR: nothing specified to run!") (if db (sqlite3:finalize! db)) (exit 6)) (let* ((stepname (args:get-arg "-runstep")) (logprofile (args:get-arg "-logpro")) (logfile (conc stepname ".log")) @@ -1718,21 +1724,21 @@ (cons cmd params) " ") ") " redir " " logfile))) ;; mark the start of the test (rmt:teststep-set-status! run-id test-id stepname "start" "n/a" (args:get-arg "-m") logfile) ;; run the test step - (debug:print-info 2 "Running \"" fullcmd "\" in directory \"" startingdir) + (debug:print-info 2 *default-log-port* "Running \"" fullcmd "\" in directory \"" startingdir) (change-directory startingdir) (set! exitstat (system fullcmd)) (set! *globalexitstatus* exitstat) ;; (change-directory testpath) ;; run logpro if applicable ;; (process-run "ls" (list "/foo" "2>&1" "blah.log")) (if logprofile (let* ((htmllogfile (conc stepname ".html")) (oldexitstat exitstat) (cmd (string-intersperse (list "logpro" logprofile htmllogfile "<" logfile ">" (conc stepname "_logpro.log")) " "))) - (debug:print-info 2 "running \"" cmd "\"") + (debug:print-info 2 *default-log-port* "running \"" cmd "\"") (change-directory startingdir) (set! exitstat (system cmd)) (set! *globalexitstatus* exitstat) ;; no necessary (change-directory testpath) (rmt:test-set-log! run-id test-id htmllogfile))) @@ -1756,11 +1762,11 @@ res))) (if (and (args:get-arg "-test-status") (or (not state) (not status))) (begin - (debug:print 0 "ERROR: You must specify :state and :status with every call to -test-status\n" help) + (debug:print 0 *default-log-port* "ERROR: You must specify :state and :status with every call to -test-status\n" help) (if (sqlite3:database? db)(sqlite3:finalize! db)) (exit 6))) (let* ((msg (args:get-arg "-m")) (numoth (length (hash-table-keys otherdata)))) ;; Convert to rpc inside the tests:test-set-status! call, not here @@ -1776,20 +1782,20 @@ (args:get-arg "-show-keys")) (let ((db #f) (keys #f)) (if (not (launch:setup)) (begin - (debug:print 0 "Failed to setup, exiting") + (debug:print 0 *default-log-port* "Failed to setup, exiting") (exit 1))) (set! keys (rmt:get-keys)) ;; db)) - (debug:print 1 "Keys: " (string-intersperse keys ", ")) + (debug:print 1 *default-log-port* "Keys: " (string-intersperse keys ", ")) (if (sqlite3:database? db)(sqlite3:finalize! db)) (set! *didsomething* #t))) (if (args:get-arg "-gui") (begin - (debug:print 0 "Look at the dashboard for now") + (debug:print 0 *default-log-port* "Look at the dashboard for now") ;; (megatest-gui) (set! *didsomething* #t))) (if (args:get-arg "-gen-megatest-area") (begin @@ -1807,40 +1813,30 @@ (if (args:get-arg "-rebuild-db") (begin (if (not (launch:setup)) (begin - (debug:print 0 "Failed to setup, exiting") + (debug:print 0 *default-log-port* "Failed to setup, exiting") (exit 1))) ;; keep this one local (open-run-close patch-db #f) (set! *didsomething* #t))) (if (args:get-arg "-cleanup-db") (begin (if (not (launch:setup)) (begin - (debug:print 0 "Failed to setup, exiting") + (debug:print 0 *default-log-port* "Failed to setup, exiting") (exit 1))) - ;; keep this one local - ;; (open-run-close db:clean-up #f) - (db:multi-db-sync - #f ;; do all run-ids - ;; 'new2old - 'killservers - 'dejunk - ;; 'adj-testids - ;; 'old2new - 'new2old - ) + (common:cleanup-db) (set! *didsomething* #t))) (if (args:get-arg "-mark-incompletes") (begin (if (not (launch:setup)) (begin - (debug:print 0 "Failed to setup, exiting") b + (debug:print 0 *default-log-port* "Failed to setup, exiting") (exit 1))) (open-run-close db:find-and-mark-incomplete #f) (set! *didsomething* #t))) ;;====================================================================== @@ -1849,11 +1845,11 @@ (if (args:get-arg "-update-meta") (begin (if (not (launch:setup)) (begin - (debug:print 0 "Failed to setup, exiting") + (debug:print 0 *default-log-port* "Failed to setup, exiting") (exit 1))) ;; now can find our db ;; keep this one local (open-run-close runs:update-all-test_meta #f) (set! *didsomething* #t))) @@ -1891,14 +1887,19 @@ ;; (import csi) (import readline) (import apropos) ;; (import (prefix sqlite3 sqlite3:)) ;; doesn't work ... (include "readline-fix.scm") - (gnu-history-install-file-manager - (string-append - (or (get-environment-variable "HOME") ".") "/.megatest_history")) - (current-input-port (make-gnu-readline-port "megatest> ")) + (if *use-new-readline* + (begin + (install-history-file (get-environment-variable "HOME") ".megatest_history") ;; [homedir] [filename] [nlines]) + (current-input-port (make-readline-port "megatest> "))) + (begin + (gnu-history-install-file-manager + (string-append + (or (get-environment-variable "HOME") ".") "/.megatest_history")) + (current-input-port (make-gnu-readline-port "megatest> ")))) (if (args:get-arg "-repl") (repl) (load (args:get-arg "-load"))) (db:close-all dbstruct)) (exit))) @@ -1912,11 +1913,11 @@ (not (or (args:get-arg "-run") (args:get-arg "-runtests")))) ;; run-wait is built into runtests now (begin (if (not (launch:setup)) (begin - (debug:print 0 "Failed to setup, exiting") + (debug:print 0 *default-log-port* "Failed to setup, exiting") (exit 1))) (operate-on 'run-wait) (set! *didsomething* #t))) ;; ;; ;; redo me ;; Not converted to use dbstruct yet @@ -1925,24 +1926,24 @@ ;; ;; ;; redo me (let* ((toppath (setup-for-run)) ;; ;; ;; redo me (dbstruct (if toppath (make-dbr:dbstruct path: toppath local: #t)))) ;; ;; ;; redo me (for-each ;; ;; ;; redo me (lambda (field) ;; ;; ;; redo me (let ((dat '())) -;; ;; ;; redo me (debug:print-info 0 "Getting data for field " field) +;; ;; ;; redo me (debug:print-info 0 *default-log-port* "Getting data for field " field) ;; ;; ;; redo me (sqlite3:for-each-row ;; ;; ;; redo me (lambda (id val) ;; ;; ;; redo me (set! dat (cons (list id val) dat))) ;; ;; ;; redo me (db:get-db db run-id) ;; ;; ;; redo me (conc "SELECT id," field " FROM tests;")) -;; ;; ;; redo me (debug:print-info 0 "found " (length dat) " items for field " field) +;; ;; ;; redo me (debug:print-info 0 *default-log-port* "found " (length dat) " items for field " field) ;; ;; ;; redo me (let ((qry (sqlite3:prepare db (conc "UPDATE tests SET " field "=? WHERE id=?;")))) ;; ;; ;; redo me (for-each ;; ;; ;; redo me (lambda (item) ;; ;; ;; redo me (let ((newval ;; (sdb:qry 'getid ;; ;; ;; redo me (cadr item))) ;; ) ;; ;; ;; redo me (if (not (equal? newval (cadr item))) -;; ;; ;; redo me (debug:print-info 0 "Converting " (cadr item) " to " newval " for test #" (car item))) +;; ;; ;; redo me (debug:print-info 0 *default-log-port* "Converting " (cadr item) " to " newval " for test #" (car item))) ;; ;; ;; redo me (sqlite3:execute qry newval (car item)))) ;; ;; ;; redo me dat) ;; ;; ;; redo me (sqlite3:finalize! qry)))) ;; ;; ;; redo me (db:close-all dbstruct) ;; ;; ;; redo me (list "uname" "rundir" "final_logf" "comment")) @@ -1973,20 +1974,20 @@ ;;====================================================================== (if *runremote* (close-all-connections!)) (if (not *didsomething*) - (debug:print 0 help)) + (debug:print 0 *default-log-port* help)) (set! *time-to-exit* #t) (thread-join! *watchdog*) (if (not (eq? *globalexitstatus* 0)) (if (or (args:get-arg "-run")(args:get-arg "-runtests")(args:get-arg "-runall")) (begin - (debug:print 0 "NOTE: Subprocesses with non-zero exit code detected: " *globalexitstatus*) + (debug:print 0 *default-log-port* "NOTE: Subprocesses with non-zero exit code detected: " *globalexitstatus*) (exit 0)) (case *globalexitstatus* ((0)(exit 0)) ((1)(exit 1)) ((2)(exit 2)) (else (exit 3))))) Index: mt.scm ================================================================== --- mt.scm +++ mt.scm @@ -50,16 +50,16 @@ ;; (print "runsdat: " runsdat) (let* ((header (vector-ref runsdat 0)) (runslst (vector-ref runsdat 1)) (full-list (append res runslst)) (have-more (eq? (length runslst) limit))) - ;; (debug:print 0 "header: " header " runslst: " runslst " have-more: " have-more) + ;; (debug:print 0 *default-log-port* "header: " header " runslst: " runslst " have-more: " have-more) (if have-more (let ((new-offset (+ offset limit)) (next-batch (rmt:get-runs-by-patt keys runnamepatt targpatt offset limit #f))) - (debug:print-info 4 "More than " limit " runs, have " (length full-list) " runs so far.") - (debug:print-info 0 "next-batch: " next-batch) + (debug:print-info 4 *default-log-port* "More than " limit " runs, have " (length full-list) " runs so far.") + (debug:print-info 0 *default-log-port* "next-batch: " next-batch) (loop next-batch full-list new-offset limit)) (vector header full-list))))) @@ -67,20 +67,20 @@ ;;====================================================================== ;; T E S T S ;;====================================================================== (define (mt:get-tests-for-run run-id testpatt states status #!key (not-in #t) (sort-by 'event_time) (sort-order "ASC") (qryvals #f)(last-update #f)) - (let loop ((testsdat (rmt:get-tests-for-run run-id testpatt states status 0 500 not-in sort-by sort-order qryvals last-update)) + (let loop ((testsdat (rmt:get-tests-for-run run-id testpatt states status 0 500 not-in sort-by sort-order qryvals last-update 'normal)) (res '()) (offset 0) (limit 500)) (let* ((full-list (append res testsdat)) (have-more (eq? (length testsdat) limit))) (if have-more (let ((new-offset (+ offset limit))) - (debug:print-info 4 "More than " limit " tests, have " (length full-list) " tests so far.") - (loop (rmt:get-tests-for-run run-id testpatt states status new-offset limit not-in sort-by sort-order qryvals last-update) + (debug:print-info 4 *default-log-port* "More than " limit " tests, have " (length full-list) " tests so far.") + (loop (rmt:get-tests-for-run run-id testpatt states status new-offset limit not-in sort-by sort-order qryvals last-update 'normal) full-list new-offset limit)) full-list)))) @@ -91,11 +91,11 @@ (if last-time (< (current-seconds)(+ last-time 5)) #f)))) (if useres (let ((result (vector-ref res 1))) - (debug:print 4 "Using lazy value res: " result) + (debug:print 4 *default-log-port* "Using lazy value res: " result) result) (let ((newres (rmt:get-prereqs-not-met run-id waitons ref-item-path mode: mode itemmaps: itemmaps))) (hash-table-set! *pre-reqs-met-cache* key (vector (current-seconds) newres)) newres)))) @@ -105,11 +105,11 @@ (define (mt:discard-blocked-tests run-id failed-test tests test-records) (if (null? tests) tests (begin - (debug:print-info 1 "Discarding tests from " tests " that are waiting on " failed-test) + (debug:print-info 1 *default-log-port* "Discarding tests from " tests " that are waiting on " failed-test) (let loop ((testn (car tests)) (remt (cdr tests)) (res '())) (let* ((test-dat (hash-table-ref/default test-records testn (vector #f #f '()))) (waitons (vector-ref test-dat 2))) @@ -120,11 +120,11 @@ new-res) (loop (car remt) (cdr remt) (if (member failed-test waitons) (begin - (debug:print 0 "Discarding test " testn "(" test-dat ") due to " failed-test) + (debug:print 0 *default-log-port* "Discarding test " testn "(" test-dat ") due to " failed-test) res) (cons testn res))))))))) ;;====================================================================== ;; T R I G G E R S @@ -137,11 +137,12 @@ (db:test-get-rundir test-dat)) ;; ) ;; ) (test-name (db:test-get-testname test-dat)) (tconfig #f) (state (if newstate newstate (db:test-get-state test-dat))) (status (if newstatus newstatus (db:test-get-status test-dat)))) - (if (and test-rundir ;; #f means no dir set yet + (if (and test-name + test-rundir ;; #f means no dir set yet (file-exists? test-rundir) (directory? test-rundir)) (call-with-environment-variables (list (cons "MT_TEST_NAME" test-name) (cons "MT_TEST_RUN_DIR" test-rundir) @@ -155,11 +156,11 @@ (if cmd ;; Putting the commandline into ( )'s means no control over the shell. ;; stdout and stderr will be caught in the NBFAKE or mt_launch.log files ;; or equivalent. No need to do this. Just run it? (let ((fullcmd (conc cmd " " test-id " " test-rundir " " trigger "&"))) - (debug:print-info 0 "TRIGGERED on " trigger ", running command " fullcmd) + (debug:print-info 0 *default-log-port* "TRIGGERED on " trigger ", running command " fullcmd) (process-run fullcmd))))) (list (conc state "/" status) (conc state "/") (conc "/" status))) @@ -172,11 +173,11 @@ ;; speed up for common cases with a little logic (define (mt:test-set-state-status-by-id run-id test-id newstate newstatus newcomment) (if (not (and run-id test-id)) (begin - (debug:print 0 "ERROR: bad data handed to mt:test-set-state-status-by-id, run-id=" run-id ", test-id=" test-id ", newstate=" newstate) + (debug:print 0 *default-log-port* "ERROR: bad data handed to mt:test-set-state-status-by-id, run-id=" run-id ", test-id=" test-id ", newstate=" newstate) (print-call-chain (current-error-port)) #f) (begin (cond ((and newstate newstatus newcomment) @@ -214,9 +215,9 @@ (setenv "MT_LINKTREE" old-link-tree) (unsetenv "MT_LINKTREE")) newtcfg)) (if (null? tal) (begin - (debug:print 0 "ERROR: No readable testconfig found for " test-name) + (debug:print 0 *default-log-port* "ERROR: No readable testconfig found for " test-name) #f) (loop (car tal)(cdr tal)))))))))) Index: multi-dboard.scm ================================================================== --- multi-dboard.scm +++ multi-dboard.scm @@ -212,11 +212,11 @@ (else (conc run-id ".db"))) #f))) (handle-exceptions exn (begin - (debug:print 0 "ERROR: Couldn't create path to " dbdir) + (debug:print 0 *default-log-port* "ERROR: Couldn't create path to " dbdir) (exit 1)) (if (not (directory? dbdir))(create-directory dbdir #t))) (if fname (conc dbdir "/" fname) dbdir))) @@ -240,11 +240,11 @@ db ;; merely return the already opened db (let* ((dbfile (areadb:dbfile-path areadat run-id)) ;; not already opened, so open it (db (if (file-exists? dbfile) (open-database dbfile) (begin - (debug:print 0 "ERROR: I was asked to open " dbfile ", but file does not exist or is not readable.") + (debug:print 0 *default-log-port* "ERROR: I was asked to open " dbfile ", but file does not exist or is not readable.") #f)))) (case run-id ((-1)(areadat-monitordb-set! areadat db)) ((0) (areadat-maindb-set! areadat db)) (else (rundat-db-set! rundat db))) @@ -263,11 +263,11 @@ (print row) (hash-table-set! runs id dat)))) (sql maindb (conc "SELECT id," (string-intersperse keys "||'/'||") ",runname,state,status,event_time FROM runs WHERE state != 'deleted';"))) - (debug:print 0 "ERROR: no main.db found at " (areadb:dbfile-path areadat 0))) + (debug:print 0 *default-log-port* "ERROR: no main.db found at " (areadb:dbfile-path areadat 0))) areadat)) ;; given an areadat and target/runname patt fill up runs data ;; ;; ?????/ @@ -323,15 +323,15 @@ (current-matrix (if (null? tab-ids) #f (tab-matrix current-tab))) (seen-nodes (make-hash-table)) (path-changed (if current-tab (equal? current-path (tab-view-path current-tab)) #t))) - ;; (debug:print-info 0 "Current path: " current-path) + ;; (debug:print-info 0 *default-log-port* "Current path: " current-path) ;; now for each area in the window gather the data (if path-changed (begin - (debug:print-info 0 "clearing matrix - path changed") + (debug:print-info 0 *default-log-port* "clearing matrix - path changed") (dboard:clear-matrix current-tab))) (for-each (lambda (area-name) ;; (print "Processing for area-name " area-name) (let* ((area-dat (hash-table-ref areas area-name)) @@ -485,11 +485,11 @@ (used-rows (hash-table-values rows)) (touched (make-hash-table)) ;; (vector row col) ==> true, touched cell (view-type (dboard:get-view-type keys current-path)) (changed #f) (state-statuses (list "PASS" "FAIL" "WARN" "CHECK" "SKIP" "RUNNING" "LAUNCHED"))) - ;; (debug:print 0 "current-matrix=" current-matrix) + ;; (debug:print 0 *default-log-port* "current-matrix=" current-matrix) (case view-type ((areas) ;; find row for this area, if not found, create new entry (let* ((curr-rownum (hash-table-ref/default rows area-name #f)) (next-rownum (+ (apply max (cons 0 used-rows)) 1)) (rownum (or curr-rownum next-rownum)) @@ -503,11 +503,11 @@ (if (not (equal? (iup:attribute current-matrix (conc "0:" count)) hed)) (iup:attribute-set! current-matrix (conc "0:" count) hed)) (iup:attribute-set! current-matrix (conc rownum ":" count) "0") (if (not (null? tal)) (loop (car tal)(cdr tal)(+ count 1)))) - (debug:print-info 0 "view-type=" view-type ", rownum=" rownum ", curr-rownum=" curr-rownum ", next-rownum=" next-rownum ", coord=" coord ", area-name=" area-name) + (debug:print-info 0 *default-log-port* "view-type=" view-type ", rownum=" rownum ", curr-rownum=" curr-rownum ", next-rownum=" next-rownum ", coord=" coord ", area-name=" area-name) (iup:attribute-set! current-matrix coord area-name) (set! changed #t)))))) (if changed (iup:attribute-set! current-matrix "REDRAW" "ALL")))) @@ -573,11 +573,11 @@ (if (not (null? area-names)) (let loop ((index 0) (hed (car area-names)) (tal (cdr area-names))) ;; (hash-table-set! tabs index hed) - (debug:print 0 "Adding area " hed " with index " index " to dashboard") + (debug:print 0 *default-log-port* "Adding area " hed " with index " index " to dashboard") (iup:attribute-set! tabtop (conc "TABTITLE" index) hed) (if (not (null? tal)) (loop (+ index 1)(car tal)(cdr tal))))) tabtop)))) @@ -730,21 +730,21 @@ toppath: (or (get-environment-variable "MT_RUN_AREA_HOME")(current-directory)))) (curr-mtcfg (if (and curr-mtcfgdat (not (null? curr-mtcfgdat)))(cadr curr-mtcfgdat) #f)) (curr-mtpath (if curr-mtcfg (car curr-mtcfgdat) #f))) (if curr-mtpath (begin - (debug:print-info 0 "Creating config file " fname) + (debug:print-info 0 *default-log-port* "Creating config file " fname) (if (not (file-exists? dirname)) (create-directory dirname #t)) (with-output-to-file fname (lambda () (let ((aname (pathname-strip-directory curr-mtpath))) (print "[" aname "]") (print "path " curr-mtpath)))) #t) (begin - (debug:print-info 0 "Need to create a config but no megatest.config found: " curr-mtcfgdat) + (debug:print-info 0 *default-log-port* "Need to create a config but no megatest.config found: " curr-mtcfgdat) #f)))) ;; ) (define (dboard:read-mtconf apath) (let* ((mtconffile (conc apath "/megatest.config"))) Index: newdashboard.scm ================================================================== --- newdashboard.scm +++ newdashboard.scm @@ -625,11 +625,11 @@ (if (< nextmintime (current-milliseconds)) (let* ((starttime (current-milliseconds)) (changes (dcommon:run-update keys data runname keypatts testpatt states statuses 'full my-window-id)) (endtime (current-milliseconds))) (set! nextmintime (+ endtime (* 2 (- endtime starttime)))) - (debug:print 11 "CHANGE(S): " (car changes) "...")) - (debug:print-info 11 "Server overloaded")))))) + (debug:print 11 *default-log-port* "CHANGE(S): " (car changes) "...")) + (debug:print-info 11 *default-log-port* "Server overloaded")))))) (dboard:data-set-updaters! *data* (make-hash-table)) (newdashboard *dbstruct-local*) (iup:main-loop) Index: nmsg-transport.scm ================================================================== --- nmsg-transport.scm +++ nmsg-transport.scm @@ -62,11 +62,11 @@ ;;====================================================================== ;; S E R V E R ;;====================================================================== (define (nmsg-transport:run dbstruct hostn run-id server-id #!key (retrynum 1000)) - (debug:print 2 "Attempting to start the server ...") + (debug:print 2 *default-log-port* "Attempting to start the server ...") (let* ((start-port (portlogger:open-run-close portlogger:find-port)) (server-thread (make-thread (lambda () (nmsg-transport:try-start-server dbstruct run-id start-port server-id)) "server thread")) (tdbdat (tasks:open-db))) @@ -84,26 +84,26 @@ (lambda ()(nmsg-transport:keep-running server-id run-id)) "keep running")) (thread-join! server-thread)) (if (> retrynum 0) (begin - (debug:print 0 "WARNING: Failed to connect to server (self) on host " hostn ":" start-port ", trying again.") + (debug:print 0 *default-log-port* "WARNING: Failed to connect to server (self) on host " hostn ":" start-port ", trying again.") (tasks:server-delete-record (db:delay-if-busy tdbdat) server-id "failed to start, never received server alive signature") (portlogger:open-run-close portlogger:set-failed start-port) (nmsg-transport:run dbstruct hostn run-id server-id)) (begin - (debug:print 0 "ERROR: could not find an open port to start server on. Giving up") + (debug:print 0 *default-log-port* "ERROR: could not find an open port to start server on. Giving up") (exit 1)))))) (define (nmsg-transport:try-start-server dbstruct run-id portnum server-id) (let ((repsoc (nn-socket 'rep))) (nn-bind repsoc (conc "tcp://*:" portnum)) (let loop ((msg-in (nn-recv repsoc))) (let* ((dat (db:string->obj msg-in transport: 'nmsg))) - (debug:print 0 "server, received: " dat) + (debug:print 0 *default-log-port* "server, received: " dat) (let ((result (api:execute-requests dbstruct dat))) - (debug:print 0 "server, sending: " result) + (debug:print 0 *default-log-port* "server, sending: " result) (nn-send repsoc (db:obj->string result transport: 'nmsg))) (loop (nn-recv repsoc)))))) ;; all routes though here end in exit ... ;; @@ -122,11 +122,11 @@ ;; (begin ;; (current-error-port *alt-log-file*) ;; (current-output-port *alt-log-file*))))) (if (server:check-if-running run-id) (begin - (debug:print-info 0 "Server for run-id " run-id " already running") + (debug:print-info 0 *default-log-port* "Server for run-id " run-id " already running") (exit 0))) (let loop ((server-id (tasks:server-lock-slot (db:delay-if-busy tdbdat) run-id)) (remtries 4)) (if (not server-id) (if (> remtries 0) @@ -134,15 +134,15 @@ (thread-sleep! 2) (if (not (server:check-if-running run-id)) (loop (tasks:server-lock-slot (db:delay-if-busy tdbdat) run-id) (- remtries 1)) (begin - (debug:print-info 0 "Another server took the slot, exiting") + (debug:print-info 0 *default-log-port* "Another server took the slot, exiting") (exit 0)))) (begin ;; since we didn't get the server lock we are going to clean up and bail out - (debug:print-info 2 "INFO: server pid=" (current-process-id) ", hostname=" (get-host-name) " not starting due to other candidates ahead in start queue") + (debug:print-info 2 *default-log-port* "INFO: server pid=" (current-process-id) ", hostname=" (get-host-name) " not starting due to other candidates ahead in start queue") (tasks:server-delete-records-for-this-pid (db:delay-if-busy tdbdat) " http-transport:launch") )) ;; locked in a server id, try to start up (nmsg-transport:run dbstruct hostn run-id server-id)) (set! *didsomething* #t) @@ -184,11 +184,11 @@ (nmsg-transport:client-api-send-receive-raw req dat timeout: timeout) ((timeout)(set! success #f) #f))) (key (if success (vector-ref result 1) #f))) - (debug:print 0 "success=" success ", key=" key ", expected-key=" expected-key ", equal? " (equal? key expected-key)) + (debug:print 0 *default-log-port* "success=" success ", key=" key ", expected-key=" expected-key ", equal? " (equal? key expected-key)) (if (and success (or (not expected-key) ;; just getting a reply is good enough then (equal? key expected-key))) (if return-socket req @@ -218,11 +218,11 @@ "send-recv")) (timeout (make-thread (lambda () (let loop ((count 0)) (thread-sleep! 1) - (debug:print-info 1 "send-receive-raw, still waiting after " count " seconds...") + (debug:print-info 1 *default-log-port* "send-receive-raw, still waiting after " count " seconds...") (if (and keepwaiting (< count timeout)) ;; yes, this is very aproximate (loop (+ count 1)))) (if keepwaiting (begin (print "timeout waiting for ping") @@ -240,14 +240,14 @@ (if success (if (and (vector? result) (vector-ref result 0)) ;; did it fail at the server? result ;; nope, all good (begin - (debug:print 0 "ERROR: error occured at server, info=" (vector-ref result 2)) - (debug:print 0 " client call chain:") + (debug:print 0 *default-log-port* "ERROR: error occured at server, info=" (vector-ref result 2)) + (debug:print 0 *default-log-port* " client call chain:") (print-call-chain (current-error-port)) - (debug:print 0 " server call chain:") + (debug:print 0 *default-log-port* " server call chain:") (pp (vector-ref result 1) (current-error-port)) (signal (vector-ref result 0)))) (signal (make-composite-condition (make-property-condition 'timeout 'message "nmsg-transport:client-api-send-receive-raw timed out talking to server")))))) @@ -263,11 +263,11 @@ (mutex-lock! *heartbeat-mutex*) (set! sdat *server-info*) (mutex-unlock! *heartbeat-mutex*) (if sdat (begin - (debug:print-info 0 "keep-running got sdat=" sdat) + (debug:print-info 0 *default-log-port* "keep-running got sdat=" sdat) sdat) (begin (thread-sleep! 0.5) (loop)))))) (iface (car server-info)) @@ -297,18 +297,18 @@ (db:sync-touched *inmemdb* run-id force-sync: #t) (if (and *server-run* (> (+ last-access server-timeout) (current-seconds))) (begin - (debug:print-info 0 "Server continuing, seconds since last db access: " (- (current-seconds) last-access)) + (debug:print-info 0 *default-log-port* "Server continuing, seconds since last db access: " (- (current-seconds) last-access)) (loop 0)) (begin - (debug:print-info 0 "Starting to shutdown the server.") + (debug:print-info 0 *default-log-port* "Starting to shutdown the server.") (set! *time-to-exit* #t) (db:sync-touched *inmemdb* run-id force-sync: #t) (tasks:server-delete-record (db:delay-if-busy tdbdat) server-id " http-transport:keep-running") - (debug:print-info 0 "Server shutdown complete. Exiting") + (debug:print-info 0 *default-log-port* "Server shutdown complete. Exiting") (exit) )))))) ;;====================================================================== ;; C L I E N T S @@ -339,20 +339,20 @@ ;; DO NOT USE ;; (define (nmsg-transport:client-signal-handler signum) (handle-exceptions exn - (debug:print " ... exiting ...") + (debug:print 0 *default-log-port* " ... exiting ...") (let ((th1 (make-thread (lambda () (if (not *received-response*) (receive-message* *runremote*))) ;; flush out last call if applicable "eat response")) (th2 (make-thread (lambda () - (debug:print 0 "ERROR: Received ^C, attempting clean exit. Please be patient and wait a few seconds before hitting ^C again.") + (debug:print 0 *default-log-port* "ERROR: Received ^C, attempting clean exit. Please be patient and wait a few seconds before hitting ^C again.") (thread-sleep! 3) ;; give the flush three seconds to do it's stuff - (debug:print 0 " Done.") + (debug:print 0 *default-log-port* " Done.") (exit 4)) "exit on ^C timer"))) (thread-start! th2) (thread-start! th1) (thread-join! th2)))) Index: portlogger.scm ================================================================== --- portlogger.scm +++ portlogger.scm @@ -54,13 +54,13 @@ (avail (tasks:wait-on-journal fname 10))) ;; wait up to about 10 seconds for the journal to go away (handle-exceptions exn (begin ;; (release-dot-lock fname) - (debug:print 0 "ERROR: portlogger:open-run-close failed. " proc " " params) - (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) - (debug:print 0 "exn=" (condition->list exn)) + (debug:print 0 *default-log-port* "ERROR: portlogger:open-run-close failed. " proc " " params) + (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 *default-log-port* "exn=" (condition->list exn)) (if (file-exists? fname)(delete-file fname)) ;; brutally get rid of it (print-call-chain (current-error-port))) (let* (;; (lock (obtain-dot-lock fname 2 9 10)) (db (portlogger:open-db fname)) (res (apply proc db params))) @@ -101,15 +101,15 @@ (define (portlogger:get-prev-used-port db) (handle-exceptions exn (begin - (debug:print 0 "EXCEPTION: portlogger database probably overloaded or unreadable. If you see this message again remove /tmp/.$USER-portlogger.db") - (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) - (debug:print 0 "exn=" (condition->list exn)) + (debug:print 0 *default-log-port* "EXCEPTION: portlogger database probably overloaded or unreadable. If you see this message again remove /tmp/.$USER-portlogger.db") + (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 *default-log-port* "exn=" (condition->list exn)) (print-call-chain (current-error-port)) - (debug:print 0 "Continuing anyway.") + (debug:print 0 *default-log-port* "Continuing anyway.") #f) (sqlite3:fold-row (lambda (var curr) (or curr var curr)) #f @@ -126,15 +126,15 @@ (+ lowport ;; top of registered ports is 49152 but lets use ports in the registered range (random (- 64000 lowport)))))) (handle-exceptions exn (begin - (debug:print 0 "EXCEPTION: portlogger database probably overloaded or unreadable. If you see this message again remove /tmp/.$USER-portlogger.db") - (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) - (debug:print 0 "exn=" (condition->list exn)) + (debug:print 0 *default-log-port* "EXCEPTION: portlogger database probably overloaded or unreadable. If you see this message again remove /tmp/.$USER-portlogger.db") + (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 *default-log-port* "exn=" (condition->list exn)) (print-call-chain (current-error-port)) - (debug:print 0 "Continuing anyway.")) + (debug:print 0 *default-log-port* "Continuing anyway.")) (portlogger:take-port db portnum)) portnum)) ;; set port to "released", "failed" etc. ;; @@ -156,14 +156,14 @@ (numargs (length args)) (result (handle-exceptions exn (begin - (debug:print 0 "EXCEPTION: portlogger database at " dbfname " probably overloaded or unreadable. Try removing it.") - (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 *default-log-port* "EXCEPTION: portlogger database at " dbfname " probably overloaded or unreadable. Try removing it.") + (debug:print 0 *default-log-port* " 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 *default-log-port* " status: " ((condition-property-accessor 'sqlite3 'status) exn)) (print-call-chain (current-error-port)) #f) (case (string->symbol (car args)) ;; commands with two or more params ((take)(portlogger:take-port db (string->number (cadr args)))) ((find)(portlogger:find-port db)) Index: process.scm ================================================================== --- process.scm +++ process.scm @@ -52,11 +52,11 @@ ;; (print "Called with cmd=" cmd ", proc=" proc ", params=" params) (handle-exceptions exn (begin (print "ERROR: Failed to run command: " cmd " " (string-intersperse params " ")) - (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) (print "exn=" (condition->list exn)) #f) (let-values (((fh fho pid) (if (null? params) (process cmd) (process cmd params)))) @@ -104,11 +104,11 @@ ;; here is an example line where the shell is sh or bash ;; "find / -print 2&>1 > findall.log" (define (run-n-wait cmdline #!key (params #f)(print-cmd #f)) (if print-cmd - (debug:print 0 + (debug:print 0 *default-log-port* (if (string? print-cmd) print-cmd "") cmdline (if params Index: rmt.scm ================================================================== --- rmt.scm +++ rmt.scm @@ -53,11 +53,11 @@ (max (- (current-seconds) start) 1)))) (vector-set! record 1 count) (if (and (> count 10) (> queries-per-second 10)) (begin - (debug:print-info 1 "db write rate too high, starting a server, count=" count " start=" start " run-id=" run-id " queries-per-second=" queries-per-second) + (debug:print-info 1 *default-log-port* "db write rate too high, starting a server, count=" count " start=" start " run-id=" run-id " queries-per-second=" queries-per-second) #t) #f)))) ;; if a server is either running or in the process of starting call client:setup ;; else return #f to let the calling proc know that there is no server available @@ -73,26 +73,26 @@ #f)))) (define *send-receive-mutex* (make-mutex)) ;; should have separate mutex per run-id (define (rmt:send-receive cmd rid params #!key (attemptnum 1)) ;; start attemptnum at 1 so the modulo below works as expected ;; clean out old connections - (mutex-lock! *db-multi-sync-mutex*) + ;; (mutex-lock! *db-multi-sync-mutex*) (let ((expire-time (- (current-seconds) (server:get-timeout) 10))) ;; don't forget the 10 second margin (for-each (lambda (run-id) (let ((connection (hash-table-ref/default *runremote* run-id #f))) (if (and (vector? connection) (< (http-transport:server-dat-get-last-access connection) expire-time)) (begin - (debug:print-info 0 "Discarding connection to server for run-id " run-id ", too long between accesses") + (debug:print-info 0 *default-log-port* "Discarding connection to server for run-id " run-id ", too long between accesses") ;; SHOULD CLOSE THE CONNECTION HERE (case *transport-type* ((nmsg)(nn-close (http-transport:server-dat-get-socket (hash-table-ref *runremote* run-id))))) (hash-table-delete! *runremote* run-id))))) (hash-table-keys *runremote*))) - (mutex-unlock! *db-multi-sync-mutex*) + ;; (mutex-unlock! *db-multi-sync-mutex*) ;; (mutex-lock! *send-receive-mutex*) (let* ((run-id (if rid rid 0)) (connection-info (rmt:get-connection-info run-id))) ;; the nmsg method does the encoding under the hood (the http method should be changed to do this also) (if connection-info @@ -114,11 +114,11 @@ ;; (mutex-unlock! *send-receive-mutex*) (case *transport-type* ((http) res) ;; (db:string->obj res)) ((nmsg) res))) ;; (vector-ref res 1))) (begin ;; let ((new-connection-info (client:setup run-id))) - (debug:print 0 "WARNING: Communication failed, trying call to rmt:send-receive again.") + (debug:print 0 *default-log-port* "WARNING: Communication failed, trying call to rmt:send-receive again.") ;; (case *transport-type* ;; ((nmsg)(nn-close (http-transport:server-dat-get-socket connection-info)))) (hash-table-delete! *runremote* run-id) ;; don't keep using the same connection ;; NOTE: killing server causes this process to block forever. No idea why. Dec 2. ;; (if (eq? (modulo attemptnum 5) 0) @@ -153,17 +153,17 @@ "300"))) (newres (rmt:open-qry-close-locally cmd run-id params))) (let ((delta (- (current-milliseconds) start-time))) (if (> delta max-query) (begin - (debug:print-info 0 "Starting server as query time " delta " is over the limit of " max-query) + (debug:print-info 0 *default-log-port* "Starting server as query time " delta " is over the limit of " max-query) (server:kind-run run-id))) ;; return the result! newres) ))) (begin - ;; (debug:print 0 "ERROR: Communication failed!") + ;; (debug:print 0 *default-log-port* "ERROR: Communication failed!") ;; (mutex-unlock! *send-receive-mutex*) ;; (exit) (rmt:open-qry-close-locally cmd run-id params) ))))) @@ -170,12 +170,12 @@ (define (rmt:update-db-stats run-id rawcmd params duration) (mutex-lock! *db-stats-mutex*) (handle-exceptions exn (begin - (debug:print 0 "WARNING: stats collection failed in update-db-stats") - (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 *default-log-port* "WARNING: stats collection failed in update-db-stats") + (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) (print "exn=" (condition->list exn)) #f) ;; if this fails we don't care, it is just stats (let* ((cmd (conc "run-id=" run-id " " (if (eq? rawcmd 'general-call) (car params) rawcmd))) (stat-vec (hash-table-ref/default *db-stats* cmd #f))) (if (not (vector? stat-vec)) @@ -187,15 +187,15 @@ (mutex-unlock! *db-stats-mutex*)) (define (rmt:print-db-stats) (let ((fmtstr "~40a~7-d~9-d~20,2-f")) ;; "~20,2-f" - (debug:print 18 "DB Stats\n========") - (debug:print 18 (format #f "~40a~8a~10a~10a" "Cmd" "Count" "TotTime" "Avg")) + (debug:print 18 *default-log-port* "DB Stats\n========") + (debug:print 18 *default-log-port* (format #f "~40a~8a~10a~10a" "Cmd" "Count" "TotTime" "Avg")) (for-each (lambda (cmd) (let ((cmd-dat (hash-table-ref *db-stats* cmd))) - (debug:print 18 (format #f fmtstr cmd (vector-ref cmd-dat 0) (vector-ref cmd-dat 1) (/ (vector-ref cmd-dat 1)(vector-ref cmd-dat 0)))))) + (debug:print 18 *default-log-port* (format #f fmtstr cmd (vector-ref cmd-dat 0) (vector-ref cmd-dat 1) (/ (vector-ref cmd-dat 1)(vector-ref cmd-dat 0)))))) (sort (hash-table-keys *db-stats*) (lambda (a b) (> (vector-ref (hash-table-ref *db-stats* a) 0) (vector-ref (hash-table-ref *db-stats* b) 0))))))) @@ -239,15 +239,15 @@ (res (vector-ref resdat 1)) (duration (- (current-milliseconds) start))) (if (not success) (if (> remretries 0) (begin - (debug:print 0 "ERROR: local query failed. Trying again.") + (debug:print 0 *default-log-port* "ERROR: local query failed. Trying again.") (thread-sleep! (/ (random 5000) 1000)) ;; some random delay (rmt:open-qry-close-locally cmd run-id params remretries: (- remretries 1))) (begin - (debug:print 0 "ERROR: too many retries in rmt:open-qry-close-locally, giving up") + (debug:print 0 *default-log-port* "ERROR: too many retries in rmt:open-qry-close-locally, giving up") #f)) (begin ;; (rmt:update-db-stats run-id cmd params duration) ;; mark this run as dirty if this was a write (if (not (member cmd api:read-only-queries)) @@ -270,11 +270,11 @@ (if (and res (vector-ref res 0)) (vector-ref res 1) ;;; YES!! THIS IS CORRECT!! CHANGE IT HERE, THEN CHANGE rmt:send-receive ALSO!!! #f))) ;; (db:string->obj (vector-ref dat 1)) ;; (begin -;; (debug:print 0 "ERROR: rmt:send-receive-no-auto-client-setup failed, attempting to continue. Got " dat) +;; (debug:print 0 *default-log-port* "ERROR: rmt:send-receive-no-auto-client-setup failed, attempting to continue. Got " dat) ;; dat)))) ;; Wrap json library for strings (why the ports crap in the first place?) (define (rmt:dat->json-str dat) (with-output-to-string @@ -365,11 +365,11 @@ (define (rmt:get-test-info-by-id run-id test-id) (if (and (number? run-id)(number? test-id)) (rmt:send-receive 'get-test-info-by-id run-id (list run-id test-id)) (begin - (debug:print 0 "WARNING: Bad data handed to rmt:get-test-info-by-id run-id=" run-id ", test-id=" test-id) + (debug:print 0 *default-log-port* "WARNING: Bad data handed to rmt:get-test-info-by-id run-id=" run-id ", test-id=" test-id) (print-call-chain (current-error-port)) #f))) (define (rmt:test-get-rundir-from-test-id run-id test-id) (rmt:send-receive 'test-get-rundir-from-test-id run-id (list run-id test-id))) @@ -376,25 +376,25 @@ (define (rmt:open-test-db-by-test-id run-id test-id #!key (work-area #f)) (let* ((test-path (if (string? work-area) work-area (rmt:test-get-rundir-from-test-id run-id test-id)))) - (debug:print 3 "TEST PATH: " test-path) + (debug:print 3 *default-log-port* "TEST PATH: " test-path) (open-test-db test-path))) ;; WARNING: This currently bypasses the transaction wrapped writes system (define (rmt:test-set-state-status-by-id run-id test-id newstate newstatus newcomment) (rmt:send-receive 'test-set-state-status-by-id run-id (list run-id test-id newstate newstatus newcomment))) (define (rmt:set-tests-state-status run-id testnames currstate currstatus newstate newstatus) (rmt:send-receive 'set-tests-state-status run-id (list run-id testnames currstate currstatus newstate newstatus))) -(define (rmt:get-tests-for-run run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals last-update) +(define (rmt:get-tests-for-run run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals last-update mode) (if (number? run-id) - (rmt:send-receive 'get-tests-for-run run-id (list run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals last-update)) + (rmt:send-receive 'get-tests-for-run run-id (list run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals last-update mode)) (begin - (debug:print "ERROR: rmt:get-tests-for-run called with bad run-id=" run-id) + (debug:print 0 *default-log-port* "ERROR: rmt:get-tests-for-run called with bad run-id=" run-id) (print-call-chain (current-error-port)) '()))) ;; get stuff via synchash (define (rmt:synchash-get run-id proc synckey keynum params) @@ -421,11 +421,11 @@ (if (list? res) (begin (mutex-lock! multi-run-mutex) (set! result (append result res)) (mutex-unlock! multi-run-mutex)) - (debug:print 0 "ERROR: get-tests-for-run-mindata failed for run-id " hed ", testpatt " testpatt ", states " states ", status " status ", not-in " not-in)))) + (debug:print 0 *default-log-port* "ERROR: get-tests-for-run-mindata failed for run-id " hed ", testpatt " testpatt ", states " states ", status " status ", not-in " not-in)))) (conc "multi-run-thread for run-id " hed))) (newthreads (cons newthread threads))) (thread-start! newthread) (thread-sleep! 0.05) ;; give that thread some time to start (if (null? tal) @@ -615,16 +615,16 @@ (if (not keyvals) #f (let ((prev-run-ids (rmt:get-prev-run-ids run-id))) ;; for each run starting with the most recent look to see if there is a matching test ;; if found then return that matching test record - (debug:print 4 "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals ", previous run ids found: " prev-run-ids) + (debug:print 4 *default-log-port* "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals ", previous run ids found: " prev-run-ids) (if (null? prev-run-ids) #f (let loop ((hed (car prev-run-ids)) (tal (cdr prev-run-ids))) - (let ((results (rmt:get-tests-for-run hed (conc test-name "/" item-path) '() '() #f #f #f #f #f #f #f))) - (debug:print 4 "Got tests for run-id " run-id ", test-name " test-name ", item-path " item-path ": " results) + (let ((results (rmt:get-tests-for-run hed (conc test-name "/" item-path) '() '() #f #f #f #f #f #f #f 'normal))) + (debug:print 4 *default-log-port* "Got tests for run-id " run-id ", test-name " test-name ", item-path " item-path ": " results) (if (and (null? results) (not (null? tal))) (loop (car tal)(cdr tal)) (if (null? results) #f (car results)))))))))) @@ -647,11 +647,11 @@ (define (rmt:teststep-set-status! run-id test-id teststep-name state-in status-in comment logfile) (let* ((state (items:check-valid-items "state" state-in)) (status (items:check-valid-items "status" status-in))) (if (or (not state)(not status)) - (debug:print 3 "WARNING: Invalid " (if status "status" "state") + (debug:print 3 *default-log-port* "WARNING: Invalid " (if status "status" "state") " value \"" (if status state-in status-in) "\", update your validvalues section in megatest.config")) (rmt:send-receive 'teststep-set-status! run-id (list run-id test-id teststep-name state-in status-in comment logfile)))) (define (rmt:get-steps-for-test run-id test-id) (rmt:send-receive 'get-steps-for-test run-id (list run-id test-id))) @@ -659,14 +659,15 @@ ;;====================================================================== ;; T E S T D A T A ;;====================================================================== (define (rmt:read-test-data run-id test-id categorypatt #!key (work-area #f)) - (let ((tdb (rmt:open-test-db-by-test-id run-id test-id work-area: work-area))) - (if tdb - (tdb:read-test-data tdb test-id categorypatt) - '()))) + (rmt:send-receive 'read-test-data run-id (list run-id test-id categorypatt))) +;; (let ((tdb (rmt:open-test-db-by-test-id run-id test-id work-area: work-area))) +;; (if tdb +;; (tdb:read-test-data tdb test-id categorypatt) +;; '()))) (define (rmt:testmeta-add-record testname) (rmt:send-receive 'testmeta-add-record #f (list testname))) (define (rmt:testmeta-get-record testname) Index: rpc-transport.scm ================================================================== --- rpc-transport.scm +++ rpc-transport.scm @@ -27,11 +27,11 @@ ;; procstr is the name of the procedure to be called as a string (define (rpc-transport:autoremote procstr params) (handle-exceptions exn (begin - (debug:print 1 "Remote failed for " proc " " params) + (debug:print 1 *default-log-port* "Remote failed for " proc " " params) (apply (eval (string->symbol procstr)) params)) ;; (if *runremote* ;; (apply (eval (string->symbol (conc "remote:" procstr))) params) (apply (eval (string->symbol procstr)) params))) @@ -43,11 +43,11 @@ (set! *run-id* run-id) (if (args:get-arg "-daemonize") (daemon:ize)) (if (server:check-if-running run-id) (begin - (debug:print 0 "INFO: Server for run-id " run-id " already running") + (debug:print 0 *default-log-port* "INFO: Server for run-id " run-id " already running") (exit 0))) (let loop ((server-id (open-run-close tasks:server-lock-slot tasks:open-db run-id)) (remtries 4)) (if (not server-id) (if (> remtries 0) @@ -55,18 +55,18 @@ (thread-sleep! 2) (loop (open-run-close tasks:server-lock-slot tasks:open-db run-id) (- remtries 1))) (begin ;; since we didn't get the server lock we are going to clean up and bail out - (debug:print-info 2 "INFO: server pid=" (current-process-id) ", hostname=" (get-host-name) " not starting due to other candidates ahead in start queue") + (debug:print-info 2 *default-log-port* "INFO: server pid=" (current-process-id) ", hostname=" (get-host-name) " not starting due to other candidates ahead in start queue") (open-run-close tasks:server-delete-records-for-this-pid tasks:open-db " rpc-transport:launch"))) (begin (rpc-transport:run (if (args:get-arg "-server")(args:get-arg "-server") "-") run-id server-id) (exit))))) (define (rpc-transport:run hostn run-id server-id) - (debug:print 2 "Attempting to start the rpc server ...") + (debug:print 2 *default-log-port* "Attempting to start the rpc server ...") ;; (trace rpc:publish-procedure!) (rpc:publish-procedure! 'server:login server:login) (rpc:publish-procedure! 'testing (lambda () "Just testing")) @@ -99,11 +99,11 @@ (set! db *inmemdb*) (open-run-close tasks:server-set-interface-port tasks:open-db server-id ipaddrstr portnum) - (debug:print 0 "Server started on " host:port) + (debug:print 0 *default-log-port* "Server started on " host:port) ;; (trace rpc:publish-procedure!) ;; (rpc:publish-procedure! 'server:login server:login) ;; (rpc:publish-procedure! 'testing (lambda () "Just testing")) @@ -123,18 +123,18 @@ (thread-sleep! 5) ;; no need to do this very often (let ((numrunning -1)) ;; (db:get-count-tests-running db))) (if (or (> numrunning 0) (> (+ *last-db-access* 60)(current-seconds))) (begin - (debug:print-info 0 "Server continuing, tests running: " numrunning ", seconds since last db access: " (- (current-seconds) *last-db-access*)) + (debug:print-info 0 *default-log-port* "Server continuing, tests running: " numrunning ", seconds since last db access: " (- (current-seconds) *last-db-access*)) (loop (+ 1 count))) (begin - (debug:print-info 0 "Starting to shutdown the server side") + (debug:print-info 0 *default-log-port* "Starting to shutdown the server side") (open-run-close tasks:server-delete-record tasks:open-db server-id " rpc-transport:try-start-server stop") (thread-sleep! 10) - (debug:print-info 0 "Max cached queries was " *max-cache-size*) - (debug:print-info 0 "Server shutdown complete. Exiting") + (debug:print-info 0 *default-log-port* "Max cached queries was " *max-cache-size*) + (debug:print-info 0 *default-log-port* "Server shutdown complete. Exiting") )))))) (define (rpc-transport:find-free-port-and-open port) (handle-exceptions exn @@ -162,11 +162,11 @@ (exit 1)))))) (define (rpc-transport:client-setup run-id #!key (remtries 10)) (if *runremote* (begin - (debug:print 0 "ERROR: Attempt to connect to server but already connected") + (debug:print 0 *default-log-port* "ERROR: Attempt to connect to server but already connected") #f) (let* ((host-info (hash-table-ref/default *runremote* run-id #f))) ;; (open-run-close db:get-var #f "SERVER")) (if host-info (let ((iface (car host-info)) (port (cadr host-info)) @@ -178,11 +178,11 @@ (begin (server:try-running run-id) (thread-sleep! 2) (rpc-transport:client-setup run-id (- remtries 1))))) (let* ((server-db-info (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 *default-log-port* "client:setup server-dat=" server-dat ", remaining-tries=" remaining-tries) (if server-db-info (let* ((iface (tasks:hostinfo-get-interface server-db-info)) (port (tasks:hostinfo-get-port server-db-info)) (server-dat (list iface port #f #f #f)) (ping-res ((rpc:procedure 'server:login host port) *toppath*))) @@ -201,26 +201,26 @@ ;; ;; (port (if (and hostinfo (> (length hostdat) 1))(cadr hostdat) #f))) ;; (if (and port ;; (string->number port)) ;; (let ((portn (string->number port))) -;; (debug:print-info 2 "Setting up to connect to host " host ":" port) +;; (debug:print-info 2 *default-log-port* "Setting up to connect to host " host ":" port) ;; (handle-exceptions ;; exn ;; (begin -;; (debug:print 0 "ERROR: Failed to open a connection to the server at host: " host " port: " port) -;; (debug:print 0 " EXCEPTION: " ((condition-property-accessor 'exn 'message) exn)) +;; (debug:print 0 *default-log-port* "ERROR: Failed to open a connection to the server at host: " host " port: " port) +;; (debug:print 0 *default-log-port* " EXCEPTION: " ((condition-property-accessor 'exn 'message) exn)) ;; ;; (open-run-close ;; ;; (lambda (db . param) ;; ;; (sqlite3:execute db "DELETE FROM metadat WHERE var='SERVER'")) ;; ;; #f) ;; (set! *runremote* #f)) ;; (if (and (not (args:get-arg "-server")) ;; no point in the server using the server using the server ;; ((rpc:procedure 'server:login host portn) *toppath*)) ;; (begin -;; (debug:print-info 2 "Logged in and connected to " host ":" port) +;; (debug:print-info 2 *default-log-port* "Logged in and connected to " host ":" port) ;; (set! *runremote* (vector host portn))) ;; (begin -;; (debug:print-info 2 "Failed to login or connect to " host ":" port) +;; (debug:print-info 2 *default-log-port* "Failed to login or connect to " host ":" port) ;; (set! *runremote* #f))))) -;; (debug:print-info 2 "no server available"))))) +;; (debug:print-info 2 *default-log-port* "no server available"))))) Index: runconfig.scm ================================================================== --- runconfig.scm +++ runconfig.scm @@ -17,20 +17,20 @@ (thekey (if keyvals (string-intersperse (map (lambda (x)(if x x "-na-")) (map cadr keyvals)) "/") (or (common:args-get-target) (get-environment-variable "MT_TARGET") (begin - (debug:print 0 "ERROR: setup-env-defaults called with no run-id or -target or -reqtarg") + (debug:print 0 *default-log-port* "ERROR: setup-env-defaults called with no run-id or -target or -reqtarg") "nothing matches this I hope")))) ;; Why was system disallowed in the reading of the runconfigs file? ;; NOTE: Should be setting env vars based on (target|default) (confdat (read-config fname #f #t environ-patt: environ-patt sections: (list "default" thekey))) (whatfound (make-hash-table)) (finaldat (make-hash-table)) (sections (list "default" thekey))) (if (not *target*)(set! *target* thekey)) ;; may save a db access or two but repeats db:get-target code - (debug:print 4 "Using key=\"" thekey "\"") + (debug:print 4 *default-log-port* "Using key=\"" thekey "\"") (if change-env (for-each ;; NB// This can be simplified with new content of keyvals having all that is needed. (lambda (keyval) (safe-setenv (car keyval)(cadr keyval))) @@ -51,15 +51,15 @@ (hash-table-set! finaldat envvar val))) (map car section-dat))))) sections) (if already-seen (begin - (debug:print 2 "Key settings found in runconfig.config:") + (debug:print 2 *default-log-port* "Key settings found in runconfig.config:") (for-each (lambda (fullkey) - (debug:print 2 (format #f "~20a ~a\n" fullkey (hash-table-ref/default whatfound fullkey 0)))) + (debug:print 2 *default-log-port* (format #f "~20a ~a\n" fullkey (hash-table-ref/default whatfound fullkey 0)))) sections) - (debug:print 2 "---") + (debug:print 2 *default-log-port* "---") (set! *already-seen-runconfig-info* #t))) ;; finaldat ;; was returning this "finaldat" which would be good but conflicts with other uses confdat )) @@ -74,7 +74,7 @@ (setup-env-defaults runconfigf run-id #t keyvals environ-patt: (conc "(default" (if targ (conc "|" targ ")") ")"))) - (debug:print 0 "WARNING: You do not have a run config file: " runconfigf)))) + (debug:print 0 *default-log-port* "WARNING: You do not have a run config file: " runconfigf)))) Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -1,7 +1,7 @@ -;; Copyright 2006-2013, 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 @@ -8,11 +8,12 @@ ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. ;; strftime('%m/%d/%Y %H:%M:%S','now','localtime') -(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking (srfi 18) posix-extras directory-utils) +(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking (srfi 18) + posix-extras directory-utils pathname-expand defstruct format) (import (prefix sqlite3 sqlite3:)) (declare (unit runs)) (declare (uses db)) (declare (uses common)) @@ -27,10 +28,12 @@ (include "common_records.scm") (include "key_records.scm") (include "db_records.scm") (include "run_records.scm") (include "test_records.scm") + +;; (include "debugger.scm") (define (runs:test-get-full-path test) (let* ((testname (db:test-get-testname test)) (itempath (db:test-get-item-path test))) (conc testname (if (equal? itempath "") "" (conc "(" itempath ")"))))) @@ -48,11 +51,11 @@ (if itempath (setenv "MT_ITEMPATH" itempath)) ;; get the info from the db and put it in the cache (if link-tree (setenv "MT_LINKTREE" link-tree) - (debug:print 0 "ERROR: linktree not set, should be set in megatest.config in [setup] section.")) + (debug:print 0 *default-log-port* "ERROR: linktree not set, should be set in megatest.config in [setup] section.")) (if (not vals) (let ((ht (make-hash-table))) (hash-table-set! *env-vars-by-run-id* run-id ht) (set! vals ht) (for-each @@ -61,19 +64,19 @@ keyvals))) ;; from the cached data set the vars (hash-table-for-each vals (lambda (key val) - (debug:print 2 "setenv " key " " val) + (debug:print 2 *default-log-port* "setenv " key " " val) (safe-setenv key val))) (if (not (get-environment-variable "MT_TARGET"))(setenv "MT_TARGET" target)) (alist->env-vars (hash-table-ref/default *configdat* "env-override" '())) ;; Lets use this as an opportunity to put MT_RUNNAME in the environment (let ((runname (if inrunname inrunname (rmt:get-run-name-from-id run-id)))) (if runname (setenv "MT_RUNNAME" runname) - (debug:print 0 "ERROR: no value for runname for id " run-id))) + (debug:print 0 *default-log-port* "ERROR: no value for runname for id " run-id))) (setenv "MT_RUN_AREA_HOME" *toppath*) ;; if a testname and itempath are available set the remaining appropriate variables (if testname (setenv "MT_TEST_NAME" testname)) (if itempath (setenv "MT_ITEMPATH" itempath)) (if (and testname link-tree) @@ -87,11 +90,11 @@ "")))) )) (define (set-item-env-vars itemdat) (for-each (lambda (item) - (debug:print 2 "setenv " (car item) " " (cadr item)) + (debug:print 2 *default-log-port* "setenv " (car item) " " (cadr item)) (setenv (car item) (cadr item))) itemdat)) ;; Every time can-run-more-tests is called increment the delay ;; @@ -125,11 +128,11 @@ (define (runs:can-run-more-tests run-id jobgroup max-concurrent-jobs) (thread-sleep! (cond ((> *runs:can-run-more-tests-count* 20) (if (runs:lownoise "waiting on tasks" 60) - (debug:print-info 2 "waiting for tasks to complete, sleeping briefly ...")) + (debug:print-info 2 *default-log-port* "waiting for tasks to complete, sleeping briefly ...")) 2);; obviously haven't had any work to do for a while (else 0))) (let* ((num-running (rmt:get-count-tests-running run-id)) (num-running-in-jobgroup (rmt:get-count-tests-running-in-jobgroup run-id jobgroup)) (job-group-limit (let ((jobg-count (config-lookup *configdat* "jobgroups" jobgroup))) @@ -138,28 +141,28 @@ jobg-count)))) (if (> (+ num-running num-running-in-jobgroup) 0) (set! *runs:can-run-more-tests-count* (+ *runs:can-run-more-tests-count* 1))) (if (not (eq? *last-num-running-tests* num-running)) (begin - (debug:print 2 "max-concurrent-jobs: " max-concurrent-jobs ", num-running: " num-running) + (debug:print 2 *default-log-port* "max-concurrent-jobs: " max-concurrent-jobs ", num-running: " num-running) (set! *last-num-running-tests* num-running))) (if (not (eq? 0 *globalexitstatus*)) (list #f num-running num-running-in-jobgroup max-concurrent-jobs job-group-limit) (let ((can-not-run-more (cond ;; if max-concurrent-jobs is set and the number running is greater ;; than it than cannot run more jobs ((and max-concurrent-jobs (>= num-running max-concurrent-jobs)) (if (runs:lownoise "mcj msg" 60) - (debug:print 0 "WARNING: Max running jobs exceeded, current number running: " num-running + (debug:print 0 *default-log-port* "WARNING: Max running jobs exceeded, current number running: " num-running ", max_concurrent_jobs: " max-concurrent-jobs)) #t) ;; if job-group-limit is set and number of jobs in the group is greater ;; than the limit then cannot run more jobs of this kind ((and job-group-limit (>= num-running-in-jobgroup job-group-limit)) (if (runs:lownoise (conc "maxjobgroup " jobgroup) 60) - (debug:print 1 "WARNING: number of jobs " num-running-in-jobgroup + (debug:print 1 *default-log-port* "WARNING: number of jobs " num-running-in-jobgroup " in jobgroup \"" jobgroup "\" exceeds limit of " job-group-limit)) #t) (else #f)))) (list (not can-not-run-more) num-running num-running-in-jobgroup max-concurrent-jobs job-group-limit))))) @@ -195,11 +198,11 @@ (set! run-count config-reruns)) (if (tasks:need-server run-id)(tasks:start-and-wait-for-server tdbdat run-id 10)) (let ((sighand (lambda (signum) - y ;; (signal-mask! signum) ;; to mask or not? seems to cause issues in exiting + ;; (signal-mask! signum) ;; to mask or not? seems to cause issues in exiting (set! *time-to-exit* #t) (print "Received signal " signum ", cleaning up before exit. Please wait...") (let ((th1 (make-thread (lambda () (let ((tdbdat (tasks:open-db))) (rmt:tasks-set-state-given-param-key task-key "killed")) @@ -206,11 +209,11 @@ (print "Killed by signal " signum ". Exiting") (thread-sleep! 3) (exit)))) (th2 (make-thread (lambda () (thread-sleep! 5) - (debug:print 0 "Done") + (debug:print 0 *default-log-port* "Done") (exit 4))))) (thread-start! th2) (thread-start! th1) (thread-join! th2))))) (set-signal-handler! signal/int sighand) @@ -218,11 +221,11 @@ (runs:set-megatest-env-vars run-id inkeys: keys inrunname: runname) ;; these may be needed by the launching process (set! runconf (if (file-exists? runconfigf) (setup-env-defaults runconfigf run-id *already-seen-runconfig-info* keyvals target) (begin - (debug:print 0 "WARNING: You do not have a run config file: " runconfigf) + (debug:print 0 *default-log-port* "WARNING: You do not have a run config file: " runconfigf) #f))) ;; register this run in monitor.db (rmt:tasks-add "run-tests" user target runname test-patts task-key) ;; params) (rmt:tasks-set-state-given-param-key task-key "running") @@ -249,14 +252,14 @@ ;; look up all tests matching the comma separated list of globs in ;; test-patts (using % as wildcard) ;; (set! test-names (delete-duplicates (tests:get-valid-tests *toppath* test-patts))) - (debug:print-info 0 "tests search path: " (string-intersperse (tests:get-tests-search-path *configdat*) " ")) - (debug:print-info 0 "all tests: " (string-intersperse (sort all-test-names string<) " ")) - (debug:print-info 0 "test names: " (string-intersperse (sort test-names string<) " ")) - (debug:print-info 0 "required tests: " (string-intersperse (sort required-tests string<) " ")) + (debug:print-info 0 *default-log-port* "tests search path: " (string-intersperse (tests:get-tests-search-path *configdat*) " ")) + (debug:print-info 0 *default-log-port* "all tests: " (string-intersperse (sort all-test-names string<) " ")) + (debug:print-info 0 *default-log-port* "test names: " (string-intersperse (sort test-names string<) " ")) + (debug:print-info 0 *default-log-port* "required tests: " (string-intersperse (sort required-tests string<) " ")) ;; on the first pass or call to run-tests set FAILS to NOT_STARTED if ;; -keepgoing is specified (if (eq? *passnum* 0) (begin @@ -291,17 +294,17 @@ (let loop ((hed (car test-names)) ;; NOTE: This is the main loop that iterates over the test-names (tal (cdr test-names))) ;; 'return-procs tells the config reader to prep running system but return a proc (change-directory *toppath*) ;; PLEASE OPTIMIZE ME!!! I think this should be a no-op but there are several places where change-directories could be happening. (setenv "MT_TEST_NAME" hed) ;; (let*-values (((waitons waitors config)(tests:get-waitons hed all-tests-registry))) - (debug:print-info 8 "waitons: " waitons) + (debug:print-info 8 *default-log-port* "waitons: " waitons) ;; check for hed in waitons => this would be circular, remove it and issue an ;; error (if (or (member hed waitons) (member hed waitors)) (begin - (debug:print 0 "ERROR: test " hed " has listed itself as a waiton or waitor, please correct this!") + (debug:print 0 *default-log-port* "ERROR: test " hed " has listed itself as a waiton or waitor, please correct this!") (set! waitons (filter (lambda (x)(not (equal? x hed))) waitons)) (set! waitors (filter (lambda (x)(not (equal? x hed))) waitors)))) ;; (items (items:get-items-from-config config))) (if (not (hash-table-ref/default test-records hed #f)) @@ -323,11 +326,11 @@ (waiton-itemized (and waiton-tconfig (or (hash-table-ref/default waiton-tconfig "items" #f) (hash-table-ref/default waiton-tconfig "itemstable" #f)))) (itemmaps (tests:get-itemmaps config)) ;; (configf:lookup config "requirements" "itemmap")) (new-test-patts (tests:extend-test-patts test-patts hed waiton itemmaps))) - (debug:print-info 0 "Test " waiton " has " (if waiton-record "a" "no") " waiton-record and" (if waiton-itemized " " " no ") "items") + (debug:print-info 0 *default-log-port* "Test " waiton " has " (if waiton-record "a" "no") " waiton-record and" (if waiton-itemized " " " no ") "items") ;; need to account for test-patt here, if I am test "a", selected with a test-patt of "hed/b%" ;; and we are waiting on "waiton" we need to add "waiton/,waiton/b%" to test-patt ;; is this satisfied by merely appending "/" to the waiton name added to the list? ;; ;; This approach causes all of the items in an upstream test to be run @@ -340,19 +343,19 @@ (if waiton-tconfig (begin (set! test-names (cons waiton test-names)) ;; need to process this one, only add once the waiton tconfig read (if waiton-itemized (begin - (debug:print-info 0 "New test patts: " new-test-patts ", prev test patts: " test-patts) + (debug:print-info 0 *default-log-port* "New test patts: " new-test-patts ", prev test patts: " test-patts) (set! required-tests (cons (conc waiton "/") required-tests)) (set! test-patts new-test-patts)) (begin - (debug:print-info 0 "Adding non-itemized test " waiton " to required-tests") + (debug:print-info 0 *default-log-port* "Adding non-itemized test " waiton " to required-tests") (set! required-tests (cons waiton required-tests)) (set! test-patts new-test-patts)))) (begin - (debug:print-info 0 "No testconfig info yet for " waiton ", setting up to re-process it") + (debug:print-info 0 *default-log-port* "No testconfig info yet for " waiton ", setting up to re-process it") (set! tal (append (cons waiton tal)(list hed))))) ;; (cons (conc waiton "/") required-tests)) ;; NOPE: didn't work. required needs to be plain test names. Try tacking on to test-patts ;; - doesn't work ;; (set! test-patts (conc test-patts "," waiton "/")) @@ -361,41 +364,42 @@ ))) (delete-duplicates (append waitons waitors))) (let ((remtests (delete-duplicates (append waitons tal)))) (if (not (null? remtests)) (begin - ;; (debug:print-info 0 "Preprocessing continues for " (string-intersperse remtests ", ")) + ;; (debug:print-info 0 *default-log-port* "Preprocessing continues for " (string-intersperse remtests ", ")) (loop (car remtests)(cdr remtests)))))))) (if (not (null? required-tests)) - (debug:print-info 1 "Adding \"" (string-intersperse required-tests " ") "\" to the run queue")) + (debug:print-info 1 *default-log-port* "Adding \"" (string-intersperse required-tests " ") "\" to the run queue")) ;; NOTE: these are all parent tests, items are not expanded yet. - (debug:print-info 4 "test-records=" (hash-table->alist test-records)) + (debug:print-info 4 *default-log-port* "test-records=" (hash-table->alist test-records)) (let ((reglen (configf:lookup *configdat* "setup" "runqueue"))) (if (> (length (hash-table-keys test-records)) 0) (let* ((keep-going #t) (run-queue-retries 5) (th1 (make-thread (lambda () - (handle-exceptions - exn - (begin - (print-call-chain (current-error-port)) - (debug:print 0 "ERROR: failure in runs:run-tests-queue thread, error: " ((condition-property-accessor 'exn 'message) exn)) - (if (> run-queue-retries 0) - (begin - (set! run-queue-retries (- run-queue-retries 1)) - (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests (any->number reglen) all-tests-registry)))) - (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests (any->number reglen) all-tests-registry))) + (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests (any->number reglen) all-tests-registry)) + ;; (handle-exceptions + ;; exn + ;; (begin + ;; (print-call-chain (current-error-port)) + ;; (debug:print 0 *default-log-port* "ERROR: failure in runs:run-tests-queue thread, error: " ((condition-property-accessor 'exn 'message) exn)) + ;; (if (> run-queue-retries 0) + ;; (begin + ;; (set! run-queue-retries (- run-queue-retries 1)) + ;; (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests (any->number reglen) all-tests-registry)))) + ;; (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests (any->number reglen) all-tests-registry))) "runs:run-tests-queue")) (th2 (make-thread (lambda () ;; (rmt:find-and-mark-incomplete-all-runs))))) CAN'T INTERRUPT IT ... (let ((run-ids (rmt:get-all-run-ids))) (for-each (lambda (run-id) (if keep-going (handle-exceptions exn - (debug:print 0 "error in calling find-and-mark-incomplete for run-id " run-id) + (debug:print 0 *default-log-port* "error in calling find-and-mark-incomplete for run-id " run-id) (rmt:find-and-mark-incomplete run-id #f)))) ;; ovr-deadtime))) run-ids))) "runs: mark-incompletes"))) (thread-start! th1) (thread-start! th2) @@ -409,12 +413,12 @@ (hash-table-set! flags "-preclean" #t)) (if (not (hash-table-ref/default flags "-rerun" #f)) (hash-table-set! flags "-rerun" "STUCK/DEAD,n/a,ZERO_ITEMS")) ;; recursive call to self (runs:run-tests target runname test-patts user flags run-count: (- run-count 1))))) - (debug:print-info 0 "No tests to run"))) - (debug:print-info 4 "All done by here") + (debug:print-info 0 *default-log-port* "No tests to run"))) + (debug:print-info 4 *default-log-port* "All done by here") (rmt:tasks-set-state-given-param-key task-key "done") ;; (sqlite3:finalize! tasks-db) )) @@ -438,11 +442,11 @@ ;; ((and regfull (null? reg)(not (null? tal))) (car tal)) ;; ((and regfull (not (null? reg))) (car reg)) ;; ((and (not regfull)(null? tal)(not (null? reg))) (car reg)) ;; ((and (not regfull)(not (null? tal))) (car tal)) ;; (else -;; (debug:print 0 "ERROR: runs:queue-next-hed, tal=" tal ", reg=" reg ", n=" n ", regfull=" regfull) +;; (debug:print 0 *default-log-port* "ERROR: runs:queue-next-hed, tal=" tal ", reg=" reg ", n=" n ", regfull=" regfull) ;; #f))) (define (runs:queue-next-tal tal reg n regfull) (if regfull tal @@ -459,17 +463,24 @@ (define runs:nothing-left-in-queue-count 0) (define (runs:expand-items hed tal reg reruns regfull newtal jobgroup max-concurrent-jobs run-id waitons item-path testmode test-record can-run-more items runname tconfig reglen test-registry test-records itemmaps) (let* ((loop-list (list hed tal reg reruns)) - (prereqs-not-met (rmt:get-prereqs-not-met run-id waitons hed item-path mode: testmode itemmaps: itemmaps)) + (prereqs-not-met (let ((res (rmt:get-prereqs-not-met run-id waitons hed item-path mode: testmode itemmaps: itemmaps))) + (if (list? res) + res + (begin + (debug:print 0 *default-log-port* + "ERROR: rmt:get-prereqs-not-met returned non-list!\n" + " res=" res " run-id=" run-id " waitons=" waitons " hed=" hed " item-path=" item-path " testmode=" testmode " itemmaps=" itemmaps) + '())))) ;; (prereqs-not-met (mt:lazy-get-prereqs-not-met run-id waitons item-path mode: testmode itemmap: itemmap)) (fails (runs:calc-fails prereqs-not-met)) (prereq-fails (runs:calc-prereq-fail prereqs-not-met)) (non-completed (runs:calc-not-completed prereqs-not-met)) (runnables (runs:calc-runnable prereqs-not-met))) - (debug:print-info 4 "START OF INNER COND #2 " + (debug:print-info 4 *default-log-port* "START OF INNER COND #2 " "\n can-run-more: " can-run-more "\n testname: " hed "\n prereqs-not-met: " (runs:pretty-string prereqs-not-met) "\n non-completed: " (runs:pretty-string non-completed) "\n prereq-fails: " (runs:pretty-string prereq-fails) @@ -479,41 +490,41 @@ "\n (null? non-completed): " (null? non-completed) "\n reruns: " reruns "\n items: " items "\n can-run-more: " can-run-more) - (cond + (cond ;; all prereqs met, fire off the test ;; or, if it is a 'toplevel test and all prereqs not met are COMPLETED then launch ((and (not (member 'toplevel testmode)) (member (hash-table-ref/default test-registry (db:test-make-full-name hed item-path) 'n/a) '(DONOTRUN removed CANNOTRUN))) ;; *common:cant-run-states-sym*) ;; '(COMPLETED KILLED WAIVED UNKNOWN INCOMPLETE)) ;; try to catch repeat processing of COMPLETED tests here - (debug:print-info 1 "Test " hed " set to \"" (hash-table-ref test-registry (db:test-make-full-name hed item-path)) "\". Removing it from the queue") + (debug:print-info 1 *default-log-port* "Test " hed " set to \"" (hash-table-ref test-registry (db:test-make-full-name hed item-path)) "\". Removing it from the queue") (if (or (not (null? tal)) (not (null? reg))) (list (runs:queue-next-hed tal reg reglen regfull) (runs:queue-next-tal tal reg reglen regfull) (runs:queue-next-reg tal reg reglen regfull) reruns) (begin - (debug:print-info 0 "Nothing left in the queue!") + (debug:print-info 0 *default-log-port* "Nothing left in the queue!") ;; If get here twice then we know we've tried to expand all items ;; since there must be a logic issue with the handling of loops in the ;; items expand phase we will brute force an exit here. (if (> runs:nothing-left-in-queue-count 2) (begin - (debug:print 0 "WARNING: this condition is triggered when there were no items to expand and nothing to run. Please check your run for completeness") + (debug:print 0 *default-log-port* "WARNING: this condition is triggered when there were no items to expand and nothing to run. Please check your run for completeness") (exit 0)) (set! runs:nothing-left-in-queue-count (+ runs:nothing-left-in-queue-count 1))) #f))) ;; ((or (null? prereqs-not-met) (and (member 'toplevel testmode) (null? non-completed))) - (debug:print-info 4 "runs:expand-items: (or (null? prereqs-not-met) (and (member 'toplevel testmode)(null? non-completed)))") + (debug:print-info 4 *default-log-port* "runs:expand-items: (or (null? prereqs-not-met) (and (member 'toplevel testmode)(null? non-completed)))") (let ((test-name (tests:testqueue-get-testname test-record))) (setenv "MT_TEST_NAME" test-name) ;; (setenv "MT_RUNNAME" runname) (runs:set-megatest-env-vars run-id inrunname: runname) ;; these may be needed by the launching process (let ((items-list (items:get-items-from-config tconfig))) @@ -526,11 +537,11 @@ (not (> num-items 0))) (mt:test-set-state-status-by-id run-id test-id "NOT_STARTED" "ZERO_ITEMS" "Failed to run due to failed prerequisites")))) (tests:testqueue-set-items! test-record items-list) (list hed tal reg reruns)) (begin - (debug:print 0 "ERROR: The proc from reading the items table did not yield a list - please report this") + (debug:print 0 *default-log-port* "ERROR: The proc from reading the items table did not yield a list - please report this") (exit 1)))))) ((and (null? fails) (null? prereq-fails) (not (null? non-completed))) @@ -557,11 +568,11 @@ (if (and give-up (not (and (null? tal)(null? reg)))) (let ((trimmed-tal (mt:discard-blocked-tests run-id hed tal test-records)) (trimmed-reg (mt:discard-blocked-tests run-id hed reg test-records))) - (debug:print 1 "WARNING: test " hed " has discarded prerequisites, removing it from the queue") + (debug:print 1 *default-log-port* "WARNING: test " hed " has discarded prerequisites, removing it from the queue") (let ((test-id (rmt:get-test-id run-id hed ""))) (if test-id (mt:test-set-state-status-by-id run-id test-id "NOT_STARTED" "PREQ_DISCARDED" "Failed to run due to discarded prerequisites"))) (if (and (null? trimmed-tal) @@ -577,18 +588,18 @@ (null? prereq-fails) (null? non-completed)) (if (runs:can-keep-running? hed 20) (begin (runs:inc-cant-run-tests hed) - (debug:print-info 1 "no fails in prerequisites for " hed " but also none running, keeping " hed " for now. Try count: " (hash-table-ref/default *seen-cant-run-tests* hed 0)) + (debug:print-info 1 *default-log-port* "no fails in prerequisites for " hed " but also none running, keeping " hed " for now. Try count: " (hash-table-ref/default *seen-cant-run-tests* hed 0)) ;; getting here likely means the system is way overloaded, kill a full minute before continuing (thread-sleep! 60) ;; num-retries code was here ;; we use this opportunity to move contents of reg to tal (list (car newtal)(append (cdr newtal) reg) '() reruns)) ;; an issue with prereqs not yet met? (begin - (debug:print-info 1 "no fails in prerequisites for " hed " but nothing seen running in a while, dropping test " hed " from the run queue") + (debug:print-info 1 *default-log-port* "no fails in prerequisites for " hed " but nothing seen running in a while, dropping test " hed " from the run queue") (let ((test-id (rmt:get-test-id run-id hed ""))) (if test-id (mt:test-set-state-status-by-id run-id test-id "NOT_STARTED" "TIMED_OUT" "Nothing seen running in a while."))) (list (runs:queue-next-hed tal reg reglen regfull) (runs:queue-next-tal tal reg reglen regfull) (runs:queue-next-reg tal reg reglen regfull) @@ -596,11 +607,11 @@ ((and (or (not (null? fails)) (not (null? prereq-fails))) (member 'normal testmode)) - (debug:print-info 1 "test " hed " (mode=" testmode ") has failed prerequisite(s); " + (debug:print-info 1 *default-log-port* "test " hed " (mode=" testmode ") has failed prerequisite(s); " (string-intersperse (map (lambda (t)(conc (db:test-get-testname t) ":" (db:test-get-state t)"/"(db:test-get-status t))) fails) ", ") ", removing it from to-do list") (let ((test-id (rmt:get-test-id run-id hed ""))) (if test-id (if (not (null? prereq-fails)) @@ -619,11 +630,11 @@ (if (or (not (null? reg))(not (null? tal))) (list (car newtal)(append (cdr newtal) reg) '() reruns) #f)) ((null? runnables) #f) ;; if we get here and non-completed is null the it's all over. (else - (debug:print 0 "WARNING: FAILS or incomplete tests maybe preventing completion of this run. Watch for issues with test " hed ", continuing for now") + (debug:print 0 *default-log-port* "WARNING: FAILS or incomplete tests maybe preventing completion of this run. Watch for issues with test " hed ", continuing for now") ;; (list (runs:queue-next-hed tal reg reglen regfull) ;; (runs:queue-next-tal tal reg reglen regfull) ;; (runs:queue-next-reg tal reg reglen regfull) ;; reruns) (list (car newtal)(cdr newtal) reg reruns))))) @@ -652,20 +663,24 @@ (num-running-in-jobgroup (list-ref run-limits-info 2)) (max-concurrent-jobs (list-ref run-limits-info 3)) (job-group-limit (list-ref run-limits-info 4)) (prereqs-not-met (rmt:get-prereqs-not-met run-id waitons hed item-path mode: testmode itemmaps: itemmaps)) ;; (prereqs-not-met (mt:lazy-get-prereqs-not-met run-id waitons item-path mode: testmode itemmap: itemmap)) - (fails (runs:calc-fails prereqs-not-met)) + (fails (if (list? prereqs-not-met) + (runs:calc-fails prereqs-not-met) + (begin + (debug:print 0 *default-log-port* "ERROR: prereqs-not-met is not a list! " prereqs-not-met) + '()))) (non-completed (filter (lambda (x) ;; remove hed from not completed list, duh, of course it is not completed! (not (equal? x hed))) (runs:calc-not-completed prereqs-not-met))) (loop-list (list hed tal reg reruns)) ;; configure the load runner (numcpus (common:get-num-cpus)) (maxload (string->number (or (configf:lookup *configdat* "jobtools" "maxload") "3"))) (waitdelay (string->number (or (configf:lookup *configdat* "jobtools" "waitdelay") "60")))) - (debug:print-info 4 "have-resources: " have-resources " prereqs-not-met: (" + (debug:print-info 4 *default-log-port* "have-resources: " have-resources " prereqs-not-met: (" (string-intersperse (map (lambda (t) (if (vector? t) (conc (db:test-get-state t) "/" (db:test-get-status t)) (conc " WARNING: t is not a vector=" t ))) @@ -675,24 +690,24 @@ (if (and (not (null? prereqs-not-met)) (runs:lownoise (conc "waiting on tests " prereqs-not-met hed) 60)) - (debug:print-info 2 "waiting on tests; " (string-intersperse (runs:mixed-list-testname-and-testrec->list-of-strings prereqs-not-met) ", "))) + (debug:print-info 2 *default-log-port* "waiting on tests; " (string-intersperse (runs:mixed-list-testname-and-testrec->list-of-strings prereqs-not-met) ", "))) ;; Don't know at this time if the test have been launched at some time in the past ;; i.e. is this a re-launch? - (debug:print-info 4 "run-limits-info = " run-limits-info) + (debug:print-info 4 *default-log-port* "run-limits-info = " run-limits-info) (cond ;; Check item path against item-patts, ;; ((not (tests:match test-patts (tests:testqueue-get-testname test-record) item-path required: required-tests)) ;; This test/itempath is not to be run ;; else the run is stuck, temporarily or permanently ;; but should check if it is due to lack of resources vs. prerequisites - (debug:print-info 1 "Skipping " (tests:testqueue-get-testname test-record) " " item-path " as it doesn't match " test-patts) + (debug:print-info 1 *default-log-port* "Skipping " (tests:testqueue-get-testname test-record) " " item-path " as it doesn't match " test-patts) (if (or (not (null? tal))(not (null? reg))) (list (runs:queue-next-hed tal reg reglen regfull) (runs:queue-next-tal tal reg reglen regfull) (runs:queue-next-reg tal reg reglen regfull) reruns) @@ -699,21 +714,21 @@ #f)) ;; Register tests ;; ((not (hash-table-ref/default test-registry (db:test-make-full-name test-name item-path) #f)) - (debug:print-info 4 "Pre-registering test " test-name "/" item-path " to create placeholder" ) + (debug:print-info 4 *default-log-port* "Pre-registering test " test-name "/" item-path " to create placeholder" ) ;; always do firm registration now in v1.60 and greater ;; (eq? *transport-type* 'fs) ;; no point in parallel registration if use fs (let register-loop ((numtries 15)) (rmt:register-test run-id test-name item-path) (if (rmt:get-test-id run-id test-name item-path) (hash-table-set! test-registry (db:test-make-full-name test-name item-path) 'done) (if (> numtries 0) (begin (thread-sleep! 0.5) (register-loop (- numtries 1))) - (debug:print 0 "ERROR: failed to register test " (db:test-make-full-name test-name item-path))))) + (debug:print 0 *default-log-port* "ERROR: failed to register test " (db:test-make-full-name test-name item-path))))) (if (not (eq? (hash-table-ref/default test-registry (db:test-make-full-name test-name "") #f) 'done)) (begin (rmt:register-test run-id test-name "") (if (rmt:get-test-id run-id test-name "") (hash-table-set! test-registry (db:test-make-full-name test-name "") 'done)))) @@ -731,11 +746,11 @@ ;; At this point hed test registration must be completed. ;; ((eq? (hash-table-ref/default test-registry (db:test-make-full-name test-name item-path) #f) 'start) - (debug:print-info 0 "Waiting on test registration(s): " + (debug:print-info 0 *default-log-port* "Waiting on test registration(s): " (string-intersperse (filter (lambda (x) (eq? (hash-table-ref/default test-registry x #f) 'start)) (hash-table-keys test-registry)) ", ")) @@ -744,11 +759,11 @@ ;; If no resources are available just kill time and loop again ;; ((not have-resources) ;; simply try again after waiting a second (if (runs:lownoise "no resources" 60) - (debug:print-info 1 "no resources to run new tests, waiting ...")) + (debug:print-info 1 *default-log-port* "no resources to run new tests, waiting ...")) ;; Have gone back and forth on this but db starvation is an issue. ;; wait one second before looking again to run jobs. (thread-sleep! 1) ;; could have done hed tal here but doing car/cdr of newtal to rotate tests (list (car newtal)(cdr newtal) reg reruns)) @@ -766,10 +781,11 @@ ;; well, first lets see if cpu load throttling is enabled. If so wait around until the ;; average cpu load is under the threshold before continuing (if (configf:lookup *configdat* "jobtools" "maxload") ;; only gate if maxload is specified (common:wait-for-cpuload maxload numcpus waitdelay)) (run:test run-id run-info keyvals runname test-record flags #f test-registry all-tests-registry) + (runs:incremental-print-results run-id) (hash-table-set! test-registry (db:test-make-full-name test-name item-path) 'running) (runs:shrink-can-run-more-tests-count) ;; DELAY TWEAKER (still needed?) ;; (thread-sleep! *global-delta*) (if (or (not (null? tal))(not (null? reg))) (list (runs:queue-next-hed tal reg reglen regfull) @@ -779,32 +795,32 @@ #f)) ;; must be we have unmet prerequisites ;; (else - (debug:print 4 "FAILS: " fails) + (debug:print 4 *default-log-port* "FAILS: " fails) ;; If one or more of the prereqs-not-met are FAIL then we can issue ;; a message and drop hed from the items to be processed. ;; (runs:mixed-list-testname-and-testrec->list-of-strings prereqs-not-met) (if (and (not (null? prereqs-not-met)) (runs:lownoise (conc "waiting on tests " prereqs-not-met hed) 60)) - (debug:print-info 1 "waiting on tests; " (string-intersperse + (debug:print-info 1 *default-log-port* "waiting on tests; " (string-intersperse (runs:mixed-list-testname-and-testrec->list-of-strings prereqs-not-met) ", "))) (if (or (null? fails) (member 'toplevel testmode)) (begin ;; couldn't run, take a breather (if (runs:lownoise "Waiting for more work to do..." 60) - (debug:print-info 0 "Waiting for more work to do...")) + (debug:print-info 0 *default-log-port* "Waiting for more work to do...")) (thread-sleep! 1) (list (car newtal)(cdr newtal) reg reruns)) ;; the waiton is FAIL so no point in trying to run hed ever again (if (or (not (null? reg))(not (null? tal))) (if (vector? hed) (begin - (debug:print 1 "WARNING: Dropping test " test-name "/" item-path + (debug:print 1 *default-log-port* "WARNING: Dropping test " test-name "/" item-path " from the launch list as it has prerequistes that are FAIL") (let ((test-id (rmt:get-test-id run-id hed ""))) (if test-id (mt:test-set-state-status-by-id run-id test-id "NOT_STARTED" "PREQ_FAIL" "Failed to run due to failed prerequisites"))) (runs:shrink-can-run-more-tests-count) ;; DELAY TWEAKER (still needed?) ;; (thread-sleep! *global-delta*) @@ -818,11 +834,11 @@ )) (let ((nth-try (hash-table-ref/default test-registry hed 0))) (cond ((member "RUNNING" (map db:test-get-state prereqs-not-met)) (if (runs:lownoise (conc "possible RUNNING prerequistes " hed) 60) - (debug:print 0 "WARNING: test " hed " has possible RUNNING prerequisites, don't give up on it yet.")) + (debug:print 0 *default-log-port* "WARNING: test " hed " has possible RUNNING prerequisites, don't give up on it yet.")) (thread-sleep! 4) (list (runs:queue-next-hed newtal reg reglen regfull) (runs:queue-next-tal newtal reg reglen regfull) (runs:queue-next-reg newtal reg reglen regfull) reruns)) @@ -831,11 +847,11 @@ (< nth-try 10))) (hash-table-set! test-registry hed (if (number? nth-try) (+ nth-try 1) 0)) (if (runs:lownoise (conc "not removing test " hed) 60) - (debug:print 1 "WARNING: not removing test " hed " from queue although it may not be runnable due to FAILED prerequisites")) + (debug:print 1 *default-log-port* "WARNING: not removing test " hed " from queue although it may not be runnable due to FAILED prerequisites")) ;; may not have processed correctly. Could be a race condition in your test implementation? Dropping test " hed) ;; " as it has prerequistes that are FAIL. (NOTE: hed is not a vector)") (runs:shrink-can-run-more-tests-count) ;; DELAY TWEAKER (still needed?) ;; (list hed tal reg reruns) ;; (list (car newtal)(cdr newtal) reg reruns) ;; (hash-table-set! test-registry hed 'removed) @@ -848,21 +864,21 @@ (if (null? tal) #f ;; yes, really (list (car tal)(cdr tal) reg reruns)) (begin (if (runs:lownoise (conc "FAILED prerequisites or other issue" hed) 60) - (debug:print 0 "WARNING: test " hed " has FAILED prerequisites or other issue. Internal state " nth-try " will be overridden and we'll retry.")) + (debug:print 0 *default-log-port* "WARNING: test " hed " has FAILED prerequisites or other issue. Internal state " nth-try " will be overridden and we'll retry.")) (mt:test-set-state-status-by-testname run-id test-name item-path "NOT_STARTED" "KEEP_TRYING" #f) (hash-table-set! test-registry hed 0) (list (runs:queue-next-hed newtal reg reglen regfull) (runs:queue-next-tal newtal reg reglen regfull) (runs:queue-next-reg newtal reg reglen regfull) reruns)))) (else (if (runs:lownoise (conc "FAILED prerequitests and we tried" hed) 60) - (debug:print 0 "WARNING: test " hed " has FAILED prerequitests and we've tried at least 10 times to run it. Giving up now.")) - ;; (debug:print 0 " prereqs: " prereqs-not-met) + (debug:print 0 *default-log-port* "WARNING: test " hed " has FAILED prerequitests and we've tried at least 10 times to run it. Giving up now.")) + ;; (debug:print 0 *default-log-port* " prereqs: " prereqs-not-met) (hash-table-set! test-registry hed 'removed) (mt:test-set-state-status-by-testname run-id test-name item-path "NOT_STARTED" "TEN_STRIKES" #f) ;; I'm unclear on if this roll up is needed - it may be the root cause of the "all set to FAIL" bug. (rmt:roll-up-pass-fail-counts run-id test-name item-path #f "FAIL") ;; treat as FAIL (list (if (null? tal)(car newtal)(car tal)) @@ -893,20 +909,75 @@ t)) ((DELETED) #f) (else t))))) tests)) +;; move all the miscellanea into this struct +;; +(defstruct runs:gendat inc-results inc-results-last-update inc-results-fmt) + +(define *runs:general-data* + (make-runs:gendat + inc-results: (make-hash-table) + inc-results-last-update: 0 + inc-results-fmt: "~12a~12a~20a~12a~20a~25a\n" ;; state status time duration test-name item-path + ) +) + +(define (runs:incremental-print-results run-id) + (let ((curr-sec (current-seconds))) + (if (> (- curr-sec (runs:gendat-inc-results-last-update *runs:general-data*)) 5) ;; at least five seconds since last update + (let ((testsdat (rmt:get-tests-for-run run-id "%" '() '() + #f #f + #f ;; hide/not-hide + #f ;; sort-by + #f ;; sort-order + #f ;; get full data (not 'shortlist) + (runs:gendat-inc-results-last-update *runs:general-data*) ;; last update time + 'dashboard))) + (for-each + (lambda (testdat) + (let* ((test-id (db:test-get-id testdat)) + (prevdat (hash-table-ref/default (runs:gendat-inc-results *runs:general-data*) + (conc run-id "," test-id) #f)) + (test-name (db:test-get-testname testdat)) + (item-path (db:test-get-item-path testdat)) + (state (db:test-get-state testdat)) + (status (db:test-get-status testdat)) + (event-time (db:test-get-event_time testdat)) + (duration (db:test-get-run_duration testdat))) + (if (and (not (member state '("DELETED" "REMOTEHOSTSTART" "RUNNING" "LAUNCHED""NOT_STARTED"))) + (not (and prevdat + (equal? state (db:test-get-state prevdat)) + (equal? status (db:test-get-status prevdat))))) + (let ((fmt (runs:gendat-inc-results-fmt *runs:general-data*)) + (dtime (seconds->year-work-week/day-time event-time))) + (if (runs:lownoise "inc-print" 120) + (format #t fmt "State" "Status" "Start Time" "Duration" "Test name" "Item path")) + (debug:print 0 *default-log-port* "fmt: " fmt " state: " state " status: " status " test-name: " test-name " item-path: " item-path " dtime: " dtime) + ;; (debug:print 0 #f "event-time: " event-time " duration: " duration) + (format #t fmt + state + status + dtime + (seconds->hr-min-sec duration) + test-name + item-path) + (hash-table-set! (runs:gendat-inc-results *runs:general-data*) (conc run-id "," test-id) testdat))))) + testsdat))) + (runs:gendat-inc-results-last-update-set! *runs:general-data* (- curr-sec 10)))) + ;; every time though the loop increment the test/itempatt val. ;; when the min is > max-allowed and none running then force exit ;; (define *max-tries-hash* (make-hash-table)) ;; test-records is a hash table testname:item_path => vector < testname testconfig waitons priority items-info ... > (define (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests reglen-in all-tests-registry) ;; At this point the list of parent tests is expanded ;; NB// Should expand items here and then insert into the run queue. - (debug:print 5 "test-records: " test-records ", flags: " (hash-table->alist flags)) + (debug:print 5 *default-log-port* "test-records: " test-records ", flags: " (hash-table->alist flags)) ;; Do mark-and-find clean up of db before starting runing of quue ;; ;; (rmt:find-and-mark-incomplete) @@ -941,11 +1012,13 @@ (let loop ((hed (car sorted-test-names)) (tal (cdr sorted-test-names)) (reg '()) ;; registered, put these at the head of tal (reruns '())) - (if (not (null? reruns))(debug:print-info 4 "reruns=" reruns)) + (runs:incremental-print-results run-id) + + (if (not (null? reruns))(debug:print-info 4 *default-log-port* "reruns=" reruns)) ;; Here we mark any old defunct tests as incomplete. Do this every fifteen minutes ;; moving this to a parallel thread and just run it once. ;; (if (> (current-seconds)(+ last-time-incomplete 900)) @@ -980,11 +1053,11 @@ (if (> num-running 0) (set! last-time-some-running (current-seconds))) (if (> (current-seconds)(+ last-time-some-running (or (configf:lookup *configdat* "setup" "give-up-waiting") 36000))) (hash-table-set! *max-tries-hash* tfullname (+ (hash-table-ref/default *max-tries-hash* tfullname 0) 1))) - ;; (debug:print 0 "max-tries-hash: " (hash-table->alist *max-tries-hash*)) + ;; (debug:print 0 *default-log-port* "max-tries-hash: " (hash-table->alist *max-tries-hash*)) ;; Ensure all top level tests get registered. This way they show up as "NOT_STARTED" on the dashboard ;; and it is clear they *should* have run but did not. (if (not (hash-table-ref/default test-registry (db:test-make-full-name test-name "") #f)) (begin @@ -995,19 +1068,20 @@ ;; (if (member (hash-table-ref/default test-registry tfullname #f) '(DONOTRUN removed)) ;; *common:cant-run-states-sym*) ;; '(COMPLETED KILLED WAIVED UNKNOWN INCOMPLETE)) (begin (if (runs:lownoise (conc "been marked do not run " tfullname) 60) - (debug:print-info 0 "Skipping test " tfullname " as it has been marked do not run due to being completed or not runnable")) + (debug:print-info 0 *default-log-port* "Skipping test " tfullname " as it has been marked do not run due to being completed or not runnable")) (if (or (not (null? tal))(not (null? reg))) (loop (runs:queue-next-hed tal reg reglen regfull) (runs:queue-next-tal tal reg reglen regfull) (runs:queue-next-reg tal reg reglen regfull) reruns)))) ;; (loop (car tal)(cdr tal) reg reruns)))) - (debug:print 4 "TOP OF LOOP => " + (runs:incremental-print-results run-id) + (debug:print 4 *default-log-port* "TOP OF LOOP => " "test-name: " test-name "\n test-record " test-record "\n hed: " hed "\n itemdat: " itemdat "\n items: " items @@ -1018,16 +1092,27 @@ "\n reruns: " reruns "\n regfull: " regfull "\n reglen: " reglen "\n length reg: " (length reg) "\n reg: " reg) + + ;; lets use the debugger eh? +;; (debugger-start start: 7) +;; (debugger-trace-var "runs:run-tests-queue" "") +;; (debugger-trace-var "hed" hed) +;; (debugger-trace-var "tal" tal) +;; (debugger-trace-var "items" items) +;; (debugger-trace-var "item-path" item-path) +;; (debugger-trace-var "waitons" waitons) +;; (debugger-pauser) + ;; check for hed in waitons => this would be circular, remove it and issue an ;; error (if (member test-name waitons) (begin - (debug:print 0 "ERROR: test " test-name " has listed itself as a waiton, please correct this!") + (debug:print 0 *default-log-port* "ERROR: test " test-name " has listed itself as a waiton, please correct this!") (set! waiton (filter (lambda (x)(not (equal? x hed))) waitons)))) (cond ;; We want to catch tests that have waitons that are NOT in the queue and discard them IFF @@ -1041,17 +1126,17 @@ (if (and (not (member waiton tal)) ;; this waiton is not in the list to be tried to run (not (member waiton reruns))) 1 #f)) waitons))))) ;; could do this more elegantly with a marker.... - (debug:print 0 "WARNING: Marking test " tfullname " as not runnable. It is waiting on tests that cannot be run. Giving up now.") + (debug:print 0 *default-log-port* "WARNING: Marking test " tfullname " as not runnable. It is waiting on tests that cannot be run. Giving up now.") (hash-table-set! test-registry tfullname 'removed)) ;; items is #f then the test is ok to be handed off to launch (but not before) ;; ((not items) - (debug:print-info 4 "OUTER COND: (not items)") + (debug:print-info 4 *default-log-port* "OUTER COND: (not items)") (if (and (not (tests:match test-patts (tests:testqueue-get-testname test-record) item-path required: required-tests)) (not (null? tal))) (loop (car tal)(cdr tal) reg reruns)) (let ((loop-list (runs:process-expanded-tests hed tal reg reruns reglen regfull test-record runname test-name item-path jobgroup max-concurrent-jobs run-id waitons item-path testmode test-patts required-tests test-registry registry-mutex flags keyvals run-info newtal all-tests-registry itemmaps))) (if loop-list (apply loop loop-list)))) @@ -1058,18 +1143,18 @@ ;; items processed into a list but not came in as a list been processed ;; ((and (list? items) ;; thus we know our items are already calculated (not itemdat)) ;; and not yet expanded into the list of things to be done - (debug:print-info 4 "OUTER COND: (and (list? items)(not itemdat))") + (debug:print-info 4 *default-log-port* "OUTER COND: (and (list? items)(not itemdat))") ;; Must determine if the items list is valid. Discard the test if it is not. (if (and (list? items) (> (length items) 0) (and (list? (car items)) (> (length (car items)) 0)) (debug:debug-mode 1)) - (debug:print 2 (map (lambda (row) + (debug:print 2 *default-log-port* (map (lambda (row) (conc (string-intersperse (map (lambda (varval) (string-intersperse varval "=")) row) " ") @@ -1088,11 +1173,11 @@ (tests:testqueue-set-item_path! new-test-record my-item-path) (hash-table-set! test-records newtestname new-test-record) (set! tal (append tal (list newtestname))))))) ;; since these are itemized create new test names testname/itempath items) - ;; (debug:print-info 0 "Test " (tests:testqueue-get-testname test-record) " is itemized but has no items") + ;; (debug:print-info 0 *default-log-port* "Test " (tests:testqueue-get-testname test-record) " is itemized but has no items") ;; At this point we have possibly added items to tal but all must be handed off to ;; INNER COND logic. I think loop without rotating the queue ;; (loop hed tal reg reruns)) ;; (let ((newtal (append tal (list hed)))) ;; We should discard hed as it has been expanded into it's items? Yes, but only if this *is* an itemized test @@ -1114,56 +1199,56 @@ ;; if can't run more just loop with next possible test (loop (car newtal)(cdr newtal) reg reruns)))) ;; this case should not happen, added to help catch any bugs ((and (list? items) itemdat) - (debug:print 0 "ERROR: Should not have a list of items in a test and the itemspath set - please report this") + (debug:print 0 *default-log-port* "ERROR: Should not have a list of items in a test and the itemspath set - please report this") (exit 1)) ((not (null? reruns)) (let* ((newlst (tests:filter-non-runnable run-id tal test-records)) ;; i.e. not FAIL, WAIVED, INCOMPLETE, PASS, KILLED, (junked (lset-difference equal? tal newlst))) - (debug:print-info 4 "full drop through, if reruns is less than 100 we will force retry them, reruns=" reruns ", tal=" tal) + (debug:print-info 4 *default-log-port* "full drop through, if reruns is less than 100 we will force retry them, reruns=" reruns ", tal=" tal) (if (< num-retries max-retries) (set! newlst (append reruns newlst))) (set! num-retries (+ num-retries 1)) ;; (thread-sleep! (+ 1 *global-delta*)) (if (not (null? newlst)) ;; since reruns have been tacked on to newlst create new reruns from junked (loop (car newlst)(cdr newlst) reg (delete-duplicates junked))))) ((not (null? tal)) - (debug:print-info 4 "I'm pretty sure I shouldn't get here.")) + (debug:print-info 4 *default-log-port* "I'm pretty sure I shouldn't get here.")) ((not (null? reg)) ;; could we get here with leftovers? - (debug:print-info 0 "Have leftovers!") + (debug:print-info 0 *default-log-port* "Have leftovers!") (loop (car reg)(cdr reg) '() reruns)) (else - (debug:print-info 4 "Exiting loop with...\n hed=" hed "\n tal=" tal "\n reruns=" reruns)) + (debug:print-info 4 *default-log-port* "Exiting loop with...\n hed=" hed "\n tal=" tal "\n reruns=" reruns)) ))) ;; now *if* -run-wait we wait for all tests to be done ;; Now wait for any RUNNING tests to complete (if in run-wait mode) (thread-sleep! 5) ;; I think there is a race condition here. Let states/statuses settle (let wait-loop ((num-running (rmt:get-count-tests-running-for-run-id run-id)) (prev-num-running 0)) - ;; (debug:print 0 "num-running=" num-running ", prev-num-running=" prev-num-running) + ;; (debug:print 0 *default-log-port* "num-running=" num-running ", prev-num-running=" prev-num-running) (if (and (or (args:get-arg "-run-wait") (equal? (configf:lookup *configdat* "setup" "run-wait") "yes")) (> num-running 0)) (begin ;; Here we mark any old defunct tests as incomplete. Do this every fifteen minutes - ;; (debug:print 0 "Got here eh! num-running=" num-running " (> num-running 0) " (> num-running 0)) + ;; (debug:print 0 *default-log-port* "Got here eh! num-running=" num-running " (> num-running 0) " (> num-running 0)) (if (> (current-seconds)(+ last-time-incomplete 900)) (begin - (debug:print-info 0 "Marking stuck tests as INCOMPLETE while waiting for run " run-id ". Running as pid " (current-process-id) " on " (get-host-name)) + (debug:print-info 0 *default-log-port* "Marking stuck tests as INCOMPLETE while waiting for run " run-id ". Running as pid " (current-process-id) " on " (get-host-name)) (set! last-time-incomplete (current-seconds)) (rmt:find-and-mark-incomplete run-id #f))) (if (not (eq? num-running prev-num-running)) - (debug:print-info 0 "run-wait specified, waiting on " num-running " tests in RUNNING, REMOTEHOSTSTART or LAUNCHED state at " (time->string (seconds->local-time (current-seconds))))) + (debug:print-info 0 *default-log-port* "run-wait specified, waiting on " num-running " tests in RUNNING, REMOTEHOSTSTART or LAUNCHED state at " (time->string (seconds->local-time (current-seconds))))) (thread-sleep! 5) ;; (wait-loop (rmt:get-count-tests-running-for-run-id run-id) num-running)))) (wait-loop (rmt:get-count-tests-running-for-run-id run-id) num-running)))) ;; LET* ((test-record ;; we get here on "drop through". All done! - (debug:print-info 1 "All tests launched"))) + (debug:print-info 1 *default-log-port* "All tests launched"))) (define (runs:calc-fails prereqs-not-met) (filter (lambda (test) (and (vector? test) ;; not (string? test)) (member (db:test-get-state test) '("INCOMPLETE" "COMPLETED")) @@ -1227,16 +1312,16 @@ ;; setting itemdat to a list if it is #f (if (not itemdat)(set! itemdat '())) (set! item-path (item-list->path itemdat)) (set! full-test-name (db:test-make-full-name test-name item-path)) - (debug:print-info 4 + (debug:print-info 4 *default-log-port* "\nTESTNAME: " full-test-name "\n test-config: " (hash-table->alist test-conf) "\n itemdat: " itemdat ) - (debug:print 2 "Attempting to launch test " full-test-name) + (debug:print 2 *default-log-port* "Attempting to launch test " full-test-name) ;; (setenv "MT_TEST_NAME" test-name) ;; ;; (setenv "MT_ITEMPATH" item-path) ;; (setenv "MT_RUNNAME" runname) (runs:set-megatest-env-vars run-id inrunname: runname testname: test-name itempath: item-path) ;; these may be needed by the launching process (change-directory *toppath*) @@ -1268,35 +1353,35 @@ ;; NB// for the above line. I want the test to be registered long before this routine gets called! ;; (if (not test-id)(set! test-id (rmt:get-test-id run-id test-name item-path))) (if (not test-id) (begin - (debug:print 2 "WARN: Test not pre-created? test-name=" test-name ", item-path=" item-path ", run-id=" run-id) + (debug:print 2 *default-log-port* "WARN: Test not pre-created? test-name=" test-name ", item-path=" item-path ", run-id=" run-id) (rmt:register-test run-id test-name item-path) (set! test-id (rmt:get-test-id run-id test-name item-path)))) - (debug:print-info 4 "test-id=" test-id ", run-id=" run-id ", test-name=" test-name ", item-path=\"" item-path "\"") + (debug:print-info 4 *default-log-port* "test-id=" test-id ", run-id=" run-id ", test-name=" test-name ", item-path=\"" item-path "\"") (set! testdat (rmt:get-test-info-by-id run-id test-id)) (if (not testdat) (begin - (debug:print-info 0 "WARNING: server is overloaded, trying again in one second") + (debug:print-info 0 *default-log-port* "WARNING: server is overloaded, trying again in one second") (thread-sleep! 1) (loop))))) (if (not testdat) ;; should NOT happen - (debug:print 0 "ERROR: failed to get test record for test-id " test-id)) + (debug:print 0 *default-log-port* "ERROR: failed to get test record for test-id " test-id)) (set! test-id (db:test-get-id testdat)) (if (file-exists? test-path) (change-directory test-path) (begin - (debug:print "ERROR: test run path not created before attempting to run the test. Perhaps you are running -remove-runs at the same time?") + (debug:print 0 *default-log-port* "ERROR: test run path not created before attempting to run the test. Perhaps you are running -remove-runs at the same time?") (change-directory *toppath*))) (case (if force ;; (args:get-arg "-force") 'NOT_STARTED (if testdat (string->symbol (test:get-state testdat)) 'failed-to-insert)) ((failed-to-insert) - (debug:print 0 "ERROR: Failed to insert the record into the db")) + (debug:print 0 *default-log-port* "ERROR: Failed to insert the record into the db")) ((NOT_STARTED COMPLETED DELETED INCOMPLETE) (let ((runflag #f)) (cond ;; -force, run no matter what (force (set! runflag #t)) @@ -1306,34 +1391,34 @@ ((and (or (not rerun) keepgoing) ;; Require to force re-run for COMPLETED or *anything* + PASS,WARN or CHECK (or (member (test:get-status testdat) '("PASS" "WARN" "CHECK" "SKIP" "WAIVED")) (member (test:get-state testdat) '("COMPLETED")))) - (debug:print-info 2 "running test " test-name "/" item-path " suppressed as it is " (test:get-state testdat) " and " (test:get-status testdat)) + (debug:print-info 2 *default-log-port* "running test " test-name "/" item-path " suppressed as it is " (test:get-state testdat) " and " (test:get-status testdat)) (hash-table-set! test-registry full-test-name 'DONOTRUN) ;; COMPLETED) (set! runflag #f)) ;; -rerun and status is one of the specifed, run it ((and rerun (let* ((rerunlst (string-split rerun ",")) (must-rerun (member (test:get-status testdat) rerunlst))) - (debug:print-info 3 "-rerun list: " rerun ", test-status: " (test:get-status testdat)", must-rerun: " must-rerun) + (debug:print-info 3 *default-log-port* "-rerun list: " rerun ", test-status: " (test:get-status testdat)", must-rerun: " must-rerun) must-rerun)) - (debug:print-info 2 "Rerun forced for test " test-name "/" item-path) + (debug:print-info 2 *default-log-port* "Rerun forced for test " test-name "/" item-path) (set! runflag #t)) ;; -keepgoing, do not rerun FAIL ((and keepgoing (member (test:get-status testdat) '("FAIL"))) (set! runflag #f)) ((and (not rerun) (member (test:get-status testdat) '("FAIL" "n/a"))) (set! runflag #t)) (else (set! runflag #f))) - (debug:print 4 "RUNNING => runflag: " runflag " STATE: " (test:get-state testdat) " STATUS: " (test:get-status testdat)) + (debug:print 4 *default-log-port* "RUNNING => runflag: " runflag " STATE: " (test:get-state testdat) " STATUS: " (test:get-status testdat)) (if (not runflag) (if (not parent-test) (if (runs:lownoise (conc "not starting test" full-test-name) 60) - (debug:print 1 "NOTE: Not starting test " full-test-name " as it is state \"" (test:get-state testdat) + (debug:print 1 *default-log-port* "NOTE: Not starting test " full-test-name " as it is state \"" (test:get-state testdat) "\" and status \"" (test:get-status testdat) "\", use -rerun \"" (test:get-status testdat) "\" or -force to override"))) ;; NOTE: No longer be checking prerequisites here! Will never get here unless prereqs are ;; already met. ;; This would be a great place to do the process-fork @@ -1367,32 +1452,32 @@ (set! skip-test (conc "Skipping due to previous test run less than " (configf:lookup test-conf "skip" "rundelay") " ago")))))) (if skip-test (begin (mt:test-set-state-status-by-id run-id test-id "COMPLETED" "SKIP" skip-test) - (debug:print-info 1 "SKIPPING Test " full-test-name " due to " skip-test)) + (debug:print-info 1 *default-log-port* "SKIPPING Test " full-test-name " due to " skip-test)) (if (not (launch-test test-id run-id run-info keyvals runname test-conf test-name test-path itemdat flags)) (begin (print "ERROR: Failed to launch the test. Exiting as soon as possible") (set! *globalexitstatus* 1) ;; (process-signal (current-process-id) signal/kill)))))))) ((KILLED) - (debug:print 1 "NOTE: " full-test-name " is already running or was explictly killed, use -force to launch it.") + (debug:print 1 *default-log-port* "NOTE: " full-test-name " is already running or was explictly killed, use -force to launch it.") (hash-table-set! test-registry (db:test-make-full-name test-name test-path) 'DONOTRUN)) ;; KILLED)) ((LAUNCHED REMOTEHOSTSTART RUNNING) - (debug:print 2 "NOTE: " test-name " is already running")) + (debug:print 2 *default-log-port* "NOTE: " test-name " is already running")) ;; (if (> (- (current-seconds)(+ (db:test-get-event_time testdat) ;; (db:test-get-run_duration testdat))) ;; (or incomplete-timeout ;; 6000)) ;; i.e. no update for more than 6000 seconds ;; (begin - ;; (debug:print 0 "WARNING: Test " test-name " appears to be dead. Forcing it to state INCOMPLETE and status STUCK/DEAD") + ;; (debug:print 0 *default-log-port* "WARNING: Test " test-name " appears to be dead. Forcing it to state INCOMPLETE and status STUCK/DEAD") ;; (tests:test-set-status! run-id test-id "INCOMPLETE" "STUCK/DEAD" "" #f)) ;; ;; (tests:test-set-status! test-id "INCOMPLETE" "STUCK/DEAD" "" #f)) - ;; (debug:print 2 "NOTE: " test-name " is already running"))) + ;; (debug:print 2 *default-log-port* "NOTE: " test-name " is already running"))) (else - (debug:print 0 "ERROR: Failed to launch test " full-test-name ". Unrecognised state " (test:get-state testdat)) + (debug:print 0 *default-log-port* "ERROR: Failed to launch test " full-test-name ". Unrecognised state " (test:get-state testdat)) (case (string->symbol (test:get-state testdat)) ((COMPLETED INCOMPLETE) (hash-table-set! test-registry (db:test-make-full-name test-name test-path) 'DONOTRUN)) (else (hash-table-set! test-registry (db:test-make-full-name test-name test-path) 'DONOTRUN)))))))) @@ -1412,11 +1497,11 @@ (if (> (system (conc "rm -rf " real-dir)) 0) (begin ;; FAILED, possibly due to permissions, do chmod a+rwx then try one more time (system (conc "chmod -R a+rwx " real-dir)) (if (> (system (conc "rm -rf " real-dir)) 0) - (debug:print 0 "ERROR: There was a problem removing " real-dir " with rm -f"))))) + (debug:print 0 *default-log-port* "ERROR: There was a problem removing " real-dir " with rm -f"))))) (define (runs:safe-delete-test-dir real-dir) ;; first delete all sub-directories (directory-fold (lambda (f x) @@ -1454,14 +1539,14 @@ (states (if state (string-split state ",") '())) (statuses (if status (string-split status ",") '())) (state-status (if (string? new-state-status) (string-split new-state-status ",") '(#f #f))) (rp-mutex (make-mutex)) (bup-mutex (make-mutex))) - (debug:print-info 4 "runs:operate-on => Header: " header " action: " action " new-state-status: " new-state-status) + (debug:print-info 4 *default-log-port* "runs:operate-on => Header: " header " action: " action " new-state-status: " new-state-status) (if (> 2 (length state-status)) (begin - (debug:print 0 "ERROR: the parameter to -set-state-status is a comma delimited string. E.g. COMPLETED,FAIL") + (debug:print 0 *default-log-port* "ERROR: the parameter to -set-state-status is a comma delimited string. E.g. COMPLETED,FAIL") (exit))) (for-each (lambda (run) (let ((runkey (string-intersperse (map (lambda (k) (db:get-value-by-header run header k)) keys) "/")) @@ -1479,42 +1564,42 @@ (tests (if (not (equal? run-state "locked")) (proc-get-tests run-id) '())) (lasttpath "/does/not/exist/I/hope") (worker-thread #f)) - (debug:print-info 4 "runs:operate-on run=" run ", header=" header) + (debug:print-info 4 *default-log-port* "runs:operate-on run=" run ", header=" header) (if (not (null? tests)) (begin (case action ((remove-runs) (if (tasks:need-server run-id)(tasks:start-and-wait-for-server tdbdat run-id 10)) ;; seek and kill in flight -runtests with % as testpatt here ;; (if (equal? testpatt "%") (tasks:kill-runner target run-name testpatt) - ;; (debug:print 0 "not attempting to kill any run launcher processes as testpatt is " testpatt)) - (debug:print 1 "Removing tests for run: " runkey " " (db:get-value-by-header run header "runname"))) + ;; (debug:print 0 *default-log-port* "not attempting to kill any run launcher processes as testpatt is " testpatt)) + (debug:print 1 *default-log-port* "Removing tests for run: " runkey " " (db:get-value-by-header run header "runname"))) ((set-state-status) (if (tasks:need-server run-id)(tasks:start-and-wait-for-server tdbdat run-id 10)) - (debug:print 1 "Modifying state and staus for tests for run: " runkey " " (db:get-value-by-header run header "runname"))) + (debug:print 1 *default-log-port* "Modifying state and staus for tests for run: " runkey " " (db:get-value-by-header run header "runname"))) ((print-run) - (debug:print 1 "Printing info for run " runkey ", run=" run ", tests=" tests ", header=" header) + (debug:print 1 *default-log-port* "Printing info for run " runkey ", run=" run ", tests=" tests ", header=" header) action) ((run-wait) - (debug:print 1 "Waiting for run " runkey ", run=" runnamepatt " to complete")) + (debug:print 1 *default-log-port* "Waiting for run " runkey ", run=" runnamepatt " to complete")) ((archive) - (debug:print 1 "Archiving/restoring (" (args:get-arg "-archive") ") data for run: " runkey " " (db:get-value-by-header run header "runname")) + (debug:print 1 *default-log-port* "Archiving/restoring (" (args:get-arg "-archive") ") data for run: " runkey " " (db:get-value-by-header run header "runname")) (set! worker-thread (make-thread (lambda () (case (string->symbol (args:get-arg "-archive")) ((save save-remove keep-html)(archive:run-bup (args:get-arg "-archive") run-id run-name tests rp-mutex bup-mutex)) ((restore)(archive:bup-restore (args:get-arg "-archive") run-id run-name tests rp-mutex bup-mutex)) (else - (debug:print 0 "ERROR: unrecognised sub command to -archive. Run \"megatest\" to see help") + (debug:print 0 *default-log-port* "ERROR: unrecognised sub command to -archive. Run \"megatest\" to see help") (exit)))) "archive-bup-thread")) (thread-start! worker-thread)) (else - (debug:print-info 0 "action not recognised " action))) + (debug:print-info 0 *default-log-port* "action not recognised " action))) ;; actions that operate on one test at a time can be handled below ;; (let ((sorted-tests (filter vector? @@ -1532,11 +1617,11 @@ (tal (cdr sorted-tests))) (let* ((test-id (db:test-get-id test)) (new-test-dat (rmt:get-test-info-by-id run-id test-id))) (if (not new-test-dat) (begin - (debug:print 0 "ERROR: We have a test-id of " test-id " but no record was found. NOTE: No locking of records is done between processes, do not simultaneously remove the same run from two processes!") + (debug:print 0 *default-log-port* "ERROR: We have a test-id of " test-id " but no record was found. NOTE: No locking of records is done between processes, do not simultaneously remove the same run from two processes!") (if (not (null? tal)) (loop (car tal)(cdr tal)))) (let* ((item-path (db:test-get-item-path new-test-dat)) (test-name (db:test-get-testname new-test-dat)) (run-dir ;;(filedb:get-path *fdb* @@ -1550,19 +1635,19 @@ (case action ((remove-runs) ;; if the test is a toplevel-with-children issue an error and do not remove (if toplevel-with-children (begin - (debug:print 0 "WARNING: skipping removal of " test-fulln " with run-id " run-id " as it has sub tests") + (debug:print 0 *default-log-port* "WARNING: skipping removal of " test-fulln " with run-id " run-id " as it has sub tests") (hash-table-set! toplevel-retries test-fulln (+ (hash-table-ref/default toplevel-retries test-fulln 0) 1)) (if (> (hash-table-ref toplevel-retries test-fulln) 3) (if (not (null? tal)) (loop (car tal)(cdr tal))) ;; no else clause - drop it if no more in queue and > 3 tries (let ((newtal (append tal (list test)))) (loop (car newtal)(cdr newtal))))) ;; loop with test still in queue (begin - (debug:print-info 0 "test: " test-name " itest-state: " test-state) + (debug:print-info 0 *default-log-port* "test: " test-name " itest-state: " test-state) (if (member test-state (list "RUNNING" "LAUNCHED" "REMOTEHOSTSTART" "KILLREQ")) (begin (if (not (hash-table-ref/default test-retry-time test-fulln #f)) (begin ;; want to set to REMOVING BUT CANNOT do it here? @@ -1570,11 +1655,11 @@ (if (> (- (current-seconds)(hash-table-ref test-retry-time test-fulln)) allow-run-time) ;; This test is not in a correct state for cleaning up. Let's try some graceful shutdown steps first ;; Set the test to "KILLREQ" and wait five seconds then try again. Repeat up to five times then give ;; up and blow it away. (begin - (debug:print 0 "WARNING: could not gracefully remove test " test-fulln ", tried to kill it to no avail. Forcing state to FAILEDKILL and continuing") + (debug:print 0 *default-log-port* "WARNING: could not gracefully remove test " test-fulln ", tried to kill it to no avail. Forcing state to FAILEDKILL and continuing") (mt:test-set-state-status-by-id run-id (db:test-get-id test) "FAILEDKILL" "n/a" #f) (thread-sleep! 1)) (begin (mt:test-set-state-status-by-id run-id (db:test-get-id test) "KILLREQ" "n/a" #f) (thread-sleep! 1))) @@ -1586,28 +1671,28 @@ (runs:remove-test-directory new-test-dat mode) ;; 'remove-all) (if (not (null? tal)) (loop (car tal)(cdr tal))))))) (rmt:update-run-stats run-id (rmt:get-raw-run-stats run-id))) ((set-state-status) - (debug:print-info 2 "new state " (car state-status) ", new status " (cadr state-status)) + (debug:print-info 2 *default-log-port* "new state " (car state-status) ", new status " (cadr state-status)) (mt:test-set-state-status-by-id run-id (db:test-get-id test) (car state-status)(cadr state-status) #f) (if (not (null? tal)) (loop (car tal)(cdr tal)))) ((run-wait) - (debug:print-info 2 "still waiting, " (length tests) " tests still running") + (debug:print-info 2 *default-log-port* "still waiting, " (length tests) " tests still running") (thread-sleep! 10) (let ((new-tests (proc-get-tests run-id))) (if (null? new-tests) - (debug:print-info 1 "Run completed according to zero tests matching provided criteria.") + (debug:print-info 1 *default-log-port* "Run completed according to zero tests matching provided criteria.") (loop (car new-tests)(cdr new-tests))))) ((archive) (if (and run-dir (not toplevel-with-children)) (let ((ddir (conc run-dir "/"))) (case (string->symbol (args:get-arg "-archive")) ((save save-remove keep-html) (if (file-exists? ddir) - (debug:print-info 0 "Estimating disk space usage for " test-fulln ": " (common:get-disk-space-used ddir))))))) + (debug:print-info 0 *default-log-port* "Estimating disk space usage for " test-fulln ": " (common:get-disk-space-used ddir))))))) (if (not (null? tal)) (loop (car tal)(cdr tal)))) ))) ) (if worker-thread (thread-join! worker-thread)))))) @@ -1617,18 +1702,18 @@ (if (null? remtests) ;; no more tests remaining (let* ((dparts (string-split lasttpath "/")) (runpath (conc "/" (string-intersperse (take dparts (- (length dparts) 1)) "/")))) - (debug:print 1 "Removing run: " runkey " " (db:get-value-by-header run header "runname") " and related record") + (debug:print 1 *default-log-port* "Removing run: " runkey " " (db:get-value-by-header run header "runname") " and related record") (rmt:delete-run run-id) (rmt:delete-old-deleted-test-records) ;; (rmt:set-var "DELETED_TESTS" (current-seconds)) ;; need to figure out the path to the run dir and remove it if empty ;; (if (null? (glob (conc runpath "/*"))) ;; (begin - ;; (debug:print 1 "Removing run dir " runpath) + ;; (debug:print 1 *default-log-port* "Removing run dir " runpath) ;; (system (conc "rmdir -p " runpath)))) ))))) )) runs) ;; (sqlite3:finalize! (db:delay-if-busy tdbdat)) @@ -1636,46 +1721,47 @@ #t) (define (runs:remove-test-directory test mode) ;; remove-data-only) (let* ((run-dir (db:test-get-rundir test)) ;; run dir is from the link tree (real-dir (if (file-exists? run-dir) - (resolve-pathname run-dir) + ;; (resolve-pathname run-dir) + (common:nice-path run-dir) #f))) (case mode ((remove-data-only)(mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "CLEANING" "LOCKED" #f)) ((remove-all) (mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "REMOVING" "LOCKED" #f)) ((archive-remove) (mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "ARCHIVE_REMOVING" #f #f))) - (debug:print-info 1 "Attempting to remove " (if real-dir (conc " dir " real-dir " and ") "") " link " run-dir) + (debug:print-info 1 *default-log-port* "Attempting to remove " (if real-dir (conc " dir " real-dir " and ") "") " link " run-dir) (if (and real-dir (> (string-length real-dir) 5) (file-exists? real-dir)) ;; bad heuristic but should prevent /tmp /home etc. (begin ;; let* ((realpath (resolve-pathname run-dir))) - (debug:print-info 1 "Recursively removing " real-dir) + (debug:print-info 1 *default-log-port* "Recursively removing " real-dir) (if (file-exists? real-dir) (runs:safe-delete-test-dir real-dir) - (debug:print 0 "WARNING: test dir " real-dir " appears to not exist or is not readable"))) + (debug:print 0 *default-log-port* "WARNING: test dir " real-dir " appears to not exist or is not readable"))) (if real-dir - (debug:print 0 "WARNING: directory " real-dir " does not exist") - (debug:print 0 "WARNING: no real directory corrosponding to link " run-dir ", nothing done"))) + (debug:print 0 *default-log-port* "WARNING: directory " real-dir " does not exist") + (debug:print 0 *default-log-port* "WARNING: no real directory corrosponding to link " run-dir ", nothing done"))) (if (symbolic-link? run-dir) (begin - (debug:print-info 1 "Removing symlink " run-dir) + (debug:print-info 1 *default-log-port* "Removing symlink " run-dir) (handle-exceptions exn - (debug:print 0 "ERROR: Failed to remove symlink " run-dir ((condition-property-accessor 'exn 'message) exn) ", attempting to continue") + (debug:print 0 *default-log-port* "ERROR: Failed to remove symlink " run-dir ((condition-property-accessor 'exn 'message) exn) ", attempting to continue") (delete-file run-dir))) (if (directory? run-dir) (if (> (directory-fold (lambda (f x)(+ 1 x)) 0 run-dir) 0) - (debug:print 0 "WARNING: refusing to remove " run-dir " as it is not empty") + (debug:print 0 *default-log-port* "WARNING: refusing to remove " run-dir " as it is not empty") (handle-exceptions exn - (debug:print 0 "ERROR: Failed to remove directory " run-dir ((condition-property-accessor 'exn 'message) exn) ", attempting to continue") + (debug:print 0 *default-log-port* "ERROR: Failed to remove directory " run-dir ((condition-property-accessor 'exn 'message) exn) ", attempting to continue") (delete-directory run-dir))) (if (and run-dir (not (member run-dir (list "n/a" "/tmp/badname")))) - (debug:print 0 "WARNING: not removing " run-dir " as it either doesn't exist or is not a symlink") - (debug:print 0 "NOTE: the run dir for this test is undefined. Test may have already been deleted.")) + (debug:print 0 *default-log-port* "WARNING: not removing " run-dir " as it either doesn't exist or is not a symlink") + (debug:print 0 *default-log-port* "NOTE: the run dir for this test is undefined. Test may have already been deleted.")) )) ;; Only delete the records *after* removing the directory. If things fail we have a record (case mode ((remove-data-only)(mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "NOT_STARTED" "n/a" #f)) ((archive-remove) (mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "ARCHIVED" #f #f)) @@ -1690,24 +1776,24 @@ (define (general-run-call switchname action-desc proc) (let ((runname (or (args:get-arg "-runname")(args:get-arg ":runname"))) (target (common:args-get-target))) (cond ((not target) - (debug:print 0 "ERROR: Missing required parameter for " switchname ", you must specify the target with -target") + (debug:print 0 *default-log-port* "ERROR: Missing required parameter for " switchname ", you must specify the target with -target") (exit 3)) ((not runname) - (debug:print 0 "ERROR: Missing required parameter for " switchname ", you must specify the run name with -runname runname") + (debug:print 0 *default-log-port* "ERROR: Missing required parameter for " switchname ", you must specify the run name with -runname runname") (exit 3)) (else (let (;; (db #f) (keys #f)) (if (launch:setup) (begin (full-runconfigs-read) ;; cache the run config (launch:cache-config)) ;; do not cache here - need to be sure runconfigs is processed (begin - (debug:print 0 "Failed to setup, exiting") + (debug:print 0 *default-log-port* "Failed to setup, exiting") (exit 1))) (set! keys (keys:config-get-fields *configdat*)) ;; have enough to process -target or -reqtarg here (if (args:get-arg "-reqtarg") (let* ((runconfigf (conc *toppath* "/runconfigs.config")) ;; DO NOT EVALUATE ALL @@ -1714,19 +1800,19 @@ (runconfig (read-config runconfigf #f #t environ-patt: #f))) (if (hash-table-ref/default runconfig (args:get-arg "-reqtarg") #f) (keys:target-set-args keys (args:get-arg "-reqtarg") args:arg-hash) (begin - (debug:print 0 "ERROR: [" (args:get-arg "-reqtarg") "] not found in " runconfigf) + (debug:print 0 *default-log-port* "ERROR: [" (args:get-arg "-reqtarg") "] not found in " runconfigf) ;; (if db (sqlite3:finalize! db)) (exit 1) ))) (if (args:get-arg "-target") (keys:target-set-args keys (args:get-arg "-target" args:arg-hash) args:arg-hash))) (if (not (car *configinfo*)) (begin - (debug:print 0 "ERROR: Attempted to " action-desc " but run area config file not found") + (debug:print 0 *default-log-port* "ERROR: Attempted to " action-desc " but run area config file not found") (exit 1)) ;; Extract out stuff needed in most or many calls ;; here then call proc (let* ((keyvals (keys:target->keyval keys target))) (proc target runname keys keyvals))) @@ -1748,11 +1834,11 @@ (and unlock (begin (print "Do you really wish to unlock run " run-id "?\n y/n: ") (equal? "y" (read-line))))) (rmt:lock/unlock-run run-id lock unlock user) - (debug:print-info 0 "Skipping lock/unlock on " run-id)))) + (debug:print-info 0 *default-log-port* "Skipping lock/unlock on " run-id)))) runs))) ;;====================================================================== ;; Rollup runs ;;====================================================================== @@ -1766,11 +1852,11 @@ (for-each (lambda (key) (let* ((idx (cadr key)) (fld (car key)) (val (config-lookup test-conf "test_meta" fld))) - ;; (debug:print 5 "idx: " idx " fld: " fld " val: " val) + ;; (debug:print 5 *default-log-port* "idx: " idx " fld: " fld " val: " val) (if (and val (not (equal? (vector-ref currrecord idx) val))) (begin (print "Updating " test-name " " fld " to " val) (rmt:testmeta-update-field test-name fld val))))) '(("author" 2)("owner" 3)("description" 4)("reviewed" 5)("tags" 9)("jobgroup" 10))))) @@ -1786,11 +1872,11 @@ ;; This could probably be refactored into one complex query ... ;; NOT PORTED - DO NOT USE YET ;; (define (runs:rollup-run keys runname user keyvals) - (debug:print 4 "runs:rollup-run, keys: " keys " -runname " runname " user: " user) + (debug:print 4 *default-log-port* "runs:rollup-run, keys: " keys " -runname " runname " user: " user) (let* ((db #f) ;; register run operates on the main db (new-run-id (rmt:register-run keyvals runname "new" "n/a" user)) (prev-tests (rmt:get-matching-previous-test-run-records new-run-id "%" "%")) (curr-tests (mt:get-tests-for-run new-run-id "%/%" '() '())) @@ -1822,24 +1908,24 @@ "VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?);") new-run-id (cddr (vector->list testdat))) (set! new-testdat (car (mt:get-tests-for-run new-run-id (conc testname "/" item-path) '() '()))) (hash-table-set! curr-tests-hash full-name new-testdat) ;; this could be confusing, which record should go into the lookup table? ;; Now duplicate the test steps - (debug:print 4 "Copying records in test_steps from test_id=" (db:test-get-id testdat) " to " (db:test-get-id new-testdat)) + (debug:print 4 *default-log-port* "Copying records in test_steps from test_id=" (db:test-get-id testdat) " to " (db:test-get-id new-testdat)) (cdb:remote-run ;; to be replaced, note: this routine is not used currently (lambda () (sqlite3:execute db (conc "INSERT OR REPLACE INTO test_steps (test_id,stepname,state,status,event_time,comment) " "SELECT " (db:test-get-id new-testdat) ",stepname,state,status,event_time,comment FROM test_steps WHERE test_id=?;") (db:test-get-id testdat)) ;; Now duplicate the test data - (debug:print 4 "Copying records in test_data from test_id=" (db:test-get-id testdat) " to " (db:test-get-id new-testdat)) + (debug:print 4 *default-log-port* "Copying records in test_data from test_id=" (db:test-get-id testdat) " to " (db:test-get-id new-testdat)) (sqlite3:execute db (conc "INSERT OR REPLACE INTO test_data (test_id,category,variable,value,expected,tol,units,comment) " "SELECT " (db:test-get-id new-testdat) ",category,variable,value,expected,tol,units,comment FROM test_data WHERE test_id=?;") (db:test-get-id testdat)))) )) prev-tests))) Index: server.scm ================================================================== --- server.scm +++ server.scm @@ -52,12 +52,12 @@ (define (server:launch run-id) (case *transport-type* ((http)(http-transport:launch run-id)) ((nmsg)(nmsg-transport:launch run-id)) ((rpc) (rpc-transport:launch run-id)) - (else (debug:print 0 "ERROR: unknown server type " *transport-type*)))) -;; (else (debug:print 0 "ERROR: No known transport set, transport=" transport ", using rpc") + (else (debug:print 0 *default-log-port* "ERROR: unknown server type " *transport-type*)))) +;; (else (debug:print 0 *default-log-port* "ERROR: No known transport set, transport=" transport ", using rpc") ;; (rpc-transport:launch run-id))))) ;;====================================================================== ;; S E R V E R U T I L I T I E S ;;====================================================================== @@ -83,11 +83,11 @@ ;; When using zmq this would send the message back (two step process) ;; with spiffy or rpc this simply returns the return data to be returned ;; (define (server:reply return-addr query-sig success/fail result) - (debug:print-info 11 "server:reply return-addr=" return-addr ", result=" result) + (debug:print-info 11 *default-log-port* "server:reply return-addr=" return-addr ", result=" result) ;; (send-message pubsock target send-more: #t) ;; (send-message pubsock (case (server:get-transport) ((rpc) (db:obj->string (vector success/fail query-sig result))) ((http) (db:obj->string (vector success/fail query-sig result))) @@ -95,11 +95,11 @@ (let ((pub-socket (vector-ref *runremote* 1))) (send-message pub-socket return-addr send-more: #t) (send-message pub-socket (db:obj->string (vector success/fail query-sig result))))) ((fs) result) (else - (debug:print 0 "ERROR: unrecognised transport type: " *transport-type*) + (debug:print 0 *default-log-port* "ERROR: unrecognised transport type: " *transport-type*) result))) ;; Given a run id start a server process ### NOTE ### > file 2>&1 ;; if the run-id is zero and the target-host is set ;; try running on that host @@ -113,11 +113,11 @@ (cmdln (conc (common:get-megatest-exe) " -server " (or target-host "-") " -run-id " run-id (if (equal? (configf:lookup *configdat* "server" "daemonize") "yes") (conc " -daemonize -log " logfile) "") " -m testsuite:" testsuite))) ;; (conc " >> " logfile " 2>&1 &"))))) - (debug:print 0 "INFO: Starting server (" cmdln ") as none running ...") + (debug:print 0 *default-log-port* "INFO: Starting server (" cmdln ") as none running ...") (push-directory *toppath*) (if (not (directory-exists? "logs"))(create-directory "logs")) ;; Rotate logs, logic: ;; if > 500k and older than 1 week, remove previous compressed log and compress this log (directory-fold @@ -125,13 +125,13 @@ (if (and (string-match "^.*.log" file) (> (file-size (conc "logs/" file)) 200000)) (let ((gzfile (conc "logs/" file ".gz"))) (if (file-exists? gzfile) (begin - (debug:print-info 0 "removing " gzfile) + (debug:print-info 0 *default-log-port* "removing " gzfile) (delete-file gzfile))) - (debug:print-info 0 "compressing " file) + (debug:print-info 0 *default-log-port* "compressing " file) (system (conc "gzip logs/" file))))) '() "logs") ;; host.domain.tld match host? @@ -139,11 +139,11 @@ ;; look at target host, is it host.domain.tld or ip address and does it ;; match current ip or hostname (not (string-match (conc "("curr-host "|" curr-host"\\..*)") target-host)) (not (equal? curr-ip target-host))) (begin - (debug:print-info 0 "Starting server on " target-host ", logfile is " logfile) + (debug:print-info 0 *default-log-port* "Starting server on " target-host ", logfile is " logfile) (setenv "TARGETHOST" target-host))) (setenv "TARGETHOST_LOGF" logfile) (common:wait-for-normalized-load 4 " delaying server start due to load") ;; do not try starting servers on an already overloaded machine, just wait forever (system (conc "nbfake " cmdln)) (unsetenv "TARGETHOST_LOGF") @@ -193,11 +193,11 @@ timeout: 2))))) ;; if the server didn't respond we must remove the record (if res #t (begin - (debug:print-info 0 "server at " server " not responding, removing record") + (debug:print-info 0 *default-log-port* "server at " server " not responding, removing record") (tasks:server-force-clean-running-records-for-run-id (db:delay-if-busy tdbdat) run-id " server:check-if-running") res))) #f)))) @@ -211,11 +211,11 @@ #f))) (toppath (launch:setup)) (server-db-dat (if (not host-port)(tasks:get-server (db:delay-if-busy tdbdat) run-id) #f))) (if (not run-id) (begin - (debug:print 0 "ERROR: must specify run-id when doing ping, -run-id n") + (debug:print 0 *default-log-port* "ERROR: must specify run-id when doing ping, -run-id n") (print "ERROR: No run-id") (exit 1)) (if (and (not host-port) (not server-db-dat)) (begin @@ -252,14 +252,14 @@ (define (server:login toppath) (lambda (toppath) (set! *last-db-access* (current-seconds)) (if (equal? *toppath* toppath) (begin - ;; (debug:print-info 2 "login successful") + ;; (debug:print-info 2 *default-log-port* "login successful") #t) (begin - ;; (debug:print-info 2 "login failed") + ;; (debug:print-info 2 *default-log-port* "login failed") #f)))) (define (server:get-timeout) (let ((tmo (configf:lookup *configdat* "server" "timeout"))) (if (and (string? tmo) Index: sharedat.scm ================================================================== --- sharedat.scm +++ sharedat.scm @@ -115,11 +115,11 @@ (writeable (file-write-access? dbpath)) (dbexists (file-exists? dbpath))) (handle-exceptions exn (begin - (debug:print 2 "ERROR: problem accessing db " dbpath + (debug:print 2 *default-log-port* "ERROR: problem accessing db " dbpath ((condition-property-accessor 'exn 'message) exn)) (exit 1)) (call-with-database dbpath (lambda (db) Index: spublish.scm ================================================================== --- spublish.scm +++ spublish.scm @@ -115,11 +115,11 @@ (writeable (file-write-access? dbpath)) (dbexists (file-exists? dbpath))) (handle-exceptions exn (begin - (debug:print 2 "ERROR: problem accessing db " dbpath + (debug:print 2 *default-log-port* "ERROR: problem accessing db " dbpath ((condition-property-accessor 'exn 'message) exn)) (exit 1)) (call-with-database dbpath (lambda (db) Index: sretrieve.scm ================================================================== --- sretrieve.scm +++ sretrieve.scm @@ -54,12 +54,13 @@ (define sretrieve:help (conc "Usage: " *exe-name* " [action [params ...]] ls : list contents of target area get : retrieve data for release -m \"message\" : why retrieved? - + cp : copy file to current directory log : get listing of recent downloads + shell : start a shell-like interface Part of the Megatest tool suite. Learn more at http://www.kiatoa.com/fossils/megatest Version: " megatest-fossil-hash)) ;; " @@ -108,14 +109,15 @@ ;; (set-busy-handler! db (busy-timeout 10000)) ; 10 second timeout ;; ...)) ;; Create the sqlite db (define (sretrieve:db-do configdat proc) + (let ((path (configf:lookup configdat "database" "location"))) (if (not path) (begin - (debug:print 0 "[database]\nlocation /some/path\n\n Is missing from the config file!") + (debug:print 0 *default-log-port* "[database]\nlocation /some/path\n\n Is missing from the config file!") (exit 1))) (if (and path (directory? path) (file-read-access? path)) (let* ((dbpath (conc path "/" *exe-name* ".db")) @@ -122,50 +124,132 @@ (writeable (file-write-access? dbpath)) (dbexists (file-exists? dbpath))) (handle-exceptions exn (begin - (debug:print 2 "ERROR: problem accessing db " dbpath + (debug:print 2 *default-log-port* "ERROR: problem accessing db " dbpath ((condition-property-accessor 'exn 'message) exn)) (exit 1)) + ;;(debug:print 0 *default-log-port* "calling proc " proc "db path " dbpath ) (call-with-database dbpath (lambda (db) - ;; (debug:print 0 "calling proc " proc " on db " db) + ;;(debug:print 0 *default-log-port* "calling proc " proc " on db " db) (set-busy-handler! db (busy-timeout 10000)) ;; 10 sec timeout (if (not dbexists)(sretrieve:initialize-db db)) (proc db))))) - (debug:print 0 "ERROR: invalid path for storing database: " path)))) + (debug:print 0 *default-log-port* "ERROR: invalid path for storing database: " path)))) -;; copy in file to dest, validation is done BEFORE calling this +;; copy in directory to dest, validation is done BEFORE calling this ;; (define (sretrieve:get configdat retriever version comment) (let* ((base-dir (configf:lookup configdat "settings" "base-dir")) (datadir (conc base-dir "/" version))) (if (or (not base-dir) (not (file-exists? base-dir))) (begin - (debug:print 0 "ERROR: Bad configuration! base-dir " base-dir " not found") + (debug:print 0 *default-log-port* "ERROR: Bad configuration! base-dir " base-dir " not found") (exit 1))) (print datadir) (if (not (file-exists? datadir)) (begin - (debug:print 0 "ERROR: Bad version (" version "), no data found at " datadir "." ) + (debug:print 0 *default-log-port* "ERROR: Bad version (" version "), no data found at " datadir "." ) (exit 1))) (sretrieve:db-do configdat (lambda (db) (sretrieve:register-action db "get" retriever datadir comment))) (sretrieve:do-as-calling-user (lambda () - (change-directory datadir) - (let ((files (filter (lambda (x) + (if (directory? datadir) + (begin + (change-directory datadir) + (let ((files (filter (lambda (x) (not (member x '("." "..")))) (glob "*" ".*")))) - (print "files: " files) - (process-execute "/bin/tar" (append (list "chfv" "-") files))))))) + (print "files: " files) + (process-execute "/bin/tar" (append (append (list "chfv" "-") files) (list "--ignore-failed-read"))))) + (begin + (let* ((parent-dir (pathname-directory datadir) ) + (filename (conc(pathname-file datadir) "." (pathname-extension datadir)))) + (change-directory parent-dir) + (process-execute "/bin/tar" (list "chfv" "-" filename)) + ))) +)) +)) + + +;; copy in file to dest, validation is done BEFORE calling this +;; +(define (sretrieve:cp configdat retriever file comment) + (let* ((base-dir (configf:lookup configdat "settings" "base-dir")) + (allowed-sub-paths (configf:lookup configdat "settings" "allowed-sub-paths")) + (datadir (conc base-dir "/" file)) + (filename (conc(pathname-file datadir) "." (pathname-extension datadir)))) + (if (or (not base-dir) + (not (file-exists? base-dir))) + (begin + (debug:print 0 *default-log-port* "ERROR: Bad configuration! base-dir " base-dir " not found") + (exit 1))) + (print datadir) + (if (not (file-exists? datadir)) + (begin + (debug:print 0 *default-log-port* "ERROR: File (" file "), not found at " base-dir "." ) + (exit 1))) + (if (directory? datadir) + (begin + (debug:print 0 *default-log-port* "ERROR: (" file ") is a dirctory!! cp cmd works only on files ." ) + (exit 1))) + (if(not (string-match (regexp allowed-sub-paths) file)) + (begin + (debug:print 0 *default-log-port* "ERROR: Access denied to file (" file ")!! " ) + (exit 1))) + + (sretrieve:db-do + configdat + (lambda (db) + (sretrieve:register-action db "cp" retriever datadir comment))) + (sretrieve:do-as-calling-user + ;; (debug:print 0 *default-log-port* "ph: "(pathname-directory datadir) "!! " ) + (change-directory (pathname-directory datadir)) + ;;(debug:print 0 *default-log-port* "ph: /bin/tar" (list "chfv" "-" filename) ) + (process-execute "/bin/tar" (list "chfv" "-" filename))) + )) + +;; ls in file to dest, validation is done BEFORE calling this +;; +(define (sretrieve:ls configdat retriever file comment) + (let* ((base-dir (configf:lookup configdat "settings" "base-dir")) + (allowed-sub-paths (configf:lookup configdat "settings" "allowed-sub-paths")) + (datadir (conc base-dir "/" file)) + (filename (conc(pathname-file datadir) "." (pathname-extension datadir)))) + (if (or (not base-dir) + (not (file-exists? base-dir))) + (begin + (debug:print 0 *default-log-port* "ERROR: Bad configuration! base-dir " base-dir " not found") + (exit 1))) + (print datadir) + (if (not (file-exists? datadir)) + (begin + (debug:print 0 *default-log-port* "ERROR: File (" file "), not found at " base-dir "." ) + (exit 1))) + (if(not (string-match (regexp allowed-sub-paths) file)) + (begin + (debug:print 0 *default-log-port* "ERROR: Access denied to file (" file ")!! " ) + (exit 1))) + + (sretrieve:do-as-calling-user + (lambda () + ;;(change-directory datadir) + ;; (debug:print 0 *default-log-port* "/usr/bin/find" (list datadir "-ls" "|" "grep" "-E" "'"allowed-file-patt"'")) + ;; (status (with-input-from-pipe "find " datadir " -ls | grep -E '" allowed-file-patt "'" (lambda () (read-line)))) + ;; (debug:print 0 *default-log-port* status) + (process-execute "/bin/ls" (list "-ls" "-lrt" datadir )) + )))) + + ;;(filter (lambda (x) ;; (not (member x '("." "..")))) ;; (glob "*" ".*")))))))) @@ -172,37 +256,37 @@ (define (sretrieve:validate target-dir targ-mk) (let* ((normal-path (normalize-pathname targ-mk)) (targ-path (conc target-dir "/" normal-path))) (if (string-contains normal-path "..") (begin - (debug:print 0 "ERROR: Path " targ-mk " resolved outside target area " target-dir ) + (debug:print 0 *default-log-port* "ERROR: Path " targ-mk " resolved outside target area " target-dir ) (exit 1))) (if (not (string-contains targ-path target-dir)) (begin - (debug:print 0 "ERROR: You cannot update data outside " target-dir ".") + (debug:print 0 *default-log-port* "ERROR: You cannot update data outside " target-dir ".") (exit 1))) - (debug:print 0 "Path " targ-mk " is valid.") + (debug:print 0 *default-log-port* "Path " targ-mk " is valid.") )) ;; make directory in dest ;; (define (sretrieve:mkdir configdat submitter target-dir targ-mk comment) (let ((targ-path (conc target-dir "/" targ-mk))) (if (file-exists? targ-path) (begin - (debug:print 0 "ERROR: target Directory " targ-path " already exist!!") + (debug:print 0 *default-log-port* "ERROR: target Directory " targ-path " already exist!!") (exit 1))) (sretrieve:db-do configdat (lambda (db) (sretrieve:register-action db "mkdir" submitter targ-mk comment))) (let* ((th1 (make-thread (lambda () (create-directory targ-path #t) - (debug:print 0 " ... dir " targ-path " created")) + (debug:print 0 *default-log-port* " ... dir " targ-path " created")) "mkdir thread")) (th2 (make-thread (lambda () (let loop () (thread-sleep! 15) @@ -219,25 +303,25 @@ ;; (define (sretrieve:ln configdat submitter target-dir targ-link link-name comment) (let ((targ-path (conc target-dir "/" link-name))) (if (file-exists? targ-path) (begin - (debug:print 0 "ERROR: target file " targ-path " already exist!!") + (debug:print 0 *default-log-port* "ERROR: target file " targ-path " already exist!!") (exit 1))) (if (not (file-exists? targ-link )) (begin - (debug:print 0 "ERROR: target file " targ-link " does not exist!!") + (debug:print 0 *default-log-port* "ERROR: target file " targ-link " does not exist!!") (exit 1))) (sretrieve:db-do configdat (lambda (db) (sretrieve:register-action db "ln" submitter link-name comment))) (let* ((th1 (make-thread (lambda () (create-symbolic-link targ-link targ-path ) - (debug:print 0 " ... link " targ-path " created")) + (debug:print 0 *default-log-port* " ... link " targ-path " created")) "symlink thread")) (th2 (make-thread (lambda () (let loop () (thread-sleep! 15) @@ -255,20 +339,20 @@ ;; (define (sretrieve:rm configdat submitter target-dir targ-file comment) (let ((targ-path (conc target-dir "/" targ-file))) (if (not (file-exists? targ-path)) (begin - (debug:print 0 "ERROR: target file " targ-path " not found, nothing to remove.") + (debug:print 0 *default-log-port* "ERROR: target file " targ-path " not found, nothing to remove.") (exit 1))) (sretrieve:db-do configdat (lambda (db) (sretrieve:register-action db "rm" submitter targ-file comment))) (let* ((th1 (make-thread (lambda () (delete-file targ-path) - (debug:print 0 " ... file " targ-path " removed")) + (debug:print 0 *default-log-port* " ... file " targ-path " removed")) "rm thread")) (th2 (make-thread (lambda () (let loop () (thread-sleep! 15) @@ -308,11 +392,11 @@ (define (sretrieve:do-as-calling-user proc) (let ((eid (current-effective-user-id)) (cid (current-user-id))) (if (not (eq? eid cid)) ;; running suid (set! (current-effective-user-id) cid)) - ;; (debug:print 0 "running as " (current-effective-user-id)) + ;; (debug:print 0 *default-log-port* "running as " (current-effective-user-id)) (proc) (if (not (eq? eid cid)) (set! (current-effective-user-id) eid)))) (define (sretrieve:find name paths) @@ -328,10 +412,55 @@ (define (sretrieve:stderr-print . args) (with-output-to-port (current-error-port) (lambda () (apply print args)))) + +;;====================================================================== +;; SHELL +;;====================================================================== + +(define (toplevel-command . args) #f) +(define (sretrieve:shell) + (use readline) + (let* ((path '()) + (prompt "> ") + (top-areas '("mrwellan" "pjhatwal" "bjbarcla" "ritikaag" "jmoon18")) + (iport (make-readline-port prompt))) + (install-history-file) ;; [homedir] [filename] [nlines]) + (with-input-from-port iport + (lambda () + (let loop ((inl (read-line))) + (if (not (or (eof-object? inl) + (equal? inl "exit"))) + (let* ((parts (string-split inl)) + (cmd (if (null? parts) #f (car parts)))) + (if (not cmd) + (loop (read-line)) + (case (string->symbol cmd) + ((cd) + (if (> (length parts) 1) ;; have a parameter + (set! path (append path (string-split (cadr parts)))) ;; not correct for relative paths + (set! path '()))) + ((ls) + (let* ((thepath (if (> (length parts) 1) ;; have a parameter + (cdr parts) + path)) + (plen (length thepath))) + (cond + ((null? thepath) + (print (string-intersperse top-areas " "))) + ((and (< plen 2) + (member (car thepath) top-areas)) + (system (conc "ls /p/fdk/gwa/" (car thepath)))) + (else ;; have a long path + ;; check for access rights here + (system (conc "ls /p/fdk/gwa/" (string-intersperse thepath "/"))))))) + (else + (print "Got command: " inl)))) + (loop (read-line))))))))) + ;;====================================================================== ;; MAIN ;;====================================================================== @@ -358,62 +487,86 @@ (if (file-exists? upstream-file) (if (or (not (file-exists? package-config)) ;; if not created call the updater, otherwise call only if upstream newer (> (file-modification-time upstream-file)(file-modification-time package-config))) (handle-exceptions exn - (debug:print 0 "ERROR: failed to run script " conversion-script " with params " upstream-file " " package-config) + (debug:print 0 *default-log-port* "ERROR: failed to run script " conversion-script " with params " upstream-file " " package-config) (let ((pid (process-run conversion-script (list upstream-file package-config)))) (process-wait pid))) - (debug:print 0 "Skipping update of " package-config " from " upstream-file)) - (debug:print 0 "Skipping update of " package-config " as " upstream-file " not found")) + (debug:print 0 *default-log-port* "Skipping update of " package-config " from " upstream-file)) + (debug:print 0 *default-log-port* "Skipping update of " package-config " as " upstream-file " not found")) ;; (ini:property-separator-patt " * *") ;; (ini:property-separator #\space) (let ((res (if (file-exists? package-config) (begin - (debug:print 0 "Reading package config " package-config) + (debug:print 0 *default-log-port* "Reading package config " package-config) (read-config package-config #f #t)) (make-hash-table)))) (pop-directory) res))) (define (sretrieve:process-action configdat action . args) (let* ((base-dir (configf:lookup configdat "settings" "base-dir")) (user (current-user-name)) + (allowed-sub-paths (configf:lookup configdat "settings" "allowed-sub-paths")) (allowed-users (string-split (or (configf:lookup configdat "settings" "allowed-users") ""))) (default-area (configf:lookup configdat "settings" "default-area"))) ;; otherwise known as the package (if (not base-dir) (begin - (debug:print 0 "[settings]\nbase-dir /some/path\n\n Is MISSING from the config file!") + (debug:print 0 *default-log-port* "[settings]\nbase-dir /some/path\n\n Is MISSING from the config file!") (exit))) (if (null? allowed-users) (begin - (debug:print 0 "[setings]\nallowed-users user1 user2 ...\n\n Is MISSING from the config file!") + (debug:print 0 *default-log-port* "[setings]\nallowed-users user1 user2 ...\n\n Is MISSING from the config file!") (exit))) (if (not (member user allowed-users)) (begin - (debug:print 0 "User \"" (current-user-name) "\" does not have access. Exiting") + (debug:print 0 *default-log-port* "User \"" (current-user-name) "\" does not have access. Exiting") (exit 1))) (case (string->symbol action) ((get) (if (< (length args) 1) (begin - (debug:print 0 "ERROR: Missing arguments; " (string-intersperse args ", ")) + (debug:print 0 *default-log-port* "ERROR: Missing arguments; " (string-intersperse args ", ")) (exit 1))) (let* ((remargs (args:get-args args '("-m" "-i" "-package") '() args:arg-hash 0)) (version (car args)) (msg (or (args:get-arg "-m") "")) (package-type (or (args:get-arg "-package") default-area)) (exe-dir (configf:lookup configdat "exe-info" "exe-dir"))) ;; (relconfig (sretrieve:load-packages configdat exe-dir package-type))) - (debug:print 0 "retrieving " version " of " package-type " as tar data on stdout") + (debug:print 0 *default-log-port* "retrieving " version " of " package-type " as tar data on stdout") (sretrieve:get configdat user version msg))) - (else (debug:print 0 "Unrecognised command " action))))) + ((cp) + (if (< (length args) 1) + (begin + (debug:print 0 *default-log-port* "ERROR: Missing arguments; " (string-intersperse args ", ")) + (exit 1))) + (let* ((remargs (args:get-args args '("-m" "-i" "-package") '() args:arg-hash 0)) + (file (car args)) + (msg (or (args:get-arg "-m") "")) ) + + (debug:print 0 *default-log-port* "copinging " file " to current directory " ) + (sretrieve:cp configdat user file msg))) + ((ls) + (if (< (length args) 1) + (begin + (debug:print 0 *default-log-port* "ERROR: Missing arguments; " (string-intersperse args ", ")) + (exit 1))) + (let* ((remargs (args:get-args args '("-m" "-i" "-package") '() args:arg-hash 0)) + (dir (car args)) + (msg (or (args:get-arg "-m") "")) ) + + (debug:print 0 *default-log-port* "Listing files in " ) + (sretrieve:ls configdat user dir msg))) + + (else (debug:print 0 *default-log-port* "Unrecognised command " action))))) ;; ease debugging by loading ~/.dashboardrc - REMOVE FROM PRODUCTION! ;; (let ((debugcontrolf (conc (get-environment-variable "HOME") "/.sretrieverc"))) ;; (if (file-exists? debugcontrolf) ;; (load debugcontrolf))) @@ -442,23 +595,25 @@ (if base-dir (begin (print "Files in " base-dir) (sretrieve:do-as-calling-user (lambda () - (process-execute "/bin/ls" (list base-dir))))) + (process-execute "/bin/ls" (list "-lrt" base-dir))))) (print "ERROR: No base dir specified!")))) ((log) (sretrieve:db-do configdat (lambda (db) (print "Logs : ") (query (for-each-row (lambda (row) (apply print (intersperse row " | ")))) (sql db "SELECT * FROM actions"))))) + ((shell) + (sretrieve:shell)) (else (print "ERROR: Unrecognised command. Try \"sretrieve help\"")))) ;; multi-word commands ((null? rema)(print sretrieve:help)) ((>= (length rema) 2) (apply sretrieve:process-action configdat (car rema)(cdr rema))) - (else (debug:print 0 "ERROR: Unrecognised command. Try \"sretrieve help\""))))) + (else (debug:print 0 *default-log-port* "ERROR: Unrecognised command. Try \"sretrieve help\""))))) (main) Index: synchash.scm ================================================================== --- synchash.scm +++ synchash.scm @@ -71,11 +71,11 @@ (hash-table-set! synchash synckey myhash))) (for-each (lambda (item) (let ((id (car item)) (dat (cadr item))) - ;; (debug:print-info 2 "Processing item: " item) + ;; (debug:print-info 2 *default-log-port* "Processing item: " item) (hash-table-set! myhash id dat))) newdat) (for-each (lambda (id) (hash-table-delete! myhash id)) @@ -85,11 +85,11 @@ (list newdat removs))) ;; synchash)) (define *synchashes* (make-hash-table)) (define (synchash:server-get dbstruct run-id proc synckey keynum params) - ;; (debug:print-info 2 "synckey: " synckey ", keynum: " keynum ", params: " params) + ;; (debug:print-info 2 *default-log-port* "synckey: " synckey ", keynum: " keynum ", params: " params) (let* ((dbdat (db:get-db dbstruct run-id)) (db (db:dbdat-get-db dbdat)) (synchash (hash-table-ref/default *synchashes* synckey #f)) (newdat (apply (case proc ((db:get-runs) db:get-runs) @@ -103,22 +103,22 @@ (make-indexed (lambda (x) (list (vector-ref x keynum) x)))) ;; Now process newdat based on the query type (set! postdat (case proc ((db:get-runs) - ;; (debug:print-info 2 "Get runs call") + ;; (debug:print-info 2 *default-log-port* "Get runs call") (let ((header (vector-ref newdat 0)) (data (vector-ref newdat 1))) - ;; (debug:print-info 2 "header: " header ", data: " data) + ;; (debug:print-info 2 *default-log-port* "header: " header ", data: " data) (cons (list "header" header) ;; add the header keyed by the word "header" (map make-indexed data)))) ;; add each element keyed by the keynum'th val (else - ;; (debug:print-info 2 "Non-get runs call") + ;; (debug:print-info 2 *default-log-port* "Non-get runs call") (map make-indexed newdat)))) - ;; (debug:print-info 2 "postdat: " postdat) + ;; (debug:print-info 2 *default-log-port* "postdat: " postdat) ;; (if (not indb)(sqlite3:finalize! db)) (if (not synchash) (begin (set! synchash (make-hash-table)) (hash-table-set! *synchashes* synckey synchash))) (synchash:get-delta postdat synchash))) Index: tasks.scm ================================================================== --- tasks.scm +++ tasks.scm @@ -25,27 +25,27 @@ ;; wait up to aprox n seconds for a journal to go away ;; (define (tasks:wait-on-journal path n #!key (remove #f)(waiting-msg #f)) (if (not (string? path)) - (debug:print 0 "ERROR: Called tasks:wait-on-journal with path=" path " (not a string)") + (debug:print 0 *default-log-port* "ERROR: Called tasks:wait-on-journal with path=" path " (not a string)") (let ((fullpath (conc path "-journal"))) (handle-exceptions exn (begin (print-call-chain (current-error-port)) - (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) - (debug:print 0 " exn=" (condition->list exn)) - (debug:print 0 "tasks:wait-on-journal failed. Continuing on, you can ignore this call-chain") + (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 *default-log-port* " exn=" (condition->list exn)) + (debug:print 0 *default-log-port* "tasks:wait-on-journal failed. Continuing on, you can ignore this call-chain") #t) ;; if stuff goes wrong just allow it to move on (let loop ((journal-exists (file-exists? fullpath)) (count n)) ;; wait ten times ... (if journal-exists (begin (if (and waiting-msg (eq? (modulo n 30) 0)) - (debug:print 0 waiting-msg)) + (debug:print 0 *default-log-port* waiting-msg)) (if (> count 0) (begin (thread-sleep! 1) (loop (file-exists? fullpath) (- count 1))) @@ -59,11 +59,11 @@ (configf:lookup *configdat* "setup" "dbdir") (conc (configf:lookup *configdat* "setup" "linktree") "/.db")))) (handle-exceptions exn (begin - (debug:print 0 "ERROR: Couldn't create path to " dbdir) + (debug:print 0 *default-log-port* "ERROR: Couldn't create path to " dbdir) (exit 1)) (if (not (directory? dbdir))(create-directory dbdir #t))) dbdir)) ;; If file exists AND @@ -81,18 +81,18 @@ (handle-exceptions exn (if (> numretries 0) (begin (print-call-chain (current-error-port)) - (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) - (debug:print 0 " exn=" (condition->list exn)) + (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 *default-log-port* " exn=" (condition->list exn)) (thread-sleep! 1) (tasks:open-db numretries (- numretries 1))) (begin (print-call-chain (current-error-port)) - (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) - (debug:print 0 " exn=" (condition->list exn)))) + (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 *default-log-port* " exn=" (condition->list exn)))) (let* ((dbpath (tasks:get-task-db-path)) (dbfile (conc dbpath "/monitor.db")) (avail (tasks:wait-on-journal dbpath 10)) ;; wait up to about 10 seconds for the journal to go away (exists (file-exists? dbpath)) (write-access (file-write-access? dbpath)) @@ -286,21 +286,21 @@ port)))))) (define (tasks:server-am-i-the-server? mdb run-id) (let* ((all (tasks:server-get-servers-vying-for-run-id mdb run-id)) (first (if (null? all) - #f;; (begin (debug:print 0 "ERROR: no servers listed, should be at least one by now.") + #f;; (begin (debug:print 0 *default-log-port* "ERROR: no servers listed, should be at least one by now.") ;; (sqlite3:finalize! mdb) ;; (exit 1)) (car (db:get-rows all))))) (if first (let* ((header (db:get-header all)) (id (db:get-value-by-header first header "id")) (hostname (db:get-value-by-header first header "hostname")) (pid (db:get-value-by-header first header "pid")) (priority (db:get-value-by-header first header "priority"))) - ;; (debug:print 0 "INFO: am-i-the-server got record " first) + ;; (debug:print 0 *default-log-port* "INFO: am-i-the-server got record " first) ;; for now a basic check. add tiebreaking by priority later (if (and (equal? hostname (get-host-name)) (equal? pid (current-process-id))) id #f)) @@ -326,20 +326,20 @@ (best #f)) (handle-exceptions exn (begin (print-call-chain (current-error-port)) - (debug:print 0 "WARNING: tasks:get-server db access error.") - (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) - (debug:print 0 " for run " run-id) + (debug:print 0 *default-log-port* "WARNING: tasks:get-server db access error.") + (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 *default-log-port* " for run " run-id) (print-call-chain (current-error-port)) (if (> retries 0) (begin - (debug:print 0 " trying call to tasks:get-server again in 10 seconds") + (debug:print 0 *default-log-port* " trying call to tasks:get-server again in 10 seconds") (thread-sleep! 10) (tasks:get-server mdb run-id retries: (- retries 0))) - (debug:print 0 "10 tries of tasks:get-server all crashed and burned. Giving up and returning \"no server found\""))) + (debug:print 0 *default-log-port* "10 tries of tasks:get-server all crashed and burned. Giving up and returning \"no server found\""))) (sqlite3:for-each-row (lambda (id interface port pubport transport pid hostname) (set! res (vector id interface port pubport transport pid hostname))) mdb ;; removed: @@ -373,15 +373,15 @@ ;; (maxqry (cdr (rmt:get-max-query-average run-id))) ;; (threshold (string->number (or (configf:lookup *configdat* "server" "server-query-threshold") "10")))) ;; (cond ;; (forced ;; (if (common:low-noise-print 60 run-id "server required is set") -;; (debug:print-info 0 "Server required is set, starting server for run-id " run-id ".")) +;; (debug:print-info 0 *default-log-port* "Server required is set, starting server for run-id " run-id ".")) ;; #t) ;; ((> maxqry threshold) ;; (if (common:low-noise-print 60 run-id "Max query time execeeded") -;; (debug:print-info 0 "Max avg query time of " maxqry "ms exceeds limit of " threshold "ms, server needed for run-id " run-id ".")) +;; (debug:print-info 0 *default-log-port* "Max avg query time of " maxqry "ms exceeds limit of " threshold "ms, server needed for run-id " run-id ".")) ;; #t) ;; (else ;; #f)))) ;; try to start a server and wait for it to be available @@ -392,11 +392,11 @@ (delay-time 0)) (if (and (not server-dat) (< delay-time delay-max-tries)) (begin (if (common:low-noise-print 60 "tasks:start-and-wait-for-server" run-id) - (debug:print 0 "Try starting server for run-id " run-id)) + (debug:print 0 *default-log-port* "Try starting server for run-id " run-id)) (thread-sleep! (/ (random 2000) 1000)) (server:kind-run run-id) (thread-sleep! (min delay-time 1)) (loop (tasks:get-server (db:delay-if-busy tdbdat) run-id)(+ delay-time 1)))))) @@ -424,11 +424,11 @@ (reverse res))) ;; no elegance here ... ;; (define (tasks:kill-server hostname pid) - (debug:print-info 0 "Attempting to kill server process " pid " on host " hostname) + (debug:print-info 0 *default-log-port* "Attempting to kill server process " pid " on host " hostname) (setenv "TARGETHOST" hostname) (setenv "TARGETHOST_LOGF" "server-kills.log") (system (conc "nbfake kill " pid)) (unsetenv "TARGETHOST_LOGF") (unsetenv "TARGETHOST")) @@ -441,14 +441,14 @@ (if sdat (let ((hostname (vector-ref sdat 6)) (pid (vector-ref sdat 5)) (server-id (vector-ref sdat 0))) (tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "killed") - (debug:print-info 0 "Killing server " server-id " for run-id " run-id " on host " hostname " with pid " pid) + (debug:print-info 0 *default-log-port* "Killing server " server-id " for run-id " run-id " on host " hostname " with pid " pid) (tasks:kill-server hostname pid) (tasks:server-delete-record (db:delay-if-busy tdbdat) server-id tag) ) - (debug:print-info 0 "No server found for run-id " run-id ", nothing to kill")) + (debug:print-info 0 *default-log-port* "No server found for run-id " run-id ", nothing to kill")) ;; (sqlite3:finalize! tdb) )) ;;====================================================================== ;; M O N I T O R S @@ -519,11 +519,11 @@ res)) ;; (define (tasks:start-monitor db mdb) (if (> (tasks:get-num-alive-monitors mdb) 2) ;; have two running, no need for more - (debug:print-info 1 "Not starting monitor, already have more than two running") + (debug:print-info 1 *default-log-port* "Not starting monitor, already have more than two running") (let* ((megatestdb (conc *toppath* "/megatest.db")) (monitordbf (conc (db:dbfile-path #f) "/monitor.db")) (last-db-update 0)) ;; (file-modification-time megatestdb))) (task:register-monitor mdb) (let loop ((count 0) @@ -747,28 +747,28 @@ ;; (define (tasks:kill-runner target run-name testpatt) (let ((records (rmt:tasks-find-task-queue-records target run-name testpatt "running" "run-tests")) (hostpid-rx (regexp "\\s+(\\w+)\\s+(\\d+)$"))) ;; host pid is at end of param string (if (null? records) - (debug:print 0 "No run launching processes found for " target " / " run-name " with testpatt " (or testpatt "* no testpatt specified! *")) - (debug:print 0 "Found " (length records) " run(s) to kill.")) + (debug:print 0 *default-log-port* "No run launching processes found for " target " / " run-name " with testpatt " (or testpatt "* no testpatt specified! *")) + (debug:print 0 *default-log-port* "Found " (length records) " run(s) to kill.")) (for-each (lambda (record) (let* ((param-key (list-ref record 8)) (match-dat (string-search hostpid-rx param-key))) (if match-dat (let ((hostname (cadr match-dat)) (pid (string->number (caddr match-dat)))) - (debug:print 0 "Sending SIGINT to process " pid " on host " hostname) + (debug:print 0 *default-log-port* "Sending SIGINT to process " pid " on host " hostname) (if (equal? (get-host-name) hostname) (if (process:alive? pid) (begin (handle-exceptions exn (begin - (debug:print 0 "Kill of process " pid " on host " hostname " failed.") - (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 *default-log-port* "Kill of process " pid " on host " hostname " failed.") + (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) #t) (process-signal pid signal/int) (thread-sleep! 5) (if (process:alive? pid) (process-signal pid signal/kill))))) @@ -778,11 +778,11 @@ (setenv "TARGETHOST_LOGF" "server-kills.log") (system (conc "nbfake kill " pid)) (if old-targethost (setenv "TARGETHOST" old-targethost)) (unsetenv "TARGETHOST") (unsetenv "TARGETHOST_LOGF")))) - (debug:print 0 "ERROR: no record or improper record for " target "/" run-name " in tasks_queue in main.db")))) + (debug:print 0 *default-log-port* "ERROR: no record or improper record for " target "/" run-name " in tasks_queue in main.db")))) records))) ;; (define (tasks:start-run dbstruct mdb task) ;; (let ((flags (make-hash-table))) ;; (hash-table-set! flags "-rerun" "NOT_STARTED") Index: tdb.scm ================================================================== --- tdb.scm +++ tdb.scm @@ -45,11 +45,11 @@ ;; ;; Moved these tables into .db ;; THIS CODE TO BE REMOVED ;; (define (open-test-db work-area) - (debug:print-info 11 "open-test-db " work-area) + (debug:print-info 11 *default-log-port* "open-test-db " work-area) (if (and work-area (directory? work-area) (file-read-access? work-area)) (let* ((dbpath (conc work-area "/testdat.db")) (dbexists (file-exists? dbpath)) @@ -56,11 +56,11 @@ (work-area-writeable (file-write-access? work-area)) (db (handle-exceptions ;; open the db if area writeable or db pre-existing. open in-mem otherwise. if exception, open in-mem exn (begin (print-call-chain (current-error-port)) - (debug:print 2 "ERROR: problem accessing test db " work-area ", you probably should clean and re-run this test" + (debug:print 2 *default-log-port* "ERROR: problem accessing test db " work-area ", you probably should clean and re-run this test" ((condition-property-accessor 'exn 'message) exn)) (set! dbexists #f) ;; must force re-creation of tables, more tom-foolery (sqlite3:open-database ":memory:")) ;; open an in-memory db to allow readonly access (if (or work-area-writeable dbexists) @@ -76,48 +76,48 @@ *db-write-access*) (sqlite3:set-busy-handler! db handler)) (if (not dbexists) (begin (db:set-sync db) ;; (sqlite3:execute db "PRAGMA synchronous = FULL;") - (debug:print-info 11 "Initialized test database " dbpath) + (debug:print-info 11 *default-log-port* "Initialized test database " dbpath) (tdb:testdb-initialize db))) ;; (sqlite3:execute db "PRAGMA synchronous = 0;") - (debug:print-info 11 "open-test-db END (sucessful)" work-area) + (debug:print-info 11 *default-log-port* "open-test-db END (sucessful)" work-area) ;; now let's test that everything is correct (handle-exceptions exn (begin (print-call-chain (current-error-port)) - (debug:print 0 "ERROR: problem accessing test db " work-area ", you probably should clean and re-run this test or remove the file " + (debug:print 0 *default-log-port* "ERROR: problem accessing test db " work-area ", you probably should clean and re-run this test or remove the file " dbpath ".\n " ((condition-property-accessor 'exn 'message) exn)) #f) ;; Is there a cheaper single line operation that will check for existance of a table ;; and raise an exception ? (sqlite3:execute db "SELECT id FROM test_data LIMIT 1;")) db) ;; no work-area or not readable - create a placeholder to fake rest of world out (let ((baddb (sqlite3:open-database ":memory:"))) - (debug:print-info 11 "open-test-db END (unsucessful)" work-area) + (debug:print-info 11 *default-log-port* "open-test-db END (unsucessful)" work-area) ;; provide an in-mem db (this is dangerous!) (tdb:testdb-initialize baddb) baddb))) ;; find and open the testdat.db file for an existing test (define (tdb:open-test-db-by-test-id test-id #!key (work-area #f)) (let* ((test-path (if work-area work-area (rmt:test-get-rundir-from-test-id test-id)))) - (debug:print 3 "TEST PATH: " test-path) + (debug:print 3 *default-log-port* "TEST PATH: " test-path) (open-test-db test-path))) ;; find and open the testdat.db file for an existing test (define (tdb:open-test-db-by-test-id-local dbstruct run-id test-id #!key (work-area #f)) (let* ((test-path (if work-area work-area (db:test-get-rundir-from-test-id dbstruct run-id test-id)))) - (debug:print 3 "TEST PATH: " test-path) + (debug:print 3 *default-log-port* "TEST PATH: " test-path) (open-test-db test-path))) ;; find and open the testdat.db file for an existing test (define (tdb:open-run-close-db-by-test-id-local dbstruct run-id test-id work-area proc . params) (let* ((test-path (if work-area @@ -125,11 +125,11 @@ (db:test-get-rundir-from-test-id dbstruct run-id test-id))) (tdb (open-test-db test-path))) (apply proc tdb params))) (define (tdb:testdb-initialize db) - (debug:print 11 "db:testdb-initialize START") + (debug:print 11 *default-log-port* "db:testdb-initialize START") (sqlite3:with-transaction db (lambda () (for-each (lambda (sqlcmd) @@ -171,11 +171,11 @@ id INTEGER PRIMARY KEY, var TEXT, val TEXT, ackstate INTEGER DEFAULT 0, CONSTRAINT metadat_constraint UNIQUE (var));")))) - (debug:print 11 "db:testdb-initialize END")) + (debug:print 11 *default-log-port* "db:testdb-initialize END")) ;; This routine moved to db:read-test-data ;; (define (tdb:read-test-data tdb test-id categorypatt) (let ((res '())) @@ -208,11 +208,23 @@ ;; NOTE: Run this local with #f for db !!! (define (tdb:load-test-data run-id test-id) (let loop ((lin (read-line))) (if (not (eof-object? lin)) (begin - (debug:print 4 lin) + (debug:print 4 *default-log-port* lin) + (rmt:csv->test-data run-id test-id lin) + (loop (read-line))))) + ;; roll up the current results. + ;; FIXME: Add the status too + (rmt:test-data-rollup run-id test-id #f)) + +;; NOTE: Run this local with #f for db !!! +(define (tdb:load-logpro-data run-id test-id) + (let loop ((lin (read-line))) + (if (not (eof-object? lin)) + (begin + (debug:print 4 *default-log-port* lin) (rmt:csv->test-data run-id test-id lin) (loop (read-line))))) ;; roll up the current results. ;; FIXME: Add the status too (rmt:test-data-rollup run-id test-id #f)) @@ -234,17 +246,17 @@ ;; (define (tdb:get-steps-table steps);; organise the steps for better readability (let ((res (make-hash-table))) (for-each (lambda (step) - (debug:print 6 "step=" step) + (debug:print 6 *default-log-port* "step=" step) (let ((record (hash-table-ref/default res (tdb:step-get-stepname step) ;; stepname start end status Duration Logfile (vector (tdb:step-get-stepname step) "" "" "" "" "")))) - (debug:print 6 "record(before) = " record + (debug:print 6 *default-log-port* "record(before) = " record "\nid: " (tdb:step-get-id step) "\nstepname: " (tdb:step-get-stepname step) "\nstate: " (tdb:step-get-state step) "\nstatus: " (tdb:step-get-status step) "\ntime: " (tdb:step-get-event_time step)) @@ -258,11 +270,11 @@ ((end) (vector-set! record 2 (any->number (tdb:step-get-event_time step))) (vector-set! record 3 (tdb:step-get-status step)) (vector-set! record 4 (let ((startt (any->number (vector-ref record 1))) (endt (any->number (vector-ref record 2)))) - (debug:print 4 "record[1]=" (vector-ref record 1) + (debug:print 4 *default-log-port* "record[1]=" (vector-ref record 1) ", startt=" startt ", endt=" endt ", get-status: " (tdb:step-get-status step)) (if (and (number? startt)(number? endt)) (seconds->hr-min-sec (- endt startt)) "-1"))) (if (> (string-length (tdb:step-get-logfile step)) @@ -271,11 +283,11 @@ (else (vector-set! record 2 (tdb:step-get-state step)) (vector-set! record 3 (tdb:step-get-status step)) (vector-set! record 4 (tdb:step-get-event_time step)))) (hash-table-set! res (tdb:step-get-stepname step) record) - (debug:print 6 "record(after) = " record + (debug:print 6 *default-log-port* "record(after) = " record "\nid: " (tdb:step-get-id step) "\nstepname: " (tdb:step-get-stepname step) "\nstate: " (tdb:step-get-state step) "\nstatus: " (tdb:step-get-status step) "\ntime: " (tdb:step-get-event_time step)))) @@ -295,17 +307,17 @@ (define (tdb:get-steps-table-list steps) ;; organise the steps for better readability (let ((res (make-hash-table))) (for-each (lambda (step) - (debug:print 6 "step=" step) + (debug:print 6 *default-log-port* "step=" step) (let ((record (hash-table-ref/default res (tdb:step-get-stepname step) ;; stepname start end status (vector (tdb:step-get-stepname step) "" "" "" "" "")))) - (debug:print 6 "record(before) = " record + (debug:print 6 *default-log-port* "record(before) = " record "\nid: " (tdb:step-get-id step) "\nstepname: " (tdb:step-get-stepname step) "\nstate: " (tdb:step-get-state step) "\nstatus: " (tdb:step-get-status step) "\ntime: " (tdb:step-get-event_time step)) @@ -319,11 +331,11 @@ ((end) (vector-set! record 2 (any->number (tdb:step-get-event_time step))) (vector-set! record 3 (tdb:step-get-status step)) (vector-set! record 4 (let ((startt (any->number (vector-ref record 1))) (endt (any->number (vector-ref record 2)))) - (debug:print 4 "record[1]=" (vector-ref record 1) + (debug:print 4 *default-log-port* "record[1]=" (vector-ref record 1) ", startt=" startt ", endt=" endt ", get-status: " (tdb:step-get-status step)) (if (and (number? startt)(number? endt)) (seconds->hr-min-sec (- endt startt)) "-1"))) (if (> (string-length (tdb:step-get-logfile step)) @@ -332,11 +344,11 @@ (else (vector-set! record 2 (tdb:step-get-state step)) (vector-set! record 3 (tdb:step-get-status step)) (vector-set! record 4 (tdb:step-get-event_time step)))) (hash-table-set! res (tdb:step-get-stepname step) record) - (debug:print 6 "record(after) = " record + (debug:print 6 *default-log-port* "record(after) = " record "\nid: " (tdb:step-get-id step) "\nstepname: " (tdb:step-get-stepname step) "\nstate: " (tdb:step-get-state step) "\nstatus: " (tdb:step-get-status step) "\ntime: " (tdb:step-get-event_time step)))) @@ -383,7 +395,7 @@ (if (sqlite3:database? tdb) (begin (sqlite3:execute tdb "INSERT INTO test_rundat (update_time,cpuload,diskfree,run_duration) VALUES (strftime('%s','now'),?,?,?);" cpuload diskfree minutes) (sqlite3:finalize! tdb)) - (debug:print 2 "Can't update testdat.db for test " test-id " read-only or non-existant")))) + (debug:print 2 *default-log-port* "Can't update testdat.db for test " test-id " read-only or non-existant")))) Index: tests.scm ================================================================== --- tests.scm +++ tests.scm @@ -47,11 +47,11 @@ (filter (lambda (d) (if (directory-exists? d) d (begin (if (common:low-noise-print 60 "tests:get-tests-search-path" d) - (debug:print 0 "WARNING: problem with directory " d ", dropping it from tests path")) + (debug:print 0 *default-log-port* "WARNING: problem with directory " d ", dropping it from tests path")) #f))) (append paths (list (conc *toppath* "/tests")))))) (define (tests:get-valid-tests test-registry tests-paths) (if (null? tests-paths) @@ -101,11 +101,11 @@ (tests:match (car itemmap) testname #f)) itemmaps))) (if (null? best-matches) #f (let ((res (car best-matches))) - ;; (debug:print 0 "res=" res) + ;; (debug:print 0 *default-log-port* "res=" res) (cond ((string? res) res) ;;; FIX THE ROOT CAUSE HERE .... ((null? res) #f) ((string? (cdr res)) (cdr res)) ;; it is a pair ((string? (cadr res))(cadr res)) ;; it is a list @@ -120,23 +120,23 @@ ;; process can know to call items:get-items-from-config ;; if either is a list and none is a proc go ahead and call get-items ;; otherwise return #f - this is not an iterated test (cond ((procedure? items) - (debug:print-info 4 "items is a procedure, will calc later") + (debug:print-info 4 *default-log-port* "items is a procedure, will calc later") items) ;; calc later ((procedure? itemstable) - (debug:print-info 4 "itemstable is a procedure, will calc later") + (debug:print-info 4 *default-log-port* "itemstable is a procedure, will calc later") itemstable) ;; calc later ((filter (lambda (x) (let ((val (car x))) (if (procedure? val) val #f))) (append (if (list? items) items '()) (if (list? itemstable) itemstable '()))) 'have-procedure) ((or (list? items)(list? itemstable)) ;; calc now - (debug:print-info 4 "items and itemstable are lists, calc now\n" + (debug:print-info 4 *default-log-port* "items and itemstable are lists, calc now\n" " items: " items " itemstable: " itemstable) (items:get-items-from-config tconfig)) (else #f)))) ;; not iterated @@ -145,50 +145,50 @@ (define (tests:get-waitons test-name all-tests-registry) (let* ((config (tests:get-testconfig test-name all-tests-registry 'return-procs))) (let ((instr (if config (config-lookup config "requirements" "waiton") (begin ;; No config means this is a non-existant test - (debug:print 0 "ERROR: non-existent required test \"" test-name "\"") + (debug:print 0 *default-log-port* "ERROR: non-existent required test \"" test-name "\"") (exit 1)))) (instr2 (if config (config-lookup config "requirements" "waitor") ""))) - (debug:print-info 8 "waitons string is " instr ", waitors string is " instr2) + (debug:print-info 8 *default-log-port* "waitons string is " instr ", waitors string is " instr2) (let ((newwaitons (string-split (cond ((procedure? instr) ;; here (let ((res (instr))) - (debug:print-info 8 "waiton procedure results in string " res " for test " test-name) + (debug:print-info 8 *default-log-port* "waiton procedure results in string " res " for test " test-name) res)) ((string? instr) instr) (else - ;; NOTE: This is actually the case of *no* waitons! ;; (debug:print 0 "ERROR: something went wrong in processing waitons for test " test-name) + ;; NOTE: This is actually the case of *no* waitons! ;; (debug:print 0 *default-log-port* "ERROR: something went wrong in processing waitons for test " test-name) "")))) (newwaitors (string-split (cond ((procedure? instr2) (let ((res (instr2))) - (debug:print-info 8 "waitor procedure results in string " res " for test " test-name) + (debug:print-info 8 *default-log-port* "waitor procedure results in string " res " for test " test-name) res)) ((string? instr2) instr2) (else - ;; NOTE: This is actually the case of *no* waitons! ;; (debug:print 0 "ERROR: something went wrong in processing waitons for test " test-name) + ;; NOTE: This is actually the case of *no* waitons! ;; (debug:print 0 *default-log-port* "ERROR: something went wrong in processing waitons for test " test-name) ""))))) (values ;; the waitons (filter (lambda (x) (if (hash-table-ref/default all-tests-registry x #f) #t (begin - (debug:print 0 "ERROR: test " test-name " has unrecognised waiton testname " x) + (debug:print 0 *default-log-port* "ERROR: test " test-name " has unrecognised waiton testname " x) #f))) newwaitons) (filter (lambda (x) (if (hash-table-ref/default all-tests-registry x #f) #t (begin - (debug:print 0 "ERROR: test " test-name " has unrecognised waiton testname " x) + (debug:print 0 *default-log-port* "ERROR: test " test-name " has unrecognised waiton testname " x) #f))) newwaitors) config))))) ;; given waiting-test that is waiting on waiton-test extend test-patt appropriately @@ -302,29 +302,29 @@ (waiver-rx (regexp "^(\\S+)\\s+(.*)$")) (diff-rule "diff %file1% %file2%") (logpro-rule "diff %file1% %file2% | logpro %waivername%.logpro %waivername%.html")) (if (not (file-exists? test-rundir)) (begin - (debug:print 0 "ERROR: test run directory is gone, cannot propagate waiver") + (debug:print 0 *default-log-port* "ERROR: test run directory is gone, cannot propagate waiver") #f) (begin (push-directory test-rundir) (let ((result (if (null? waivers) #f (let loop ((hed (car waivers)) (tal (cdr waivers))) - (debug:print 0 "INFO: Applying waiver rule \"" hed "\"") + (debug:print 0 *default-log-port* "INFO: Applying waiver rule \"" hed "\"") (let* ((waiver (configf:lookup testconfig "waivers" hed)) (wparts (if waiver (string-match waiver-rx waiver) #f)) (waiver-rule (if wparts (cadr wparts) #f)) (waiver-glob (if wparts (caddr wparts) #f)) (logpro-file (if waiver (let ((fname (conc hed ".logpro"))) (if (file-exists? fname) fname (begin - (debug:print 0 "INFO: No logpro file " fname " falling back to diff") + (debug:print 0 *default-log-port* "INFO: No logpro file " fname " falling back to diff") #f))) #f)) ;; if rule by name of waiver-rule is found in testconfig - use it ;; else if waivername.logpro exists use logpro-rule ;; else default to diff-rule @@ -332,21 +332,21 @@ (if rule rule (if logpro-file logpro-rule (begin - (debug:print 0 "INFO: No logpro file " logpro-file " found, using diff rule") + (debug:print 0 *default-log-port* "INFO: No logpro file " logpro-file " found, using diff rule") diff-rule))))) ;; (string-substitute "%file1%" "foofoo.txt" "This is %file1% and so is this %file1%." #t) (processed-cmd (string-substitute "%file1%" (conc test-rundir "/" waiver-glob) (string-substitute "%file2%" (conc prev-rundir "/" waiver-glob) (string-substitute "%waivername%" hed rule-string #t) #t) #t)) (res #f)) - (debug:print 0 "INFO: waiver command is \"" processed-cmd "\"") + (debug:print 0 *default-log-port* "INFO: waiver command is \"" processed-cmd "\"") (if (eq? (system processed-cmd) 0) (if (null? tal) #t (loop (car tal)(cdr tal))) #f)))))) @@ -377,11 +377,11 @@ (waived (if prev-test (if prev-test ;; true if we found a previous test in this run series (let ((prev-status (db:test-get-status prev-test)) (prev-state (db:test-get-state prev-test)) (prev-comment (db:test-get-comment prev-test))) - (debug:print 4 "prev-status " prev-status ", prev-state " prev-state ", prev-comment " prev-comment) + (debug:print 4 *default-log-port* "prev-status " prev-status ", prev-state " prev-state ", prev-comment " prev-comment) (if (and (equal? prev-state "COMPLETED") (equal? prev-status "WAIVED")) (if comment comment prev-comment) ;; waived is either the comment or #f @@ -390,11 +390,11 @@ #f))) (if (and waived (tests:check-waiver-eligibility testdat prev-test)) (set! real-status "WAIVED")) - (debug:print 4 "real-status " real-status ", waived " waived ", status " status) + (debug:print 4 *default-log-port* "real-status " real-status ", waived " waived ", status " status) ;; update the primary record IF state AND status are defined (if (and state status) (begin (rmt:test-set-status-state run-id test-id real-status state (if waived waived comment)) @@ -423,11 +423,11 @@ (expected (hash-table-ref/default otherdat ":expected" #f)) (tol (hash-table-ref/default otherdat ":tol" #f)) (units (hash-table-ref/default otherdat ":units" "")) (type (hash-table-ref/default otherdat ":type" "")) (dcomment (hash-table-ref/default otherdat ":comment" ""))) - (debug:print 4 + (debug:print 4 *default-log-port* "category: " category ", variable: " variable ", value: " value ", expected: " expected ", tol: " tol ", units: " units) (if (and value expected tol) ;; all three required (let ((dat (conc category "," variable "," @@ -465,15 +465,15 @@ (path (if logf-info (car logf-info) #f))) ;; This query finds the path and changes the directory to it for the test (if (and (string? path) (directory? path)) ;; can get #f here under some wierd conditions. why, unknown ... (begin - (debug:print 4 "Found path: " path) + (debug:print 4 *default-log-port* "Found path: " path) (change-directory path)) ;; (set! outputfilename (conc path "/" outputfilename))) - (debug:print 0 "ERROR: summarize-items for run-id=" run-id ", test-name=" test-name ", no such path: " path)) - (debug:print 4 "summarize-items with logf " logf ", outputfilename " outputfilename " and force " force) + (debug:print 0 *default-log-port* "ERROR: summarize-items for run-id=" run-id ", test-name=" test-name ", no such path: " path)) + (debug:print 4 *default-log-port* "summarize-items with logf " logf ", outputfilename " outputfilename " and force " force) (if (or (equal? logf "logs/final.log") (equal? logf outputfilename) force) (let ((my-start-time (current-seconds)) (lockf (conc outputfilename ".lock"))) @@ -494,11 +494,11 @@ ;; didn't get the lock, check to see if current update started later than this ;; update, if so we can exit without doing any work (if (> my-start-time (file-modification-time lockf)) ;; we started since current re-gen in flight, delay a little and try again (begin - (debug:print-info 1 "Waiting to update " outputfilename ", another test currently updating it") + (debug:print-info 1 *default-log-port* "Waiting to update " outputfilename ", another test currently updating it") (thread-sleep! (+ 5 (random 5))) ;; delay between 5 and 10 seconds (loop (common:simple-file-lock lockf)))))))))) (define (tests:generate-html-summary-for-iterated-test run-id test-id test-name outputfilename) (let ((counts (make-hash-table)) @@ -579,17 +579,17 @@ ;; (let ((steps (db:get-steps-for-test db test-id work-area: work-area))) ;; organise the steps for better readability (let ((res (make-hash-table))) (for-each (lambda (step) - (debug:print 6 "step=" step) + (debug:print 6 *default-log-port* "step=" step) (let ((record (hash-table-ref/default res (tdb:step-get-stepname step) - ;; stepname start end status Duration Logfile - (vector (tdb:step-get-stepname step) "" "" "" "" "")))) - (debug:print 6 "record(before) = " record + ;; stepname start end status Duration Logfile Comment + (vector (tdb:step-get-stepname step) "" "" "" "" "" "")))) + (debug:print 6 *default-log-port* "record(before) = " record "\nid: " (tdb:step-get-id step) "\nstepname: " (tdb:step-get-stepname step) "\nstate: " (tdb:step-get-state step) "\nstatus: " (tdb:step-get-status step) "\ntime: " (tdb:step-get-event_time step)) @@ -603,24 +603,28 @@ ((end) (vector-set! record 2 (any->number (tdb:step-get-event_time step))) (vector-set! record 3 (tdb:step-get-status step)) (vector-set! record 4 (let ((startt (any->number (vector-ref record 1))) (endt (any->number (vector-ref record 2)))) - (debug:print 4 "record[1]=" (vector-ref record 1) + (debug:print 4 *default-log-port* "record[1]=" (vector-ref record 1) ", startt=" startt ", endt=" endt ", get-status: " (tdb:step-get-status step)) (if (and (number? startt)(number? endt)) (seconds->hr-min-sec (- endt startt)) "-1"))) (if (> (string-length (tdb:step-get-logfile step)) 0) - (vector-set! record 5 (tdb:step-get-logfile step)))) + (vector-set! record 5 (tdb:step-get-logfile step))) + (if (> (string-length (tdb:step-get-comment step)) + 0) + (vector-set! record 6 (tdb:step-get-comment step)))) (else (vector-set! record 2 (tdb:step-get-state step)) (vector-set! record 3 (tdb:step-get-status step)) - (vector-set! record 4 (tdb:step-get-event_time step)))) + (vector-set! record 4 (tdb:step-get-event_time step)) + (vector-set! record 6 (tdb:step-get-comment step)))) (hash-table-set! res (tdb:step-get-stepname step) record) - (debug:print 6 "record(after) = " record + (debug:print 6 *default-log-port* "record(after) = " record "\nid: " (tdb:step-get-id step) "\nstepname: " (tdb:step-get-stepname step) "\nstate: " (tdb:step-get-state step) "\nstatus: " (tdb:step-get-status step) "\ntime: " (tdb:step-get-event_time step)))) @@ -631,17 +635,14 @@ ((eq? (tdb:step-get-event_time a)(tdb:step-get-event_time b)) (< (tdb:step-get-id a) (tdb:step-get-id b))) (else #f))))) res)) - -;; temporarily passing in dbstruct to support direct access (i.e. bypassing servers) +;; ;; -(define (tests:get-compressed-steps dbstruct run-id test-id) - (let* ((steps-data (if dbstruct - (db:get-steps-for-test dbstruct run-id test-id) - (rmt:get-steps-for-test run-id test-id))) +(define (tests:get-compressed-steps run-id test-id) + (let* ((steps-data (rmt:get-steps-for-test run-id test-id)) (comprsteps (tests:process-steps-table steps-data))) ;; (open-run-close db:get-steps-table #f test-id work-area: work-area))) (map (lambda (x) ;; take advantage of the \n on time->string (vector (vector-ref x 0) @@ -649,11 +650,12 @@ (if (number? s)(seconds->time-string s) s)) (let ((s (vector-ref x 2))) (if (number? s)(seconds->time-string s) s)) (vector-ref x 3) ;; status (vector-ref x 4) - (vector-ref x 5))) ;; time delta + (vector-ref x 5) ;; time delta + (vector-ref x 6))) (sort (hash-table-values comprsteps) (lambda (a b) (let ((time-a (vector-ref a 1)) (time-b (vector-ref b 1))) (if (and (number? time-a)(number? time-b)) @@ -675,11 +677,11 @@ (full-name (db:test-make-full-name test-name item-path)) (oup (open-output-file (conc (db:test-get-rundir test-dat) "/test-summary.html"))) (status (db:test-get-status test-dat)) (color (common:get-color-from-status status)) (logf (db:test-get-final_logf test-dat)) - (steps-dat (tests:get-compressed-steps #f run-id test-id))) + (steps-dat (tests:get-compressed-steps run-id test-id))) ;; (dcommon:get-compressed-steps #f 1 30045) ;; (#("wasting_time" "23:36:13" "23:36:21" "0" "8.0s" "wasting_time.log")) (s:output-new oup @@ -753,22 +755,23 @@ ;; (map (lambda (testp) ;; (last (string-split testp "/"))) ;; tests))))) (define (tests:get-test-path-from-environment) - (and (getenv "MT_LINKTREE") - (getenv "MT_TARGET") - (getenv "MT_RUNNAME") - (getenv "MT_TEST_NAME") - (getenv "MT_ITEMPATH") - (conc (getenv "MT_LINKTREE") "/" - (getenv "MT_TARGET") "/" - (getenv "MT_RUNNAME") "/" - (getenv "MT_TEST_NAME") "/" - (if (or (getenv "MT_ITEMPATH") - (not (string=? "" (getenv "MT_ITEMPATH")))) - (conc "/" (getenv "MT_ITEMPATH")))))) + (if (and (getenv "MT_LINKTREE") + (getenv "MT_TARGET") + (getenv "MT_RUNNAME") + (getenv "MT_TEST_NAME") + (getenv "MT_ITEMPATH")) + (conc (getenv "MT_LINKTREE") "/" + (getenv "MT_TARGET") "/" + (getenv "MT_RUNNAME") "/" + (getenv "MT_TEST_NAME") "/" + (if (or (getenv "MT_ITEMPATH") + (not (string=? "" (getenv "MT_ITEMPATH")))) + (conc "/" (getenv "MT_ITEMPATH")))) + #f)) ;; if .testconfig exists in test directory read and return it ;; else if have cached copy in *testconfigs* return it IFF there is a section "have fulldata" ;; else read the testconfig file ;; if have path to test directory save the config as .testconfig and return it @@ -803,27 +806,27 @@ (read-config test-configf #f system-allowed environ-patt: (if system-allowed "pre-launch-env-vars" #f)) #f))) - (if cache-file (hash-table-set! tcfg "have fulldata" #t)) ;; mark this as fully read data + (if (and tcfg cache-file) (hash-table-set! tcfg "have fulldata" #t)) ;; mark this as fully read data (if tcfg (hash-table-set! *testconfigs* test-name tcfg)) (if (and testexists cache-file (file-write-access? cache-path)) (let ((tpath (conc cache-path "/.testconfig"))) - (debug:print-info 1 "Caching testconfig for " test-name " in " tpath) + (debug:print-info 1 *default-log-port* "Caching testconfig for " test-name " in " tpath) (configf:write-alist tcfg tpath))) tcfg)))))) ;; sort tests by priority and waiton ;; Move test specific stuff to a test unit FIXME one of these days (define (tests:sort-by-priority-and-waiton test-records) (let* ((mungepriority (lambda (priority) (if priority (let ((tmp (any->number priority))) - (if tmp tmp (begin (debug:print 0 "ERROR: bad priority value " priority ", using 0") 0))) + (if tmp tmp (begin (debug:print 0 *default-log-port* "ERROR: bad priority value " priority ", using 0") 0))) 0))) (all-tests (hash-table-keys test-records)) (all-waited-on (let loop ((hed (car all-tests)) (tal (cdr all-tests)) (res '())) @@ -844,35 +847,35 @@ (b-raw-pri (config-lookup b-config "requirements" "priority")) (a-priority (mungepriority a-raw-pri)) (b-priority (mungepriority b-raw-pri))) (tests:testqueue-set-priority! a-record a-priority) (tests:testqueue-set-priority! b-record b-priority) - ;; (debug:print 0 "a=" a ", b=" b ", a-waitons=" a-waitons ", b-waitons=" b-waitons) + ;; (debug:print 0 *default-log-port* "a=" a ", b=" b ", a-waitons=" a-waitons ", b-waitons=" b-waitons) (cond ;; is ((member a b-waitons) ;; is b waiting on a? - ;; (debug:print 0 "case1") + ;; (debug:print 0 *default-log-port* "case1") #t) ((member b a-waitons) ;; is a waiting on b? - ;; (debug:print 0 "case2") + ;; (debug:print 0 *default-log-port* "case2") #f) ((and (not (null? a-waitons)) ;; both have waitons - do not disturb (not (null? b-waitons))) - ;; (debug:print 0 "case2.1") + ;; (debug:print 0 *default-log-port* "case2.1") #t) ((and (null? a-waitons) ;; no waitons for a but b has waitons (not (null? b-waitons))) - ;; (debug:print 0 "case3") + ;; (debug:print 0 *default-log-port* "case3") #f) ((and (not (null? a-waitons)) ;; a has waitons but b does not (null? b-waitons)) - ;; (debug:print 0 "case4") + ;; (debug:print 0 *default-log-port* "case4") #t) ((not (eq? a-priority b-priority)) ;; use (> a-priority b-priority)) (else - ;; (debug:print 0 "case5") + ;; (debug:print 0 *default-log-port* "case5") (string>? a b)))))) (sort-fn2 (lambda (a b) (> (mungepriority (tests:testqueue-get-priority (hash-table-ref test-records a))) @@ -1029,38 +1032,38 @@ ;; test-records is a hash of test-name => test record (define (tests:get-full-data test-names test-records required-tests all-tests-registry) (if (not (null? test-names)) (let loop ((hed (car test-names)) (tal (cdr test-names))) ;; 'return-procs tells the config reader to prep running system but return a proc - (debug:print-info 4 "hed=" hed " at top of loop") + (debug:print-info 4 *default-log-port* "hed=" hed " at top of loop") (let* ((config (tests:get-testconfig hed all-tests-registry 'return-procs)) (waitons (let ((instr (if config (config-lookup config "requirements" "waiton") (begin ;; No config means this is a non-existant test - (debug:print 0 "ERROR: non-existent required test \"" hed "\", grep through your testconfigs to find and remove or create the test. Discarding and continuing.") + (debug:print 0 *default-log-port* "ERROR: non-existent required test \"" hed "\", grep through your testconfigs to find and remove or create the test. Discarding and continuing.") "")))) - (debug:print-info 8 "waitons string is " instr) + (debug:print-info 8 *default-log-port* "waitons string is " instr) (string-split (cond ((procedure? instr) (let ((res (instr))) - (debug:print-info 8 "waiton procedure results in string " res " for test " hed) + (debug:print-info 8 *default-log-port* "waiton procedure results in string " res " for test " hed) res)) ((string? instr) instr) (else - ;; NOTE: This is actually the case of *no* waitons! ;; (debug:print 0 "ERROR: something went wrong in processing waitons for test " hed) + ;; NOTE: This is actually the case of *no* waitons! ;; (debug:print 0 *default-log-port* "ERROR: something went wrong in processing waitons for test " hed) "")))))) (if (not config) ;; this is a non-existant test called in a waiton. (if (null? tal) test-records (loop (car tal)(cdr tal))) (begin - (debug:print-info 8 "waitons: " waitons) + (debug:print-info 8 *default-log-port* "waitons: " waitons) ;; check for hed in waitons => this would be circular, remove it and issue an ;; error (if (member hed waitons) (begin - (debug:print 0 "ERROR: test " hed " has listed itself as a waiton, please correct this!") + (debug:print 0 *default-log-port* "ERROR: test " hed " has listed itself as a waiton, please correct this!") (set! waitons (filter (lambda (x)(not (equal? x hed))) waitons)))) ;; (items (items:get-items-from-config config))) (if (not (hash-table-ref/default test-records hed #f)) (hash-table-set! test-records @@ -1074,23 +1077,23 @@ ;; process can know to call items:get-items-from-config ;; if either is a list and none is a proc go ahead and call get-items ;; otherwise return #f - this is not an iterated test (cond ((procedure? items) - (debug:print-info 4 "items is a procedure, will calc later") + (debug:print-info 4 *default-log-port* "items is a procedure, will calc later") items) ;; calc later ((procedure? itemstable) - (debug:print-info 4 "itemstable is a procedure, will calc later") + (debug:print-info 4 *default-log-port* "itemstable is a procedure, will calc later") itemstable) ;; calc later ((filter (lambda (x) (let ((val (car x))) (if (procedure? val) val #f))) (append (if (list? items) items '()) (if (list? itemstable) itemstable '()))) 'have-procedure) ((or (list? items)(list? itemstable)) ;; calc now - (debug:print-info 4 "items and itemstable are lists, calc now\n" + (debug:print-info 4 *default-log-port* "items and itemstable are lists, calc now\n" " items: " items " itemstable: " itemstable) (items:get-items-from-config config)) (else #f))) ;; not iterated #f ;; itemsdat 5 #f ;; spare - used for item-path @@ -1155,20 +1158,20 @@ (handle-exceptions exn (if (> remtries 0) (begin (print-call-chain (current-error-port)) - (debug:print-info 0 "WARNING: failed to set meta info. Will try " remtries " more times") + (debug:print-info 0 *default-log-port* "WARNING: failed to set meta info. Will try " remtries " more times") (set! remtries (- remtries 1)) (thread-sleep! 10) (tests:set-full-meta-info db test-id run-id minutes work-area (- remtries 1))) (let ((err-status ((condition-property-accessor 'sqlite3 'status #f) exn))) - (debug:print 0 "ERROR: tried for over a minute to update meta info and failed. Giving up") - (debug:print 0 "EXCEPTION: database probably overloaded or unreadable.") - (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 *default-log-port* "ERROR: tried for over a minute to update meta info and failed. Giving up") + (debug:print 0 *default-log-port* "EXCEPTION: database probably overloaded or unreadable.") + (debug:print 0 *default-log-port* " 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 *default-log-port* " status: " ((condition-property-accessor 'sqlite3 'status) exn)) (print-call-chain (current-error-port)))) (tests:update-testdat-meta-info db test-id work-area cpuload diskfree minutes) ))) ;;====================================================================== Index: tests/Makefile ================================================================== --- tests/Makefile +++ tests/Makefile @@ -21,11 +21,11 @@ NEWTARGET = "$(OS)/$(FS)/$(VER)" TARGET = "ubuntu/nfs/none" all : build unit test1 test2 test3 test4 test5 test6 test7 test8 test9 -unit : basicserver.log runs.log misc.log +unit : basicserver.log runs.log misc.log tests.log rel : cd release;dashboard -rows 25 & ## basicserver.log : unittests/basicserver.scm Index: tests/rununittest.sh ================================================================== --- tests/rununittest.sh +++ tests/rununittest.sh @@ -13,8 +13,9 @@ dbdir=$(cd simplerun;megatest -show-config -section setup -var linktree)/.db rm -f simplerun/megatest.db simplerun/monitor.db simplerun/db/monitor.db $dbdir/*.db rm -rf simplelinks/ simpleruns/ simplerun/db/ $dbdir mkdir -p simplelinks simpleruns (cd simplerun;cp ../../*_records.scm .;perl -pi.bak -e 's/define-inline/define/' *_records.scm) +(cd simplerun;cp ../../altdb.scm .) # Run the test $1 is the unit test to run cd simplerun;echo '(load "../tests.scm")' | ../../bin/megatest -repl -debug $2 $1 Index: tests/unittests/basicserver.scm ================================================================== --- tests/unittests/basicserver.scm +++ tests/unittests/basicserver.scm @@ -7,11 +7,11 @@ ;; ./rununittest.sh server 1;(cd simplerun;megatest -stop-server 0) (delete-file* "logs/1.log") (define run-id 1) -(test "setup for run" #t (begin (launch:setup-for-run) +(test "setup for run" #t (begin (launch:setup) (string? (getenv "MT_RUN_AREA_HOME")))) ;; NON Server tests go here (test #f #f (db:dbdat-get-path *db*)) @@ -179,11 +179,11 @@ ;; ;; (test "launch server" #t (let ((pid (process-fork (lambda () ;; ;; ;; (daemon:ize) ;; ;; (server:launch 'http))))) ;; ;; (set! server-pid pid) ;; ;; (number? pid))) -;; (system "../../bin/megatest -server - -debug 22 > server.log 2> server.log &") +;; (system "../../bin/megatest -server - -debugbcom 22 > server.log 2> server.log &") ;; ;; (let loop ((n 10)) ;; (thread-sleep! 1) ;; need to wait for server to start. ;; (let ((res (open-run-close tasks:get-best-server tasks:open-db))) ;; (print "tasks:get-best-server returned " res) Index: tests/unittests/tests.scm ================================================================== --- tests/unittests/tests.scm +++ tests/unittests/tests.scm @@ -1,13 +1,80 @@ -;;====================================================================== -;; itemwait, itemmatch - -(db:compare-itempaths ref-item-path item-path itemmap) - -;; prereqs-not-met - -(rmt:get-prereqs-not-met run-id waitons item-path mode: testmode itemmap: itemmap)) - - (fails (runs:calc-fails prereqs-not-met)) - (prereq-fails (runs:calc-prereq-fail prereqs-not-met)) - (non-completed (runs:calc-not-completed prereqs-not-met)) - (runnables (runs:calc-runnable prereqs-not-met))) +;; ;;====================================================================== +;; ;; itemwait, itemmatch +;; +;; (db:compare-itempaths ref-item-path item-path itemmap) +;; +;; ;; prereqs-not-met +;; +;; (rmt:get-prereqs-not-met run-id waitons item-path mode: testmode itemmap: itemmap)) +;; +;; (fails (runs:calc-fails prereqs-not-met)) +;; (prereq-fails (runs:calc-prereq-fail prereqs-not-met)) +;; (non-completed (runs:calc-not-completed prereqs-not-met)) +;; (runnables (runs:calc-runnable prereqs-not-met))) +;; +;; +;; + +(define user (current-user-name)) +(define runname "mytestrun") +(define keys (rmt:get-keys)) +(define runinfo #f) +(define keyvals '(("SYSTEM" "abc")("RELEASE" "def"))) +(define header (list "SYSTEM" "RELEASE" "id" "runname" "state" "status" "owner" "event_time")) +(define run-id 1) + +;; Create a run +(test #f 1 (rmt:register-run keyvals runname "new" "n/a" user)) +(test #f #t (rmt:general-call 'register-test run-id run-id "test-one" "")) +(test #f #t (rmt:general-call 'register-test run-id run-id "test-two" "")) +(test #f #t (rmt:general-call 'register-test run-id run-id "test-three" "")) +(test #f #t (rmt:general-call 'register-test run-id run-id "test-four" "")) + +(rmt:test-set-state-status-by-id run-id (rmt:get-test-id run-id "test-one" "") "COMPLETED" "FAIL" "") +(rmt:test-set-state-status-by-id run-id (rmt:get-test-id run-id "test-two" "") "COMPLETED" "PASS" "") +(rmt:test-set-state-status-by-id run-id (rmt:get-test-id run-id "test-three" "") "RUNNING" "n/a" "") +(rmt:test-set-state-status-by-id run-id (rmt:get-test-id run-id "test-four" "") "COMPLETED" "WARN" "") + +(print "MODE=not in") +(test #f '() + (filter + (lambda (y) + (equal? y "FAIL")) ;; any FAIL in the output list? + (map + (lambda (x)(vector-ref x 4)) + (rmt:get-tests-for-run run-id "%/%" '() '("FAIL") #f #f #t 'event_time "DESC" 'shortlist 0 'dashboard)))) + +(print "MODE=in") +(test #f '("FAIL") + (map + (lambda (x)(vector-ref x 4)) + (rmt:get-tests-for-run run-id "%/%" '() '("FAIL") #f #f #f 'event_time "DESC" 'shortlist 0 'dashboard))) +(set! *verbosity* 1) + +(print "MODE=in, state in RUNNING") +;; (set! *verbosity* 8) +(test #f '("RUNNING") + (map + (lambda (x)(vector-ref x 3)) + (rmt:get-tests-for-run run-id "%/%" '("RUNNING") '() #f #f #f 'event_time "DESC" 'shortlist 0 'dashboard))) +(set! *verbosity* 1) + +(print "MODE=in, state in RUNNING and status IN WARN") +;; (set! *verbosity* 8) +(test #f '(("RUNNING" . "n/a") ("COMPLETED" . "WARN")) + (map + (lambda (x) + (cons (vector-ref x 3)(vector-ref x 4))) + (rmt:get-tests-for-run run-id "%/%" '("RUNNING") '("WARN") #f #f #f 'event_time "DESC" 'shortlist 0 'dashboard))) +(set! *verbosity* 1) + +(print "MODE=not in, state in RUNNING and status IN WARN") +(set! *verbosity* 8) +(test #f '(("DELETED" . "n/a") ("COMPLETED" . "PASS") ("COMPLETED" . "FAIL")) + (map + (lambda (x) + (cons (vector-ref x 3)(vector-ref x 4))) + (rmt:get-tests-for-run run-id "%/%" '("RUNNING") '("WARN") #f #f #t 'event_time "DESC" 'shortlist 0 'dashboard))) +(set! *verbosity* 1) + +(exit) ADDED utils/Makefile.git.installall Index: utils/Makefile.git.installall ================================================================== --- /dev/null +++ utils/Makefile.git.installall @@ -0,0 +1,334 @@ + +# Copyright 2013-2015 Matthew Welland. +# +# This program is made available under the GNU GPL version 2.0 or +# greater. See the accompanying file COPYING for details. +# +# This program is distributed WITHOUT ANY WARRANTY; without even the +# implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR +# PURPOSE. + +help : + @echo You may need to do the following setup first: + @echo + @echo sudo apt-get install libreadline-dev + @echo sudo apt-get install libwebkitgtk-dev libfreetype6-dev libx11-dev libxpm-dev libxmu-dev \ + libxft-dev libgtk2.0-dev libgl1-mesa-dev libglu1-mesa-dev libpangox-1.0-dev bison \ + libwebkitgtk-3.0-dev + @echo -- nb// adding monodevelop gets more packages of which some might be needed... + @echo sudo apt-get install libmotif3 + @echo + @echo Set up your PATH, setting it in the Makefile does not work as expected + @echo export PATH=$(PREFIX)/bin:\$$PATH + @echo + @echo For IUP set IUPBRANCH, currently $(IUPBRANCH) + @echo set IUPCONFIG, currently $(IUPCONFIG) - look in https://www.kiatoa.com/fossils/iuplib for .inc files + @echo You are using PREFIX=$(PREFIX) + @echo You are using PRODCHICKEN=$(PRODCHICKEN) + @echo You are using PROXY="$(PROXY)" + @echo If needed set PROXY to host.dom:port + @echo http_proxy=$(http_proxy) + @echo + @echo To make all do: make all + @echo make minimal: make nogui + @echo + @echo Note: If compiling on amd64 do CSC_OPTIONS=\'-C "-fPIC"\' make all IUPCONFIG= + +FPIC=-C "-fPIC" + +# Put the installation here +ifeq ($(PREFIX),) +PREFIX=$(PWD)/target +endif +ifeq ($(PRODCHICKEN),) +PRODCHICKEN=$(PREFIX)/prod-chicken/ +endif +# Set this on the command line of your make call if needed: make PROXY=host.com:1234 +PROXY= + +# http://code.call-cc.org/dev-snapshots/2015/06/07/chicken-4.10.0rc1.tar.gz +# http://code.call-cc.org/releases/4.10.0/chicken-4.10.0.tar.gz +# Select version of chicken, sqlite3 etc +CHICKEN_VERSION=4.10.1 +SQLITE3_VERSION=3090200 +# http://www.sqlite.org/2014/sqlite-autoconf-3080500.tar.gz +# http://www.sqlite.org/2015/sqlite-autoconf-3081101.tar.gz +# Override IUPBRANCH to use other than trunk +IUPBRANCH=trunk +IUPCONFIG=ubuntu-15.04.inc +# iup-3.15 + +# 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 \ + spiffy-directory-listing ssax sxml-serializer sxml-modifications sql-de-lite \ + srfi-19 refdb ini-file sparse-vectors z3 call-with-environment-variables hahn linenoise \ + crypt parley + +# +# Derived variables +# + +ifeq ($(PROXY),) +PROX:= +else +http_proxy:=http://$(PROXY) +PROX:=-proxy $(PROXY) +endif + +BUILDHOME=$(PWD) +PATH:=$(PREFIX)/bin:$(PATH) +LIBPATH=$(PREFIX)/lib$(ADDITIONAL_LIBPATH) +LD_LIBRARY_PATH=$(LIBPATH) +CHICKEN_INSTALL=$(PREFIX)/bin/chicken-install +CHICKEN_EGG_DIR=$(PREFIX)/lib/chicken/7 + +VPATH=$(CHICKEN_EGG_DIR):$(PWD)/eggflags + +vpath %.so $(CHICKEN_EGG_DIR) +vpath %.flag eggflags + +EGGSOFILES=$(addprefix $(CHICKEN_EGG_DIR)/,$(addsuffix .so,$(EGGS))) +EGGFLAGS=$(addprefix eggflags/,$(addsuffix .flag,$(EGGS))) + +# Stuff needed for IUP +ISARCHX86_64=$(shell uname -a | grep x86_64) +ifeq ($(ISARCHX86_64),) +ARCHSIZE= +else +ARCHSIZE=64_ +endif + +CSCLIBS=$(shell echo $(LD_LIBRARY_PATH) | sed 's/:/ -L/g') +CSC_OPTIONS="-I$(PREFIX)/include -L$(CSCLIBS) -C \"-fPIC\"" +# CSC_OPTIONS=-I $(PREFIX)/include -L $(CSCLIBS) + +nogui : base mutils + +#all : nogui libiup $(PREFIX)/lib/sqlite3.so +all : nogui libiup + +base : chkn eggs + +# stuff needed for Kiatoa and Megatest from matts miscellaneous stash +# NOTE TO SELF: eggifying these would be great... +mutils : base logprobin $(PREFIX)/bin/hs \ + $(PREFIX)/lib/chicken/7/mutils.so \ + $(PREFIX)/lib/chicken/7/dbi.so \ + $(PREFIX)/lib/chicken/7/stml.so \ + $(PREFIX)/lib/chicken/7/margs.so + +chkn : $(CHICKEN_INSTALL) + +eggs : $(EGGSOFILES) + +# libiup : $(PREFIX)/lib/libavcall.a +libiup : $(CHICKEN_EGG_DIR)/iup.so $(CHICKEN_EGG_DIR)/canvas-draw.so + +logprobin : $(PREFIX)/bin/logpro + +$(PREFIX)/bin/logpro : $(CHICKEN_EGG_DIR)/regex-literals.so + $(CHICKEN_INSTALL) logpro + +# Silly rule to make installing eggs more makeish, I don't understand why I need the basename +$(CHICKEN_EGG_DIR)/%.so : eggflags/%.flag + $(CHICKEN_INSTALL) $(PROX) -keep-installed $(shell basename $*) + +$(EGGFLAGS) : # $(CHICKEN_INSTALL) + mkdir -p eggflags + touch $(EGGFLAGS) + +# some setup stuff +# +$(PREFIX)/setup-chicken4x.sh : $(EGGFLAGS) + mkdir -p $(PREFIX) + (echo 'export PATH=$(PREFIX)/bin:$$PATH' > $(PREFIX)/setup-chicken4x.sh) + (echo "export LD_LIBRARY_PATH=$(LD_LIBRARY_PATH)" >> $(PREFIX)/setup-chicken4x.sh) + +$(PREFIX)/setup-chicken4x.csh : $(EGGFLAGS) + mkdir -p $(PREFIX) + (echo "setenv PATH $(PREFIX):'$$'PATH" > $(PREFIX)/setup-chicken4x.csh) + (echo "setenv LD_LIBRARY_PATH $(LD_LIBRARY_PATH)" >> $(PREFIX)/setup-chicken4x.csh) + +chicken-core/chicken.scm : chicken-$(CHICKEN_VERSION).tar.gz + #tar xf chicken-$(CHICKEN_VERSION).tar.gz + #ln -sf chicken-$(CHICKEN_VERSION) chicken-core + echo "Hello from chicken" + +chicken-4.9.0rc1.tar.gz : + wget http://code.call-cc.org/dev-snapshots/2014/04/17/chicken-4.9.0rc1.tar.gz + +chicken-4.9.0.1.tar.gz : + wget http://code.call-cc.org/releases/4.9.0/chicken-4.9.0.1.tar.gz + +chicken-4.10.0rc1.tar.gz : + wget http://code.call-cc.org/dev-snapshots/2015/06/07/chicken-4.10.0rc1.tar.gz + +chicken-4.10.0.tar.gz : + wget http://code.call-cc.org/releases/4.10.0/chicken-4.10.0.tar.gz + +chicken-4.10.1.tar.gz : + fossil clone https://www.kiatoa.com/fossils/chicken-core chicken-scheme.fossil + mkdir -p chicken-core + cd chicken-core; pwd + cd chicken-core; fossil open ../chicken-scheme.fossil + cd chicken-core; fossil up 337f5be +# wget http://code.call-cc.org/dev-snapshots/2015/08/29/chicken-4.10.1.tar.gz + +# git clone git://code.call-cc.org/chicken-core +# git clone http://code.call-cc.org/git/chicken-core.git + +$(PRODCHICKEN)/bin/chicken : + wget http://code.call-cc.org/dev-snapshots/2015/08/29/chicken-4.10.1.tar.gz + tar -xzvf chicken-4.10.1.tar.gz + cd chicken-4.10.1/; make PLATFORM=linux PREFIX=$(PRODCHICKEN) + cd chicken-4.10.1/; make PLATFORM=linux PREFIX=$(PRODCHICKEN) install + rm -rfv chicken-4.10.1/ + +$(CHICKEN_INSTALL) : chicken-core/chicken.scm $(PREFIX)/setup-chicken4x.sh $(PREFIX)/setup-chicken4x.csh $(PRODCHICKEN)/bin/chicken + cd chicken-core; LD_LIBRARY_PATH=$(PRODCHICKEN) make PLATFORM=linux CHICKEN=$(PRODCHICKEN)/bin/chicken PREFIX=$(PREFIX) + cd chicken-core; LD_LIBRARY_PATH=$(PRODCHICKEN) make PLATFORM=linux CHICKEN=$(PRODCHICKEN)/bin/chicken PREFIX=$(PREFIX) install + +#====================================================================== +# S Q L I T E 3 +#====================================================================== +# https://www.sqlite.org/2015/sqlite-autoconf-3090200.tar.gz +sqlite-autoconf-$(SQLITE3_VERSION).tar.gz : + wget http://www.sqlite.org/2015/sqlite-autoconf-$(SQLITE3_VERSION).tar.gz + +sqlite-autoconf-$(SQLITE3_VERSION)/config.log : sqlite-autoconf-$(SQLITE3_VERSION).tar.gz + tar xf sqlite-autoconf-$(SQLITE3_VERSION).tar.gz + +$(PREFIX)/bin/sqlite3 : sqlite-autoconf-$(SQLITE3_VERSION)/config.log + cd sqlite-autoconf-$(SQLITE3_VERSION);./configure --prefix=$(PREFIX);make;make install + +$(CHICKEN_EGG_DIR)/sqlite3.so : $(PREFIX)/bin/sqlite3 + CSC_OPTIONS="-I$(PREFIX)/include -L$(PREFIX)/lib" $(CHICKEN_INSTALL) $(PROX) sqlite3 + +#====================================================================== +# N A N O M S G +#====================================================================== + +# https://github.com/nanomsg/nanomsg/releases/download/0.6-beta/nanomsg-0.6-beta.tar.gz +# https://github.com/nanomsg/nanomsg/releases/download/0.8-beta/nanomsg-0.8-beta.tar.gz + +nanomsg-0.6-beta.tar.gz : + wget http://download.nanomsg.org/nanomsg-0.6-beta.tar.gz + +nanomsg-0.6-beta/COPYING : nanomsg-0.6-beta.tar.gz + tar xf nanomsg-0.6-beta.tar.gz + +$(PREFIX)/bin/nanocat : nanomsg-0.6-beta/COPYING + cd nanomsg-0.6-beta;./configure --prefix=$(PREFIX);make;make install + +$(PREFIX)/lib/nanomsg.so : $(PREFIX)/bin/nanocat + CSC_OPTIONS="-I$(PREFIX)/include -L$(PREFIX)/lib" $(CHICKEN_INSTALL) $(PROX) nanomsg + +# LD_LIBRARY_PATH=/mfs/pkgs/chicken/4.10.0-amd64/lib CSC_OPTIONS="-I/mfs/pkgs/chicken/4.10.0-amd64/include -L/mfs/pkgs/chicken/4.10.0-amd64/lib -C \"-fPIC\"" /mfs/pkgs/chicken/4.10.0-amd64/bin/chicken-install -D no-library-checks nanomsg + +#====================================================================== +# M A T T S U T I L S +#====================================================================== + +# opensrc + +opensrc.fossil : + fossil clone http://www.kiatoa.com/fossils/opensrc opensrc.fossil + +opensrc/histstore/histstore.scm : opensrc.fossil + mkdir -p opensrc + cd opensrc;if [ -e .fslckout ];then fossil update; else fossil open ../opensrc.fossil; fi + +$(PREFIX)/lib/chicken/7/mutils.so : opensrc/histstore/histstore.scm + cd opensrc/mutils;chicken-install + +$(PREFIX)/lib/chicken/7/dbi.so : opensrc/dbi/dbi.scm + cd opensrc/dbi; sed -i -e 's/.*postgres.*/;;commented out/g' dbi.scm; chicken-install + +$(PREFIX)/lib/chicken/7/margs.so : opensrc/margs/margs.scm + cd opensrc/margs;chicken-install + +opensrc/histstore/hs : opensrc/histstore/histstore.scm chkn eggs $(CHICKEN_EGG_DIR)/sqlite3.so + cd opensrc/histstore;$(PREFIX)/bin/csc histstore.scm -o hs + +$(PREFIX)/bin/hs : opensrc/histstore/hs + cp -f opensrc/histstore/hs $(PREFIX)/bin/hs + +# stml +stml.fossil : + fossil clone http://www.kiatoa.com/fossils/stml stml.fossil + +# open touches the .fossil :( +stml/requirements.scm.template : stml.fossil + mkdir -p stml + cd stml;if [ -e .fslckout ];then fossil update; else fossil open ../stml.fossil;fi + +stml/requirements.scm : stml/requirements.scm.template + cp stml/install.cfg.template stml/install.cfg + cp stml/requirements.scm.template stml/requirements.scm + +$(PREFIX)/lib/chicken/7/stml.so : stml/requirements.scm + cd stml; sed -i -e "s#.*TARGDIR.*#TARGDIR=$(PREFIX)/bin#g" install.cfg + cd stml;CSC_OPTIONS='-C "-fPIC"' make + +#====================================================================== +# F F C A L L (Used by IUP) +#====================================================================== + +ffcall.fossil : + fossil clone http://www.kiatoa.com/fossils/ffcall ffcall.fossil + +ffcall/README : ffcall.fossil + mkdir -p ffcall + cd ffcall && if [ -e README ];then fossil update; else fossil open ../ffcall.fossil; fi + +# NOTE: This worked fine *without* the enable-shared +# +$(PREFIX)/lib/libavcall.a : ffcall/README + cd ffcall;./configure --prefix=$(PREFIX) --enable-shared && make CC="gcc -fPIC" && make install + +#====================================================================== +# I U P +#====================================================================== + +iuplib.fossil : + #fossil clone http://www.kiatoa.com/fossils/iuplib iuplib.fossil + touch iuplib.fossil +iup/installall.sh : iuplib.fossil $(PREFIX)/lib/libiup.so + mkdir -p iup + pwd + wget -c --no-check-certificate http://sourceforge.net/projects/canvasdraw/files/5.9/Linux%20Libraries/cd-5.9_Linux26g4_64_lib.tar.gz/download + wget -c --no-check-certificate http://sourceforge.net/projects/iup/files/3.17/Linux%20Libraries/iup-3.17_Linux26g4_64_lib.tar.gz/download + wget -c --no-check-certificate http://sourceforge.net/projects/imtoolkit/files/3.10/Linux%20Libraries/im-3.10_Linux26g4_64_lib.tar.gz/download + #wget -c http://sourceforge.net/projects/luabinaries/files/5.3.2/Linux%20Libraries/lua-5.3.2_Linux26g4_64_lib.tar.gz/download + tar -xzvf cd-5.9_Linux26g4_64_lib.tar.gz -C iup/ + tar -xzvf im-3.10_Linux26g4_64_lib.tar.gz -C iup/ + tar -xzvf iup-3.17_Linux26g4_64_lib.tar.gz -C iup/ + mkdir -p $(PREFIX)/include/ $(PREFIX)/lib/ + cp iup/include/* $(PREFIX)/include/ + cp iup/*.so $(PREFIX)/lib/ + cp iup/*.a $(PREFIX)/lib/ + +# cd iup && if [ -e makeall.sh ];then fossil update $(IUPBRANCH); else fossil open ../iuplib.fossil;fossil update $(IUPBRANCH); fi + +#iup/alldone : iup/makeall.sh $(PREFIX)/include/iup.h $(PREFIX)/lib/libiup.so +# cd iup && ./makeall.sh $(IUPCONFIG) + +$(PREFIX)/lib/libiup.so $(PREFIX)/include/iup.h : iup/installall.sh +# cd iup && ./makeall.sh $(IUPCONFIG) + +# $(PREFIX)/lib/libiup.so : iup/iup/alldone +# touch -c $(PREFIX)/lib/libiup.so + +$(CHICKEN_EGG_DIR)/iup.so : $(PREFIX)/lib/libiup.so $(PREFIX)/lib/libavcall.a + LD_LIBRARY_PATH=$(LD_LIBRARY_PATH) CSC_OPTIONS=$(CSC_OPTIONS) $(CHICKEN_INSTALL) $(PROX) -D no-library-checks -feature disable-iup-web iup + +# -feature disable-iup-web + +$(CHICKEN_EGG_DIR)/canvas-draw.so : $(PREFIX)/lib/libiup.so $(PREFIX)/lib/libavcall.a + CSC_OPTIONS=$(CSC_OPTIONS) $(CHICKEN_INSTALL) $(PROX) -D no-library-checks canvas-draw + + +clean : + rm -rf chicken-4.8.0 eggflags ffcall sqlite-autoconf-$(SQLITE3_VERSION) Index: utils/Makefile.installall ================================================================== --- utils/Makefile.installall +++ utils/Makefile.installall @@ -44,11 +44,12 @@ PROXY= # http://code.call-cc.org/dev-snapshots/2015/06/07/chicken-4.10.0rc1.tar.gz # http://code.call-cc.org/releases/4.10.0/chicken-4.10.0.tar.gz # Select version of chicken, sqlite3 etc -CHICKEN_VERSION=4.10.0 +# CHICKEN_VERSION=4.10.0 +CHICKEN_VERSION=4.11.0rc2 SQLITE3_VERSION=3090200 # http://www.sqlite.org/2014/sqlite-autoconf-3080500.tar.gz # http://www.sqlite.org/2015/sqlite-autoconf-3081101.tar.gz # Override IUPBRANCH to use other than trunk IUPBRANCH=trunk @@ -56,14 +57,14 @@ # iup-3.15 # 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 \ + json md5 awful http-client spiffy uri-common intarweb spiffy-request-vars pathname-expand \ spiffy-directory-listing ssax sxml-serializer sxml-modifications sql-de-lite \ srfi-19 refdb ini-file sparse-vectors z3 call-with-environment-variables hahn linenoise \ - crypt + crypt parley # # Derived variables # @@ -77,11 +78,11 @@ BUILDHOME=$(PWD) PATH:=$(PREFIX)/bin:$(PATH) LIBPATH=$(PREFIX)/lib$(ADDITIONAL_LIBPATH) LD_LIBRARY_PATH=$(LIBPATH) CHICKEN_INSTALL=$(PREFIX)/bin/chicken-install -CHICKEN_EGG_DIR=$(PREFIX)/lib/chicken/7 +CHICKEN_EGG_DIR=$(PREFIX)/lib/chicken/8 VPATH=$(CHICKEN_EGG_DIR):$(PWD)/eggflags vpath %.so $(CHICKEN_EGG_DIR) vpath %.flag eggflags @@ -101,21 +102,22 @@ CSC_OPTIONS="-I$(PREFIX)/include -L$(CSCLIBS) -C \"-fPIC\"" # CSC_OPTIONS=-I $(PREFIX)/include -L $(CSCLIBS) nogui : base mutils -all : nogui libiup $(PREFIX)/lib/sqlite3.so +#all : nogui libiup $(PREFIX)/lib/sqlite3.so +all : nogui libiup base : chkn eggs # stuff needed for Kiatoa and Megatest from matts miscellaneous stash # NOTE TO SELF: eggifying these would be great... mutils : base logprobin $(PREFIX)/bin/hs \ - $(PREFIX)/lib/chicken/7/mutils.so \ - $(PREFIX)/lib/chicken/7/dbi.so \ - $(PREFIX)/lib/chicken/7/stml.so \ - $(PREFIX)/lib/chicken/7/margs.so + $(PREFIX)/lib/chicken/8/mutils.so \ + $(PREFIX)/lib/chicken/8/dbi.so \ + $(PREFIX)/lib/chicken/8/stml.so \ + $(PREFIX)/lib/chicken/8/margs.so chkn : $(CHICKEN_INSTALL) eggs : $(EGGSOFILES) @@ -145,14 +147,15 @@ $(PREFIX)/setup-chicken4x.csh : $(EGGFLAGS) mkdir -p $(PREFIX) (echo "setenv PATH $(PREFIX):'$$'PATH" > $(PREFIX)/setup-chicken4x.csh) (echo "setenv LD_LIBRARY_PATH $(LD_LIBRARY_PATH)" >> $(PREFIX)/setup-chicken4x.csh) +# NOTE: the touch chicken-core/chicken.scm compensates for the time stamp from the tar file chicken-core/chicken.scm : chicken-$(CHICKEN_VERSION).tar.gz tar xf chicken-$(CHICKEN_VERSION).tar.gz ln -sf chicken-$(CHICKEN_VERSION) chicken-core - + if [[ -e chicken-core/chicken.scm ]];then touch chicken-core/chicken.scm;fi chicken-4.9.0rc1.tar.gz : wget http://code.call-cc.org/dev-snapshots/2014/04/17/chicken-4.9.0rc1.tar.gz chicken-4.9.0.1.tar.gz : @@ -162,10 +165,13 @@ wget http://code.call-cc.org/dev-snapshots/2015/06/07/chicken-4.10.0rc1.tar.gz chicken-4.10.0.tar.gz : wget http://code.call-cc.org/releases/4.10.0/chicken-4.10.0.tar.gz +chicken-4.11.0rc2.tar.gz : + wget http://code.call-cc.org/dev-snapshots/2016/04/28/chicken-4.11.0rc2.tar.gz + # git clone git://code.call-cc.org/chicken-core # git clone http://code.call-cc.org/git/chicken-core.git $(CHICKEN_INSTALL) : chicken-core/chicken.scm $(PREFIX)/setup-chicken4x.sh $(PREFIX)/setup-chicken4x.csh cd chicken-core;make PLATFORM=linux PREFIX=$(PREFIX) @@ -219,17 +225,17 @@ opensrc/histstore/histstore.scm : opensrc.fossil mkdir -p opensrc cd opensrc;if [ -e .fslckout ];then fossil update; else fossil open ../opensrc.fossil; fi -$(PREFIX)/lib/chicken/7/mutils.so : opensrc/histstore/histstore.scm +$(PREFIX)/lib/chicken/8/mutils.so : opensrc/histstore/histstore.scm cd opensrc/mutils;chicken-install -$(PREFIX)/lib/chicken/7/dbi.so : opensrc/dbi/dbi.scm +$(PREFIX)/lib/chicken/8/dbi.so : opensrc/dbi/dbi.scm cd opensrc/dbi;chicken-install -$(PREFIX)/lib/chicken/7/margs.so : opensrc/margs/margs.scm +$(PREFIX)/lib/chicken/8/margs.so : opensrc/margs/margs.scm cd opensrc/margs;chicken-install opensrc/histstore/hs : opensrc/histstore/histstore.scm chkn eggs $(CHICKEN_EGG_DIR)/sqlite3.so cd opensrc/histstore;$(PREFIX)/bin/csc histstore.scm -o hs @@ -247,11 +253,11 @@ stml/requirements.scm : stml/requirements.scm.template cp stml/install.cfg.template stml/install.cfg cp stml/requirements.scm.template stml/requirements.scm -$(PREFIX)/lib/chicken/7/stml.so : stml/requirements.scm +$(PREFIX)/lib/chicken/8/stml.so : stml/requirements.scm cd stml;make #====================================================================== # F F C A L L (Used by IUP) #====================================================================== @@ -273,29 +279,58 @@ #====================================================================== iuplib.fossil : fossil clone http://www.kiatoa.com/fossils/iuplib iuplib.fossil -iup/installall.sh : iuplib.fossil +cd-5.9_Linux26g4_64_lib.tar.gz : + wget -c http://sourceforge.net/projects/canvasdraw/files/5.9/Linux%20Libraries/cd-5.9_Linux26g4_64_lib.tar.gz/download + mv download cd-5.9_Linux26g4_64_lib.tar.gz + +iup-3.17_Linux26g4_64_lib.tar.gz : + wget -c http://sourceforge.net/projects/iup/files/3.17/Linux%20Libraries/iup-3.17_Linux26g4_64_lib.tar.gz/download + mv download iup-3.17_Linux26g4_64_lib.tar.gz + +im-3.10_Linux26g4_64_lib.tar.gz : + wget -c http://sourceforge.net/projects/imtoolkit/files/3.10/Linux%20Libraries/im-3.10_Linux26g4_64_lib.tar.gz/download + mv download im-3.10_Linux26g4_64_lib.tar.gz + +lua-5.3.2_Linux26g4_64_lib.tar.gz : + wget -c http://sourceforge.net/projects/luabinaries/files/5.3.2/Linux%20Libraries/lua-5.3.2_Linux26g4_64_lib.tar.gz/download + mv download lua-5.3.2_Linux26g4_64_lib.tar.gz + +iup/installall.sh : $(PREFIX)/lib/libiup.so \ + cd-5.9_Linux26g4_64_lib.tar.gz \ + iup-3.17_Linux26g4_64_lib.tar.gz \ + im-3.10_Linux26g4_64_lib.tar.gz \ + lua-5.3.2_Linux26g4_64_lib.tar.gz # iuplib.fossil mkdir -p iup - cd iup && if [ -e makeall.sh ];then fossil update $(IUPBRANCH); else fossil open ../iuplib.fossil;fossil update $(IUPBRANCH); fi + pwd + tar -xzvf cd-5.9_Linux26g4_64_lib.tar.gz -C iup/ + tar -xzvf im-3.10_Linux26g4_64_lib.tar.gz -C iup/ + tar -xzvf iup-3.17_Linux26g4_64_lib.tar.gz -C iup/ + mkdir -p $(PREFIX)/include/ $(PREFIX)/lib/ + cp iup/include/* $(PREFIX)/include/ + cp iup/*.so $(PREFIX)/lib/ + cp iup/*.a $(PREFIX)/lib/ + +# cd iup && if [ -e makeall.sh ];then fossil update $(IUPBRANCH); else fossil open ../iuplib.fossil;fossil update $(IUPBRANCH); fi -iup/alldone : iup/makeall.sh $(PREFIX)/include/iup.h $(PREFIX)/lib/libiup.so - cd iup && ./makeall.sh $(IUPCONFIG) +iup/alldone : $(PREFIX)/include/iup.h $(PREFIX)/lib/libiup.so # iup/makeall.sh +# cd iup && ./makeall.sh $(IUPCONFIG) $(PREFIX)/lib/libiup.so $(PREFIX)/include/iup.h : iup/installall.sh iup/alldone - cd iup && ./makeall.sh $(IUPCONFIG) +# cd iup && ./makeall.sh $(IUPCONFIG) # $(PREFIX)/lib/libiup.so : iup/iup/alldone # touch -c $(PREFIX)/lib/libiup.so $(CHICKEN_EGG_DIR)/iup.so : $(PREFIX)/lib/libiup.so $(PREFIX)/lib/libavcall.a - LD_LIBRARY_PATH=$(LD_LIBRARY_PATH) CSC_OPTIONS=$(CSC_OPTIONS) $(CHICKEN_INSTALL) $(PROX) -D no-library-checks iup + LD_LIBRARY_PATH=$(LD_LIBRARY_PATH) CSC_OPTIONS=$(CSC_OPTIONS) $(CHICKEN_INSTALL) $(PROX) -D no-library-checks -feature disable-iup-web iup # -feature disable-iup-web $(CHICKEN_EGG_DIR)/canvas-draw.so : $(PREFIX)/lib/libiup.so $(PREFIX)/lib/libavcall.a CSC_OPTIONS=$(CSC_OPTIONS) $(CHICKEN_INSTALL) $(PROX) -D no-library-checks canvas-draw clean : rm -rf chicken-4.8.0 eggflags ffcall sqlite-autoconf-$(SQLITE3_VERSION) ADDED utils/Makefile.latest.installall Index: utils/Makefile.latest.installall ================================================================== --- /dev/null +++ utils/Makefile.latest.installall @@ -0,0 +1,320 @@ + +# Copyright 2013-2015 Matthew Welland. +# +# This program is made available under the GNU GPL version 2.0 or +# greater. See the accompanying file COPYING for details. +# +# This program is distributed WITHOUT ANY WARRANTY; without even the +# implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR +# PURPOSE. + +help : + @echo You may need to do the following setup first: + @echo + @echo sudo apt-get install libreadline-dev + @echo sudo apt-get install libwebkitgtk-dev libfreetype6-dev libx11-dev libxpm-dev libxmu-dev \ + libxft-dev libgtk2.0-dev libgl1-mesa-dev libglu1-mesa-dev libpangox-1.0-dev bison \ + libwebkitgtk-3.0-dev + @echo -- nb// adding monodevelop gets more packages of which some might be needed... + @echo sudo apt-get install libmotif3 + @echo + @echo Set up your PATH, setting it in the Makefile does not work as expected + @echo export PATH=$(PREFIX)/bin:\$$PATH + @echo + @echo For IUP set IUPBRANCH, currently $(IUPBRANCH) + @echo set IUPCONFIG, currently $(IUPCONFIG) - look in https://www.kiatoa.com/fossils/iuplib for .inc files + @echo You are using PREFIX=$(PREFIX) + @echo You are using PROXY="$(PROXY)" + @echo If needed set PROXY to host.dom:port + @echo http_proxy=$(http_proxy) + @echo + @echo To make all do: make all + @echo make minimal: make nogui + @echo + @echo Note: If compiling on amd64 do CSC_OPTIONS=\'-C "-fPIC"\' make all IUPCONFIG= + +FPIC=-C "-fPIC" + +# Put the installation here +ifeq ($(PREFIX),) +PREFIX=$(PWD)/target +endif + +# Set this on the command line of your make call if needed: make PROXY=host.com:1234 +PROXY= + +# http://code.call-cc.org/dev-snapshots/2015/06/07/chicken-4.10.0rc1.tar.gz +# http://code.call-cc.org/releases/4.10.0/chicken-4.10.0.tar.gz +# Select version of chicken, sqlite3 etc +CHICKEN_VERSION=4.10.1 +SQLITE3_VERSION=3090200 +# http://www.sqlite.org/2014/sqlite-autoconf-3080500.tar.gz +# http://www.sqlite.org/2015/sqlite-autoconf-3081101.tar.gz +# Override IUPBRANCH to use other than trunk +IUPBRANCH=trunk +IUPCONFIG=ubuntu-15.04.inc +# iup-3.15 + +# 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 \ + spiffy-directory-listing ssax sxml-serializer sxml-modifications sql-de-lite \ + srfi-19 refdb ini-file sparse-vectors z3 call-with-environment-variables hahn linenoise \ + crypt parley zlib shell udp loops foof-loop lazy-seq ansi-escape-sequences rfc3339 slice \ + slice-utf8 scsh-process functional-lists srfi-101 uuid-lib filepath srfi-78 srfi-42 sexp-diff \ + low-level-macros symbol-utils expand-full chicken-doc irc silex lalr lalr-driver sha1 refdb + +# +# Derived variables +# + +ifeq ($(PROXY),) +PROX:= +else +http_proxy:=http://$(PROXY) +PROX:=-proxy $(PROXY) +endif + +BUILDHOME=$(PWD) +PATH:=$(PREFIX)/bin:$(PATH) +LIBPATH=$(PREFIX)/lib$(ADDITIONAL_LIBPATH) +LD_LIBRARY_PATH=$(LIBPATH) +CHICKEN_INSTALL=$(PREFIX)/bin/chicken-install +CHICKEN_EGG_DIR=$(PREFIX)/lib/chicken/7 + +VPATH=$(CHICKEN_EGG_DIR):$(PWD)/eggflags + +vpath %.so $(CHICKEN_EGG_DIR) +vpath %.flag eggflags + +EGGSOFILES=$(addprefix $(CHICKEN_EGG_DIR)/,$(addsuffix .so,$(EGGS))) +EGGFLAGS=$(addprefix eggflags/,$(addsuffix .flag,$(EGGS))) + +# Stuff needed for IUP +ISARCHX86_64=$(shell uname -a | grep x86_64) +ifeq ($(ISARCHX86_64),) +ARCHSIZE= +else +ARCHSIZE=64_ +endif + +CSCLIBS=$(shell echo $(LD_LIBRARY_PATH) | sed 's/:/ -L/g') +CSC_OPTIONS="-I$(PREFIX)/include -L$(CSCLIBS) -C \"-fPIC\"" +# CSC_OPTIONS=-I $(PREFIX)/include -L $(CSCLIBS) + +nogui : base mutils + +#all : nogui libiup $(PREFIX)/lib/sqlite3.so +all : nogui libiup + +base : chkn eggs + +# stuff needed for Kiatoa and Megatest from matts miscellaneous stash +# NOTE TO SELF: eggifying these would be great... +mutils : base logprobin $(PREFIX)/bin/hs \ + $(PREFIX)/lib/chicken/7/mutils.so \ + $(PREFIX)/lib/chicken/7/dbi.so \ + $(PREFIX)/lib/chicken/7/stml.so \ + $(PREFIX)/lib/chicken/7/margs.so + +chkn : $(CHICKEN_INSTALL) + +eggs : $(EGGSOFILES) + +# libiup : $(PREFIX)/lib/libavcall.a +libiup : $(CHICKEN_EGG_DIR)/iup.so $(CHICKEN_EGG_DIR)/canvas-draw.so + +logprobin : $(PREFIX)/bin/logpro + +$(PREFIX)/bin/logpro : $(CHICKEN_EGG_DIR)/regex-literals.so + $(CHICKEN_INSTALL) logpro + +# Silly rule to make installing eggs more makeish, I don't understand why I need the basename +$(CHICKEN_EGG_DIR)/%.so : eggflags/%.flag + $(CHICKEN_INSTALL) $(PROX) -keep-installed $(shell basename $*) + +$(EGGFLAGS) : # $(CHICKEN_INSTALL) + mkdir -p eggflags + touch $(EGGFLAGS) + +# some setup stuff +# +$(PREFIX)/setup-chicken4x.sh : $(EGGFLAGS) + mkdir -p $(PREFIX) + (echo 'export PATH=$(PREFIX)/bin:$$PATH' > $(PREFIX)/setup-chicken4x.sh) + (echo "export LD_LIBRARY_PATH=$(LD_LIBRARY_PATH)" >> $(PREFIX)/setup-chicken4x.sh) + +$(PREFIX)/setup-chicken4x.csh : $(EGGFLAGS) + mkdir -p $(PREFIX) + (echo "setenv PATH $(PREFIX):'$$'PATH" > $(PREFIX)/setup-chicken4x.csh) + (echo "setenv LD_LIBRARY_PATH $(LD_LIBRARY_PATH)" >> $(PREFIX)/setup-chicken4x.csh) + +chicken-core/chicken.scm : chicken-$(CHICKEN_VERSION).tar.gz + tar xf chicken-$(CHICKEN_VERSION).tar.gz + ln -sf chicken-$(CHICKEN_VERSION) chicken-core + + +chicken-4.9.0rc1.tar.gz : + wget http://code.call-cc.org/dev-snapshots/2014/04/17/chicken-4.9.0rc1.tar.gz + +chicken-4.9.0.1.tar.gz : + wget http://code.call-cc.org/releases/4.9.0/chicken-4.9.0.1.tar.gz + +chicken-4.10.0rc1.tar.gz : + wget http://code.call-cc.org/dev-snapshots/2015/06/07/chicken-4.10.0rc1.tar.gz + +chicken-4.10.0.tar.gz : + wget http://code.call-cc.org/releases/4.10.0/chicken-4.10.0.tar.gz + +chicken-4.10.1.tar.gz : + wget http://code.call-cc.org/dev-snapshots/2015/08/29/chicken-4.10.1.tar.gz + +# git clone git://code.call-cc.org/chicken-core +# git clone http://code.call-cc.org/git/chicken-core.git + +$(CHICKEN_INSTALL) : chicken-core/chicken.scm $(PREFIX)/setup-chicken4x.sh $(PREFIX)/setup-chicken4x.csh + cd chicken-core;make PLATFORM=linux PREFIX=$(PREFIX) + cd chicken-core;make PLATFORM=linux PREFIX=$(PREFIX) install + +#====================================================================== +# S Q L I T E 3 +#====================================================================== +# https://www.sqlite.org/2015/sqlite-autoconf-3090200.tar.gz +sqlite-autoconf-$(SQLITE3_VERSION).tar.gz : + wget http://www.sqlite.org/2015/sqlite-autoconf-$(SQLITE3_VERSION).tar.gz + +sqlite-autoconf-$(SQLITE3_VERSION)/config.log : sqlite-autoconf-$(SQLITE3_VERSION).tar.gz + tar xf sqlite-autoconf-$(SQLITE3_VERSION).tar.gz + +$(PREFIX)/bin/sqlite3 : sqlite-autoconf-$(SQLITE3_VERSION)/config.log + cd sqlite-autoconf-$(SQLITE3_VERSION);./configure --prefix=$(PREFIX);make;make install + +$(CHICKEN_EGG_DIR)/sqlite3.so : $(PREFIX)/bin/sqlite3 + CSC_OPTIONS="-I$(PREFIX)/include -L$(PREFIX)/lib" $(CHICKEN_INSTALL) $(PROX) sqlite3 + +#====================================================================== +# N A N O M S G +#====================================================================== + +# https://github.com/nanomsg/nanomsg/releases/download/0.6-beta/nanomsg-0.6-beta.tar.gz +# https://github.com/nanomsg/nanomsg/releases/download/0.8-beta/nanomsg-0.8-beta.tar.gz + +nanomsg-0.6-beta.tar.gz : + wget http://download.nanomsg.org/nanomsg-0.6-beta.tar.gz + +nanomsg-0.6-beta/COPYING : nanomsg-0.6-beta.tar.gz + tar xf nanomsg-0.6-beta.tar.gz + +$(PREFIX)/bin/nanocat : nanomsg-0.6-beta/COPYING + cd nanomsg-0.6-beta;./configure --prefix=$(PREFIX);make;make install + +$(PREFIX)/lib/nanomsg.so : $(PREFIX)/bin/nanocat + CSC_OPTIONS="-I$(PREFIX)/include -L$(PREFIX)/lib" $(CHICKEN_INSTALL) $(PROX) nanomsg + +# LD_LIBRARY_PATH=/mfs/pkgs/chicken/4.10.0-amd64/lib CSC_OPTIONS="-I/mfs/pkgs/chicken/4.10.0-amd64/include -L/mfs/pkgs/chicken/4.10.0-amd64/lib -C \"-fPIC\"" /mfs/pkgs/chicken/4.10.0-amd64/bin/chicken-install -D no-library-checks nanomsg + +#====================================================================== +# M A T T S U T I L S +#====================================================================== + +# opensrc + +opensrc.fossil : + fossil clone http://www.kiatoa.com/fossils/opensrc opensrc.fossil + +opensrc/histstore/histstore.scm : opensrc.fossil + mkdir -p opensrc + cd opensrc;if [ -e .fslckout ];then fossil update; else fossil open ../opensrc.fossil; fi + +$(PREFIX)/lib/chicken/7/mutils.so : opensrc/histstore/histstore.scm + cd opensrc/mutils;chicken-install + +$(PREFIX)/lib/chicken/7/dbi.so : opensrc/dbi/dbi.scm + cd opensrc/dbi;chicken-install + +$(PREFIX)/lib/chicken/7/margs.so : opensrc/margs/margs.scm + cd opensrc/margs;chicken-install + +opensrc/histstore/hs : opensrc/histstore/histstore.scm chkn eggs $(CHICKEN_EGG_DIR)/sqlite3.so + cd opensrc/histstore;$(PREFIX)/bin/csc histstore.scm -o hs + +$(PREFIX)/bin/hs : opensrc/histstore/hs + cp -f opensrc/histstore/hs $(PREFIX)/bin/hs + +# stml +stml.fossil : + fossil clone http://www.kiatoa.com/fossils/stml stml.fossil + +# open touches the .fossil :( +stml/requirements.scm.template : stml.fossil + mkdir -p stml + cd stml;if [ -e .fslckout ];then fossil update; else fossil open ../stml.fossil;fi + +stml/requirements.scm : stml/requirements.scm.template + cp stml/install.cfg.template stml/install.cfg + cp stml/requirements.scm.template stml/requirements.scm + +$(PREFIX)/lib/chicken/7/stml.so : stml/requirements.scm + cd stml;make + +#====================================================================== +# F F C A L L (Used by IUP) +#====================================================================== + +ffcall.fossil : + fossil clone http://www.kiatoa.com/fossils/ffcall ffcall.fossil + +ffcall/README : ffcall.fossil + mkdir -p ffcall + cd ffcall && if [ -e README ];then fossil update; else fossil open ../ffcall.fossil; fi + +# NOTE: This worked fine *without* the enable-shared +# +$(PREFIX)/lib/libavcall.a : ffcall/README + cd ffcall;./configure --prefix=$(PREFIX) --enable-shared && make CC="gcc -fPIC" && make install + +#====================================================================== +# I U P +#====================================================================== + +iuplib.fossil : + #fossil clone http://www.kiatoa.com/fossils/iuplib iuplib.fossil + touch iuplib.fossil +iup/installall.sh : iuplib.fossil $(PREFIX)/lib/libiup.so + mkdir -p iup + pwd + #wget -c http://sourceforge.net/projects/canvasdraw/files/5.9/Linux%20Libraries/cd-5.9_Linux26g4_64_lib.tar.gz/download + #wget -c http://sourceforge.net/projects/iup/files/3.17/Linux%20Libraries/iup-3.17_Linux26g4_64_lib.tar.gz/download + #wget -c http://sourceforge.net/projects/imtoolkit/files/3.10/Linux%20Libraries/im-3.10_Linux26g4_64_lib.tar.gz/download + #wget -c http://sourceforge.net/projects/luabinaries/files/5.3.2/Linux%20Libraries/lua-5.3.2_Linux26g4_64_lib.tar.gz/download + tar -xzvf cd-5.9_Linux26g4_64_lib.tar.gz -C iup/ + tar -xzvf im-3.10_Linux26g4_64_lib.tar.gz -C iup/ + tar -xzvf iup-3.17_Linux26g4_64_lib.tar.gz -C iup/ + mkdir -p $(PREFIX)/include/ $(PREFIX)/lib/ + cp iup/include/* $(PREFIX)/include/ + cp iup/*.so $(PREFIX)/lib/ + cp iup/*.a $(PREFIX)/lib/ + +# cd iup && if [ -e makeall.sh ];then fossil update $(IUPBRANCH); else fossil open ../iuplib.fossil;fossil update $(IUPBRANCH); fi + +#iup/alldone : iup/makeall.sh $(PREFIX)/include/iup.h $(PREFIX)/lib/libiup.so +# cd iup && ./makeall.sh $(IUPCONFIG) + +$(PREFIX)/lib/libiup.so $(PREFIX)/include/iup.h : iup/installall.sh +# cd iup && ./makeall.sh $(IUPCONFIG) + +# $(PREFIX)/lib/libiup.so : iup/iup/alldone +# touch -c $(PREFIX)/lib/libiup.so + +$(CHICKEN_EGG_DIR)/iup.so : $(PREFIX)/lib/libiup.so $(PREFIX)/lib/libavcall.a + LD_LIBRARY_PATH=$(LD_LIBRARY_PATH) CSC_OPTIONS=$(CSC_OPTIONS) $(CHICKEN_INSTALL) $(PROX) -D no-library-checks -feature disable-iup-web iup + +# -feature disable-iup-web + +$(CHICKEN_EGG_DIR)/canvas-draw.so : $(PREFIX)/lib/libiup.so $(PREFIX)/lib/libavcall.a + CSC_OPTIONS=$(CSC_OPTIONS) $(CHICKEN_INSTALL) $(PROX) -D no-library-checks canvas-draw + + +clean : + rm -rf chicken-4.8.0 eggflags ffcall sqlite-autoconf-$(SQLITE3_VERSION)