Index: api.scm ================================================================== --- api.scm +++ api.scm @@ -78,11 +78,11 @@ read-test-data* login tasks-get-last testmeta-get-record have-incompletes? - synchash-get + ;; synchash-get get-changed-record-ids get-run-record-ids get-not-completed-cnt)) (define api:write-queries @@ -247,11 +247,11 @@ ;; ARCHIVES ;; ((archive-get-allocations) ((archive-register-disk) (apply db:archive-register-disk dbstruct params)) ((archive-register-block-name)(apply db:archive-register-block-name dbstruct params)) - ((archive-allocate-testsuite/area-to-block)(apply db:archive-allocate-testsuite/area-to-block dbstruct block-id testsuite-name areakey)) + ;; ((archive-allocate-testsuite/area-to-block)(apply db:archive-allocate-testsuite/area-to-block dbstruct block-id testsuite-name areakey)) ;;====================================================================== ;; READ ONLY QUERIES ;;====================================================================== @@ -271,21 +271,21 @@ ((test-get-rundir-from-test-id) (apply db:test-get-rundir-from-test-id dbstruct params)) ((get-count-tests-running-for-testname) (apply db:get-count-tests-running-for-testname dbstruct params)) ((get-count-tests-running) (apply db:get-count-tests-running dbstruct params)) ((get-count-tests-running-in-jobgroup) (apply db:get-count-tests-running-in-jobgroup dbstruct params)) ;; ((delete-test-step-records) (apply db:delete-test-step-records dbstruct params)) - ((get-previous-test-run-record) (apply db:get-previous-test-run-record dbstruct params)) + ;; ((get-previous-test-run-record) (apply db:get-previous-test-run-record dbstruct params)) ((get-matching-previous-test-run-records)(apply db:get-matching-previous-test-run-records dbstruct params)) ((test-get-logfile-info) (apply db:test-get-logfile-info dbstruct params)) ((test-get-records-for-index-file) (apply db:test-get-records-for-index-file dbstruct params)) ((get-testinfo-state-status) (apply db:get-testinfo-state-status dbstruct params)) ((test-get-top-process-pid) (apply db:test-get-top-process-pid dbstruct params)) ((test-get-paths-matching-keynames-target-new) (apply db:test-get-paths-matching-keynames-target-new dbstruct params)) ((get-prereqs-not-met) (apply db:get-prereqs-not-met dbstruct params)) ((get-count-tests-running-for-run-id) (apply db:get-count-tests-running-for-run-id dbstruct params)) ((get-not-completed-cnt) (apply db:get-not-completed-cnt dbstruct params)) - ((synchash-get) (apply synchash:server-get dbstruct params)) + ;; ((synchash-get) (apply synchash:server-get dbstruct params)) ((get-raw-run-stats) (apply db:get-raw-run-stats dbstruct params)) ((get-test-times) (apply db:get-test-times dbstruct params)) ;; RUNS ((get-run-info) (apply db:get-run-info dbstruct params)) @@ -294,11 +294,11 @@ ((set-run-status) (apply db:set-run-status dbstruct params)) ((set-run-state-status) (apply db:set-run-state-status dbstruct params)) ((get-tests-for-run) (apply db:get-tests-for-run dbstruct params)) ((get-test-id) (apply db:get-test-id dbstruct params)) ((get-tests-for-run-mindata) (apply db:get-tests-for-run-mindata dbstruct params)) - ((get-tests-for-runs-mindata) (apply db:get-tests-for-runs-mindata dbstruct params)) + ;; ((get-tests-for-runs-mindata) (apply db:get-tests-for-runs-mindata dbstruct params)) ((get-runs) (apply db:get-runs dbstruct params)) ((simple-get-runs) (apply db:simple-get-runs dbstruct params)) ((get-num-runs) (apply db:get-num-runs dbstruct params)) ((get-runs-cnt-by-patt) (apply db:get-runs-cnt-by-patt dbstruct params)) ((get-all-run-ids) (db:get-all-run-ids dbstruct)) @@ -329,12 +329,12 @@ (run-id (cadr params)) (realparams (cddr params))) (db:general-call dbstruct stmtname realparams))) ((sdb-qry) (apply sdb:qry params)) ((ping) (current-process-id)) - ((get-changed-record-ids) (apply db:get-changed-record-ids dbstruct params)) - ((get-run-record-ids) (apply db:get-run-record-ids dbstruct params)) + ((get-changed-record-ids) (apply db:get-changed-record-ids dbstruct params)) + ((get-run-record-ids) (apply db:get-run-record-ids dbstruct params)) ;; TESTMETA ((testmeta-get-record) (apply db:testmeta-get-record dbstruct params)) ;; TASKS ((find-task-queue-records) (apply tasks:find-task-queue-records dbstruct params)) Index: client.scm ================================================================== --- client.scm +++ client.scm @@ -39,24 +39,26 @@ (let ((sig (conc (get-host-name) " " (current-process-id)))) (set! *my-client-signature* sig) *my-client-signature*))) ;; Not currently used! But, I think it *should* be used!!! -(define (client:logout serverdat) +#;(define (client:logout serverdat) (let ((ok (and (socket? serverdat) (cdb:logout serverdat *toppath* (client:get-signature))))) ok)) -(define (client:connect iface port) - (case (server:get-transport) +#;(define (client:connect iface port) + (http-transport:client-connect iface port) + #;(case (server:get-transport) ((rpc) (rpc:client-connect iface port)) ((http) (http:client-connect iface port)) ((zmq) (zmq:client-connect iface port)) (else (rpc:client-connect iface port)))) (define (client:setup areapath #!key (remaining-tries 100) (failed-connects 0)) - (case (server:get-transport) + (client:setup-http areapath remaining-tries: remaining-tries failed-connects: failed-connects) + #;(case (server:get-transport) ((rpc) (rpc-transport:client-setup remaining-tries: remaining-tries failed-connects: failed-connects)) ;;(client:setup-rpc run-id)) ((http)(client:setup-http areapath remaining-tries: remaining-tries failed-connects: failed-connects)) (else (rpc-transport:client-setup remaining-tries: remaining-tries failed-connects: failed-connects)))) ;; (client:setup-rpc run-id)))) ;; Do all the connection work, look up the transport type and set up the Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -889,11 +889,11 @@ *db-cache-path* (if *toppath* ;; common:get-create-writeable-dir (handle-exceptions exn (begin - (debug:print-error 0 *default-log-port* "Couldn't create path to " dbdir) + (debug:print-error 0 *default-log-port* "Couldn't create path to " *db-cache-path*) (exit 1)) (let ((dbpath (common:get-create-writeable-dir (list (conc "/tmp/" (current-user-name) "/megatest_localdb/" (common:get-testsuite-name) "/" @@ -1219,25 +1219,25 @@ (args-testpatt (or (args:get-arg "-testpatt") (args:get-arg "-runtests") "%")) (rtestpatt (if rconf (runconfigs-get rconf testpatt-key) #f))) (cond ((or (args:get-arg "--modepatt") (args:get-arg "-modepatt")) ;; modepatt is a forced setting, when set it MUST refer to an existing PATT in the runconfig (if rconf - (let* ((patts-from-mode-patt (runconfigs-get rconf testpatt-key))) - (debug:print-info 0 *default-log-port* "modepatt defined is: "testpatt-key" runconfigs values for " testpatt-key " " patts-from-mode-patt) - patts-from-mode-patt) - (begin - (debug:print-info 0 *default-log-port* " modepatt defined is: "testpatt-key" runconfigs values for " testpatt-key " " patts-from-mode-patt) - #f))) ;; We do NOT fall back to "%" + (let* ((patts-from-mode-patt (runconfigs-get rconf testpatt-key))) + (debug:print-info 0 *default-log-port* "modepatt defined is: "testpatt-key" runconfigs values for " testpatt-key " " patts-from-mode-patt) + patts-from-mode-patt) + (begin + (debug:print-info 0 *default-log-port* " modepatt defined is: "testpatt-key" runconfigs values for " testpatt-key) ;; " " patts-from-mode-patt) + #f))) ;; We do NOT fall back to "%" ;; (tags-testpatt ;; (debug:print-info 0 *default-log-port* "-tagexpr "tagexpr" selects testpatt "tags-testpatt) ;; tags-testpatt) ((and (equal? args-testpatt "%") rtestpatt) (debug:print-info 0 *default-log-port* "testpatt defined in "testpatt-key" from runconfigs: " rtestpatt) rtestpatt) (else - (debug:print-info 0 *default-log-port* "using testpatt " args-testpatt " rtestpatt:" rtestpatt) - args-testpatt)))) + (debug:print-info 0 *default-log-port* "using testpatt " args-testpatt " rtestpatt:" rtestpatt) + args-testpatt)))) (define (common:false-on-exception thunk #!key (message #f)) (handle-exceptions exn @@ -2931,12 +2931,10 @@ (queue-push cmddat) ;; put request into the queue (nn-send soc "queued")) ;; reply with "queued" (print "ERROR: ["(common:human-time)"] BAD request " dat)) (loop (nn-recv soc))))) (nn-close soc))) - - ;;====================================================================== ;; D A S H B O A R D U S E R V I E W S ;;====================================================================== Index: dashboard-tests.scm ================================================================== --- dashboard-tests.scm +++ dashboard-tests.scm @@ -49,10 +49,16 @@ ;; C O M M O N ;;====================================================================== (define *dashboard-comment-share-slot* #f) +(define (message-window msg) + (iup:show + (iup:dialog + (iup:vbox + (iup:label msg #:margin "40x40"))))) + (define (dtests:get-pre-command #!key (default-override #f)) (let* ((orig-pre-command "export CMD='") (viewscreen-pre-command "viewscreen ") (use-viewscreen (configf:lookup *configdat* "dashboard" "use-viewscreen")) (default-pre-command (if use-viewscreen viewscreen-pre-command orig-pre-command)) @@ -628,11 +634,11 @@ #:expand "HORIZONTAL" #:font "Courier New, -10" #:action (lambda (obj cnum val) ;; (print "cnum=" cnum) (if (eq? cnum 13) - (command-prox obj))) + (command-proc obj))) )) (command-launch-button (iup:button "Execute!" #:action (lambda (x) (command-proc command-text-box)))) ;; (lambda (x) ;; (let* ((cmd (iup:attribute command-text-box "VALUE")) @@ -823,6 +829,112 @@ ;; Now start keeping the gui updated from the db (refreshdat) ;; update from the db here ;(thread-suspend! other-thread) (if *exit-started* (set! *exit-started* 'ok)))))))))) + +(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)))) + +;; Display the tests as rows of boxes on the test/task pane +;; +(define (dashboard:draw-tests cnv xadj yadj tests-draw-state sorted-testnames test-records) + (canvas-clear! cnv) + (canvas-font-set! cnv "Helvetica, -10") + (let-values (((sizex sizey sizexmm sizeymm) (canvas-size cnv)) + ((originx originy) (canvas-origin cnv))) + ;; (print "originx: " originx " originy: " originy) + ;; (canvas-origin-set! cnv 0 (- (/ sizey 2))) + (if (hash-table-ref/default tests-draw-state 'first-time #t) + (begin + (hash-table-set! tests-draw-state 'first-time #f) + (hash-table-set! tests-draw-state 'scalef 1) + (hash-table-set! tests-draw-state 'tests-info (make-hash-table)) + (hash-table-set! tests-draw-state 'selected-tests (make-hash-table)) + ;; set these + (dcommon:initial-draw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames test-records)) + (dcommon:redraw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames test-records)) + )) + +(define (dboard:tabdat-test-patts-use vec) + (let ((val (dboard:tabdat-test-patts vec)))(if val val ""))) ;;RADT => What is the if for? + +;; additional setters for dboard:data +(define (dboard:tabdat-test-patts-set!-use vec val) + (dboard:tabdat-test-patts-set! vec (if (equal? val "") #f val))) + +;; Extract the various bits of data from tabdat and create the command line equivalent that will be displayed +;; +(define (dashboard:update-run-command tabdat) + (let* ((cmd-tb (dboard:tabdat-command-tb tabdat)) + (cmd (dboard:tabdat-command tabdat)) + (test-patt (let ((tp (dboard:tabdat-test-patts tabdat))) + (if (or (not tp) + (equal? tp "")) + "%" + tp))) + (states (dboard:tabdat-states tabdat)) + (statuses (dboard:tabdat-statuses tabdat)) + (target (let ((targ-list (dboard:tabdat-target tabdat))) + (if targ-list (string-intersperse targ-list "/") "no-target-selected"))) + (run-name (dboard:tabdat-run-name tabdat)) + (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) + ((run) + (set! full-cmd (conc full-cmd + " -run" + " -testpatt " + test-patt + " -target " + target + " -runname " + run-name + " -clean-cache" + ))) + ((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))) + +(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)) + +;; if tab-num passed in then use it, otherwise look in commondat at curr-tab-num +;; adds the updater passed in the updaters list at that hashkey +;; +(define (dboard:commondat-add-updater commondat updater #!key (tab-num #f)) + (let* ((tnum (or tab-num + (dboard:commondat-curr-tab-num commondat))) + (curr-updaters (hash-table-ref/default (dboard:commondat-updaters commondat) tnum '()))) + (hash-table-set! (dboard:commondat-updaters commondat) + tnum + (cons updater curr-updaters)))) Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -226,11 +226,11 @@ (readyfname (conc parent-dir "/.ready-" raw-fname)) (readyexists (common:file-exists? readyfname))) (if (not readyexists) (common:simple-file-lock-and-wait lockfname)) (let ((db (sqlite3:open-database fname))) - (sqlite3:set-busy-handler! db (make-busy-timeout 136000)) + (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 136000)) (sqlite3:execute db "PRAGMA synchronous = 0;") (if (and (configf:lookup *configdat* "setup" "tmp_mode") (string-match "^/tmp/.*" fname)) (begin ;;(print "DEBUG: Setting tmp_mode for " fname) (sqlite3:execute db (configf:lookup *configdat* "setup" "tmp_mode")) @@ -617,11 +617,11 @@ ((equal? fname "monitor.db") (sqlite3:execute "DELETE FROM servers WHERE state LIKE 'defunct%';")) (else (sqlite3:execute db "vacuum;"))) - (finalize! db) + (sqlite3:finalize! db) #t)))))) ;; tbls is ( ("tablename" ( "field1" [#f|proc1] ) ( "field2" [#f|proc2] ) .... ) ) ;; db's are dbdat's ;; @@ -1109,11 +1109,11 @@ (debug:print-info 0 *default-log-port* "Sync of " res " records from newdb to olddb completed in " sync-time " seconds pid="(current-process-id)) (debug:print-info 0 *default-log-port* "No sync needed, last updated " (- start-time last-update) " seconds ago"))) res)) ;; keeping it around for debugging purposes only -(define (open-run-close-no-exception-handling proc idb . params) +#;(define (open-run-close-no-exception-handling proc idb . params) (debug:print-info 11 *default-log-port* "open-run-close-no-exception-handling START given a db=" (if idb "yes " "no ") ", params=" params) (print "I don't work anymore. open-run-close-no-exception-handling needs fixing or removing...") (exit) (if (or *db-write-access* (not #t)) ;; was: (member proc * db:all-write-procs *))) @@ -1128,11 +1128,11 @@ (if (not idb)(sqlite3:finalize! dbstruct)) (debug:print-info 11 *default-log-port* "open-run-close-no-exception-handling END" ) res) #f)) -(define (open-run-close-exception-handling proc idb . params) +#;(define (open-run-close-exception-handling proc idb . params) (handle-exceptions exn (let ((sleep-time (random 30)) (err-status ((condition-property-accessor 'sqlite3 'status #f) exn))) (case err-status @@ -1148,11 +1148,11 @@ (debug:print-info 0 *default-log-port* "trying db call one more time....this may never recover, if necessary kill process " (current-process-id) " on host " (get-host-name) " to clean up"))) (apply open-run-close-exception-handling proc idb params)) (apply open-run-close-no-exception-handling proc idb params))) ;; (define open-run-close -(define open-run-close open-run-close-exception-handling) +#;(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) @@ -1461,11 +1461,11 @@ db "SELECT id FROM archive_blocks WHERE archive_disk_id=? AND disk_path=?;" bdisk-id archive-path) (if res ;; record exists, update du if applicable and return res (begin - (if du (sqlite3:exectute db "UPDATE archive_blocks SET last_du=?,last_du_time=(strftime('%s','now')) + (if du (sqlite3:execute db "UPDATE archive_blocks SET last_du=?,last_du_time=(strftime('%s','now')) WHERE archive_disk_id=? AND disk_path=?;" bdisk-id archive-path du)) res) (begin (sqlite3:execute db "INSERT OR REPLACE INTO archive_blocks (archive_disk_id,disk_path,last_du) @@ -1518,11 +1518,11 @@ (define (open-logging-db) (let* ((dbpath (conc (if *toppath* (conc *toppath* "/") "") "logging.db")) ;; fname) (dbexists (common:file-exists? dbpath)) (db (sqlite3:open-database dbpath)) - (handler (make-busy-timeout (if (args:get-arg "-override-timeout") + (handler (sqlite3:make-busy-timeout (if (args:get-arg "-override-timeout") (string->number (args:get-arg "-override-timeout")) 136000)))) ;; 136000))) (sqlite3:set-busy-handler! db handler) (if (not dbexists) (begin @@ -1934,11 +1934,11 @@ (define (db:open-no-sync-db) (let* ((dbpath (db:dbfile-path)) (dbname (conc dbpath "/no-sync.db")) (db-exists (common:file-exists? dbname)) (db (sqlite3:open-database dbname))) - (sqlite3:set-busy-handler! db (make-busy-timeout 136000)) + (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 136000)) (if (not db-exists) (begin (sqlite3:execute db "PRAGMA synchronous = 0;") (sqlite3:execute db "CREATE TABLE IF NOT EXISTS no_sync_metadat (var TEXT,val TEXT, CONSTRAINT no_sync_metadat_constraint UNIQUE (var));") (sqlite3:execute db "PRAGMA journal_mode=WAL;"))) @@ -4109,17 +4109,18 @@ ;; (define (db:get-state-status-summary dbstruct run-id testname) (let ((res '())) (db:with-db dbstruct #f #f - (sqlite3:for-each-row - (lambda (state status count) - (set! res (cons (vector state status count) res))) - db - "SELECT state,status,count(state) FROM tests WHERE run_id=? AND testname=? AND item_path='' GROUP BY state,status;" - run-id testname) - res))) + (lambda (db) + (sqlite3:for-each-row + (lambda (state status count) + (set! res (cons (vector state status count) res))) + db + "SELECT state,status,count(state) FROM tests WHERE run_id=? AND testname=? AND item_path='' GROUP BY state,status;" + run-id testname) + res)))) (define (db:get-latest-host-load dbstruct raw-hostname) (let* ((hostname (string-substitute "\\..*$" "" raw-hostname)) (res (cons -1 0))) (db:with-db @@ -4569,10 +4570,11 @@ ;; (if (not ever-seen)(set! result (cons waitontest-name result))))) ((not ever-seen) (set! result (append (if (null? waiton-tests)(list waitontest-name) waiton-tests) result)))))) waitons) (delete-duplicates result))))) + ;;====================================================================== ;; To sync individual run ;;====================================================================== (define (db:get-run-record-ids dbstruct target run keynames test-patt) (let ((backcons (lambda (lst item)(cons item lst)))) @@ -4587,15 +4589,15 @@ " AND ")) (run-qry (conc "SELECT id FROM runs WHERE " keystr " and runname='" run"'")) (test-qry (conc "SELECT id FROM tests WHERE run_id in (" run-qry ") and testname like '" test-patt "'"))) (print run-qry) (print test-qry) - `((runs . ,(fold-row backcons '() db run-qry)) - (tests . ,(fold-row backcons '() db test-qry)) - (test_steps . ,(fold-row backcons '() db (conc "SELECT id FROM test_steps WHERE test_id in (" test-qry ")"))) - (test_data . ,(fold-row backcons '() db (conc "SELECT id FROM test_data WHERE test_id in (" test-qry ")" ))) - )))))) + `((runs . ,(sqlite3:fold-row backcons '() db run-qry)) + (tests . ,(sqlite3:fold-row backcons '() db test-qry)) + (test_steps . ,(sqlite3:fold-row backcons '() db (conc "SELECT id FROM test_steps WHERE test_id in (" test-qry ")"))) + (test_data . ,(sqlite3:fold-row backcons '() db (conc "SELECT id FROM test_data WHERE test_id in (" test-qry ")" ))) + )))))) ;;====================================================================== ;; Just for sync, procedures to make sync easy ;;====================================================================== @@ -4606,16 +4608,16 @@ ;; no transaction, allow the db to be accessed between the big queries (let ((backcons (lambda (lst item)(cons item lst)))) (db:with-db dbstruct #f #f (lambda (db) - `((runs . ,(fold-row backcons '() db "SELECT id FROM runs WHERE last_update>=?" since-time)) - (tests . ,(fold-row backcons '() db "SELECT id FROM tests WHERE last_update>=?" since-time)) - (test_steps . ,(fold-row backcons '() db "SELECT id FROM test_steps WHERE last_update>=?" since-time)) - (test_data . ,(fold-row backcons '() db "SELECT id FROM test_data WHERE last_update>=?" since-time)) + `((runs . ,(sqlite3:fold-row backcons '() db "SELECT id FROM runs WHERE last_update>=?" since-time)) + (tests . ,(sqlite3:fold-row backcons '() db "SELECT id FROM tests WHERE last_update>=?" since-time)) + (test_steps . ,(sqlite3:fold-row backcons '() db "SELECT id FROM test_steps WHERE last_update>=?" since-time)) + (test_data . ,(sqlite3:fold-row backcons '() db "SELECT id FROM test_data WHERE last_update>=?" since-time)) ;; (test_meta . ,(fold-row backcons '() db "SELECT id FROM test_meta WHERE last_update>?" since-time)) - (run_stats . ,(fold-row backcons '() db "SELECT id FROM run_stats WHERE last_update>=?" since-time)) + (run_stats . ,(sqlite3:fold-row backcons '() db "SELECT id FROM run_stats WHERE last_update>=?" since-time)) ))))) ;;====================================================================== ;; Extract ods file from the db ;;====================================================================== Index: dcommon.scm ================================================================== --- dcommon.scm +++ dcommon.scm @@ -43,10 +43,75 @@ ;;====================================================================== ;; C O M M O N D A T A S T R U C T U R E ;;====================================================================== ;; +;; data common to all tabs goes here +;; +(defstruct dboard:commondat + ((curr-tab-num 0) : number) + please-update + tabdats + update-mutex + updaters + updating + uidat ;; needs to move to tabdat at some time + hide-not-hide-tabs + ) + +(define (dboard:commondat-make) + (make-dboard:commondat + curr-tab-num: 0 + tabdats: (make-hash-table) + please-update: #t + update-mutex: (make-mutex) + updaters: (make-hash-table) + updating: #f + hide-not-hide-tabs: #f + )) + +;; RADT => Matrix defstruct addition +(defstruct dboard:graph-dat + ((id #f) : string) + ((color #f) : vector) + ((flag #t) : boolean) + ((cell #f) : number) + ) + +;; data for runs, tests etc. was used in run summary? +;; +(defstruct dboard:runsdat + ;; new system + runs-index ;; target/runname => colnum + tests-index ;; testname/itempath => rownum + matrix-dat ;; vector of vectors rows/cols + ) + +(define (dboard:runsdat-make-init) + (make-dboard:runsdat + runs-index: (make-hash-table) + tests-index: (make-hash-table) + matrix-dat: (make-sparse-array))) + +;; used to keep the rundata from rmt:get-tests-for-run +;; in sync. +;; +(defstruct dboard:rundat + run + tests-drawn ;; list of id's already drawn on screen + tests-notdrawn ;; list of id's NOT already drawn + rowsused ;; hash of lists covering what areas used - replace with quadtree + hierdat ;; put hierarchial sorted list here + tests ;; hash of id => testdat + ((tests-by-name (make-hash-table)) : hash-table) ;; hash of testfullname => testdat + key-vals + ((last-update 0) : number) ;; last query to db got records from before last-update + ((last-db-time 0) : number) ;; last timestamp on megatest.db + ((data-changed #f) : boolean) + ((run-data-offset 0) : number) ;; get only 100 items per call, set back to zero when received less than 100 items + (db-path #f)) + ;;====================================================================== ;; D O T F I L E ;;====================================================================== @@ -81,11 +146,11 @@ ;; (define (dcommon:modifiy-if-different mtrx cell-name new-val prev-changed) (let ((curr-val (iup:attribute mtrx cell-name))) (if (not (equal? curr-val new-val)) (begin - (iup:attribute-set! mtrx cell-name col-name) + (iup:attribute-set! mtrx cell-name new-val) ;; was col-name #t) ;; need a re-draw prev-changed))) ;; TO-DO @@ -270,11 +335,11 @@ ;; (if changed (iup:attribute-set! (dboard:tabdat-runs-matrix data) "REDRAW" "ALL")) ;; ;; (debug:print 2 *default-log-port* "run-changes: " run-changes) ;; ;; (debug:print 2 *default-log-port* "test-changes: " test-changes) ;; (list run-changes all-test-changes))) -(define (dcommon:runsdat-get-col-num dat target runname force-set) +#;(define (dcommon:runsdat-get-col-num dat target runname force-set) (let* ((runs-index (dboard:runsdat-runs-index dat)) (col-name (conc target "/" runname)) (res (hash-table-ref/default runs-index col-name #f))) (if res res @@ -281,11 +346,11 @@ (if force-set (let ((max-col-num (+ 1 (common:max (cons-1 (hash-table-values runs-index)))))) (hash-table-set! runs-index col-name max-col-num) max-col-num))))) -(define (dcommon:runsdat-get-row-num dat testname itempath force-set) +#;(define (dcommon:runsdat-get-row-num dat testname itempath force-set) (let* ((tests-index (dboard:runsdat-runs-index dat)) (row-name (conc testname "/" itempath)) (res (hash-table-ref/default runs-index row-name #f))) (if res res @@ -448,11 +513,11 @@ (debug:print 2 "ERROR: No test data found for test " test-id ", exiting") (exit 1)) (let* ((rundir (if testdat (db:test-get-rundir testdat) - logfile)) + (current-directory))) ;; logfile)) (testfullname (if testdat (db:test-get-fullname testdat) "Gathering data ...")) (xterm (lambda () (if (directory-exists? rundir) (let* ((shell (if (get-environment-variable "SHELL") (conc "-e " (get-environment-variable "SHELL")) @@ -722,11 +787,11 @@ (iup:menu-item "Files" (iup:menu ;; Note that you can use either #:action or action: for options (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-set! area-name "VALUE" ;; was source-tb, no idea what is correct (iup:attribute fd "VALUE")) (iup:destroy! fd)))) ;; (lambda (obj) ;; (iup:show (iup:file-dialog)) ;; (print "File->open " obj))) @@ -1330,6 +1395,63 @@ (define (dcommon:run-html-viewer lfilename) (let ((htmlviewercmd (configf:lookup *configdat* "setup" "htmlviewercmd"))) (if htmlviewercmd (system (conc "(" htmlviewercmd " " lfilename " ) &")) (iup:send-url lfilename)))) + +(define (dashboard:monitor-changed? commondat tabdat) + (let* ((run-update-time (current-seconds)) + (monitor-db-path (dboard:tabdat-monitor-db-path tabdat)) + (monitor-modtime (if (and monitor-db-path (common:file-exists? monitor-db-path)) + (file-modification-time monitor-db-path) + -1))) + (if (and (eq? (dboard:commondat-curr-tab-num commondat) 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) + #t) + #f))) + +;; DOES NOT WORK RELIABLY WITH /tmp WAL mode files. Timestamps only change when the db +;; is closed (I think). If db dir starts with /tmp always return true +;; +(define (dashboard:database-changed? commondat tabdat #!key (context-key 'default)) + (let* ((run-update-time (current-seconds)) + (dbdir (dboard:tabdat-dbdir tabdat)) + (modtime (dashboard:get-youngest-run-db-mod-time dbdir)) + (recalc (dashboard:recalc modtime + (dboard:commondat-please-update commondat) + (dboard:get-last-db-update tabdat context-key)))) + ;; (dboard:tabdat-last-db-update tabdat)))) + (if recalc + (dboard:set-last-db-update! tabdat context-key run-update-time)) + (dboard:commondat-please-update-set! commondat #f) + recalc)) + +(define (dashboard:get-youngest-run-db-mod-time dbdir) + (handle-exceptions + exn + (begin + (debug:print 2 *default-log-port* "WARNING: error in accessing databases in get-youngest-run-db-mod-time: " ((condition-property-accessor 'exn 'message) exn) " db-dir="dbdir) + (current-seconds)) ;; something went wrong - just print an error and return current-seconds + (common:max (map (lambda (filen) + (file-modification-time filen)) + (glob (conc dbdir "/*.db*")))))) + +(define (dboard:get-last-db-update tabdat context) + (hash-table-ref/default (dboard:tabdat-last-db-update tabdat) context 0)) + +(define (dboard:set-last-db-update! tabdat context newtime) + (hash-table-set! (dboard:tabdat-last-db-update tabdat) context newtime)) + +;; point inside line +;; +(define-inline (dashboard:px-between px lx1 lx2) + (and (< lx1 px)(> lx2 px))) + +(define (dashboard:recalc modtime please-update-buttons last-db-update-time) + (or please-update-buttons + (and ;; (> (current-milliseconds)(+ *last-recalc-ended-time* 150)) ;; can't use this - it needs to be tab specific + (> modtime (- last-db-update-time 3)) ;; add three seconds of margin + (> (current-seconds)(+ last-db-update-time 1))))) Index: env.scm ================================================================== --- env.scm +++ env.scm @@ -68,15 +68,15 @@ (for-each-row (lambda (row) (let ((var (car row)) (val (cadr row))) (hash-table-set! result var - (if (and (hash-table-ref/default results var #f) + (if (and (hash-table-ref/default result var #f) (assoc var paths)) ;; this var is a path and there is a previous path (let ((sep (cadr (assoc var paths)))) - (env:merge-path-envvar sep (hash-table-ref results var) valb)) - valb))))) + (env:merge-path-envvar sep (hash-table-ref result var) val)) + val))))) (sql db "SELECT var,val FROM envvars WHERE context=?") context)) contexts) result)) Index: http-transport.scm ================================================================== --- http-transport.scm +++ http-transport.scm @@ -58,10 +58,13 @@ ;; (define *db:process-queue-mutex* (make-mutex)) (define (http-transport:run hostn) + ;; Configurations for server + (tcp-buffer-size 2048) + (max-connections 2048) (debug:print 2 *default-log-port* "Attempting to start the server ...") (let* ((db #f) ;; (open-db)) ;; we don't want the server to be opening and closing the db unnecesarily (hostname (get-host-name)) (ipaddrstr (let ((ipstr (if (string=? "-" hostn) ;; (string-intersperse (map number->string (u8vector->list (hostname->ip hostname))) ".") @@ -306,11 +309,11 @@ (if (vector-ref res 0) ;; this is the first flag or the second flag? res ;; this is the *inner* vector? seriously? why? (if (debug:debug-mode 11) (let ((call-chain (get-call-chain))) ;; note: this code also called in nmsg-transport - consider consolidating it (print-call-chain (current-error-port)) - (debug:print-error 11 *default-log-port* "error above occured at server, res=" res " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print-error 11 *default-log-port* "error above occured at server, res=" res) ;; " message: " ((condition-property-accessor 'exn 'message) exn)) (debug:print 11 *default-log-port* " server call chain:") (pp (vector-ref res 1) (current-error-port)) (signal (vector-ref res 0))) res)) (signal (make-composite-condition @@ -379,17 +382,18 @@ (define (http-transport:keep-running) ;; if none running or if > 20 seconds since ;; server last used then start shutdown ;; This thread waits for the server to come alive (debug:print-info 0 *default-log-port* "Starting the sync-back, keep alive thread in server") - (let* ((tmp-area (common:get-db-tmp-area)) + (let* ((sdat #f) + (tmp-area (common:get-db-tmp-area)) (started-file (conc tmp-area "/.server-started")) (server-start-time (current-seconds)) (server-info (let loop ((start-time (current-seconds)) (changed #t) (last-sdat "not this")) - (let ((sdat #f)) + (begin ;; let ((sdat #f)) (thread-sleep! 0.01) (debug:print-info 0 *default-log-port* "Waiting for server alive signature") (mutex-lock! *heartbeat-mutex*) (set! sdat *server-info*) (mutex-unlock! *heartbeat-mutex*) @@ -415,16 +419,16 @@ (T . server) (pid . ,(current-process-id)) (ipaddr . ,(car sdat)) (port . ,(cadr sdat)) (msg . "Transport died?")) - *configdat* #t) + *configdat* #t) (exit)) (loop start-time (equal? sdat last-sdat) sdat))))))) - (iface (car server-info)) + (iface (car server-info)) (port (cadr server-info)) (last-access 0) (server-timeout (server:expiration-timeout)) (server-going #f) (server-log-file (args:get-arg "-log"))) ;; always set when we are a server @@ -654,11 +658,11 @@ "

Server Stats

" (http-transport:stats-table) "
" (http-transport:runs linkpath) "
" - (http-transport:run-stats) + ;; (http-transport:run-stats) "" ))) (define (http-transport:stats-table) (mutex-lock! *heartbeat-mutex*) @@ -689,14 +693,14 @@ (map (lambda (p) (conc "" p "
")) files)) " "))) -(define (http-transport:run-stats) +#;(define (http-transport:run-stats) (let ((stats (open-run-close db:get-running-stats #f))) (conc "" (string-intersperse (map (lambda (stat) (conc "")) stats) " ") "
" (car stat) "" (cadr stat) "
"))) Index: items.scm ================================================================== --- items.scm +++ items.scm @@ -117,11 +117,11 @@ #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))) + (let ((valid-values (let ((s (configf:lookup *configdat* "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 @@ -1247,11 +1247,11 @@ (cons 1 (conc *toppath* "/runs")) (loop (car tail) (cdr tail)))))))))))))) ;; the code creates the necessary directories if it does not exist and returns the path. (define (launch:test-copy test-src-path test-path) - (let* ((ovrcmd (let ((cmd (config-lookup *configdat* "setup" "testcopycmd"))) + (let* ((ovrcmd (let ((cmd (configf: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))) @@ -1300,11 +1300,11 @@ (toptest-path (conc disk-path (if contour (conc "/" contour) "") "/" testtop-base)) (test-path (conc disk-path (if contour (conc "/" contour) "") "/" test-base)) ;; ensure this exists first as links to subtests must be created there (linktree (common:get-linktree)) - ;; WAS: (let ((rd (config-lookup *configdat* "setup" "linktree"))) + ;; WAS: (let ((rd (configf:lookup *configdat* "setup" "linktree"))) ;; (if rd rd (conc *toppath* "/runs")))) ;; which seems wrong ... (lnkbase (conc linktree (if contour (conc "/" contour) "") "/" target "/" runname)) (lnkpath (conc lnkbase "/" testname)) @@ -1511,23 +1511,23 @@ ;; for tconfig, why do we allow fallback to test-conf? (tconfig (or (tests:get-testconfig test-name item-path tregistry #t force-create: #t) (begin (debug:print 0 *default-log-port* "WARNING: falling back to pre-calculated testconfig. This is likely not desired.") test-conf))) ;; force re-read now that all vars are set - (useshell (let ((ush (config-lookup *configdat* "jobtools" "useshell"))) + (useshell (let ((ush (configf:lookup *configdat* "jobtools" "useshell"))) (if ush (if (equal? ush "no") ;; must use "no" to NOT use shell #f ush) #t))) ;; default is yes - (runscript (config-lookup tconfig "setup" "runscript")) + (runscript (configf:lookup tconfig "setup" "runscript")) (ezsteps (> (length (hash-table-ref/default tconfig "ezsteps" '())) 0)) ;; don't send all the steps, could be big, just send a flag (subrun (> (length (hash-table-ref/default tconfig "subrun" '())) 0)) ;; send a flag to process a subrun - ;; (diskspace (config-lookup tconfig "requirements" "diskspace")) - ;; (memory (config-lookup tconfig "requirements" "memory")) - ;; (hosts (config-lookup *configdat* "jobtools" "workhosts")) ;; I'm pretty sure this was never completed - (remote-megatest (config-lookup *configdat* "setup" "executable")) + ;; (diskspace (configf:lookup tconfig "requirements" "diskspace")) + ;; (memory (configf:lookup tconfig "requirements" "memory")) + ;; (hosts (configf:lookup *configdat* "jobtools" "workhosts")) ;; I'm pretty sure this was never completed + (remote-megatest (configf:lookup *configdat* "setup" "executable")) (run-time-limit (or (configf:lookup tconfig "requirements" "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 @@ -1539,11 +1539,11 @@ (case (string->symbol exe) ((dboard) "../megatest") ((mtest) "../megatest") ((dashboard) "megatest") (else exe))))) - (launcher (common:get-launcher *configdat* test-name item-path)) ;; (config-lookup *configdat* "jobtools" "launcher")) + (launcher (common:get-launcher *configdat* test-name item-path)) ;; (configf:lookup *configdat* "jobtools" "launcher")) (test-sig (conc (common:get-testsuite-name) ":" test-name ":" item-path)) ;; (item-list->path itemdat))) ;; test-path is the full path including the item-path (work-area #f) (toptest-work-area #f) ;; for iterated tests the top test contains data relevant for all (diskpath #f) (cmdparms #f) @@ -1706,11 +1706,11 @@ ;; - it it's run directory correct for the test ;; - is there a controlling mtest (maybe stuck) ;; 2. if recovery is needed watch pid ;; - when it exits take the exit code and do the needful ;; - (let* ((pid (rmt:test-get-top-process-id run-id test-id)) + (let* ((pid (rmt:test-get-top-process-pid run-id test-id)) (psres (with-input-from-pipe (conc "ps -F -u " (current-user-name) " | grep -E '" pid " ' | grep -v 'grep -E " pid "'") (lambda () (read-line)))) (rundir (if (string? psres) ;; real process owned by user Index: portlogger.scm ================================================================== --- portlogger.scm +++ portlogger.scm @@ -25,20 +25,19 @@ (declare (unit portlogger)) (declare (uses db)) ;; lsof -i - (define (portlogger:open-db fname) (let* ((avail (tasks:wait-on-journal fname 5 remove: #t)) ;; wait up to about 10 seconds for the journal to go away (exists (common:file-exists? fname)) (db (if avail (sqlite3:open-database fname) (begin (system (conc "rm -f " fname)) (sqlite3:open-database fname)))) - (handler (make-busy-timeout 136000)) + (handler (sqlite3:make-busy-timeout 136000)) (canwrite (file-write-access? fname))) ;; (db-init (lambda () ;; (sqlite3:execute ;; db ;; "CREATE TABLE IF NOT EXISTS ports ( Index: process.scm ================================================================== --- process.scm +++ process.scm @@ -99,11 +99,11 @@ (if (not (eof-object? curr)) (loop (read-line fh) (append result (list (proc curr)))) (begin (close-input-port fh) - (close-input-port fhe) + ;;(close-input-port fhe) (close-output-port fho) result)))))) (define (process:cmd-run-proc-each-line-alt cmd proc) (let* ((fh (open-input-pipe cmd)) Index: rmt.scm ================================================================== --- rmt.scm +++ rmt.scm @@ -342,11 +342,11 @@ (resdat (if (not (and read-only qry-is-write)) (let ((v (api:execute-requests dbstruct-local (vector (symbol->string cmd) params)))) (handle-exceptions ;; there has been a long history of receiving strange errors from values returned by the client when things go wrong.. exn ;; This is an attempt to detect that situation and recover gracefully (begin - (debug:print0 *default-log-port* "ERROR: bad data from server " v " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 *default-log-port* "ERROR: bad data from server " v " message: " ((condition-property-accessor 'exn 'message) exn)) (vector #t '())) ;; should always get a vector but if something goes wrong return a dummy (if (and (vector? v) (> (vector-length v) 1)) (let ((newvec (vector (vector-ref v 0)(vector-ref v 1)))) newvec) ;; by copying the vector while inside the error handler we should force the detection of a corrupted record Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -246,11 +246,11 @@ );; obviously haven't had any work to do for a while (else 0))) (let* ((num-running (rmt:get-count-tests-running run-id)) (num-running-in-jobgroup (rmt:get-count-tests-running-in-jobgroup run-id jobgroup)) - (job-group-limit (let ((jobg-count (config-lookup *configdat* "jobgroups" jobgroup))) + (job-group-limit (let ((jobg-count (configf:lookup *configdat* "jobgroups" jobgroup))) (if (string? jobg-count) (string->number jobg-count) jobg-count)))) (if (> (+ num-running num-running-in-jobgroup) 0) (runs:inc-can-run-more-tests-count runsdat)) ;; (set! *runs:can-run-more-tests-count* (+ *runs:can-run-more-tests-count* 1))) @@ -386,11 +386,12 @@ (waitors-upon (make-hash-table)) ;; given a test, return list of tests waiting upon this test. (task-key (conc (hash-table->alist flags) " " (get-host-name) " " (current-process-id))) ;; (tdbdat (tasks:open-db)) (config-reruns (let ((x (configf:lookup *configdat* "setup" "reruns"))) (if x (string->number x) #f))) - (allowed-tests #f)) + (allowed-tests #f) + (runconf #f)) ;; check if readonly (when readonly-mode (debug:print-error 0 *default-log-port* "megatest.db is readonly. Cannot proceed.") (exit 1)) @@ -546,11 +547,11 @@ (let*-values (((waitons waitors config) (tests:get-waitons hed all-tests-registry)) ;; NOTE: Have the config - can extract [waitons] section ((hed-mode) - (let ((m (config-lookup config "requirements" "mode"))) + (let ((m (configf:lookup config "requirements" "mode"))) (if m (map string->symbol (string-split m)) '(normal)))) ((hed-itemized-waiton) ;; are items in hed waiting on items of waiton? (not (null? (lset-intersection eq? hed-mode '(itemmatch itemwait))))) ) (debug:print-info 8 *default-log-port* "waitons: " waitons) @@ -567,11 +568,11 @@ (if (not (hash-table-ref/default test-records hed #f)) ;; waiton-tconfig below will be #f until that test is visted here at least once (hash-table-set! test-records ;; BB: we are doing a manual make-tests:testqueue hed (vector hed ;; 0 ;; testname config ;; 1 waitons ;; 2 - (config-lookup config "requirements" "priority") ;; priority 3 + (configf:lookup config "requirements" "priority") ;; priority 3 (tests:get-items config) ;; 4 ;; expand the [items] and or [itemstable] into explict items #f ;; itemsdat 5 #f ;; spare - used for item-path waitors ;; ))) @@ -1346,11 +1347,11 @@ (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-retries (configf:lookup *configdat* "setup" "maxretries")) (max-concurrent-jobs (configf:lookup-number *configdat* "setup" "max_concurrent_jobs" default: 50)) (reglen (if (number? reglen-in) reglen-in 1)) (last-time-incomplete (- (current-seconds) 900)) ;; force at least one clean up cycle (last-time-some-running (current-seconds)) ;; (tdbdat (tasks:open-db)) @@ -1416,12 +1417,12 @@ ;; (print "Top of loop, hed=" hed ", tal=" tal " ,reruns=" reruns) (let* ((test-record (hash-table-ref test-records hed)) (test-name (tests:testqueue-get-testname test-record)) (tconfig (tests:testqueue-get-testconfig test-record)) - (jobgroup (config-lookup tconfig "test_meta" "jobgroup")) - (testmode (let ((m (config-lookup tconfig "requirements" "mode"))) + (jobgroup (configf:lookup tconfig "test_meta" "jobgroup")) + (testmode (let ((m (configf:lookup tconfig "requirements" "mode"))) (if m (map string->symbol (string-split m)) '(normal)))) (itemmaps (tests:get-itemmaps tconfig)) ;; (configf:lookup tconfig "requirements" "itemmap")) (priority (tests:testqueue-get-priority test-record)) (itemdat (tests:testqueue-get-itemdat test-record)) ;; itemdat can be a string, list or #f (items (tests:testqueue-get-items test-record)) @@ -2544,11 +2545,11 @@ (rmt:testmeta-add-record test-name))) (for-each (lambda (key) (let* ((idx (cadr key)) (fld (car key)) - (val (config-lookup test-conf "test_meta" fld))) + (val (configf:lookup test-conf "test_meta" fld))) ;; (debug:print 5 *default-log-port* "idx: " idx " fld: " fld " val: " val) (if (and val (not (equal? (vector-ref currrecord idx) val))) (begin (print "Updating " test-name " " fld " to " val) (rmt:testmeta-update-field test-name fld val))))) @@ -2579,11 +2580,11 @@ (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) (debug:print 4 *default-log-port* "runs:rollup-run, keys: " keys " -runname " runname " user: " user) (let* ((db #f) ;; register run operates on the main db (new-run-id (rmt:register-run keyvals runname "new" "n/a" user (args:get-arg "-contour"))) (prev-tests (rmt:get-matching-previous-test-run-records new-run-id "%" "%")) Index: tasks.scm ================================================================== --- tasks.scm +++ tasks.scm @@ -113,11 +113,11 @@ (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))) + (handler (sqlite3:make-busy-timeout 36000))) (if (and exists (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;")) @@ -279,11 +279,11 @@ "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) +#;(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 *default-log-port* "Not starting monitor, already have more than two running") (let* ((megatestdb (conc *toppath* "/megatest.db")) (monitordbf (conc (db:dbfile-path #f) "/monitor.db")) (last-db-update 0)) ;; (file-modification-time megatestdb))) @@ -443,23 +443,23 @@ (db:with-db dbstruct #f #t (lambda (db) (sqlite3:execute db (conc "DELETE FROM tasks_queue WHERE id IN (" task-ids ");"))))) -(define (tasks:process-queue dbstruct) +#;(define (tasks:process-queue dbstruct) (let* ((task (tasks:snag-a-task dbstruct)) (action (if task (tasks:task-get-action task) #f))) (if action (print "tasks:process-queue task: " task)) (if action (case (string->symbol action) ((run) (tasks:start-run dbstruct task)) ((remove) (tasks:remove-runs dbstruct task)) ((lock) (tasks:lock-runs dbstruct task)) ;; ((monitor) (tasks:start-monitor db task)) - ((rollup) (tasks:rollup-runs dbstruct task)) + #;((rollup) (tasks:rollup-runs dbstruct task)) ((updatemeta)(tasks:update-meta dbstruct task)) - ((kill) (tasks:kill-monitors dbstruct task)))))) + #;((kill) (tasks:kill-monitors dbstruct task)))))) (define (tasks:tasks->text tasks) (let ((fmtstr "~10a~10a~10a~12a~20a~12a~12a~10a")) (conc (format #f fmtstr "id" "action" "owner" "state" "target" "runname" "testpatts" "params") "\n" (string-intersperse @@ -469,11 +469,11 @@ (tasks:task-get-action task) (tasks:task-get-owner task) (tasks:task-get-state task) (tasks:task-get-target task) (tasks:task-get-name task) - (tasks:task-get-test task) + (tasks:task-get-testpatt task) ;; (tasks:task-get-item task) (tasks:task-get-params task))) tasks) "\n")))) (define (tasks:set-state dbstruct task-id state) Index: tdb.scm ================================================================== --- tdb.scm +++ tdb.scm @@ -75,13 +75,13 @@ dbexists) (sqlite3:open-database dbpath) (sqlite3:open-database ":memory:")))) (tdb-writeable (and (file-write-access? work-area) (file-write-access? dbpath))) - (handler (make-busy-timeout (if (args:get-arg "-override-timeout") - (string->number (args:get-arg "-override-timeout")) - 136000)))) + (handler (sqlite3:make-busy-timeout (if (args:get-arg "-override-timeout") + (string->number (args:get-arg "-override-timeout")) + 136000)))) (if (and tdb-writeable *db-write-access*) (sqlite3:set-busy-handler! db handler)) (if (not dbexists) Index: tests.scm ================================================================== --- tests.scm +++ tests.scm @@ -42,10 +42,13 @@ (include "db_records.scm") (include "run_records.scm") (include "test_records.scm") (include "js-path.scm") +(define (init-java-script-lib) + (set! *java-script-lib* (conc (common:get-install-area) "/share/js/jquery-3.1.0.slim.min.js")) + ) ;; Call this one to do all the work and get a standardized list of tests ;; gets paths from configs and finds valid tests ;; returns hash of testname --> fullpath ;; @@ -166,16 +169,16 @@ ;; returns waitons waitors tconfigdat ;; (define (tests:get-waitons test-name all-tests-registry) (let* ((config (tests:get-testconfig test-name #f all-tests-registry 'return-procs))) ;; assuming no problems with immediate evaluation, this could be simplified ('return-procs -> #t) (let ((instr (if config - (config-lookup config "requirements" "waiton") + (configf:lookup config "requirements" "waiton") (begin ;; No config means this is a non-existant test (debug:print-error 0 *default-log-port* "non-existent required test \"" test-name "\"") (exit 1)))) (instr2 (if config - (config-lookup config "requirements" "waitor") + (configf:lookup config "requirements" "waitor") ""))) (debug:print-info 8 *default-log-port* "waitons string is " instr ", waitors string is " instr2) (let ((newwaitons (string-split (cond ((procedure? instr) ;; here @@ -1620,12 +1623,12 @@ (b-record (hash-table-ref test-records b)) (a-waitons (or (tests:testqueue-get-waitons a-record) '())) (b-waitons (or (tests:testqueue-get-waitons b-record) '())) (a-config (tests:testqueue-get-testconfig a-record)) (b-config (tests:testqueue-get-testconfig b-record)) - (a-raw-pri (config-lookup a-config "requirements" "priority")) - (b-raw-pri (config-lookup b-config "requirements" "priority")) + (a-raw-pri (configf:lookup a-config "requirements" "priority")) + (b-raw-pri (configf:lookup b-config "requirements" "priority")) (a-priority (mungepriority a-raw-pri)) (b-priority (mungepriority b-raw-pri))) (tests:testqueue-set-priority! a-record a-priority) (tests:testqueue-set-priority! b-record b-priority) ;; (debug:print 0 *default-log-port* "a=" a ", b=" b ", a-waitons=" a-waitons ", b-waitons=" b-waitons) @@ -1815,11 +1818,11 @@ (tal (cdr test-names))) ;; 'return-procs tells the config reader to prep running system but return a proc (debug:print-info 4 *default-log-port* "hed=" hed " at top of loop") ;; don't know item-path at this time, let the testconfig get the top level testconfig (let* ((config (tests:get-testconfig hed #f all-tests-registry 'return-procs)) (waitons (let ((instr (if config - (config-lookup config "requirements" "waiton") + (configf:lookup config "requirements" "waiton") (begin ;; No config means this is a non-existant test (debug:print-error 0 *default-log-port* "non-existent required test \"" hed "\", grep through your testconfigs to find and remove or create the test. Discarding and continuing.") "")))) (debug:print-info 8 *default-log-port* "waitons string is " instr) (string-split (cond @@ -1848,11 +1851,11 @@ (if (not (hash-table-ref/default test-records hed #f)) (hash-table-set! test-records hed (vector hed ;; 0 config ;; 1 waitons ;; 2 - (config-lookup config "requirements" "priority") ;; priority 3 + (configf:lookup config "requirements" "priority") ;; priority 3 (let ((items (hash-table-ref/default config "items" #f)) ;; items 4 (itemstable (hash-table-ref/default config "itemstable" #f))) ;; if either items or items table is a proc return it so test running ;; process can know to call items:get-items-from-config ;; if either is a list and none is a proc go ahead and call get-items @@ -1930,11 +1933,11 @@ (uname (get-uname "-srvpio")) (hostname (get-host-name))) (tests:update-central-meta-info run-id test-id cpuload diskfree minutes uname hostname))) ;; (define (tests:set-partial-meta-info test-id run-id minutes work-area) -(define (tests:set-partial-meta-info test-id run-id minutes work-area remtries) +#;(define (tests:set-partial-meta-info test-id run-id minutes work-area remtries) (let* ((cpuload (get-cpu-load)) (diskfree (get-df (current-directory))) (remtries 10)) (handle-exceptions exn Index: vg.scm ================================================================== --- vg.scm +++ vg.scm @@ -563,11 +563,11 @@ ;; (begin ;; (canvas-foreground-set! cnv fill-color) ;; (canvas-box! cnv llx ulx lly uly))) ;; docs are all over the place on this one.;; w h) (if line-color (canvas-foreground-set! cnv line-color) - (if fill-color + #;(if fill-color (canvas-foreground-set! cnv prev-foreground-color))) (canvas-line! cnv llx ulx lly uly) (canvas-foreground-set! cnv prev-foreground-color) (if text (let* ((prev-font (canvas-font cnv))