Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -42,12 +42,12 @@ csc $(CSCOPTS) $(OFILES) megatest.o -o mtest dboard : $(OFILES) $(GOFILES) dashboard.scm csc $(OFILES) dashboard.scm $(GOFILES) -o dboard -ndboard : newdashboard.scm $(OFILES) $(GOFILES) - csc $(OFILES) $(GOFILES) newdashboard.scm -o ndboard +odboard : olddashboard.scm $(OFILES) $(GOFILES) + csc $(OFILES) $(GOFILES) olddashboard.scm -o odboard # # $(PREFIX)/bin/revtagfsl : utils/revtagfsl.scm # csc utils/revtagfsl.scm -o $(PREFIX)/bin/revtagfsl @@ -57,11 +57,11 @@ tests.o runs.o dashboard.o dashboard-tests.o dashboard-main.o : run_records.scm db.o ezsteps.o keys.o launch.o megatest.o monitor.o runs-for-ref.o runs.o tests.o : key_records.scm tests.o tasks.o dashboard-tasks.o : task_records.scm runs.o : test_records.scm megatest.o : megatest-fossil-hash.scm -client.scm common.scm configf.scm dashboard-guimonitor.scm dashboard-tests.scm dashboard.scm db.scm dcommon.scm ezsteps.scm fs-transport.scm http-transport.scm index-tree.scm items.scm keys.scm launch.scm megatest.scm monitor.scm mt.scm newdashboard.scm runconfig.scm runs.scm server.scm tdb.scm tests.scm tree.scm zmq-transport.scm : common_records.scm rpc-transport.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 olddashboard.scm runconfig.scm runs.scm server.scm tdb.scm tests.scm tree.scm zmq-transport.scm : common_records.scm rpc-transport.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 @@ -77,16 +77,16 @@ @echo Installing to PREFIX=$(PREFIX) $(INSTALL) mtest $(PREFIX)/bin/.$(ARCHSTR)/mtest utils/mk_wrapper $(PREFIX) mtest $(PREFIX)/bin/megatest chmod a+x $(PREFIX)/bin/megatest -$(PREFIX)/bin/.$(ARCHSTR)/ndboard : ndboard - $(INSTALL) ndboard $(PREFIX)/bin/.$(ARCHSTR)/ndboard +$(PREFIX)/bin/.$(ARCHSTR)/odboard : odboard + $(INSTALL) odboard $(PREFIX)/bin/.$(ARCHSTR)/odboard -$(PREFIX)/bin/newdashboard : $(PREFIX)/bin/.$(ARCHSTR)/ndboard - utils/mk_wrapper $(PREFIX) ndboard $(PREFIX)/bin/newdashboard - chmod a+x $(PREFIX)/bin/newdashboard +$(PREFIX)/bin/olddashboard : $(PREFIX)/bin/.$(ARCHSTR)/odboard + utils/mk_wrapper $(PREFIX) odboard $(PREFIX)/bin/olddashboard + chmod a+x $(PREFIX)/bin/olddashboard # $(HELPERS) : utils/% # $(INSTALL) $< $@ # chmod a+x $@ @@ -138,11 +138,11 @@ $(INSTALL) dboard $(PREFIX)/bin/.$(ARCHSTR)/dboard install : $(PREFIX)/bin/.$(ARCHSTR) $(PREFIX)/bin/.$(ARCHSTR)/mtest $(PREFIX)/bin/megatest \ $(PREFIX)/bin/.$(ARCHSTR)/dboard $(PREFIX)/bin/dashboard $(HELPERS) $(PREFIX)/bin/nbfake \ $(PREFIX)/bin/nbfind $(PREFIX)/bin/loadrunner $(PREFIX)/bin/mt_xterm \ - $(PREFIX)/bin/newdashboard + $(PREFIX)/bin/olddashboard $(PREFIX)/bin/.$(ARCHSTR) : mkdir -p $(PREFIX)/bin/.$(ARCHSTR) test: tests/tests.scm Index: archive.scm ================================================================== --- archive.scm +++ archive.scm @@ -43,17 +43,17 @@ (apath (archive:get-archive testname itempath dused))) (jobrunner:run-job flavor maxload '() - archive:run-bup + archive:run-bup ;; this will break!!! need area-dat (list testdir apath)))))) ;; Get archive disks from megatest.config ;; -(define (archive:get-archive-disks) - (let ((section (configf:get-section *configdat* "archive-disks"))) +(define (archive:get-archive-disks area-dat) + (let ((section (configf:get-section (megatest:area-configdat area-dat) "archive-disks"))) (if section section '()))) ;; look for the best candidate archive area, else create new @@ -99,23 +99,25 @@ ;; 1. create the bup dir if not exists ;; 2. start the du of each directory ;; 3. gen index ;; 4. save ;; -(define (archive:run-bup archive-command run-id run-name tests) +(define (archive:run-bup archive-command run-id run-name tests area-dat) ;; move the getting of archive space down into the below block so that a single run can ;; allocate as needed should a disk fill up ;; - (let* ((min-space (string->number (or (configf:lookup *configdat* "archive" "minspace") "1000"))) - (archive-info (archive:allocate-new-archive-block *toppath* (common:get-testsuite-name) min-space)) + (let* ((configdat (megatest:area-configdat area-dat)) + (toppath (megatest:area-path area-dat)) + (min-space (string->number (or (configf:lookup configdat "archive" "minspace") "1000"))) + (archive-info (archive:allocate-new-archive-block toppath (common:get-testsuite-name) min-space)) (archive-dir (if archive-info (cdr archive-info) #f)) (archive-id (if archive-info (car archive-info) -1)) (disk-groups (make-hash-table)) (test-groups (make-hash-table)) ;; these two (disk and test groups) could be combined nicely - (bup-exe (or (configf:lookup *configdat* "archive" "bup") "bup")) - (compress (or (configf:lookup *configdat* "archive" "compress") "9")) - (linktree (configf:lookup *configdat* "setup" "linktree"))) + (bup-exe (or (configf:lookup configdat "archive" "bup") "bup")) + (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") @@ -196,22 +198,23 @@ (runs:remove-test-directory test-dat 'archive-remove)))) (hash-table-ref test-groups disk-group)))) (hash-table-keys disk-groups)) #t)) -(define (archive:bup-restore archive-command run-id run-name tests) ;; move the getting of archive space down into the below block so that a single run can +(define (archive:bup-restore archive-command run-id run-name tests area-dat) ;; move the getting of archive space down into the below block so that a single run can ;; allocate as needed should a disk fill up ;; - (let* ((bup-exe (or (configf:lookup *configdat* "archive" "bup") "bup")) - (linktree (configf:lookup *configdat* "setup" "linktree"))) + (let* ((configdat (megatest:area-configdat area-dat)) + (bup-exe (or (configf:lookup configdat "archive" "bup") "bup")) + (linktree (configf:lookup configdat "setup" "linktree"))) ;; from the test info bin the path to the test by stem ;; (for-each (lambda (test-dat) ;; When restoring test-dat will initially contain an old and invalid path to the test - (let* ((best-disk (get-best-disk *configdat*)) + (let* ((best-disk (get-best-disk configdat)) (item-path (db:test-get-item-path test-dat)) (test-name (db:test-get-testname test-dat)) (test-id (db:test-get-id test-dat)) (run-id (db:test-get-run_id test-dat)) (keyvals (rmt:get-key-val-pairs run-id)) Index: batchsim/Makefile ================================================================== --- batchsim/Makefile +++ batchsim/Makefile @@ -1,3 +1,7 @@ + +all : batchsim + ./batchsim batchsim : batchsim.scm csc batchsim.scm + Index: client.scm ================================================================== --- client.scm +++ client.scm @@ -66,26 +66,26 @@ ;; (debug:print 0 "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) ;; (exit 1)) -;; (let ((host-info (hash-table-ref/default *runremote* run-id #f))) +;; (let ((host-info (hash-table-ref/default (common:get-remote remote) run-id #f))) ;; (debug:print-info 0 "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)) ;; (ping-res (client:login-no-auto-setup start-res run-id))) ;; (if ping-res ;; sucessful login? ;; (begin -;; (hash-table-set! *runremote* run-id start-res) +;; (hash-table-set! (common:get-remote remote) 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) -;; (hash-table-delete! *runremote* run-id) +;; (hash-table-delete! (common:get-remote remote) run-id) ;; (open-run-close tasks:server-force-clean-run-record ;; tasks:open-db ;; run-id ;; (car host-info) ;; (cadr host-info) @@ -105,16 +105,16 @@ ;; (start-res (http-transport:client-connect iface port)) ;; ;; (ping-res (server:ping-server run-id iface port)) ;; (ping-res (rmt:login-no-auto-client-setup start-res run-id))) ;; (if start-res ;; (begin -;; (hash-table-set! *runremote* run-id start-res) +;; (hash-table-set! (common:get-remote remote) 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) -;; (hash-table-delete! *runremote* run-id) +;; (hash-table-delete! (common:get-remote remote) run-id) ;; (open-run-close tasks:server-force-clean-run-record ;; tasks:open-db ;; run-id ;; (tasks:hostinfo-get-interface server-dat) ;; (tasks:hostinfo-get-port server-dat) @@ -144,19 +144,19 @@ ;; Do all the connection work, look up the transport type and set up the ;; connection if required. ;; ;; There are two scenarios. -;; 1. We are a test manager and we received *transport-type* and *runremote* via cmdline +;; 1. We are a test manager and we received *transport-type* and (common:get-remote remote) via cmdline ;; 2. We are a run tests, list runs or other interactive process and we must figure out -;; *transport-type* and *runremote* from the monitor.db +;; *transport-type* and (common:get-remote remote) from the monitor.db ;; ;; client:setup ;; -;; lookup_server, need to remove *runremote* stuff +;; lookup_server, need to remove (common:get-remote remote) stuff ;; -(define (client:setup-http run-id #!key (remaining-tries 10) (failed-connects 0)) +(define (client:setup-http run-id #!key (remaining-tries 10) (failed-connects 0)(remote #f)) (debug:print-info 2 "client:setup remaining-tries=" remaining-tries) (let* ((tdbdat (tasks:open-db))) (if (<= remaining-tries 0) (begin (debug:print 0 "ERROR: failed to start or connect to server for run-id " run-id) @@ -177,18 +177,18 @@ (car (vector-ref logininfo 1)) #f)))))) (if (and start-res ping-res) (begin - (hash-table-set! *runremote* run-id start-res) + (common:set-remote! remote run-id start-res) (debug:print-info 2 "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) (case *transport-type* ((http)(http-transport:close-connections run-id))) - (hash-table-delete! *runremote* run-id) + (common:del-remote! remote run-id) (tasks:kill-server-run-id run-id) (tasks:server-force-clean-run-record (db:delay-if-busy tdbdat) run-id (tasks:hostinfo-get-interface server-dat) (tasks:hostinfo-get-port server-dat) Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -35,14 +35,21 @@ (define home (getenv "HOME")) (define user (getenv "USER")) ;; GLOBAL GLETCHES -(define *db-keys* #f) -(define *configinfo* #f) -(define *configdat* #f) -(define *toppath* #f) +(define-record megatest:area + name + path + transport + configinfo + configdat + denoise + client-signature + remote + ) + (define *already-seen-runconfig-info* #f) (define *waiting-queue* (make-hash-table)) (define *test-meta-updated* (make-hash-table)) (define *globalexitstatus* 0) ;; attempt to work around possible thread issues (define *passnum* 0) ;; when running track calls to run-tests or similar @@ -64,14 +71,36 @@ (define *task-db* #f) ;; (vector db path-to-db) (define *db-access-allowed* #t) ;; flag to allow access (define *db-access-mutex* (make-mutex)) ;; SERVER -(define *my-client-signature* #f) -(define *transport-type* 'http) -(define *transport-type* 'http) ;; override with [server] transport http|rpc|nmsg -(define *runremote* (make-hash-table)) ;; if set up for server communication this will hold +;; (define *my-client-signature* #f) +;; (define *transport-type* 'http) ;; override with [server] transport http|rpc|nmsg +;; (define *runremote* (make-hash-table)) ;; if set up for server communication this will hold + +(define (common:get-remote remote run-id) + (let ((ht (or remote *runremote*))) + (if ht + (hash-table-ref/default ht run-id #f) + #f))) + +(define (common:set-remote! remote run-id value) + (let ((ht (or remote *runremote*))) + (if ht + (hash-table-set! ht run-id value)))) + +(define (common:del-remote! remote run-id) + (let ((ht (or remote *runremote*))) + (if ht + (hash-table-delete! ht run-id)))) + +(define (common:get-remote-all remote) + (let ((ht (or remote *runremote*))) + (if ht + (hash-table-keys ht) + '()))) + (define *max-cache-size* 0) (define *logged-in-clients* (make-hash-table)) (define *client-non-blocking-mode* #f) (define *server-id* #f) (define *server-info* #f) @@ -234,24 +263,25 @@ (define (assoc/default key lst . default) (let ((res (assoc key lst))) (if res (cadr res)(if (null? default) #f (car default))))) -(define (common:get-testsuite-name) - (or (configf:lookup *configdat* "setup" "testsuite" ) - (pathname-file *toppath*))) +(define (common:get-testsuite-name area-dat) + (or (configf:lookup (megatest:area-configdat area-dat) "setup" "testsuite" ) + (pathname-file (megatest:area-path area-dat)))) ;;====================================================================== ;; E X I T H A N D L I N G ;;====================================================================== -(define (std-exit-procedure) +(define (std-exit-procedure area-dat) (debug:print-info 2 "starting exit process, finalizing databases.") - (rmt:print-db-stats) - (let ((run-ids (hash-table-keys *db-local-sync*))) + (rmt:print-db-stats area-dat) + (let* ((configdat (megatest:area-configdat area-dat)) + (run-ids (hash-table-keys *db-local-sync*))) (if (and (not (null? run-ids)) - (configf:lookup *configdat* "setup" "megatest-db")) + (configf:lookup configdat "setup" "megatest-db")) (db:multi-db-sync run-ids 'new2old))) (if *dbstruct-db* (db:close-all *dbstruct-db*)) (if *inmemdb* (db:close-all *inmemdb*)) (if (and *megatest-db* (sqlite3:database? *megatest-db*)) Index: dashboard-tests.scm ================================================================== --- dashboard-tests.scm +++ dashboard-tests.scm @@ -39,16 +39,16 @@ ;; C O M M O N ;;====================================================================== (define *dashboard-comment-share-slot* #f) -(define (dtests:get-pre-command #!key (default-override #f)) - (let ((cfg-ovrd (configf:lookup *configdat* "dashboard" "pre-command"))) +(define (dtests:get-pre-command area-dat #!key (default-override #f)) + (let ((cfg-ovrd (configf:lookup (megatest:area-configdat area-dat) "dashboard" "pre-command"))) (or cfg-ovrd default-override "xterm -geometry 180x20 -e \""))) -(define (dtests:get-post-command #!key (default-override #f)) - (let ((cfg-ovrd (configf:lookup *configdat* "dashboard" "post-command"))) +(define (dtests:get-post-command area-dat #!key (default-override #f)) + (let ((cfg-ovrd (configf:lookup (megatest:area-configdat area-dat) "dashboard" "post-command"))) (or cfg-ovrd default-override ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &"))) (define (test-info-panel testdat store-label widgets) (iup:frame @@ -302,11 +302,12 @@ (if wtxtbox (begin (iup:attribute-set! wtxtbox "VALUE" c) (if (not *dashboard-comment-share-slot*) (set! *dashboard-comment-share-slot* wtxtbox))) - )))) + )) + area-dat)) (begin (rmt:test-set-state-status-by-id run-id test-id #f status #f) (db:test-set-status! testdat status)))))))) btn)) (map cadr *common:std-statuses*)))) ;; (list "PASS" "WARN" "FAIL" "CHECK" "n/a" "WAIVED" "SKIP")))) @@ -319,12 +320,12 @@ (if (not (colors-similar? newcolor (iup:attribute btn "BGCOLOR"))) (iup:attribute-set! btn "BGCOLOR" newcolor)))) btns))) btns)))))) -(define (dashboard-tests:run-html-viewer lfilename) - (let ((htmlviewercmd (configf:lookup *configdat* "setup" "htmlviewercmd"))) +(define (dashboard-tests:run-html-viewer lfilename area-dat) + (let ((htmlviewercmd (configf:lookup (megatest:area-configdat area-dat) "setup" "htmlviewercmd"))) (if htmlviewercmd (system (conc "(" htmlviewercmd " " lfilename " ) &")) (iup:send-url lfilename)))) (define (dashboard-tests:run-a-step info) @@ -353,12 +354,12 @@ ;; #:expand "HORIZONTAL" ;; #:action (lambda (obj) ;; (print "Refresh test data " stepname)) ))) -(define (dashboard-tests:waiver run-id testdat ovrdval cmtcmd) - (let* ((wpatt (configf:lookup *configdat* "setup" "waivercommentpatt")) +(define (dashboard-tests:waiver run-id testdat ovrdval cmtcmd area-dat) + (let* ((wpatt (configf:lookup (megatest:area-configdat area-dat) "setup" "waivercommentpatt")) (wregx (if (string? wpatt)(regexp wpatt) #f)) (wmesg (iup:label (if wpatt (conc "Comment must match pattern " wpatt) ""))) (comnt (iup:textbox #:action (lambda (val a b) (if wpatt (if (string-match wregx b) @@ -399,13 +400,13 @@ ;;====================================================================== ;; ;;====================================================================== -(define (examine-test run-id test-id) ;; run-id run-key origtest) - (let* ((db-path (db:dbfile-path run-id)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/db/" run-id ".db")) - (dbstruct (make-dbr:dbstruct path: (db:dbfile-path #f) ;; (configf:lookup *configdat* "setup" "linktree") +(define (examine-test run-id test-id area-dat) ;; run-id run-key origtest) + (let* ((db-path (db:dbfile-path run-id)) + (dbstruct (make-dbr:dbstruct path: (db:dbfile-path #f) local: #t)) (testdat (db:get-test-info-by-id dbstruct run-id test-id)) (db-mod-time 0) ;; (file-modification-time db-path)) (last-update 0) ;; (current-seconds)) (request-update #t)) @@ -443,18 +444,18 @@ "/")) (item-path (db:test-get-item-path testdat)) (viewlog (lambda (x) (if (file-exists? logfile) ;(system (conc "firefox " logfile "&")) - (dashboard-tests:run-html-viewer logfile) + (dashboard-tests:run-html-viewer logfile area-dat) (message-window (conc "File " logfile " not found"))))) (view-a-log (lambda (lfile) (let ((lfilename (conc rundir "/" lfile))) ;; (print "lfilename: " lfilename) (if (file-exists? lfilename) ;(system (conc "firefox " logfile "&")) - (dashboard-tests:run-html-viewer lfilename) + (dashboard-tests:run-html-viewer lfilename area-dat) (message-window (conc "File " lfilename " not found")))))) (xterm (lambda (x) (if (directory-exists? rundir) (let ((shell (if (get-environment-variable "SHELL") (conc "-e " (get-environment-variable "SHELL")) @@ -542,13 +543,13 @@ lbl)) (store-button store-label) (command-text-box (iup:textbox #:expand "HORIZONTAL" #:font "Courier New, -10")) (command-launch-button (iup:button "Execute!" #:action (lambda (x) (let* ((cmd (iup:attribute command-text-box "VALUE")) - (fullcmd (conc (dtests:get-pre-command) + (fullcmd (conc (dtests:get-pre-command area-dat) cmd - (dtests:get-post-command)))) + (dtests:get-post-command area-dat)))) (debug:print-info 02 "Running command: " fullcmd) (system fullcmd))))) (kill-jobs (lambda (x) (iup:attribute-set! command-text-box "VALUE" @@ -579,13 +580,13 @@ ";megatest -target " keystring " -runname " runname " -runtests " (conc testname "/" (if (equal? item-path "") "%" item-path)) ))) - (system (conc (dtests:get-pre-command) + (system (conc (dtests:get-pre-command area-dat) cmd - (dtests:get-post-command)))))) + (dtests:get-post-command area-dat)))))) (remove-test (lambda (x) (iup:attribute-set! command-text-box "VALUE" (conc "megatest -remove-runs -target " keystring " -runname " runname " -testpatt " (conc testname "/" (if (equal? item-path "") Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -1,59 +1,48 @@ ;;====================================================================== -;; Copyright 2006-2012, Matthew Welland. +;; Copyright 2006-2013, 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. ;;====================================================================== -(use format) +(use format numbers) (require-library iup) (import (prefix iup iup:)) - (use canvas-draw) -(import canvas-draw-iup) (use sqlite3 srfi-1 posix regex regex-case srfi-69) (import (prefix sqlite3 sqlite3:)) -(declare (uses common)) (declare (uses margs)) -(declare (uses keys)) -(declare (uses items)) +(declare (uses launch)) +(declare (uses megatest-version)) +(declare (uses gutils)) (declare (uses db)) -(declare (uses configf)) -(declare (uses process)) -(declare (uses launch)) -(declare (uses runs)) -(declare (uses dashboard-tests)) -(declare (uses dashboard-guimonitor)) -(declare (uses tree)) +(declare (uses server)) +(declare (uses synchash)) (declare (uses dcommon)) - -;; (declare (uses dashboard-main)) -(declare (uses megatest-version)) -(declare (uses mt)) +(declare (uses tree)) (include "common_records.scm") (include "db_records.scm") -(include "run_records.scm") -(include "megatest-fossil-hash.scm") +(include "key_records.scm") (define help (conc "Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest version " megatest-version " - license GPL, Copyright (C) Matt Welland 2012-2014 + license GPL, Copyright (C) Matt Welland 2011 Usage: dashboard [options] - -h : this help - -server host:port : connect to host:port instead of db access - -test run-id,test-id : control test identified by testid - -guimonitor : control panel for runs + -h : this help + -server host:port : connect to host:port instead of db access + -test testid : control test identified by testid + -guimonitor : control panel for runs Misc -rows N : set number of rows ")) @@ -63,14 +52,12 @@ (list "-rows" "-run" "-test" "-debug" "-host" - "-transport" ) (list "-h" - "-use-server" "-guimonitor" "-main" "-v" "-q" ) @@ -85,1499 +72,565 @@ (if (not (launch:setup-for-run)) (begin (print "Failed to find megatest.config, exiting") (exit 1))) -(define *dbdir* (db:dbfile-path #f)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db")) +;; (if (args:get-arg "-host") +;; (begin +;; (set! (common:get-remote remote) (string-split (args:get-arg "-host" ":"))) +;; (client:launch)) +;; (client:launch)) + +;; ease debugging by loading ~/.dashboardrc +(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.dashboardrc"))) + (if (file-exists? debugcontrolf) + (load debugcontrolf))) + +(define *dbdir* (db:dbfile-path #f)) (define *dbstruct-local* (make-dbr:dbstruct path: *dbdir* local: #t)) (define *db-file-path* (db:dbfile-path 0)) ;; HACK ALERT: this is a hack, please fix. (define *read-only* (not (file-read-access? *db-file-path*))) -(define toplevel #f) -(define dlg #f) -(define max-test-num 0) -(define *keys* (db:get-keys *dbstruct-local*)) - -(define *dbkeys* (append *keys* (list "runname"))) - -(define *header* #f) -(define *allruns* '()) -(define *allruns-by-id* (make-hash-table)) ;; -(define *runchangerate* (make-hash-table)) - -(define *buttondat* (make-hash-table)) ;; -(define *alltestnamelst* '()) -(define *searchpatts* (make-hash-table)) -(define *num-runs* 8) -(define *tot-run-count* (db:get-num-runs *dbstruct-local* "%")) -;; (define *tot-run-count* (db:get-num-runs *dbstruct-local* "%")) - -;; Update management -;; -(define *last-update* (current-seconds)) -(define *last-db-update-time* 0) -(define *please-update-buttons* #t) -(define *delayed-update* 0) -(define *update-is-running* #f) -(define *update-mutex* (make-mutex)) - -(define *all-item-test-names* '()) -(define *num-tests* 15) -(define *start-run-offset* 0) -(define *start-test-offset* 0) -(define *examine-test-dat* (make-hash-table)) -(define *exit-started* #f) -(define *status-ignore-hash* (make-hash-table)) -(define *state-ignore-hash* (make-hash-table)) - -(define *tests-sort-options* (vector (vector "Sort +a" 'testname "ASC") - (vector "Sort -a" 'testname "DESC") - (vector "Sort +t" 'event_time "ASC") - (vector "Sort -t" 'event_time "DESC") - (vector "Sort +s" 'statestatus "ASC") - (vector "Sort -s" 'statestatus "DESC") - (vector "Sort +a" 'testname "ASC"))) - -(define *tests-sort-type-index* '(("+testname" 0) - ("-testname" 1) - ("+event_time" 2) - ("-event_time" 3) - ("+statestatus" 4) - ("-statestatus" 5))) - -;; Don't forget to adjust the >= below if you add to the sort-options above -(define (next-sort-option) - (if (>= *tests-sort-reverse* 5) - (set! *tests-sort-reverse* 0) - (set! *tests-sort-reverse* (+ *tests-sort-reverse* 1))) - *tests-sort-reverse*) - -(define *tests-sort-reverse* - (let ((t-sort (assoc (configf:lookup *configdat* "dashboard" "testsort") *tests-sort-type-index*))) - (if t-sort - (cadr t-sort) - 3))) - -(define (get-curr-sort) - (vector-ref *tests-sort-options* *tests-sort-reverse*)) - -(define *hide-empty-runs* #f) -(define *hide-not-hide* #t) ;; toggle for hide/not hide -(define *hide-not-hide-button* #f) -(define *hide-not-hide-tabs* #f) - -(define *current-tab-number* 0) -(define *updaters* (make-hash-table)) - (debug:setup) -(define uidat #f) - -(define-inline (dboard:uidat-get-keycol vec)(vector-ref vec 0)) -(define-inline (dboard:uidat-get-lftcol vec)(vector-ref vec 1)) -(define-inline (dboard:uidat-get-header vec)(vector-ref vec 2)) -(define-inline (dboard:uidat-get-runsvec vec)(vector-ref vec 3)) - -(if (get-environment-variable "MT_RUN_AREA_HOME")(change-directory (get-environment-variable "MT_RUN_AREA_HOME"))) +(define *tim* (iup:timer)) +(define *ord* #f) + +(iup:attribute-set! *tim* "TIME" 300) +(iup:attribute-set! *tim* "RUN" "YES") (define (message-window msg) (iup:show (iup:dialog (iup:vbox (iup:label msg #:margin "40x40"))))) -(define (iuplistbox-fill-list lb items #!key (selected-item #f)) - (let ((i 1)) +(define (iuplistbox-fill-list lb items . default) + (let ((i 1) + (selected-item (if (null? default) #f (car default)))) + (iup:attribute-set! lb "VALUE" (if selected-item selected-item "")) (for-each (lambda (item) (iup:attribute-set! lb (number->string i) item) (if selected-item (if (equal? selected-item item) - (iup:attribute-set! lb "VALUE" i))) ;; (number->string i)))) + (iup:attribute-set! lb "VALUE" item))) ;; (number->string i)))) (set! i (+ i 1))) items) - ;; (iup:attribute-set! lb "VALUE" (if selected-item selected-item "")) i)) (define (pad-list l n)(append l (make-list (- n (length l))))) -(define (colors-similar? color1 color2) - (let* ((c1 (map string->number (string-split color1))) - (c2 (map string->number (string-split color2))) - (delta (map (lambda (a b)(abs (- a b))) c1 c2))) - (null? (filter (lambda (x)(> x 3)) delta)))) - -;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") ) -(define (update-rundat runnamepatt numruns testnamepatt keypatts) - (let* ((referenced-run-ids '()) - (allruns (db:get-runs *dbstruct-local* runnamepatt numruns ;; (+ numruns 1) ;; (/ numruns 2)) - *start-run-offset* keypatts)) - (header (db:get-header allruns)) - (runs (db:get-rows allruns)) - (result '()) - (maxtests 0) - (states (hash-table-keys *state-ignore-hash*)) - (statuses (hash-table-keys *status-ignore-hash*)) - (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))) - ;; - ;; trim runs to only those that are changing often here - ;; - (for-each (lambda (run) - (let* ((run-id (db:get-value-by-header run header "id")) - (tests (db:get-tests-for-run *dbstruct-local* run-id testnamepatt states statuses - #f #f - *hide-not-hide* - sort-by - sort-order - 'shortlist)) - ;; NOTE: bubble-up also sets the global *all-item-test-names* - ;; (tests (bubble-up tmptests priority: bubble-type)) - (key-vals (db:get-key-vals *dbstruct-local* run-id))) - ;; 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) - ;; Not sure this is needed? - (set! referenced-run-ids (cons run-id referenced-run-ids)) - (if (> (length tests) maxtests) - (set! maxtests (length tests))) - (if (or (not *hide-empty-runs*) ;; this reduces the data burden when set - (not (null? tests))) - (let ((dstruct (vector run tests key-vals))) - ;; - ;; compare the tests with the tests in *allruns-by-id* same run-id - ;; if different then increment value in *runchangerate* - ;; - (hash-table-set! *allruns-by-id* run-id dstruct) - (set! result (cons dstruct result)))))) - runs) - - (set! *header* header) - (set! *allruns* result) - (debug:print-info 6 "*allruns* has " (length *allruns*) " runs") - maxtests)) - -(define *collapsed* (make-hash-table)) -; (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)) - (if (hash-table-ref/default *collapsed* basetestname #f) - (begin - ;(iup:attribute-set! btn "FGCOLOR" "0 0 0") - (hash-table-delete! *collapsed* basetestname)) - (begin - ;(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 "(")) - (res (vector "" ""))) - (vector-set! res 0 (car splst)) - (if (> (length splst) 1) - (vector-set! res 1 (car (string-split (cadr splst) ")")))) - res)) - lst)) - -(define (collapse-rows inlst) - (let* ((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)) - (newlst (filter (lambda (x) - (let* ((tparts (string-split x "(")) - (basetname (if (null? tparts) x (car tparts)))) - ;(print "x " x " tparts: " tparts " basetname: " basetname) - (cond - ((string-match blank-line-rx x) #f) - ((equal? x basetname) #t) - ((hash-table-ref/default *collapsed* basetname #f) - ;(print "Removing " basetname " from items") - #f) - (else #t)))) - inlst)) - (vlst (run-item-name->vectors newlst)) - (vlst2 (bubble-up vlst priority: bubble-type))) - (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)) - (maxn (- numcols 1)) - (allvals (make-vector numcols ""))) - (for-each (lambda (name) - (if (<= rown maxn) - (vector-set! allvals rown name)) ;) - (set! rown (+ 1 rown))) - *alltestnamelst*) - (let loop ((i 0)) - (let* ((lbl (vector-ref lftcol i)) - (keyval (vector-ref keycol i)) - (oldval (iup:attribute lbl "TITLE")) - (newval (vector-ref allvals i))) - (if (not (equal? oldval newval)) - (let ((munged-val (let ((parts (string-split newval "("))) - (if (> (length parts) 1)(conc " " (car (string-split (cadr parts) ")"))) newval)))) - (vector-set! keycol i newval) - (iup:attribute-set! lbl "TITLE" munged-val))) - (iup:attribute-set! lbl "FGCOLOR" (if (hash-table-ref/default *collapsed* newval #f) "0 112 112" "0 0 0")) - (if (< i maxn) - (loop (+ i 1))))))) - -;; -(define (get-itemized-tests test-dats) - (let ((tnames '())) - (for-each (lambda (tdat) - (let ((tname (vector-ref tdat 0)) ;; (db:test-get-testname tdat)) - (ipath (vector-ref tdat 1))) ;; (db:test-get-item-path tdat))) - (if (not (equal? ipath "")) - (if (and (list? tnames) - (string? tname) - (not (member tname tnames))) - (set! tnames (append tnames (list tname))))))) - test-dats) - tnames)) - -;; Bubble up the top tests to above the items, collect the items underneath -;; all while preserving the sort order from the SQL query as best as possible. -;; -(define (bubble-up test-dats #!key (priority 'itempath)) - (if (null? test-dats) - test-dats - (begin - (let* ((tnames '()) ;; list of names used to reserve order - (tests (make-hash-table)) ;; hash of lists, used to build as we go - (itemized (get-itemized-tests test-dats))) - (for-each - (lambda (testdat) - (let* ((tname (vector-ref testdat 0)) ;; db:test-get-testname testdat)) - (ipath (vector-ref testdat 1))) ;; db:test-get-item-path testdat))) - ;; (seen (hash-table-ref/default tests tname #f))) - (if (not (member tname tnames)) - (if (or (and (eq? priority 'itempath) - (not (equal? ipath ""))) - (and (eq? priority 'testname) - (equal? ipath "")) - (not (member tname itemized))) - (set! tnames (append tnames (list tname))))) - (if (equal? ipath "") - ;; This a top level, prepend it - (hash-table-set! tests tname (cons testdat (hash-table-ref/default tests tname '()))) - ;; This is item, append it - (hash-table-set! tests tname (append (hash-table-ref/default tests tname '())(list testdat)))))) - test-dats) - ;; Set all tests with items - (set! *all-item-test-names* (append (if (null? tnames) - '() - (filter (lambda (tname) - (let ((tlst (hash-table-ref tests tname))) - (and (list tlst) - (> (length tlst) 1)))) - tnames)) - *all-item-test-names*)) - (let loop ((hed (car tnames)) - (tal (cdr tnames)) - (res '())) - (let ((newres (append res (hash-table-ref tests hed)))) - (if (null? tal) - newres - (loop (car tal)(cdr tal) newres)))))))) - -(define (update-buttons uidat numruns numtests) - (let* ((runs (if (> (length *allruns*) numruns) - (take-right *allruns* numruns) - (pad-list *allruns* numruns))) - (lftcol (dboard:uidat-get-lftcol uidat)) - (tableheader (dboard:uidat-get-header uidat)) - (table (dboard:uidat-get-runsvec uidat)) - (coln 0)) - (set! *alltestnamelst* '()) - ;; create a concise list of test names - (for-each - (lambda (rundat) - (if (vector? rundat) - (let* ((testdat (vector-ref rundat 1)) - (testnames (map test:test-get-fullname testdat))) - (if (not (and *hide-empty-runs* - (null? testnames))) - (for-each (lambda (testname) - (if (not (member testname *alltestnamelst*)) - (begin - (set! *alltestnamelst* (append *alltestnamelst* (list testname)))))) - testnames))))) - runs) - - (set! *alltestnamelst* (collapse-rows *alltestnamelst*)) ;;; argh. please clean up this sillyness - (set! *alltestnamelst* (let ((xl (if (> (length *alltestnamelst*) *start-test-offset*) - (drop *alltestnamelst* *start-test-offset*) - '()))) - (append xl (make-list (- *num-tests* (length xl)) "")))) - (update-labels uidat) - (for-each - (lambda (rundat) - (if (not rundat) ;; handle padded runs - ;; ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration - (set! rundat (vector (make-vector 20 #f) '() (map (lambda (x) "") *keys*))));; 3))) - (let* ((run (vector-ref rundat 0)) - (testsdat (vector-ref rundat 1)) - (key-val-dat (vector-ref rundat 2)) - (run-id (db:get-value-by-header run *header* "id")) - (key-vals (append key-val-dat - (list (let ((x (db:get-value-by-header run *header* "runname"))) - (if x x ""))))) - (run-key (string-intersperse key-vals "\n"))) - - ;; fill in the run header key values - (let ((rown 0) - (headercol (vector-ref tableheader coln))) - (for-each (lambda (kval) - (let* ((labl (vector-ref headercol rown))) - (if (not (equal? kval (iup:attribute labl "TITLE"))) - (iup:attribute-set! (vector-ref headercol rown) "TITLE" kval)) - (set! rown (+ rown 1)))) - key-vals)) - - ;; For this run now fill in the buttons for each test - (let ((rown 0) - (columndat (vector-ref table coln))) - (for-each - (lambda (testname) - (let ((buttondat (hash-table-ref/default *buttondat* (mkstr coln rown) #f))) - (if buttondat - (let* ((test (let ((matching (filter - (lambda (x)(equal? (test:test-get-fullname x) testname)) - testsdat))) - (if (null? matching) - (vector -1 -1 "" "" "" 0 "" "" 0 "" "" "" 0 "" "") - (car matching)))) - (testname (db:test-get-testname test)) - (itempath (db:test-get-item-path test)) - (testfullname (test:test-get-fullname test)) - (teststatus (db:test-get-status test)) - (teststate (db:test-get-state test)) - ;;(teststart (db:test-get-event_time test)) - ;;(runtime (db:test-get-run_duration test)) - (buttontxt (cond - ((member teststate '("COMPLETED" "ARCHIVED")) teststatus) - ((and (equal? teststate "NOT_STARTED") - (member teststatus '("ZERO_ITEMS" "BLOCKED" "PREQ_FAIL" "PREQ_DISCARDED" "TIMED_OUT" "KEEP_TRYING" "TEN_STRIKES"))) - teststatus) - (else - teststate))) - (button (vector-ref columndat rown)) - (color (car (gutils:get-color-for-state-status teststate teststatus))) - (curr-color (vector-ref buttondat 1)) ;; (iup:attribute button "BGCOLOR")) - (curr-title (vector-ref buttondat 2))) ;; (iup:attribute button "TITLE"))) - (if (not (equal? curr-color color)) - (iup:attribute-set! button "BGCOLOR" color)) - (if (not (equal? curr-title buttontxt)) - (iup:attribute-set! button "TITLE" buttontxt)) - (vector-set! buttondat 0 run-id) - (vector-set! buttondat 1 color) - (vector-set! buttondat 2 buttontxt) - (vector-set! buttondat 3 test) - (vector-set! buttondat 4 run-key))) - (set! rown (+ rown 1)))) - *alltestnamelst*)) - (set! coln (+ coln 1)))) - runs))) (define (mkstr . x) (string-intersperse (map conc x) ",")) -(define (set-bg-on-filter) - (let ((search-changed (not (null? (filter (lambda (key) - (not (equal? (hash-table-ref *searchpatts* key) "%"))) - (hash-table-keys *searchpatts*))))) - (state-changed (not (null? (hash-table-keys *state-ignore-hash*)))) - (status-changed (not (null? (hash-table-keys *status-ignore-hash*))))) - (iup:attribute-set! *hide-not-hide-tabs* "BGCOLOR" - (if (or search-changed - state-changed - status-changed) - "190 180 190" - "190 190 190" - )))) - -(define (update-search x val) - (hash-table-set! *searchpatts* x val) - (set-bg-on-filter)) - -(define (mark-for-update) - (set! *last-db-update-time* 0) - (set! *delayed-update* 1)) - -;;====================================================================== -;; R U N C O N T R O L -;;====================================================================== - -;; target populating logic -;; -;; lb = -;; field = target field name for this dropdown -;; referent-vals = selected value in the left dropdown -;; targets = list of targets to use to build the dropdown -;; -;; each node is chained: key1 -> key2 -> key3 -;; -;; must select values from only apropriate targets -;; a b c -;; a d e -;; a b f -;; a/b => c f -;; -(define (dashboard:populate-target-dropdown lb referent-vals targets) ;; runconf-targs) - ;; is the current value in the new list? choose new default if not - (let* ((remvalues (map (lambda (row) - (common:list-is-sublist referent-vals (vector->list row))) - targets)) - (values (delete-duplicates (map car (filter list? remvalues)))) - (sel-valnum (iup:attribute lb "VALUE")) - (sel-val (iup:attribute lb sel-valnum)) - (val-num 1)) - ;; first check if the current value is in the new list, otherwise replace with - ;; first value from values - (iup:attribute-set! lb "REMOVEITEM" "ALL") - (for-each (lambda (val) - ;; (iup:attribute-set! lb "APPENDITEM" val) - (iup:attribute-set! lb (conc val-num) val) - (if (equal? sel-val val) - (iup:attribute-set! lb "VALUE" val-num)) - (set! val-num (+ val-num 1))) - values) - (let ((val (iup:attribute lb "VALUE"))) - (if val - val - (if (not (null? values)) - (let ((newval (car values))) - (iup:attribute-set! lb "VALUE" newval) - newval)))))) - -(define (dashboard:update-target-selector key-lbs #!key (action-proc #f)) - (let* ((runconf-targs (common:get-runconfig-targets)) - (db-target-dat (db:get-targets *dbstruct-local*)) - (header (vector-ref db-target-dat 0)) - (db-targets (vector-ref db-target-dat 1)) - (all-targets (append db-targets - (map (lambda (x) - (list->vector - (take (append (string-split x "/") - (make-list (length header) "na")) - (length header)))) - runconf-targs))) - (key-listboxes (if key-lbs key-lbs (make-list (length header) #f)))) - (let loop ((key (car header)) - (remkeys (cdr header)) - (refvals '()) - (indx 0) - (lbs '())) - (let* ((lb (let ((lb (list-ref key-listboxes indx))) - (if lb - lb - (iup:listbox - #:size "45x50" - #:fontsize "10" - #:expand "YES" ;; "VERTICAL" - ;; #:dropdown "YES" - #:editbox "YES" - #:action (lambda (obj a b c) - (action-proc)) - #:caret_cb (lambda (obj a b c)(action-proc)) - )))) - ;; loop though all the targets and build the list for this dropdown - (selected-value (dashboard:populate-target-dropdown lb refvals all-targets))) - (if (null? remkeys) - ;; return a list of the listbox items and an iup:hbox with the labels and listboxes - (let ((listboxes (append lbs (list lb)))) - (list listboxes - (map (lambda (htxt lb) - (iup:vbox - (iup:label htxt) - lb)) - header - listboxes))) - (loop (car remkeys) - (cdr remkeys) - (append refvals (list selected-value)) - (+ indx 1) - (append lbs (list lb)))))))) - -;; Make a vertical list of toggles using items, when toggled call proc with the conc'd string -;; interspersed with commas -;; -(define (dashboard:text-list-toggle-box items proc) - (let ((alltgls (make-hash-table))) - (apply iup:vbox - (map (lambda (item) - (iup:toggle - item - #:expand "YES" - #:action (lambda (obj tstate) - (if (eq? tstate 0) - (hash-table-delete! alltgls item) - (hash-table-set! alltgls item #t)) - (let ((all (hash-table-keys alltgls))) - (proc all))))) - items)))) - -;; Extract the various bits of data from *data* and create the command line equivalent that will be displayed -;; -(define (dashboard:update-run-command) - (let* ((cmd-tb (dboard:data-get-command-tb *data*)) - (cmd (dboard:data-get-command *data*)) - (test-patt (let ((tp (dboard:data-get-test-patts *data*))) - (if (equal? tp "") "%" tp))) - (states (dboard:data-get-states *data*)) - (statuses (dboard:data-get-statuses *data*)) - (target (let ((targ-list (dboard:data-get-target *data*))) - (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 ",")))) - (statuses-str (if (or (not statuses) - (null? statuses)) - "" - (conc " :status " (string-intersperse statuses ",")))) - (full-cmd "megatest")) - (case (string->symbol cmd) - ((runtests) - (set! full-cmd (conc full-cmd - " -runtests " - test-patt - " -target " - target - " -runname " - run-name - ))) - ((remove-runs) - (set! full-cmd (conc full-cmd - " -remove-runs -runname " - run-name - " -target " - target - " -testpatt " - test-patt - states-str - statuses-str - ))) - (else (set! full-cmd " no valid command "))) - (iup:attribute-set! cmd-tb "VALUE" full-cmd))) - -;; Display the tests as rows of boxes on the test/task pane -;; -(define (dashboard:draw-tests cnv xadj yadj tests-draw-state sorted-testnames) - (canvas-clear! cnv) - (canvas-font-set! cnv "Helvetica, -10") - (let-values (((sizex sizey sizexmm sizeymm) (canvas-size cnv)) - ((originx originy) (canvas-origin cnv))) - ;; (print "originx: " originx " originy: " originy) - ;; (canvas-origin-set! cnv 0 (- (/ sizey 2))) - (if (hash-table-ref/default tests-draw-state 'first-time #t) - (begin - (hash-table-set! tests-draw-state 'first-time #f) - (hash-table-set! tests-draw-state 'scalef 8) - (hash-table-set! tests-draw-state 'tests-info (make-hash-table)) - (hash-table-set! tests-draw-state 'selected-tests (make-hash-table)) - ;; set these - (hash-table-set! tests-draw-state 'test-browse-xoffset 20) ;; (- 0 (* (/ sizex 2) (* 8 xadj)))) - (hash-table-set! tests-draw-state 'test-browse-yoffset 20) ;; (- 0 (* (/ sizey 2) (* 8 (- 1 yadj))))))) - (dcommon:initial-draw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames)) - (dcommon:redraw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames)) - )) - -;;====================================================================== -;; R U N C O N T R O L S -;;====================================================================== -;; -;; A gui for launching tests -;; -(define (dashboard:run-controls) - (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") - (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))))) - (dboard:data-set-target! *data* targ) - (if updater-for-runs (updater-for-runs)) - (dashboard:update-run-command)))) - (tests-draw-state (make-hash-table)) ;; use for keeping state of the test canvas - (test-patterns-textbox #f)) - (hash-table-set! tests-draw-state 'first-time #t) - (hash-table-set! tests-draw-state 'scalef 8) - (tests:get-full-data test-names test-records '() all-tests-registry) - (set! sorted-testnames (tests:sort-by-priority-and-waiton test-records)) - - ;; refer to *keys*, *dbkeys* for keys - (iup:vbox - ;; The command line display/exectution control - (iup:frame - #:title "Command to be exectuted" - (iup:hbox - (iup:label "Run on" #:size "40x") - (iup:radio - (iup:hbox - (iup:toggle "Local" #:size "40x") - (iup:toggle "Server" #:size "40x"))) - (let ((tb (iup:textbox - #:value "megatest " - #:expand "HORIZONTAL" - #:readonly "YES" - #:font "Courier New, -12" - ))) - (dboard:data-set-command-tb! *data* tb) - tb) - (iup:button "Execute" #:size "50x" - #:action (lambda (obj) - (let ((cmd (conc "xterm -geometry 180x20 -e \"" - (iup:attribute (dboard:data-get-command-tb *data*) "VALUE") - ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &"))) - (system cmd)))))) - - (iup:split - #:orientation "HORIZONTAL" - - (iup:split - #:value 300 - - ;; Target, testpatt, state and status input boxes - ;; - (iup:vbox - ;; 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")) - (lb (iup:listbox #:expand "HORIZONTAL" - #:dropdown "YES" - #:action (lambda (obj val index lbstate) - ;; (print obj " " val " " index " " lbstate) - (dboard:data-set-command! *data* val) - (dashboard:update-run-command)))) - (default-cmd (car cmds-list))) - (iuplistbox-fill-list lb cmds-list selected-item: default-cmd) - (dboard:data-set-command! *data* default-cmd) - lb))) - - (iup:frame - #:title "Runname" - (let* ((default-run-name (seconds->work-week/day (current-seconds))) - (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)) - (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)))) - (refresh-runs-list (lambda () - (let* ((target (dboard:data-get-target-string *data*)) - (runs-for-targ (db:get-runs-by-patt *dbstruct-local* *keys* "%" target #f #f)) - (runs-header (vector-ref runs-for-targ 0)) - (runs-dat (vector-ref runs-for-targ 1)) - (run-names (cons default-run-name - (map (lambda (x) - (db:get-value-by-header x runs-header "runname")) - runs-dat)))) - (iup:attribute-set! lb "REMOVEITEM" "ALL") - (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 - tb - lb))) - - (iup:frame - #:title "SELECTORS" - (iup:vbox - ;; Text box for test patterns - (iup:frame - #:title "Test patterns (one per line)" - (let ((tb (iup:textbox #:action (lambda (val a b) - (dboard:data-set-test-patts! - *data* - (dboard:lines->test-patt b)) - (dashboard:update-run-command)) - #:value (dboard:test-patt->lines - (dboard:data-get-test-patts *data*)) - #:expand "YES" - #:size "x50" - #:multiline "YES"))) - (set! test-patterns-textbox tb) - tb)) - (iup:frame - #:title "Target" - ;; Target selectors - (apply iup:hbox - (let* ((dat (dashboard:update-target-selector key-listboxes action-proc: update-keyvals)) - (key-lb (car dat)) - (combos (cadr dat))) - (set! key-listboxes key-lb) - combos))) - (iup:hbox - ;; Text box for STATES - (iup:frame - #:title "States" - (dashboard:text-list-toggle-box - ;; Move these definitions to common and find the other useages and replace! - (map cadr *common:std-states*) ;; '("COMPLETED" "RUNNING" "STUCK" "INCOMPLETE" "LAUNCHED" "REMOTEHOSTSTART" "KILLED") - (lambda (all) - (dboard:data-set-states! *data* all) - (dashboard:update-run-command)))) - ;; Text box for STATES - (iup:frame - #:title "Statuses" - (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) - (the-cnv #f) - (canvas-obj - (iup:canvas #:action (make-canvas-action - (lambda (cnv xadj yadj) - (if (not updater) - (set! updater (lambda (xadj yadj) - ;; (print "cnv: " cnv " xadj: " xadj " yadj: " yadj) - (dashboard:draw-tests cnv xadj yadj tests-draw-state sorted-testnames) - (set! last-xadj xadj) - (set! last-yadj yadj)))) - (updater xadj yadj) - (set! the-cnv cnv) - )) - ;; Following doesn't work - #:wheel-cb (lambda (obj step x y dir) ;; dir is 4 for up and 5 for down. I think. - (let ((xadj last-xadj) - (yadj (+ last-yadj (if (> step 0) - -0.01 - 0.01)))) - ;; (print "step: " step " x: " x " y: " y " dir: \"" dir "\"") - ;; (print "the-cnv: " the-cnv " obj: " obj " xadj: " xadj " yadj: " yadj " dir: " dir) - (if the-cnv - (dashboard:draw-tests the-cnv xadj yadj tests-draw-state sorted-testnames)) - (set! last-xadj xadj) - (set! last-yadj yadj) - )) - ;; #:size "50x50" - #:expand "YES" - #:scrollbar "YES" - #:posx "0.5" - #:posy "0.5" - #:button-cb (lambda (obj btn pressed x y status) - ;; (print "obj: " obj) - (let ((tests-info (hash-table-ref tests-draw-state 'tests-info)) - (selected-tests (hash-table-ref tests-draw-state 'selected-tests))) - ;; (print "x\ty\tllx\tlly\turx\tury") - (for-each (lambda (test-name) - (let* ((rec-coords (hash-table-ref tests-info test-name)) - (llx (list-ref rec-coords 0)) - (urx (list-ref rec-coords 1)) - (lly (list-ref rec-coords 2)) - (ury (list-ref rec-coords 3))) - ;; (print x "\t" y "\t" llx "\t" lly "\t" urx "\t" ury "\t" test-name " " - (if (and (eq? pressed 1) - (> x llx) - (> y lly) - (< x urx) - (< y ury)) - (let ((patterns (string-split (iup:attribute test-patterns-textbox "VALUE")))) - (let* ((selected (not (member test-name patterns))) - (newpatt-list (if selected - (cons test-name patterns) - (delete test-name patterns))) - (newpatt (string-intersperse newpatt-list "\n"))) - ;; (if cnv-obj - ;; (dashboard:draw-tests cnv-obj 0 0 tests-draw-state sorted-testnames)) - (iup:attribute-set! obj "REDRAW" "ALL") - (hash-table-set! selected-tests test-name selected) - (iup:attribute-set! test-patterns-textbox "VALUE" newpatt) - (dboard:data-set-test-patts! *data* (dboard:lines->test-patt newpatt)) - (dashboard:update-run-command) - (if updater (updater last-xadj last-yadj))))))) - (hash-table-keys tests-info))))))) - canvas-obj))) - ;; (print "obj: " obj " btn: " btn " pressed: " pressed " x: " x " y: " y " status: " status)) - - (iup:frame - #:title "Logs" ;; To be replaced with tabs - (let ((logs-tb (iup:textbox #:expand "YES" - #:multiline "YES"))) - (dboard:data-set-logs-textbox! *data* logs-tb) - logs-tb)))))) - - -;; (trace dashboard:populate-target-dropdown -;; common:list-is-sublist) -;; -;; ;; key1 key2 key3 ... -;; ;; target entry (wild cards allowed) -;; -;; ;; The action -;; (iup:hbox -;; ;; label Action | action selector -;; )) -;; ;; Test/items selector -;; (iup:hbox -;; ;; tests -;; ;; items -;; )) -;; ;; The command line -;; (iup:hbox -;; ;; commandline entry -;; ;; GO button -;; ) -;; ;; The command log monitor -;; (iup:tabs -;; ;; log monitor -;; ))) - -;;====================================================================== -;; 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))) - (iup:vbox - (iup:split - #:value 500 - (iup:frame - #:title "General Info" - (iup:vbox - (iup:hbox - (iup:label "Area Path") - (iup:textbox #:value *toppath* #:expand "HORIZONTAL")) - (iup:hbox - (dcommon:keys-matrix rawconfig) - (dcommon:general-info) - ))) - (iup:frame - #:title "Server" - (dcommon:servers-table))) - (iup:frame - #:title "Megatest config settings" - (iup:hbox - (dcommon:section-matrix rawconfig "setup" "Varname" "Value") - (iup:vbox - (dcommon:section-matrix rawconfig "server" "Varname" "Value") - ;; (iup:frame - ;; #:title "Disks Areas" - (dcommon:section-matrix rawconfig "disks" "Disk area" "Path")))) - (iup:frame - #:title "Run statistics" - (dcommon:run-stats db))))) - -;;====================================================================== -;; R U N -;;====================================================================== -;; -;; display and manage a single run at a time - -(define (tree-path->run-id path) - (if (not (null? path)) - (hash-table-ref/default (dboard:data-get-path-run-ids *data*) path #f) - #f)) - -(define dashboard:update-run-summary-tab #f) - -;; (define (tests window-id) -(define (dashboard:one-run db) - (let* ((tb (iup:treebox - #:value 0 - #:name "Runs" - #:expand "YES" - #:addexpanded "NO" - #:selection-cb - (lambda (obj id state) - ;; (print "obj: " obj ", id: " id ", state: " state) - (let* ((run-path (tree:node->path obj id)) - (run-id (tree-path->run-id (cdr run-path)))) - (if run-id - (begin - (dboard:data-set-curr-run-id! *data* run-id) - (dashboard:update-run-summary-tab))) - ;; (print "path: " (tree:node->path obj id) " run-id: " run-id) - )))) - (cell-lookup (make-hash-table)) - (run-matrix (iup:matrix - #:expand "YES" - #:click-cb - (lambda (obj lin col status) - (let* ((toolpath (car (argv))) - (key (conc lin ":" col)) - (test-id (hash-table-ref/default cell-lookup key -1)) - (cmd (conc toolpath " -test " (dboard:data-get-curr-run-id *data*) "," test-id "&"))) - (system cmd))))) - (updater (lambda () - (let* ((runs-dat (db:get-runs-by-patt db *keys* "%" #f #f #f)) - (runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records - (run-id (dboard:data-get-curr-run-id *data*)) - (tests-dat (let ((tdat (db:get-tests-for-run db run-id - (hash-table-ref/default *searchpatts* "test-name" "%/%") - (hash-table-keys *state-ignore-hash*) ;; '() - (hash-table-keys *status-ignore-hash*) ;; '() - #f #f - *hide-not-hide* - #f #f - "id,testname,item_path,state,status"))) ;; get 'em all - (sort tdat (lambda (a b) - (let* ((aval (vector-ref a 2)) - (bval (vector-ref b 2)) - (anum (string->number aval)) - (bnum (string->number bval))) - (if (and anum bnum) - (< anum bnum) - (string<= aval bval))))))) - (tests-mindat (dcommon:minimize-test-data tests-dat)) - (indices (common:sparse-list-generate-index tests-mindat)) ;; proc: set-cell)) - (row-indices (cadr indices)) - (col-indices (car indices)) - (max-row (if (null? row-indices) 1 (common:max (map cadr row-indices)))) - (max-col (if (null? col-indices) 1 (common:max (map cadr col-indices)))) - (max-visible (max (- *num-tests* 15) 3)) ;; *num-tests* is proportional to the size of the window - (numrows 1) - (numcols 1) - (changed #f) - (runs-hash (let ((ht (make-hash-table))) - (for-each (lambda (run) - (hash-table-set! ht (db:get-value-by-header run runs-header "id") run)) - (vector-ref runs-dat 1)) - ht)) - (run-ids (sort (filter number? (hash-table-keys runs-hash)) - (lambda (a b) - (let* ((record-a (hash-table-ref runs-hash a)) - (record-b (hash-table-ref runs-hash b)) - (time-a (db:get-value-by-header record-a runs-header "event_time")) - (time-b (db:get-value-by-header record-b runs-header "event_time"))) - (< time-a time-b)))))) - - ;; (iup:attribute-set! tb "VALUE" "0") - ;; (iup:attribute-set! tb "NAME" "Runs") - ;; Update the runs tree - (for-each (lambda (run-id) - (let* ((run-record (hash-table-ref/default runs-hash run-id #f)) - (key-vals (map (lambda (key)(db:get-value-by-header run-record runs-header key)) - *keys*)) - (run-name (db:get-value-by-header run-record runs-header "runname")) - (col-name (conc (string-intersperse key-vals "\n") "\n" run-name)) - (run-path (append key-vals (list run-name))) - (existing (tree:find-node tb run-path))) - (if (not (hash-table-ref/default (dboard:data-get-path-run-ids *data*) run-path #f)) - (begin - (hash-table-set! (dboard:data-get-run-keys *data*) run-id run-path) - ;; (iup:attribute-set! (dboard:data-get-runs-matrix *data*) - ;; (conc rownum ":" colnum) col-name) - ;; (hash-table-set! runid-to-col run-id (list colnum run-record)) - ;; Here we update the tests treebox and tree keys - (tree:add-node tb "Runs" run-path ;; (append key-vals (list run-name)) - userdata: (conc "run-id: " run-id)) - (hash-table-set! (dboard:data-get-path-run-ids *data*) run-path run-id) - ;; (set! colnum (+ colnum 1)) - )))) - run-ids) - (iup:attribute-set! run-matrix "CLEARVALUE" "ALL") ;; NOTE: Was CONTENTS - (iup:attribute-set! run-matrix "CLEARATTRIB" "CONTENTS") - (iup:attribute-set! run-matrix "RESIZEMATRIX" "YES") - (iup:attribute-set! run-matrix "NUMCOL" max-col ) - (iup:attribute-set! run-matrix "NUMLIN" (if (< max-row max-visible) max-visible max-row)) ;; min of 20 - ;; (iup:attribute-set! run-matrix "NUMCOL_VISIBLE" max-col) - ;; (iup:attribute-set! run-matrix "NUMLIN_VISIBLE" (if (> max-row max-visible) max-visible max-row)) - - ;; Row labels - (for-each (lambda (ind) - (let* ((name (car ind)) - (num (cadr ind)) - (key (conc num ":0"))) - (if (not (equal? (iup:attribute run-matrix key) name)) - (begin - (set! changed #t) - (iup:attribute-set! run-matrix key name))))) - row-indices) - - ;; Cell contents - (for-each (lambda (entry) - (let* ((row-name (cadr entry)) - (col-name (car entry)) - (valuedat (caddr entry)) - (test-id (list-ref valuedat 0)) - (test-name row-name) ;; (list-ref valuedat 1)) - (item-path col-name) ;; (list-ref valuedat 2)) - (state (list-ref valuedat 1)) - (status (list-ref valuedat 2)) - (value (gutils:get-color-for-state-status state status)) - (row-num (cadr (assoc row-name row-indices))) - (col-num (cadr (assoc col-name col-indices))) - (key (conc row-num ":" col-num))) - (hash-table-set! cell-lookup key test-id) - (if (not (equal? (iup:attribute run-matrix key) (cadr value))) - (begin - (set! changed #t) - (iup:attribute-set! run-matrix key (cadr value)) - (iup:attribute-set! run-matrix (conc "BGCOLOR" key) (car value)))))) - tests-mindat) - - ;; Col labels - do after setting Cell contents so they are accounted for in the size calc. - - (for-each (lambda (ind) - (let* ((name (car ind)) - (num (cadr ind)) - (key (conc "0:" num))) - (if (not (equal? (iup:attribute run-matrix key) name)) - (begin - (set! changed #t) - (iup:attribute-set! run-matrix key name) - (iup:attribute-set! run-matrix "FITTOTEXT" (conc "C" num)))))) - col-indices) - (if changed (iup:attribute-set! run-matrix "REDRAW" "ALL")))))) - - (set! dashboard:update-run-summary-tab updater) - (dboard:data-set-runs-tree! *data* tb) - (iup:split - tb - run-matrix))) - -;;====================================================================== -;; R U N S -;;====================================================================== - -(define (make-dashboard-buttons db nruns ntests keynames) - (let* ((nkeys (length keynames)) - (runsvec (make-vector nruns)) - (header (make-vector nruns)) - (lftcol (make-vector ntests)) - (keycol (make-vector ntests)) - (controls '()) - (lftlst '()) - (hdrlst '()) - (bdylst '()) - (result '()) - (i 0)) - ;; controls (along bottom) - (set! controls - (iup:hbox - (iup:vbox - (iup:frame - #:title "filter test and items" - (iup:hbox - (iup:textbox #:size "120x15" #:fontsize "10" #:value "%" - #:action (lambda (obj unk val) - (mark-for-update) - (update-search "test-name" val))) - ;;(iup:textbox #:size "60x15" #:fontsize "10" #:value "%" - ;; #:action (lambda (obj unk val) - ;; (mark-for-update) - ;; (update-search "item-name" val)) - )) - (iup:vbox - (iup:hbox - (let* ((cmds-list '("+testname" "-testname" "+event_time" "-event_time" "+statestatus" "-statestatus")) - (lb (iup:listbox #:expand "HORIZONTAL" - #:dropdown "YES" - #:action (lambda (obj val index lbstate) - (set! *tests-sort-reverse* index) - (mark-for-update)))) - (default-cmd (car (list-ref *tests-sort-type-index* *tests-sort-reverse*)))) - (iuplistbox-fill-list lb cmds-list selected-item: default-cmd) - (mark-for-update) - ;; (set! *tests-sort-reverse* *tests-sort-reverse*0) - lb) - ;; (iup:button "Sort -t" #:action (lambda (obj) - ;; (next-sort-option) - ;; (iup:attribute-set! obj "TITLE" (vector-ref (vector-ref *tests-sort-options* *tests-sort-reverse*) 0)) - ;; (mark-for-update))) - (iup:button "HideEmpty" #:action (lambda (obj) - (set! *hide-empty-runs* (not *hide-empty-runs*)) - (iup:attribute-set! obj "TITLE" (if *hide-empty-runs* "+HideE" "-HideE")) - (mark-for-update))) - (let ((hideit (iup:button "HideTests" #:action (lambda (obj) - (set! *hide-not-hide* (not *hide-not-hide*)) - (iup:attribute-set! obj "TITLE" (if *hide-not-hide* "HideTests" "NotHide")) - (mark-for-update))))) - (set! *hide-not-hide-button* hideit) - hideit)) - (iup:hbox - (iup:button "Quit" #:action (lambda (obj) - ;; (if *dbstruct-local* (db:close-all *dbstruct-local*)) - (exit))) - (iup:button "Refresh" #:action (lambda (obj) - (mark-for-update))) - (iup:button "Collapse" #:action (lambda (obj) - (let ((myname (iup:attribute obj "TITLE"))) - (if (equal? myname "Collapse") - (begin - (for-each (lambda (tname) - (hash-table-set! *collapsed* tname #t)) - *all-item-test-names*) - (iup:attribute-set! obj "TITLE" "Expand")) - (begin - (for-each (lambda (tname) - (hash-table-delete! *collapsed* tname)) - (hash-table-keys *collapsed*)) - (iup:attribute-set! obj "TITLE" "Collapse")))) - (mark-for-update)))))) - (iup:frame - #:title "state/status filter" - (iup:vbox - (apply - iup:hbox - (map (lambda (status) - (iup:toggle status #:action (lambda (obj val) - (mark-for-update) - (if (eq? val 1) - (hash-table-set! *status-ignore-hash* status #t) - (hash-table-delete! *status-ignore-hash* status)) - (set-bg-on-filter)))) - (map cadr *common:std-statuses*))) ;; '("PASS" "FAIL" "WARN" "CHECK" "WAIVED" "STUCK/DEAD" "n/a" "SKIP"))) - (apply - iup:hbox - (map (lambda (state) - (iup:toggle state #:action (lambda (obj val) - (mark-for-update) - (if (eq? val 1) - (hash-table-set! *state-ignore-hash* state #t) - (hash-table-delete! *state-ignore-hash* state)) - (set-bg-on-filter)))) - (map cadr *common:std-states*))) ;; '("RUNNING" "COMPLETED" "INCOMPLETE" "LAUNCHED" "NOT_STARTED" "KILLED" "DELETED"))) - (iup:valuator #:valuechanged_cb (lambda (obj) - (let ((val (inexact->exact (round (/ (string->number (iup:attribute obj "VALUE")) 10)))) - (oldmax (string->number (iup:attribute obj "MAX"))) - (maxruns *tot-run-count*)) - (set! *start-run-offset* val) - (mark-for-update) - (debug:print 6 "*start-run-offset* " *start-run-offset* " maxruns: " maxruns ", val: " val " oldmax: " oldmax) - (iup:attribute-set! obj "MAX" (* maxruns 10)))) - #:expand "HORIZONTAL" - #:max (* 10 (length *allruns*)) - #:min 0 - #:step 0.01))) - ;(iup:button "inc rows" #:action (lambda (obj)(set! *num-tests* (+ *num-tests* 1)))) - ;(iup:button "dec rows" #:action (lambda (obj)(set! *num-tests* (if (> *num-tests* 0)(- *num-tests* 1) 0)))) - ) - ) - - ;; 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 - (map (lambda (x) - (let ((res (iup:hbox #:expand "HORIZONTAL" - (iup:label x #:size "x15" #:fontsize "10" #:expand "HORIZONTAL") - (iup:textbox #:size "x15" #:fontsize "10" #:value "%" #:expand "HORIZONTAL" - #:action (lambda (obj unk val) - (mark-for-update) - (update-search x val)))))) - (set! i (+ i 1)) - res)) - keynames))))) - (let loop ((testnum 0) - (res '())) - (cond - ((>= testnum ntests) - ;; now lftlst will be an hbox with the test keys and the test name labels - (set! lftlst (append lftlst (list (iup:hbox #:expand "HORIZONTAL" - (iup:valuator #:valuechanged_cb (lambda (obj) - (let ((val (string->number (iup:attribute obj "VALUE"))) - (oldmax (string->number (iup:attribute obj "MAX"))) - (newmax (* 10 (length *alltestnamelst*)))) - (set! *please-update-buttons* #t) - (set! *start-test-offset* (inexact->exact (round (/ val 10)))) - (debug:print 6 "*start-test-offset* " *start-test-offset* " val: " val " newmax: " newmax " oldmax: " oldmax) - (if (< val 10) - (iup:attribute-set! obj "MAX" newmax)) - )) - #:expand "VERTICAL" - #:orientation "VERTICAL" - #:min 0 - #:step 0.01) - (apply iup:vbox (reverse res))))))) - (else - (let ((labl (iup:button "" - #:flat "YES" - #:alignment "ALEFT" - ; #:image img1 - ; #:impress img2 - #:size "x15" - #:expand "HORIZONTAL" - #:fontsize "10" - #:action (lambda (obj) - (mark-for-update) - (toggle-hide testnum))))) ;; (iup:attribute obj "TITLE")))) - (vector-set! lftcol testnum labl) - (loop (+ testnum 1)(cons labl res)))))) - ;; - (let loop ((runnum 0) - (keynum 0) - (keyvec (make-vector nkeys)) - (res '())) - (cond ;; nb// no else for this approach. - ((>= runnum nruns) #f) - ((>= keynum nkeys) - (vector-set! header runnum keyvec) - (set! hdrlst (cons (apply iup:vbox (reverse res)) hdrlst)) - (loop (+ runnum 1) 0 (make-vector nkeys) '())) - (else - (let ((labl (iup:label "" #:size "60x15" #:fontsize "10" #:expand "HORIZONTAL"))) ;; #:expand "HORIZONTAL" - (vector-set! keyvec keynum labl) - (loop runnum (+ keynum 1) keyvec (cons labl res)))))) - ;; By here the hdrlst contains a list of vboxes containing nkeys labels - (let loop ((runnum 0) - (testnum 0) - (testvec (make-vector ntests)) - (res '())) - (cond - ((>= runnum nruns) #f) ;; (vector tableheader runsvec)) - ((>= testnum ntests) - (vector-set! runsvec runnum testvec) - (set! bdylst (cons (apply iup:vbox (reverse res)) bdylst)) - (loop (+ runnum 1) 0 (make-vector ntests) '())) - (else - (let* ((button-key (mkstr runnum testnum)) - (butn (iup:button "" ;; button-key - #:size "60x15" - #:expand "HORIZONTAL" - #:fontsize "10" - #:action (lambda (x) - (let* ((toolpath (car (argv))) - (buttndat (hash-table-ref *buttondat* button-key)) - (test-id (db:test-get-id (vector-ref buttndat 3))) - (run-id (db:test-get-run_id (vector-ref buttndat 3))) - (cmd (conc toolpath " -test " run-id "," test-id "&"))) - ;(print "Launching " cmd) - (system cmd)))))) - (hash-table-set! *buttondat* button-key (vector 0 "100 100 100" button-key #f #f)) - (vector-set! testvec testnum butn) - (loop runnum (+ testnum 1) testvec (cons butn res)))))) - ;; now assemble the hdrlst and bdylst and kick off the dialog - (iup:show - (iup:dialog - #:title (conc "Megatest dashboard " (current-user-name) ":" *toppath*) - #:menu (dcommon:main-menu) - (let* ((runs-view (iup:vbox - (apply iup:hbox - (cons (apply iup:vbox lftlst) - (list - (iup:vbox - ;; the header - (apply iup:hbox (reverse hdrlst)) - (apply iup:hbox (reverse bdylst)))))) - controls)) - (tabs (iup:tabs - #:tabchangepos-cb (lambda (obj curr prev) - (set! *please-update-buttons* #t) - (set! *current-tab-number* curr)) - (dashboard:summary db) - runs-view - (dashboard:one-run db) - (dashboard:run-controls) - ))) - ;; (set! (iup:callback tabs tabchange-cb:) (lambda (a b c)(print "SWITCHED TO TAB: " a " " b " " c))) - (iup:attribute-set! tabs "TABTITLE0" "Summary") - (iup:attribute-set! tabs "TABTITLE1" "Runs") - (iup:attribute-set! tabs "TABTITLE2" "Run Summary") - (iup:attribute-set! tabs "TABTITLE3" "Run Control") - (iup:attribute-set! tabs "BGCOLOR" "190 190 190") - (set! *hide-not-hide-tabs* tabs) - tabs))) - (vector keycol lftcol header runsvec))) - -(if (or (args:get-arg "-rows") - (get-environment-variable "DASHBOARDROWS" )) - (begin - (set! *num-tests* (string->number (or (args:get-arg "-rows") - (get-environment-variable "DASHBOARDROWS")))) - (update-rundat "%" *num-runs* "%/%" '())) - (set! *num-tests* (min (max (update-rundat "%" *num-runs* "%/%" '()) 8) 20))) - -(define *tim* (iup:timer)) -(define *ord* #f) -(iup:attribute-set! *tim* "TIME" 300) -(iup:attribute-set! *tim* "RUN" "YES") - -;; Move this stuff to db.scm? I'm not sure that is the right thing to do... -;; -(define *last-db-update-time* (file-modification-time *db-file-path*)) ;; (conc *toppath* "/db/main.db"))) -(define *last-recalc-ended-time* 0) - -(define (dashboard:been-changed) - (> (file-modification-time *db-file-path*) *last-db-update-time*)) - -(define (dashboard:set-db-update-time) - (set! *last-db-update-time* (file-modification-time *db-file-path*))) - -(define (dashboard:recalc modtime please-update-buttons last-db-update-time) - (or please-update-buttons - (and (> (current-milliseconds)(+ *last-recalc-ended-time* 150)) - (> modtime last-db-update-time) - (> (current-seconds)(+ last-db-update-time 1))))) - -(define *monitor-db-path* (conc *dbdir* "/monitor.db")) -(define *last-monitor-update-time* 0) - -;; Force creation of the db in case it isn't already there. -(tasks:open-db) - -(define (dashboard:get-youngest-run-db-mod-time) - (handle-exceptions - exn - (begin - (debug:print 0 "WARNING: error in accessing databases in get-youngest-run-db-mod-time: " ((condition-property-accessor 'exn 'message) exn)) - (current-seconds)) ;; something went wrong - just print an error and return current-seconds - (apply max (map (lambda (filen) - (file-modification-time filen)) - (glob (conc *dbdir* "/*.db")))))) - -(define (dashboard:run-update x) - (let* ((modtime (dashboard:get-youngest-run-db-mod-time)) ;; (file-modification-time *db-file-path*)) - (monitor-modtime (if (file-exists? *monitor-db-path*) - (file-modification-time *monitor-db-path*) - -1)) - (run-update-time (current-seconds)) - (recalc (dashboard:recalc modtime *please-update-buttons* *last-db-update-time*))) - (if (and (eq? *current-tab-number* 0) - (or (> monitor-modtime *last-monitor-update-time*) - (> (- run-update-time *last-monitor-update-time*) 5))) ;; update every 1/2 minute just in case - (begin - (set! *last-monitor-update-time* run-update-time) ;; monitor-modtime) - (if dashboard:update-servers-table (dashboard:update-servers-table)))) - (if recalc - (begin - (case *current-tab-number* - ((0) - (if dashboard:update-summary-tab (dashboard:update-summary-tab))) - ((1) ;; The runs table is active - (update-rundat (hash-table-ref/default *searchpatts* "runname" "%") *num-runs* - (hash-table-ref/default *searchpatts* "test-name" "%/%") - ;; (hash-table-ref/default *searchpatts* "item-name" "%") - (let ((res '())) - (for-each (lambda (key) - (if (not (equal? key "runname")) - (let ((val (hash-table-ref/default *searchpatts* key #f))) - (if val (set! res (cons (list key val) res)))))) - *dbkeys*) - res)) - (update-buttons uidat *num-runs* *num-tests*)) - ((2) - (dashboard:update-run-summary-tab)) - (else - (let ((updater (hash-table-ref/default *updaters* *current-tab-number* #f))) - (if updater (updater))))) - (set! *please-update-buttons* #f) - (set! *last-db-update-time* modtime) - (set! *last-update* run-update-time) - (set! *last-recalc-ended-time* (current-milliseconds)))))) - -;;====================================================================== -;; The heavy lifting starts here -;;====================================================================== - -;; ease debugging by loading ~/.dashboardrc -(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.dashboardrc"))) - (if (file-exists? debugcontrolf) - (load debugcontrolf))) - -(cond - ((args:get-arg "-run") - (let ((runid (string->number (args:get-arg "-run")))) - (if runid - (begin - (lambda (x) - (on-exit std-exit-procedure) - (examine-run *dbstruct-local* runid))) - (begin - (print "ERROR: runid is not a number " (args:get-arg "-run")) - (exit 1))))) - ((args:get-arg "-test") ;; run-id,test-id - (let* ((dat (map string->number (string-split (args:get-arg "-test") ","))) - (run-id (car dat)) - (test-id (cadr dat))) - (if (and (number? run-id) - (number? test-id) - (>= test-id 0)) - (examine-test run-id test-id) - (begin - (debug:print 3 "INFO: tried to open test with invalid run-id,test-id. " (args:get-arg "-test")) - (exit 1))))) - ((args:get-arg "-guimonitor") - (gui-monitor *dbstruct-local*)) - (else - (set! uidat (make-dashboard-buttons *dbstruct-local* *num-runs* *num-tests* *dbkeys*)) - (iup:callback-set! *tim* - "ACTION_CB" - (lambda (x) - (let ((update-is-running #f)) - (mutex-lock! *update-mutex*) - (set! update-is-running *update-is-running*) - (if (not update-is-running) - (set! *update-is-running* #t)) - (mutex-unlock! *update-mutex*) - (if (not update-is-running) - (begin - (dashboard:run-update x) - (mutex-lock! *update-mutex*) - (set! *update-is-running* #f) - (mutex-unlock! *update-mutex*)))) - 1)))) - -(let ((th1 (make-thread (lambda () - (thread-sleep! 1) - (set! *please-update-buttons* #t) - (dashboard:run-update 1)) "update buttons once")) - ;; need to wait for first *update-is-running* #t - ;; (let loop () - ;; (mutex-lock! *update-mutex*) - ;; (if *update-is-running* - ;; (begin - ;; (set! *please-update-buttons* #t) - ;; (mark-for-update) - ;; (print "Did redraw trigger")) "First update after startup") - ;; (mutex-unlock! *update-mutex*) - ;; (thread-sleep! 1) - ;; (if (not *please-update-buttons*) - ;; (loop)))))) - (th2 (make-thread iup:main-loop "Main loop"))) - (thread-start! th1) - (thread-start! th2) - (thread-join! th2)) - -;; (iup:main-loop)(db:close-all *dbstruct-local*) +(define (update-search x val) + (hash-table-set! *searchpatts* x val)) + +;; mtest is actually the megatest.config file +;; +(define (mtest window-id area-dat) + (let* ((toppath (megatest:area-path area-dat)) + (curr-row-num 0) + (rawconfig (read-config (conc toppath "/megatest.config") #f 'return-string)) + (keys-matrix (dcommon:keys-matrix rawconfig)) + (setup-matrix (dcommon:section-matrix rawconfig "setup" "Varname" "Value")) + (jobtools-matrix (iup:matrix + #:expand "YES" + #:numcol 1 + #:numlin 5 + #:numcol-visible 1 + #:numlin-visible 3)) + (validvals-matrix (iup:matrix + #:expand "YES" + #:numcol 1 + #:numlin 2 + #:numcol-visible 1 + #:numlin-visible 2)) + (envovrd-matrix (iup:matrix + #:expand "YES" + #:numcol 1 + #:numlin 20 + #:numcol-visible 1 + #:numlin-visible 8)) + (disks-matrix (iup:matrix + #:expand "YES" + #:numcol 1 + #:numlin 20 + #:numcol-visible 1 + #:numlin-visible 8)) + ) + (iup:attribute-set! disks-matrix "0:0" "Disk Name") + (iup:attribute-set! disks-matrix "0:1" "Disk Path") + (iup:attribute-set! disks-matrix "WIDTH1" "120") + (iup:attribute-set! disks-matrix "WIDTH0" "100") + (iup:attribute-set! disks-matrix "ALIGNMENT1" "ALEFT") + (iup:attribute-set! disks-matrix "FIXTOTEXT" "C1") + (iup:attribute-set! disks-matrix "RESIZEMATRIX" "YES") + + ;; fill in existing info + (for-each + (lambda (mat fname) + (set! curr-row-num 1) + (for-each + (lambda (var) + (iup:attribute-set! mat (conc curr-row-num ":0") var) + (iup:attribute-set! mat (conc curr-row-num ":1") (config-lookup rawconfig fname var)) + (set! curr-row-num (+ curr-row-num 1))) + (configf:section-vars rawconfig fname))) + (list setup-matrix jobtools-matrix validvals-matrix envovrd-matrix disks-matrix) + (list "setup" "jobtools" "validvalues" "env-override" "disks")) + + (for-each + (lambda (mat) + (iup:attribute-set! mat "0:1" "Value") + (iup:attribute-set! mat "0:0" "Var") + (iup:attribute-set! mat "ALIGNMENT1" "ALEFT") + (iup:attribute-set! mat "FIXTOTEXT" "C1") + (iup:attribute-set! mat "RESIZEMATRIX" "YES") + (iup:attribute-set! mat "WIDTH1" "120") + (iup:attribute-set! mat "WIDTH0" "100") + ) + (list setup-matrix jobtools-matrix validvals-matrix envovrd-matrix)) + + (iup:attribute-set! validvals-matrix "WIDTH1" "290") + (iup:attribute-set! envovrd-matrix "WIDTH1" "290") + + (iup:vbox + (iup:hbox + + (iup:vbox + (let ((tabs (iup:tabs + ;; The required tab + (iup:hbox + ;; The keys + (iup:frame + #:title "Keys (required)" + (iup:vbox + (iup:label (conc "Set the fields for organising your runs\n" + "here. Note: can only be changed before\n" + "running the first run when megatest.db\n" + "is created.")) + keys-matrix)) + (iup:vbox + ;; The setup section + (iup:frame + #:title "Setup" + (iup:vbox + (iup:label (conc "max_concurrent_jobs : limits total concurrent jobs (optional)\n" + "linktree : directory where linktree will be created.")) + setup-matrix)) + ;; The jobtools + (iup:frame + #:title "Jobtools" + (iup:vbox + (iup:label (conc "launcher : tool or script to run jobs (try nbfake)\n" + "useshell : use system to run your launcher\n" + "workhosts : spread jobs out on these hosts")) + jobtools-matrix)) + ;; The disks + (iup:frame + #:title "Disks" + (iup:vbox + (iup:label (conc "Enter names and existing paths of locations to run tests")) + disks-matrix)))) + ;; The optional tab + (iup:vbox + ;; The Environment Overrides + (iup:frame + #:title "Env override" + envovrd-matrix) + ;; The valid values + (iup:frame + #:title "Validvalues" + validvals-matrix) + )))) + (iup:attribute-set! tabs "TABTITLE0" "Required settings") + (iup:attribute-set! tabs "TABTITLE1" "Optional settings") + tabs)) + )))) + +;; The runconfigs.config file +;; +(define (rconfig window-id) + (iup:vbox + (iup:frame #:title "Default"))) + +;;====================================================================== +;; T E S T S +;;====================================================================== + +(define (tree-path->test-id path) + (if (not (null? path)) + (hash-table-ref/default (dboard:data-get-path-test-ids *data*) path #f) + #f)) + +(define (test-panel window-id) + (let* ((curr-row-num 0) + (viewlog (lambda (x) + (if (file-exists? logfile) + ;(system (conc "firefox " logfile "&")) + (iup:send-url logfile) + (message-window (conc "File " logfile " not found"))))) + (xterm (lambda (x) + (if (directory-exists? rundir) + (let ((shell (if (get-environment-variable "SHELL") + (conc "-e " (get-environment-variable "SHELL")) + ""))) + (system (conc "cd " rundir + ";xterm -T \"" (string-translate testfullname "()" " ") "\" " shell "&"))) + (message-window (conc "Directory " rundir " not found"))))) + (command-text-box (iup:textbox #:expand "HORIZONTAL" #:font "Courier New, -12")) + (command-launch-button (iup:button "Execute!" + ;; #:expand "HORIZONTAL" + #:size "50x" + #:action (lambda (x) + (let ((cmd (iup:attribute command-text-box "VALUE"))) + (system (conc cmd " &")))))) + (run-test (lambda (x) + (iup:attribute-set! + command-text-box "VALUE" + (conc "xterm -geometry 180x20 -e \"megatest -target " keystring " :runname " runname + " -runtests " (conc testname "/" (if (equal? item-path "") + "%" + item-path)) + ";echo Press any key to continue;bash -c 'read -n 1 -s'\"")))) + (remove-test (lambda (x) + (iup:attribute-set! + command-text-box "VALUE" + (conc "xterm -geometry 180x20 -e \"megatest -remove-runs -target " keystring " :runname " runname + " -testpatt " (conc testname "/" (if (equal? item-path "") + "%" + item-path)) + " -v;echo Press any key to continue;bash -c 'read -n 1 -s'\"")))) + (run-info-matrix (iup:matrix + #:expand "YES" + ;; #:scrollbar "YES" + #:numcol 1 + #:numlin 4 + #:numcol-visible 1 + #:numlin-visible 4 + #:click-cb (lambda (obj lin col status) + (print "obj: " obj " lin: " lin " col: " col " status: " status)))) + (test-info-matrix (iup:matrix + #:expand "YES" + #:numcol 1 + #:numlin 7 + #:numcol-visible 1 + #:numlin-visible 7)) + (test-run-matrix (iup:matrix + #:expand "YES" + #:numcol 1 + #:numlin 5 + #:numcol-visible 1 + #:numlin-visible 5)) + (meta-dat-matrix (iup:matrix + #:expand "YES" + #:numcol 1 + #:numlin 5 + #:numcol-visible 1 + #:numlin-visible 5)) + (steps-matrix (iup:matrix + #:expand "YES" + #:numcol 6 + #:numlin 50 + #:numcol-visible 6 + #:numlin-visible 8)) + (data-matrix (iup:matrix + #:expand "YES" + #:numcol 8 + #:numlin 50 + #:numcol-visible 8 + #:numlin-visible 8)) + (updater (lambda (testdat) + (test-update window-id testdat run-info-matrix test-info-matrix test-run-matrix meta-dat-matrix steps-matrix data-matrix)))) + + ;; Set the updater in updaters + (hash-table-set! (dboard:data-get-updaters *data*) window-id updater) + ;; + (for-each + (lambda (mat) + ;; (iup:attribute-set! mat "0:1" "Value") + ;; (iup:attribute-set! mat "0:0" "Var") + (iup:attribute-set! mat "HEIGHT0" 0) + (iup:attribute-set! mat "ALIGNMENT1" "ALEFT") + ;; (iup:attribute-set! mat "FIXTOTEXT" "C1") + (iup:attribute-set! mat "RESIZEMATRIX" "YES")) + ;; (iup:attribute-set! mat "WIDTH1" "120") + ;; (iup:attribute-set! mat "WIDTH0" "100")) + (list run-info-matrix test-info-matrix test-run-matrix meta-dat-matrix)) + + ;; Steps matrix + (iup:attribute-set! steps-matrix "0:1" "Step Name") + (iup:attribute-set! steps-matrix "0:2" "Start") + (iup:attribute-set! steps-matrix "WIDTH2" "40") + (iup:attribute-set! steps-matrix "0:3" "End") + (iup:attribute-set! steps-matrix "WIDTH3" "40") + (iup:attribute-set! steps-matrix "0:4" "Status") + (iup:attribute-set! steps-matrix "WIDTH4" "40") + (iup:attribute-set! steps-matrix "0:5" "Duration") + (iup:attribute-set! steps-matrix "WIDTH5" "40") + (iup:attribute-set! steps-matrix "0:6" "Log File") + (iup:attribute-set! steps-matrix "ALIGNMENT1" "ALEFT") + ;; (iup:attribute-set! steps-matrix "FIXTOTEXT" "C1") + (iup:attribute-set! steps-matrix "RESIZEMATRIX" "YES") + ;; (iup:attribute-set! steps-matrix "WIDTH1" "120") + ;; (iup:attribute-set! steps-matrix "WIDTH0" "100") + + ;; Data matrix + ;; + (let ((rownum 1)) + (for-each + (lambda (x) + (iup:attribute-set! data-matrix (conc "0:" rownum) x) + (iup:attribute-set! data-matrix (conc "WIDTH" rownum) "50") + (set! rownum (+ rownum 1))) + (list "Category" "Variable" "Value" "Expected" "Tolerance" "Status" "Units" "Type" "Comment"))) + (iup:attribute-set! data-matrix "REDRAW" "ALL") + + (for-each + (lambda (data) + (let ((mat (car data)) + (keys (cadr data)) + (rownum 1)) + (for-each + (lambda (key) + (iup:attribute-set! mat (conc rownum ":0") key) + (set! rownum (+ rownum 1))) + keys) + (iup:attribute-set! mat "REDRAW" "ALL"))) + (list + (list run-info-matrix '("Run Id" "Target" "Runname" "Run Start Time" )) + (list test-info-matrix '("Test Id" "Testname" "Itempath" "State" "Status" "Test Start Time" "Comment")) + (list test-run-matrix '("Hostname" "Host info" "Disk Free" "CPU Load" "Run Duration")) + (list meta-dat-matrix '("Author" "Owner" "Last Reviewed" "Tags" "Description")))) + + (iup:split + #:orientation "HORIZONTAL" + (iup:vbox + (iup:hbox + (iup:vbox + run-info-matrix + test-info-matrix) + ;; test-info-matrix) + (iup:vbox + test-run-matrix + meta-dat-matrix)) + (iup:vbox + (iup:vbox + (iup:hbox + (iup:button "View Log" #:action viewlog #:size "60x" ) ;; #:size "30x" + (iup:button "Start Xterm" #:action xterm #:size "60x" )) ;; #:size "30x" + (iup:hbox + (iup:button "Run Test" #:action run-test #:size "60x" ) ;; #:size "30x" + (iup:button "Clean Test" #:action remove-test #:size "60x" ))) ;; #:size "30x" + (iup:hbox + ;; hiup:split ;; hbox + ;; #:orientation "HORIZONTAL" + ;; #:value 300 + command-text-box + command-launch-button))) + (iup:vbox + (let ((tabs (iup:tabs + steps-matrix + data-matrix))) + (iup:attribute-set! tabs "TABTITLE0" "Test Steps") + (iup:attribute-set! tabs "TABTITLE1" "Test Data") + tabs))))) + +;; Test browser +(define (tests window-id) + (iup:split + (let* ((tb (iup:treebox + #:selection-cb + (lambda (obj id state) + ;; (print "obj: " obj ", id: " id ", state: " state) + (let* ((run-path (tree:node->path obj id)) + (test-id (tree-path->test-id (cdr run-path)))) + (if test-id + (hash-table-set! (dboard:data-get-curr-test-ids *data*) + window-id test-id)) + (print "path: " (tree:node->path obj id) " test-id: " test-id)))))) + (iup:attribute-set! tb "VALUE" "0") + (iup:attribute-set! tb "NAME" "Runs") + ;;(iup:attribute-set! tb "ADDEXPANDED" "NO") + (dboard:data-set-tests-tree! *data* tb) + tb) + (test-panel window-id))) + +;; The function to update the fields in the test view panel +(define (test-update window-id testdat run-info-matrix test-info-matrix test-run-matrix meta-dat-matrix steps-matrix data-matrix) + ;; get test-id + ;; then get test record + (if testdat + (let* ((test-id (hash-table-ref/default (dboard:data-get-curr-test-ids *data*) window-id #f)) + (test-data (hash-table-ref/default testdat test-id #f)) + (run-id (db:test-get-run_id test-data)) + (targ/runname (hash-table-ref/default (dboard:data-get-run-keys *data*) + run-id + '())) + (target (if (null? targ/runname) "" (string-intersperse (reverse (cdr (reverse targ/runname))) "/"))) + (runname (if (null? targ/runname) "" (car (cdr targ/runname)))) + (steps-dat (tests:get-compressed-steps *dbstruct-local* run-id test-id))) + + (if test-data + (begin + ;; + (for-each + (lambda (data) + (let ((mat (car data)) + (vals (cadr data)) + (rownum 1)) + (for-each + (lambda (key) + (let ((cell (conc rownum ":1"))) + (if (not (equal? (iup:attribute mat cell)(conc key))) + (begin + ;; (print "setting cell " cell " in matrix " mat " to value " key) + (iup:attribute-set! mat cell (conc key)) + (iup:attribute-set! mat "REDRAW" cell))) + (set! rownum (+ rownum 1)))) + vals))) + (list + (list run-info-matrix + (if test-id + (list (db:test-get-run_id test-data) + target + runname + "n/a") + (make-list 4 ""))) + (list test-info-matrix + (if test-id + (list test-id + (db:test-get-testname test-data) + (db:test-get-item-path test-data) + (db:test-get-state test-data) + (db:test-get-status test-data) + (seconds->string (db:test-get-event_time test-data)) + (db:test-get-comment test-data)) + (make-list 7 ""))) + (list test-run-matrix + (if test-id + (list (db:test-get-host test-data) + (db:test-get-uname test-data) + (db:test-get-diskfree test-data) + (db:test-get-cpuload test-data) + (seconds->hr-min-sec (db:test-get-run_duration test-data))) + (make-list 5 ""))) + )) + (dcommon:populate-steps steps-dat steps-matrix)))))) + ;;(list meta-dat-matrix + ;; (if test-id + ;; (list ( + + +;; db:test-get-id +;; db:test-get-run_id +;; db:test-get-testname +;; db:test-get-state +;; db:test-get-status +;; db:test-get-event_time +;; db:test-get-host +;; db:test-get-cpuload +;; db:test-get-diskfree +;; db:test-get-uname +;; db:test-get-rundir +;; db:test-get-item-path +;; db:test-get-run_duration +;; db:test-get-final_logf +;; db:test-get-comment +;; db:test-get-fullname + + +;;====================================================================== +;; R U N C O N T R O L +;;====================================================================== + +;; Overall runs browser +;; +(define (runs window-id) + (let* ((runs-matrix (iup:matrix + #:expand "YES" + ;; #:fittosize "YES" + #:scrollbar "YES" + #:numcol 100 + #:numlin 100 + #:numcol-visible 7 + #:numlin-visible 7 + #:click-cb (lambda (obj lin col status) + (print "obj: " obj " lin: " lin " col: " col " status: " status))))) + + (iup:attribute-set! runs-matrix "RESIZEMATRIX" "YES") + (iup:attribute-set! runs-matrix "WIDTH0" "100") + + (dboard:data-set-runs-matrix! *data* runs-matrix) + (iup:hbox + (iup:frame + #:title "Runs browser" + (iup:vbox + runs-matrix))))) + +;; Browse and control a single run +;; +(define (runcontrol window-id) + (iup:hbox)) + +;;====================================================================== +;; D A S H B O A R D +;;====================================================================== + +;; Main Panel +(define (main-panel window-id) + (iup:dialog + #:title "Megatest Control Panel" + #:menu (dcommon:main-menu) + #:shrink "YES" + (let ((tabtop (iup:tabs + (runs window-id) + (tests window-id) + (runcontrol window-id) + (mtest window-id) + (rconfig window-id) + ))) + (iup:attribute-set! tabtop "TABTITLE0" "Runs") + (iup:attribute-set! tabtop "TABTITLE1" "Tests") + (iup:attribute-set! tabtop "TABTITLE2" "Run Control") + (iup:attribute-set! tabtop "TABTITLE3" "megatest.config") + (iup:attribute-set! tabtop "TABTITLE4" "runconfigs.config") + tabtop))) + +(define *current-window-id* 0) + +(define (newdashboard data) + (let* ((keys (db:get-keys dbstruct)) + (runname "%") + (testpatt "%") + (keypatts (map (lambda (k)(list k "%")) keys)) + (states '()) + (statuses '()) + (nextmintime (current-milliseconds)) + (my-window-id *current-window-id*)) + (set! *current-window-id* (+ 1 *current-window-id*)) + (dboard:data-set-runs! *data* data) ;; make this data available to the rest of the application + (iup:show (main-panel my-window-id)) + ;; Yes, running iup:show will pop up a new panel + ;; (iup:show (main-panel my-window-id)) + (iup:callback-set! *tim* + "ACTION_CB" + (lambda (x) + ;; Want to dedicate no more than 50% of the time to this so skip if + ;; 2x delta time has not passed since last query + (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")))))) +;;; main +;;; +(let ((data (make-hash-table))) ;; data will have "areaname" => "area record" entries + (newdashboard data) + (iup:main-loop)) Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -98,16 +98,16 @@ (mutex-unlock! *rundb-mutex*)))) ;; (db:with-db dbstruct run-id sqlite3:exec "select blah from blaz;") ;; r/w is a flag to indicate if the db is modified by this query #t = yes, #f = no ;; -(define (db:with-db dbstruct run-id r/w proc . params) +(define (db:with-db dbstruct area-dat run-id r/w proc . params) (let* ((dbdat (if (vector? dbstruct) (db:get-db dbstruct run-id) dbstruct)) ;; cheat, allow for passing in a dbdat - (db (db:dbdat-get-db dbdat))) - (db:delay-if-busy dbdat) + (db (db:dbdat-get-db dbdat area-dat))) + (db:delay-if-busy dbdat area-dat) (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)) (print-call-chain (current-error-port))) @@ -121,11 +121,11 @@ ;; (define (db:get-filedb dbstruct run-id) ;; (let ((db (vector-ref dbstruct 2))) ;; (if db ;; db -;; (let ((fdb (filedb:open-db (conc *toplevel* "/db/files.db")))) +;; (let ((fdb (filedb:open-db (conc toppath "/db/files.db")))) ;; (vector-set! dbstruct 2 fdb) ;; fdb)))) ;; ;; ;; Can also be used to save arbitrary strings ;; ;; @@ -140,14 +140,16 @@ ;; (filedb:get-path db id))) ;; NB// #f => return dbdir only ;; (was planned to be; zeroth db with name=main.db) ;; -(define (db:dbfile-path run-id) +(define (db:dbfile-path run-id area-dat) (let* (;; (toppath (dbr:dbstruct-get-path dbstruct)) - (link-tree-path (configf:lookup *configdat* "setup" "linktree")) - (dbpath (configf:lookup *configdat* "setup" "dbdir")) + (configdat (megatest:area-configdat area-dat)) + (toppath (megatest:area-path area-dat)) + (link-tree-path (configf:lookup configdat "setup" "linktree")) + (dbpath (configf:lookup configdat "setup" "dbdir")) (fname (if run-id (if (eq? run-id 0) "main.db" (conc run-id ".db")) #f)) (dbdir (if dbpath dbpath @@ -160,12 +162,12 @@ (if (not (directory? dbdir))(create-directory dbdir #t))) (if fname (conc dbdir fname) dbdir))) -(define (db:set-sync db) - (let ((syncprag (configf:lookup *configdat* "setup" "sychronous"))) +(define (db:set-sync db area-dat) + (let ((syncprag (configf:lookup (megatest:area-configdat area-dat) "setup" "sychronous"))) (sqlite3:execute db (conc "PRAGMA synchronous = " (or syncprag 1) ";")))) ;; open an sql database inside a file lock ;; ;; returns: db existed-prior-to-opening @@ -191,11 +193,11 @@ (debug:print 0 "ERROR: no such 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*))) +(define (db:open-rundb dbstruct run-id #!key (attemptnum 0)(do-not-open #f)) ;; (conc toppath "/megatest.db") (car configinfo))) (let* ((local (dbr:dbstruct-get-local dbstruct)) (rdb (if local (dbr:dbstruct-get-localdb dbstruct run-id) (dbr:dbstruct-get-inmem dbstruct)))) ;; (dbr:dbstruct-get-runrec dbstruct run-id 'inmem))) (if (or rdb @@ -244,22 +246,22 @@ db) (begin (dbr:dbstruct-set-inmem! dbstruct inmem) ;; dec 14, 2014 - keep deleted records available. hunch is that they are needed for id placeholders ;; (sqlite3:execute db "DELETE FROM tests WHERE state='DELETED';") ;; they just slow us down in this context - (db:sync-tables db:sync-tests-only db inmem) - (db:delay-if-busy refdb) ;; dbpath: (db:dbdat-get-path refdb)) ;; What does delaying here achieve? + (db:sync-tables area-dat db:sync-tests-only db inmem) + (db:delay-if-busy refdb area-dat) ;; dbpath: (db:dbdat-get-path refdb)) ;; What does delaying here achieve? (dbr:dbstruct-set-refdb! dbstruct refdb) - (db:sync-tables db:sync-tests-only inmem refdb) ;; use inmem as the reference, don't read again from db + (db:sync-tables area-dat db:sync-tests-only inmem refdb) ;; use inmem as the reference, don't read again from db ;; sync once more to deal with delays? ;; (db:sync-tables db:sync-tests-only db inmem) ;; (db:sync-tables db:sync-tests-only inmem refdb) inmem)))))) ;; This routine creates the db. It is only called if the db is not already ls opened ;; -(define (db:open-main dbstruct) ;; (conc *toppath* "/megatest.db") (car *configinfo*))) +(define (db:open-main dbstruct) ;; (conc toppath "/megatest.db") (car configinfo))) (let ((mdb (dbr:dbstruct-get-main dbstruct))) (if mdb mdb (let* ((dbpath (db:dbfile-path 0)) (dbexists (file-exists? dbpath)) @@ -274,18 +276,19 @@ dbdat)))) ;; Make the dbstruct, setup up auxillary db's and call for main db at least once ;; (define (db:setup run-id #!key (local #f)) - (let* ((dbdir (db:dbfile-path #f)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db")) + (let* ((dbdir (db:dbfile-path #f)) ;; (conc (configf:lookup configdat "setup" "linktree") "/.db")) (dbstruct (make-dbr:dbstruct path: dbdir local: local))) dbstruct)) ;; Open the classic megatest.db file in toppath ;; -(define (db:open-megatest-db) - (let* ((dbpath (conc *toppath* "/megatest.db")) +(define (db:open-megatest-db area-dat) + (let* ((toppath (megatest:area-path area-dat)) + (dbpath (conc toppath "/megatest.db")) (dbexists (file-exists? dbpath)) (db (db:lock-create-open dbpath (lambda (db) (db:initialize-main-db db) (db:initialize-run-id-db db)))) @@ -314,13 +317,13 @@ (if (or (not (number? mtime)) (not (number? stime)) (> mtime stime) force-sync) (begin - (db:delay-if-busy maindb) - (db:delay-if-busy olddb) - (let ((num-synced (db:sync-tables (db:sync-main-list maindb) maindb olddb))) + (db:delay-if-busy maindb area-dat) + (db:delay-if-busy olddb area-dat) + (let ((num-synced (db:sync-tables area-dat (db:sync-main-list maindb) maindb olddb))) (dbr:dbstruct-set-stime! dbstruct (current-milliseconds)) num-synced) 0)) (begin ;; this can occur when using local access (i.e. not in a server) @@ -332,14 +335,14 @@ (if (or (not (number? mtime)) (not (number? stime)) (> mtime stime) force-sync) (begin - (db:delay-if-busy rundb) - (db:delay-if-busy olddb) + (db:delay-if-busy rundb area-dat) + (db:delay-if-busy olddb area-dat) (dbr:dbstruct-set-stime! dbstruct (current-milliseconds)) - (let ((num-synced (db:sync-tables db:sync-tests-only inmem refdb rundb olddb))) + (let ((num-synced (db:sync-tables area-dat db:sync-tests-only inmem refdb rundb olddb))) ;; (mutex-unlock! *http-mutex*) num-synced) (begin ;; (mutex-unlock! *http-mutex*) 0)))))) @@ -488,11 +491,11 @@ '("jobgroup" #f))))) ;; tbls is ( ("tablename" ( "field1" [#f|proc1] ) ( "field2" [#f|proc2] ) .... ) ) ;; db's are dbdat's ;; -(define (db:sync-tables tbls fromdb todb . slave-dbs) +(define (db:sync-tables area-dat tbls fromdb todb . slave-dbs) (mutex-lock! *db-sync-mutex*) (handle-exceptions exn (begin (debug:print 0 "EXCEPTION: database probably overloaded or unreadable in db:sync-tables.") @@ -537,11 +540,11 @@ (full-ins (conc "INSERT OR REPLACE INTO " tablename " ( " (string-intersperse (map car fields) ",") " ) " " VALUES ( " (string-intersperse (make-list num-fields "?") ",") " );")) (fromdat '()) (fromdats '()) (totrecords 0) - (batch-len (string->number (or (configf:lookup *configdat* "sync" "batchsize") "10"))) + (batch-len (string->number (or (configf:lookup configdat "sync" "batchsize") "10"))) (todat (make-hash-table)) (count 0)) ;; set up the field->num table (for-each @@ -639,45 +642,45 @@ (mtdb (if toppath (db:open-megatest-db))) (allow-cleanup (if run-ids #f #t)) (run-ids (if run-ids run-ids (if toppath (begin - (db:delay-if-busy mtdb) + (db:delay-if-busy mtdb area-dat) (db:get-all-run-ids mtdb))))) (tdbdat (tasks:open-db)) - (servers (tasks:get-all-servers (db:delay-if-busy tdbdat)))) + (servers (tasks:get-all-servers (db:delay-if-busy tdbdat area-dat)))) ;; kill servers (if (member 'killservers options) (for-each (lambda (server) - (tasks:server-delete-record (db:delay-if-busy tdbdat) (vector-ref server 0) "dbmigration") + (tasks:server-delete-record (db:delay-if-busy tdbdat area-dat) (vector-ref server 0) "dbmigration") (tasks:kill-server (vector-ref server 2)(vector-ref server 1))) servers)) ;; clear out junk records ;; (if (member 'dejunk options) (begin - (db:delay-if-busy mtdb) + (db:delay-if-busy mtdb area-dat) (db:clean-up mtdb))) ;; adjust test-ids to fit into proper range ;; (if (member 'adj-testids options) (begin - (db:delay-if-busy mtdb) + (db:delay-if-busy mtdb area-dat) (db:prep-megatest.db-for-migration mtdb))) ;; sync runs, test_meta etc. ;; (if (member 'old2new options) (begin - (db:sync-tables (db:sync-main-list mtdb) mtdb (db:get-db dbstruct #f)) + (db:sync-tables area-dat (db:sync-main-list mtdb) mtdb (db:get-db dbstruct #f)) (for-each (lambda (run-id) - (db:delay-if-busy mtdb) + (db:delay-if-busy mtdb area-dat) (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") (db:replace-test-records dbstruct run-id testrecs) (sqlite3:finalize! (db:dbdat-get-db (dbr:dbstruct-get-rundb dbstruct))))) @@ -702,15 +705,15 @@ ;; (db:delay-if-busy frundb) ;; (db:delay-if-busy mtdb) ;; (db:clean-up frundb) (if (eq? run-id 0) (begin - (db:sync-tables (db:sync-main-list dbstruct) (db:get-db fromdb #f) mtdb) + (db:sync-tables area-dat (db:sync-main-list dbstruct) (db:get-db fromdb #f) mtdb) (set! dead-runs (db:clean-up-maindb (db:get-db fromdb #f)))) (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:sync-tables area-dat db:sync-tests-only (db:get-db fromdb run-id) mtdb) (db:clean-up-rundb (db:get-db fromdb run-id)) )))) all-run-ids) ;; removed deleted runs (let ((dbdir (tasks:get-task-db-path))) @@ -766,12 +769,12 @@ (define open-run-close open-run-close-exception-handling) ;; open-run-close-no-exception-handling ;; open-run-close-exception-handling) ;;) -(define (db:initialize-main-db dbdat) - (let* ((configdat (car *configinfo*)) ;; tut tut, global warning... +(define (db:initialize-main-db dbdat area-dat) + (let* ((configdat (megatest:area-configdat area-dat)) ;; (car configinfo)) ;; tut tut, global warning... (keys (keys:config-get-fields configdat)) (havekeys (> (length keys) 0)) (keystr (keys->keystr keys)) (fieldstr (keys->key/field keys)) (db (db:dbdat-get-db dbdat))) @@ -1077,12 +1080,13 @@ ;;====================================================================== ;; L O G G I N G D B ;;====================================================================== -(define (open-logging-db) ;; (conc *toppath* "/megatest.db") (car *configinfo*))) - (let* ((dbpath (conc (if *toppath* (conc *toppath* "/") "") "logging.db")) ;; fname) +(define (open-logging-db area-dat) ;; (conc toppath "/megatest.db") (car configinfo))) + (let* ((toppath (megatest:area-path area-dat)) + (dbpath (conc (if toppath (conc toppath "/") "") "logging.db")) ;; fname) (dbexists (file-exists? dbpath)) (db (sqlite3:open-database dbpath)) (handler (make-busy-timeout (if (args:get-arg "-override-timeout") (string->number (args:get-arg "-override-timeout")) 136000)))) ;; 136000))) @@ -1114,17 +1118,17 @@ ;;====================================================================== ;; M A I N T E N A N C E ;;====================================================================== -(define (db:have-incompletes? dbstruct run-id ovr-deadtime) +(define (db:have-incompletes? dbstruct run-id ovr-deadtime area-dat) (let* ((dbdat (db:get-db dbstruct run-id)) (db (db:dbdat-get-db dbdat)) (incompleted '()) (oldlaunched '()) (toplevels '()) - (deadtime-str (configf:lookup *configdat* "setup" "deadtime")) + (deadtime-str (configf:lookup (megatest:area-configdat area-dat) "setup" "deadtime")) (deadtime (if (and deadtime-str (string->number deadtime-str)) (string->number deadtime-str) 7200))) ;; two hours (if (number? ovr-deadtime)(set! deadtime ovr-deadtime)) @@ -1133,11 +1137,11 @@ ;; ;; HOWEVER: this code in run:test seems to work fine ;; (> (- (current-seconds)(+ (db:test-get-event_time testdat) ;; (db:test-get-run_duration testdat))) ;; 600) - (db:delay-if-busy dbdat) + (db:delay-if-busy dbdat area-dat) (sqlite3:for-each-row (lambda (test-id run-dir uname testname item-path) (if (and (equal? uname "n/a") (equal? item-path "")) ;; this is a toplevel test ;; what to do with toplevel? call rollup? @@ -1149,11 +1153,11 @@ "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) ;; in LAUNCHED for more than one day. Could be long due to job queues TODO/BUG: Need override for this in config ;; - (db:delay-if-busy dbdat) + (db:delay-if-busy dbdat area-dat) (sqlite3:for-each-row (lambda (test-id run-dir uname testname item-path) (if (and (equal? uname "n/a") (equal? item-path "")) ;; this is a toplevel test ;; what to do with toplevel? call rollup? @@ -1173,17 +1177,17 @@ ;; select end_time-now from ;; (select testname,item_path,event_time+run_duration as ;; end_time,strftime('%s','now') as now from tests where state in ;; ('RUNNING','REMOTEHOSTSTART','LAUNCED')); -(define (db:find-and-mark-incomplete dbstruct run-id ovr-deadtime) +(define (db:find-and-mark-incomplete dbstruct run-id ovr-deadtime area-dat) (let* ((dbdat (db:get-db dbstruct run-id)) (db (db:dbdat-get-db dbdat)) (incompleted '()) (oldlaunched '()) (toplevels '()) - (deadtime-str (configf:lookup *configdat* "setup" "deadtime")) + (deadtime-str (configf:lookup (megatest:area-configdat area-dat) "setup" "deadtime")) (deadtime (if (and deadtime-str (string->number deadtime-str)) (string->number deadtime-str) 7200))) ;; two hours (if (number? ovr-deadtime)(set! deadtime ovr-deadtime)) @@ -1192,11 +1196,11 @@ ;; ;; HOWEVER: this code in run:test seems to work fine ;; (> (- (current-seconds)(+ (db:test-get-event_time testdat) ;; (db:test-get-run_duration testdat))) ;; 600) - (db:delay-if-busy dbdat) + (db:delay-if-busy dbdat area-dat) (sqlite3:for-each-row (lambda (test-id run-dir uname testname item-path) (if (and (equal? uname "n/a") (equal? item-path "")) ;; this is a toplevel test ;; what to do with toplevel? call rollup? @@ -1208,11 +1212,11 @@ "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) ;; in LAUNCHED for more than one day. Could be long due to job queues TODO/BUG: Need override for this in config ;; - (db:delay-if-busy dbdat) + (db:delay-if-busy dbdat area-dat) (sqlite3:for-each-row (lambda (test-id run-dir uname testname item-path) (if (and (equal? uname "n/a") (equal? item-path "")) ;; this is a toplevel test ;; what to do with toplevel? call rollup? @@ -1224,11 +1228,11 @@ (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.") ;; These are defunct tests, do not do all the overhead of set-state-status. Force them to INCOMPLETE. ;; - (db:delay-if-busy dbdat) + (db:delay-if-busy dbdat area-dat) (let* (;; (min-incompleted (filter (lambda (x) ;; (let* ((testpath (cadr x)) ;; (tdatpath (conc testpath "/testdat.db")) ;; (dbexists (file-exists? tdatpath))) ;; (or (not dbexists) ;; if no file then something wrong - mark as incomplete @@ -1245,11 +1249,11 @@ (string-intersperse (map conc all-ids) ",") ");"))))) ;; Now do rollups for the toplevel tests ;; - (db:delay-if-busy dbdat) + (db:delay-if-busy dbdat area-dat) (for-each (lambda (toptest) (let ((test-name (list-ref toptest 3))) ;; (run-id (list-ref toptest 5))) (db:general-call db 'top-test-set-per-pf-counts (list test-name run-id test-name test-name test-name)))) ;; (list run-id test-name)))) @@ -1283,11 +1287,11 @@ ;; delete all runs that are state='deleted' "DELETE FROM runs WHERE state='deleted';" ;; delete empty runs "DELETE FROM runs WHERE id NOT IN (SELECT DISTINCT r.id FROM runs AS r INNER JOIN tests AS t ON t.run_id=r.id);" )))) - (db:delay-if-busy dbdat) + (db:delay-if-busy dbdat area-dat) (sqlite3:with-transaction db (lambda () (sqlite3:for-each-row (lambda (tot) (debug:print-info 0 "Records count before clean: " tot)) @@ -1297,11 +1301,11 @@ (debug:print-info 0 "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) + (db:delay-if-busy dbdat area-dat) (sqlite3:execute db "VACUUM;"))) ;; Clean out old junk and vacuum the database ;; ;; Ultimately do something like this: @@ -1324,11 +1328,11 @@ ;; delete all tests that belong to runs that are 'deleted' ;; (conc "DELETE FROM tests WHERE run_id NOT IN (" (string-intersperse (map conc valid-runs) ",") ");") ;; delete all tests that are 'DELETED' "DELETE FROM tests WHERE state='DELETED';" )))) - (db:delay-if-busy dbdat) + (db:delay-if-busy dbdat area-dat) (sqlite3:with-transaction db (lambda () (sqlite3:for-each-row (lambda (tot) (debug:print-info 0 "Records count before clean: " tot)) @@ -1338,11 +1342,11 @@ (debug:print-info 0 "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) + (db:delay-if-busy dbdat area-dat) (sqlite3:execute db "VACUUM;"))) ;; Clean out old junk and vacuum the database ;; ;; Ultimately do something like this: @@ -1371,11 +1375,11 @@ (sqlite3:for-each-row (lambda (run-id) (set! dead-runs (cons run-id dead-runs))) db "SELECT id FROM runs WHERE state='deleted';") - (db:delay-if-busy dbdat) + (db:delay-if-busy dbdat area-dat) (sqlite3:with-transaction db (lambda () (sqlite3:for-each-row (lambda (tot) (debug:print-info 0 "Records count before clean: " tot)) @@ -1385,11 +1389,11 @@ (debug:print-info 0 "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) + (db:delay-if-busy dbdat area-dat) (sqlite3:execute db "VACUUM;") dead-runs)) ;;====================================================================== ;; M E T A G E T A N D S E T V A R S @@ -1398,18 +1402,18 @@ ;; returns number if string->number is successful, string otherwise ;; also updates *global-delta* ;; ;; Operates on megatestdb ;; -(define (db:get-var dbstruct var) +(define (db:get-var dbstruct var area-dat) (let* ((start-ms (current-milliseconds)) - (throttle (let ((t (config-lookup *configdat* "setup" "throttle"))) + (throttle (let ((t (config-lookup (megatest:area-configdat area-dat) "setup" "throttle"))) (if t (string->number t) t))) (res #f) (dbdat (db:get-db dbstruct #f)) (db (db:dbdat-get-db dbdat))) - (db:delay-if-busy dbdat) + (db:delay-if-busy dbdat area-dat) (sqlite3:for-each-row (lambda (val) (set! res val)) db "SELECT val FROM metadat WHERE var=?;" var) @@ -1428,11 +1432,11 @@ res)) (define (db:set-var dbstruct var val) (let ((dbdat (db:get-db dbstruct #f)) (db (db:dbdat-get-db dbdat))) - (db:delay-if-busy dbdat) + (db:delay-if-busy dbdat area-dat) (sqlite3:execute db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" var val))) (define (db:del-var dbstruct var) ;; (db:delay-if-busy) (db:with-db dbstruct #f #t @@ -1441,25 +1445,23 @@ ;; use a global for some primitive caching, it is just silly to ;; re-read the db over and over again for the keys since they never ;; change -;; why get the keys from the db? why not get from the *configdat* +;; why get the keys from the db? why not get from the configdat ;; using keys:config-get-fields? (define (db:get-keys dbstruct) - (if *db-keys* *db-keys* - (let ((res '())) - (db:with-db dbstruct #f #f - (lambda (db) - (sqlite3:for-each-row - (lambda (key) - (set! res (cons key res))) - db - "SELECT fieldname FROM keys ORDER BY id DESC;"))) - (set! *db-keys* res) - res))) + (let ((res '())) + (db:with-db dbstruct #f #f + (lambda (db) + (sqlite3:for-each-row + (lambda (key) + (set! res (cons key res))) + db + "SELECT fieldname FROM keys ORDER BY id DESC;"))) + res)) ;; look up values in a header/data structure (define (db:get-value-by-header row header field) (if (null? header) #f (let loop ((hed (car header)) @@ -1545,23 +1547,23 @@ (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") (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) + (db:delay-if-busy dbdat area-dat) (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) - (db:delay-if-busy dbdat) + (db:delay-if-busy dbdat area-dat) (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) qry) qryvals) - (db:delay-if-busy dbdat) + (db:delay-if-busy dbdat area-dat) (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") #f)))) @@ -1721,11 +1723,11 @@ (totals (make-hash-table)) (curr (make-hash-table)) (res '()) (runs-info '())) ;; First get all the runname/run-ids - (db:delay-if-busy dbdat) + (db:delay-if-busy dbdat area-dat) (sqlite3:for-each-row (lambda (run-id runname) (set! runs-info (cons (list run-id runname) runs-info))) db "SELECT id,runname FROM runs WHERE state != 'deleted';") @@ -1813,11 +1815,11 @@ (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) - (db:delay-if-busy dbdat) + (db:delay-if-busy dbdat area-dat) (sqlite3:for-each-row (lambda (a . x) (set! res (apply vector a x))) db (conc "SELECT " keystr " FROM runs WHERE id=? AND state != 'deleted';") @@ -1841,15 +1843,15 @@ ;; First set any related tests to DELETED (let* ((rdbdat (db:get-db dbstruct run-id)) (rdb (db:dbdat-get-db rdbdat)) (dbdat (db:get-db dbstruct #f)) (db (db:dbdat-get-db dbdat))) - (db:delay-if-busy rdbdat) + (db:delay-if-busy rdbdat area-dat) (sqlite3:execute rdb "UPDATE tests SET state='DELETED',comment='';") (sqlite3:execute rdb "DELETE FROM test_steps;") (sqlite3:execute rdb "DELETE FROM test_data;") - (db:delay-if-busy dbdat) + (db:delay-if-busy dbdat area-dat) (sqlite3:execute db "UPDATE runs SET state='deleted',comment='' WHERE id=?;" run-id))) (define (db:update-run-event_time dbstruct run-id) (db:with-db dbstruct @@ -1874,11 +1876,11 @@ (debug:print-info 1 "" 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) + (db:delay-if-busy dbdat area-dat) (if msg (sqlite3:execute db "UPDATE runs SET status=?,comment=? WHERE id=?;" status msg run-id) (sqlite3:execute db "UPDATE runs SET status=? WHERE id=?;" status run-id)))) (define (db:get-run-status dbstruct run-id) @@ -1908,11 +1910,11 @@ (dbdat (db:get-db dbstruct #f)) (db (db:dbdat-get-db dbdat))) (for-each (lambda (key) (let ((qry (conc "SELECT " key " FROM runs WHERE id=?;"))) - (db:delay-if-busy dbdat) + (db:delay-if-busy dbdat area-dat) (sqlite3:for-each-row (lambda (key-val) (set! res (cons (list key key-val) res))) db qry run-id))) keys) @@ -1925,11 +1927,11 @@ (dbdat (db:get-db dbstruct #f)) (db (db:dbdat-get-db dbdat))) (for-each (lambda (key) (let ((qry (conc "SELECT " key " FROM runs WHERE id=?;"))) - (db:delay-if-busy dbdat) + (db:delay-if-busy dbdat area-dat) (sqlite3:for-each-row (lambda (key-val) (set! res (cons key-val res))) db qry run-id))) keys) @@ -2239,11 +2241,11 @@ (db (db:dbdat-get-db dbdat))) (if (not jobgroup) 0 ;; (let ((testnames '())) ;; get the testnames - (db:delay-if-busy dbdat) + (db:delay-if-busy dbdat area-dat) (sqlite3:for-each-row (lambda (testname) (set! testnames (cons testname testnames))) db "SELECT testname FROM test_meta WHERE jobgroup=?" @@ -2341,11 +2343,11 @@ (let* ((dbdat (if (vector? dbstruct) (db:get-db dbstruct run-id) dbstruct)) ;; still settling on when to use dbstruct or dbdat (db (db:dbdat-get-db dbdat)) (res '())) - (db:delay-if-busy dbdat) + (db:delay-if-busy dbdat area-dat) (sqlite3:for-each-row (lambda (id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment shortdir attemptnum archived) ;; 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 (set! res (cons (vector id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment shortdir attemptnum archived) res))) @@ -2536,11 +2538,11 @@ (define (db:test-data-rollup dbstruct run-id test-id status) (let* ((dbdat (db:get-db dbstruct run-id)) (db (db:dbdat-get-db dbdat)) (fail-count 0) (pass-count 0)) - (db:delay-if-busy dbdat) + (db:delay-if-busy dbdat area-dat) (sqlite3:for-each-row (lambda (fcount pcount) (set! fail-count fcount) (set! pass-count pcount)) db @@ -2605,11 +2607,11 @@ ((>=) (if (>= value expected) "pass" "fail")) ((<=) (if (<= value expected) "pass" "fail")) (else (conc "ERROR: bad tol comparator " tol)))))) (debug:print 4 "AFTER2: category: " category " variable: " variable " value: " value ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment) - (db:delay-if-busy dbdat) + (db:delay-if-busy dbdat area-dat) (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))) ;;====================================================================== @@ -2830,14 +2832,14 @@ sync set-verbosity killserver )) -(define (db:login dbstruct calling-path calling-version run-id client-signature) +(define (db:login dbstruct area-dat calling-path calling-version run-id client-signature) (cond - ((not (equal? calling-path *toppath*)) - (list #f "Login failed due to mismatch paths: " calling-path ", " *toppath*)) + ((not (equal? calling-path (megatest:area-path area-dat))) + (list #f "Login failed due to mismatch paths: " calling-path ", " (megatest:area-path area-dat))) ((not (equal? *run-id* run-id)) (list #f "Login failed due to mismatch run-id: " run-id ", " *run-id*)) ((not (equal? megatest-version calling-version)) (list #f "Login failed due to mismatch megatest version: " calling-version ", " megatest-version)) (else @@ -2848,11 +2850,11 @@ (let ((query (let ((q (alist-ref (if (string? stmtname) (string->symbol stmtname) stmtname) db:queries))) (if q (car q) #f)))) - (db:delay-if-busy dbdat) + (db:delay-if-busy dbdat area-dat) (apply sqlite3:execute (db:dbdat-get-db dbdat) query params) #t)) ;; BUG or Sillyness, why do I return #t instead of the query result? ;; get the previous records for when these tests were run where all keys match but runname ;; NB// Merge this with test:get-previous-test-run-records? This one looks for all matching tests @@ -2867,11 +2869,11 @@ (selstr (string-intersperse (map (lambda (x)(vector-ref x 0)) keys) ",")) (qrystr (string-intersperse (map (lambda (x)(conc (vector-ref x 0) "=?")) keys) " AND ")) (keyvals #f) (tests-hash (make-hash-table))) ;; first look up the key values from the run selected by run-id - (db:delay-if-busy dbdat) + (db:delay-if-busy dbdat area-dat) (sqlite3:for-each-row (lambda (a . b) (set! keyvals (cons a b))) db (conc "SELECT " selstr " FROM runs WHERE id=? ORDER BY event_time DESC;") run-id) @@ -2906,12 +2908,12 @@ results) (if (null? tal) (map cdr (hash-table->alist tests-hash)) ;; return a list of the most recent tests (loop (car tal)(cdr tal)))))))))) -(define (db:delay-if-busy dbdat #!key (count 6)) - (if (not (configf:lookup *configdat* "server" "delay-on-busy")) +(define (db:delay-if-busy dbdat area-dat #!key (count 6)) + (if (not (configf:lookup (megatest:area-configdat area-dat) "server" "delay-on-busy")) (and dbdat (db:dbdat-get-db dbdat)) (if dbdat (let* ((dbpath (db:dbdat-get-path dbdat)) (db (db:dbdat-get-db dbdat)) ;; we'll return this so (db:delay--if-busy can be called inline (dbfj (conc dbpath "-journal"))) @@ -2918,31 +2920,31 @@ (if (handle-exceptions exn (begin (debug:print-info 0 "WARNING: failed to test for existance of " dbfj) (thread-sleep! 1) - (db:delay-if-busy count (- count 1))) + (db:delay-if-busy dbdat area-dat count: (- count 1))) (file-exists? dbfj)) (case count ((6) (thread-sleep! 0.2) - (db:delay-if-busy count: 5)) + (db:delay-if-busy dbdat area-dat count: 5)) ((5) (thread-sleep! 0.4) - (db:delay-if-busy count: 4)) + (db:delay-if-busy dbdat area-dat count: 4)) ((4) (thread-sleep! 0.8) - (db:delay-if-busy count: 3)) + (db:delay-if-busy dbdat area-dat count: 3)) ((3) (thread-sleep! 1.6) - (db:delay-if-busy count: 2)) + (db:delay-if-busy dbdat area-dat count: 2)) ((2) (thread-sleep! 3.2) - (db:delay-if-busy count: 1)) + (db:delay-if-busy dbdat area-dat count: 1)) ((1) (thread-sleep! 6.4) - (db:delay-if-busy count: 0)) + (db:delay-if-busy dbdat area-dat count: 0)) (else (debug:print-info 0 "delaying db access due to high database load.") (thread-sleep! 12.8)))) db) "bogus result from db:delay-if-busy"))) Index: dcommon.scm ================================================================== --- dcommon.scm +++ dcommon.scm @@ -32,11 +32,13 @@ ;;====================================================================== ;; C O M M O N D A T A S T R U C T U R E ;;====================================================================== ;; -;; A single data structure for all the data used in a dashboard. +;; A single data structure for all the data used in a dashboard for +;; a given area. +;; ;; Share this structure between newdashboard and dashboard with the ;; intent of converging on a single app. ;; (define *data* (make-vector 25 #f)) (define (dboard:data-get-runs vec) (vector-ref vec 0)) @@ -63,10 +65,11 @@ (define (dboard:data-get-target-string vec) (let ((targ (dboard:data-get-target vec))) (if (list? targ)(string-intersperse targ "/") "no-target-specified"))) (define (dboard:data-get-run-name vec) (vector-ref vec 19)) (define (dboard:data-get-runs-listbox vec) (vector-ref vec 20)) +(define (dboard:data-get-area-path vec) (vector-ref vec 21)) (define (dboard:data-set-runs! vec val)(vector-set! vec 0 val)) (define (dboard:data-set-tests! vec val)(vector-set! vec 1 val)) (define (dboard:data-set-runs-matrix! vec val)(vector-set! vec 2 val)) (define (dboard:data-set-tests-tree! vec val)(vector-set! vec 3 val)) @@ -87,10 +90,11 @@ (define (dboard:data-set-command! vec val)(vector-set! vec 16 val)) (define (dboard:data-set-command-tb! vec val)(vector-set! vec 17 val)) (define (dboard:data-set-target! vec val)(vector-set! vec 18 val)) (define (dboard:data-set-run-name! vec val)(vector-set! vec 19 val)) (define (dboard:data-set-runs-listbox! vec val)(vector-set! vec 20 val)) +(define (dboard:data-set-area-path! vec val)(vector-set! vec 21 val)) (dboard:data-set-run-keys! *data* (make-hash-table)) ;; List of test ids being viewed in various panels (dboard:data-set-curr-test-ids! *data* (make-hash-table)) @@ -98,10 +102,68 @@ ;; Look up test-ids by (key1 key2 ... testname [itempath]) (dboard:data-set-path-test-ids! *data* (make-hash-table)) ;; Look up run-ids by ?? (dboard:data-set-path-run-ids! *data* (make-hash-table)) + +;;====================================================================== +;; D O T F I L E +;;====================================================================== + +;; write a sexp list to fname +;; +(define (dcommon:write-dotfile fname dat) + (with-output-to-file fname + (lambda () + (pp dat)))) + +(define (dcommon:read-dotfile fname) + (if (file-exists? fname) + (with-input-from-file fname + (lambda () + (read))) + '())) + +;; gets the name for the file ~/.megatest/ +;; creates .megatest dir if not there +;; +(define (dcommon:get-dot-file-pathn name) + (let* ((dot-dir (conc (get-environment-variable "HOME") "/.megatest")) + (dfile (conc dot-dir "/" name))) + (if (not (file-exists? dot-dir)) + (create-directory dot-dir)) + dfile)) + +;; dat is the top level data stucture that contains all the info being +;; displayed in all runs etc. +;; +(define (dcommon:dotfiles-save-areas data) + (let* ((areas-dat (dcommon:data-get-areas data)) + (areas-dfile (dcommon:get-dot-file-pathn "areas"))) + (dcommon:write-dotfile areas-dfile areas-dat))) + +;; returns alist of area => path +;; +(define (dcommon:data-get-areas data) + (let ((area-names (hash-table-keys data))) + (map (lambda (area-name) + (cons area-name + (dboard:data-get-area-path (hash-table-ref data area-name)))) + area-names))) + +;; Fill the hash table data with area => area-record +;; +(define (dcommon:read-areas-init-data data) + (let* ((dfile (dcommon:get-dot-file-pathn "areas")) + (areas-dfile (dcommon:read-dotfile dfile))) + (for-each + (lambda (area) + (let ((rec (vector 25 #f))) + (dboard:data-set-area-path! rec (cdr area)) + (dboard:data-set-updaters! rec (make-hash-table)) + (hash-table-set! data (car area) rec))) + areas-dfile))) ;;====================================================================== ;; TARGET AND PATTERN MANIPULATIONS ;;====================================================================== @@ -110,11 +172,10 @@ (define (dboard:test-patt->lines test-patt) (string-substitute (regexp ",") "\n" test-patt)) (define (dboard:lines->test-patt lines) (string-substitute (regexp "\n") "," lines #t)) - ;;====================================================================== ;; P R O C E S S R U N S ;;====================================================================== @@ -328,11 +389,11 @@ (for-each (lambda (var) ;; (iup:attribute-set! keys-matrix "ADDLIN" (conc curr-row-num)) (iup:attribute-set! keys-matrix (conc curr-row-num ":0") curr-row-num) (iup:attribute-set! keys-matrix (conc curr-row-num ":1") var) - (set! curr-row-num (+ 1 curr-row-num))) ;; (config-lookup *configdat* "fields" var))) + (set! curr-row-num (+ 1 curr-row-num))) ;; (config-lookup configdat "fields" var))) key-vals) (iup:attribute-set! keys-matrix "WIDTHDEF" "40") keys-matrix)) ;; Section to table @@ -354,11 +415,11 @@ (for-each (lambda (var) ;; (iup:attribute-set! keys-matrix "ADDLIN" (conc curr-row-num)) (iup:attribute-set! section-matrix (conc curr-row-num ":0") var) (iup:attribute-set! section-matrix (conc curr-row-num ":1") (configf:lookup rawconfig sectionname var)) - (set! curr-row-num (+ 1 curr-row-num))) ;; (config-lookup *configdat* "fields" var))) + (set! curr-row-num (+ 1 curr-row-num))) ;; (config-lookup configdat "fields" var))) key-vals) (iup:vbox (iup:label (if title title (conc "Settings from [" sectionname "]")) ;; #:size "5x" #:expand "HORIZONTAL" @@ -380,11 +441,11 @@ ;; User (this is not always obvious - it is common to run as a different user (iup:attribute-set! general-matrix "1:0" "User") (iup:attribute-set! general-matrix "1:1" (current-user-name)) ;; Megatest area ;; (iup:attribute-set! general-matrix "2:0" "Area") - ;; (iup:attribute-set! general-matrix "2:1" *toppath*) + ;; (iup:attribute-set! general-matrix "2:1" toppath) ;; Megatest version (iup:attribute-set! general-matrix "2:0" "Version") (iup:attribute-set! general-matrix "2:1" (conc megatest-version "-" (substring megatest-fossil-hash 0 4))) general-matrix)) @@ -540,28 +601,35 @@ ;; ))) servers-matrix )) ;; The main menu -(define (dcommon:main-menu) +(define (dcommon:main-menu data) (iup:menu ;; a menu is a special attribute to a dialog (think Gnome putting the menu at screen top) (iup:menu-item "Files" (iup:menu ;; Note that you can use either #:action or action: for options - (iup:menu-item "Open" action: (lambda (obj) - (iup:show (iup:file-dialog)) - (print "File->open " obj))) - (iup:menu-item "Save" #:action (lambda (obj)(print "File->save " obj))) - (iup:menu-item "Exit" #:action (lambda (obj)(exit))))) + (iup:menu-item "Open" action: (lambda (obj) + (let* ((area-name (iup:textbox #:expand "HORIZONTAL")) + (fd (iup:file-dialog #:dialogtype "DIR")) + (top (iup:show fd #:modal? "YES"))) + (iup:attribute-set! source-tb "VALUE" + (iup:attribute fd "VALUE")) + (iup:destroy! fd)))) + ;; (lambda (obj) + ;; (iup:show (iup:file-dialog)) + ;; (print "File->open " obj))) + (iup:menu-item "Save" #:action (lambda (obj)(print "File->save " obj))) + (iup:menu-item "Exit" #:action (lambda (obj)(exit))))) (iup:menu-item "Tools" (iup:menu - (iup:menu-item "Create new blah" #:action (lambda (obj)(print "Tools->new blah"))) - ;; (iup:menu-item "Show dialog" #:action (lambda (obj) - ;; (show message-window - ;; #:modal? #t - ;; ;; set positon using coordinates or center, start, top, left, end, bottom, right, parent-center, current - ;; ;; #:x 'mouse - ;; ;; #:y 'mouse - ;; ) - )))) + (iup:menu-item "Create new blah" #:action (lambda (obj)(print "Tools->new blah"))) + ;; (iup:menu-item "Show dialog" #:action (lambda (obj) + ;; (show message-window + ;; #:modal? #t + ;; ;; set positon using coordinates or center, start, top, left, end, bottom, right, parent-center, current + ;; ;; #:x 'mouse + ;; ;; #:y 'mouse + ;; ) + )))) ;;====================================================================== ;; CANVAS STUFF FOR TESTS ;;====================================================================== Index: ezsteps.scm ================================================================== --- ezsteps.scm +++ ezsteps.scm @@ -164,11 +164,11 @@ 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 (if (not (equal? item-path "")) - (cdb:roll-up-pass-fail-counts *runremote* run-id test-name item-path new-status)))) + (cdb:roll-up-pass-fail-counts (common:get-remote remote run-id) run-id test-name item-path new-status)))) ;; for automated creation of the rollup html file this is a good place... (if (not (equal? item-path "")) (tests:summarize-items #f run-id test-id test-name #f)) ;; don't force - just update if no ))) (pop-directory) Index: http-transport.scm ================================================================== --- http-transport.scm +++ http-transport.scm @@ -59,21 +59,22 @@ (string-intersperse (map number->string (u8vector->list (if res res (hostname->ip hostname)))) "."))) -(define (http-transport:run hostn run-id server-id) +(define (http-transport:run hostn run-id server-id area-dat) (debug:print 2 "Attempting to start the server ...") - (let* ((db #f) ;; (open-db)) ;; we don't want the server to be opening and closing the db unnecesarily + (let* ((configdat (megatest:area-configdat area-dat)) + (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) #f))) (if ipstr ipstr hostn))) ;; hostname))) (start-port (portlogger:open-run-close portlogger:find-port)) - (link-tree-path (configf:lookup *configdat* "setup" "linktree"))) + (link-tree-path (configf:lookup configdat "setup" "linktree"))) ;; (set! db *inmemdb*) (debug:print-info 0 "portlogger recommended port: " start-port) (root-path (if link-tree-path link-tree-path (current-directory))) ;; WARNING: SECURITY HOLE. FIX ASAP! @@ -94,11 +95,11 @@ (dat ($ 'dat)) (res #f)) (cond ((equal? (uri-path (request-uri (current-request))) '(/ "api")) - (send-response body: (api:process-request *inmemdb* $) ;; the $ is the request vars proc + (send-response body: (api:process-request *inmemdb* area-dat $) ;; the $ is the request vars proc headers: '((content-type text/plain))) (mutex-lock! *heartbeat-mutex*) (set! *last-db-access* (current-seconds)) (mutex-unlock! *heartbeat-mutex*)) ((equal? (uri-path (request-uri (current-request))) @@ -114,17 +115,17 @@ ((equal? (uri-path (request-uri (current-request))) '(/ "hey")) (send-response body: "hey there!\n" headers: '((content-type text/plain)))) (else (continue)))))))) - (http-transport:try-start-server run-id ipaddrstr start-port server-id))) + (http-transport:try-start-server run-id ipaddrstr start-port server-id area-dat))) ;; 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))) +(define (http-transport:try-start-server run-id ipaddrstr portnum server-id area-dat) + (let ((config-hostname (configf:lookup (megatest:area-configdat area-dat) "server" "hostname")) + (tdbdat (tasks:open-db area-dat))) (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) (handle-exceptions exn (begin (print-error-message exn) @@ -139,11 +140,12 @@ ;; get_next_port goes here (http-transport:try-start-server run-id ipaddrstr (portlogger:open-run-close portlogger:find-port) - server-id)) + server-id + area-dat)) (begin (tasks:server-force-clean-run-record (db:delay-if-busy tdbdat) run-id ipaddrstr portnum " http-transport:try-start-server") (print "ERROR: Tried and tried but could not start the server")))) ;; any error in following steps will result in a retry (set! *server-info* (list ipaddrstr portnum)) @@ -221,11 +223,11 @@ (mutex-lock! *http-mutex*) (set! *http-requests-in-progress* (+ 1 *http-requests-in-progress*))) ;; Send "cmd" with json payload "params" to serverdat and receive result ;; -(define (http-transport:client-api-send-receive run-id serverdat cmd params #!key (numretries 3)) +(define (http-transport:client-api-send-receive run-id serverdat cmd params #!key (numretries 3)(remote #f)) (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") (exit 1)))) @@ -270,11 +272,11 @@ 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)) - (hash-table-delete! *runremote* run-id) + (common:del-remote! remote 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 ;;; (make-property-condition 'commfail 'message "failed to connect to server"))) @@ -314,14 +316,14 @@ (signal (make-composite-condition (make-property-condition 'timeout 'message "nmsg-transport:client-api-send-receive-raw timed out talking to server"))))))) -;; careful closing of connections stored in *runremote* +;; careful closing of connections stored in (common:get-remote remote) ;; (define (http-transport:close-connections run-id) - (let* ((server-dat (hash-table-ref/default *runremote* run-id #f))) + (let* ((server-dat (common:get-remote remote run-id))) (if (vector? server-dat) (let ((api-dat (http-transport:server-dat-get-api-uri server-dat))) (close-connection! api-dat) #t) #f))) @@ -470,11 +472,11 @@ ;; (debug:print 11 "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" "wait-on-running"))) ;; wait on running tasks (if not true then exit on time out) + ;; (let ((wait-on-running (configf:lookup configdat "server" "wait-on-running"))) ;; wait on running tasks (if not true then exit on time out) ;; (if (and *server-run* (> (+ last-access server-timeout) (current-seconds))) (begin @@ -522,11 +524,11 @@ ;; all routes though here end in exit ... ;; ;; start_server? ;; -(define (http-transport:launch run-id) +(define (http-transport:launch run-id area-dat) (let* ((tdbdat (tasks:open-db))) (set! *run-id* run-id) (if (args:get-arg "-daemonize") (begin (daemon:ize) @@ -556,11 +558,12 @@ (http-transport:run (if (args:get-arg "-server") (args:get-arg "-server") "-") run-id - server-id)) "Server run")) + server-id + area-dat)) "Server run")) (th3 (make-thread (lambda () (debug:print-info 0 "Server monitor thread started") (http-transport:keep-running server-id run-id)) "Keep running"))) (thread-start! th2) @@ -602,15 +605,16 @@ ;;====================================================================== ;; web pages ;;====================================================================== -(define (http-transport:main-page) - (let ((linkpath (root-path))) - (conc "

" (pathname-strip-directory *toppath*) "

" +(define (http-transport:main-page area-dat) + (let* ((toppath (megatest:area-path area-dat)) + (linkpath (root-path))) + (conc "

" (pathname-strip-directory toppath) "

" "" - "Run area: " *toppath* + "Run area: " toppath "

Server Stats

" (http-transport:stats-table) "
" (http-transport:runs linkpath) "
" Index: items.scm ================================================================== --- items.scm +++ items.scm @@ -127,12 +127,12 @@ '() #f))) res))) ;; Nope, not now, return null as of 6/6/2011 -(define (items:check-valid-items class item) - (let ((valid-values (let ((s (config-lookup *configdat* "validvalues" class))) +(define (items:check-valid-items class item area-dat) + (let ((valid-values (let ((s (config-lookup (megatest:area-configdat area-dat) "validvalues" class))) (if s (string-split s) #f)))) (if valid-values (if (member item valid-values) item #f) item))) Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -77,18 +77,18 @@ ;; call the command using mt_ezstep ;; (set! script (conc "mt_ezstep " stepname " " (if prevstep prevstep "x") " " stepcmd)) (debug:print 4 "script: " script) - (rmt:teststep-set-status! run-id test-id stepname "start" "-" #f #f) + (rmt:teststep-set-status! run-id test-id stepname "start" "-" #f #f area-dat) ;; now launch the actual process (call-with-environment-variables (list (cons "PATH" (conc (get-environment-variable "PATH") ":."))) (lambda () (let* ((cmd (conc stepcmd " > " stepname ".log")) (pid (process-run cmd))) - (rmt:test-set-top-process-pid run-id test-id pid) + (rmt:test-set-top-process-pid run-id test-id pid area-dat) (let processloop ((i 0)) (let-values (((pid-val exit-status exit-code)(process-wait pid #t))) (mutex-lock! m) (vector-set! exit-info 0 pid) (vector-set! exit-info 1 exit-status) @@ -116,13 +116,13 @@ (processloop (+ i 1))))) (debug:print-info 0 "logpro for step " stepname " exited with code " (vector-ref exit-info 2))))) (let ((exinfo (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)) + (rmt:teststep-set-status! run-id test-id stepname "end" exinfo #f logfna area-dat)) (if logpro-used - (rmt:test-set-log! run-id test-id (conc stepname ".html"))) + (rmt:test-set-log! run-id test-id (conc stepname ".html") area-dat)) ;; set the test final status (let* ((this-step-status (cond ((and (eq? (vector-ref exit-info 2) 2) logpro-used) 'warn) ((eq? (vector-ref exit-info 2) 0) 'pass) (else 'fail))) @@ -157,11 +157,11 @@ (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:execute encoded-cmd) +(define (launch:execute encoded-cmd area-dat) (let* ((cmdinfo (common:read-encoded-string encoded-cmd))) (setenv "MT_CMDINFO" encoded-cmd) (if (list? cmdinfo) ;; ((testpath /tmp/mrwellan/jazzmind/src/example_run/tests/sqlitespeed) ;; (test-name sqlitespeed) (runscript runscript.rb) (db-host localhost) (run-id 1)) (let* ((testpath (assoc/default 'testpath cmdinfo)) ;; testpath is the test spec area @@ -203,35 +203,35 @@ ;; (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-testinfo-state-status run-id test-id))) + (let ((test-info (rmt:get-testinfo-state-status run-id test-id area-dat))) (if (not (member (db:test-get-state test-info) '("REMOVING" "REMOTEHOSTSTART" "RUNNING" "KILLREQ"))) (tests:test-force-state-status! run-id test-id "REMOTEHOSTSTART" "n/a") (begin (debug:print 0 "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)) - (set! keys (rmt:get-keys)) - ;; (runs:set-megatest-env-vars run-id inkeys: keys inkeyvals: keyvals) ;; these may be needed by the launching process + (set! keys (rmt:get-keys area-dat)) + ;; (runs:set-megatest-env-vars run-id area-dat inkeys: keys inkeyvals: keyvals) ;; these may be needed by the launching process ;; one of these is defunct/redundant ... - (if (not (launch:setup-for-run force: #t)) + (if (not (launch:setup-for-run area-dat force: #t)) (begin (debug:print 0 "Failed to setup, exiting") ;; (sqlite3:finalize! db) ;; (sqlite3:finalize! tdb) (exit 1))) - (change-directory *toppath*) + (change-directory toppath) ;; NOTE: Current order is to process runconfigs *before* setting the MT_ vars. This ;; seems non-ideal but could well break stuff ;; BUG? BUG? BUG? - (let ((rconfig (full-runconfigs-read))) ;; (read-config (conc *toppath* "/runconfigs.config") #f #t sections: (list "default" target)))) - ;; (setup-env-defaults (conc *toppath* "/runconfigs.config") run-id (make-hash-table) keyvals target) + (let ((rconfig (full-runconfigs-read))) ;; (read-config (conc toppath "/runconfigs.config") #f #t sections: (list "default" target)))) + ;; (setup-env-defaults (conc toppath "/runconfigs.config") run-id (make-hash-table) keyvals target) ;; (set-run-config-vars run-id keyvals target) ;; (db:get-target db run-id)) ;; Now have runconfigs data loaded, set environment vars (for-each (lambda (section) (for-each (lambda (varval) (let ((var (car varval)) @@ -272,11 +272,11 @@ (list "MT_ITEM_INFO" (conc itemdat)) (list "MT_ITEMPATH" item-path) (list "MT_RUNNAME" runname) (list "MT_MEGATEST" megatest) (list "MT_TARGET" target) - (list "MT_LINKTREE" (configf:lookup *configdat* "setup" "linktree")) + (list "MT_LINKTREE" (configf:lookup (megatest:area-configdat area-dat) "setup" "linktree")) (list "MT_TESTSUITENAME" (common:get-testsuite-name)))) (if mt-bindir-path (setenv "PATH" (conc (getenv "PATH") ":" mt-bindir-path))) ;; (change-directory top-path) ;; Can setup as client for server mode now @@ -283,11 +283,11 @@ ;; (client:setup) ;; environment overrides are done *before* the remaining critical envars. (alist->env-vars env-ovrd) - (runs:set-megatest-env-vars run-id inkeys: keys inkeyvals: keyvals) + (runs:set-megatest-env-vars run-id area-dat inkeys: keys inkeyvals: keyvals) (set-item-env-vars itemdat) (save-environment-as-files "megatest") ;; 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) @@ -319,17 +319,17 @@ ;; 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 "RUNNING") + (rmt:roll-up-pass-fail-counts run-id test-name item-path "RUNNING" area-dat) ;; (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) + (rmt:test-set-top-process-pid run-id test-id pid area-dat) (let loop ((i 0)) (let-values (((pid-val exit-status exit-code) (process-wait pid #t))) (mutex-lock! m) (vector-set! exit-info 0 pid) @@ -390,11 +390,11 @@ (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 (vector-ref exit-info 0)) - (pid2 (rmt:test-get-top-process-pid run-id test-id)) + (pid2 (rmt:test-get-top-process-pid run-id test-id area-dat)) (pids (delete-duplicates (filter number? (list pid1 pid2))))) (if (not (null? pids)) (begin (for-each (lambda (pid) @@ -445,11 +445,11 @@ (thread-join! th1) (thread-sleep! 1) ;; give thread th1 a chance to be done TODO: Verify this is needed. At 0.1 I was getting fail to stop, increased to total of 1.1 sec. (mutex-lock! m) (let* ((item-path (item-list->path itemdat)) ;; only state and status needed - use lazy routine - (testinfo (rmt:get-testinfo-state-status run-id test-id))) + (testinfo (rmt:get-testinfo-state-status run-id test-id area-dat))) ;; Am I completed? (if (member (db:test-get-state testinfo) '("REMOTEHOSTSTART" "RUNNING")) ;; NOTE: It should *not* be REMOTEHOSTSTART but for reasons I don't yet understand it sometimes gets stuck in that state ;; (not (equal? (db:test-get-state testinfo) "COMPLETED")) (let ((new-state (if kill-job? "KILLED" "COMPLETED") ;; (if (eq? (vector-ref exit-info 2) 0) ;; exited with "good" status ;; "COMPLETED" ;; (db:test-get-state testinfo))) ;; else preseve the state as set within the test @@ -482,105 +482,114 @@ (debug:print 2 "Output from running " fullrunscript ", pid " (vector-ref exit-info 0) " in work area " work-area ":\n====\n exit code " (vector-ref exit-info 2) "\n" "====\n") (if (not (vector-ref exit-info 1)) (exit 4))))))) +(define (launch:read-cached-config) + (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"))) + (if (file-exists? alistconfig) + (list (configf:read-alist alistconfig) + (get-environment-variable "MT_RUN_AREA_HOME")) + #f)) + #f)) + +(define (launch:read-megatest-config toppath) + (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 up the very basics needed for doing anything here. -(define (launch:setup-for-run #!key (force #f)) +(define (launch:setup-for-run area-dat #!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"))) - (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*) + (let ((configdat (megatest:area-configdat area-dat))) + (if (or force (not (hash-table? configdat))) ;; no need to re-open on every call + (let* ((newconfiginfo (or (launch:read-cached-config) ;; no config cached - give up + (launch:read-megatest-config (megatest:area-path area-dat)))) + (configdat (car newconfiginfo)) + (toppath (cadr newconfiginfo))) + (megatest:area-configinfo-set! area-dat newconfiginfo) + (megatest:area-configdat-set! area-dat configdat) + (megatest:area-path-set! area-dat toppath) + (let* ((tmptransport (configf:lookup configdat "server" "transport")) + (transport (if tmptransport (string->symbol tmptransport) 'http))) + (if (member transport '(http rpc nmsg)) + (megatest:area-transport-set! area-dat 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*) + (exit 1)))) + toppath)))) -(define (launch:cache-config) +(define (launch:cache-config area-dat) ;; if we have a linktree and -runtests and -target and the directory exists dump the config ;; to megatest-(current-seconds).cfg and symlink it to megatest.cfg - (if (and *configdat* - (args:get-arg "-runtests")) - (let* ((linktree (get-environment-variable "MT_LINKTREE")) - (target (common:args-get-target)) - (runname (or (args:get-arg "-runname") - (args:get-arg ":runname"))) - (fulldir (conc linktree "/" - target "/" - runname))) - (debug:print-info 0 "Have -runtests with target=" target ", runname=" runname ", fulldir=" fulldir) - (if (file-exists? linktree) ;; can't proceed without linktree - (begin - (if (not (file-exists? fulldir)) - (create-directory fulldir #t)) ;; need to protect with exception handler - (if (and target - runname - (file-exists? fulldir)) - (let ((tmpfile (conc fulldir "/.megatest.cfg." (current-seconds))) - (targfile (conc fulldir "/.megatest.cfg"))) - (debug:print-info 0 "Caching megatest.config in " fulldir "/.megatest.cfg") - (configf:write-alist *configdat* tmpfile) - (system (conc "ln -sf " tmpfile " " targfile)) - ))))))) + (let ((configdat (megatest:area-configdat area-dat))) + (if (and configdat + (args:get-arg "-runtests")) + (let* ((linktree (get-environment-variable "MT_LINKTREE")) + (target (common:args-get-target)) + (runname (or (args:get-arg "-runname") + (args:get-arg ":runname"))) + (fulldir (conc linktree "/" + target "/" + runname))) + (debug:print-info 0 "Have -runtests with target=" target ", runname=" runname ", fulldir=" fulldir) + (if (file-exists? linktree) ;; can't proceed without linktree + (begin + (if (not (file-exists? fulldir)) + (create-directory fulldir #t)) ;; need to protect with exception handler + (if (and target + runname + (file-exists? fulldir)) + (let ((tmpfile (conc fulldir "/.megatest.cfg." (current-seconds))) + (targfile (conc fulldir "/.megatest.cfg"))) + (debug:print-info 0 "Caching megatest.config in " fulldir "/.megatest.cfg") + (configf:write-alist configdat tmpfile) + (system (conc "ln -sf " tmpfile " " targfile)) + )))))))) (define (get-best-disk confdat) (let* ((disks (hash-table-ref/default confdat "disks" #f)) (minspace (let ((m (configf:lookup confdat "setup" "minspace"))) (string->number (or m "10000"))))) @@ -606,12 +615,13 @@ ;; ;; All log file links should be stored relative to the top of link path ;; ;; - [ - ] ;; -(define (create-work-area run-id run-info keyvals test-id test-src-path disk-path testname itemdat #!key (remtries 2)) - (let* ((item-path (if (string? itemdat) itemdat (item-list->path itemdat))) ;; if pass in string - just use it +(define (create-work-area run-id run-info keyvals test-id test-src-path disk-path testname itemdat area-dat #!key (remtries 2)) + (let* ((configdat (megatest:area-configdat area-dat)) + (item-path (if (string? itemdat) itemdat (item-list->path itemdat))) ;; if pass in string - just use it (runname (if (string? run-info) ;; if we pass in a string as run-info use it as run-name. run-info (db:get-value-by-header (db:get-rows run-info) (db:get-header run-info) "runname"))) @@ -627,21 +637,21 @@ ;; nb// if itempath is not "" then it is prefixed with "/" (toptest-path (conc disk-path "/" testtop-base)) (test-path (conc disk-path "/" test-base)) ;; ensure this exists first as links to subtests must be created there - (linktree (let ((rd (config-lookup *configdat* "setup" "linktree"))) - (if rd rd (conc *toppath* "/runs")))) + (linktree (let ((rd (config-lookup configdat "setup" "linktree"))) + (if rd rd (conc (megatest:area-path area-dat) "/runs")))) (lnkbase (conc linktree "/" target "/" runname)) (lnkpath (conc lnkbase "/" testname)) (lnkpathf (conc lnkpath (if not-iterated "" "/") item-path)) (lnktarget (conc lnkpath "/" item-path))) ;; 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) + (rmt:general-call 'test-set-rundir-shortdir run-id lnkpathf test-path testname item-path area-dat) (debug:print 2 "INFO:\n lnkbase=" lnkbase "\n lnkpath=" lnkpath "\n toptest-path=" toptest-path "\n test-path=" test-path) (if (not (file-exists? linktree)) (begin (debug:print 0 "WARNING: linktree did not exist! Creating it now at " linktree) @@ -697,11 +707,11 @@ ;; Do the setting of this record after the paths are created so that the shortdir can ;; be set to the real directory location. This is safer for future clean up if the link ;; tree is damaged or lost. ;; (if (not (hash-table-ref/default *toptest-paths* testname #f)) - (let* ((testinfo (rmt:get-test-info-by-id run-id test-id)) ;; run-id testname item-path)) + (let* ((testinfo (rmt:get-test-info-by-id run-id test-id area-dat)) ;; run-id testname item-path)) (curr-test-path (if testinfo ;; (filedb:get-path *fdb* ;; (db:get-path dbstruct ;; (rmt:sdb-qry 'getstr (db:test-get-rundir testinfo) ;; ) ;; ) #f))) @@ -709,11 +719,11 @@ ;; 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) lnkpath) - testname "") + testname "" area-dat) ;; (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) @@ -751,11 +761,11 @@ (if (not (directory? test-path)) (create-directory test-path #t)) ;; this is a hack, I don't know why out of the blue this path does not exist sometimes (if (and test-src-path (directory? test-path)) (begin - (let* ((ovrcmd (let ((cmd (config-lookup *configdat* "setup" "testcopycmd"))) + (let* ((ovrcmd (let ((cmd (config-lookup configdat "setup" "testcopycmd"))) (if cmd ;; substitute the TEST_SRC_PATH and TEST_TARG_PATH (string-substitute "TEST_TARG_PATH" test-path (string-substitute "TEST_SRC_PATH" test-src-path cmd #t) #t) #f))) @@ -779,35 +789,37 @@ ;; 3. create link from run dir to megatest runs area ;; 4. remotely run the test on allocated host ;; - could be ssh to host from hosts table (update regularly with load) ;; - could be netbatch ;; (launch-test db (cadr status) test-conf)) -(define (launch-test test-id run-id run-info keyvals runname test-conf test-name test-path itemdat params) - (change-directory *toppath*) +(define (launch-test test-id run-id run-info keyvals runname test-conf test-name test-path itemdat params area-dat) + (let ((toppath (megatest:area-path area-dat)) + (configdat (megatest:area-configdat area-dat))) + (change-directory toppath) (alist->env-vars ;; consolidate this code with the code in megatest.scm for "-execute" (list ;; (list "MT_TEST_RUN_DIR" work-area) - (list "MT_RUN_AREA_HOME" *toppath*) + (list "MT_RUN_AREA_HOME" toppath) (list "MT_TEST_NAME" test-name) ;; (list "MT_ITEM_INFO" (conc itemdat)) (list "MT_RUNNAME" runname) ;; (list "MT_TARGET" mt_target) )) - (let* ((useshell (let ((ush (config-lookup *configdat* "jobtools" "useshell"))) + (let* ((useshell (let ((ush (config-lookup configdat "jobtools" "useshell"))) (if ush (if (equal? ush "no") ;; must use "no" to NOT use shell #f ush) #t))) ;; default is yes - (launcher (config-lookup *configdat* "jobtools" "launcher")) + (launcher (config-lookup configdat "jobtools" "launcher")) (runscript (config-lookup test-conf "setup" "runscript")) (ezsteps (> (length (hash-table-ref/default test-conf "ezsteps" '())) 0)) ;; don't send all the steps, could be big (diskspace (config-lookup test-conf "requirements" "diskspace")) (memory (config-lookup test-conf "requirements" "memory")) - (hosts (config-lookup *configdat* "jobtools" "workhosts")) - (remote-megatest (config-lookup *configdat* "setup" "executable")) + (hosts (config-lookup configdat "jobtools" "workhosts")) + (remote-megatest (config-lookup configdat "setup" "executable")) (run-time-limit (or (configf:lookup test-conf "requirements" "runtimelim") - (configf:lookup *configdat* "setup" "runtimelim"))) + (configf:lookup configdat "setup" "runtimelim"))) ;; FIXME SOMEDAY: not good how this is so obtuse, this hack is to ;; allow running from dashboard. Extract the path ;; from the called megatest and convert dashboard ;; or dboard to megatest (local-megatest (let* ((lm (car (argv))) @@ -826,11 +838,11 @@ (diskpath #f) (cmdparms #f) (fullcmd #f) ;; (define a (with-output-to-string (lambda ()(write x)))) (mt-bindir-path #f) ;; (test-id (cdb:remote-run db:get-test-id #f run-id test-name item-path)) - (testinfo (rmt:get-test-info-by-id run-id test-id)) + (testinfo (rmt:get-test-info-by-id run-id test-id area-dat)) (mt_target (string-intersperse (map cadr keyvals) "/")) (debug-param (append (if (args:get-arg "-debug") (list "-debug" (args:get-arg "-debug")) '()) (if (args:get-arg "-logging")(list "-logging") '())))) (setenv "MT_ITEMPATH" item-path) (if hosts (set! hosts (string-split hosts))) @@ -842,16 +854,16 @@ (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) (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")) - (rmt:roll-up-pass-fail-counts run-id test-name item-path "LAUNCHED") - (set! diskpath (get-best-disk *configdat*)) + (rmt:roll-up-pass-fail-counts run-id test-name item-path "LAUNCHED" area-dat) + (set! diskpath (get-best-disk configdat)) (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)) @@ -862,13 +874,13 @@ (set! cmdparms (base64:base64-encode (z3:encode-buffer (with-output-to-string (lambda () ;; (list 'hosts hosts) (write (list (list 'testpath test-path) - (list 'transport (conc *transport-type*)) + (list 'transport (conc (megatest:area-transport area-dat))) ;;; *transport-type*)) ;; (list 'serverinf *server-info*) - (list 'toppath *toppath*) + (list 'toppath toppath) (list 'work-area work-area) (list 'test-name test-name) (list 'runscript runscript) (list 'run-id run-id ) (list 'test-id test-id ) @@ -876,11 +888,11 @@ (list 'itemdat itemdat ) (list 'megatest remote-megatest) (list 'ezsteps ezsteps) (list 'target mt_target) (list 'runtlim (if run-time-limit (common:hms-string->seconds run-time-limit) #f)) - (list 'env-ovrd (hash-table-ref/default *configdat* "env-override" '())) + (list 'env-ovrd (hash-table-ref/default configdat "env-override" '())) (list 'set-vars (if params (hash-table-ref/default params "-setvars" #f))) (list 'runname runname) (list 'mt-bindir-path mt-bindir-path)))))))) ;; clean out step records from previous run if they exist @@ -900,11 +912,11 @@ (if (args:get-arg "-xterm")(set! fullcmd (append fullcmd (list "-xterm")))) (debug:print 1 "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) (let* ((commonprevvals (alist->env-vars - (hash-table-ref/default *configdat* "env-override" '()))) + (hash-table-ref/default configdat "env-override" '()))) (testprevvals (alist->env-vars (hash-table-ref/default test-conf "pre-launch-env-overrides" '()))) (miscprevvals (alist->env-vars ;; consolidate this code with the code in megatest.scm for "-execute" (append (list (list "MT_TEST_RUN_DIR" work-area) (list "MT_TEST_NAME" test-name) @@ -913,11 +925,11 @@ (list "MT_TARGET" mt_target) (list "MT_ITEMPATH" item-path) ) itemdat))) ;; Launchwait defaults to true, must override it to turn off wait - (launchwait (if (equal? (configf:lookup *configdat* "setup" "launchwait") "no") #f #t)) + (launchwait (if (equal? (configf:lookup configdat "setup" "launchwait") "no") #f #t)) (launch-results (apply (if launchwait cmd-run-with-stderr->list process-run) (if useshell (let ((cmdstr (string-intersperse fullcmd " "))) @@ -950,7 +962,9 @@ )) (alist->env-vars miscprevvals) (alist->env-vars testprevvals) (alist->env-vars commonprevvals) launch-results)) - (change-directory *toppath*)) + (change-directory toppath)) + ;; added paren below after refactoring above routine. must have missed something? + ) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -8,10 +8,13 @@ ;; PURPOSE. ;; (include "common.scm") ;; (include "megatest-version.scm") +;; fakeout readline +(define (toplevel-command . a) #f) + (use sqlite3 srfi-1 posix regex regex-case srfi-69 base64 readline apropos json http-client directory-utils rpc ;; (srfi 18) extras) http-client srfi-18 extras format) ;; zmq extras) ;; Added for csv stuff - will be removed ;; @@ -51,18 +54,31 @@ (let ((debugcontrolf (conc (get-environment-variable "HOME") "/.megatestrc"))) (if (file-exists? debugcontrolf) (load debugcontrolf))) +(define *area-dat* (make-megatest:area + "default" ;; area name + #f ;; area path + 'http ;; transport + #f ;; configinfo + #f ;; configdat + (make-hash-table) ;; denoise + #f ;; client signature + #f ;; remote connections + )) + +(define *runremote* #f) ;; BUG: Remove this ASAP and update common:*remote* to not refer to *runremote* + ;; Disabled help items ;; -rollup : (currently disabled) fill run (set by :runname) with latest test(s) ;; from prior runs with same keys (define help (conc " Megatest, documentation at http://www.kiatoa.com/fossils/megatest version " megatest-version " - license GPL, Copyright Matt Welland 2006-2012 + license GPL, Copyright Matt Welland 2006-2015 Usage: megatest [options] -h : this help -version : print megatest version (currently " megatest-version ") @@ -301,11 +317,12 @@ (define *time-zero* (current-seconds)) (define *watchdog* (make-thread (lambda () (thread-sleep! 0.05) ;; delay for startup - (let ((legacy-sync (configf:lookup *configdat* "setup" "megatest-db")) + ;; the query to get megatest-db setting might not work, forcing it to be default on. Use "no" to turn off + (let ((legacy-sync (configf:lookup (megatest:area-configdat *area-dat*) "setup" "megatest-db")) (debug-mode (debug:debug-mode 1)) (last-time (current-seconds))) (let loop () ;; sync for filesystem local db writes ;; @@ -312,11 +329,11 @@ (let ((start-time (current-seconds)) (servers-started (make-hash-table))) (for-each (lambda (run-id) (mutex-lock! *db-multi-sync-mutex*) - (if (and legacy-sync + (if (and (not (equal? legacy-sync "no")) (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) (if (common:low-noise-print 30 "sync new to old") @@ -415,11 +432,12 @@ (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) (hash-table-set! args:arg-hash "-testpatt" newval) (hash-table-delete! args:arg-hash "-itempatt"))) -(on-exit std-exit-procedure) +(on-exit (lambda () + (std-exit-procedure *area-dat*))) ;;====================================================================== ;; Misc general calls ;;====================================================================== @@ -427,18 +445,18 @@ (begin (save-environment-as-files (args:get-arg "-env2file")) (set! *didsomething* #t))) (if (args:get-arg "-list-disks") - (let ((toppath (launch:setup-for-run))) + (let ((toppath (launch:setup-for-run *area-dat*))) (print (string-intersperse (map (lambda (x) (string-intersperse x " => ")) - (common:get-disks *configdat*)) + (common:get-disks (megatest:area-configdat *area-dat*))) "\n")) (set! *didsomething* #t))) (define (make-sparse-array) (let ((a (make-sparse-vector))) @@ -619,28 +637,20 @@ (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))))) - ;;====================================================================== ;; 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 ;;====================================================================== (if (args:get-arg "-server") ;; Server? Start up here. ;; - (let ((tl (launch:setup-for-run)) + (let ((tl (launch:setup-for-run *area-dat*)) (run-id (and (args:get-arg "-run-id") (string->number (args:get-arg "-run-id"))))) (if run-id (begin (server:launch run-id) @@ -656,14 +666,14 @@ '("-list-servers" "-stop-server" "-show-cmdinfo" "-list-runs" "-ping"))) - (if (launch:setup-for-run) + (if (launch:setup-for-run *area-dat*) (let ((run-id (and (args:get-arg "-run-id") (string->number (args:get-arg "-run-id"))))) - ;; (set! *fdb* (filedb:open-db (conc *toppath* "/db/paths.db"))) + ;; (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") (begin @@ -672,15 +682,15 @@ ;; (client:launch 0) ;; without run-id we'll start a server for "0" #t )))))) ;; MAY STILL NEED THIS -;; (set! *megatest-db* (make-dbr:dbstruct path: *toppath* local: #t)))))))))) +;; (set! *megatest-db* (make-dbr:dbstruct path: toppath local: #t)))))))))) (if (or (args:get-arg "-list-servers") (args:get-arg "-stop-server")) - (let ((tl (launch:setup-for-run))) + (let ((tl (launch:setup-for-run *area-dat*))) (if tl (let* ((tdbdat (tasks:open-db)) (servers (tasks:get-all-servers (db:delay-if-busy tdbdat))) (fmtstr "~5a~12a~8a~20a~24a~10a~10a~10a~10a\n") (servers-to-kill '()) @@ -737,28 +747,29 @@ ;; (print "[" x "]")) (print x)) targets) (set! *didsomething* #t))) -(define (full-runconfigs-read) - (let* ((keys (rmt:get-keys)) - (target (common:args-get-target)) +(define (full-runconfigs-read area-dat) + (let* ((toppath (megatest:area-path area-dat)) + (keys (rmt:get-keys)) + (target (common:args-get-target)) (key-vals (if target (keys:target->keyval keys target) #f)) (sections (if target (list "default" target) #f)) (data (begin - (setenv "MT_RUN_AREA_HOME" *toppath*) + (setenv "MT_RUN_AREA_HOME" toppath) (if key-vals (for-each (lambda (kt) (setenv (car kt) (cadr kt))) key-vals)) - (read-config (conc *toppath* "/runconfigs.config") #f #t sections: sections)))) + (read-config (conc toppath "/runconfigs.config") #f #t sections: sections)))) data)) (if (args:get-arg "-show-runconfig") - (let ((tl (launch:setup-for-run))) - (push-directory *toppath*) + (let ((tl (launch:setup-for-run *area-dat*))) + (push-directory (megatest:area-path *area-dat*)) (let ((data (full-runconfigs-read))) ;; keep this one local (cond ((and (args:get-arg "-section") (args:get-arg "-var")) @@ -772,13 +783,13 @@ (debug:print 0 "ERROR: -dumpmode of " (args:get-arg "-dumpmode") " not recognised"))) (set! *didsomething* #t)) (pop-directory))) (if (args:get-arg "-show-config") - (let ((tl (launch:setup-for-run)) - (data *configdat*)) ;; (read-config "megatest.config" #f #t))) - (push-directory *toppath*) + (let ((tl (launch:setup-for-run *area-dat*)) + (data (megatest:area-configdat *area-dat*))) + (push-directory (megatest:area-path *area-dat*)) ;; keep this one local (cond ((and (args:get-arg "-section") (args:get-arg "-var")) (let ((val (configf:lookup data (args:get-arg "-section")(args:get-arg "-var")))) @@ -805,13 +816,14 @@ ;; Remove old run(s) ;;====================================================================== ;; since several actions can be specified on the command line the removal ;; is done first -(define (operate-on action) - (let* ((runrec (runs:runrec-make-record)) - (target (common:args-get-target))) +(define (operate-on action area-dat) + (let* ((runrec (runs:runrec-make-record)) + (target (common:args-get-target)) + (configinfo (megatest:area-configinfo area-dat))) (cond ((not target) (debug:print 0 "ERROR: Missing required parameter for " action ", you must specify -target or -reqtarg") (exit 1)) ((not (or (args:get-arg ":runname") @@ -820,19 +832,20 @@ (exit 2)) ((not (args:get-arg "-testpatt")) (debug:print 0 "ERROR: Missing required parameter for " action ", you must specify the test pattern with -testpatt") (exit 3)) (else - (if (not (car *configinfo*)) + (if (not (car configinfo)) (begin (debug:print 0 "ERROR: Attempted " action "on test(s) but run area config file not found") (exit 1)) ;; put test parameters into convenient variables (runs:operate-on action target (or (args:get-arg "-runname")(args:get-arg ":runname")) (args:get-arg "-testpatt") + area-dat state: (or (args:get-arg "-state")(args:get-arg ":state") ) status: (or (args:get-arg "-status")(args:get-arg ":status")) new-state-status: (args:get-arg "-set-state-status"))) (set! *didsomething* #t))))) @@ -839,18 +852,20 @@ (if (args:get-arg "-remove-runs") (general-run-call "-remove-runs" "remove runs" (lambda (target runname keys keyvals) - (operate-on 'remove-runs)))) + (operate-on 'remove-runs)) + *area-dat*)) (if (args:get-arg "-set-state-status") (general-run-call "-set-state-status" "set state and status" (lambda (target runname keys keyvals) - (operate-on 'set-state-status)))) + (operate-on 'set-state-status)) + *area-dat*)) (if (or (args:get-arg "-set-run-status") (args:get-arg "-get-run-status")) (general-run-call "-set-run-status" @@ -868,22 +883,23 @@ (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")) (print (rmt:get-run-status run-id)) - ))))))) + ))))) + *area-dat*)) ;;====================================================================== ;; Query runs ;;====================================================================== ;; NOTE: list-runs and list-db-targets operate on local db!!! ;; (if (or (args:get-arg "-list-runs") (args:get-arg "-list-db-targets")) - (if (launch:setup-for-run) - (let* ((dbstruct (make-dbr:dbstruct path: *toppath* local: #t)) + (if (launch:setup-for-run *area-dat*) + (let* ((dbstruct (make-dbr:dbstruct path: (megatest:area-path *area-dat*) local: #t)) (runpatt (args:get-arg "-list-runs")) (testpatt (if (args:get-arg "-testpatt") (args:get-arg "-testpatt") "%")) (keys (db:get-keys dbstruct)) @@ -1005,11 +1021,13 @@ (lambda (target runname keys keyvals) (runs:run-tests target runname (args:get-arg "-testpatt") user - args:arg-hash)))) + args:arg-hash + *area-dat*)) + *area-dat*)) ;;====================================================================== ;; run one test ;;====================================================================== @@ -1044,11 +1062,13 @@ ;; #f)))) (runs:run-tests target runname (args:get-arg "-runtests") user - args:arg-hash)))) + args:arg-hash + *area-dat*)) + *area-dat*)) ;;====================================================================== ;; Rollup into a run ;;====================================================================== @@ -1058,11 +1078,12 @@ "rollup tests" (lambda (target runname keys keyvals) (runs:rollup-run keys keyvals (or (args:get-arg "-runname")(args:get-arg ":runname") ) - user)))) + user)) + *area-dat*)) ;;====================================================================== ;; Lock or unlock a run ;;====================================================================== @@ -1075,11 +1096,12 @@ target keys (or (args:get-arg "-runname")(args:get-arg ":runname") ) (args:get-arg "-lock") (args:get-arg "-unlock") - user)))) + user)) + *area-dat*)) ;;====================================================================== ;; Get paths to tests ;;====================================================================== ;; Get test paths matching target, runname, and testpatt @@ -1102,11 +1124,11 @@ (change-directory toppath) (if (not target) (begin (debug:print 0 "ERROR: -target is required.") (exit 1))) - (if (not (launch:setup-for-run)) + (if (not (launch:setup-for-run *area-dat*)) (begin (debug:print 0 "Failed to setup, giving up on -test-paths or -test-files, exiting") (exit 1))) (let* ((keys (rmt:get-keys)) ;; db:test-get-paths must not be run remote @@ -1123,11 +1145,12 @@ (let* ((db #f) ;; DO NOT run remote (paths (tests:test-get-paths-matching keys target (args:get-arg "-test-files")))) (for-each (lambda (path) (print path)) - paths)))))) + paths))) + *area-dat*))) ;;====================================================================== ;; Archive tests ;;====================================================================== ;; Archive tests matching target, runname, and testpatt @@ -1135,11 +1158,12 @@ ;; else do a general-run-call (general-run-call "-archive" "Archive" (lambda (target runname keys keyvals) - (operate-on 'archive)))) + (operate-on 'archive)) + *area-dat*)) ;;====================================================================== ;; Extract a spreadsheet from the runs database ;;====================================================================== @@ -1146,19 +1170,20 @@ (if (args:get-arg "-extract-ods") (general-run-call "-extract-ods" "Make ods spreadsheet" (lambda (target runname keys keyvals) - (let ((dbstruct (make-dbr:dbstruct path: *toppath* local: #t)) + (let ((dbstruct (make-dbr:dbstruct path: (megatest:area-path *area-dat*) 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) (db:extract-ods-file dbstruct outputfile keyvals (if runspatt runspatt "%") pathmod) (db:close-all dbstruct) - (set! *didsomething* #t))))) + (set! *didsomething* #t))) + *area-dat*)) ;;====================================================================== ;; execute the test ;; - gets called on remote host ;; - receives info from the -execute param @@ -1190,11 +1215,11 @@ (test-id (assoc/default 'test-id cmdinfo)) (itemdat (assoc/default 'itemdat cmdinfo)) (work-area (assoc/default 'work-area cmdinfo)) (db #f)) (change-directory testpath) - (if (not (launch:setup-for-run)) + (if (not (launch:setup-for-run *area-dat*)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) (if (and state status) (rmt:teststep-set-status! run-id test-id step state status msg logfile) @@ -1238,11 +1263,11 @@ (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"))) - (if (not (launch:setup-for-run)) + (if (not (launch:setup-for-run *area-dat*)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) (if (args:get-arg "-runstep")(debug:print-info 1 "Running -runstep, first change to directory " work-area)) @@ -1343,11 +1368,11 @@ (if (or (args:get-arg "-showkeys") (args:get-arg "-show-keys")) (let ((db #f) (keys #f)) - (if (not (launch:setup-for-run)) + (if (not (launch:setup-for-run *area-dat*)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) (set! keys (cdb:remote-run db:get-keys db)) (debug:print 1 "Keys: " (string-intersperse keys ", ")) @@ -1374,21 +1399,21 @@ ;; Update the database schema, clean up the db ;;====================================================================== (if (args:get-arg "-rebuild-db") (begin - (if (not (launch:setup-for-run)) + (if (not (launch:setup-for-run *area-dat*)) (begin (debug:print 0 "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-for-run)) + (if (not (launch:setup-for-run *area-dat*)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) ;; keep this one local ;; (open-run-close db:clean-up #f) @@ -1403,11 +1428,11 @@ ) (set! *didsomething* #t))) (if (args:get-arg "-mark-incompletes") (begin - (if (not (launch:setup-for-run)) + (if (not (launch:setup-for-run *area-dat*)) (begin (debug:print 0 "Failed to setup, exiting") b (exit 1))) (open-run-close db:find-and-mark-incomplete #f) (set! *didsomething* #t))) @@ -1416,11 +1441,11 @@ ;; Update the tests meta data from the testconfig files ;;====================================================================== (if (args:get-arg "-update-meta") (begin - (if (not (launch:setup-for-run)) + (if (not (launch:setup-for-run *area-dat*)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) ;; now can find our db ;; keep this one local @@ -1429,29 +1454,30 @@ ;;====================================================================== ;; Start a repl ;;====================================================================== -;; fakeout readline -(define (toplevel-command . a) #f) - (if (or (args:get-arg "-repl") (args:get-arg "-load")) - (let* ((toppath (launch:setup-for-run)) + (let* ((toppath (launch:setup-for-run *area-dat*)) (dbstruct (if toppath (make-dbr:dbstruct path: toppath local: #t) #f))) (if dbstruct (begin (set! *db* dbstruct) (set! *client-non-blocking-mode* #t) (import extras) ;; might not be needed ;; (import csi) (import readline) + (use-legacy-bindings) (import apropos) ;; (import (prefix sqlite3 sqlite3:)) ;; doesn't work ... (gnu-history-install-file-manager - (string-append - (or (get-environment-variable "HOME") ".") "/.megatest_history")) + (let ((d (string-append + (or (get-environment-variable "HOME") ".") "/.megatest"))) + (if (not (file-exists? d)) + (create-directory d #t)) + d)) (current-input-port (make-gnu-readline-port "megatest> ")) (if (args:get-arg "-repl") (repl) (load (args:get-arg "-load"))) (db:close-all dbstruct)) @@ -1463,11 +1489,11 @@ ;;====================================================================== (if (and (args:get-arg "-run-wait") (not (args:get-arg "-runtests"))) ;; run-wait is built into runtests now (begin - (if (not (launch:setup-for-run)) + (if (not (launch:setup-for-run *area-dat*)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) (operate-on 'run-wait) (set! *didsomething* #t))) @@ -1523,11 +1549,15 @@ ;;====================================================================== ;; Exit and clean up ;;====================================================================== -(if *runremote* (close-all-connections!)) +;; if *runremote* is defined, close connections, otherwise - trust that it was +;; taken care of. +;; +(if (common:get-remote (megatest:area-remote *area-dat*) #f) + (close-all-connections!)) (if (not *didsomething*) (debug:print 0 help)) (set! *time-to-exit* #t) Index: mt.scm ================================================================== --- mt.scm +++ mt.scm @@ -187,22 +187,23 @@ (define (mt:test-set-state-status-by-testname run-id test-name item-path new-state new-status new-comment) (let ((test-id (cdb:remote-run db:get-test-id-cached #f run-id test-name item-path))) (mt:test-set-state-status-by-id test-id new-state new-status new-comment))) -(define (mt:lazy-read-test-config test-name) - (let ((tconf (hash-table-ref/default *testconfigs* test-name #f))) +(define (mt:lazy-read-test-config test-name area-dat) + (let ((tconf (hash-table-ref/default *testconfigs* test-name #f)) + (configdat (megatest:area-configdat area-dat))) (if tconf tconf - (let ((test-dirs (tests:get-tests-search-path *configdat*))) + (let ((test-dirs (tests:get-tests-search-path configdat area-dat))) (let loop ((hed (car test-dirs)) (tal (cdr test-dirs))) ;; Setting MT_LINKTREE here is almost certainly unnecessary. (let ((tconfig-file (conc hed "/" test-name "/testconfig"))) (if (and (file-exists? tconfig-file) (file-read-access? tconfig-file)) - (let ((link-tree-path (configf:lookup *configdat* "setup" "linktree")) + (let ((link-tree-path (configf:lookup configdat "setup" "linktree")) (old-link-tree (get-environment-variable "MT_LINKTREE"))) (if link-tree-path (setenv "MT_LINKTREE" link-tree-path)) (let ((newtcfg (read-config tconfig-file #f #f))) ;; NOTE: Does NOT run [system ...] (hash-table-set! *testconfigs* test-name newtcfg) (if old-link-tree @@ -209,9 +210,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-info 0 "No readable testconfig found for " test-name) #f) (loop (car tal)(cdr tal)))))))))) Index: newdashboard.scm ================================================================== --- newdashboard.scm +++ newdashboard.scm @@ -74,20 +74,20 @@ (print "Failed to find megatest.config, exiting") (exit 1))) ;; (if (args:get-arg "-host") ;; (begin -;; (set! *runremote* (string-split (args:get-arg "-host" ":"))) +;; (set! (common:get-remote remote) (string-split (args:get-arg "-host" ":"))) ;; (client:launch)) ;; (client:launch)) ;; ease debugging by loading ~/.dashboardrc (let ((debugcontrolf (conc (get-environment-variable "HOME") "/.dashboardrc"))) (if (file-exists? debugcontrolf) (load debugcontrolf))) -(define *dbdir* (db:dbfile-path #f)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db")) +(define *dbdir* (db:dbfile-path #f)) ;; (conc (configf:lookup configdat "setup" "linktree") "/.db")) (define *dbstruct-local* (make-dbr:dbstruct path: *dbdir* local: #t)) (define *db-file-path* (db:dbfile-path 0)) ;; HACK ALERT: this is a hack, please fix. @@ -129,13 +129,13 @@ (define (update-search x val) (hash-table-set! *searchpatts* x val)) ;; mtest is actually the megatest.config file ;; -(define (mtest window-id) +(define (mtest window-id area-dat) (let* ((curr-row-num 0) - (rawconfig (read-config (conc *toppath* "/megatest.config") #f 'return-string)) + (rawconfig (read-config (conc (megatest:area-path area-dat) "/megatest.config") #f 'return-string)) (keys-matrix (dcommon:keys-matrix rawconfig)) (setup-matrix (dcommon:section-matrix rawconfig "setup" "Varname" "Value")) (jobtools-matrix (iup:matrix #:expand "YES" #:numcol 1 @@ -579,21 +579,21 @@ ;;====================================================================== ;; D A S H B O A R D ;;====================================================================== ;; Main Panel -(define (main-panel window-id) +(define (main-panel window-id area-dat) (iup:dialog #:title "Megatest Control Panel" #:menu (dcommon:main-menu) #:shrink "YES" (let ((tabtop (iup:tabs - (runs window-id) - (tests window-id) - (runcontrol window-id) - (mtest window-id) - (rconfig window-id) + (runs window-id area-dat) + (tests window-id area-dat) + (runcontrol window-id area-dat) + (mtest window-id area-dat) + (rconfig window-id area-dat) ))) (iup:attribute-set! tabtop "TABTITLE0" "Runs") (iup:attribute-set! tabtop "TABTITLE1" "Tests") (iup:attribute-set! tabtop "TABTITLE2" "Run Control") (iup:attribute-set! tabtop "TABTITLE3" "megatest.config") Index: nmsg-transport.scm ================================================================== --- nmsg-transport.scm +++ nmsg-transport.scm @@ -61,11 +61,11 @@ ;;====================================================================== ;; S E R V E R ;;====================================================================== -(define (nmsg-transport:run dbstruct hostn run-id server-id #!key (retrynum 1000)) +(define (nmsg-transport:run dbstruct area-dat hostn run-id server-id #!key (retrynum 1000)) (debug:print 2 "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")) @@ -79,19 +79,19 @@ (set! *server-info* (list hostn start-port)) ;; probably not needed anymore? currently used by keep-running (thread-sleep! 3) ;; give some margin for queries to complete before switching from file based access to server based access ;; (set! *inmemdb* dbstruct) (tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "running") (thread-start! (make-thread - (lambda ()(nmsg-transport:keep-running server-id run-id)) + (lambda ()(nmsg-transport:keep-running server-id run-id area-dat)) "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.") (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)) + (nmsg-transport:run dbstruct area-dat hostn run-id server-id)) (begin (debug:print 0 "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) @@ -105,11 +105,11 @@ (nn-send repsoc (db:obj->string result transport: 'nmsg))) (loop (nn-recv repsoc)))))) ;; all routes though here end in exit ... ;; -(define (nmsg-transport:launch run-id) +(define (nmsg-transport:launch run-id area-dat) (let* ((tdbdat (tasks:open-db)) (dbstruct (db:setup run-id)) (hostn (or (args:get-arg "-server") "-"))) (set! *run-id* run-id) (set! *inmemdb* dbstruct) @@ -142,11 +142,11 @@ ;; 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") (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)) + (nmsg-transport:run dbstruct area-dat hostn run-id server-id)) (set! *didsomething* #t) (exit)))) ;;====================================================================== ;; S E R V E R U T I L I T I E S @@ -252,11 +252,11 @@ (make-property-condition 'timeout 'message "nmsg-transport:client-api-send-receive-raw timed out talking to server")))))) ;; run nmsg-transport:keep-running in a parallel thread to monitor that the db is being ;; used and to shutdown after sometime if it is not. ;; -(define (nmsg-transport:keep-running server-id run-id) +(define (nmsg-transport:keep-running server-id run-id area-dat) ;; if none running or if > 20 seconds since ;; server last used then start shutdown ;; This thread waits for the server to come alive (let* ((server-info (let loop () (let ((sdat #f)) @@ -272,11 +272,11 @@ (loop)))))) (iface (car server-info)) (port (cadr server-info)) (last-access 0) (tdbdat (tasks:open-db)) - (server-timeout (let ((tmo (configf:lookup *configdat* "server" "timeout"))) + (server-timeout (let ((tmo (configf:lookup (megatest:area-configdat area-dat) "server" "timeout"))) (if (and (string? tmo) (string->number tmo)) (* 60 60 (string->number tmo)) ;; (* 3 24 60 60) ;; default to three days (* 60 1) ;; default to one minute @@ -342,11 +342,11 @@ (handle-exceptions exn (debug:print " ... exiting ...") (let ((th1 (make-thread (lambda () (if (not *received-response*) - (receive-message* *runremote*))) ;; flush out last call if applicable + (receive-message* (common:get-remote remote #f)))) ;; flush out last call if applicable "eat response")) (th2 (make-thread (lambda () (debug:print 0 "ERROR: Received ^C, attempting clean exit. Please be patient and wait a few seconds before hitting ^C again.") (thread-sleep! 3) ;; give the flush three seconds to do it's stuff (debug:print 0 " Done.") ADDED olddashboard.scm Index: olddashboard.scm ================================================================== --- /dev/null +++ olddashboard.scm @@ -0,0 +1,2256 @@ +;;====================================================================== +;; Copyright 2006-2012, Matthew Welland. +;; +;; This program is made available under the GNU GPL version 2.0 or +;; greater. See the accompanying file COPYING for details. +;; +;; This program is distributed WITHOUT ANY WARRANTY; without even the +;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR +;; PURPOSE. +;;====================================================================== + +(use format) +(require-library iup) +(import (prefix iup iup:)) + +(use canvas-draw) +(import canvas-draw-iup) + +(use sqlite3 srfi-1 posix regex regex-case srfi-69) +(import (prefix sqlite3 sqlite3:)) + +(declare (uses common)) +(declare (uses margs)) +(declare (uses keys)) +(declare (uses items)) +(declare (uses db)) +(declare (uses configf)) +(declare (uses process)) +(declare (uses launch)) +(declare (uses runs)) +(declare (uses dashboard-tests)) +(declare (uses dashboard-guimonitor)) +(declare (uses tree)) +;; (declare (uses dcommon)) + +;; (declare (uses dashboard-main)) +(declare (uses megatest-version)) +(declare (uses mt)) + +(include "common_records.scm") +(include "db_records.scm") +(include "key_records.scm") +(include "run_records.scm") +(include "megatest-fossil-hash.scm") + +;; Inserting dcommon to keep old dashboard around while new +;; is under development + +(declare (uses gutils)) +(declare (uses synchash)) + +;; yes, this is non-ideal +(define dashboard:update-summary-tab #f) +(define dashboard:update-servers-table #f) + +;;====================================================================== +;; C O M M O N D A T A S T R U C T U R E +;;====================================================================== +;; +;; A single data structure for all the data used in a dashboard. +;; Share this structure between newdashboard and dashboard with the +;; intent of converging on a single app. +;; +(define *data* (make-vector 25 #f)) +(define (dboard:data-get-runs vec) (vector-ref vec 0)) +(define (dboard:data-get-tests vec) (vector-ref vec 1)) +(define (dboard:data-get-runs-matrix vec) (vector-ref vec 2)) +(define (dboard:data-get-tests-tree vec) (vector-ref vec 3)) +(define (dboard:data-get-run-keys vec) (vector-ref vec 4)) +(define (dboard:data-get-curr-test-ids vec) (vector-ref vec 5)) +;; (define (dboard:data-get-test-details vec) (vector-ref vec 6)) +(define (dboard:data-get-path-test-ids vec) (vector-ref vec 7)) +(define (dboard:data-get-updaters vec) (vector-ref vec 8)) +(define (dboard:data-get-path-run-ids vec) (vector-ref vec 9)) +(define (dboard:data-get-curr-run-id vec) (vector-ref vec 10)) +(define (dboard:data-get-runs-tree vec) (vector-ref vec 11)) +;; For test-patts convert #f to "" +(define (dboard:data-get-test-patts vec) + (let ((val (vector-ref vec 12)))(if val val ""))) +(define (dboard:data-get-states vec) (vector-ref vec 13)) +(define (dboard:data-get-statuses vec) (vector-ref vec 14)) +(define (dboard:data-get-logs-textbox vec val)(vector-ref vec 15)) +(define (dboard:data-get-command vec) (vector-ref vec 16)) +(define (dboard:data-get-command-tb vec) (vector-ref vec 17)) +(define (dboard:data-get-target vec) (vector-ref vec 18)) +(define (dboard:data-get-target-string vec) + (let ((targ (dboard:data-get-target vec))) + (if (list? targ)(string-intersperse targ "/") "no-target-specified"))) +(define (dboard:data-get-run-name vec) (vector-ref vec 19)) +(define (dboard:data-get-runs-listbox vec) (vector-ref vec 20)) + +(define (dboard:data-set-runs! vec val)(vector-set! vec 0 val)) +(define (dboard:data-set-tests! vec val)(vector-set! vec 1 val)) +(define (dboard:data-set-runs-matrix! vec val)(vector-set! vec 2 val)) +(define (dboard:data-set-tests-tree! vec val)(vector-set! vec 3 val)) +(define (dboard:data-set-run-keys! vec val)(vector-set! vec 4 val)) +(define (dboard:data-set-curr-test-ids! vec val)(vector-set! vec 5 val)) +;; (define (dboard:data-set-test-details! vec val)(vector-set! vec 6 val)) +(define (dboard:data-set-path-test-ids! vec val)(vector-set! vec 7 val)) +(define (dboard:data-set-updaters! vec val)(vector-set! vec 8 val)) +(define (dboard:data-set-path-run-ids! vec val)(vector-set! vec 9 val)) +(define (dboard:data-set-curr-run-id! vec val)(vector-set! vec 10 val)) +(define (dboard:data-set-runs-tree! vec val)(vector-set! vec 11 val)) +;; For test-patts convert "" to #f +(define (dboard:data-set-test-patts! vec val) + (vector-set! vec 12 (if (equal? val "") #f val))) +(define (dboard:data-set-states! vec val)(vector-set! vec 13 val)) +(define (dboard:data-set-statuses! vec val)(vector-set! vec 14 val)) +(define (dboard:data-set-logs-textbox! vec val)(vector-set! vec 15 val)) +(define (dboard:data-set-command! vec val)(vector-set! vec 16 val)) +(define (dboard:data-set-command-tb! vec val)(vector-set! vec 17 val)) +(define (dboard:data-set-target! vec val)(vector-set! vec 18 val)) +(define (dboard:data-set-run-name! vec val)(vector-set! vec 19 val)) +(define (dboard:data-set-runs-listbox! vec val)(vector-set! vec 20 val)) + +(dboard:data-set-run-keys! *data* (make-hash-table)) + +;; List of test ids being viewed in various panels +(dboard:data-set-curr-test-ids! *data* (make-hash-table)) + +;; Look up test-ids by (key1 key2 ... testname [itempath]) +(dboard:data-set-path-test-ids! *data* (make-hash-table)) + +;; Look up run-ids by ?? +(dboard:data-set-path-run-ids! *data* (make-hash-table)) + +;;====================================================================== +;; TARGET AND PATTERN MANIPULATIONS +;;====================================================================== + +;; Convert to and from list of lines (for a text box) +;; "," => "\n" +(define (dboard:test-patt->lines test-patt) + (string-substitute (regexp ",") "\n" test-patt)) + +(define (dboard:lines->test-patt lines) + (string-substitute (regexp "\n") "," lines #t)) + + +;;====================================================================== +;; P R O C E S S R U N S +;;====================================================================== + +;; MOVE THIS INTO *data* +(define *cachedata* (make-hash-table)) +(hash-table-set! *cachedata* "runid-to-col" (make-hash-table)) +(hash-table-set! *cachedata* "testname-to-row" (make-hash-table)) + +;; TO-DO +;; 1. Make "data" hash-table hierarchial store of all displayed data +;; 2. Update synchash to understand "get-runs", "get-tests" etc. +;; 3. Add extraction of filters to synchash calls +;; +;; Mode is 'full or 'incremental for full refresh or incremental refresh +(define (dcommon:run-update keys data runname keypatts testpatt states statuses mode window-id) + (let* (;; count and offset => #f so not used + ;; the synchash calls modify the "data" hash + (get-runs-sig (conc (client:get-signature) " get-runs")) + (get-tests-sig (conc (client:get-signature) " get-tests")) + (get-details-sig (conc (client:get-signature) " get-test-details")) + + ;; test-ids to get and display are indexed on window-id in curr-test-ids hash + (test-ids (hash-table-values (dboard:data-get-curr-test-ids *data*))) + ;; run-id is #f in next line to send the query to server 0 + (run-changes (synchash:client-get 'db:get-runs get-runs-sig (length keypatts) data #f runname #f #f keypatts)) + (tests-detail-changes (if (not (null? test-ids)) + (synchash:client-get 'db:get-test-info-by-ids get-details-sig 0 data #f test-ids) + '())) + + ;; Now can calculate the run-ids + (run-hash (hash-table-ref/default data get-runs-sig #f)) + (run-ids (if run-hash (filter number? (hash-table-keys run-hash)) '())) + + (all-test-changes (let ((res (make-hash-table))) + (for-each (lambda (run-id) + (if (> run-id 0) + (hash-table-set! res run-id (synchash:client-get 'db:get-tests-for-run-mindata get-tests-sig 0 data run-id 1 testpatt states statuses #f)))) + run-ids) + res)) + (runs-hash (hash-table-ref/default data get-runs-sig #f)) + (header (hash-table-ref/default runs-hash "header" #f)) + (run-ids (sort (filter number? (hash-table-keys runs-hash)) + (lambda (a b) + (let* ((record-a (hash-table-ref runs-hash a)) + (record-b (hash-table-ref runs-hash b)) + (time-a (db:get-value-by-header record-a header "event_time")) + (time-b (db:get-value-by-header record-b header "event_time"))) + (> time-a time-b))) + )) + (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) + + ;; 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 + + ;; NOTE: Also build the test tree browser and look up table + ;; + ;; Each run is unique on its keys and runname or run-id, store in hash on colnum + (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 header key)) + keys)) + (run-name (db:get-value-by-header run-record header "runname")) + (col-name (conc (string-intersperse key-vals "\n") "\n" run-name)) + (run-path (append key-vals (list run-name)))) + (hash-table-set! (dboard:data-get-run-keys *data*) 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 (dboard:data-get-tests-tree *data*) "Runs" (append key-vals (list run-name)) + userdata: (conc "run-id: " run-id)) + (set! colnum (+ colnum 1)))) + run-ids) + + ;; Scan all tests to be displayed and organise all the test names, respecting what is in the hash table + ;; Do this analysis in the order of the run-ids, the most recent run wins + (for-each (lambda (run-id) + (let* ((run-path (hash-table-ref (dboard:data-get-run-keys *data*) run-id)) + (test-changes (hash-table-ref all-test-changes run-id)) + (new-test-dat (car test-changes)) + (removed-tests (cadr test-changes)) + (tests (sort (map cadr (filter (lambda (testrec) + (eq? run-id (db:mintest-get-run_id (cadr testrec)))) + new-test-dat)) + (lambda (a b) + (let ((time-a (db:mintest-get-event_time a)) + (time-b (db:mintest-get-event_time b))) + (> time-a time-b))))) + ;; test-changes is a list of (( id record ) ... ) + ;; Get list of test names sorted by time, remove tests + (test-names (delete-duplicates (map (lambda (t) + (let ((i (db:mintest-get-item_path t)) + (n (db:mintest-get-testname t))) + (if (string=? i "") + (conc " " i) + n))) + tests))) + (colnum (car (hash-table-ref runid-to-col run-id)))) + ;; for each test name get the slot if it exists and fill in the cell + ;; or take the next slot and fill in the cell, deal with items in the + ;; run view panel? The run view panel can have a tree selector for + ;; browsing the tests/items + + ;; SWITCH THIS TO USING CHANGED TESTS ONLY + (for-each (lambda (test) + (let* ((test-id (db:mintest-get-id test)) + (state (db:mintest-get-state test)) + (status (db:mintest-get-status test)) + (testname (db:mintest-get-testname test)) + (itempath (db:mintest-get-item_path test)) + (fullname (conc testname "/" itempath)) + (dispname (if (string=? itempath "") testname (conc " " itempath))) + (rownum (hash-table-ref/default testname-to-row fullname #f)) + (test-path (append run-path (if (equal? itempath "") + (list testname) + (list testname itempath)))) + (tb (dboard:data-get-tests-tree *data*))) + (print "INFONOTE: run-path: " run-path) + (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) + (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) + 1 + (+ 1 (apply max rownums)))) + (hash-table-set! testname-to-row fullname rownum) + ;; 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) + (iup:attribute-set! (dboard:data-get-runs-matrix *data*) + (conc rownum ":" colnum) + (if (member state '("ARCHIVED" "COMPLETED")) + status + state)) + (iup:attribute-set! (dboard:data-get-runs-matrix *data*) + (conc "BGCOLOR" rownum ":" colnum) + (car (gutils:get-color-for-state-status state status))) + )) + tests))) + run-ids) + + (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) + (list run-changes all-test-changes))) + +;;====================================================================== +;; TESTS DATA +;;====================================================================== + +;; Produce a list of lists ready for common:sparse-list-generate-index +;; +(define (dcommon:minimize-test-data tests-dat) + (if (null? tests-dat) + '() + (let loop ((hed (car tests-dat)) + (tal (cdr tests-dat)) + (res '())) + (let* ((test-id (vector-ref hed 0)) ;; look at the tests-dat spec for locations + (test-name (vector-ref hed 1)) + (item-path (vector-ref hed 2)) + (state (vector-ref hed 3)) + (status (vector-ref hed 4)) + (newitem (list test-name item-path (list test-id state status)))) + (if (null? tal) + (reverse (cons newitem res)) + (loop (car tal)(cdr tal)(cons newitem res))))))) + + +;;====================================================================== +;; D A T A T A B L E S +;;====================================================================== + +;; Table of keys +(define (dcommon:keys-matrix rawconfig) + (let* ((curr-row-num 1) + (key-vals (configf:section-vars rawconfig "fields")) + (keys-matrix (iup:matrix + #:alignment1 "ALEFT" + #:expand "YES" ;; "HORIZONTAL" ;; "VERTICAL" + ;; #:scrollbar "YES" + #:numcol 1 + #:numlin (length key-vals) + #:numcol-visible 1 + #:numlin-visible (length key-vals) + #:click-cb (lambda (obj lin col status) + (print "obj: " obj " lin: " lin " col: " col " status: " status))))) + ;; (iup:attribute-set! keys-matrix "0:0" "Run Keys") + (iup:attribute-set! keys-matrix "WIDTH0" 0) + (iup:attribute-set! keys-matrix "0:1" "Key Name") + ;; (iup:attribute-set! keys-matrix "WIDTH1" "100") + ;; fill in keys + (for-each + (lambda (var) + ;; (iup:attribute-set! keys-matrix "ADDLIN" (conc curr-row-num)) + (iup:attribute-set! keys-matrix (conc curr-row-num ":0") curr-row-num) + (iup:attribute-set! keys-matrix (conc curr-row-num ":1") var) + (set! curr-row-num (+ 1 curr-row-num))) ;; (config-lookup configdat "fields" var))) + key-vals) + (iup:attribute-set! keys-matrix "WIDTHDEF" "40") + keys-matrix)) + +;; Section to table +(define (dcommon:section-matrix rawconfig sectionname varcolname valcolname #!key (title #f)) + (let* ((curr-row-num 1) + (key-vals (configf:section-vars rawconfig sectionname)) + (section-matrix (iup:matrix + #:alignment1 "ALEFT" + #:expand "YES" ;; "HORIZONTAL" + #:numcol 1 + #:numlin (length key-vals) + #:numcol-visible 1 + #:numlin-visible (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 + (for-each + (lambda (var) + ;; (iup:attribute-set! keys-matrix "ADDLIN" (conc curr-row-num)) + (iup:attribute-set! section-matrix (conc curr-row-num ":0") var) + (iup:attribute-set! section-matrix (conc curr-row-num ":1") (configf:lookup rawconfig sectionname var)) + (set! curr-row-num (+ 1 curr-row-num))) ;; (config-lookup configdat "fields" var))) + key-vals) + (iup:vbox + (iup:label (if title title (conc "Settings from [" sectionname "]")) + ;; #:size "5x" + #:expand "HORIZONTAL" + ) + section-matrix))) + +;; General data +;; +(define (dcommon:general-info) + (let ((general-matrix (iup:matrix + #:alignment1 "ALEFT" + #:expand "YES" ;; "HORIZONTAL" + #:numcol 1 + #:numlin 2 + #:numcol-visible 1 + #:numlin-visible 2))) + (iup:attribute-set! general-matrix "WIDTH1" "150") + (iup:attribute-set! general-matrix "0:1" "About this Megatest area") + ;; User (this is not always obvious - it is common to run as a different user + (iup:attribute-set! general-matrix "1:0" "User") + (iup:attribute-set! general-matrix "1:1" (current-user-name)) + ;; Megatest area + ;; (iup:attribute-set! general-matrix "2:0" "Area") + ;; (iup:attribute-set! general-matrix "2:1" toppath) + ;; Megatest version + (iup:attribute-set! general-matrix "2:0" "Version") + (iup:attribute-set! general-matrix "2:1" (conc megatest-version "-" (substring megatest-fossil-hash 0 4))) + + general-matrix)) + +(define (dcommon:run-stats dbstruct) + (let* ((stats-matrix (iup:matrix expand: "YES")) + (changed #f) + (updater (lambda () + (let* ((run-stats (db:get-run-stats dbstruct)) + (indices (common:sparse-list-generate-index run-stats)) ;; proc: set-cell)) + (row-indices (car indices)) + (col-indices (cadr indices)) + (max-row (if (null? row-indices) 1 (apply max (map cadr row-indices)))) + (max-col (if (null? col-indices) 1 + (apply max (map cadr col-indices)))) + (max-visible (max (- *num-tests* 15) 3)) + (max-col-vis (if (> max-col 10) 10 max-col)) + (numrows 1) + (numcols 1)) + (iup:attribute-set! stats-matrix "CLEARVALUE" "CONTENTS") + (iup:attribute-set! stats-matrix "NUMCOL" max-col ) + (iup:attribute-set! stats-matrix "NUMLIN" (if (< max-row max-visible) max-visible max-row)) ;; min of 20 + (iup:attribute-set! stats-matrix "NUMCOL_VISIBLE" max-col-vis) + (iup:attribute-set! stats-matrix "NUMLIN_VISIBLE" (if (> max-row max-visible) max-visible max-row)) + + ;; Row labels + (for-each (lambda (ind) + (let* ((name (car ind)) + (num (cadr ind)) + (key (conc num ":0"))) + (if (not (equal? (iup:attribute stats-matrix key) name)) + (begin + (set! changed #t) + (iup:attribute-set! stats-matrix key name))))) + row-indices) + + ;; Col labels + (for-each (lambda (ind) + (let* ((name (car ind)) + (num (cadr ind)) + (key (conc "0:" num))) + (if (not (equal? (iup:attribute stats-matrix key) name)) + (begin + (set! changed #t) + (iup:attribute-set! stats-matrix key name))))) + col-indices) + + ;; Cell contents + (for-each (lambda (entry) + (let* ((row-name (car entry)) + (col-name (cadr entry)) + (value (caddr entry)) + (row-num (cadr (assoc row-name row-indices))) + (col-num (cadr (assoc col-name col-indices))) + (key (conc row-num ":" col-num))) + (if (not (equal? (iup:attribute stats-matrix key) value)) + (begin + (set! changed #t) + (iup:attribute-set! stats-matrix key value))))) + run-stats) + (if changed (iup:attribute-set! stats-matrix "REDRAW" "ALL")))))) + (updater) + (set! dashboard:update-summary-tab updater) + (iup:attribute-set! stats-matrix "WIDTHDEF" "40") + (iup:vbox + ;; (iup:label "Run statistics" #:expand "HORIZONTAL") + stats-matrix))) + +(define (dcommon:servers-table) + (let* ((tdbdat (tasks:open-db)) + (colnum 0) + (rownum 0) + (servers-matrix (iup:matrix #:expand "YES" + #:numcol 7 + #:numcol-visible 7 + #:numlin-visible 5 + )) + (colnames (list "Id" "MTver" "Pid" "Host" "Interface:OutPort" "RunTime" "State" "RunId")) + (updater (lambda () + (let ((servers (tasks:get-all-servers (db:delay-if-busy tdbdat)))) + (iup:attribute-set! servers-matrix "NUMLIN" (length servers)) + ;; (set! colnum 0) + ;; (for-each (lambda (colname) + ;; ;; (print "colnum: " colnum " colname: " colname) + ;; (iup:attribute-set! servers-matrix (conc "0:" colnum) colname) + ;; (set! colnum (+ 1 colnum))) + ;; colnames) + (set! rownum 1) + (for-each + (lambda (server) + (set! colnum 0) + (let* ((vals (list (vector-ref server 0) ;; Id + (vector-ref server 9) ;; MT-Ver + (vector-ref server 1) ;; Pid + (vector-ref server 2) ;; Hostname + (conc (vector-ref server 3) ":" (vector-ref server 4)) ;; IP:Port + (seconds->hr-min-sec (- (current-seconds)(vector-ref server 6))) + ;; (vector-ref server 5) ;; Pubport + ;; (vector-ref server 10) ;; Last beat + ;; (vector-ref server 6) ;; Start time + ;; (vector-ref server 7) ;; Priority + ;; (vector-ref server 8) ;; State + (vector-ref server 8) ;; State + (vector-ref server 12) ;; RunId + ))) + (for-each (lambda (val) + (let* ((row-col (conc rownum ":" colnum)) + (curr-val (iup:attribute servers-matrix row-col))) + (if (not (equal? (conc val) curr-val)) + (begin + (iup:attribute-set! servers-matrix row-col val) + (iup:attribute-set! servers-matrix "FITTOTEXT" (conc "C" colnum)))) + (set! colnum (+ 1 colnum)))) + vals) + (set! rownum (+ rownum 1))) + (iup:attribute-set! servers-matrix "REDRAW" "ALL")) + servers))))) + (set! colnum 0) + (for-each (lambda (colname) + (iup:attribute-set! servers-matrix (conc "0:" colnum) colname) + (iup:attribute-set! servers-matrix "FITTOTEXT" (conc "C" colnum)) + (set! colnum (+ colnum 1))) + colnames) + (set! dashboard:update-servers-table updater) + ;; (iup:attribute-set! servers-matrix "WIDTHDEF" "40") + ;; (iup:hbox + ;; (iup:vbox + ;; (iup:button "Start" + ;; ;; #:size "50x" + ;; #:expand "YES" + ;; #:action (lambda (obj) + ;; (let ((cmd (conc ;; "xterm -geometry 180x20 -e \"" + ;; "megatest -server - &"))) + ;; ;; ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &"))) + ;; (system cmd)))) + ;; (iup:button "Stop" + ;; #:expand "YES" + ;; ;; #:size "50x" + ;; #:action (lambda (obj) + ;; (let ((cmd (conc ;; "xterm -geometry 180x20 -e \"" + ;; "megatest -stop-server 0 &"))) + ;; ;; ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &"))) + ;; (system cmd)))) + ;; (iup:button "Restart" + ;; #:expand "YES" + ;; ;; #:size "50x" + ;; #:action (lambda (obj) + ;; (let ((cmd (conc ;; "xterm -geometry 180x20 -e \"" + ;; "megatest -stop-server 0;megatest -server - &"))) + ;; ;; ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &"))) + ;; (system cmd))))) + ;; servers-matrix + ;; ))) + servers-matrix + )) + +;; The main menu +(define (dcommon:main-menu) + (iup:menu ;; a menu is a special attribute to a dialog (think Gnome putting the menu at screen top) + (iup:menu-item "Files" (iup:menu ;; Note that you can use either #:action or action: for options + (iup:menu-item "Open" action: (lambda (obj) + (iup:show (iup:file-dialog)) + (print "File->open " obj))) + (iup:menu-item "Save" #:action (lambda (obj)(print "File->save " obj))) + (iup:menu-item "Exit" #:action (lambda (obj)(exit))))) + (iup:menu-item "Tools" (iup:menu + (iup:menu-item "Create new blah" #:action (lambda (obj)(print "Tools->new blah"))) + ;; (iup:menu-item "Show dialog" #:action (lambda (obj) + ;; (show message-window + ;; #:modal? #t + ;; ;; set positon using coordinates or center, start, top, left, end, bottom, right, parent-center, current + ;; ;; #:x 'mouse + ;; ;; #:y 'mouse + ;; ) + )))) + +;;====================================================================== +;; CANVAS STUFF FOR TESTS +;;====================================================================== + +(define (dcommon:draw-test cnv x y w h name selected) + (let* ((llx x) + (lly y) + (urx (+ x w)) + (ury (+ y h))) + (canvas-text! cnv (+ llx 5)(+ lly 5) name) ;; (conc testname " (" xtorig "," ytorig ")")) + (canvas-rectangle! cnv llx urx lly ury) + (if selected (canvas-box! cnv llx (+ llx 5) lly (+ lly 5))))) + +(define (dcommon:initial-draw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames) + (let* ((scalef (hash-table-ref/default tests-draw-state 'scalef 8)) + (test-browse-xoffset (hash-table-ref tests-draw-state 'test-browse-xoffset)) + (test-browse-yoffset (hash-table-ref tests-draw-state 'test-browse-yoffset)) + (xtorig (+ test-browse-xoffset (* (/ sizex 2) scalef (- 0.5 xadj)))) ;; (- xadj 1)))) + (ytorig (+ test-browse-yoffset (* (/ sizey 2) scalef (- yadj 0.5)))) + (boxw 90) ;; default, overriden by length estimate below + (boxh 25) + (gapx 20) + (gapy 30) + (tests-hash (hash-table-ref tests-draw-state 'tests-info)) + (selected-tests (hash-table-ref tests-draw-state 'selected-tests ))) + (hash-table-set! tests-draw-state 'xtorig xtorig) + (hash-table-set! tests-draw-state 'ytorig ytorig) + (let ((longest-str (if (null? sorted-testnames) " " (car (sort sorted-testnames (lambda (a b)(>= (string-length a)(string-length b)))))))) + (let-values (((x-max y-max) (canvas-text-size cnv longest-str))) + (if (> x-max boxw)(set! boxw (+ 10 x-max))))) + ;; (print "sizex: " sizex " sizey: " sizey " font: " (canvas-font cnv) " originx: " originx " originy: " originy " xtorig: " xtorig " ytorig: " ytorig " xadj: " xadj " yadj: " yadj) + (if (not (null? sorted-testnames)) + (let loop ((hed (car (reverse sorted-testnames))) + (tal (cdr (reverse sorted-testnames))) + (llx xtorig) + (lly ytorig) + (urx (+ xtorig boxw)) + (ury (+ ytorig boxh))) + ; (print "hed " hed " llx " llx " lly " lly " urx " urx " ury " ury) + (dcommon:draw-test cnv llx lly boxw boxh hed (hash-table-ref/default selected-tests hed #f)) + ;; data used by mouse click calc. keep the wacky order for now. + (hash-table-set! tests-hash hed (list llx urx (- sizey ury)(- sizey lly) lly boxw boxh)) + ;; (list llx lly boxw boxh)) ;; NB// Swap ury and lly + (if (not (null? tal)) + ;; leave a column of space to the right to list items + (let ((have-room + (if #t ;; put "auto" here where some form of auto rearanging can be done + (> (* 3 (+ boxw gapx)) (- urx xtorig)) + (< urx (- sizex boxw gapx boxw))))) ;; is there room for another column? + (loop (car tal) + (cdr tal) + (if have-room (+ llx boxw gapx) xtorig) ;; have room, + (if have-room lly (+ lly boxh gapy)) + (if have-room (+ urx boxw gapx) (+ xtorig boxw)) + (if have-room ury (+ ury boxh gapy))))))))) + +(define (dcommon:redraw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames) + (let* ((scalef (hash-table-ref/default tests-draw-state 'scalef 8)) + (test-browse-xoffset (hash-table-ref tests-draw-state 'test-browse-xoffset)) + (test-browse-yoffset (hash-table-ref tests-draw-state 'test-browse-yoffset)) + (xtorig (+ test-browse-xoffset (* (/ sizex 2) scalef (- 0.5 xadj)))) ;; (- xadj 1)))) + (ytorig (+ test-browse-yoffset (* (/ sizey 2) scalef (- yadj 0.5)))) + (xdelta (- (hash-table-ref tests-draw-state 'xtorig) xtorig)) + (ydelta (- (hash-table-ref tests-draw-state 'ytorig) ytorig)) + (tests-hash (hash-table-ref tests-draw-state 'tests-info)) + (selected-tests (hash-table-ref tests-draw-state 'selected-tests ))) + (hash-table-set! tests-draw-state 'xtorig xtorig) + (hash-table-set! tests-draw-state 'ytorig ytorig) + (if (not (null? sorted-testnames)) + (let loop ((hed (car (reverse sorted-testnames))) + (tal (cdr (reverse sorted-testnames)))) + (let* ((tvals (hash-table-ref tests-hash hed)) + (llx (+ xdelta (list-ref tvals 0))) + (lly (+ ydelta (list-ref tvals 4))) + (boxw (list-ref tvals 5)) + (boxh (list-ref tvals 6)) + (urx (+ llx boxw)) + (ury (+ lly boxh))) + (dcommon:draw-test cnv llx lly boxw boxh hed (hash-table-ref/default selected-tests hed #f)) + (hash-table-set! tests-hash hed (list llx urx (- sizey ury)(- sizey lly) lly boxw boxh)) + (if (not (null? tal)) + ;; leave a column of space to the right to list items + (loop (car tal) + (cdr tal)))))))) + +;;====================================================================== +;; S T E P S +;;====================================================================== + +(define (dcommon:populate-steps teststeps steps-matrix) + (let ((max-row 0)) + (if (null? teststeps) + (iup:attribute-set! steps-matrix "CLEARVALUE" "CONTENTS") + (let loop ((hed (car teststeps)) + (tal (cdr teststeps)) + (rownum 1) + (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) + (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))) + (mtrx-rc (conc rownum ":" colnum)) + (curr-val (iup:attribute steps-matrix mtrx-rc))) + ;; (debug:print-info 0 "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 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"))))) + + + +(define help (conc +"Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest + version " megatest-version " + license GPL, Copyright (C) Matt Welland 2012-2014 + +Usage: dashboard [options] + -h : this help + -server host:port : connect to host:port instead of db access + -test run-id,test-id : control test identified by testid + -guimonitor : control panel for runs + +Misc + -rows N : set number of rows +")) + +;; process args +(define remargs (args:get-args + (argv) + (list "-rows" + "-run" + "-test" + "-debug" + "-host" + "-transport" + ) + (list "-h" + "-use-server" + "-guimonitor" + "-main" + "-v" + "-q" + ) + args:arg-hash + 0)) + +(if (args:get-arg "-h") + (begin + (print help) + (exit))) + +(if (not (launch:setup-for-run)) + (begin + (print "Failed to find megatest.config, exiting") + (exit 1))) + +(define *dbdir* (db:dbfile-path #f)) ;; (conc (configf:lookup configdat "setup" "linktree") "/.db")) +(define *dbstruct-local* (make-dbr:dbstruct path: *dbdir* + local: #t)) +(define *db-file-path* (db:dbfile-path 0)) + +;; HACK ALERT: this is a hack, please fix. +(define *read-only* (not (file-read-access? *db-file-path*))) + +(define toplevel #f) +(define dlg #f) +(define max-test-num 0) +(define *keys* (db:get-keys *dbstruct-local*)) + +(define *dbkeys* (append *keys* (list "runname"))) + +(define *header* #f) +(define *allruns* '()) +(define *allruns-by-id* (make-hash-table)) ;; +(define *runchangerate* (make-hash-table)) + +(define *buttondat* (make-hash-table)) ;; +(define *alltestnamelst* '()) +(define *searchpatts* (make-hash-table)) +(define *num-runs* 8) +(define *tot-run-count* (db:get-num-runs *dbstruct-local* "%")) +;; (define *tot-run-count* (db:get-num-runs *dbstruct-local* "%")) + +;; Update management +;; +(define *last-update* (current-seconds)) +(define *last-db-update-time* 0) +(define *please-update-buttons* #t) +(define *delayed-update* 0) +(define *update-is-running* #f) +(define *update-mutex* (make-mutex)) + +(define *all-item-test-names* '()) +(define *num-tests* 15) +(define *start-run-offset* 0) +(define *start-test-offset* 0) +(define *examine-test-dat* (make-hash-table)) +(define *exit-started* #f) +(define *status-ignore-hash* (make-hash-table)) +(define *state-ignore-hash* (make-hash-table)) + +(define *tests-sort-options* (vector (vector "Sort +a" 'testname "ASC") + (vector "Sort -a" 'testname "DESC") + (vector "Sort +t" 'event_time "ASC") + (vector "Sort -t" 'event_time "DESC") + (vector "Sort +s" 'statestatus "ASC") + (vector "Sort -s" 'statestatus "DESC") + (vector "Sort +a" 'testname "ASC"))) + +(define *tests-sort-type-index* '(("+testname" 0) + ("-testname" 1) + ("+event_time" 2) + ("-event_time" 3) + ("+statestatus" 4) + ("-statestatus" 5))) + +;; Don't forget to adjust the >= below if you add to the sort-options above +(define (next-sort-option) + (if (>= *tests-sort-reverse* 5) + (set! *tests-sort-reverse* 0) + (set! *tests-sort-reverse* (+ *tests-sort-reverse* 1))) + *tests-sort-reverse*) + +(define *tests-sort-reverse* + (let ((t-sort (assoc (configf:lookup (megatest:area-configdat *area-dat*) "dashboard" "testsort") *tests-sort-type-index*))) + (if t-sort + (cadr t-sort) + 3))) + +(define (get-curr-sort) + (vector-ref *tests-sort-options* *tests-sort-reverse*)) + +(define *hide-empty-runs* #f) +(define *hide-not-hide* #t) ;; toggle for hide/not hide +(define *hide-not-hide-button* #f) +(define *hide-not-hide-tabs* #f) + +(define *current-tab-number* 0) +(define *updaters* (make-hash-table)) + +(debug:setup) + +(define uidat #f) + +(define-inline (dboard:uidat-get-keycol vec)(vector-ref vec 0)) +(define-inline (dboard:uidat-get-lftcol vec)(vector-ref vec 1)) +(define-inline (dboard:uidat-get-header vec)(vector-ref vec 2)) +(define-inline (dboard:uidat-get-runsvec vec)(vector-ref vec 3)) + +(if (get-environment-variable "MT_RUN_AREA_HOME")(change-directory (get-environment-variable "MT_RUN_AREA_HOME"))) + +(define (message-window msg) + (iup:show + (iup:dialog + (iup:vbox + (iup:label msg #:margin "40x40"))))) + +(define (iuplistbox-fill-list lb items #!key (selected-item #f)) + (let ((i 1)) + (for-each (lambda (item) + (iup:attribute-set! lb (number->string i) item) + (if selected-item + (if (equal? selected-item item) + (iup:attribute-set! lb "VALUE" i))) ;; (number->string i)))) + (set! i (+ i 1))) + items) + ;; (iup:attribute-set! lb "VALUE" (if selected-item selected-item "")) + i)) + +(define (pad-list l n)(append l (make-list (- n (length l))))) + +(define (colors-similar? color1 color2) + (let* ((c1 (map string->number (string-split color1))) + (c2 (map string->number (string-split color2))) + (delta (map (lambda (a b)(abs (- a b))) c1 c2))) + (null? (filter (lambda (x)(> x 3)) delta)))) + +;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") ) +(define (update-rundat runnamepatt numruns testnamepatt keypatts) + (let* ((referenced-run-ids '()) + (allruns (db:get-runs *dbstruct-local* runnamepatt numruns ;; (+ numruns 1) ;; (/ numruns 2)) + *start-run-offset* keypatts)) + (header (db:get-header allruns)) + (runs (db:get-rows allruns)) + (result '()) + (maxtests 0) + (states (hash-table-keys *state-ignore-hash*)) + (statuses (hash-table-keys *status-ignore-hash*)) + (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))) + ;; + ;; trim runs to only those that are changing often here + ;; + (for-each (lambda (run) + (let* ((run-id (db:get-value-by-header run header "id")) + (tests (db:get-tests-for-run *dbstruct-local* run-id testnamepatt states statuses + #f #f + *hide-not-hide* + sort-by + sort-order + 'shortlist)) + ;; NOTE: bubble-up also sets the global *all-item-test-names* + ;; (tests (bubble-up tmptests priority: bubble-type)) + (key-vals (db:get-key-vals *dbstruct-local* run-id))) + ;; 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) + ;; Not sure this is needed? + (set! referenced-run-ids (cons run-id referenced-run-ids)) + (if (> (length tests) maxtests) + (set! maxtests (length tests))) + (if (or (not *hide-empty-runs*) ;; this reduces the data burden when set + (not (null? tests))) + (let ((dstruct (vector run tests key-vals))) + ;; + ;; compare the tests with the tests in *allruns-by-id* same run-id + ;; if different then increment value in *runchangerate* + ;; + (hash-table-set! *allruns-by-id* run-id dstruct) + (set! result (cons dstruct result)))))) + runs) + + (set! *header* header) + (set! *allruns* result) + (debug:print-info 6 "*allruns* has " (length *allruns*) " runs") + maxtests)) + +(define *collapsed* (make-hash-table)) +; (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)) + (if (hash-table-ref/default *collapsed* basetestname #f) + (begin + ;(iup:attribute-set! btn "FGCOLOR" "0 0 0") + (hash-table-delete! *collapsed* basetestname)) + (begin + ;(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 "(")) + (res (vector "" ""))) + (vector-set! res 0 (car splst)) + (if (> (length splst) 1) + (vector-set! res 1 (car (string-split (cadr splst) ")")))) + res)) + lst)) + +(define (collapse-rows inlst) + (let* ((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)) + (newlst (filter (lambda (x) + (let* ((tparts (string-split x "(")) + (basetname (if (null? tparts) x (car tparts)))) + ;(print "x " x " tparts: " tparts " basetname: " basetname) + (cond + ((string-match blank-line-rx x) #f) + ((equal? x basetname) #t) + ((hash-table-ref/default *collapsed* basetname #f) + ;(print "Removing " basetname " from items") + #f) + (else #t)))) + inlst)) + (vlst (run-item-name->vectors newlst)) + (vlst2 (bubble-up vlst priority: bubble-type))) + (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)) + (maxn (- numcols 1)) + (allvals (make-vector numcols ""))) + (for-each (lambda (name) + (if (<= rown maxn) + (vector-set! allvals rown name)) ;) + (set! rown (+ 1 rown))) + *alltestnamelst*) + (let loop ((i 0)) + (let* ((lbl (vector-ref lftcol i)) + (keyval (vector-ref keycol i)) + (oldval (iup:attribute lbl "TITLE")) + (newval (vector-ref allvals i))) + (if (not (equal? oldval newval)) + (let ((munged-val (let ((parts (string-split newval "("))) + (if (> (length parts) 1)(conc " " (car (string-split (cadr parts) ")"))) newval)))) + (vector-set! keycol i newval) + (iup:attribute-set! lbl "TITLE" munged-val))) + (iup:attribute-set! lbl "FGCOLOR" (if (hash-table-ref/default *collapsed* newval #f) "0 112 112" "0 0 0")) + (if (< i maxn) + (loop (+ i 1))))))) + +;; +(define (get-itemized-tests test-dats) + (let ((tnames '())) + (for-each (lambda (tdat) + (let ((tname (vector-ref tdat 0)) ;; (db:test-get-testname tdat)) + (ipath (vector-ref tdat 1))) ;; (db:test-get-item-path tdat))) + (if (not (equal? ipath "")) + (if (and (list? tnames) + (string? tname) + (not (member tname tnames))) + (set! tnames (append tnames (list tname))))))) + test-dats) + tnames)) + +;; Bubble up the top tests to above the items, collect the items underneath +;; all while preserving the sort order from the SQL query as best as possible. +;; +(define (bubble-up test-dats #!key (priority 'itempath)) + (if (null? test-dats) + test-dats + (begin + (let* ((tnames '()) ;; list of names used to reserve order + (tests (make-hash-table)) ;; hash of lists, used to build as we go + (itemized (get-itemized-tests test-dats))) + (for-each + (lambda (testdat) + (let* ((tname (vector-ref testdat 0)) ;; db:test-get-testname testdat)) + (ipath (vector-ref testdat 1))) ;; db:test-get-item-path testdat))) + ;; (seen (hash-table-ref/default tests tname #f))) + (if (not (member tname tnames)) + (if (or (and (eq? priority 'itempath) + (not (equal? ipath ""))) + (and (eq? priority 'testname) + (equal? ipath "")) + (not (member tname itemized))) + (set! tnames (append tnames (list tname))))) + (if (equal? ipath "") + ;; This a top level, prepend it + (hash-table-set! tests tname (cons testdat (hash-table-ref/default tests tname '()))) + ;; This is item, append it + (hash-table-set! tests tname (append (hash-table-ref/default tests tname '())(list testdat)))))) + test-dats) + ;; Set all tests with items + (set! *all-item-test-names* (append (if (null? tnames) + '() + (filter (lambda (tname) + (let ((tlst (hash-table-ref tests tname))) + (and (list tlst) + (> (length tlst) 1)))) + tnames)) + *all-item-test-names*)) + (let loop ((hed (car tnames)) + (tal (cdr tnames)) + (res '())) + (let ((newres (append res (hash-table-ref tests hed)))) + (if (null? tal) + newres + (loop (car tal)(cdr tal) newres)))))))) + +(define (update-buttons uidat numruns numtests) + (let* ((runs (if (> (length *allruns*) numruns) + (take-right *allruns* numruns) + (pad-list *allruns* numruns))) + (lftcol (dboard:uidat-get-lftcol uidat)) + (tableheader (dboard:uidat-get-header uidat)) + (table (dboard:uidat-get-runsvec uidat)) + (coln 0)) + (set! *alltestnamelst* '()) + ;; create a concise list of test names + (for-each + (lambda (rundat) + (if (vector? rundat) + (let* ((testdat (vector-ref rundat 1)) + (testnames (map test:test-get-fullname testdat))) + (if (not (and *hide-empty-runs* + (null? testnames))) + (for-each (lambda (testname) + (if (not (member testname *alltestnamelst*)) + (begin + (set! *alltestnamelst* (append *alltestnamelst* (list testname)))))) + testnames))))) + runs) + + (set! *alltestnamelst* (collapse-rows *alltestnamelst*)) ;;; argh. please clean up this sillyness + (set! *alltestnamelst* (let ((xl (if (> (length *alltestnamelst*) *start-test-offset*) + (drop *alltestnamelst* *start-test-offset*) + '()))) + (append xl (make-list (- *num-tests* (length xl)) "")))) + (update-labels uidat) + (for-each + (lambda (rundat) + (if (not rundat) ;; handle padded runs + ;; ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration + (set! rundat (vector (make-vector 20 #f) '() (map (lambda (x) "") *keys*))));; 3))) + (let* ((run (vector-ref rundat 0)) + (testsdat (vector-ref rundat 1)) + (key-val-dat (vector-ref rundat 2)) + (run-id (db:get-value-by-header run *header* "id")) + (key-vals (append key-val-dat + (list (let ((x (db:get-value-by-header run *header* "runname"))) + (if x x ""))))) + (run-key (string-intersperse key-vals "\n"))) + + ;; fill in the run header key values + (let ((rown 0) + (headercol (vector-ref tableheader coln))) + (for-each (lambda (kval) + (let* ((labl (vector-ref headercol rown))) + (if (not (equal? kval (iup:attribute labl "TITLE"))) + (iup:attribute-set! (vector-ref headercol rown) "TITLE" kval)) + (set! rown (+ rown 1)))) + key-vals)) + + ;; For this run now fill in the buttons for each test + (let ((rown 0) + (columndat (vector-ref table coln))) + (for-each + (lambda (testname) + (let ((buttondat (hash-table-ref/default *buttondat* (mkstr coln rown) #f))) + (if buttondat + (let* ((test (let ((matching (filter + (lambda (x)(equal? (test:test-get-fullname x) testname)) + testsdat))) + (if (null? matching) + (vector -1 -1 "" "" "" 0 "" "" 0 "" "" "" 0 "" "") + (car matching)))) + (testname (db:test-get-testname test)) + (itempath (db:test-get-item-path test)) + (testfullname (test:test-get-fullname test)) + (teststatus (db:test-get-status test)) + (teststate (db:test-get-state test)) + ;;(teststart (db:test-get-event_time test)) + ;;(runtime (db:test-get-run_duration test)) + (buttontxt (cond + ((member teststate '("COMPLETED" "ARCHIVED")) teststatus) + ((and (equal? teststate "NOT_STARTED") + (member teststatus '("ZERO_ITEMS" "BLOCKED" "PREQ_FAIL" "PREQ_DISCARDED" "TIMED_OUT" "KEEP_TRYING" "TEN_STRIKES"))) + teststatus) + (else + teststate))) + (button (vector-ref columndat rown)) + (color (car (gutils:get-color-for-state-status teststate teststatus))) + (curr-color (vector-ref buttondat 1)) ;; (iup:attribute button "BGCOLOR")) + (curr-title (vector-ref buttondat 2))) ;; (iup:attribute button "TITLE"))) + (if (not (equal? curr-color color)) + (iup:attribute-set! button "BGCOLOR" color)) + (if (not (equal? curr-title buttontxt)) + (iup:attribute-set! button "TITLE" buttontxt)) + (vector-set! buttondat 0 run-id) + (vector-set! buttondat 1 color) + (vector-set! buttondat 2 buttontxt) + (vector-set! buttondat 3 test) + (vector-set! buttondat 4 run-key))) + (set! rown (+ rown 1)))) + *alltestnamelst*)) + (set! coln (+ coln 1)))) + runs))) + +(define (mkstr . x) + (string-intersperse (map conc x) ",")) + +(define (set-bg-on-filter) + (let ((search-changed (not (null? (filter (lambda (key) + (not (equal? (hash-table-ref *searchpatts* key) "%"))) + (hash-table-keys *searchpatts*))))) + (state-changed (not (null? (hash-table-keys *state-ignore-hash*)))) + (status-changed (not (null? (hash-table-keys *status-ignore-hash*))))) + (iup:attribute-set! *hide-not-hide-tabs* "BGCOLOR" + (if (or search-changed + state-changed + status-changed) + "190 180 190" + "190 190 190" + )))) + +(define (update-search x val) + (hash-table-set! *searchpatts* x val) + (set-bg-on-filter)) + +(define (mark-for-update) + (set! *last-db-update-time* 0) + (set! *delayed-update* 1)) + +;;====================================================================== +;; R U N C O N T R O L +;;====================================================================== + +;; target populating logic +;; +;; lb = +;; field = target field name for this dropdown +;; referent-vals = selected value in the left dropdown +;; targets = list of targets to use to build the dropdown +;; +;; each node is chained: key1 -> key2 -> key3 +;; +;; must select values from only apropriate targets +;; a b c +;; a d e +;; a b f +;; a/b => c f +;; +(define (dashboard:populate-target-dropdown lb referent-vals targets) ;; runconf-targs) + ;; is the current value in the new list? choose new default if not + (let* ((remvalues (map (lambda (row) + (common:list-is-sublist referent-vals (vector->list row))) + targets)) + (values (delete-duplicates (map car (filter list? remvalues)))) + (sel-valnum (iup:attribute lb "VALUE")) + (sel-val (iup:attribute lb sel-valnum)) + (val-num 1)) + ;; first check if the current value is in the new list, otherwise replace with + ;; first value from values + (iup:attribute-set! lb "REMOVEITEM" "ALL") + (for-each (lambda (val) + ;; (iup:attribute-set! lb "APPENDITEM" val) + (iup:attribute-set! lb (conc val-num) val) + (if (equal? sel-val val) + (iup:attribute-set! lb "VALUE" val-num)) + (set! val-num (+ val-num 1))) + values) + (let ((val (iup:attribute lb "VALUE"))) + (if val + val + (if (not (null? values)) + (let ((newval (car values))) + (iup:attribute-set! lb "VALUE" newval) + newval)))))) + +(define (dashboard:update-target-selector key-lbs #!key (action-proc #f)) + (let* ((runconf-targs (common:get-runconfig-targets)) + (db-target-dat (db:get-targets *dbstruct-local*)) + (header (vector-ref db-target-dat 0)) + (db-targets (vector-ref db-target-dat 1)) + (all-targets (append db-targets + (map (lambda (x) + (list->vector + (take (append (string-split x "/") + (make-list (length header) "na")) + (length header)))) + runconf-targs))) + (key-listboxes (if key-lbs key-lbs (make-list (length header) #f)))) + (let loop ((key (car header)) + (remkeys (cdr header)) + (refvals '()) + (indx 0) + (lbs '())) + (let* ((lb (let ((lb (list-ref key-listboxes indx))) + (if lb + lb + (iup:listbox + #:size "45x50" + #:fontsize "10" + #:expand "YES" ;; "VERTICAL" + ;; #:dropdown "YES" + #:editbox "YES" + #:action (lambda (obj a b c) + (action-proc)) + #:caret_cb (lambda (obj a b c)(action-proc)) + )))) + ;; loop though all the targets and build the list for this dropdown + (selected-value (dashboard:populate-target-dropdown lb refvals all-targets))) + (if (null? remkeys) + ;; return a list of the listbox items and an iup:hbox with the labels and listboxes + (let ((listboxes (append lbs (list lb)))) + (list listboxes + (map (lambda (htxt lb) + (iup:vbox + (iup:label htxt) + lb)) + header + listboxes))) + (loop (car remkeys) + (cdr remkeys) + (append refvals (list selected-value)) + (+ indx 1) + (append lbs (list lb)))))))) + +;; Make a vertical list of toggles using items, when toggled call proc with the conc'd string +;; interspersed with commas +;; +(define (dashboard:text-list-toggle-box items proc) + (let ((alltgls (make-hash-table))) + (apply iup:vbox + (map (lambda (item) + (iup:toggle + item + #:expand "YES" + #:action (lambda (obj tstate) + (if (eq? tstate 0) + (hash-table-delete! alltgls item) + (hash-table-set! alltgls item #t)) + (let ((all (hash-table-keys alltgls))) + (proc all))))) + items)))) + +;; Extract the various bits of data from *data* and create the command line equivalent that will be displayed +;; +(define (dashboard:update-run-command) + (let* ((cmd-tb (dboard:data-get-command-tb *data*)) + (cmd (dboard:data-get-command *data*)) + (test-patt (let ((tp (dboard:data-get-test-patts *data*))) + (if (equal? tp "") "%" tp))) + (states (dboard:data-get-states *data*)) + (statuses (dboard:data-get-statuses *data*)) + (target (let ((targ-list (dboard:data-get-target *data*))) + (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 ",")))) + (statuses-str (if (or (not statuses) + (null? statuses)) + "" + (conc " :status " (string-intersperse statuses ",")))) + (full-cmd "megatest")) + (case (string->symbol cmd) + ((runtests) + (set! full-cmd (conc full-cmd + " -runtests " + test-patt + " -target " + target + " -runname " + run-name + ))) + ((remove-runs) + (set! full-cmd (conc full-cmd + " -remove-runs -runname " + run-name + " -target " + target + " -testpatt " + test-patt + states-str + statuses-str + ))) + (else (set! full-cmd " no valid command "))) + (iup:attribute-set! cmd-tb "VALUE" full-cmd))) + +;; Display the tests as rows of boxes on the test/task pane +;; +(define (dashboard:draw-tests cnv xadj yadj tests-draw-state sorted-testnames) + (canvas-clear! cnv) + (canvas-font-set! cnv "Helvetica, -10") + (let-values (((sizex sizey sizexmm sizeymm) (canvas-size cnv)) + ((originx originy) (canvas-origin cnv))) + ;; (print "originx: " originx " originy: " originy) + ;; (canvas-origin-set! cnv 0 (- (/ sizey 2))) + (if (hash-table-ref/default tests-draw-state 'first-time #t) + (begin + (hash-table-set! tests-draw-state 'first-time #f) + (hash-table-set! tests-draw-state 'scalef 8) + (hash-table-set! tests-draw-state 'tests-info (make-hash-table)) + (hash-table-set! tests-draw-state 'selected-tests (make-hash-table)) + ;; set these + (hash-table-set! tests-draw-state 'test-browse-xoffset 20) ;; (- 0 (* (/ sizex 2) (* 8 xadj)))) + (hash-table-set! tests-draw-state 'test-browse-yoffset 20) ;; (- 0 (* (/ sizey 2) (* 8 (- 1 yadj))))))) + (dcommon:initial-draw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames)) + (dcommon:redraw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames)) + )) + +;;====================================================================== +;; R U N C O N T R O L S +;;====================================================================== +;; +;; A gui for launching tests +;; +(define (dashboard:run-controls) + (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") + (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))))) + (dboard:data-set-target! *data* targ) + (if updater-for-runs (updater-for-runs)) + (dashboard:update-run-command)))) + (tests-draw-state (make-hash-table)) ;; use for keeping state of the test canvas + (test-patterns-textbox #f)) + (hash-table-set! tests-draw-state 'first-time #t) + (hash-table-set! tests-draw-state 'scalef 8) + (tests:get-full-data test-names test-records '() all-tests-registry) + (set! sorted-testnames (tests:sort-by-priority-and-waiton test-records)) + + ;; refer to *keys*, *dbkeys* for keys + (iup:vbox + ;; The command line display/exectution control + (iup:frame + #:title "Command to be exectuted" + (iup:hbox + (iup:label "Run on" #:size "40x") + (iup:radio + (iup:hbox + (iup:toggle "Local" #:size "40x") + (iup:toggle "Server" #:size "40x"))) + (let ((tb (iup:textbox + #:value "megatest " + #:expand "HORIZONTAL" + #:readonly "YES" + #:font "Courier New, -12" + ))) + (dboard:data-set-command-tb! *data* tb) + tb) + (iup:button "Execute" #:size "50x" + #:action (lambda (obj) + (let ((cmd (conc "xterm -geometry 180x20 -e \"" + (iup:attribute (dboard:data-get-command-tb *data*) "VALUE") + ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &"))) + (system cmd)))))) + + (iup:split + #:orientation "HORIZONTAL" + + (iup:split + #:value 300 + + ;; Target, testpatt, state and status input boxes + ;; + (iup:vbox + ;; 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")) + (lb (iup:listbox #:expand "HORIZONTAL" + #:dropdown "YES" + #:action (lambda (obj val index lbstate) + ;; (print obj " " val " " index " " lbstate) + (dboard:data-set-command! *data* val) + (dashboard:update-run-command)))) + (default-cmd (car cmds-list))) + (iuplistbox-fill-list lb cmds-list selected-item: default-cmd) + (dboard:data-set-command! *data* default-cmd) + lb))) + + (iup:frame + #:title "Runname" + (let* ((default-run-name (seconds->work-week/day (current-seconds))) + (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)) + (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)))) + (refresh-runs-list (lambda () + (let* ((target (dboard:data-get-target-string *data*)) + (runs-for-targ (db:get-runs-by-patt *dbstruct-local* *keys* "%" target #f #f)) + (runs-header (vector-ref runs-for-targ 0)) + (runs-dat (vector-ref runs-for-targ 1)) + (run-names (cons default-run-name + (map (lambda (x) + (db:get-value-by-header x runs-header "runname")) + runs-dat)))) + (iup:attribute-set! lb "REMOVEITEM" "ALL") + (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 + tb + lb))) + + (iup:frame + #:title "SELECTORS" + (iup:vbox + ;; Text box for test patterns + (iup:frame + #:title "Test patterns (one per line)" + (let ((tb (iup:textbox #:action (lambda (val a b) + (dboard:data-set-test-patts! + *data* + (dboard:lines->test-patt b)) + (dashboard:update-run-command)) + #:value (dboard:test-patt->lines + (dboard:data-get-test-patts *data*)) + #:expand "YES" + #:size "x50" + #:multiline "YES"))) + (set! test-patterns-textbox tb) + tb)) + (iup:frame + #:title "Target" + ;; Target selectors + (apply iup:hbox + (let* ((dat (dashboard:update-target-selector key-listboxes action-proc: update-keyvals)) + (key-lb (car dat)) + (combos (cadr dat))) + (set! key-listboxes key-lb) + combos))) + (iup:hbox + ;; Text box for STATES + (iup:frame + #:title "States" + (dashboard:text-list-toggle-box + ;; Move these definitions to common and find the other useages and replace! + (map cadr *common:std-states*) ;; '("COMPLETED" "RUNNING" "STUCK" "INCOMPLETE" "LAUNCHED" "REMOTEHOSTSTART" "KILLED") + (lambda (all) + (dboard:data-set-states! *data* all) + (dashboard:update-run-command)))) + ;; Text box for STATES + (iup:frame + #:title "Statuses" + (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) + (the-cnv #f) + (canvas-obj + (iup:canvas #:action (make-canvas-action + (lambda (cnv xadj yadj) + (if (not updater) + (set! updater (lambda (xadj yadj) + ;; (print "cnv: " cnv " xadj: " xadj " yadj: " yadj) + (dashboard:draw-tests cnv xadj yadj tests-draw-state sorted-testnames) + (set! last-xadj xadj) + (set! last-yadj yadj)))) + (updater xadj yadj) + (set! the-cnv cnv) + )) + ;; Following doesn't work + #:wheel-cb (lambda (obj step x y dir) ;; dir is 4 for up and 5 for down. I think. + (let ((xadj last-xadj) + (yadj (+ last-yadj (if (> step 0) + -0.01 + 0.01)))) + ;; (print "step: " step " x: " x " y: " y " dir: \"" dir "\"") + ;; (print "the-cnv: " the-cnv " obj: " obj " xadj: " xadj " yadj: " yadj " dir: " dir) + (if the-cnv + (dashboard:draw-tests the-cnv xadj yadj tests-draw-state sorted-testnames)) + (set! last-xadj xadj) + (set! last-yadj yadj) + )) + ;; #:size "50x50" + #:expand "YES" + #:scrollbar "YES" + #:posx "0.5" + #:posy "0.5" + #:button-cb (lambda (obj btn pressed x y status) + ;; (print "obj: " obj) + (let ((tests-info (hash-table-ref tests-draw-state 'tests-info)) + (selected-tests (hash-table-ref tests-draw-state 'selected-tests))) + ;; (print "x\ty\tllx\tlly\turx\tury") + (for-each (lambda (test-name) + (let* ((rec-coords (hash-table-ref tests-info test-name)) + (llx (list-ref rec-coords 0)) + (urx (list-ref rec-coords 1)) + (lly (list-ref rec-coords 2)) + (ury (list-ref rec-coords 3))) + ;; (print x "\t" y "\t" llx "\t" lly "\t" urx "\t" ury "\t" test-name " " + (if (and (eq? pressed 1) + (> x llx) + (> y lly) + (< x urx) + (< y ury)) + (let ((patterns (string-split (iup:attribute test-patterns-textbox "VALUE")))) + (let* ((selected (not (member test-name patterns))) + (newpatt-list (if selected + (cons test-name patterns) + (delete test-name patterns))) + (newpatt (string-intersperse newpatt-list "\n"))) + ;; (if cnv-obj + ;; (dashboard:draw-tests cnv-obj 0 0 tests-draw-state sorted-testnames)) + (iup:attribute-set! obj "REDRAW" "ALL") + (hash-table-set! selected-tests test-name selected) + (iup:attribute-set! test-patterns-textbox "VALUE" newpatt) + (dboard:data-set-test-patts! *data* (dboard:lines->test-patt newpatt)) + (dashboard:update-run-command) + (if updater (updater last-xadj last-yadj))))))) + (hash-table-keys tests-info))))))) + canvas-obj))) + ;; (print "obj: " obj " btn: " btn " pressed: " pressed " x: " x " y: " y " status: " status)) + + (iup:frame + #:title "Logs" ;; To be replaced with tabs + (let ((logs-tb (iup:textbox #:expand "YES" + #:multiline "YES"))) + (dboard:data-set-logs-textbox! *data* logs-tb) + logs-tb)))))) + + +;; (trace dashboard:populate-target-dropdown +;; common:list-is-sublist) +;; +;; ;; key1 key2 key3 ... +;; ;; target entry (wild cards allowed) +;; +;; ;; The action +;; (iup:hbox +;; ;; label Action | action selector +;; )) +;; ;; Test/items selector +;; (iup:hbox +;; ;; tests +;; ;; items +;; )) +;; ;; The command line +;; (iup:hbox +;; ;; commandline entry +;; ;; GO button +;; ) +;; ;; The command log monitor +;; (iup:tabs +;; ;; log monitor +;; ))) + +;;====================================================================== +;; S U M M A R Y +;;====================================================================== +;; +;; General info about the run(s) and megatest area +(define (dashboard:summary db area-dat) + (let* ((toppath (megatest:area-path area-dat)) + (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" + (iup:vbox + (iup:hbox + (iup:label "Area Path") + (iup:textbox #:value toppath #:expand "HORIZONTAL")) + (iup:hbox + (dcommon:keys-matrix rawconfig) + (dcommon:general-info) + ))) + (iup:frame + #:title "Server" + (dcommon:servers-table))) + (iup:frame + #:title "Megatest config settings" + (iup:hbox + (dcommon:section-matrix rawconfig "setup" "Varname" "Value") + (iup:vbox + (dcommon:section-matrix rawconfig "server" "Varname" "Value") + ;; (iup:frame + ;; #:title "Disks Areas" + (dcommon:section-matrix rawconfig "disks" "Disk area" "Path")))) + (iup:frame + #:title "Run statistics" + (dcommon:run-stats db))))) + +;;====================================================================== +;; R U N +;;====================================================================== +;; +;; display and manage a single run at a time + +(define (tree-path->run-id path) + (if (not (null? path)) + (hash-table-ref/default (dboard:data-get-path-run-ids *data*) path #f) + #f)) + +(define dashboard:update-run-summary-tab #f) + +;; (define (tests window-id) +(define (dashboard:one-run db) + (let* ((tb (iup:treebox + #:value 0 + #:name "Runs" + #:expand "YES" + #:addexpanded "NO" + #:selection-cb + (lambda (obj id state) + ;; (print "obj: " obj ", id: " id ", state: " state) + (let* ((run-path (tree:node->path obj id)) + (run-id (tree-path->run-id (cdr run-path)))) + (if run-id + (begin + (dboard:data-set-curr-run-id! *data* run-id) + (dashboard:update-run-summary-tab))) + ;; (print "path: " (tree:node->path obj id) " run-id: " run-id) + )))) + (cell-lookup (make-hash-table)) + (run-matrix (iup:matrix + #:expand "YES" + #:click-cb + (lambda (obj lin col status) + (let* ((toolpath (car (argv))) + (key (conc lin ":" col)) + (test-id (hash-table-ref/default cell-lookup key -1)) + (cmd (conc toolpath " -test " (dboard:data-get-curr-run-id *data*) "," test-id "&"))) + (system cmd))))) + (updater (lambda () + (let* ((runs-dat (db:get-runs-by-patt db *keys* "%" #f #f #f)) + (runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records + (run-id (dboard:data-get-curr-run-id *data*)) + (tests-dat (let ((tdat (db:get-tests-for-run db run-id + (hash-table-ref/default *searchpatts* "test-name" "%/%") + (hash-table-keys *state-ignore-hash*) ;; '() + (hash-table-keys *status-ignore-hash*) ;; '() + #f #f + *hide-not-hide* + #f #f + "id,testname,item_path,state,status"))) ;; get 'em all + (sort tdat (lambda (a b) + (let* ((aval (vector-ref a 2)) + (bval (vector-ref b 2)) + (anum (string->number aval)) + (bnum (string->number bval))) + (if (and anum bnum) + (< anum bnum) + (string<= aval bval))))))) + (tests-mindat (dcommon:minimize-test-data tests-dat)) + (indices (common:sparse-list-generate-index tests-mindat)) ;; proc: set-cell)) + (row-indices (cadr indices)) + (col-indices (car indices)) + (max-row (if (null? row-indices) 1 (common:max (map cadr row-indices)))) + (max-col (if (null? col-indices) 1 (common:max (map cadr col-indices)))) + (max-visible (max (- *num-tests* 15) 3)) ;; *num-tests* is proportional to the size of the window + (numrows 1) + (numcols 1) + (changed #f) + (runs-hash (let ((ht (make-hash-table))) + (for-each (lambda (run) + (hash-table-set! ht (db:get-value-by-header run runs-header "id") run)) + (vector-ref runs-dat 1)) + ht)) + (run-ids (sort (filter number? (hash-table-keys runs-hash)) + (lambda (a b) + (let* ((record-a (hash-table-ref runs-hash a)) + (record-b (hash-table-ref runs-hash b)) + (time-a (db:get-value-by-header record-a runs-header "event_time")) + (time-b (db:get-value-by-header record-b runs-header "event_time"))) + (< time-a time-b)))))) + + ;; (iup:attribute-set! tb "VALUE" "0") + ;; (iup:attribute-set! tb "NAME" "Runs") + ;; Update the runs tree + (for-each (lambda (run-id) + (let* ((run-record (hash-table-ref/default runs-hash run-id #f)) + (key-vals (map (lambda (key)(db:get-value-by-header run-record runs-header key)) + *keys*)) + (run-name (db:get-value-by-header run-record runs-header "runname")) + (col-name (conc (string-intersperse key-vals "\n") "\n" run-name)) + (run-path (append key-vals (list run-name))) + (existing (tree:find-node tb run-path))) + (if (not (hash-table-ref/default (dboard:data-get-path-run-ids *data*) run-path #f)) + (begin + (hash-table-set! (dboard:data-get-run-keys *data*) run-id run-path) + ;; (iup:attribute-set! (dboard:data-get-runs-matrix *data*) + ;; (conc rownum ":" colnum) col-name) + ;; (hash-table-set! runid-to-col run-id (list colnum run-record)) + ;; Here we update the tests treebox and tree keys + (tree:add-node tb "Runs" run-path ;; (append key-vals (list run-name)) + userdata: (conc "run-id: " run-id)) + (hash-table-set! (dboard:data-get-path-run-ids *data*) run-path run-id) + ;; (set! colnum (+ colnum 1)) + )))) + run-ids) + (iup:attribute-set! run-matrix "CLEARVALUE" "ALL") ;; NOTE: Was CONTENTS + (iup:attribute-set! run-matrix "CLEARATTRIB" "CONTENTS") + (iup:attribute-set! run-matrix "RESIZEMATRIX" "YES") + (iup:attribute-set! run-matrix "NUMCOL" max-col ) + (iup:attribute-set! run-matrix "NUMLIN" (if (< max-row max-visible) max-visible max-row)) ;; min of 20 + ;; (iup:attribute-set! run-matrix "NUMCOL_VISIBLE" max-col) + ;; (iup:attribute-set! run-matrix "NUMLIN_VISIBLE" (if (> max-row max-visible) max-visible max-row)) + + ;; Row labels + (for-each (lambda (ind) + (let* ((name (car ind)) + (num (cadr ind)) + (key (conc num ":0"))) + (if (not (equal? (iup:attribute run-matrix key) name)) + (begin + (set! changed #t) + (iup:attribute-set! run-matrix key name))))) + row-indices) + + ;; Cell contents + (for-each (lambda (entry) + (let* ((row-name (cadr entry)) + (col-name (car entry)) + (valuedat (caddr entry)) + (test-id (list-ref valuedat 0)) + (test-name row-name) ;; (list-ref valuedat 1)) + (item-path col-name) ;; (list-ref valuedat 2)) + (state (list-ref valuedat 1)) + (status (list-ref valuedat 2)) + (value (gutils:get-color-for-state-status state status)) + (row-num (cadr (assoc row-name row-indices))) + (col-num (cadr (assoc col-name col-indices))) + (key (conc row-num ":" col-num))) + (hash-table-set! cell-lookup key test-id) + (if (not (equal? (iup:attribute run-matrix key) (cadr value))) + (begin + (set! changed #t) + (iup:attribute-set! run-matrix key (cadr value)) + (iup:attribute-set! run-matrix (conc "BGCOLOR" key) (car value)))))) + tests-mindat) + + ;; Col labels - do after setting Cell contents so they are accounted for in the size calc. + + (for-each (lambda (ind) + (let* ((name (car ind)) + (num (cadr ind)) + (key (conc "0:" num))) + (if (not (equal? (iup:attribute run-matrix key) name)) + (begin + (set! changed #t) + (iup:attribute-set! run-matrix key name) + (iup:attribute-set! run-matrix "FITTOTEXT" (conc "C" num)))))) + col-indices) + (if changed (iup:attribute-set! run-matrix "REDRAW" "ALL")))))) + + (set! dashboard:update-run-summary-tab updater) + (dboard:data-set-runs-tree! *data* tb) + (iup:split + tb + run-matrix))) + +;;====================================================================== +;; R U N S +;;====================================================================== + +(define (make-dashboard-buttons db nruns ntests keynames area-dat) + (let* ((toppath (megatest:area-path area-dat)) + (nkeys (length keynames)) + (runsvec (make-vector nruns)) + (header (make-vector nruns)) + (lftcol (make-vector ntests)) + (keycol (make-vector ntests)) + (controls '()) + (lftlst '()) + (hdrlst '()) + (bdylst '()) + (result '()) + (i 0)) + ;; controls (along bottom) + (set! controls + (iup:hbox + (iup:vbox + (iup:frame + #:title "filter test and items" + (iup:hbox + (iup:textbox #:size "120x15" #:fontsize "10" #:value "%" + #:action (lambda (obj unk val) + (mark-for-update) + (update-search "test-name" val))) + ;;(iup:textbox #:size "60x15" #:fontsize "10" #:value "%" + ;; #:action (lambda (obj unk val) + ;; (mark-for-update) + ;; (update-search "item-name" val)) + )) + (iup:vbox + (iup:hbox + (let* ((cmds-list '("+testname" "-testname" "+event_time" "-event_time" "+statestatus" "-statestatus")) + (lb (iup:listbox #:expand "HORIZONTAL" + #:dropdown "YES" + #:action (lambda (obj val index lbstate) + (set! *tests-sort-reverse* index) + (mark-for-update)))) + (default-cmd (car (list-ref *tests-sort-type-index* *tests-sort-reverse*)))) + (iuplistbox-fill-list lb cmds-list selected-item: default-cmd) + (mark-for-update) + ;; (set! *tests-sort-reverse* *tests-sort-reverse*0) + lb) + ;; (iup:button "Sort -t" #:action (lambda (obj) + ;; (next-sort-option) + ;; (iup:attribute-set! obj "TITLE" (vector-ref (vector-ref *tests-sort-options* *tests-sort-reverse*) 0)) + ;; (mark-for-update))) + (iup:button "HideEmpty" #:action (lambda (obj) + (set! *hide-empty-runs* (not *hide-empty-runs*)) + (iup:attribute-set! obj "TITLE" (if *hide-empty-runs* "+HideE" "-HideE")) + (mark-for-update))) + (let ((hideit (iup:button "HideTests" #:action (lambda (obj) + (set! *hide-not-hide* (not *hide-not-hide*)) + (iup:attribute-set! obj "TITLE" (if *hide-not-hide* "HideTests" "NotHide")) + (mark-for-update))))) + (set! *hide-not-hide-button* hideit) + hideit)) + (iup:hbox + (iup:button "Quit" #:action (lambda (obj) + ;; (if *dbstruct-local* (db:close-all *dbstruct-local*)) + (exit))) + (iup:button "Refresh" #:action (lambda (obj) + (mark-for-update))) + (iup:button "Collapse" #:action (lambda (obj) + (let ((myname (iup:attribute obj "TITLE"))) + (if (equal? myname "Collapse") + (begin + (for-each (lambda (tname) + (hash-table-set! *collapsed* tname #t)) + *all-item-test-names*) + (iup:attribute-set! obj "TITLE" "Expand")) + (begin + (for-each (lambda (tname) + (hash-table-delete! *collapsed* tname)) + (hash-table-keys *collapsed*)) + (iup:attribute-set! obj "TITLE" "Collapse")))) + (mark-for-update)))))) + (iup:frame + #:title "state/status filter" + (iup:vbox + (apply + iup:hbox + (map (lambda (status) + (iup:toggle status #:action (lambda (obj val) + (mark-for-update) + (if (eq? val 1) + (hash-table-set! *status-ignore-hash* status #t) + (hash-table-delete! *status-ignore-hash* status)) + (set-bg-on-filter)))) + (map cadr *common:std-statuses*))) ;; '("PASS" "FAIL" "WARN" "CHECK" "WAIVED" "STUCK/DEAD" "n/a" "SKIP"))) + (apply + iup:hbox + (map (lambda (state) + (iup:toggle state #:action (lambda (obj val) + (mark-for-update) + (if (eq? val 1) + (hash-table-set! *state-ignore-hash* state #t) + (hash-table-delete! *state-ignore-hash* state)) + (set-bg-on-filter)))) + (map cadr *common:std-states*))) ;; '("RUNNING" "COMPLETED" "INCOMPLETE" "LAUNCHED" "NOT_STARTED" "KILLED" "DELETED"))) + (iup:valuator #:valuechanged_cb (lambda (obj) + (let ((val (inexact->exact (round (/ (string->number (iup:attribute obj "VALUE")) 10)))) + (oldmax (string->number (iup:attribute obj "MAX"))) + (maxruns *tot-run-count*)) + (set! *start-run-offset* val) + (mark-for-update) + (debug:print 6 "*start-run-offset* " *start-run-offset* " maxruns: " maxruns ", val: " val " oldmax: " oldmax) + (iup:attribute-set! obj "MAX" (* maxruns 10)))) + #:expand "HORIZONTAL" + #:max (* 10 (length *allruns*)) + #:min 0 + #:step 0.01))) + ;(iup:button "inc rows" #:action (lambda (obj)(set! *num-tests* (+ *num-tests* 1)))) + ;(iup:button "dec rows" #:action (lambda (obj)(set! *num-tests* (if (> *num-tests* 0)(- *num-tests* 1) 0)))) + ) + ) + + ;; 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 + (map (lambda (x) + (let ((res (iup:hbox #:expand "HORIZONTAL" + (iup:label x #:size "x15" #:fontsize "10" #:expand "HORIZONTAL") + (iup:textbox #:size "x15" #:fontsize "10" #:value "%" #:expand "HORIZONTAL" + #:action (lambda (obj unk val) + (mark-for-update) + (update-search x val)))))) + (set! i (+ i 1)) + res)) + keynames))))) + (let loop ((testnum 0) + (res '())) + (cond + ((>= testnum ntests) + ;; now lftlst will be an hbox with the test keys and the test name labels + (set! lftlst (append lftlst (list (iup:hbox #:expand "HORIZONTAL" + (iup:valuator #:valuechanged_cb (lambda (obj) + (let ((val (string->number (iup:attribute obj "VALUE"))) + (oldmax (string->number (iup:attribute obj "MAX"))) + (newmax (* 10 (length *alltestnamelst*)))) + (set! *please-update-buttons* #t) + (set! *start-test-offset* (inexact->exact (round (/ val 10)))) + (debug:print 6 "*start-test-offset* " *start-test-offset* " val: " val " newmax: " newmax " oldmax: " oldmax) + (if (< val 10) + (iup:attribute-set! obj "MAX" newmax)) + )) + #:expand "VERTICAL" + #:orientation "VERTICAL" + #:min 0 + #:step 0.01) + (apply iup:vbox (reverse res))))))) + (else + (let ((labl (iup:button "" + #:flat "YES" + #:alignment "ALEFT" + ; #:image img1 + ; #:impress img2 + #:size "x15" + #:expand "HORIZONTAL" + #:fontsize "10" + #:action (lambda (obj) + (mark-for-update) + (toggle-hide testnum))))) ;; (iup:attribute obj "TITLE")))) + (vector-set! lftcol testnum labl) + (loop (+ testnum 1)(cons labl res)))))) + ;; + (let loop ((runnum 0) + (keynum 0) + (keyvec (make-vector nkeys)) + (res '())) + (cond ;; nb// no else for this approach. + ((>= runnum nruns) #f) + ((>= keynum nkeys) + (vector-set! header runnum keyvec) + (set! hdrlst (cons (apply iup:vbox (reverse res)) hdrlst)) + (loop (+ runnum 1) 0 (make-vector nkeys) '())) + (else + (let ((labl (iup:label "" #:size "60x15" #:fontsize "10" #:expand "HORIZONTAL"))) ;; #:expand "HORIZONTAL" + (vector-set! keyvec keynum labl) + (loop runnum (+ keynum 1) keyvec (cons labl res)))))) + ;; By here the hdrlst contains a list of vboxes containing nkeys labels + (let loop ((runnum 0) + (testnum 0) + (testvec (make-vector ntests)) + (res '())) + (cond + ((>= runnum nruns) #f) ;; (vector tableheader runsvec)) + ((>= testnum ntests) + (vector-set! runsvec runnum testvec) + (set! bdylst (cons (apply iup:vbox (reverse res)) bdylst)) + (loop (+ runnum 1) 0 (make-vector ntests) '())) + (else + (let* ((button-key (mkstr runnum testnum)) + (butn (iup:button "" ;; button-key + #:size "60x15" + #:expand "HORIZONTAL" + #:fontsize "10" + #:action (lambda (x) + (let* ((toolpath (car (argv))) + (buttndat (hash-table-ref *buttondat* button-key)) + (test-id (db:test-get-id (vector-ref buttndat 3))) + (run-id (db:test-get-run_id (vector-ref buttndat 3))) + (cmd (conc toolpath " -test " run-id "," test-id "&"))) + ;(print "Launching " cmd) + (system cmd)))))) + (hash-table-set! *buttondat* button-key (vector 0 "100 100 100" button-key #f #f)) + (vector-set! testvec testnum butn) + (loop runnum (+ testnum 1) testvec (cons butn res)))))) + ;; now assemble the hdrlst and bdylst and kick off the dialog + (iup:show + (iup:dialog + #:title (conc "Megatest dashboard " (current-user-name) ":" toppath) + #:menu (dcommon:main-menu) + (let* ((runs-view (iup:vbox + (apply iup:hbox + (cons (apply iup:vbox lftlst) + (list + (iup:vbox + ;; the header + (apply iup:hbox (reverse hdrlst)) + (apply iup:hbox (reverse bdylst)))))) + controls)) + (tabs (iup:tabs + #:tabchangepos-cb (lambda (obj curr prev) + (set! *please-update-buttons* #t) + (set! *current-tab-number* curr)) + (dashboard:summary db) + runs-view + (dashboard:one-run db) + (dashboard:run-controls) + ))) + ;; (set! (iup:callback tabs tabchange-cb:) (lambda (a b c)(print "SWITCHED TO TAB: " a " " b " " c))) + (iup:attribute-set! tabs "TABTITLE0" "Summary") + (iup:attribute-set! tabs "TABTITLE1" "Runs") + (iup:attribute-set! tabs "TABTITLE2" "Run Summary") + (iup:attribute-set! tabs "TABTITLE3" "Run Control") + (iup:attribute-set! tabs "BGCOLOR" "190 190 190") + (set! *hide-not-hide-tabs* tabs) + tabs))) + (vector keycol lftcol header runsvec))) + +(if (or (args:get-arg "-rows") + (get-environment-variable "DASHBOARDROWS" )) + (begin + (set! *num-tests* (string->number (or (args:get-arg "-rows") + (get-environment-variable "DASHBOARDROWS")))) + (update-rundat "%" *num-runs* "%/%" '())) + (set! *num-tests* (min (max (update-rundat "%" *num-runs* "%/%" '()) 8) 20))) + +(define *tim* (iup:timer)) +(define *ord* #f) +(iup:attribute-set! *tim* "TIME" 300) +(iup:attribute-set! *tim* "RUN" "YES") + +;; Move this stuff to db.scm? I'm not sure that is the right thing to do... +;; +(define *last-db-update-time* (file-modification-time *db-file-path*)) ;; (conc toppath "/db/main.db"))) +(define *last-recalc-ended-time* 0) + +(define (dashboard:been-changed) + (> (file-modification-time *db-file-path*) *last-db-update-time*)) + +(define (dashboard:set-db-update-time) + (set! *last-db-update-time* (file-modification-time *db-file-path*))) + +(define (dashboard:recalc modtime please-update-buttons last-db-update-time) + (or please-update-buttons + (and (> (current-milliseconds)(+ *last-recalc-ended-time* 150)) + (> modtime last-db-update-time) + (> (current-seconds)(+ last-db-update-time 1))))) + +(define *monitor-db-path* (conc *dbdir* "/monitor.db")) +(define *last-monitor-update-time* 0) + +;; Force creation of the db in case it isn't already there. +(tasks:open-db) + +(define (dashboard:get-youngest-run-db-mod-time) + (handle-exceptions + exn + (begin + (debug:print 0 "WARNING: error in accessing databases in get-youngest-run-db-mod-time: " ((condition-property-accessor 'exn 'message) exn)) + (current-seconds)) ;; something went wrong - just print an error and return current-seconds + (apply max (map (lambda (filen) + (file-modification-time filen)) + (glob (conc *dbdir* "/*.db")))))) + +(define (dashboard:run-update x) + (let* ((modtime (dashboard:get-youngest-run-db-mod-time)) ;; (file-modification-time *db-file-path*)) + (monitor-modtime (if (file-exists? *monitor-db-path*) + (file-modification-time *monitor-db-path*) + -1)) + (run-update-time (current-seconds)) + (recalc (dashboard:recalc modtime *please-update-buttons* *last-db-update-time*))) + (if (and (eq? *current-tab-number* 0) + (or (> monitor-modtime *last-monitor-update-time*) + (> (- run-update-time *last-monitor-update-time*) 5))) ;; update every 1/2 minute just in case + (begin + (set! *last-monitor-update-time* run-update-time) ;; monitor-modtime) + (if dashboard:update-servers-table (dashboard:update-servers-table)))) + (if recalc + (begin + (case *current-tab-number* + ((0) + (if dashboard:update-summary-tab (dashboard:update-summary-tab))) + ((1) ;; The runs table is active + (update-rundat (hash-table-ref/default *searchpatts* "runname" "%") *num-runs* + (hash-table-ref/default *searchpatts* "test-name" "%/%") + ;; (hash-table-ref/default *searchpatts* "item-name" "%") + (let ((res '())) + (for-each (lambda (key) + (if (not (equal? key "runname")) + (let ((val (hash-table-ref/default *searchpatts* key #f))) + (if val (set! res (cons (list key val) res)))))) + *dbkeys*) + res)) + (update-buttons uidat *num-runs* *num-tests*)) + ((2) + (dashboard:update-run-summary-tab)) + (else + (let ((updater (hash-table-ref/default *updaters* *current-tab-number* #f))) + (if updater (updater))))) + (set! *please-update-buttons* #f) + (set! *last-db-update-time* modtime) + (set! *last-update* run-update-time) + (set! *last-recalc-ended-time* (current-milliseconds)))))) + +;;====================================================================== +;; The heavy lifting starts here +;;====================================================================== + +;; ease debugging by loading ~/.dashboardrc +(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.dashboardrc"))) + (if (file-exists? debugcontrolf) + (load debugcontrolf))) + +(cond + ((args:get-arg "-run") + (let ((runid (string->number (args:get-arg "-run")))) + (if runid + (begin + (lambda (x) + (on-exit std-exit-procedure) + (examine-run *dbstruct-local* runid))) + (begin + (print "ERROR: runid is not a number " (args:get-arg "-run")) + (exit 1))))) + ((args:get-arg "-test") ;; run-id,test-id + (let* ((dat (map string->number (string-split (args:get-arg "-test") ","))) + (run-id (car dat)) + (test-id (cadr dat))) + (if (and (number? run-id) + (number? test-id) + (>= test-id 0)) + (examine-test run-id test-id) + (begin + (debug:print 3 "INFO: tried to open test with invalid run-id,test-id. " (args:get-arg "-test")) + (exit 1))))) + ((args:get-arg "-guimonitor") + (gui-monitor *dbstruct-local*)) + (else + (set! uidat (make-dashboard-buttons *dbstruct-local* *num-runs* *num-tests* *dbkeys*)) + (iup:callback-set! *tim* + "ACTION_CB" + (lambda (x) + (let ((update-is-running #f)) + (mutex-lock! *update-mutex*) + (set! update-is-running *update-is-running*) + (if (not update-is-running) + (set! *update-is-running* #t)) + (mutex-unlock! *update-mutex*) + (if (not update-is-running) + (begin + (dashboard:run-update x) + (mutex-lock! *update-mutex*) + (set! *update-is-running* #f) + (mutex-unlock! *update-mutex*)))) + 1)))) + +(let ((th1 (make-thread (lambda () + (thread-sleep! 1) + (set! *please-update-buttons* #t) + (dashboard:run-update 1)) "update buttons once")) + ;; need to wait for first *update-is-running* #t + ;; (let loop () + ;; (mutex-lock! *update-mutex*) + ;; (if *update-is-running* + ;; (begin + ;; (set! *please-update-buttons* #t) + ;; (mark-for-update) + ;; (print "Did redraw trigger")) "First update after startup") + ;; (mutex-unlock! *update-mutex*) + ;; (thread-sleep! 1) + ;; (if (not *please-update-buttons*) + ;; (loop)))))) + (th2 (make-thread iup:main-loop "Main loop"))) + (thread-start! th1) + (thread-start! th2) + (thread-join! th2)) + +;; (iup:main-loop)(db:close-all *dbstruct-local*) Index: portlogger.scm ================================================================== --- portlogger.scm +++ portlogger.scm @@ -114,12 +114,12 @@ (or curr var curr)) #f db "SELECT (port) FROM ports WHERE state='released' LIMIT 1;"))) -(define (portlogger:find-port db) - (let* ((lowport (let ((val (configf:lookup *configdat* "server" "lowport"))) +(define (portlogger:find-port db area-dat) + (let* ((lowport (let ((val (configf:lookup (megatest:area-configdat area-dat) "server" "lowport"))) (if (and val (string->number val)) (string->number val) 32768))) (portnum (or (portlogger:get-prev-used-port db) Index: rmt.scm ================================================================== --- rmt.scm +++ rmt.scm @@ -70,42 +70,48 @@ #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 ;; -(define (rmt:get-connection-info run-id) - (let ((cinfo (hash-table-ref/default *runremote* run-id #f))) +(define (rmt:get-connection-info run-id area-dat #!key (remote #f)) + (let ((cinfo (common:get-remote remote run-id))) (if cinfo cinfo ;; NB// can cache the answer for server running for 10 seconds ... ;; ;; (and (not (rmt:write-frequency-over-limit? cmd run-id)) (if (tasks:server-running-or-starting? (db:delay-if-busy (tasks:open-db)) run-id) - (client:setup run-id) + (client:setup run-id remote: remote) #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 +(define (rmt:discard-old-connections area-dat) ;; clean out old connections (mutex-lock! *db-multi-sync-mutex*) - (let ((expire-time (- (current-seconds) (server:get-timeout) 10))) ;; don't forget the 10 second margin + (let ((remote (megatest:area-remote area-dat)) + (expire-time (- (current-seconds) (server:get-timeout area-dat) 10))) ;; don't forget the 10 second margin (for-each (lambda (run-id) - (let ((connection (hash-table-ref/default *runremote* run-id #f))) + (let ((connection (common:get-remote remote run-id))) (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") ;; SHOULD CLOSE THE CONNECTION HERE - (case *transport-type* + (case (megatest:area-transport area-dat) ((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*) + (common:get-remote remote run-id))))) + (common:del-remote! remote run-id))))) + (common:get-remote-all remote))) + (mutex-unlock! *db-multi-sync-mutex*)) + +(define *send-receive-mutex* (make-mutex)) ;; should have separate mutex per run-id + +(define (rmt:send-receive cmd rid params area-dat #!key (attemptnum 1)(remote #f)) ;; start attemptnum at 1 so the modulo below works as expected + (rmt:discard-old-connections area-dat) ;; (mutex-lock! *send-receive-mutex*) (let* ((run-id (if rid rid 0)) - (connection-info (rmt:get-connection-info run-id))) + (configdat (megatest:area-configdat area-dat)) + (connection-info (rmt:get-connection-info run-id area-dat))) ;; the nmsg method does the encoding under the hood (the http method should be changed to do this also) (if connection-info ;; use the server if have connection info (let* ((dat (case *transport-type* ((http)(condition-case @@ -127,11 +133,11 @@ ((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.") ;; (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 + (common:del-remote! remote 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) ;; (tasks:kill-server-run-id run-id tag: "api-send-receive-failed")) ;; (mutex-unlock! *send-receive-mutex*) ;; close the mutex here to allow other threads access to communications (tasks:start-and-wait-for-server (tasks:open-db) run-id 15) @@ -140,34 +146,34 @@ ;; no longer killing the server in http-transport:client-api-send-receive ;; may kill it here but what are the criteria? ;; start with three calls then kill server ;; (if (eq? attemptnum 3)(tasks:kill-server-run-id run-id)) ;; (thread-sleep! 2) - (rmt:send-receive cmd run-id params attemptnum: (+ attemptnum 1))))) + (rmt:send-receive cmd run-id params area-dat attemptnum: (+ attemptnum 1))))) ;; no connection info? try to start a server, or access locally if no ;; server and the query is read-only ;; ;; Note: The tasks db was checked for a server in starting mode in the rmt:get-connection-info call ;; (if (and (< attemptnum 15) (member cmd api:write-queries)) - (let ((faststart (configf:lookup *configdat* "server" "faststart"))) - (hash-table-delete! *runremote* run-id) + (let ((faststart (configf:lookup configdat "server" "faststart"))) + (common:del-remote! remote run-id) ;; (mutex-unlock! *send-receive-mutex*) (if (and faststart (equal? faststart "no")) (begin (tasks:start-and-wait-for-server (db:delay-if-busy (tasks:open-db)) run-id 10) (thread-sleep! (random 5)) ;; give some time to settle and minimize collison? - (rmt:send-receive cmd rid params attemptnum: (+ attemptnum 1))) + (rmt:send-receive cmd rid params area-dat attemptnum: (+ attemptnum 1))) (begin - (server:kind-run run-id) - (rmt:open-qry-close-locally cmd run-id params)))) + (server:kind-run run-id area-dat) + (rmt:open-qry-close-locally cmd run-id params area-dat)))) (begin ;; (debug:print 0 "ERROR: Communication failed!") ;; (mutex-unlock! *send-receive-mutex*) ;; (exit) - (rmt:open-qry-close-locally cmd run-id params) + (rmt:open-qry-close-locally cmd run-id params area-dat) ))))) (define (rmt:update-db-stats run-id rawcmd params duration) (mutex-lock! *db-stats-mutex*) (handle-exceptions @@ -186,11 +192,11 @@ (vector-set! stat-vec 0 (+ (vector-ref stat-vec 0) 1)) (vector-set! stat-vec 1 (+ (vector-ref stat-vec 1) duration)))) (mutex-unlock! *db-stats-mutex*)) -(define (rmt:print-db-stats) +(define (rmt:print-db-stats area-dat) (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")) (for-each (lambda (cmd) (let ((cmd-dat (hash-table-ref *db-stats* cmd))) @@ -226,11 +232,11 @@ res)) (define (rmt:open-qry-close-locally cmd run-id params #!key (remretries 5)) (let* ((dbstruct-local (if *dbstruct-db* *dbstruct-db* - (let* ((dbdir (db:dbfile-path #f)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db")) + (let* ((dbdir (db:dbfile-path #f)) (db (make-dbr:dbstruct path: dbdir local: #t))) (set! *dbstruct-db* db) db))) (db-file-path (db:dbfile-path 0)) ;; (read-only (not (file-read-access? db-file-path))) @@ -258,11 +264,11 @@ ;; just set it every time. Is a write more expensive than a read and does it matter? (hash-table-set! *db-local-sync* (or run-id 0) start-time) ;; the oldest "write" (mutex-unlock! *db-multi-sync-mutex*))) res)))) -(define (rmt:send-receive-no-auto-client-setup connection-info cmd run-id params) +(define (rmt:send-receive-no-auto-client-setup connection-info cmd run-id params area-dat) (let* ((run-id (if run-id run-id 0)) ;; (jparams (db:obj->string params)) ;; (rmt:dat->json-str params)) (res (handle-exceptions exn #f @@ -296,106 +302,108 @@ ;;====================================================================== ;; S E R V E R ;;====================================================================== (define (rmt:kill-server run-id) - (rmt:send-receive 'kill-server run-id (list run-id))) + (rmt:send-receive 'kill-server run-id (list run-id) area-dat)) (define (rmt:start-server run-id) - (rmt:send-receive 'start-server 0 (list run-id))) + (rmt:send-receive 'start-server 0 (list run-id) area-dat)) ;;====================================================================== ;; M I S C ;;====================================================================== -(define (rmt:login run-id) - (rmt:send-receive 'login run-id (list *toppath* megatest-version run-id *my-client-signature*))) +(define (rmt:login run-id area-dat) + (rmt:send-receive 'login run-id (list (megatest:area-path area-dat) megatest-version run-id *my-client-signature*) area-dat)) ;; This login does no retries under the hood - it acts a bit like a ping. ;; Deprecated for nmsg-transport. ;; -(define (rmt:login-no-auto-client-setup connection-info run-id) - (case *transport-type* - ((http)(rmt:send-receive-no-auto-client-setup connection-info 'login run-id (list *toppath* megatest-version run-id *my-client-signature*))) - ((nmsg)(nmsg-transport:client-api-send-receive run-id connection-info 'login (list *toppath* megatest-version run-id *my-client-signature*))))) +(define (rmt:login-no-auto-client-setup connection-info run-id area-dat) + (let ((transport (megatest:area-transport area-dat)) + (toppath (megatest:area-path area-dat))) + (case transport + ((http)(rmt:send-receive-no-auto-client-setup connection-info 'login run-id (list toppath megatest-version run-id *my-client-signature*) area-dat)) + ((nmsg)(nmsg-transport:client-api-send-receive run-id connection-info 'login (list toppath megatest-version run-id *my-client-signature*) area-dat))))) ;; hand off a call to one of the db:queries statements ;; added run-id to make looking up the correct db possible ;; -(define (rmt:general-call stmtname run-id . params) - (rmt:send-receive 'general-call run-id (append (list stmtname run-id) params))) +(define (rmt:general-call stmtname run-id area-dat . params) + (rmt:send-receive 'general-call run-id (append (list stmtname run-id) params) area-dat)) -(define (rmt:sync-inmem->db run-id) - (rmt:send-receive 'sync-inmem->db run-id '())) +(define (rmt:sync-inmem->db run-id area-dat) + (rmt:send-receive 'sync-inmem->db run-id '() area-dat)) -(define (rmt:sdb-qry qry val run-id) +(define (rmt:sdb-qry qry val run-id area-dat) ;; add caching if qry is 'getid or 'getstr - (rmt:send-receive 'sdb-qry run-id (list qry val))) + (rmt:send-receive 'sdb-qry run-id (list qry val) area-dat)) ;; NOT COMPLETED -(define (rmt:runtests user run-id testpatt params) - (rmt:send-receive 'runtests run-id testpatt)) +(define (rmt:runtests user run-id testpatt params area-dat) + (rmt:send-receive 'runtests run-id testpatt area-dat)) ;;====================================================================== ;; K E Y S ;;====================================================================== ;; These require run-id because the values come from the run! ;; -(define (rmt:get-key-val-pairs run-id) - (rmt:send-receive 'get-key-val-pairs run-id (list run-id))) +(define (rmt:get-key-val-pairs run-id area-dat) + (rmt:send-receive 'get-key-val-pairs run-id (list run-id) area-dat)) -(define (rmt:get-keys) - (rmt:send-receive 'get-keys #f '())) +(define (rmt:get-keys area-dat) + (rmt:send-receive 'get-keys #f '() area-dat)) ;;====================================================================== ;; T E S T S ;;====================================================================== -(define (rmt:get-test-id run-id testname item-path) - (rmt:send-receive 'get-test-id run-id (list run-id testname item-path))) +(define (rmt:get-test-id run-id testname item-path area-dat) + (rmt:send-receive 'get-test-id run-id (list run-id testname item-path) area-dat)) -(define (rmt:get-test-info-by-id run-id test-id) +(define (rmt:get-test-info-by-id run-id test-id area-dat) (if (and (number? run-id)(number? test-id)) - (rmt:send-receive 'get-test-info-by-id run-id (list run-id test-id)) + (rmt:send-receive 'get-test-info-by-id run-id (list run-id test-id) area-dat) (begin (debug:print 0 "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))) +(define (rmt:test-get-rundir-from-test-id run-id test-id area-dat) + (rmt:send-receive 'test-get-rundir-from-test-id run-id (list run-id test-id) area-dat)) -(define (rmt:open-test-db-by-test-id run-id test-id #!key (work-area #f)) +(define (rmt:open-test-db-by-test-id run-id test-id area-dat #!key (work-area #f)) (let* ((test-path (if (string? work-area) work-area - (rmt:test-get-rundir-from-test-id run-id test-id)))) + (rmt:test-get-rundir-from-test-id run-id test-id area-dat)))) (debug:print 3 "TEST PATH: " test-path) (open-test-db test-path))) ;; WARNING: This currently bypasses the transaction wrapped writes system -(define (rmt:test-set-state-status-by-id 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:test-set-state-status-by-id run-id test-id newstate newstatus newcomment area-dat) + (rmt:send-receive 'test-set-state-status-by-id run-id (list run-id test-id newstate newstatus newcomment) area-dat)) -(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:set-tests-state-status run-id testnames currstate currstatus newstate newstatus area-dat) + (rmt:send-receive 'set-tests-state-status run-id (list run-id testnames currstate currstatus newstate newstatus) area-dat)) -(define (rmt:get-tests-for-run run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals) +(define (rmt:get-tests-for-run run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals area-dat) (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)) + (rmt:send-receive 'get-tests-for-run run-id (list run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals) area-dat) (begin (debug:print "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) - (rmt:send-receive 'synchash-get run-id (list run-id proc synckey keynum params))) +(define (rmt:synchash-get run-id proc synckey keynum params area-dat) + (rmt:send-receive 'synchash-get run-id (list run-id proc synckey keynum params) area-dat)) ;; IDEA: Threadify these - they spend a lot of time waiting ... ;; -(define (rmt:get-tests-for-runs-mindata run-ids testpatt states status not-in) +(define (rmt:get-tests-for-runs-mindata run-ids testpatt states status not-in area-dat) (let ((multi-run-mutex (make-mutex)) (run-id-list (if run-ids run-ids (rmt:get-all-run-ids))) (result '())) @@ -406,11 +414,11 @@ (threads '())) (if (> (length threads) 5) (loop hed tal (filter (lambda (th)(not (member (thread-state th) '(terminated dead)))) threads)) (let* ((newthread (make-thread (lambda () - (let ((res (rmt:send-receive 'get-tests-for-run-mindata hed (list hed testpatt states status not-in)))) + (let ((res (rmt:send-receive 'get-tests-for-run-mindata hed (list hed testpatt states status not-in) area-dat))) (if (list? res) (begin (mutex-lock! multi-run-mutex) (set! result (append result res)) (mutex-unlock! multi-run-mutex)) @@ -432,169 +440,169 @@ ;; (rmt:get-all-run-ids)))) ;; (apply append (map (lambda (run-id) ;; (rmt:send-receive 'get-tests-for-run-mindata run-id (list run-ids testpatt states status not-in))) ;; run-id-list)))) -(define (rmt:delete-test-records run-id test-id) - (rmt:send-receive 'delete-test-records run-id (list run-id test-id))) +(define (rmt:delete-test-records run-id test-id area-dat) + (rmt:send-receive 'delete-test-records run-id (list run-id test-id) area-dat)) ;; This is not needed as test steps are deleted on test delete call ;; ;; (define (rmt:delete-test-step-records run-id test-id) ;; (rmt:send-receive 'delete-test-step-records run-id (list run-id test-id))) -(define (rmt:test-set-status-state run-id test-id status state msg) - (rmt:send-receive 'test-set-status-state run-id (list run-id test-id status state msg))) +(define (rmt:test-set-status-state run-id test-id status state msg area-dat) + (rmt:send-receive 'test-set-status-state run-id (list run-id test-id status state msg) area-dat)) -(define (rmt:test-toplevel-num-items run-id test-name) - (rmt:send-receive 'test-toplevel-num-items run-id (list run-id test-name))) +(define (rmt:test-toplevel-num-items run-id test-name area-dat) + (rmt:send-receive 'test-toplevel-num-items run-id (list run-id test-name) area-dat)) ;; (define (rmt:get-previous-test-run-record run-id test-name item-path) ;; (rmt:send-receive 'get-previous-test-run-record run-id (list run-id test-name item-path))) -(define (rmt:get-matching-previous-test-run-records run-id test-name item-path) - (rmt:send-receive 'get-matching-previous-test-run-records run-id (list run-id test-name item-path))) - -(define (rmt:test-get-logfile-info run-id test-name) - (rmt:send-receive 'test-get-logfile-info run-id (list run-id test-name))) - -(define (rmt:test-get-records-for-index-file run-id test-name) - (rmt:send-receive 'test-get-records-for-index-file run-id (list run-id test-name))) - -(define (rmt:get-testinfo-state-status run-id test-id) - (rmt:send-receive 'get-testinfo-state-status run-id (list run-id test-id))) - -(define (rmt:test-set-log! run-id test-id logf) - (if (string? logf)(rmt:general-call 'test-set-log run-id logf test-id))) - -(define (rmt:test-set-top-process-pid run-id test-id pid) - (rmt:send-receive 'test-set-top-process-pid run-id (list run-id test-id pid))) - -(define (rmt:test-get-top-process-pid run-id test-id) - (rmt:send-receive 'test-get-top-process-pid run-id (list run-id test-id))) - -(define (rmt:get-run-ids-matching-target keynames target res runname testpatt statepatt statuspatt) - (rmt:send-receive 'get-run-ids-matching-target #f (list keynames target res runname testpatt statepatt statuspatt))) +(define (rmt:get-matching-previous-test-run-records run-id test-name item-path area-dat) + (rmt:send-receive 'get-matching-previous-test-run-records run-id (list run-id test-name item-path) area-dat)) + +(define (rmt:test-get-logfile-info run-id test-name area-dat) + (rmt:send-receive 'test-get-logfile-info run-id (list run-id test-name) area-dat)) + +(define (rmt:test-get-records-for-index-file run-id test-name area-dat) + (rmt:send-receive 'test-get-records-for-index-file run-id (list run-id test-name) area-dat)) + +(define (rmt:get-testinfo-state-status run-id test-id area-dat) + (rmt:send-receive 'get-testinfo-state-status run-id (list run-id test-id) area-dat)) + +(define (rmt:test-set-log! run-id test-id logf area-dat) + (if (string? logf)(rmt:general-call 'test-set-log run-id logf test-id area-dat))) + +(define (rmt:test-set-top-process-pid run-id test-id pid area-dat) + (rmt:send-receive 'test-set-top-process-pid run-id (list run-id test-id pid) area-dat)) + +(define (rmt:test-get-top-process-pid run-id test-id area-dat) + (rmt:send-receive 'test-get-top-process-pid run-id (list run-id test-id) area-dat)) + +(define (rmt:get-run-ids-matching-target keynames target res runname testpatt statepatt statuspatt area-dat) + (rmt:send-receive 'get-run-ids-matching-target #f (list keynames target res runname testpatt statepatt statuspatt) area-dat)) ;; NOTE: This will open and access ALL run databases. ;; -(define (rmt:test-get-paths-matching-keynames-target-new keynames target res testpatt statepatt statuspatt runname) - (let ((run-ids (rmt:get-run-ids-matching-target keynames target res runname testpatt statepatt statuspatt))) +(define (rmt:test-get-paths-matching-keynames-target-new keynames target res testpatt statepatt statuspatt runname area-dat) + (let ((run-ids (rmt:get-run-ids-matching-target keynames target res runname testpatt statepatt statuspatt area-dat))) (apply append (map (lambda (run-id) - (rmt:send-receive 'test-get-paths-matching-keynames-target-new run-id (list run-id keynames target res testpatt statepatt statuspatt runname))) + (rmt:send-receive 'test-get-paths-matching-keynames-target-new run-id (list run-id keynames target res testpatt statepatt statuspatt runname) area-dat)) run-ids)))) -(define (rmt:get-run-ids-matching keynames target res) - (rmt:send-receive #f 'get-run-ids-matching (list keynames target res))) - -(define (rmt:get-prereqs-not-met run-id waitons ref-item-path #!key (mode '(normal))) - (rmt:send-receive 'get-prereqs-not-met run-id (list run-id waitons ref-item-path mode))) - -(define (rmt:get-count-tests-running-for-run-id run-id) - (rmt:send-receive 'get-count-tests-running-for-run-id run-id (list run-id))) +(define (rmt:get-run-ids-matching keynames target res area-dat) + (rmt:send-receive #f 'get-run-ids-matching (list keynames target res) area-dat) area-dat) + +(define (rmt:get-prereqs-not-met run-id waitons ref-item-path area-dat #!key (mode '(normal))) + (rmt:send-receive 'get-prereqs-not-met run-id (list run-id waitons ref-item-path mode) area-dat)) + +(define (rmt:get-count-tests-running-for-run-id run-id area-dat) + (rmt:send-receive 'get-count-tests-running-for-run-id run-id (list run-id) area-dat)) ;; Statistical queries -(define (rmt:get-count-tests-running run-id) - (rmt:send-receive 'get-count-tests-running run-id (list run-id))) - -(define (rmt:get-count-tests-running-for-testname run-id testname) - (rmt:send-receive 'get-count-tests-running-for-testname run-id (list run-id testname))) - -(define (rmt:get-count-tests-running-in-jobgroup run-id jobgroup) - (rmt:send-receive 'get-count-tests-running-in-jobgroup run-id (list run-id jobgroup))) - -(define (rmt:roll-up-pass-fail-counts run-id test-name item-path status) - (rmt:send-receive 'roll-up-pass-fail-counts run-id (list run-id test-name item-path status))) - -(define (rmt:update-pass-fail-counts run-id test-name) - (rmt:general-call 'update-fail-pass-counts run-id (list run-id test-name run-id test-name run-id test-name))) +(define (rmt:get-count-tests-running run-id area-dat) + (rmt:send-receive 'get-count-tests-running run-id (list run-id) area-dat)) + +(define (rmt:get-count-tests-running-for-testname run-id testname area-dat) + (rmt:send-receive 'get-count-tests-running-for-testname run-id (list run-id testname) area-dat)) + +(define (rmt:get-count-tests-running-in-jobgroup run-id jobgroup area-dat) + (rmt:send-receive 'get-count-tests-running-in-jobgroup run-id (list run-id jobgroup) area-dat)) + +(define (rmt:roll-up-pass-fail-counts run-id test-name item-path status area-dat) + (rmt:send-receive 'roll-up-pass-fail-counts run-id (list run-id test-name item-path status) area-dat)) + +(define (rmt:update-pass-fail-counts run-id test-name area-dat) + (rmt:general-call 'update-fail-pass-counts run-id (list run-id test-name run-id test-name run-id test-name) area-dat)) ;;====================================================================== ;; R U N S ;;====================================================================== -(define (rmt:get-run-info run-id) - (rmt:send-receive 'get-run-info run-id (list run-id))) +(define (rmt:get-run-info run-id area-dat) + (rmt:send-receive 'get-run-info run-id (list run-id) area-dat)) ;; Use the special run-id == #f scenario here since there is no run yet -(define (rmt:register-run keyvals runname state status user) - (rmt:send-receive 'register-run #f (list keyvals runname state status user))) - -(define (rmt:get-run-name-from-id run-id) - (rmt:send-receive 'get-run-name-from-id run-id (list run-id))) - -(define (rmt:delete-run run-id) - (rmt:send-receive 'delete-run run-id (list run-id))) - -(define (rmt:delete-old-deleted-test-records) - (rmt:send-receive 'delete-old-deleted-test-records #f '())) - -(define (rmt:get-runs runpatt count offset keypatts) - (rmt:send-receive 'get-runs #f (list runpatt count offset keypatts))) - -(define (rmt:get-runs runpatt count offset keypatts) - (rmt:send-receive 'get-runs #f (list runpatt count offset keypatts))) - -(define (rmt:get-all-run-ids) - (rmt:send-receive 'get-all-run-ids #f '())) - -(define (rmt:get-prev-run-ids run-id) - (rmt:send-receive 'get-prev-run-ids #f (list run-id))) - -(define (rmt:lock/unlock-run run-id lock unlock user) - (rmt:send-receive 'lock/unlock-run #f (list run-id lock unlock user))) +(define (rmt:register-run keyvals runname state status user area-dat) + (rmt:send-receive 'register-run #f (list keyvals runname state status user) area-dat)) + +(define (rmt:get-run-name-from-id run-id area-dat) + (rmt:send-receive 'get-run-name-from-id run-id (list run-id) area-dat)) + +(define (rmt:delete-run run-id area-dat) + (rmt:send-receive 'delete-run run-id (list run-id) area-dat)) + +(define (rmt:delete-old-deleted-test-records area-dat) + (rmt:send-receive 'delete-old-deleted-test-records #f '() area-dat)) + +(define (rmt:get-runs runpatt count offset keypatts area-dat) + (rmt:send-receive 'get-runs #f (list runpatt count offset keypatts) area-dat)) + +(define (rmt:get-runs runpatt count offset keypatts area-dat) + (rmt:send-receive 'get-runs #f (list runpatt count offset keypatts) area-dat)) + +(define (rmt:get-all-run-ids area-dat) + (rmt:send-receive 'get-all-run-ids #f '() area-dat)) + +(define (rmt:get-prev-run-ids run-id area-dat) + (rmt:send-receive 'get-prev-run-ids #f (list run-id) area-dat)) + +(define (rmt:lock/unlock-run run-id lock unlock user area-dat) + (rmt:send-receive 'lock/unlock-run #f (list run-id lock unlock user) area-dat)) ;; set/get status -(define (rmt:get-run-status run-id) - (rmt:send-receive 'get-run-status #f (list run-id))) - -(define (rmt:set-run-status run-id run-status #!key (msg #f)) - (rmt:send-receive 'set-run-status #f (list run-id run-status msg))) - -(define (rmt:update-run-event_time run-id) - (rmt:send-receive 'update-run-event_time #f (list run-id))) - -(define (rmt:get-runs-by-patt keys runnamepatt targpatt offset limit) - (rmt:send-receive 'get-runs-by-patt #f (list keys runnamepatt targpatt offset limit))) - -(define (rmt:find-and-mark-incomplete run-id ovr-deadtime) - (if (rmt:send-receive 'have-incompletes? run-id (list run-id ovr-deadtime)) - (rmt:send-receive 'mark-incomplete run-id (list run-id ovr-deadtime)))) +(define (rmt:get-run-status run-id area-dat) + (rmt:send-receive 'get-run-status #f (list run-id) area-dat)) + +(define (rmt:set-run-status run-id run-status area-dat #!key (msg #f)) + (rmt:send-receive 'set-run-status #f (list run-id run-status msg) area-dat)) + +(define (rmt:update-run-event_time run-id area-dat) + (rmt:send-receive 'update-run-event_time #f (list run-id) area-dat)) + +(define (rmt:get-runs-by-patt keys runnamepatt targpatt offset limit area-dat) + (rmt:send-receive 'get-runs-by-patt #f (list keys runnamepatt targpatt offset limit) area-dat)) + +(define (rmt:find-and-mark-incomplete run-id ovr-deadtime area-dat) + (if (rmt:send-receive 'have-incompletes? run-id (list run-id ovr-deadtime) area-dat) + (rmt:send-receive 'mark-incomplete run-id (list run-id ovr-deadtime) area-dat))) ;;====================================================================== ;; M U L T I R U N Q U E R I E S ;;====================================================================== ;; Need to move this to multi-run section and make associated changes -(define (rmt:find-and-mark-incomplete-all-runs #!key (ovr-deadtime #f)) - (let ((run-ids (rmt:get-all-run-ids))) +(define (rmt:find-and-mark-incomplete-all-runs area-dat #!key (ovr-deadtime #f)) + (let ((run-ids (rmt:get-all-run-ids area-dat))) (for-each (lambda (run-id) - (rmt:find-and-mark-incomplete run-id ovr-deadtime)) + (rmt:find-and-mark-incomplete run-id ovr-deadtime area-dat)) run-ids))) ;; get the previous record for when this test was run where all keys match but runname ;; returns #f if no such test found, returns a single test record if found ;; ;; Run this at the client end since we have to connect to multiple run-id dbs ;; -(define (rmt:get-previous-test-run-record run-id test-name item-path) - (let* ((keyvals (rmt:get-key-val-pairs run-id)) - (keys (rmt:get-keys)) +(define (rmt:get-previous-test-run-record run-id test-name item-path area-dat) + (let* ((keyvals (rmt:get-key-val-pairs run-id area-dat)) + (keys (rmt:get-keys area-dat)) (selstr (string-intersperse keys ",")) (qrystr (string-intersperse (map (lambda (x)(conc x "=?")) keys) " AND "))) (if (not keyvals) #f - (let ((prev-run-ids (rmt:get-prev-run-ids run-id))) + (let ((prev-run-ids (rmt:get-prev-run-ids run-id area-dat))) ;; 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) (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))) + (let ((results (rmt:get-tests-for-run hed (conc test-name "/" item-path) '() '() #f #f #f #f #f #f area-dat))) (debug:print 4 "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 @@ -614,75 +622,75 @@ ;; 2. Continue as above ;; ;;(define (rmt:get-steps-for-test run-id test-id) ;; (rmt:send-receive 'get-steps-data run-id (list test-id))) -(define (rmt:teststep-set-status! run-id test-id teststep-name state-in status-in comment logfile) +(define (rmt:teststep-set-status! run-id test-id teststep-name state-in status-in comment logfile area-dat) (let* ((state (items:check-valid-items "state" state-in)) (status (items:check-valid-items "status" status-in))) (if (or (not state)(not status)) (debug:print 3 "WARNING: Invalid " (if status "status" "state") " value \"" (if status state-in status-in) "\", update your validvalues section in megatest.config")) - (rmt:send-receive 'teststep-set-status! run-id (list run-id test-id teststep-name state-in status-in comment logfile)))) + (rmt:send-receive 'teststep-set-status! run-id (list run-id test-id teststep-name state-in status-in comment logfile) area-dat))) -(define (rmt:get-steps-for-test run-id test-id) - (rmt:send-receive 'get-steps-for-test run-id (list run-id test-id))) +(define (rmt:get-steps-for-test run-id test-id area-dat) + (rmt:send-receive 'get-steps-for-test run-id (list run-id test-id) area-dat)) ;;====================================================================== ;; 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))) +(define (rmt:read-test-data run-id test-id categorypatt area-dat #!key (work-area #f)) + (let ((tdb (rmt:open-test-db-by-test-id run-id test-id area-dat work-area: work-area))) (if tdb - (tdb:read-test-data tdb test-id categorypatt) + (tdb:read-test-data tdb test-id categorypatt area-dat) '()))) -(define (rmt:testmeta-add-record testname) - (rmt:send-receive 'testmeta-add-record #f (list testname))) - -(define (rmt:testmeta-get-record testname) - (rmt:send-receive 'testmeta-get-record #f (list testname))) - -(define (rmt:testmeta-update-field test-name fld val) - (rmt:send-receive 'testmeta-update-field #f (list test-name fld val))) - -(define (rmt:test-data-rollup run-id test-id status) - (rmt:send-receive 'test-data-rollup run-id (list run-id test-id status))) - -(define (rmt:csv->test-data run-id test-id csvdata) - (rmt:send-receive 'csv->test-data run-id (list run-id test-id csvdata))) +(define (rmt:testmeta-add-record testname area-dat) + (rmt:send-receive 'testmeta-add-record #f (list testname) area-dat)) + +(define (rmt:testmeta-get-record testname area-dat) + (rmt:send-receive 'testmeta-get-record #f (list testname) area-dat)) + +(define (rmt:testmeta-update-field test-name fld val area-dat) + (rmt:send-receive 'testmeta-update-field #f (list test-name fld val) area-dat)) + +(define (rmt:test-data-rollup run-id test-id status area-dat) + (rmt:send-receive 'test-data-rollup run-id (list run-id test-id status) area-dat)) + +(define (rmt:csv->test-data run-id test-id csvdata area-dat) + (rmt:send-receive 'csv->test-data run-id (list run-id test-id csvdata) area-dat)) ;;====================================================================== ;; T A S K S ;;====================================================================== -(define (rmt:tasks-find-task-queue-records target run-name test-patt state-patt action-patt) - (rmt:send-receive 'find-task-queue-records #f (list target run-name test-patt state-patt action-patt))) - -(define (rmt:tasks-add action owner target runname testpatt params) - (rmt:send-receive 'tasks-add #f (list action owner target runname testpatt params))) - -(define (rmt:tasks-set-state-given-param-key param-key new-state) - (rmt:send-receive 'tasks-set-state-given-param-key #f (list param-key new-state))) +(define (rmt:tasks-find-task-queue-records target run-name test-patt state-patt action-patt area-dat) + (rmt:send-receive 'find-task-queue-records #f (list target run-name test-patt state-patt action-patt) area-dat)) + +(define (rmt:tasks-add action owner target runname testpatt params area-dat) + (rmt:send-receive 'tasks-add #f (list action owner target runname testpatt params) area-dat)) + +(define (rmt:tasks-set-state-given-param-key param-key new-state area-dat) + (rmt:send-receive 'tasks-set-state-given-param-key #f (list param-key new-state) area-dat)) ;;====================================================================== ;; A R C H I V E S ;;====================================================================== -(define (rmt:archive-get-allocations testname itempath dneeded) - (rmt:send-receive 'archive-get-allocations #f (list testname itempath dneeded))) - -(define (rmt:archive-register-block-name bdisk-id archive-path) - (rmt:send-receive 'archive-register-block-name #f (list bdisk-id archive-path))) - -(define (rmt:archive-allocate-testsuite/area-to-block block-id testsuite-name areakey) - (rmt:send-receive 'archive-allocate-test-to-block #f (list block-id testsuite-name areakey))) - -(define (rmt:archive-register-disk bdisk-name bdisk-path df) - (rmt:send-receive 'archive-register-disk #f (list bdisk-name bdisk-path df))) - -(define (rmt:test-set-archive-block-id run-id test-id archive-block-id) - (rmt:send-receive 'test-set-archive-block-id run-id (list run-id test-id archive-block-id))) - -(define (rmt:test-get-archive-block-info archive-block-id) - (rmt:send-receive 'test-get-archive-block-info #f (list archive-block-id))) +(define (rmt:archive-get-allocations testname itempath dneeded area-dat) + (rmt:send-receive 'archive-get-allocations #f (list testname itempath dneeded) area-dat)) + +(define (rmt:archive-register-block-name bdisk-id archive-path area-dat) + (rmt:send-receive 'archive-register-block-name #f (list bdisk-id archive-path) area-dat)) + +(define (rmt:archive-allocate-testsuite/area-to-block block-id testsuite-name areakey area-dat) + (rmt:send-receive 'archive-allocate-test-to-block #f (list block-id testsuite-name areakey) area-dat)) + +(define (rmt:archive-register-disk bdisk-name bdisk-path df area-dat) + (rmt:send-receive 'archive-register-disk #f (list bdisk-name bdisk-path df) area-dat)) + +(define (rmt:test-set-archive-block-id run-id test-id archive-block-id area-dat) + (rmt:send-receive 'test-set-archive-block-id run-id (list run-id test-id archive-block-id) area-dat)) + +(define (rmt:test-get-archive-block-info archive-block-id area-dat) + (rmt:send-receive 'test-get-archive-block-info #f (list archive-block-id) area-dat)) Index: rpc-transport.scm ================================================================== --- rpc-transport.scm +++ rpc-transport.scm @@ -29,11 +29,11 @@ (handle-exceptions exn (begin (debug:print 1 "Remote failed for " proc " " params) (apply (eval (string->symbol procstr)) params)) - ;; (if *runremote* + ;; (if (common:get-remote remote) ;; (apply (eval (string->symbol (conc "remote:" procstr))) params) (apply (eval (string->symbol procstr)) params))) ;; all routes though here end in exit ... ;; @@ -61,26 +61,27 @@ (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) +(define (rpc-transport:run hostn run-id server-id area-dat) (debug:print 2 "Attempting to start the rpc server ...") ;; (trace rpc:publish-procedure!) (rpc:publish-procedure! 'server:login server:login) (rpc:publish-procedure! 'testing (lambda () "Just testing")) - (let* ((db #f) + (let* ((configdat (megatest:area-configdat area-dat)) + (db #f) (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) #f))) (if ipstr ipstr hostn))) ;; hostname))) (start-port (open-run-close tasks:server-get-next-port tasks:open-db)) - (link-tree-path (configf:lookup *configdat* "setup" "linktree")) + (link-tree-path (configf:lookup configdat "setup" "linktree")) (rpc:listener (rpc-transport:find-free-port-and-open (rpc:default-server-port))) (th1 (make-thread (lambda () ((rpc:make-server rpc:listener) #t)) "rpc:server")) @@ -143,63 +144,64 @@ (rpc-transport:find-free-port-and-open (+ port 1))) (rpc:default-server-port port) (tcp-read-timeout 240000) (tcp-listen (rpc:default-server-port) 10000))) -(define (rpc-transport:ping run-id host port) +(define (rpc-transport:ping run-id host port area-dat) (handle-exceptions exn (begin (print "SERVER_NOT_FOUND") (exit 1)) - (let ((login-res ((rpc:procedure 'server:login host port) *toppath*))) + (let ((login-res ((rpc:procedure 'server:login host port) (megatest:area-path area-dat)))) (if (and (list? login-res) (car login-res)) (begin (print "LOGIN_OK") (exit 0)) (begin (print "LOGIN_FAILED") (exit 1)))))) -(define (rpc-transport:client-setup run-id #!key (remtries 10)) - (if *runremote* +(define (rpc-transport:client-setup run-id area-dat #!key (remtries 10)) + (if (common:get-remote remote run-id) (begin (debug:print 0 "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")) + (let* ((toppath (megatest:area-path area-dat)) + (host-info (common:get-remote remote run-id))) ;; (open-run-close db:get-var #f "SERVER")) (if host-info (let ((iface (car host-info)) (port (cadr host-info)) - (ping-res ((rpc:procedure 'server:login host port) *toppath*))) + (ping-res ((rpc:procedure 'server:login host port) toppath))) (if ping-res (let ((server-dat (list iface port #f #f #f))) - (hash-table-set! *runremote* run-id server-dat) + (common:set-remote! remote run-id server-dat) server-dat) (begin (server:try-running run-id) (thread-sleep! 2) - (rpc-transport:client-setup run-id (- remtries 1))))) + (rpc-transport:client-setup run-id area-dat remtries: (- 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) (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*))) + (ping-res ((rpc:procedure 'server:login host port) toppath))) (if start-res (begin - (hash-table-set! *runremote* run-id server-dat) + (common:set-remote! remote run-id server-dat) server-dat) (begin (server:try-running run-id) (thread-sleep! 2) - (rpc-transport:client-setup run-id (- remtries 1))))) + (rpc-transport:client-setup run-id area-dat remtries: (- remtries 1))))) (begin (server:try-running run-id) (thread-sleep! 2) - (rpc-transport:client-setup run-id (- remtries 1))))))))) + (rpc-transport:client-setup run-id area-dat remtries: (- remtries 1))))))))) ;; ;; (port (if (and hostinfo (> (length hostdat) 1))(cadr hostdat) #f))) ;; (if (and port ;; (string->number port)) ;; (let ((portn (string->number port))) @@ -211,16 +213,16 @@ ;; (debug:print 0 " EXCEPTION: " ((condition-property-accessor 'exn 'message) exn)) ;; ;; (open-run-close ;; ;; (lambda (db . param) ;; ;; (sqlite3:execute db "DELETE FROM metadat WHERE var='SERVER'")) ;; ;; #f) -;; (set! *runremote* #f)) +;; (set! (common:get-remote remote) #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*)) +;; ((rpc:procedure 'server:login host portn) toppath)) ;; (begin ;; (debug:print-info 2 "Logged in and connected to " host ":" port) -;; (set! *runremote* (vector host portn))) +;; (set! (common:get-remote remote) (vector host portn))) ;; (begin ;; (debug:print-info 2 "Failed to login or connect to " host ":" port) -;; (set! *runremote* #f))))) +;; (set! (common:get-remote remote) #f))))) ;; (debug:print-info 2 "no server available"))))) Index: run_records.scm ================================================================== --- run_records.scm +++ run_records.scm @@ -1,7 +1,7 @@ ;;====================================================================== -;; Copyright 2006-2012, Matthew Welland. +;; Copyright 2006-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 @@ -19,11 +19,11 @@ (define-inline (runs:runrec-mconfig vec)(vector-ref vec 6)) ;; megatest.config (define-inline (runs:runrec-runconfig vec)(vector-ref vec 7)) ;; runconfigs.config (define-inline (runs:runrec-serverdat vec)(vector-ref vec 8)) ;; (host port) (define-inline (runs:runrec-transport vec)(vector-ref vec 9)) ;; 'http (define-inline (runs:runrec-db vec)(vector-ref vec 10)) ;; (if 'fs) -(define-inline (runs:runrec-top-path vec)(vector-ref vec 11)) ;; *toppath* +(define-inline (runs:runrec-top-path vec)(vector-ref vec 11)) ;; toppath (define-inline (runs:runrec-run_id vec)(vector-ref vec 12)) ;; run-id (define-inline (test:get-id vec) (vector-ref vec 0)) (define-inline (test:get-run_id vec) (vector-ref vec 1)) (define-inline (test:get-test-name vec)(vector-ref vec 2)) Index: runconfig.scm ================================================================== --- runconfig.scm +++ runconfig.scm @@ -56,13 +56,13 @@ sections) (debug:print 2 "---") (set! *already-seen-runconfig-info* #t))) finaldat)) -(define (set-run-config-vars run-id keyvals targ-from-db) - (push-directory *toppath*) ;; the push/pop doesn't appear to do anything ... - (let ((runconfigf (conc *toppath* "/runconfigs.config")) +(define (set-run-config-vars run-id keyvals targ-from-db area-dat) + (push-directory (megatest:area-path area-dat)) ;; the push/pop doesn't appear to do anything ... + (let ((runconfigf (conc (megatest:area-path area-dat) "/runconfigs.config")) (targ (or (common:args-get-target) targ-from-db (get-environment-variable "MT_TARGET")))) (pop-directory) (if (file-exists? runconfigf) Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -33,74 +33,75 @@ (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 ")"))))) -;; This is the *new* methodology. One record to inform them and in the chaos, organise them. -;; -(define (runs:create-run-record) - (let* ((mconfig (if *configdat* - *configdat* - (if (launch:setup-for-run) - *configdat* - (begin - (debug:print 0 "ERROR: Called setup in a non-megatest area, exiting") - (exit 1))))) - (runrec (runs:runrec-make-record)) - (target (common:args-get-target)) - (runname (or (args:get-arg "-runname") - (args:get-arg ":runname"))) - (testpatt (or (args:get-arg "-testpatt") - (args:get-arg "-runtests"))) - (keys (keys:config-get-fields mconfig)) - (keyvals (keys:target->keyval keys target)) - (toppath *toppath*) - (envdat keyvals) ;; initial values start with keyvals - (runconfig #f) - (serverdat (if (args:get-arg "-server") - *runremote* - #f)) ;; to be used later - (transport (or (args:get-arg "-transport") 'http)) - (run-id #f)) - ;; Set all the environment vars we know so far, start with keys - (for-each (lambda (keyval) - (setenv (car keyval)(cadr keyval))) - keyvals) - ;; Set up various and sundry known vars here - (setenv "MT_RUN_AREA_HOME" toppath) - (setenv "MT_RUNNAME" runname) - (setenv "MT_TARGET" target) - (setenv "MT_TESTSUITENAME" (common:get-testsuite-name)) - (set! envdat (append - envdat - (list (list "MT_RUN_AREA_HOME" toppath) - (list "MT_RUNNAME" runname) - (list "MT_TARGET" target)))) - ;; Now can read the runconfigs file - ;; - (set! runconfig (read-config (conc *toppath* "/runconfigs.config") #f #t sections: (list "default" target))) - (if (not (hash-table-ref/default runconfig (args:get-arg "-reqtarg") #f)) - (begin - (debug:print 0 "ERROR: [" (args:get-arg "-reqtarg") "] not found in " runconfigf) - (if db (sqlite3:finalize! db)) - (exit 1))) - ;; Now have runconfigs data loaded, set environment vars - (for-each (lambda (section) - (for-each (lambda (varval) - (set! envdat (append envdat (list varval))) - (safe-setenv (car varval)(cadr varval))) - (configf:get-section runconfig section))) - (list "default" target)) - (vector target runname testpatt keys keyvals envdat mconfig runconfig serverdat transport db toppath run-id))) - -(define (runs:set-megatest-env-vars run-id #!key (inkeys #f)(inrunname #f)(inkeyvals #f)) - (let* ((target (or (common:args-get-target) +;;;;;; ;; This is the *new* methodology. One record to inform them and in the chaos, organise them. +;;;;;; ;; +;;;;;; (define (runs:create-run-record area-dat) ;; #!key (remote #f)) +;;;;;; (let* ((remote (megatest:area-remote area-dat)) +;;;;;; (configdat (megatest:area-configdat area-dat)) +;;;;;; (toppath (megatest:area-path area-dat))) +;;;;;; (mconfig (if configdat +;;;;;; configdat +;;;;;; (if (launch:setup-for-run) +;;;;;; configdat +;;;;;; (begin +;;;;;; (debug:print 0 "ERROR: Called setup in a non-megatest area, exiting") +;;;;;; (exit 1))))) +;;;;;; (runrec (runs:runrec-make-record)) +;;;;;; (target (common:args-get-target)) +;;;;;; (runname (or (args:get-arg "-runname") +;;;;;; (args:get-arg ":runname"))) +;;;;;; (testpatt (or (args:get-arg "-testpatt") +;;;;;; (args:get-arg "-runtests"))) +;;;;;; (keys (keys:config-get-fields mconfig)) +;;;;;; (keyvals (keys:target->keyval keys target)) +;;;;;; (envdat keyvals) ;; initial values start with keyvals +;;;;;; (runconfig #f) +;;;;;; (transport (or (args:get-arg "-transport") 'http)) +;;;;;; (run-id #f)) +;;;;;; ;; Set all the environment vars we know so far, start with keys +;;;;;; (for-each (lambda (keyval) +;;;;;; (setenv (car keyval)(cadr keyval))) +;;;;;; keyvals) +;;;;;; ;; Set up various and sundry known vars here +;;;;;; (setenv "MT_RUN_AREA_HOME" toppath) +;;;;;; (setenv "MT_RUNNAME" runname) +;;;;;; (setenv "MT_TARGET" target) +;;;;;; (setenv "MT_TESTSUITENAME" (common:get-testsuite-name)) +;;;;;; (set! envdat (append +;;;;;; envdat +;;;;;; (list (list "MT_RUN_AREA_HOME" toppath) +;;;;;; (list "MT_RUNNAME" runname) +;;;;;; (list "MT_TARGET" target)))) +;;;;;; ;; Now can read the runconfigs file +;;;;;; ;; +;;;;;; (set! runconfig (read-config (conc toppath "/runconfigs.config") #f #t sections: (list "default" target))) +;;;;;; (if (not (hash-table-ref/default runconfig (args:get-arg "-reqtarg") #f)) +;;;;;; (begin +;;;;;; (debug:print 0 "ERROR: [" (args:get-arg "-reqtarg") "] not found in " runconfigf) +;;;;;; (if db (sqlite3:finalize! db)) +;;;;;; (exit 1))) +;;;;;; ;; Now have runconfigs data loaded, set environment vars +;;;;;; (for-each (lambda (section) +;;;;;; (for-each (lambda (varval) +;;;;;; (set! envdat (append envdat (list varval))) +;;;;;; (safe-setenv (car varval)(cadr varval))) +;;;;;; (configf:get-section runconfig section))) +;;;;;; (list "default" target)) +;;;;;; (vector target runname testpatt keys keyvals envdat mconfig runconfig (common:get-remote remote run-id) transport db toppath run-id))) + +(define (runs:set-megatest-env-vars run-id area-dat #!key (inkeys #f)(inrunname #f)(inkeyvals #f)) + (let* ((configdat (megatest:area-configdat area-dat)) + (toppath (megatest:area-path area-dat)) + (target (or (common:args-get-target) (get-environment-variable "MT_TARGET"))) (keys (if inkeys inkeys (rmt:get-keys))) (keyvals (if inkeyvals inkeyvals (keys:target->keyval keys target))) (vals (hash-table-ref/default *env-vars-by-run-id* run-id #f)) - (link-tree (configf:lookup *configdat* "setup" "linktree"))) + (link-tree (configf:lookup configdat "setup" "linktree"))) ;; 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.")) (if (not vals) @@ -116,17 +117,17 @@ vals (lambda (key val) (debug:print 2 "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" '())) + (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))) - (setenv "MT_RUN_AREA_HOME" *toppath*))) + (setenv "MT_RUN_AREA_HOME" toppath))) (define (set-item-env-vars itemdat) (for-each (lambda (item) (debug:print 2 "setenv " (car item) " " (cadr item)) (setenv (car item) (cadr item))) @@ -160,20 +161,21 @@ (begin (hash-table-set! *runs:denoise* key currtime) #t) #f))) -(define (runs:can-run-more-tests run-id jobgroup max-concurrent-jobs) +(define (runs:can-run-more-tests run-id jobgroup max-concurrent-jobs area-dat) (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 ...")) 2);; obviously haven't had any work to do for a while (else 0))) - (let* ((num-running (rmt:get-count-tests-running run-id)) + (let* ((configdat (megatest:area-configdat area-dat)) + (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))) + (job-group-limit (let ((jobg-count (config-lookup configdat "jobgroups" jobgroup))) (if (string? jobg-count) (string->number jobg-count) jobg-count)))) (if (> (+ num-running num-running-in-jobgroup) 0) (set! *runs:can-run-more-tests-count* (+ *runs:can-run-more-tests-count* 1))) @@ -205,26 +207,28 @@ ;; test-names: Comma separated patterns same as test-patts but used in selection ;; of tests to run. The item portions are not respected. ;; FIXME: error out if /patt specified ;; -(define (runs:run-tests target runname test-patts user flags #!key (run-count 3)) ;; test-names - (let* ((keys (keys:config-get-fields *configdat*)) +(define (runs:run-tests target runname test-patts user flags area-dat #!key (run-count 3)) ;; test-names + (let* ((configdat (megatest:area-configdat area-dat)) + (toppath (megatest:area-path area-dat)) + (keys (keys:config-get-fields configdat)) (keyvals (keys:target->keyval keys target)) - (run-id (rmt:register-run keyvals runname "new" "n/a" user)) ;; test-name))) + (run-id (rmt:register-run keyvals runname "new" "n/a" user area-dat)) ;; test-name))) (deferred '()) ;; delay running these since they have a waiton clause - (runconfigf (conc *toppath* "/runconfigs.config")) + (runconfigf (conc toppath "/runconfigs.config")) (test-records (make-hash-table)) ;; need to process runconfigs before generating these lists (all-tests-registry #f) ;; (tests:get-all)) ;; (tests:get-valid-tests (make-hash-table) test-search-path)) ;; all valid tests to check waiton names (all-test-names #f) ;; (hash-table-keys all-tests-registry)) (test-names #f) ;; (tests:filter-test-names all-test-names test-patts)) (required-tests #f) ;;(lset-intersection equal? (string-split test-patts ",") test-names))) ;; test-names)) ;; Added test-names as initial for required-tests but that failed to work (task-key (conc (hash-table->alist flags) " " (get-host-name) " " (current-process-id))) (tdbdat (tasks:open-db))) - (if (tasks:need-server run-id)(tasks:start-and-wait-for-server tdbdat run-id 10)) + (if (tasks:need-server run-id area-dat)(tasks:start-and-wait-for-server tdbdat run-id 10)) (set-signal-handler! signal/int (lambda (signum) (signal-mask! signum) (print "Received signal " signum ", cleaning up before exit. Please wait...") @@ -234,26 +238,26 @@ (exit))) ;; 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") - (runs:set-megatest-env-vars run-id inkeys: keys inrunname: runname) ;; these may be needed by the launching process + (runs:set-megatest-env-vars run-id area-dat inkeys: keys inrunname: runname) ;; these may be needed by the launching process (if (file-exists? runconfigf) (setup-env-defaults runconfigf run-id *already-seen-runconfig-info* keyvals target) (debug:print 0 "WARNING: You do not have a run config file: " runconfigf)) ;; Now generate all the tests lists - (set! all-tests-registry (tests:get-all)) + (set! all-tests-registry (tests:get-all area-dat)) (set! all-test-names (hash-table-keys all-tests-registry)) (set! test-names (tests:filter-test-names all-test-names test-patts)) (set! required-tests (lset-intersection equal? (string-split test-patts ",") test-names)) ;; 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: " (tests:get-tests-search-path *configdat*)) + ;; (set! test-names (delete-duplicates (tests:get-valid-tests toppath test-patts))) + (debug:print-info 0 "tests search path: " (tests:get-tests-search-path configdat area-dat)) (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<) " ")) ;; on the first pass or call to run-tests set FAILS to NOT_STARTED if ;; -keepgoing is specified @@ -271,11 +275,11 @@ ;; Now convert FAIL and anything in allow-auto-rerun to NOT_STARTED ;; (for-each (lambda (state) (rmt:set-tests-state-status run-id test-names state #f "NOT_STARTED" state)) - (string-split (or (configf:lookup *configdat* "setup" "allow-auto-rerun") ""))))) + (string-split (or (configf:lookup configdat "setup" "allow-auto-rerun") ""))))) ;; Ensure all tests are registered in the test_meta table (runs:update-all-test_meta #f) ;; now add non-directly referenced dependencies (i.e. waiton) @@ -286,11 +290,11 @@ ;; ;;====================================================================== (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 - (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. + (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* ((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 @@ -369,11 +373,11 @@ (if (not (null? required-tests)) (debug:print-info 1 "Adding " 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)) - (let ((reglen (configf:lookup *configdat* "setup" "runqueue"))) + (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 @@ -382,12 +386,12 @@ (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 area-dat)))) + (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests (any->number reglen) all-tests-registry area-dat))) "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) @@ -408,11 +412,11 @@ (begin (if (not (hash-table-ref/default flags "-preclean" #f)) (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")) - (runs:run-tests target runname test-patts user flags run-count: (- run-count 1))))) + (runs:run-tests target runname test-patts user flags area-dat run-count: (- run-count 1))))) (debug:print-info 0 "No tests to run"))) (debug:print-info 4 "All done by here") (rmt:tasks-set-state-given-param-key task-key "done") ;; (sqlite3:finalize! tasks-db) )) @@ -513,11 +517,11 @@ (null? non-completed))) (debug:print-info 4 "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 + (runs:set-megatest-env-vars run-id area-dat inrunname: runname) ;; these may be needed by the launching process (let ((items-list (items:get-items-from-config tconfig))) (if (list? items-list) (begin (if (null? items-list) (let ((test-id (rmt:get-test-id run-id test-name ""))) @@ -640,12 +644,14 @@ t) (else (conc t)))) inlst))) -(define (runs:process-expanded-tests hed tal reg reruns reglen regfull test-record runname test-name item-path jobgroup max-concurrent-jobs run-id waitons item-path testmode test-patts required-tests test-registry registry-mutex flags keyvals run-info newtal all-tests-registry itemmap) - (let* ((run-limits-info (runs:can-run-more-tests run-id jobgroup max-concurrent-jobs)) ;; look at the test jobgroup and tot jobs running +(define (runs:process-expanded-tests hed tal reg reruns reglen regfull test-record runname test-name item-path jobgroup max-concurrent-jobs run-id waitons item-path testmode test-patts required-tests test-registry registry-mutex flags keyvals run-info newtal all-tests-registry itemmap area-dat) + (let* ((configdat (megatest:area-configdat area-dat)) + (toppath (megatest:area-path area-dat)) + (run-limits-info (runs:can-run-more-tests run-id jobgroup max-concurrent-jobs)) ;; look at the test jobgroup and tot jobs running (have-resources (car run-limits-info)) (num-running (list-ref run-limits-info 1)) (num-running-in-jobgroup (list-ref run-limits-info 2)) (max-concurrent-jobs (list-ref run-limits-info 3)) (job-group-limit (list-ref run-limits-info 4)) @@ -654,12 +660,12 @@ (fails (runs:calc-fails prereqs-not-met)) (non-completed (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")))) + (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: (" (string-intersperse (map (lambda (t) (if (vector? t) (conc (db:test-get-state t) "/" (db:test-get-status t)) @@ -754,13 +760,13 @@ ;; we are going to reset all the counters for test retries by setting a new hash table ;; this means they will increment only when nothing can be run (set! *max-tries-hash* (make-hash-table)) ;; 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 + (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) + (run:test run-id run-info keyvals runname test-record flags #f test-registry all-tests-registry area-dat) (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) @@ -888,27 +894,29 @@ ;; 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) +(define (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests reglen-in all-tests-registry area-dat) ;; 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)) ;; Do mark-and-find clean up of db before starting runing of quue ;; ;; (cdb:remote-run db:find-and-mark-incomplete #f) - (let ((run-info (rmt:get-run-info run-id)) + (let ((configdat (megatest:area-configdat area-dat)) + (toppath (megatest:area-path area-dat)) + (run-info (rmt:get-run-info run-id area-dat)) (tests-info (mt:get-tests-for-run run-id #f '() '())) ;; qryvals: "id,testname,item_path")) (sorted-test-names (tests:sort-by-priority-and-waiton test-records)) (test-registry (make-hash-table)) (registry-mutex (make-mutex)) (num-retries 0) - (max-retries (config-lookup *configdat* "setup" "maxretries")) - (max-concurrent-jobs (let ((mcj (config-lookup *configdat* "setup" "max_concurrent_jobs"))) + (max-retries (config-lookup configdat "setup" "maxretries")) + (max-concurrent-jobs (let ((mcj (config-lookup configdat "setup" "max_concurrent_jobs"))) (if (and mcj (string->number mcj)) (string->number mcj) 1))) ;; length of the register queue ahead (reglen (if (number? reglen-in) reglen-in 1)) (last-time-incomplete (- (current-seconds) 900)) ;; force at least one clean up cycle @@ -957,15 +965,15 @@ (items (tests:testqueue-get-items test-record)) (item-path (item-list->path itemdat)) (tfullname (db:test-make-full-name test-name item-path)) (newtal (append tal (list hed))) (regfull (>= (length reg) reglen)) - (num-running (rmt:get-count-tests-running-for-run-id run-id))) + (num-running (rmt:get-count-tests-running-for-run-id run-id area-dat))) ;; every couple minutes verify the server is there for this run (if (and (common:low-noise-print 60 "try start server" run-id) - (tasks:need-server run-id)) + (tasks:need-server run-id area-dat)) (tasks:start-and-wait-for-server tdbdat run-id 10)) ;; NOTE: delay and wait is done under the hood (if (> num-running 0) (set! last-time-some-running (current-seconds))) @@ -975,11 +983,11 @@ ;; Ensure all top level tests get registered. This way they show up as "NOT_STARTED" on the dashboard ;; and it is clear they *should* have run but did not. (if (not (hash-table-ref/default test-registry (db:test-make-full-name test-name "") #f)) (begin - (rmt:general-call 'register-test run-id run-id test-name "") + (rmt:general-call 'register-test run-id run-id test-name "" area-dat) (hash-table-set! test-registry (db:test-make-full-name test-name "") 'done))) ;; Fast skip of tests that are already "COMPLETED" - NO! Cannot do that as the items may not have been expanded yet :( ;; (if (member (hash-table-ref/default test-registry tfullname #f) @@ -1126,29 +1134,29 @@ (else (debug:print-info 4 "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) - (let wait-loop ((num-running (rmt:get-count-tests-running-for-run-id run-id)) + (let wait-loop ((num-running (rmt:get-count-tests-running-for-run-id run-id area-dat)) (prev-num-running 0)) ;; (debug:print 0 "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")) + (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)) (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)) (set! last-time-incomplete (current-seconds)) - (rmt:find-and-mark-incomplete run-id #f))) + (rmt:find-and-mark-incomplete run-id #f area-dat))) (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))))) (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)))) + (wait-loop (rmt:get-count-tests-running-for-run-id run-id area-dat) num-running)))) ;; LET* ((test-record ;; we get here on "drop through". All done! (debug:print-info 1 "All tests launched"))) (define (runs:calc-fails prereqs-not-met) @@ -1196,21 +1204,22 @@ (conc t) (conc (db:test-get-testname t) ":" (db:test-get-state t) "/" (db:test-get-status t)))) lst)) ;; parent-test is there as a placeholder for when parent-tests can be run as a setup step -(define (run:test run-id run-info keyvals runname test-record flags parent-test test-registry all-tests-registry) +(define (run:test run-id run-info keyvals runname test-record flags parent-test test-registry all-tests-registry area-dat) ;; All these vars might be referenced by the testconfig file reader - (let* ((test-name (tests:testqueue-get-testname test-record)) + (let* ((toppath (megatest:area-path area-dat)) + (test-name (tests:testqueue-get-testname test-record)) (test-waitons (tests:testqueue-get-waitons test-record)) (test-conf (tests:testqueue-get-testconfig test-record)) (itemdat (tests:testqueue-get-itemdat test-record)) - (test-path (hash-table-ref all-tests-registry test-name)) ;; (conc *toppath* "/tests/" test-name)) ;; could use tests:get-testconfig here ... + (test-path (hash-table-ref all-tests-registry test-name)) (force (hash-table-ref/default flags "-force" #f)) (rerun (hash-table-ref/default flags "-rerun" #f)) (keepgoing (hash-table-ref/default flags "-keepgoing" #f)) - (incomplete-timeout (string->number (or (configf:lookup *configdat* "setup" "incomplete-timeout") "x"))) + (incomplete-timeout (string->number (or (configf:lookup configdat "setup" "incomplete-timeout") "x"))) (item-path "") (db #f) (full-test-name #f)) ;; setting itemdat to a list if it is #f @@ -1224,12 +1233,12 @@ ) (debug:print 2 "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) ;; these may be needed by the launching process - (change-directory *toppath*) + (runs:set-megatest-env-vars run-id area-dat inrunname: runname) ;; these may be needed by the launching process + (change-directory toppath) ;; Here is where the test_meta table is best updated ;; Yes, another use of a global for caching. Need a better way? ;; ;; There is now a single call to runs:update-all-test_meta and this @@ -1241,12 +1250,12 @@ (hash-table-set! *test-meta-updated* test-name #t) (runs:update-test_meta test-name test-conf))) ;; itemdat => ((ripeness "overripe") (temperature "cool") (season "summer")) (let* ((new-test-path (string-intersperse (cons test-path (map cadr itemdat)) "/")) - (test-id (rmt:get-test-id run-id test-name item-path)) - (testdat (if test-id (rmt:get-test-info-by-id run-id test-id) #f))) + (test-id (rmt:get-test-id run-id test-name item-path area-dat)) + (testdat (if test-id (rmt:get-test-info-by-id run-id test-id area-dat) #f))) (if (not testdat) (let loop () ;; ensure that the path exists before registering the test ;; NOPE: Cannot! Don't know yet which disk area will be assigned.... ;; (system (conc "mkdir -p " new-test-path)) @@ -1253,18 +1262,18 @@ ;; ;; (open-run-close tests:register-test db run-id test-name item-path) ;; ;; NB// for the above line. I want the test to be registered long before this routine gets called! ;; - (if (not test-id)(set! test-id (rmt:get-test-id run-id test-name item-path))) + (if (not test-id)(set! test-id (rmt:get-test-id run-id test-name item-path area-dat))) (if (not test-id) (begin (debug:print 2 "WARN: Test not pre-created? test-name=" test-name ", item-path=" item-path ", run-id=" run-id) - (rmt:general-call 'register-test run-id run-id test-name item-path) - (set! test-id (rmt:get-test-id run-id test-name item-path)))) + (rmt:general-call 'register-test run-id run-id test-name item-path area-dat) + (set! test-id (rmt:get-test-id run-id test-name item-path area-dat)))) (debug:print-info 4 "test-id=" test-id ", run-id=" run-id ", test-name=" test-name ", item-path=\"" item-path "\"") - (set! testdat (rmt:get-test-info-by-id run-id test-id)) + (set! testdat (rmt:get-test-info-by-id run-id test-id area-dat)) (if (not testdat) (begin (debug:print-info 0 "WARNING: server is overloaded, trying again in one second") (thread-sleep! 1) (loop))))) @@ -1273,11 +1282,11 @@ (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?") - (change-directory *toppath*))) + (change-directory toppath))) (case (if force ;; (args:get-arg "-force") 'NOT_STARTED (if testdat (string->symbol (test:get-state testdat)) 'failed-to-insert)) @@ -1332,11 +1341,11 @@ ;; Have to check for skip conditions. This one skips if there are same-named tests ;; currently running ((and skip-check (configf:lookup test-conf "skip" "prevrunning")) ;; run-ids = #f means *all* runs - (let ((running-tests (rmt:get-tests-for-runs-mindata #f full-test-name '("RUNNING" "REMOTEHOSTSTART" "LAUNCHED") '() #f))) + (let ((running-tests (rmt:get-tests-for-runs-mindata #f full-test-name '("RUNNING" "REMOTEHOSTSTART" "LAUNCHED") '() #f area-dat))) (if (not (null? running-tests)) ;; have to skip (set! skip-test "Skipping due to previous tests running")))) ((and skip-check (configf:lookup test-conf "skip" "fileexists")) (if (file-exists? (configf:lookup test-conf "skip" "fileexists")) @@ -1416,15 +1425,15 @@ ;; 'remove-runs ;; 'set-state-status ;; ;; NB// should pass in keys? ;; -(define (runs:operate-on action target runnamepatt testpatt #!key (state #f)(status #f)(new-state-status #f)(mode 'remove-all)(options '())) +(define (runs:operate-on action target runnamepatt testpatt area-dat #!key (state #f)(status #f)(new-state-status #f)(mode 'remove-all)(options '())) (common:clear-caches) ;; clear all caches (let* ((db #f) (tdbdat (tasks:open-db)) - (keys (rmt:get-keys)) + (keys (rmt:get-keys area-dat)) (rundat (mt:get-runs-by-patt keys runnamepatt target)) (header (vector-ref rundat 0)) (runs (vector-ref rundat 1)) (states (if state (string-split state ",") '())) (statuses (if status (string-split status ",") '())) @@ -1457,18 +1466,18 @@ (debug:print-info 4 "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)) + (if (tasks:need-server run-id area-dat)(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) (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"))) ((set-state-status) - (if (tasks:need-server run-id)(tasks:start-and-wait-for-server tdbdat run-id 10)) + (if (tasks:need-server run-id area-dat)(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"))) ((print-run) (debug:print 1 "Printing info for run " runkey ", run=" run ", tests=" tests ", header=" header) action) ((run-wait) @@ -1502,11 +1511,11 @@ (test-retry-time (make-hash-table)) (allow-run-time 10)) ;; seconds to allow for killing tests before just brutally killing 'em (let loop ((test (car sorted-tests)) (tal (cdr sorted-tests))) (let* ((test-id (db:test-get-id test)) - (new-test-dat (rmt:get-test-info-by-id run-id test-id))) + (new-test-dat (rmt:get-test-info-by-id run-id test-id area-dat))) (if (not new-test-dat) (begin (debug:print 0 "ERROR: We have a test-id of " test-id " but no record was found. NOTE: No locking of records is done between processes, do not simultaneously remove the same run from two processes!") (if (not (null? tal)) (loop (car tal)(cdr tal)))) @@ -1517,11 +1526,11 @@ (db:test-get-rundir new-test-dat)) ;; ) ;; run dir is from the link tree (test-state (db:test-get-state new-test-dat)) (test-fulln (db:test-get-fullname new-test-dat)) (uname (db:test-get-uname new-test-dat)) (toplevel-with-children (and (db:test-get-is-toplevel test) - (> (rmt:test-toplevel-num-items run-id test-name) 0)))) + (> (rmt:test-toplevel-num-items run-id test-name area-dat) 0)))) (case action ((remove-runs) ;; if the test is a toplevel-with-children issue an error and do not remove (if toplevel-with-children (begin @@ -1589,12 +1598,12 @@ (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") - (rmt:delete-run run-id) - (rmt:delete-old-deleted-test-records) + (rmt:delete-run run-id area-dat) + (rmt:delete-old-deleted-test-records area-dat) ;; (cdb:remote-run db:set-var db "DELETED_TESTS" (current-seconds)) ;; need to figure out the path to the run dir and remove it if empty ;; (if (null? (glob (conc runpath "/*"))) ;; (begin ;; (debug:print 1 "Removing run dir " runpath) @@ -1648,21 +1657,24 @@ )) ;; 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)) - (else (rmt:delete-test-records (db:test-get-run_id test) (db:test-get-id test)))))) + (else (rmt:delete-test-records (db:test-get-run_id test) (db:test-get-id test) area-dat))))) ;;====================================================================== ;; Routines for manipulating runs ;;====================================================================== ;; Since many calls to a run require pretty much the same setup ;; this wrapper is used to reduce the replication of code -(define (general-run-call switchname action-desc proc) - (let ((runname (or (args:get-arg "-runname")(args:get-arg ":runname"))) - (target (common:args-get-target))) +(define (general-run-call switchname action-desc proc area-dat) + (let ((runname (or (args:get-arg "-runname")(args:get-arg ":runname"))) + (target (common:args-get-target)) + (toppath (megatest:area-path area-dat)) + (configdat (megatest:area-configdat area-dat)) + (configinfo (megatest:area-configinfo area-dat))) (cond ((not target) (debug:print 0 "ERROR: Missing required parameter for " switchname ", you must specify the target with -target") (exit 3)) ((not runname) @@ -1669,21 +1681,21 @@ (debug:print 0 "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-for-run) - (launch:cache-config) + (if (launch:setup-for-run area-dat) + (launch:cache-config area-dat) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) ;; (if (args:get-arg "-server") ;; (cdb:remote-run server:start db (args:get-arg "-server"))) - (set! keys (keys:config-get-fields *configdat*)) + (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 + (let* ((runconfigf (conc toppath "/runconfigs.config")) ;; DO NOT EVALUATE ALL (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 @@ -1691,11 +1703,11 @@ ;; (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*)) + (if (not (car configinfo)) (begin (debug:print 0 "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 @@ -1718,57 +1730,57 @@ (if (or lock (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) + (rmt:lock/unlock-run run-id lock unlock user area-dat) (debug:print-info 0 "Skipping lock/unlock on " run-id)))) runs))) ;;====================================================================== ;; Rollup runs ;;====================================================================== ;; Update the test_meta table for this test -(define (runs:update-test_meta test-name test-conf) - (let ((currrecord (rmt:testmeta-get-record test-name))) +(define (runs:update-test_meta test-name test-conf area-dat) + (let ((currrecord (rmt:testmeta-get-record test-name area-dat))) (if (not currrecord) (begin (set! currrecord (make-vector 11 #f)) - (rmt:testmeta-add-record test-name))) + (rmt:testmeta-add-record test-name area-dat))) (for-each (lambda (key) (let* ((idx (cadr key)) (fld (car key)) (val (config-lookup test-conf "test_meta" fld))) ;; (debug:print 5 "idx: " idx " fld: " fld " val: " val) (if (and val (not (equal? (vector-ref currrecord idx) val))) (begin (print "Updating " test-name " " fld " to " val) - (rmt:testmeta-update-field test-name fld val))))) + (rmt:testmeta-update-field test-name fld val area-dat))))) '(("author" 2)("owner" 3)("description" 4)("reviewed" 5)("tags" 9)("jobgroup" 10))))) ;; Update test_meta for all tests (define (runs:update-all-test_meta db) - (let ((test-names (tests:get-all))) ;; (tests:get-valid-tests))) + (let ((test-names (tests:get-all area-dat))) ;; (tests:get-valid-tests))) (for-each (lambda (test-name) (let* ((test-conf (mt:lazy-read-test-config test-name))) (if test-conf (runs:update-test_meta test-name test-conf)))) (hash-table-keys test-names)))) ;; This could probably be refactored into one complex query ... ;; NOT PORTED - DO NOT USE YET ;; -(define (runs:rollup-run keys runname user keyvals) +(define (runs:rollup-run keys runname user keyvals area-dat) (debug:print 4 "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 "%/%" '() '())) + (new-run-id (rmt:register-run keyvals runname "new" "n/a" user area-dat)) + (prev-tests (rmt:get-matching-previous-test-run-records new-run-id "%" "%" area-dat)) + (curr-tests (mt:get-tests-for-run new-run-id "%/%" '() '() area-dat)) (curr-tests-hash (make-hash-table))) - (rmt:update-run-event_time new-run-id) + (rmt:update-run-event_time new-run-id area-dat) ;; index the already saved tests by testname and itemdat in curr-tests-hash (for-each (lambda (testdat) (let* ((testname (db:test-get-testname testdat)) (item-path (db:test-get-item-path testdat)) @@ -1782,11 +1794,11 @@ (lambda (testdat) (let* ((testname (db:test-get-testname testdat)) (item-path (db:test-get-item-path testdat)) (full-name (conc testname "/" item-path)) (prev-test-dat (hash-table-ref/default curr-tests-hash full-name #f)) - (test-steps (rmt:get-steps-for-test (db:test-get-id testdat))) + (test-steps (rmt:get-steps-for-test (db:test-get-id testdat) area-dat)) (new-test-record #f)) ;; replace these with insert ... select (apply sqlite3:execute db (conc "INSERT OR REPLACE INTO tests (run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment) " Index: server.scm ================================================================== --- server.scm +++ server.scm @@ -47,32 +47,32 @@ ;; all routes though here end in exit ... ;; ;; start_server ;; -(define (server:launch run-id) +(define (server:launch run-id area-dat) (case *transport-type* - ((http)(http-transport:launch run-id)) - ((nmsg)(nmsg-transport:launch run-id)) - ((rpc) (rpc-transport:launch run-id)) + ((http)(http-transport:launch run-id area-dat)) + ((nmsg)(nmsg-transport:launch run-id area-dat)) + ((rpc) (rpc-transport:launch run-id area-dat)) (else (debug:print 0 "ERROR: unknown server type " *transport-type*)))) ;; (else (debug:print 0 "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 ;;====================================================================== ;; Get the transport -(define (server:get-transport) - (if *transport-type* - *transport-type* +(define (server:get-transport area-dat) + (if (megatest:area-transport area-dat) + (megatest-area-transport area-dat) (let ((ttype (string->symbol (or (args:get-arg "-transport") - (configf:lookup *configdat* "server" "transport") + (configf:lookup (megatest:area-configdat area-dat) "server" "transport") "rpc")))) - (set! *transport-type* ttype) + (megatest:area-transport-set! area-dat ttype) ttype))) ;; Generate a unique signature for this server (define (server:mk-signature) (message-digest-string (md5-primitive) @@ -82,19 +82,19 @@ (argv))))))) ;; 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) +(define (server:reply return-addr query-sig success/fail result #!key (remote #f)) (debug:print-info 11 "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))) ((zmq) - (let ((pub-socket (vector-ref *runremote* 1))) + (let ((pub-socket (vector-ref (common:get-remote remote #f) 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*) @@ -102,23 +102,25 @@ ;; 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 ;; -(define (server:run run-id) - (let* ((curr-host (get-host-name)) +(define (server:run run-id area-dat) + (let* ((configdat (megatest:area-configdat area-dat)) + (toppath (megatest:area-path area-dat)) + (curr-host (get-host-name)) (curr-ip (server:get-best-guess-address curr-host)) - (target-host (configf:lookup *configdat* "server" "homehost" )) + (target-host (configf:lookup configdat "server" "homehost" )) (testsuite (common:get-testsuite-name)) - (logfile (conc *toppath* "/logs/" run-id ".log")) + (logfile (conc toppath "/logs/" run-id ".log")) (cmdln (conc (common:get-megatest-exe) - " -server " (or target-host "-") " -run-id " run-id (if (equal? (configf:lookup *configdat* "server" "daemonize") "yes") + " -server " (or target-host "-") " -run-id " run-id (if (equal? (configf:lookup configdat "server" "daemonize") "yes") (conc " -daemonize -log " logfile) "") " -debug 4 testsuite:" testsuite))) ;; (conc " >> " logfile " 2>&1 &"))))) (debug:print 0 "INFO: Starting server (" cmdln ") as none running ...") - (push-directory *toppath*) + (push-directory toppath) (if (not (directory-exists? "logs"))(create-directory "logs")) ;; host.domain.tld match host? (if (and target-host ;; look at target host, is it host.domain.tld or ip address and does it ;; match current ip or hostname @@ -160,11 +162,11 @@ (define (server:check-if-running run-id) (let ((tdbdat (tasks:open-db))) (let loop ((server (tasks:get-server (db:delay-if-busy tdbdat) run-id)) (trycount 0)) (if server - ;; note: client:start will set *runremote*. this needs to be changed + ;; note: client:start will set (common:get-remote remote). this needs to be changed ;; also, client:start will login to the server, also need to change that. ;; ;; client:start returns #t if login was successful. ;; (let ((res (case *transport-type* @@ -230,26 +232,26 @@ ((NOREPLY) #f) ((LOGIN_OK) #t) (else #f)) (loop (read-line) inl)))))) -(define (server:login toppath) +(define (server:login toppath area-dat) (lambda (toppath) (set! *last-db-access* (current-seconds)) - (if (equal? *toppath* toppath) + (if (equal? (megatest:area-path area-dat) toppath) (begin ;; (debug:print-info 2 "login successful") #t) (begin ;; (debug:print-info 2 "login failed") #f)))) -(define (server:get-timeout) - (let ((tmo (configf:lookup *configdat* "server" "timeout"))) +(define (server:get-timeout area-dat) + (let ((tmo (configf:lookup (megatest:area-configdat area-dat) "server" "timeout"))) (if (and (string? tmo) (string->number tmo)) (* 60 60 (string->number tmo)) ;; (* 3 24 60 60) ;; default to three days (* 60 1) ;; default to one minute ;; (* 60 60 25) ;; default to 25 hours ))) Index: tasks.scm ================================================================== --- tasks.scm +++ tasks.scm @@ -52,12 +52,12 @@ (begin (if remove (system (conc "rm -rf " fullpath))) #f))) #t)))))) -(define (tasks:get-task-db-path) - (let* ((linktree (configf:lookup *configdat* "setup" "linktree")) +(define (tasks:get-task-db-path area-dat) + (let* ((linktree (configf:lookup (megatest:area-configdat area-dat) "setup" "linktree")) (dbpath (conc linktree "/.db"))) dbpath)) @@ -68,11 +68,11 @@ ;; file NOT readable ;; ==> open in-mem version ;; If file NOT exists ;; ==> open in-mem version ;; -(define (tasks:open-db #!key (numretries 4)) +(define (tasks:open-db area-dat #!key (numretries 4)) (if *task-db* *task-db* (handle-exceptions exn (if (> numretries 0) @@ -79,22 +79,23 @@ (begin (print-call-chain (current-error-port)) (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) (debug:print 0 " exn=" (condition->list exn)) (thread-sleep! 1) - (tasks:open-db numretries (- numretries 1))) + (tasks:open-db area-dat 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)))) - (let* ((dbpath (tasks:get-task-db-path)) + (let* ((toppath (megatest:area-path area-dat)) + (dbpath (tasks:get-task-db-path area-dat)) (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)) - (mdb (cond ;; what the hek is *toppath* doing here? - ((and (string? *toppath*)(file-write-access? *toppath*)) + (mdb (cond ;; what the hek is toppath doing here? + ((and (string? toppath)(file-write-access? toppath)) (sqlite3:open-database dbfile)) ((file-read-access? dbpath) (sqlite3:open-database dbfile)) (else (sqlite3:open-database ":memory:")))) ;; (never-give-up-open-db dbpath)) (handler (make-busy-timeout 36000))) (if (and exists @@ -101,11 +102,11 @@ (not write-access)) (set! *db-write-access* write-access)) ;; only unset so other db's also can use this control (sqlite3:set-busy-handler! mdb handler) (db:set-sync mdb) ;; (sqlite3:execute mdb (conc "PRAGMA synchronous = 0;")) ;; (if (or (and (not exists) - ;; (file-write-access? *toppath*)) + ;; (file-write-access? toppath)) ;; (not (file-read-access? dbpath))) ;; (begin ;; ;; TASKS QUEUE MOVED TO main.db ;; @@ -149,11 +150,11 @@ login_time TIMESTAMP, logout_time TIMESTAMP DEFAULT -1, CONSTRAINT clients_constraint UNIQUE (pid,hostname));") ;)) - (set! *task-db* (cons mdb dbpath)) + (set! *task-db* (cons mdb dbpath)) ;; Move into area-dat !!!! *task-db*)))) ;;====================================================================== ;; Server and client management ;;====================================================================== @@ -253,16 +254,11 @@ (get-rand-port (lambda () (+ lownum (random (- highnum lownum))))) (port-param (if (and (args:get-arg "-port") (string->number (args:get-arg "-port"))) (string->number (args:get-arg "-port")) - #f)) - ;; (config-port (if (and (config-lookup *configdat* "server" "port") - ;; (string->number (config-lookup *configdat* "server" "port"))) - ;; (string->number (config-lookup *configdat* "server" "port")) - ;; #f)) - ) + #f))) (sqlite3:for-each-row (lambda (port) (set! used-ports (cons port used-ports))) mdb "SELECT port FROM servers;") @@ -360,15 +356,19 @@ (set! res id)) mdb ;; NEEDS dbprep ADDED "SELECT id FROM servers WHERE run_id=? AND state = 'running';" run-id) res)) -(define (tasks:need-server run-id) - (configf:lookup *configdat* "server" "required")) +(define (tasks:need-server run-id area-dat) + (let ((req (configf:lookup (megatest:area-configdat area-dat) "server" "required"))) + (if (and req + (equal? req "yes")) + #t + #f))) ;; (maxqry (cdr (rmt:get-max-query-average run-id))) -;; (threshold (string->number (or (configf:lookup *configdat* "server" "server-query-threshold") "10")))) +;; (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 ".")) ;; #t) @@ -428,12 +428,12 @@ (unsetenv "TARGETHOST_LOGF") (unsetenv "TARGETHOST")) ;; look up a server by run-id and send it a kill, also delete the record for that server ;; -(define (tasks:kill-server-run-id run-id #!key (tag "default")) - (let* ((tdbdat (tasks:open-db)) +(define (tasks:kill-server-run-id run-id area-dat #!key (tag "default")) + (let* ((tdbdat (tasks:open-db area-dat)) (sdat (tasks:get-server (db:delay-if-busy tdbdat) run-id))) (if sdat (let ((hostname (vector-ref sdat 6)) (pid (vector-ref sdat 5)) (server-id (vector-ref sdat 0))) @@ -511,31 +511,10 @@ mdb "SELECT count(id) FROM monitors WHERE last_update < (strftime('%s','now') - 300) AND username=?;" (car (user-information (current-user-id)))) 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") - (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) - (next-touch 0)) ;; next-touch is the time where we need to update last_update - ;; if the db has been modified we'd best look at the task queue - (let ((modtime (file-modification-time megatestdbpath ))) - (if (> modtime last-db-update) - (tasks:process-queue db mdb last-db-update megatestdb next-touch)) - ;; WARNING: Possible race conditon here!! - ;; should this update be immediately after the task-get-action call above? - (if (> (current-seconds) next-touch) - (begin - (tasks:monitors-update mdb) - (loop (+ count 1)(+ (current-seconds) 240))) - (loop (+ count 1) next-touch))))))) ;;====================================================================== ;; T A S K S Q U E U E ;; ;; NOTE:: These operate on task_queue which is in main.db @@ -739,12 +718,12 @@ ;; kill any runner processes (i.e. processes handling -runtests) that match target/runname ;; ;; do a remote call to get the task queue info but do the killing as self here. ;; -(define (tasks:kill-runner target run-name) - (let ((records (rmt:tasks-find-task-queue-records target run-name "%" "running" "run-tests")) +(define (tasks:kill-runner target run-name area-dat) + (let ((records (rmt:tasks-find-task-queue-records target run-name "%" "running" "run-tests" area-dat)) (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) (debug:print 0 "Found " (length records) " run(s) to kill.")) (for-each Index: tests.scm ================================================================== --- tests.scm +++ tests.scm @@ -32,17 +32,17 @@ (include "db_records.scm") (include "run_records.scm") (include "test_records.scm") ;; Call this one to do all the work and get a standardized list of tests -(define (tests:get-all) - (let* ((test-search-path (tests:get-tests-search-path *configdat*))) +(define (tests:get-all area-dat) + (let* ((test-search-path (tests:get-tests-search-path (megatest:area-configdat area-dat)))) (tests:get-valid-tests (make-hash-table) test-search-path))) -(define (tests:get-tests-search-path cfgdat) +(define (tests:get-tests-search-path cfgdat area-dat) (let ((paths (map cadr (configf:get-section cfgdat "tests-paths")))) - (append paths (list (conc *toppath* "/tests"))))) + (append paths (list (conc (megatest:area-path area-dat) "/tests"))))) (define (tests:get-valid-tests test-registry tests-paths) (if (null? tests-paths) test-registry (let loop ((hed (car tests-paths)) @@ -584,12 +584,12 @@ ;; (tests:match test-patts testname #f)) ;; (map (lambda (testp) ;; (last (string-split testp "/"))) ;; tests))))) -(define (tests:get-testconfig test-name test-registry system-allowed) - (let* ((test-path (hash-table-ref/default test-registry test-name (conc *toppath* "/tests/" test-name))) +(define (tests:get-testconfig test-name test-registry system-allowed area-dat) + (let* ((test-path (hash-table-ref/default test-registry test-name (conc (megatest:area-path area-dat) "/tests/" test-name))) (test-configf (conc test-path "/testconfig")) (testexists (and (file-exists? test-configf)(file-read-access? test-configf))) (tcfg (if testexists (read-config test-configf #f system-allowed environ-patt: (if system-allowed "pre-launch-env-vars" @@ -651,11 +651,11 @@ (itemdat (tests:testqueue-get-itemdat test-record)) (item-path (tests:testqueue-get-item_path test-record)) (waitons (tests:testqueue-get-waitons test-record)) (keep-test #t) (test-id (rmt:get-test-id run-id test-name item-path)) - (tdat (rmt:get-testinfo-state-status run-id test-id))) ;; (cdb:get-test-info-by-id *runremote* test-id))) + (tdat (rmt:get-testinfo-state-status run-id test-id))) ;; (cdb:get-test-info-by-id (common:get-remote remote) test-id))) (if tdat (begin ;; Look at the test state and status (if (or (and (member (db:test-get-status tdat) '("PASS" "WARN" "WAIVED" "CHECK" "SKIP")) @@ -668,11 +668,11 @@ ;; from the runnable list (if keep-test (for-each (lambda (waiton) ;; for now we are waiting only on the parent test (let* ((parent-test-id (rmt:get-test-id run-id waiton "")) - (wtdat (rmt:get-testinfo-state-status run-id test-id))) ;; (cdb:get-test-info-by-id *runremote* test-id))) + (wtdat (rmt:get-testinfo-state-status run-id test-id))) ;; (cdb:get-test-info-by-id (common:get-remote remote) test-id))) (if (or (and (equal? (db:test-get-state wtdat) "COMPLETED") (member (db:test-get-status wtdat) '("FAIL"))) (member (db:test-get-status wtdat) '("KILLED")) (member (db:test-get-state wtdat) '("INCOMPETE"))) ;; (if (or (member (db:test-get-status wtdat) Index: tests/Makefile ================================================================== --- tests/Makefile +++ tests/Makefile @@ -170,12 +170,12 @@ cd fullrun;$(BINPATH)/dashboard -rows 15 & dashboard : cleanprep cd fullrun && $(BINPATH)/dashboard -rows $(ROWS) & -newdashboard : cleanprep - cd fullrun && $(BINPATH)/newdashboard & +olddashboard : cleanprep + cd fullrun && $(BINPATH)/olddashboard & remove : cd fullrun;$(MEGATEST) -remove-runs :runname $(RUN) -testpatt % -itempatt % :sysname % :fsname % :datapath % clean : Index: tests/unittests/basicserver.scm ================================================================== --- tests/unittests/basicserver.scm +++ tests/unittests/basicserver.scm @@ -7,16 +7,16 @@ ;; ./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-for-run *area-dat*) (string? (getenv "MT_RUN_AREA_HOME")))) ;; NON Server tests go here -(test #f #f (db:dbdat-get-path *db*)) +(test #f #f (db:dbdat-get-path *db* *area-dat*)) (test #f #f (db:get-run-name-from-id *db* run-id)) ;; (test #f '("SYSTEM" "RELEASE") (rmt:get-keys)) ;; (exit) Index: zmq-transport.scm ================================================================== --- zmq-transport.scm +++ zmq-transport.scm @@ -66,13 +66,13 @@ (define-inline (zmqsock:get-pub dat)(vector-ref dat 0)) (define-inline (zmqsock:get-pull dat)(vector-ref dat 1)) (define-inline (zmqsock:set-pub! dat s)(vector-set! dat s 0)) (define-inline (zmqsock:set-pull! dat s)(vector-set! dat s 0)) -(define (zmq-transport:run hostn) +(define (zmq-transport:run hostn area-dat) (debug:print 2 "Attempting to start the server ...") - (if (not *toppath*) + (if (not (megatest:area-path area-dat)) (if (not (setup-for-run)) (begin (debug:print 0 "ERROR: cannot find megatest.config, cannot start server, exiting") (exit)))) (let* ((db (open-db)) ;; here we *do not* want to be opening and closing the db @@ -104,16 +104,16 @@ (set! pub-socket (cadr zmq-sdat2)) (set! p2 (caddr zmq-sdat2)) (set! *cache-on* #t) - (set! *runremote* (vector pull-socket pub-socket)) ;; overloading the use of *runremote* BUG!? + (set! *runremote* (vector pull-socket pub-socket)) ;; overloading the use of (common:get-remote remote) BUG!? ;; what to do when we quit ;; ;; (on-exit (lambda () -;; (if (and *toppath* *server-info*) +;; (if (and toppath *server-info*) ;; (open-run-close tasks:server-deregister-self tasks:open-db (car *server-info*)) ;; (let loop () ;; (let ((queue-len 0)) ;; (thread-sleep! (random 5)) ;; (mutex-lock! *incoming-mutex*) @@ -359,18 +359,18 @@ (debug:print-info 0 "Max cached queries was " *max-cache-size*) (debug:print-info 0 "Server shutdown complete. Exiting") (exit))))))) ;; all routes though here end in exit ... -(define (zmq-transport:launch) - (if (not *toppath*) - (if (not (setup-for-run)) +(define (zmq-transport:launch run-id area-dat) + (if (not (megatest:area-path area-dat)) + (if (not (launch:setup-for-run area-dat)) (begin (debug:print 0 "ERROR: cannot find megatest.config, exiting") (exit)))) (debug:print-info 2 "Starting zmq server") - (if *toppath* + (if (megatest:area-path area-dat) (let* (;; (th1 (make-thread (lambda () ;; (let ((server-info #f)) ;; ;; wait for the server to be online and available ;; (let loop () ;; (debug:print-info 2 "Waiting for the server to come online before starting heartbeat") @@ -477,11 +477,11 @@ ;; (pullport (list-ref server-info 2)) ;; (pubport (list-ref server-info 3))) ;; (zmq-transport:client-connect iface pullport pubport) ;; (let loop () ;; (thread-sleep! 2) -;; (cdb:client-call *runremote* 'ping #t) +;; (cdb:client-call (common:get-remote remote) 'ping #t) ;; (debug:print 4 "zmq-transport:self-ping - I'm alive on " iface ":" pullport "/" pubport "!") ;; (mutex-lock! *heartbeat-mutex*) ;; (set! *server-loop-heart-beat* (current-seconds)) ;; (mutex-unlock! *heartbeat-mutex*) ;; (loop))))