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: configf.scm
==================================================================
--- configf.scm
+++ configf.scm
@@ -121,11 +121,11 @@
" extra)))"))
((get g)
(let* ((parts (string-split cmd))
(sect (car parts))
(var (cadr parts)))
- (conc "(lambda (ht)(config-lookup ht \"" sect "\" \"" var "\"))")))
+ (conc "(lambda (ht)(configf:lookup ht \"" sect "\" \"" var "\"))")))
((runconfigs-get rget) (conc "(lambda (ht)(runconfigs-get ht \"" cmd "\"))"))
;; ((rget) (conc "(lambda (ht)(runconfigs-get ht \"" cmd "\"))"))
(else "(lambda (ht)(print \"ERROR\") \"ERROR\")"))))
;; (print "fullcmd=" fullcmd)
(handle-exceptions
@@ -463,11 +463,11 @@
;; if a continued line
(configf:cont-ln-rx ( x whsp val )
(let ((alist (hash-table-ref/default res curr-section-name '())))
(if var-flag ;; if set to a string then we have a continued var
(let ((newval (conc
- (config-lookup res curr-section-name var-flag) "\n"
+ (configf:lookup res curr-section-name var-flag) "\n"
;; trim lead from the incoming whsp to support some indenting.
(if lead
(string-substitute (regexp lead) "" whsp)
"")
val)))
@@ -498,11 +498,11 @@
(let ((configdat (if configfile
(read-config configfile #f #t environ-patt: environ-patt post-section-procs: (list (cons "^fields$" set-fields)) #f))))
(if toppath (change-directory curr-dir))
(list configdat toppath configfile fname))))
-(define (config-lookup cfgdat section var)
+(define (configf:lookup cfgdat section var)
(if (hash-table? cfgdat)
(let ((sectdat (hash-table-ref/default cfgdat section '())))
(if (null? sectdat)
#f
(let ((match (assoc var sectdat)))
@@ -519,11 +519,11 @@
;; (configf:var-is? cfgdat "foo" "var" "yes") => #t
;;
(define (configf:var-is? cfgdat section var expected-val)
(equal? (configf:lookup cfgdat section var) expected-val))
-(define configf:lookup config-lookup)
+(define config-lookup configf:lookup)
(define configf:read-file read-config)
;; safely look up a value that is expected to be a number, return
;; a default (#f unless provided)
;;
@@ -634,11 +634,11 @@
(sechash (make-hash-table)) ;; current section hash, init with hash for "default" section
(new #f) ;; put the line to be used in new, if it is to be deleted the set new to #f
(secname #f))
;; step 2: Flatten multiline entries
- (if (not (null? fdat))(set! fdat (configf:compress-multi-line fdat)))
+ (if (not (null? fdat))(set! fdat (configf:compress-multi-lines fdat)))
;; step 3: Modify values per contents of "indat" and remove absent values
(if (not (null? fdat))
(let loop ((hed (car fdat))
(tal (cadr fdat))
@@ -649,19 +649,19 @@
(configf:comment-rx _ (set! res (append res (list hed)))) ;; (loop (read-line inp) curr-section-name #f #f))
(configf:blank-l-rx _ (set! res (append res (list hed)))) ;; (loop (read-line inp) curr-section-name #f #f))
(configf:section-rx ( x section-name ) (let ((section-hash (hash-table-ref/default refdat section-name #f)))
(if (not section-hash)
(let ((newhash (make-hash-table)))
- (hash-table-set! refhash section-name newhash)
+ (hash-table-set! refdat section-name newhash) ;; was refhash - not sure that refdat is correct here
(set! sechash newhash))
(set! sechash section-hash))
(set! new hed) ;; will append this at the bottom of the loop
(set! secname section-name)
))
;; No need to process key cmd, let it fall though to key val
(configf:key-val-pr ( x key val )
- (let ((newval (config-lookup indat sec key)))
+ (let ((newval (configf:lookup indat secname key))) ;; was sec, bug or correct?
;; can handle newval == #f here => that means key is removed
(cond
((equal? newval val)
(set! res (append res (list hed))))
((not newval) ;; key has been removed
@@ -683,18 +683,18 @@
(lambda (section)
(let ((sdat '()) ;; append needed bits here
(svars (configf:section-vars indat section)))
(for-each
(lambda (var)
- (let ((val (config-lookup refdat section var)))
+ (let ((val (configf:lookup refdat section var)))
(if (not val) ;; this one is new
(begin
(if (null? sdat)(set! sdat (list (conc "[" section "]"))))
(set! sdat (append sdat (list (conc var " " val))))))))
svars)
(set! fdat (append fdat sdat))))
- (delete-duplicates (append require-sections (hash-table-keys indat))))
+ (delete-duplicates (append required-sections (hash-table-keys indat))))
;; step 5: Write out new file
(with-output-to-file fname
(lambda ()
(for-each
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
@@ -1,6 +1,6 @@
-;======================================================================
+;;======================================================================
;; Copyright 2006-2016, Matthew Welland.
;;
;; This file is part of Megatest.
;;
;; Megatest is free software: you can redistribute it and/or modify
@@ -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"))
@@ -267,11 +267,13 @@
(condition-case
(begin
(debug:print 2 *default-log-port* "WARNING: opening db in non-writable dir " fname)
(let ((db (sqlite3:open-database fname)))
- ;; (mutex-unlock! *db-open-mutex*)
+ (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 136000))
+ (sqlite3:execute db "PRAGMA synchronous = 0;")
+ ;; (mutex-unlock! *db-open-mutex*)
db))
(exn (io-error) (debug:print 0 *default-log-port* "ERROR: i/o error with " fname ". Check permissions, disk space etc. and try again."))
(exn (corrupt) (debug:print 0 *default-log-port* "ERROR: database " fname " is corrupt. Repair it to proceed."))
(exn (busy) (debug:print 0 *default-log-port* "ERROR: database " fname " is locked. Try copying to another location, remove original and copy back."))
(exn (permission)(debug:print 0 *default-log-port* "ERROR: database " fname " has some permissions problem."))
@@ -605,10 +607,12 @@
"\"\n")
(exit) ;; we can not safely continue when a db was corrupted - even if fixed.
)
;; test read/write access to the database
(let ((db (sqlite3:open-database dbpath)))
+ (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 136000))
+ (sqlite3:execute db "PRAGMA synchronous = 0;")
(cond
((equal? fname "megatest.db")
(sqlite3:execute db "DELETE FROM tests WHERE state='DELETED';"))
((equal? fname "main.db")
(sqlite3:execute db "DELETE FROM runs WHERE state='deleted';"))
@@ -617,11 +621,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 +1113,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 +1132,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 +1152,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 +1465,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 +1522,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 +1938,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 +4113,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 +4574,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 +4593,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 +4612,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 @@
"<h2>Server Stats</h2>"
(http-transport:stats-table)
"<hr>"
(http-transport:runs linkpath)
"<hr>"
- (http-transport:run-stats)
+ ;; (http-transport:run-stats)
"</body>"
)))
(define (http-transport:stats-table)
(mutex-lock! *heartbeat-mutex*)
@@ -689,14 +693,14 @@
(map (lambda (p)
(conc "<a href=\"" p "\">" p "</a><br>"))
files))
" ")))
-(define (http-transport:run-stats)
+#;(define (http-transport:run-stats)
(let ((stats (open-run-close db:get-running-stats #f)))
(conc "<table>"
(string-intersperse
(map (lambda (stat)
(conc "<tr><td>" (car stat) "</td><td>" (cadr stat) "</td></tr>"))
stats)
" ")
"</table>")))
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))