Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -478,14 +478,14 @@ (define *common:std-statuses* '(;; (0 "DELETED") (1 "n/a") (2 "PASS") - (3 "CHECK") - (4 "SKIP") - (5 "WARN") - (6 "WAIVED") + (3 "SKIP") + (4 "WARN") + (5 "WAIVED") + (6 "CHECK") (7 "STUCK/DEAD") (8 "FAIL") (9 "ABORT"))) (define *common:ended-states* ;; states which indicate the test is stopped and will not proceed @@ -969,10 +969,14 @@ ;; (tags-testpatt (if tagexpr (string-join (runs:get-tests-matching-tags tagexpr) ",") #f)) (testpatt-key (if (args:get-arg "--modepatt") (args:get-arg "--modepatt") "TESTPATT")) (args-testpatt (or (args:get-arg "-testpatt") (args:get-arg "-runtests") "%")) (rtestpatt (if rconf (runconfigs-get rconf testpatt-key) #f))) (cond + ((args:get-arg "--modepatt") ;; modepatt is a forced setting, when set it MUST refer to an existing PATT in the runconfig + (if rconf + (runconfigs-get rconf testpatt-key) + #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) @@ -1000,10 +1004,22 @@ ;;;; TODO: catch permission denied exceptions and emit appropriate warnings, eg: system error while trying to access file: "/nfs/pdx/disks/icf_env_disk001/bjbarcla/gwa/issues/mtdev/randy-slow/reproduce/q... (common:false-on-exception (lambda () (directory-exists? path-string)) message: (conc "Unable to access path: " path-string) )) +;; does the directory exist and do we have write access? +;; +;; returns the directory or #f +;; +(define (common:directory-writable? path-string) + (handle-exceptions + exn + #f + (if (and (directory-exists? path-string) + (file-write-access? path-string)) + path-string + #f))) (define (common:get-linktree) (or (getenv "MT_LINKTREE") (or (and *configdat* (configf:lookup *configdat* "setup" "linktree")) @@ -1041,10 +1057,20 @@ (begin (debug:print-error 0 *default-log-port* "Invalid target, spaces or blanks not allowed \"" target "\", target should be: " (string-intersperse keys "/") ", have " tlist " for elements") (if exit-if-bad (exit 1)) #f) #f)))) + +;; looking only (at least for now) at the MT_ variables craft the full testname +;; +(define (common:get-full-test-name) + (if (getenv "MT_TEST_NAME") + (if (and (getenv "MT_ITEMPATH") + (not (equal? (getenv "MT_ITEMPATH") ""))) + (getenv "MT_TEST_NAME") + (conc (getenv "MT_TEST_NAME") "/" (getenv "MT_ITEMPATH"))) + #f)) ;; logic for getting homehost. Returns (host . at-home) ;; IF *toppath* is not set, wait up to five seconds trying every two seconds ;; (this is to accomodate the watchdog) ;; @@ -1107,14 +1133,24 @@ #f))) ;; do we honor the caches of the config files? ;; (define (common:use-cache?) - (not (or (args:get-arg "-no-cache") - (and *configdat* - (equal? (configf:lookup *configdat* "setup" "use-cache") "no"))))) - + (let ((res #t)) ;; priority by order of evaluation + (if *configdat* + (if (equal? (configf:lookup *configdat* "setup" "use-cache") "no") + (set! res #f) + (if (equal? (configf:lookup *configdat* "setup" "use-cache") "yes") + (set! res #t)))) + (if (args:get-arg "-no-cache")(set! res #f)) ;; overrides setting in "setup" + (if (getenv "MT_USE_CACHE") + (if (equal? (getenv "MT_USE_CACHE") "yes") + (set! res #t) + (if (equal? (getenv "MT_USE_CACHE") "no") + (set! res #f)))) ;; overrides -no-cache switch + res)) + ;; force use of server? ;; (define (common:force-server?) (let* ((force-setting (configf:lookup *configdat* "server" "force")) (force-type (if force-setting (string->symbol force-setting) #f)) @@ -1131,17 +1167,10 @@ (begin (debug:print-info 0 *default-log-port* "forcing use of server, force setting is \"" force-setting "\".") #t) #f))) -;; do we honor the caches of the config files? -;; -(define (common:use-cache?) - (not (or (args:get-arg "-no-cache") - (and *configdat* - (equal? (configf:lookup *configdat* "setup" "use-cache") "no"))))) - ;;====================================================================== ;; M I S C L I S T S ;;====================================================================== ;; items in lista are matched value and position in listb Index: configf.scm ================================================================== --- configf.scm +++ configf.scm @@ -320,10 +320,11 @@ (proc curr-section-name section-name res path)))) post-section-procs) ;; after gathering the vars for a section and if apply-wildcards is true and if there is a wildcard in the section name process wildcards ;; NOTE: we are processing the curr-section-name, NOT section-name. (process-wildcards res curr-section-name) + (if (not (hash-table-ref/default res section-name #f))(hash-table-set! res section-name '())) ;; ensure that mere mention of a section is not lost (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) ;; if we have the sections list then force all settings into "" and delete it later? ;; (if (or (not sections) ;; (member section-name sections)) ;; section-name "") ;; stick everything into "". NOPE: We need new strategy. Put stuff in correct sections and then delete all sections later. Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -204,11 +204,13 @@ ((allruns-by-id (make-hash-table)) : hash-table) ;; hash of run-id -> dboard:rundat records ((done-runs '()) : list) ;; list of runs already drawn ((not-done-runs '()) : list) ;; list of runs not yet drawn (header #f) ;; header for decoding the run records (keys #f) ;; keys for this run (i.e. target components) - ((numruns (string->number (or (args:get-arg "-cols") "10"))) : number) ;; + ((numruns (string->number (or (args:get-arg "-cols") + (configf:lookup *configdat* "dashboard" "cols") + "8"))) : number) ;; ((tot-runs 0) : number) ((last-data-update 0) : number) ;; last time the data in allruns was updated ((last-runs-update 0) : number) ;; last time we pulled the runs info to update the tree (runs-mutex (make-mutex)) ;; use to prevent parallel access to draw objects ((run-update-times (make-hash-table)) : hash-table) ;; update times indexed by run-id @@ -222,11 +224,11 @@ (runs-matrix #f) ;; used in newdashboard ((start-run-offset 0) : number) ;; left-right slider value ((start-test-offset 0) : number) ;; up-down slider value ((runs-btn-height (or (configf:lookup *configdat* "dashboard" "btn-height") "x16")) : string) ;; was 12 ((runs-btn-fontsz (or (configf:lookup *configdat* "dashboard" "btn-fontsz") "10")) : string) ;; was 8 - ((runs-cell-width (or (configf:lookup *configdat* "dashboard" "cell-width") "60")) : string) ;; was 50 + ((runs-cell-width (or (configf:lookup *configdat* "dashboard" "cell-width") "50")) : string) ;; was 50 ((all-test-names '()) : list) ;; Canvas and drawing data (cnv #f) (cnv-obj #f) @@ -1085,10 +1087,11 @@ (dboard:tabdat-filters-changed-set! tabdat #t))) (define (update-search commondat tabdat x val) (hash-table-set! (dboard:tabdat-searchpatts tabdat) x val) (dboard:tabdat-filters-changed-set! tabdat #t) + (mark-for-update tabdat) (set-bg-on-filter commondat tabdat)) ;; force ALL updates to zero (effectively) ;; (define (mark-for-update tabdat) @@ -1376,11 +1379,11 @@ ;; Target, testpatt, state and status input boxes ;; (iup:vbox ;; Command to run, placed over the top of the canvas (dcommon:command-action-selector commondat tabdat tab-num: tab-num) - (dboard:runs-tree-browser commondat tabdat) + (dboard:runs-tree-browser commondat tabdat) (dcommon:command-runname-selector commondat tabdat tab-num: tab-num) (dcommon:command-testname-selector commondat tabdat update-keyvals)) ;; key-listboxes)) (dcommon:command-tests-tasks-canvas tabdat test-records sorted-testnames tests-draw-state)))) (tb (dboard:tabdat-runs-tree tabdat))) @@ -1397,14 +1400,20 @@ ;; (let ((logs-tb (iup:textbox #:expand "YES" ;; #:multiline "YES"))) ;; (dboard:tabdat-logs-textbox-set! tabdat logs-tb) ;; logs-tb)) +;; browse runs as a tree. Used in both "Runs" tab and +;; in the runs control panel. +;; (define (dboard:runs-tree-browser commondat tabdat) - (let* ((txtbox (iup:textbox #:action (lambda (val a b) + (let* ( + (txtbox (iup:textbox #:action (lambda (val a b) (debug:catch-and-dump (lambda () + ;; for the Runs view we put the list of keyvals into tabdat target + ;; for the Run Controls we put then update the run-command (if b (dboard:tabdat-target-set! tabdat (string-split b "/"))) (dashboard:update-run-command tabdat)) "command-testname-selector tb action")) #:value (dboard:test-patt->lines (dboard:tabdat-test-patts-use tabdat)) @@ -1414,11 +1423,11 @@ (tb (iup:treebox #:value 0 #:name "Runs" #:expand "YES" - #:addexpanded "NO" + #:addexpanded "YES" #:size "10x" #:selection-cb (lambda (obj id state) (debug:catch-and-dump (lambda () @@ -1440,11 +1449,14 @@ (debug:print-error 5 *default-log-port* "tree-path->run-id returned non-number " run-id)))) "treebox")) ;; (print "path: " (tree:node->path obj id) " run-id: " run-id) ))) (dboard:tabdat-runs-tree-set! tabdat tb) - (iup:vbox tb txtbox))) + (iup:detachbox + (iup:vbox + tb + txtbox)))) ;;====================================================================== ;; R U N C O N T R O L S ;;====================================================================== ;; @@ -1509,11 +1521,11 @@ (iup:vbox (iup:split #:orientation "HORIZONTAL" #:value 800 (let* ((cnv-obj (iup:canvas - ;; #:size "500x400" + ;; #:size "250x250" ;; "500x400" #:expand "YES" #:scrollbar "YES" #:posx "0.5" #:posy "0.5" #:action (make-canvas-action @@ -1554,15 +1566,15 @@ (let* ((hb1 (iup:hbox)) (graph-cell-table (dboard:tabdat-graph-cell-table tabdat)) (changed #f) (graph-matrix (iup:matrix #:alignment1 "ALEFT" - #:expand "YES" ;; "HORIZONTAL" + ;; #:expand "YES" ;; "HORIZONTAL" #:scrollbar "YES" #:numcol 10 #:numlin 20 - #:numcol-visible (min 8) + #:numcol-visible 5 ;; (min 8) #:numlin-visible 1 #:click-cb (lambda (obj row col status) (let* ((graph-cell (conc row ":" col)) @@ -1865,11 +1877,11 @@ (define (dashboard:summary commondat tabdat #!key (tab-num #f)) (let* ((rawconfig (read-config (conc *toppath* "/megatest.config") #f #f)) ;; changed to #f since I want #{} to be expanded by [system ...] to NOT be expanded. WAS: 'return-string))) (changed #f)) (iup:vbox (iup:split - #:value 500 + #:value 300 (iup:frame #:title "General Info" (iup:vbox (iup:hbox (iup:label "Area Path") @@ -2048,11 +2060,11 @@ (let* ((update-mutex (dboard:commondat-update-mutex commondat)) (tb (iup:treebox #:value 0 #:name "Runs" #:expand "YES" - #:addexpanded "NO" + #:addexpanded "YES" #:selection-cb (lambda (obj id state) (debug:catch-and-dump (lambda () ;; (print "obj: " obj ", id: " id ", state: " state) @@ -2159,10 +2171,28 @@ ;;====================================================================== ;; R U N S ;;====================================================================== +(define (dboard:squarify toggles size) + (let loop ((hed (car toggles)) + (tal (cdr toggles)) + (cur '()) + (res '())) + (let* ((ovrflo (>= (length cur) size)) + (newcur (if ovrflo + (list hed) + (cons hed cur))) + (newres (if ovrflo + (cons cur res) + res))) + (if (null? tal) + (if ovrflo + newres + (cons newcur res)) + (loop (car tal)(cdr tal) newcur newres))))) + (define (dboard:make-controls commondat tabdat #!key (extra-widget #f) ) (let ((btn-fontsz (dboard:tabdat-runs-btn-fontsz tabdat))) (iup:hbox (iup:vbox (iup:frame @@ -2223,17 +2253,17 @@ (mark-for-update tabdat)))) (default-cmd (car (list-ref *tests-sort-type-index* *tests-sort-reverse*)))) (iuplistbox-fill-list sort-lb cmds-list selected-item: default-cmd) - (set! hide-empty (iup:button "HideEmpty" - ;; #:expand HORIZONTAL" - #:expand "NO" #:size "80x15" - #:action (lambda (obj) - (dboard:tabdat-hide-empty-runs-set! tabdat (not (dboard:tabdat-hide-empty-runs tabdat))) - (iup:attribute-set! obj "TITLE" (if (dboard:tabdat-hide-empty-runs tabdat) "+HideE" "-HideE")) - (mark-for-update tabdat)))) + ;; (set! hide-empty (iup:button "HideEmpty" + ;; ;; #:expand HORIZONTAL" + ;; #:expand "NO" #:size "80x15" + ;; #:action (lambda (obj) + ;; (dboard:tabdat-hide-empty-runs-set! tabdat (not (dboard:tabdat-hide-empty-runs tabdat))) + ;; (iup:attribute-set! obj "TITLE" (if (dboard:tabdat-hide-empty-runs tabdat) "+HideE" "-HideE")) + ;; (mark-for-update tabdat)))) (set! hide (iup:button "Hide" #:expand "NO" #:size "40x15" ;; #:expand "HORIZONTAL" #:action (lambda (obj) (dboard:tabdat-hide-not-hide-set! tabdat #t) ;; (not (dboard:tabdat-hide-not-hide tabdat))) ;; (iup:attribute-set! obj "TITLE" (if (dboard:tabdat-hide-not-hide tabdat) "HideTests" "NotHide")) @@ -2263,54 +2293,80 @@ ))) - (iup:frame - #:title "state/status filter" - (iup:vbox - (apply - iup:hbox - (map (lambda (status) - (iup:toggle (conc status " ") - #:fontsize btn-fontsz ;; "10" - #:expand "HORIZONTAL" - #:action (lambda (obj val) - (mark-for-update tabdat) - (if (eq? val 1) - (hash-table-set! (dboard:tabdat-status-ignore-hash tabdat) status #t) - (hash-table-delete! (dboard:tabdat-status-ignore-hash tabdat) status)) - (set-bg-on-filter commondat tabdat)))) - (map cadr *common:std-statuses*))) ;; '("PASS" "FAIL" "WARN" "CHECK" "WAIVED" "STUCK/DEAD" "n/a" "SKIP"))) - (apply - iup:hbox - (map (lambda (state) - (iup:toggle (conc state " ") - #:fontsize btn-fontsz - #:expand "HORIZONTAL" - #:action (lambda (obj val) - (mark-for-update tabdat) - (if (eq? val 1) - (hash-table-set! (dboard:tabdat-state-ignore-hash tabdat) state #t) - (hash-table-delete! (dboard:tabdat-state-ignore-hash tabdat) state)) - (set-bg-on-filter commondat tabdat)))) - (map cadr *common:std-states*))) ;; '("RUNNING" "COMPLETED" "INCOMPLETE" "LAUNCHED" "NOT_STARTED" "KILLED" "DELETED"))) - (iup:valuator #:valuechanged_cb (lambda (obj) - (let ((val (inexact->exact (round (/ (string->number (iup:attribute obj "VALUE")) 10)))) - (oldmax (string->number (iup:attribute obj "MAX"))) - (maxruns (dboard:tabdat-tot-runs tabdat))) - (dboard:tabdat-start-run-offset-set! tabdat val) - (mark-for-update tabdat) - (debug:print 6 *default-log-port* "(dboard:tabdat-start-run-offset tabdat) " (dboard:tabdat-start-run-offset tabdat) " maxruns: " maxruns ", val: " val " oldmax: " oldmax) - (iup:attribute-set! obj "MAX" (* maxruns 10)))) - #:expand "HORIZONTAL" - #:max (* 10 (max (hash-table-size (dboard:tabdat-allruns-by-id tabdat)) 10)) - #:min 0 - #:step 0.01))) - ;;(iup:button "inc rows" #:action (lambda (obj)(dboard:tabdat-num-tests-set! tabdat (+ (dboard:tabdat-num-tests tabdat) 1)))) - ;(iup:button "dec rows" #:action (lambda (obj)(dboard:tabdat-num-tests-set! tabdat (if (> (dboard:tabdat-num-tests tabdat) 0)(- (dboard:tabdat-num-tests tabdat) 1) 0)))) - ))) + (let* ((status-toggles (map (lambda (status) + (iup:toggle (conc status) + #:fontsize 8 ;; btn-fontsz ;; "10" + ;; #:expand "HORIZONTAL" + #:action (lambda (obj val) + (mark-for-update tabdat) + (if (eq? val 1) + (hash-table-set! (dboard:tabdat-status-ignore-hash tabdat) status #t) + (hash-table-delete! (dboard:tabdat-status-ignore-hash tabdat) status)) + (set-bg-on-filter commondat tabdat)))) + (map cadr *common:std-statuses*))) ;; '("PASS" "FAIL" "WARN" "CHECK" "WAIVED" "STUCK/DEAD" "n/a" "SKIP"))) + (state-toggles (map (lambda (state) + (iup:toggle (conc state) + #:fontsize 8 ;; btn-fontsz + ;; #:expand "HORIZONTAL" + #:action (lambda (obj val) + (mark-for-update tabdat) + (if (eq? val 1) + (hash-table-set! (dboard:tabdat-state-ignore-hash tabdat) state #t) + (hash-table-delete! (dboard:tabdat-state-ignore-hash tabdat) state)) + (set-bg-on-filter commondat tabdat)))) + (map cadr *common:std-states*))) ;; '("RUNNING" "COMPLETED" "INCOMPLETE" "LAUNCHED" "NOT_STARTED" "KILLED" "DELETED"))) + (num-toggle-cols (inexact->exact (round (/ (max (length status-toggles)(length state-toggles)) 3))))) + (iup:vbox + (iup:hbox + (iup:frame + #:title "states" + (apply + iup:hbox + (map (lambda (colgrp) + (apply iup:vbox colgrp)) + (dboard:squarify state-toggles 3)))) + (iup:frame + #:title "statuses" + (apply + iup:hbox + (map (lambda (colgrp) + (apply iup:vbox colgrp)) + (dboard:squarify status-toggles 3))))) + ;; + ;; (iup:frame + ;; #:title "state/status filter" + ;; (iup:vbox + ;; (apply + ;; iup:hbox + ;; (map + ;; (lambda (status-toggle state-toggle) + ;; (iup:vbox + ;; status-toggle + ;; state-toggle)) + ;; status-toggles state-toggles)) + + ;; horizontal slider was here + + ))))) + +(define (dashboard:runs-horizontal-slider tabdat ) + (iup:valuator #:valuechanged_cb (lambda (obj) + (let ((val (inexact->exact (round (/ (string->number (iup:attribute obj "VALUE")) 10)))) + (oldmax (string->number (iup:attribute obj "MAX"))) + (maxruns (dboard:tabdat-tot-runs tabdat))) + (dboard:tabdat-start-run-offset-set! tabdat val) + (mark-for-update tabdat) + (debug:print 6 *default-log-port* "(dboard:tabdat-start-run-offset tabdat) " (dboard:tabdat-start-run-offset tabdat) " maxruns: " maxruns ", val: " val " oldmax: " oldmax) + (iup:attribute-set! obj "MAX" (* maxruns 10)))) + #:expand "HORIZONTAL" + #:max (* 10 (max (hash-table-size (dboard:tabdat-allruns-by-id tabdat)) 10)) + #:min 0 + #:step 0.01)) + (define (dashboard:popup-menu run-id test-id target runname test-name testpatt item-test-path test-info) (iup:menu (iup:menu-item "Test Control Panel" @@ -2506,10 +2562,13 @@ (map (lambda (x) (let ((res (iup:hbox #:expand "HORIZONTAL" (iup:label x #:size (conc 40 btn-height) #:fontsize btn-fontsz #:expand "NO") ;; "HORIZONTAL") (iup:textbox #:size (conc 35 btn-height) #:fontsize btn-fontsz #:value "%" #:expand "NO" ;; "HORIZONTAL" #:action (lambda (obj unk val) + ;; each field (field name is "x" var) live updates + ;; the search filter as it is typed + (dboard:tabdat-target-set! runs-dat #f) ;; ensure the fields text boxes are used and not the info from the tree (mark-for-update runs-dat) (update-search commondat runs-dat x val)))))) (set! i (+ i 1)) res)) keynames))))) @@ -2630,20 +2689,23 @@ #:title (conc "Megatest dashboard " (current-user-name) ":" *toppath*) #:menu (dcommon:main-menu) (let* ((runs-view (iup:vbox (iup:split #:orientation "VERTICAL" ;; "HORIZONTAL" - #:value 150 + #:value 100 (dboard:runs-tree-browser commondat runs-dat) (iup:split + #:value 100 ;; left most block, including row names (apply iup:vbox lftlst) ;; right hand block, including cells (iup:vbox + #:expand "YES" ;; the header (apply iup:hbox (reverse hdrlst)) - (apply iup:hbox (reverse bdylst))))) + (apply iup:hbox (reverse bdylst)) + (dashboard:runs-horizontal-slider runs-dat)))) controls )) (views-cfgdat (common:load-views-config)) (additional-tabnames '()) (tab-start-num 5) ;; DON'T FORGET TO UPDATE THIS WHEN CHANGING THE STANDARD TABS BELOW @@ -2688,10 +2750,11 @@ runs-view (dashboard:runs-summary commondat onerun-dat tab-num: 2) ;; (dashboard:new-view db data new-view-dat tab-num: 3) (dashboard:run-controls commondat runcontrols-dat tab-num: 3) (dashboard:run-times commondat runtimes-dat tab-num: 4) + ;; (dashboard:runs-summary commondat onerun-dat tab-num: 4) additional-views))) ;; (set! (iup:callback tabs tabchange-cb:) (lambda (a b c)(print "SWITCHED TO TAB: " a " " b " " c))) (iup:attribute-set! tabs "TABTITLE0" "Summary") (iup:attribute-set! tabs "TABTITLE1" "Runs") (iup:attribute-set! tabs "TABTITLE2" "Run Summary") Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -232,11 +232,11 @@ (if (not file-exists) (begin (if (and (configf:lookup *configdat* "setup" "use-wal") (string-match "^/tmp/.*" fname)) ;; this is a file in /tmp (sqlite3:execute db "PRAGMA journal_mode=WAL;") - (print "Creating " fname " in NON-WAL mode.")) + (debug:print 2 *default-log-port* "Creating " fname " in NON-WAL mode.")) (initproc db))) (if (not readyexists) (begin (common:simple-file-release-lock lockfname) (with-output-to-file @@ -3349,10 +3349,14 @@ *common:std-statuses* >)) (non-completes (filter (lambda (x) (not (equal? x "COMPLETED"))) all-curr-states)) (newstate (cond + ((> running 0) + "RUNNING") ;; anything running, call the situation running + ((> bad-not-started 0) ;; we have an ugly situation, it is completed in the sense we cannot do more. + "COMPLETED") ((> (length non-completes) 0) ;; (car non-completes)) ;; (remove (lambda (x)(equal? "COMPLETED" x)) all-curr-states))) (else (car all-curr-states)))) ;; (if (> running 0) Index: dcommon.scm ================================================================== --- dcommon.scm +++ dcommon.scm @@ -491,11 +491,11 @@ (define (dcommon:section-matrix rawconfig sectionname varcolname valcolname #!key (title #f)) (let* ((curr-row-num 1) (key-vals (configf:section-vars rawconfig sectionname)) (section-matrix (iup:matrix #:alignment1 "ALEFT" - #:expand "YES" ;; "HORIZONTAL" + ;; #:expand "YES" ;; "HORIZONTAL" #:numcol 1 #:numlin (length key-vals) #:numcol-visible 1 #:numlin-visible (min 10 (length key-vals)) #:scrollbar "YES"))) @@ -1185,11 +1185,11 @@ (* scalef 0.01) (* scalef -0.01)))) (if the-cnv (dashboard:draw-tests the-cnv last-xadj last-yadj tests-draw-state sorted-testnames test-records)) )) - ;; #:size "50x50" + ;; #:size "250x250" #:expand "YES" #:scrollbar "YES" #:posx "0.5" #:posy "0.5" #:button-cb (lambda (obj btn pressed x y status) Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -566,11 +566,11 @@ (debug:print 2 *default-log-port* "Exectuing " test-name " (id: " test-id ") on " (get-host-name)) (set! keys (rmt:get-keys)) ;; (runs:set-megatest-env-vars run-id inkeys: keys inkeyvals: keyvals) ;; these may be needed by the launching process ;; one of these is defunct/redundant ... - (if (not (launch:setup force: #t)) + (if (not (launch:setup force-reread: #t)) (begin (debug:print 0 *default-log-port* "Failed to setup, exiting") ;; (sqlite3:finalize! db) ;; (sqlite3:finalize! tdb) (exit 1))) @@ -741,11 +741,12 @@ (rmt:update-run-stats run-id (rmt:get-raw-run-stats run-id))) (mutex-unlock! m) (debug:print 2 *default-log-port* "Output from running " fullrunscript ", pid " (launch:einf-pid exit-info) " in work area " work-area ":\n====\n exit code " (launch:einf-exit-code exit-info) "\n" "====\n") (if (not (launch:einf-exit-status exit-info)) - (exit 4))))))) + (exit 4)))) + ))) (define (launch:cache-config) ;; if we have a linktree and -runtests and -target and the directory exists dump the config ;; to megatest-(current-seconds).cfg and symlink it to megatest.cfg (if (and *configdat* @@ -794,61 +795,79 @@ ;; side effects: ;; sets; *configdat* (megatest.config info) ;; *runconfigdat* (runconfigs.config info) ;; *configstatus* (status of the read data) ;; -(define (launch:setup #!key (force #f) (areapath #f)) +(define (launch:setup #!key (force-reread #f) (areapath #f)) (mutex-lock! *launch-setup-mutex*) (if (and *toppath* - (eq? *configstatus* 'fulldata)) ;; got it all + (eq? *configstatus* 'fulldata) (not force-reread)) ;; got it all (begin - (debug:print 0 *default-log-port* "NOTE: skipping launch:setup-body call since we have fulldata") + (debug:print 2 *default-log-port* "NOTE: skipping launch:setup-body call since we have fulldata") (mutex-unlock! *launch-setup-mutex*) *toppath*) - (let ((res (launch:setup-body force: force areapath: areapath))) + (let ((res (launch:setup-body force-reread: force-reread areapath: areapath))) (mutex-unlock! *launch-setup-mutex*) res))) + +;; return paths depending on what info is available. +;; +(define (launch:get-cache-file-paths areapath toppath target mtconfig) + (let* ((use-cache (common:use-cache?)) + (runname (common:args-get-runname)) + (linktree (common:get-linktree)) + (testname (common:get-full-test-name)) + (rundir (if (and runname target linktree) + (common:directory-writable? (conc linktree "/" target "/" runname)) + #f)) + (testdir (if (and rundir testname) + (common:directory-writable? (conc rundir "/" testname)) + #f)) + (cachedir (or testdir rundir)) + (mtcachef (and cachedir (conc cachedir "/" ".megatest.cfg-" megatest-version "-" megatest-fossil-hash))) + (rccachef (and cachedir (conc cachedir "/" ".runconfigs.cfg-" megatest-version "-" megatest-fossil-hash)))) + (debug:print-info 6 *default-log-port* + "runname=" runname + "\n linktree=" linktree + "\n testname=" testname + "\n rundir=" rundir + "\n testdir=" testdir + "\n cachedir=" cachedir + "\n mtcachef=" mtcachef + "\n rccachef=" rccachef) + (cons mtcachef rccachef))) (define (launch:setup-body #!key (force-reread #f) (areapath #f)) (if (and (eq? *configstatus* 'fulldata) *toppath* (not force-reread)) ;; no need to reprocess *toppath* ;; return toppath - (let* ((use-cache (common:use-cache?)) + (let* ((use-cache (common:use-cache?)) ;; BB- use-cache checks *configdat* for use-cache setting. We do not have *configdat*. Bootstrapping problem here. (toppath (or *toppath* areapath (getenv "MT_RUN_AREA_HOME"))) ;; preserve toppath - - (runname (common:args-get-runname)) (target (common:args-get-target)) - (linktree (common:get-linktree)) - (contour #f) ;; NOT READY FOR THIS (args:get-arg "-contour")) (sections (if target (list "default" target) #f)) ;; for runconfigs (mtconfig (or (args:get-arg "-config") "megatest.config")) ;; allow overriding megatest.config - (rundir (if (and runname target linktree) - (conc linktree (if contour (conc "/" contour) "") "/" target "/" runname) - #f)) - - (mtcachef (and rundir (conc rundir "/" ".megatest.cfg-" megatest-version "-" megatest-fossil-hash))) - (rccachef (and rundir (conc rundir "/" ".runconfigs.cfg-" megatest-version "-" megatest-fossil-hash))) - (cancreate (and rundir (common:file-exists? rundir)(file-write-access? rundir) (not (common:in-running-test?))))) - ;; (cxt (hash-table-ref/default *contexts* toppath #f))) - - ;; create our cxt for this area if it doesn't already exist - ;; (if (not cxt)(hash-table-set! *contexts* toppath (make-cxt))) - - ;; (print "runname: " runname " target: " target " mtcachef: " mtcachef " rccachef: " rccachef) + (cachefiles (launch:get-cache-file-paths areapath toppath target mtconfig)) + (mtcachef (car cachefiles)) ;; (and cachedir (conc cachedir "/" ".megatest.cfg-" megatest-version "-" megatest-fossil-hash))) + (rccachef (cdr cachefiles)) ;; (and cachedir (conc cachedir "/" ".runconfigs.cfg-" megatest-version "-" megatest-fossil-hash))) + ) ;; (cancreate (and cachedir (common:file-exists? cachedir)(file-write-access? cachedir) (not (common:in-running-test?))))) (set! *toppath* toppath) ;; This is needed when we are running as a test using CMDINFO as a datasource + ;;(BB> "launch:setup-body -- cachefiles="cachefiles) (cond ;; if mtcachef exists just read it, however we need to assume toppath is available in $MT_RUN_AREA_HOME - ((and mtcachef (common:file-exists? mtcachef) (get-environment-variable "MT_RUN_AREA_HOME") use-cache) - (set! *configdat* (configf:read-alist mtcachef)) + ((and (not force-reread) mtcachef (common:file-exists? mtcachef) (get-environment-variable "MT_RUN_AREA_HOME") use-cache) + ;;(BB> "launch:setup-body -- cond branch 1 - use-cache") + (set! *configdat* (configf:read-alist mtcachef)) + ;;(BB> "launch:setup-body -- 1 set! *configdat*="*configdat*) (set! *runconfigdat* (configf:read-alist rccachef)) (set! *configinfo* (list *configdat* (get-environment-variable "MT_RUN_AREA_HOME"))) (set! *configstatus* 'fulldata) (set! *toppath* (get-environment-variable "MT_RUN_AREA_HOME")) *toppath*) ;; we have all the info needed to fully process runconfigs and megatest.config - (mtcachef + ((and (not force-reread) mtcachef) ;; BB- why are we doing this without asking if caching is desired? + ;;(BB> "launch:setup-body -- cond branch 2") (let* ((first-pass (find-and-read-config ;; NB// sets MT_RUN_AREA_HOME as side effect mtconfig environ-patt: "env-override" given-toppath: toppath pathenvvar: "MT_RUN_AREA_HOME")) @@ -863,11 +882,13 @@ *runconfigdat* #t sections: sections)))) (set! *runconfigdat* first-rundat) (if first-pass ;; (begin + ;;(BB> "launch:setup-body -- \"first-pass\"=first-pass") (set! *configdat* (car first-pass)) + ;;(BB> "launch:setup-body -- 2 set! *configdat*="*configdat*) (set! *configinfo* first-pass) (set! *toppath* (or toppath (cadr first-pass))) ;; use the gathered data unless already have it (set! toppath *toppath*) (if (not *toppath*) (begin @@ -889,26 +910,33 @@ (runconfigdat (begin ;; this read of the runconfigs will see any adjustments made by re-reading megatest.config (for-each (lambda (kt) (setenv (car kt) (cadr kt))) key-vals) (read-config (conc toppath "/runconfigs.config") *runconfigdat* #t ;; consider using runconfig:read some day ... - sections: sections)))) - (if cancreate (configf:write-alist runconfigdat rccachef)) + sections: sections))) + (cachefiles (launch:get-cache-file-paths areapath toppath target mtconfig)) + (mtcachef (car cachefiles)) + (rccachef (cdr cachefiles))) + (if rccachef (configf:write-alist runconfigdat rccachef)) (set! *runconfigdat* runconfigdat) - (if cancreate (configf:write-alist *configdat* mtcachef)) - (if cancreate (set! *configstatus* 'fulldata)))) + (if mtcachef (configf:write-alist *configdat* mtcachef)) + (if (and rccachef mtcachef) (set! *configstatus* 'fulldata)))) ;; no configs found? should not happen but let's try to recover gracefully, return an empty hash-table - (set! *configdat* (make-hash-table)) + (begin (set! *configdat* (make-hash-table)) + ;;(BB> "launch:setup-body -- 3 set! *configdat*="*configdat*) + ) ))) ;; else read what you can and set the flag accordingly (else + ;;(BB> "launch:setup-body -- cond branch 3 - else") (let* ((cfgdat (find-and-read-config (or (args:get-arg "-config") "megatest.config") environ-patt: "env-override" given-toppath: (get-environment-variable "MT_RUN_AREA_HOME") pathenvvar: "MT_RUN_AREA_HOME"))) - (if cfgdat + + (if (and cfgdat (list? cfgdat) (> (length cfgdat) 0) (hash-table? (car cfgdat))) (let* ((toppath (or (get-environment-variable "MT_RUN_AREA_HOME")(cadr cfgdat))) (rdat (read-config (conc toppath ;; convert this to use runconfig:read! "/runconfigs.config") *runconfigdat* #t sections: sections))) (set! *configinfo* cfgdat) (set! *configdat* (car cfgdat)) @@ -951,10 +979,19 @@ (debug:print-error 0 *default-log-port* "failed to find the top path to your Megatest area.") ;;(exit 1) (set! *toppath* #f) ;; force it to be false so we return #f #f )) + ;; one more attempt to cache the configs for future reading + (let* ((cachefiles (launch:get-cache-file-paths areapath toppath target mtconfig)) + (mtcachef (car cachefiles)) + (rccachef (cdr cachefiles))) + (if (and rccachef *runconfigdat*) (configf:write-alist *runconfigdat* rccachef)) + (if (and mtcachef *configdat*) (configf:write-alist *configdat* mtcachef)) + (if (and rccachef mtcachef *runconfigdat* *configdat*) + (set! *configstatus* 'fulldata))) + ;; if have -append-config then read and append here (let ((cfname (args:get-arg "-append-config"))) (if (and cfname (file-read-access? cfname)) (read-config cfname *configdat* #t))) ;; values are added to the hash, no need to do anything special. Index: megatest-version.scm ================================================================== --- megatest-version.scm +++ megatest-version.scm @@ -1,7 +1,7 @@ ;; Always use two or four digit decimal ;; 1.01, 1.02...1.10,1.11,1.1101 ... 1.99,2.00.. (declare (unit megatest-version)) -(define megatest-version 1.6404) +(define megatest-version 1.6407) Index: megatest.config ================================================================== --- megatest.config +++ megatest.config @@ -18,5 +18,6 @@ quick selector=QUICKPATT/quick full areas=fullrun,ext-tests; selector=MAXPATT/ all areas=fullrun,ext-tests snazy areas=%; selector=QUICKPATT/ +[nopurpose] Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -133,11 +133,11 @@ -list-disks : list the disks available for storing runs -list-targets : list the targets in runconfigs.config -list-db-targets : list the target combinations used in the db -show-config : dump the internal representation of the megatest.config file -show-runconfig : dump the internal representation of the runconfigs.config file - -dumpmode MODE : dump in MODE format instead of sexpr, MODE=json,ini,sexp etc. + -dumpmode MODE : dump in MODE format instead of sexpr, MODE=json,ini,sexp etc. (add -debug 0,9 to see which file contributes each line) -show-cmdinfo : dump the command info for a test (run in test environment) -section sectionName -var varName : for config and runconfig lookup value for sectionName varName -since N : get list of runs changed since time N (Unix seconds) -fields fieldspec : fields to include in json dump; runs:id,runame+tests:testname+steps @@ -424,18 +424,21 @@ (exn () (debug:print-error 0 *default-log-port* "Could not open log file for write: "logpath) (define *didsomething* #t) (exit 1)))) - +;; this segment will run launch:setup only if -log is not set. This is fairly safe as servers are not +;; manually started and thus should never be started in a non-megatest area. Thus no need to handle situation +;; where (launch:setup) returns #f? +;; (if (or (args:get-arg "-log")(args:get-arg "-server")) ;; redirect the log always when a server (handle-exceptions exn (begin (print "ERROR: Failed to switch to log output. " ((conition-property-accessor 'exn 'message) exn)) ) - (let* ((tl (or (args:get-arg "-log")(launch:setup))) ;; run launch:setup if -server + (let* ((tl (or (args:get-arg "-log")(launch:setup))) ;; run launch:setup if -server, ensure we do NOT run launch:setup if -log specified (logf (or (args:get-arg "-log") ;; use -log unless we are a server, then craft a logfile name (conc tl "/logs/server-" (current-process-id) "-" (get-host-name) ".log"))) (oup (open-logfile logf))) (if (not (args:get-arg "-log")) (hash-table-set! args:arg-hash "-log" logf)) ;; fake out future queries of -log @@ -861,11 +864,11 @@ (file-write-access? rundir)) (begin (if (not (common:in-running-test?)) (configf:write-alist data cfgf)) ;; force re-read of megatest.config - this resolves circular references between megatest.config - (launch:setup force: #t) + (launch:setup force-reread: #t) (launch:cache-config))) ;; we can safely cache megatest.config since we have a valid runconfig data)))) (if (args:get-arg "-show-runconfig") (let ((tl (launch:setup))) @@ -1403,61 +1406,63 @@ (if (or (args:get-arg "-runall") (args:get-arg "-run") (args:get-arg "-rerun-clean") (args:get-arg "-rerun-all") (args:get-arg "-runtests")) - (general-run-call - "-runall" - "run all tests" - (lambda (target runname keys keyvals) - (if (args:get-arg "-rerun-clean") ;; first set states/statuses correct - (let ((states (or (configf:lookup *configdat* "validvalues" "cleanrerun-states") - "KILLREQ,KILLED,UNKNOWN,INCOMPLETE,STUCK,NOT_STARTED")) - (statuses (or (configf:lookup *configdat* "validvalues" "cleanrerun-statuses") - "FAIL,INCOMPLETE,ABORT,CHECK"))) - (hash-table-set! args:arg-hash "-preclean" #t) - (runs:operate-on 'set-state-status - target - (common:args-get-runname) ;; (or (args:get-arg "-runname")(args:get-arg ":runname")) - "%" ;; (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt") - state: states - ;; status: statuses - new-state-status: "NOT_STARTED,n/a") - (runs:clean-cache target runname *toppath*) - (runs:operate-on 'set-state-status - target - (common:args-get-runname) ;; (or (args:get-arg "-runname")(args:get-arg ":runname")) - "%" ;; (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt") - ;; state: states - status: statuses - new-state-status: "NOT_STARTED,n/a"))) - ;; RERUN ALL - (if (args:get-arg "-rerun-all") ;; first set states/statuses correct - (begin - (hash-table-set! args:arg-hash "-preclean" #t) - (runs:operate-on 'set-state-status - target - (common:args-get-runname) ;; (or (args:get-arg "-runname")(args:get-arg ":runname")) - "%" ;; (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt") - state: #f - ;; status: statuses - new-state-status: "NOT_STARTED,n/a") - (runs:clean-cache target runname *toppath*) - (runs:operate-on 'set-state-status - target - (common:args-get-runname) ;; (or (args:get-arg "-runname")(args:get-arg ":runname")) - "%" ;; (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt") - ;; state: states - status: #f - new-state-status: "NOT_STARTED,n/a"))) - (runs:run-tests target - runname - #f ;; (common:args-get-testpatt #f) - ;; (or (args:get-arg "-testpatt") - ;; "%") - user - args:arg-hash)))) + (let ((need-clean (or (args:get-arg "-rerun-clean") + (args:get-arg "-rerun-all")))) + (general-run-call + "-runall" + "run all tests" + (lambda (target runname keys keyvals) + (if (args:get-arg "-rerun-clean") ;; first set states/statuses correct + (let ((states (or (configf:lookup *configdat* "validvalues" "cleanrerun-states") + "KILLREQ,KILLED,UNKNOWN,INCOMPLETE,STUCK,NOT_STARTED")) + (statuses (or (configf:lookup *configdat* "validvalues" "cleanrerun-statuses") + "FAIL,INCOMPLETE,ABORT,CHECK"))) + (hash-table-set! args:arg-hash "-preclean" #t) + (runs:operate-on 'set-state-status + target + (common:args-get-runname) ;; (or (args:get-arg "-runname")(args:get-arg ":runname")) + "%" ;; (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt") + state: states + ;; status: statuses + new-state-status: "NOT_STARTED,n/a") + (runs:clean-cache target runname *toppath*) + (runs:operate-on 'set-state-status + target + (common:args-get-runname) ;; (or (args:get-arg "-runname")(args:get-arg ":runname")) + "%" ;; (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt") + ;; state: states + status: statuses + new-state-status: "NOT_STARTED,n/a"))) + ;; RERUN ALL + (if (args:get-arg "-rerun-all") ;; first set states/statuses correct + (begin + (hash-table-set! args:arg-hash "-preclean" #t) + (runs:operate-on 'set-state-status + target + (common:args-get-runname) ;; (or (args:get-arg "-runname")(args:get-arg ":runname")) + "%" ;; (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt") + state: #f + ;; status: statuses + new-state-status: "NOT_STARTED,n/a") + (runs:clean-cache target runname *toppath*) + (runs:operate-on 'set-state-status + target + (common:args-get-runname) ;; (or (args:get-arg "-runname")(args:get-arg ":runname")) + "%" ;; (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt") + ;; state: states + status: #f + new-state-status: "NOT_STARTED,n/a"))) + (runs:run-tests target + runname + #f ;; (common:args-get-testpatt #f) + ;; (or (args:get-arg "-testpatt") + ;; "%") + user + args:arg-hash))))) ;;====================================================================== ;; run one test ;;====================================================================== Index: mtut.scm ================================================================== --- mtut.scm +++ mtut.scm @@ -12,11 +12,11 @@ ;; fake out readline usage of toplevel-command (define (toplevel-command . a) #f) (use srfi-1 posix srfi-69 readline ;; regex regex-case srfi-69 apropos json http-client directory-utils rpc typed-records;; (srfi 18) extras) - srfi-18 extras format pkts pkts regex regex-case + srfi-18 extras format pkts regex regex-case (prefix dbi dbi:)) ;; zmq extras) (declare (uses common)) (declare (uses megatest-version)) (declare (uses margs)) @@ -56,55 +56,56 @@ mtutil, part of the Megatest tool suite, documentation at http://www.kiatoa.com/fossils/megatest version " megatest-version " license GPL, Copyright Matt Welland 2006-2017 Usage: mtutil action [options] - -h : this help - -manual : show the Megatest user manual - -version : print megatest version (currently " megatest-version ") - -Actions: - run : initiate runs - remove : remove runs - rerun : register action for processing - set-ss : set state/status - archive : compress and move test data to archive disk - kill : stop tests or entire runs - db : database utilities + -h : this help + -manual : show the Megatest user manual + -version : print megatest version (currently " megatest-version ") + +Actions: + run : initiate runs + remove : remove runs + rerun : register action for processing + set-ss : set state/status + archive : compress and move test data to archive disk + kill : stop tests or entire runs + db : database utilities + areas, contours, setup : show areas, contours or setup section from megatest.config Contour actions: - process : runs import, rungen and dispatch - -Selectors - -immediate : apply this action immediately, default is to queue up actions - -area areapatt1,area2... : apply this action only to the specified areas - -target key1/key2/... : run for key1, key2, etc. - -test-patt p1/p2,p3/... : % is wildcard - -run-name : required, name for this particular test run - -contour contourname : run all targets for contourname, requires -run-name, -target - -state-status c/p,c/f : Specify a list of state and status patterns - -tag-expr tag1,tag2%,.. : select tests with tags matching expression - -mode-patt key : load testpatt from in runconfigs instead of default TESTPATT - if -testpatt and -tagexpr are not specified - -new state/status : specify new state/status for set-ss - -Misc - -start-dir path : switch to this directory before running mtutil - -set-vars V1=1,V2=2 : Add environment variables to a run NB// these are - overwritten by values set in config files. - -log logfile : send stdout and stderr to logfile - -repl : start a repl (useful for extending megatest) - -load file.scm : load and run file.scm - -debug N|N,M,O... : enable debug messages 0-N or N and M and O ... - -Utility - db pgschema : emit postgresql schema; do \"mtutil db pgschema | psql -d mydb\" + process : runs import, rungen and dispatch + +Selectors + -immediate : apply this action immediately, default is to queue up actions + -area areapatt1,area2... : apply this action only to the specified areas + -target key1/key2/... : run for key1, key2, etc. + -test-patt p1/p2,p3/... : % is wildcard + -run-name : required, name for this particular test run + -contour contourname : run all targets for contourname, requires -run-name, -target + -state-status c/p,c/f : Specify a list of state and status patterns + -tag-expr tag1,tag2%,.. : select tests with tags matching expression + -mode-patt key : load testpatt from in runconfigs instead of default TESTPATT + if -testpatt and -tagexpr are not specified + -new state/status : specify new state/status for set-ss + +Misc + -start-dir path : switch to this directory before running mtutil + -set-vars V1=1,V2=2 : Add environment variables to a run NB// these are + overwritten by values set in config files. + -log logfile : send stdout and stderr to logfile + -repl : start a repl (useful for extending megatest) + -load file.scm : load and run file.scm + -debug N|N,M,O... : enable debug messages 0-N or N and M and O ... + +Utility + db pgschema : emit postgresql schema; do \"mtutil db pgschema | psql -d mydb\" Examples: # Start a megatest run in the area \"mytests\" -mtutil -area mytests -action run -target v1.63/aa3e -mode-patt MYPATT -tag-expr quick +mtutil run -area mytests -target v1.63/aa3e -mode-patt MYPATT -tag-expr quick # Start a contour mtutil run -contour quick -target v1.63/aa3e Called as " (string-intersperse (argv) " ") " @@ -301,10 +302,11 @@ (not (or (args:get-arg "-runstep") (args:get-arg "-envcap") (args:get-arg "-envdelta") (member *action* '("db")) ;; very loose checks on db. + (equal? *action* "show") ;; just keep going if list ))) (debug:print-error 0 *default-log-port* "Unrecognised arguments: " (string-intersperse (if (list? remargs) remargs (argv)) " "))) (if (or (args:any? "-h" "help" "-help" "--help") (member *action* '("-h" "-help" "--help" "help"))) @@ -324,13 +326,15 @@ (if (not (and pktsdir toppath pdbpath)) (begin (print "ERROR: settings are missing in your megatest.config for area management.") (print " you need to have pktsdir in the [setup] section.")) (let* ((pdb (open-queue-db pdbpath "pkts.db" - schema: '("CREATE TABLE groups (id INTEGER PRIMARY KEY,groupname TEXT, CONSTRAINT group_constraint UNIQUE (groupname));")))) - (proc pktsdirs pktsdir pdb) - (dbi:close pdb))))) + schema: '("CREATE TABLE groups (id INTEGER PRIMARY KEY,groupname TEXT, CONSTRAINT group_constraint UNIQUE (groupname));"))) + (res (proc pktsdirs pktsdir pdb))) + (dbi:close pdb) + res + )))) (define (load-pkts-to-db mtconf) (with-queue-db mtconf (lambda (pktsdirs pktsdir pdb) @@ -347,12 +351,13 @@ (if (not exists) (let* ((pktdat (string-intersperse (with-input-from-file pkt read-lines) "\n")) (apkt (pkt->alist pktdat)) - (ptype (alist-ref 'T apkt))) - (add-to-queue pdb pktdat uuid (or ptype 'cmd) #f 0) + (ptype (alist-ref 'T apkt)) + (parent (alist-ref 'P apkt))) + (add-to-queue pdb pktdat uuid (or ptype 'cmd) parent 0) (debug:print 4 *default-log-port* "Added " uuid " of type " ptype " to queue")) (debug:print 4 *default-log-port* "pkt: " uuid " exists, skipping...") ))) pkts)))) (string-split pktsdirs))))) @@ -386,11 +391,11 @@ ;; collect, translate, collate and assemble a pkt from the command-line ;; ;; sched => force the run start time to be recorded as sched Unix ;; epoch. This aligns times properly for triggers in some cases. ;; -(define (command-line->pkt action args-alist sched-in) +(define (command-line->pkt action args-alist sched-in #!key (extra-dat '())) (let* ((sched (cond ((vector? sched-in)(local-time->seconds sched-in)) ;; we recieved a time ((number? sched-in) sched-in) (else (current-seconds)))) (args-data (if args-alist @@ -400,10 +405,11 @@ (hash-table->alist args:arg-hash))) ;; if no args-alist then we assume this is a call driven directly by commandline (alldat (apply append (list 'T "cmd" 'a action 'U (current-user-name) 'D sched) + extra-dat (map (lambda (x) (let* ((param (car x)) (value (cdr x)) (pmeta (assoc param *arg-keys*)) ;; translate the card key to a megatest switch or parameter (smeta (assoc param *switch-keys*)) ;; first lookup the key in arg-keys or switch-keys @@ -523,16 +529,27 @@ (equal? action "run")) `(("-preclean" . " ") ("-rerun-all" . " ")) ;; if run we *always* want preclean set, use single space as placeholder '()) ) - sched))) + sched + extra-dat: `((a . ,runkey)) ;; we need the run key for marking the run as launched + ))) (with-output-to-file (conc pktsdir "/" uuid ".pkt") (lambda () (print pkt)))))) + +(define (val-alist->areas val-alist) + (string-split (or (alist-ref 'areas val-alist) "") ",")) + +(define (area-allowed? area areas) + (or (not areas) + (null? areas) + (member area areas))) + ;; (use trace)(trace create-run-pkt) ;; collect all needed data and create run pkts for contours with changed inputs ;; (define (generate-run-pkts mtconf toppath) @@ -603,10 +620,11 @@ (if (not (alist-ref 'cron val-alist)) ;; gotta have cron spec (print "ERROR: bad sense spec \"" (string-intersperse sense " ") "\" params: " val-alist) (let* ((run-name (alist-ref 'run-name val-alist)) (target (alist-ref 'target val-alist)) (crontab (alist-ref 'cron val-alist)) + (areas (val-alist->areas val-alist)) ;; (action (alist-ref 'action val-alist)) (cron-safe-string (string-translate (string-intersperse (string-split (alist-ref 'cron val-alist)) "-") "*" "X")) (runname std-runname)) ;; (conc "sched" (time->string (seconds->local-time (current-seconds)) "%M%H%d"))))) ;; (print "last-run: " last-run " need-run: " need-run) ;; (if need-run @@ -624,10 +642,17 @@ `((message . ,(conc ruletype ":" cron-safe-string)) (runname . ,runname) (runtrans . ,runtrans) (action . ,action) (target . ,target))))) + ((remove) + (push-run-spec torun contour runkey + `((message . ,(conc ruletype ":" cron-safe-string)) + (runname . ,runname) + (runtrans . ,runtrans) + (action . ,action) + (target . ,target)))) (else (print "ERROR: action \"" action "\" has no scheduled handler") ))))) ((script) @@ -703,10 +728,11 @@ (print "Got datetime=" datetime " node=" node)))) val-alist)) ((file file-or) ;; one or more files must be newer than the reference (let* ((file-globs (alist-ref 'glob val-alist)) + (areas (val-alist->areas val-alist)) (youngestdat (common:get-youngest (common:bash-glob file-globs))) (youngestmod (car youngestdat))) ;; (print "youngestmod: " youngestmod " starttimes: " starttimes) (if (null? starttimes) ;; this target has never been run (push-run-spec torun contour runkey @@ -769,11 +795,11 @@ (for-each (lambda (contour) (print "contour: " contour) (let* ((val (or (configf:lookup mtconf "contours" contour) "")) (val-alist (val->alist val)) - (areas (string-split (or (alist-ref 'areas val-alist) "") ",")) + (areas (val-alist->areas val-alist)) (selector (alist-ref 'selector val-alist)) (mode-tag (and selector (string-split-fields "/" selector #:infix))) (mode-patt (and mode-tag (if (eq? (length mode-tag) 2)(cadr mode-tag) #f))) (tag-expr (and mode-tag (if (null? mode-tag) #f (car mode-tag))))) (for-each @@ -783,28 +809,30 @@ (runkeydats (cadr runkeydatset))) (for-each (lambda (runkeydat) (for-each (lambda (area) - (let ((runname (alist-ref 'runname runkeydat)) - (runtrans (alist-ref 'runtrans runkeydat)) - (reason (alist-ref 'message runkeydat)) - (sched (alist-ref 'sched runkeydat)) - (action (alist-ref 'action runkeydat)) - (dbdest (alist-ref 'dbdest runkeydat)) - (append (alist-ref 'append runkeydat)) - (target (or (alist-ref 'target runkeydat) runkey))) ;; override with target if forced - (print "Have: runkey=" runkey " contour=" contour " area=" area " action=" action " tag-expr=" tag-expr " mode-patt=" mode-patt " target=" target) - (if (case (or (and action (string->symbol action)) 'noaction) ;; ensure we have the needed data to run this action - ((noaction) #f) - ((run) (and runname reason)) + (if (area-allowed? area areas) ;; is this area to be handled (from areas=a,b,c ...) + (let ((runname (alist-ref 'runname runkeydat)) + (runtrans (alist-ref 'runtrans runkeydat)) + (reason (alist-ref 'message runkeydat)) + (sched (alist-ref 'sched runkeydat)) + (action (alist-ref 'action runkeydat)) + (dbdest (alist-ref 'dbdest runkeydat)) + (append (alist-ref 'append runkeydat)) + (target (or (alist-ref 'target runkeydat) runkey))) ;; override with target if forced + (print "Have: runkey=" runkey " contour=" contour " area=" area " action=" action " tag-expr=" tag-expr " mode-patt=" mode-patt " target=" target) + (if (case (or (and action (string->symbol action)) 'noaction) ;; ensure we have the needed data to run this action + ((noaction) #f) + ((run) (and runname reason)) ((sync sync-prepend) (and reason dbdest)) - (else #f)) - ;; instead of unwrapping the runkeydat alist, pass it directly to create-run-pkt - (create-run-pkt mtconf action area runkey runname mode-patt tag-expr pktsdir reason contour sched dbdest append runtrans) - (print "ERROR: Missing info to make a " action " call: runkey=" runkey " contour=" contour " area=" area " tag-expr=" tag-expr " mode-patt=" mode-patt " dbdest=" dbdest) - ))) + (else #f)) + ;; instead of unwrapping the runkeydat alist, pass it directly to create-run-pkt + (create-run-pkt mtconf action area runkey runname mode-patt tag-expr pktsdir reason contour sched dbdest append runtrans) + (print "ERROR: Missing info to make a " action " call: runkey=" runkey " contour=" contour " area=" area " tag-expr=" tag-expr " mode-patt=" mode-patt " dbdest=" dbdest) + )) + (print "NOTE: skipping " runkeydat " for area, not in " areas))) all-areas)) runkeydats))) (let ((res (configf:get-section torun contour))) ;; each contour / target ;; (print "res=" res) res)))) @@ -896,11 +924,11 @@ (if (file-exists? debugcontrolf) (load debugcontrolf))) (if *action* (case (string->symbol *action*) - ((run remove rerun set-ss archive kill) + ((run remove rerun set-ss archive kill list) (let* ((mtconfdat (simple-setup (args:get-arg "-start-dir"))) (mtconf (car mtconfdat)) (pktsdirs (configf:lookup mtconf "setup" "pktsdirs")) (pktsdir (if pktsdirs (car (string-split pktsdirs " ")) #f)) (adjargs (hash-table-copy args:arg-hash))) @@ -923,10 +951,32 @@ (load-pkts-to-db mtconf) (dispatch-commands mtconf toppath))) ((import) (load-pkts-to-db mtconf)) ;; import pkts ((rungen) (generate-run-pkts mtconf toppath)) ((dispatch) (dispatch-commands mtconf toppath))))) + ;; misc + ((show) + (if (> (length remargs) 0) + (let* ((mtconfdat (simple-setup (args:get-arg "-start-dir"))) + (mtconf (car mtconfdat)) + (sect-dat (configf:get-section mtconf (car remargs)))) + (if sect-dat + (for-each + (lambda (entry) + (if (> (length entry) 1) + (print (car entry) " " (cadr entry)) + (print (car entry)))) + sect-dat) + (print "No section \"" (car remargs) "\" found"))) + (print "ERROR: list requires section parameter; areas, setup or contours"))) + ((gendot) + (let* ((mtconfdat (simple-setup (args:get-arg "-start-dir"))) + (mtconf (car mtconfdat))) + (with-queue-db + mtconf + (lambda (pktsdirs pktsdir conn) + (make-report "out.dot" conn '()))))) ((db) (if (null? remargs) (print "ERROR: missing sub command for db command") (let ((subcmd (car remargs))) (case (string->symbol subcmd) @@ -963,5 +1013,11 @@ (install-history-file (get-environment-variable "HOME") ".mtutil_history") ;; [homedir] [filename] [nlines]) (current-input-port (make-readline-port "mtutil> ")) (if (args:get-arg "-repl") (repl) (load (args:get-arg "-load"))))) + +#| +(define mtconf (car (simple-setup #f))) +(define dat (with-queue-db mtconf (lambda (conn)(get-pkts conn '())))) +(pp (pkts#flatten-all dat '((cmd . ((parent . P)(url . M)))(runtype . ((parent . P)))) 'id 'group-id 'uuid 'parent 'pkt-type 'pkt 'processed)) +|# Index: runconfigs.config ================================================================== --- runconfigs.config +++ runconfigs.config @@ -8,12 +8,12 @@ # example of a cron entry to run sync using db spec pgdb, with pgdb setting in file local.config # [a/b/c] all:scheduled:sync cron= 0/5 * * * *;dbdest=pgdb;appendconf=/mfs/matt/.sysmaint/local.config -quick:scheduled:sync cron= 0/5 * * * *;dbdest=pgdb;appendconf=/mfs/matt/.sysmaint/local.config -fast:scheduled:sync-prepend cron= 0/1 * * * *;dbdest=pgdb;appendconf=/mfs/matt/.sysmaint/local.config +# quick:scheduled:sync cron= 0/5 * * * *;dbdest=pgdb;appendconf=/mfs/matt/.sysmaint/local.config +# fast:scheduled:sync-prepend cron= 0/1 * * * *;dbdest=pgdb;appendconf=/mfs/matt/.sysmaint/local.config [scriptinc ./gentargets.sh #{getenv USER}] # [v1.23/45/67] # tip will be replaced with hashkey? @@ -25,24 +25,25 @@ # [v1.63/tip/dev] # file: files changes since last run trigger new run # script: script is called with unix seconds as last parameter (other parameters are preserved) # # contour:sensetype:action params data -quick:file:run runtrans=auto; glob=/home/matt/data/megatest/*.scm -snazy:file:run runtrans=corporate-ww; glob=/home/matt/data/megatest/*.scm +# commented out for debug +# quick:file:run runtrans=auto; glob=/home/matt/data/megatest/*.scm +# snazy:file:run runtrans=corporate-ww; glob=/home/matt/data/megatest/*.scm short:file:run runtrans=short; glob=/home/matt/data/megatest/*.scm # script returns change-time (unix epoch), new-target-name, run-name # # quick:script:run checkfossil = http://www.kiatoa.com/fossils/megatest v1.63;\ # checkfossil = http://www.kiatoa.com/fossils/megatest_qa trunk -# fossil based trigger -# -quick:fossil:run http://www.kiatoa.com/fossils/megatest=v1.63;\ - http://www.kiatoa.com/fossils/megatest_qa=trunk;\ - http://www.kiatoa.com/fossils/megatest=v1.64 +# # fossil based trigger +# # +# quick:fossil:run http://www.kiatoa.com/fossils/megatest=v1.63;\ +# http://www.kiatoa.com/fossils/megatest_qa=trunk;\ +# http://www.kiatoa.com/fossils/megatest=v1.64 # field allowed values # ----- -------------- # minute 0-59 # hour 0-23 Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -96,18 +96,28 @@ (msg ((condition-property-accessor 'exn 'message) exn))) (if (< count 5) (begin ;; this call is colliding, do some crude stuff to fix it. (debug:print 0 *default-log-port* "ERROR: *configdat* was inaccessible! This should never happen. Retry #" count) (launch:setup force-reread: #t) - (fatal-loop (+ count 1))) + (fatal-loop (+ count 1))) (begin (debug:print 0 *default-log-port* "FATAL: *configdat* was inaccessible! This should never happen. Retried " count " times. Message: " msg) (debug:print 0 *default-log-port* "Call chain:") (with-output-to-port *default-log-port* - (lambda ()(pp call-chain))) + + (lambda () + (print "*configdat* is >>"*configdat*"<<") + (pp *configdat*) + (pp call-chain))) + (exit 1)))) ;;(bb-check-path msg: "runs:set-megatest-env-vars block 1.5") + (when (or (not *configdat*) (not (hash-table? *configdat*))) + (debug:print 0 *default-log-port* "WARNING: *configdat* was inaccessible! This should never happen. Brute force reread.") + ;;(BB> "ERROR: *configdat* was inaccessible! This should never happen. Brute force reread.") + (thread-sleep! 2) ;; assuming nfs lag. + (launch:setup force-reread: #t)) (alist->env-vars (hash-table-ref/default *configdat* "env-override" '())))) ;;;; environment is tainted HERE in this let block. ;;(bb-check-path msg: "runs:set-megatest-env-vars block 2") ;; Lets use this as an opportunity to put MT_RUNNAME in the environment (let ((runname (if inrunname inrunname (rmt:get-run-name-from-id run-id)))) (if runname @@ -218,11 +228,49 @@ " in jobgroup \"" jobgroup "\" exceeds limit of " job-group-limit)) #t) (else #f)))) (list (not can-not-run-more) num-running num-running-in-jobgroup max-concurrent-jobs job-group-limit))))) - +(define (runs:run-pre-hook run-id) + (let* ((run-pre-hook (configf:lookup *configdat* "runs" "pre-hook")) + (existing-tests (if run-pre-hook + (rmt:get-tests-for-run run-id "%" '() '() ;; run-id testpatt states statuses + #f #f ;; offset limit + #f ;; not-in + #f ;; sort-by + #f ;; sort-order + #f ;; get full data (not 'shortlist) + 0 ;; (runs:gendat-inc-results-last-update *runs:general-data*) ;; last update time + 'dashboard) + '())) + (log-dir (conc *toppath* "/logs")) + (log-file (conc "pre-hook-" (string-translate (getenv "MT_TARGET") "/" "-") "-" (getenv "MT_RUNNAME") ".log")) + (full-log-fname (conc log-dir "/" log-file))) + (if run-pre-hook + (if (null? existing-tests) + (let* ((use-log-dir (if (not (directory-exists? log-dir)) + (handle-exceptions + exn + (begin + (debug:print 0 *default-log-port* "WARNING: Failed to create " log-dir) + #f) + (create-directory log-dir #t) + #t) + #t)) + (start-time (current-seconds)) + (actual-logf (if use-log-dir full-log-fname log-file))) + (handle-exceptions + exn + (begin + (print-call-chain *default-log-port*) + (debug:print 0 *default-log-port* "Message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 *default-log-port* "ERROR: failed to run pre-hook " run-pre-hook ", check the log " log-file)) + (debug:print-info 0 *default-log-port* "running run-pre-hook: \"" run-pre-hook "\", log is " actual-logf) + (system (conc run-pre-hook " >> " actual-logf " 2>&1")) + (debug:print-info 0 *default-log-port* "pre-hook \"" run-pre-hook "\" took " (- (current-seconds) start-time) " seconds to run."))) + (debug:print 0 *default-log-port* "Skipping pre-hook call \"" run-pre-hook "\" as there are existing tests for this run."))))) + ;; test-names: Comma separated patterns same as test-patts but used in selection ;; of tests to run. The item portions are not respected. ;; FIXME: error out if /patt specified ;; (define (runs:run-tests target runname test-patts user flags #!key (run-count 1)) ;; test-names @@ -292,10 +340,16 @@ (debug:print 0 *default-log-port* "WARNING: You do not have a run config file: " runconfigf) #f))) (if (not test-patts) ;; first time in - adjust testpatt (set! test-patts (common:args-get-testpatt runconf))) + ;; if test-patts is #f at this point there is something wrong and we need to bail out + (if (not test-patts) + (begin + (debug:print 0 *default-log-port* "WARNING: there is no test pattern for this run. Exiting now.") + (exit 0))) + (if (args:get-arg "-tagexpr") (begin (set! allowed-tests (string-join (runs:get-tests-matching-tags (args:get-arg "-tagexpr")) ",")) (debug:print-info 0 *default-log-port* "filtering initial test list with tagexpr: " (args:get-arg "-tagexpr") " => " allowed-tests) ));; tests will be ANDed with this list @@ -361,10 +415,14 @@ (string-split (or (configf:lookup *configdat* "setup" "allow-auto-rerun") ""))))) ;; Ensure all tests are registered in the test_meta table (runs:update-all-test_meta #f) + ;; run the run prehook if there are no tests yet run for this run: + ;; + (runs:run-pre-hook run-id) + ;; now add non-directly referenced dependencies (i.e. waiton) ;;====================================================================== ;; refactoring this block into tests:get-full-data ;; ;; What happended, this code is now duplicated in tests!? @@ -1703,11 +1761,10 @@ (readonly-mode (not (file-write-access? dbfile)))) (when (and readonly-mode (member action write-access-actions)) (debug:print-error 0 *default-log-port* "megatest.db is readonly. Cannot proceed with action ["action"] in which write-access isrequired .") (exit 1))) - (debug:print-info 4 *default-log-port* "runs:operate-on => Header: " header " action: " action " new-state-status: " new-state-status) (if (> 2 (length state-status)) (begin (debug:print-error 0 *default-log-port* "the parameter to -set-state-status is a comma delimited string. E.g. COMPLETED,FAIL") Index: tasks.scm ================================================================== --- tasks.scm +++ tasks.scm @@ -183,15 +183,18 @@ ;; no elegance here ... ;; (define (tasks:kill-server hostname pid #!key (kill-switch "")) (debug:print-info 0 *default-log-port* "Attempting to kill server process " pid " on host " hostname) (setenv "TARGETHOST" hostname) - (setenv "TARGETHOST_LOGF" "server-kills.log") - (system (conc "nbfake kill "kill-switch" "pid)) - - (unsetenv "TARGETHOST_LOGF") - (unsetenv "TARGETHOST")) + (let ((logdir (if (directory-exists? "logs") + "logs/" + ""))) + (setenv "TARGETHOST_LOGF" (conc logdir "server-kills.log")) + (system (conc "nbfake kill "kill-switch" "pid)) + + (unsetenv "TARGETHOST_LOGF") + (unsetenv "TARGETHOST"))) ;;====================================================================== ;; M O N I T O R S ;;====================================================================== Index: tests.scm ================================================================== --- tests.scm +++ tests.scm @@ -1146,14 +1146,15 @@ (getenv "MT_TEST_NAME") (getenv "MT_ITEMPATH")) (conc (getenv "MT_LINKTREE") "/" (getenv "MT_TARGET") "/" (getenv "MT_RUNNAME") "/" - (getenv "MT_TEST_NAME") "/" - (if (or (getenv "MT_ITEMPATH") - (not (string=? "" (getenv "MT_ITEMPATH")))) - (conc "/" (getenv "MT_ITEMPATH")))) + (getenv "MT_TEST_NAME") + (if (and (getenv "MT_ITEMPATH") + (not (string=? "" (getenv "MT_ITEMPATH")))) + (conc "/" (getenv "MT_ITEMPATH")) + "")) #f)) ;; if .testconfig exists in test directory read and return it ;; else if have cached copy in *testconfigs* return it IFF there is a section "have fulldata" ;; else read the testconfig file