Index: .mtutil.scm
==================================================================
--- .mtutil.scm
+++ .mtutil.scm
@@ -23,45 +23,46 @@
(define (str-first-char->number str)
(char->integer (string-ref str 0)))
;; example of how to set up and write target mappers
;;
-(hash-table-set! *target-mappers*
- 'prefix-contour
- (lambda (target run-name area area-path reason contour mode-patt)
- (conc contour "/" target)))
-(hash-table-set! *target-mappers*
- 'prefix-area-contour
- (lambda (target run-name area area-path reason contour mode-patt)
- (conc area "/" contour "/" target)))
-
-(hash-table-set! *runname-mappers*
- 'corporate-ww
- (lambda (target run-name area area-path reason contour mode-patt)
- (print "corporate-ww called with: target=" target " run-name=" run-name " area=" area " area-path=" area-path " reason=" reason " contour=" contour " mode-patt=" mode-patt)
- (let* ((last-name (get-last-runname area-path target))
- (last-letter (let* ((ch (if (string? last-name)
- (let ((len (string-length last-name)))
- (substring last-name (- len 1) len))
- "a"))
- (chnum (str-first-char->number ch))
- (a (str-first-char->number "a"))
- (z (str-first-char->number "z")))
- (if (and (>= chnum a)(<= chnum z))
- chnum
- #f)))
- (next-letter (if last-letter
- (list->string
- (list
- (integer->char
- (+ last-letter 1)))) ;; surely there is an easier way?
- "a")))
- ;; (print "last-name: " last-name " last-letter: " last-letter " next-letter: " next-letter)
- (conc (seconds->wwdate (current-seconds)) next-letter))))
-
-(hash-table-set! *runname-mappers*
- 'auto
- (lambda (target run-name area area-path reason contour mode-patt)
- "auto-eh"))
-
-;; (print "Got here!")
+(add-target-mapper 'prefix-contour
+ (lambda (target run-name area area-path reason contour mode-patt)
+ (conc contour "/" target)))
+(add-target-mapper 'prefix-area-contour
+ (lambda (target run-name area area-path reason contour mode-patt)
+ (conc area "/" contour "/" target)))
+
+(add-runname-mapper 'corporate-ww
+ (lambda (target run-name area area-path reason contour mode-patt)
+ (print "corporate-ww called with: target=" target " run-name=" run-name " area=" area " area-path=" area-path " reason=" reason " contour=" contour " mode-patt=" mode-patt)
+ (let* ((last-name (get-last-runname area-path target))
+ (last-letter (let* ((ch (if (string? last-name)
+ (let ((len (string-length last-name)))
+ (substring last-name (- len 1) len))
+ "a"))
+ (chnum (str-first-char->number ch))
+ (a (str-first-char->number "a"))
+ (z (str-first-char->number "z")))
+ (if (and (>= chnum a)(<= chnum z))
+ chnum
+ #f)))
+ (next-letter (if last-letter
+ (list->string
+ (list
+ (integer->char
+ (+ last-letter 1)))) ;; surely there is an easier way?
+ "a")))
+ ;; (print "last-name: " last-name " last-letter: " last-letter " next-letter: " next-letter)
+ (conc (seconds->wwdate (current-seconds)) next-letter))))
+
+(add-runname-mapper 'auto
+ (lambda (target run-name area area-path reason contour mode-patt)
+ "auto-eh"))
+
+;; run only areas where first letter of area name is "a"
+;;
+(add-area-checker 'first-letter-a
+ (lambda (area target contour)
+ (string-match "^a.*$" area)))
+
Index: common.scm
==================================================================
--- common.scm
+++ common.scm
@@ -17,11 +17,10 @@
(import (prefix sqlite3 sqlite3:))
(import (prefix base64 base64:))
(declare (unit common))
-(declare (uses keys))
(include "common_records.scm")
;; (require-library margs)
;; (include "margs.scm")
@@ -238,11 +237,11 @@
(db:multi-db-sync
dbstruct
;; 'new2old
'killservers
'dejunk
- ;; 'adj-testids
+ 'adj-target
;; 'old2new
'new2old
'schema)
(if (common:version-changed?)
(common:set-last-run-version)))
@@ -478,14 +477,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 +968,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,30 +1003,44 @@
;;;; 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"))
+ (if *configdat*
+ (configf:lookup *configdat* "setup" "linktree")
(if *toppath*
(conc *toppath* "/lt")
- (if (file-exists? "megatest.config") ;; we are in the toppath (new area, mtutils compatible)
- (conc (current-directory) "/lt")
- #f)))))
+ #f))))
(define (common:args-get-runname)
(let ((res (or (args:get-arg "-runname")
(args:get-arg ":runname")
(getenv "MT_RUNNAME"))))
;; (if res (set-environment-variable "MT_RUNNAME" res)) ;; not sure if this is a good idea. side effect and all ...
res))
+
+(define (common:get-fields cfgdat)
+ (let ((fields (hash-table-ref/default cfgdat "fields" '())))
+ (map car fields)))
(define (common:args-get-target #!key (split #f)(exit-if-bad #f))
- (let* ((keys (if (hash-table? *configdat*) (keys:config-get-fields *configdat*) '()))
+ (let* ((keys (if (hash-table? *configdat*) (common:get-fields *configdat*) '()))
(numkeys (length keys))
(target (or (args:get-arg "-reqtarg")
(args:get-arg "-target")
(getenv "MT_TARGET")))
(tlist (if target (string-split target "/" #t) '()))
@@ -1041,10 +1058,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 +1134,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 +1168,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.
@@ -400,11 +401,11 @@
(let* ((curr-dir (current-directory))
(configinfo (find-config fname toppath: given-toppath))
(toppath (car configinfo))
(configfile (cadr configinfo))
(set-fields (lambda (curr-section next-section ht path)
- (let ((field-names (if ht (keys:config-get-fields ht) '()))
+ (let ((field-names (if ht (common:get-fields ht) '()))
(target (or (getenv "MT_TARGET")(args:get-arg "-reqtarg")(args:get-arg "-target"))))
(debug:print-info 9 *default-log-port* "set-fields with field-names=" field-names " target=" target " curr-section=" curr-section " next-section=" next-section " path=" path " ht=" ht)
(if (not (null? field-names))(keys:target-set-args field-names target #f))))))
(if toppath (change-directory toppath))
(if (and toppath pathenvvar)(setenv pathenvvar toppath))
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
@@ -836,10 +836,40 @@
BEGIN
UPDATE run_stats SET last_update=(strftime('%s','now'))
WHERE id=old.id;
END;"))
+(define (db:adj-target db)
+ (let ((fields (configf:get-section *configdat* "fields"))
+ (field-num 0))
+ ;; because we will be refreshing the keys table it is best to clear it here
+ (sqlite3:execute db "DELETE FROM keys;")
+ (for-each
+ (lambda (field)
+ (let ((column (car field))
+ (spec (cadr field)))
+ (handle-exceptions
+ exn
+ (if (string-match ".*duplicate.*" ((condition-property-accessor 'exn 'message) exn))
+ (debug:print 0 *default-log-port* "Target field " column " already exists in the runs table")
+ (db:general-sqlite-error-dump exn "alter table runs ..." #f "none"))
+ ;; Add the column if needed
+ (sqlite3:execute
+ db
+ (conc "ALTER TABLE runs ADD COLUMN " column " " spec)))
+ ;; correct the entry in the keys column
+ (sqlite3:execute
+ db
+ "INSERT INTO keys (id,fieldname,fieldtype) VALUES (?,?,?);"
+ field-num column spec)
+ ;; fill in blanks (not allowed as it would be part of the path
+ (sqlite3:execute
+ db
+ (conc "UPDATE runs SET " column "='x' WHERE " column "='';"))
+ (set! field-num (+ field-num 1))))
+ fields)))
+
(define *global-db-store* (make-hash-table))
(define (db:get-access-mode)
(if (args:get-arg "-use-db-cache") 'cached 'rmt))
@@ -923,138 +953,62 @@
(tmpdb (db:get-db dbstruct))
(refndb (dbr:dbstruct-refndb dbstruct))
(allow-cleanup #t) ;; (if run-ids #f #t))
(servers (server:get-list *toppath*)) ;; (tasks:get-all-servers (db:delay-if-busy tdbdat)))
(data-synced 0)) ;; count of changed records (I hope)
-
- ;; kill servers
- (if (member 'killservers options)
- (for-each
- (lambda (server)
- (match-let (((mod-time host port start-time pid) server))
- (if (and host pid)
- (tasks:kill-server host pid))))
- servers))
-
- ;; clear out junk records
- ;;
- (if (member 'dejunk options)
- (begin
+
+ (for-each
+ (lambda (option)
+
+ (case option
+ ;; kill servers
+ ((killservers)
+ (for-each
+ (lambda (server)
+ (match-let (((mod-time host port start-time pid) server))
+ (if (and host pid)
+ (tasks:kill-server host pid))))
+ servers))
+
+ ;; clear out junk records
+ ;;
+ ((dejunk)
(db:delay-if-busy mtdb) ;; ok to delay on mtdb
(db:clean-up mtdb)
(db:clean-up tmpdb)
- (db:clean-up refndb)))
-
- ;; adjust test-ids to fit into proper range
- ;;
- ;; (if (member 'adj-testids options)
- ;; (begin
- ;; (db:delay-if-busy mtdb)
- ;; (db:prep-megatest.db-for-migration mtdb)))
-
- ;; sync runs, test_meta etc.
- ;;
- (if (member 'old2new options)
- ;; (begin
- (set! data-synced
- (+ (db:sync-tables (db:sync-all-tables-list dbstruct) #f mtdb tmpdb refndb)
- data-synced)))
- ;; (db:sync-main-list mtdb) mtdb (db:get-db dbstruct #f))
-;; (for-each
-;; (lambda (run-id)
-;; (db:delay-if-busy mtdb)
-;; (let ((testrecs (db:get-all-tests-info-by-run-id mtdb run-id)))
-;; ;; (dbstruct (if toppath (make-dbr:dbstruct path: toppath local: #t) #f)))
-;; (debug:print 0 *default-log-port* "INFO: Propagating " (length testrecs) " records for run-id=" run-id " to run specific db")
-;; (db:replace-test-records dbstruct run-id testrecs)
-;; (sqlite3:finalize! (db:dbdat-get-db (dbr:dbstruct-rundb dbstruct)))))
-;; run-ids)))
-
- ;; now ensure all newdb data are synced to megatest.db
- ;; do not use the run-ids list passed in to the function
- ;;
- (if (member 'new2old options)
- (set! data-synced
- (+ (db:sync-tables (db:sync-all-tables-list dbstruct) #f tmpdb refndb mtdb)
- data-synced)))
-
-
-
- (if (member 'schema options)
- (begin
+ (db:clean-up refndb))
+
+ ;; sync runs, test_meta etc.
+ ;;
+ ((old2new)
+ (set! data-synced
+ (+ (db:sync-tables (db:sync-all-tables-list dbstruct) #f mtdb tmpdb refndb)
+ data-synced)))
+
+ ;; now ensure all newdb data are synced to megatest.db
+ ;; do not use the run-ids list passed in to the function
+ ;;
+ ((new2old)
+ (set! data-synced
+ (+ (db:sync-tables (db:sync-all-tables-list dbstruct) #f tmpdb refndb mtdb)
+ data-synced)))
+
+ ((adj-target)
+ (db:adj-target (db:dbdat-get-db mtdb))
+ (db:adj-target (db:dbdat-get-db tmpdb))
+ (db:adj-target (db:dbdat-get-db refndb)))
+
+ ((schema)
(db:patch-schema-maindb (db:dbdat-get-db mtdb))
(db:patch-schema-maindb (db:dbdat-get-db tmpdb))
(db:patch-schema-maindb (db:dbdat-get-db refndb))
(db:patch-schema-rundb (db:dbdat-get-db mtdb))
(db:patch-schema-rundb (db:dbdat-get-db tmpdb))
(db:patch-schema-rundb (db:dbdat-get-db refndb))))
-
- ;; (let* ((maindb (make-dbr:dbstruct path: toppath local: #t))
- ;; (src-run-ids (if run-ids run-ids (db:get-all-run-ids (db:dbdat-get-db (db:get-db maindb 0)))))
- ;; (all-run-ids (sort (delete-duplicates (cons 0 src-run-ids)) <))
- ;; (count 1)
- ;; (total (length all-run-ids))
- ;; (dead-runs '()))
- ;; ;; first fix schema if needed
- ;; (map
- ;; (lambda (th)
- ;; (thread-join! th))
- ;; (map
- ;; (lambda (run-id)
- ;; (thread-start!
- ;; (make-thread
- ;; (lambda ()
- ;; (let* ((fromdb (if toppath (make-dbr:dbstruct path: toppath local: #t) #f))
-;; (if (member 'schema options)
- ;; (if (eq? run-id 0)
- ;; (let ((maindb (db:dbdat-get-db (db:get-db fromdb #f))))
- ;; (db:patch-schema-maindb run-id maindb))
- ;; (db:patch-schema-rundb run-id frundb)))
- ;; (set! count (+ count 1))
- ;; (debug:print 0 *default-log-port* "Finished patching schema for " (if (eq? run-id 0) " main.db " (conc run-id ".db")) ", " count " of " total)))))
- ;; all-run-ids))
- ;; ;; Then sync and fix db's
- ;; (set! count 0)
- ;; (process-fork
- ;; (lambda ()
- ;; (map
- ;; (lambda (th)
- ;; (thread-join! th))
- ;; (map
- ;; (lambda (run-id)
- ;; (thread-start!
- ;; (make-thread
- ;; (lambda ()
- ;; (let* ((fromdb (if toppath (make-dbr:dbstruct path: toppath local: #t) #f))
- ;; (frundb (db:dbdat-get-db (db:get-db fromdb run-id))))
- ;; (if (eq? run-id 0)
- ;; (let ((maindb (db:dbdat-get-db (db:get-db fromdb #f))))
-;; (db:sync-tables (db:sync-main-list dbstruct) #f (db:get-db fromdb #f) mtdb)
- ;; (set! dead-runs (db:clean-up-maindb (db:get-db fromdb #f))))
- ;; (begin
- ;; ;; NB// must sync first to ensure deleted tests get marked as such in megatest.db
-;; (db:sync-tables db:sync-tests-only #f (db:get-db fromdb run-id) mtdb)
- ;; (db:clean-up-rundb (db:get-db fromdb run-id)))))
- ;; (set! count (+ count 1))
- ;; (debug:print 0 *default-log-port* "Finished clean up of "
- ;; (if (eq? run-id 0)
- ;; " main.db " (conc run-id ".db")) ", " count " of " total)))))
- ;; all-run-ids))))
-
- ;; removed deleted runs
-;; (let ((dbdir (tasks:get-task-db-path)))
-;; (for-each (lambda (run-id)
-;; (let ((fullname (conc dbdir "/" run-id ".db")))
-;; (if (file-exists? fullname)
-;; (begin
-;; (debug:print 0 *default-log-port* "Removing database file for deleted run " fullname)
-;; (delete-file fullname)))))
-;; dead-runs))))
-;;
- ;; (db:close-all dbstruct)
- ;; (sqlite3:finalize! mdb)
- (stack-push! (dbr:dbstruct-dbstack dbstruct) tmpdb)
+
+ (stack-push! (dbr:dbstruct-dbstack dbstruct) tmpdb))
+ options)
data-synced)))
;; keeping it around for debugging purposes only
(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)
@@ -1105,17 +1059,17 @@
(launch:setup)) ;; added because Elena was getting stack dump because *configinfo* below was #f.
(let* ((configdat (car *configinfo*)) ;; tut tut, global warning...
(keys (keys:config-get-fields configdat))
(havekeys (> (length keys) 0))
(keystr (keys->keystr keys))
- (fieldstr (keys->key/field keys))
+ (fieldstr (keys:make-key/field-string configdat))
(db (db:dbdat-get-db dbdat)))
(for-each (lambda (key)
(let ((keyn key))
(if (member (string-downcase keyn)
(list "runname" "state" "status" "owner" "event_time" "comment" "fail_count"
- "pass_count"))
+ "pass_count" "contour"))
(begin
(print "ERROR: your key cannot be named " keyn " as this conflicts with the same named field in the runs table, you must remove your megatest.db and <linktree>/.db before trying again.")
(exit 1)))))
keys)
(sqlite3:with-transaction
@@ -3349,10 +3303,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: docs/Makefile
==================================================================
--- docs/Makefile
+++ docs/Makefile
@@ -13,5 +13,7 @@
fossil add html/*
megatest.pdf : megatest.lyx
lyx -e pdf2 megatest.lyx
+pkts.pdf : pkts.dot
+ dot -Tpdf pkts.dot -o pkts.pdf
ADDED docs/pkts.dot
Index: docs/pkts.dot
==================================================================
--- /dev/null
+++ docs/pkts.dot
@@ -0,0 +1,59 @@
+digraph megatest_pkts {
+ ranksep=0.05
+ // rankdir=LR
+
+node [shape=box,style=filled];
+
+ "SENSORS" [ label = "{ Sensor Processing | { file | git | fossil | script }}"
+ shape = "record"; ];
+
+ "RUNS" [ label = "{ Runs Processing | { launch | clean | re-run | archive } | { dispatcher }}";
+ shape = "record"; ];
+
+ "WORK" [ label = "{ Work Items | { start task | task competed }}";
+ shape = "record"; ];
+
+ "USERREQ" [ label = "{ User Requests (Unix and Web) | { launch | clean | re-run | archive }}";
+ shape = "record"; ];
+
+ "MTAREA1" [ label = "{ Megatest Area 1 | { parallel job\nmanagement | test\nmanagement | data\nrollup }}";
+ shape = "record"; ];
+
+ "MTAREA2" [ label = "{ Megatest Area 2 | { parallel job\nmanagement | test\nmanagement | data\nrollup }}";
+ shape = "record"; ];
+
+ "MTAREA3" [ label = "More Megatest Areas ... ";
+ shape = "record"; ];
+
+ "PGDB" [ label = "postgres database";
+ shape = "cylinder"; ];
+
+ "WEBAPP" [ label = "{ Web View | { Runs | Contours | Control | Time View }}";
+ shape = "record"; ];
+
+ // "WEBCTRL" [ label = "{ Web View \n(control) }";
+ // shape = "record"; ];
+
+ "SENSORS" -> "SPKTS";
+ "RUNS" -> "run pkts";
+ "run pkts" -> "RUNS";
+ "WORK" -> "work pkts";
+ "work pkts" -> "RUNS";
+ "USERREQ" -> "user request pkts";
+ "SPKTS" -> "RUNS";
+ "user request pkts" -> "RUNS";
+ "RUNS" -> "MTAREA1" -> "PGDB";
+ "RUNS" -> "MTAREA2" -> "PGDB";
+ "RUNS" -> "MTAREA3" -> "PGDB";
+ "PGDB" -> "WEBAPP";
+ // "WEBCTRL" -> "run pkts";
+
+ subgraph cluster_pkts {
+ label="Packets";
+ "SPKTS" [ label = "Sensor Packets" ];
+ "run pkts";
+ "work pkts";
+ "user request pkts";
+ }
+}
+
ADDED docs/pkts.pdf
Index: docs/pkts.pdf
==================================================================
--- /dev/null
+++ docs/pkts.pdf
cannot compute difference between binary files
Index: gutils.scm
==================================================================
--- gutils.scm
+++ gutils.scm
@@ -28,10 +28,11 @@
((COMPLETED) ;; ARCHIVED)
(case (string->symbol status)
((PASS) (list "70 249 73" status))
((WARN WAIVED) (list "255 172 13" status))
((SKIP) (list "230 230 0" status))
+ ((ABORT) (list "198 36 166" status))
(else (list "253 33 49" status))))
((ARCHIVED)
(case (string->symbol status)
((PASS) (list "70 170 73" status))
((WARN WAIVED) (list "200 130 13" status))
Index: items.scm
==================================================================
--- items.scm
+++ items.scm
@@ -132,12 +132,12 @@
(set! itemstable (map (lambda (item)
(if (procedure? (cadr item))
(list (car item)((cadr item))) ;; evaluate the proc
item))
itemstable))
- (if (and have-items (null? items)) (debug:print-error 0 *default-log-port* "[items] section in testconfig but no entries defined"))
- (if (and have-itable (null? itemstable))(debug:print-error 0 *default-log-port* "[itemstable] section in testconfig but no entries defined"))
+ (if (and have-items (null? items)) (debug:print 0 *default-log-port* "WARNING:[items] section in testconfig but no entries defined"))
+ (if (and have-itable (null? itemstable))(debug:print 0 *default-log-port* "WARNNG:[itemstable] section in testconfig but no entries defined"))
(if (or (not (null? items))(not (null? itemstable)))
(append (item-assoc->item-list items)
(item-table->item-list itemstable))
'(()))))
Index: key_records.scm
==================================================================
--- key_records.scm
+++ key_records.scm
@@ -10,13 +10,13 @@
;;======================================================================
(define-inline (keys->valslots keys) ;; => ?,?,? ....
(string-intersperse (map (lambda (x) "?") keys) ","))
-(define-inline (keys->key/field keys . additional)
- (string-join (map (lambda (k)(conc k " TEXT"))
- (append keys additional)) ","))
+;; (define-inline (keys->key/field keys . additional)
+;; (string-join (map (lambda (k)(conc k " TEXT"))
+;; (append keys additional)) ","))
(define-inline (item-list->path itemdat)
(if (list? itemdat)
(string-intersperse (map cadr itemdat) "/")
""))
Index: keys.scm
==================================================================
--- keys.scm
+++ keys.scm
@@ -64,9 +64,13 @@
;;======================================================================
;; config file related routines
;;======================================================================
-(define (keys:config-get-fields confdat)
- (let ((fields (hash-table-ref/default confdat "fields" '())))
- (map car fields)))
+(define keys:config-get-fields common:get-fields)
+(define (keys:make-key/field-string confdat)
+ (let ((fields (configf:get-section confdat "fields")))
+ (string-join
+ (map (lambda (field)(conc (car field) " " (cadr field)))
+ fields)
+ ",")))
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.6501)
Index: megatest.config
==================================================================
--- megatest.config
+++ megatest.config
@@ -1,22 +1,33 @@
-[fields]
-a text
-b text
-c text
+# [fields]
+# a text
+# b text
+# c text
+
+[defaults]
+usercode .mtutil.scm
+areafilter area-to-run
+targtrans generic-target-translator
+runtrans generic-runname-translator
[setup]
-pktsdirs /tmp/pkts /some/other/source
+pktsdirs /tmp/mt_pkts /some/other/source
[areas]
# path-to-area map-target-script(future, optional)
-fullrun path=tests/fullrun
+# someqa path=../megatestqa/someqa; targtrans=somefunc; areafilter=area-to-run
+fullrun path=tests/fullrun;
# targtrans is name of scheme proc stored in .mtutil.scm, which lives in PWD where mtutil is run
+# the target translator can return: a/target OR (list/of targets/to apply/run) OR #f i.e. run nothing
# ext-tests path=ext-tests; targtrans=prefix-contour;
ext-tests path=ext-tests
[contours]
# mode-patt/tag-expr
-quick selector=QUICKPATT/quick
-full areas=fullrun,ext-tests; selector=MAXPATT/
-all areas=fullrun,ext-tests
-snazy areas=%; selector=QUICKPATT/
+quick areas=ext-tests; selector=/QUICKPATT
+# quick areas=fullrun,ext-tests; selector=QUICKPATT/quick
+# full areas=fullrun,ext-tests; selector=MAXPATT/
+# short areas=fullrun,ext-tests; selector=MAXPATT/
+# all areas=fullrun,ext-tests
+# snazy 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
@@ -494,10 +497,24 @@
;; for some switches always print the command to stderr
;;
(if (args:any? "-run" "-runall" "-remove-runs" "-set-state-status")
(debug:print 0 *default-log-port* (string-intersperse (argv) " ")))
+
+;; some switches imply homehost. Exit here if not on homehost
+;;
+(let ((homehost-required (list "-cleanup-db" "-server")))
+ (if (apply args:any? homehost-required)
+ (if (not (common:on-homehost?))
+ (for-each
+ (lambda (switch)
+ (if (args:get-arg switch)
+ (begin
+ (debug:print 0 *default-log-port* "ERROR: you must be on the homehost to run with " switch
+ ", you can move homehost by removing the .homehost file but this will disrupt any runs in progress.")
+ (exit 1))))
+ homehost-required))))
;;======================================================================
;; Misc setup stuff
;;======================================================================
@@ -861,11 +878,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 +1420,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))
@@ -25,13 +25,58 @@
(include "megatest-fossil-hash.scm")
(require-library stml)
-(define *target-mappers* (make-hash-table)) ;; '())
-(define *runname-mappers* (make-hash-table)) ;; '())
+;; stuff for the mapper and checker functions
+;;
+(define *target-mappers* (make-hash-table))
+(define *runname-mappers* (make-hash-table))
+(define *area-checkers* (make-hash-table))
+
+;; helpers for mappers/checkers
+(define (add-target-mapper name proc)
+ (hash-table-set! *target-mappers* name proc))
+(define (add-runname-mapper name proc)
+ (hash-table-set! *runname-mappers* name proc))
+(define (add-area-checker name proc)
+ (hash-table-set! *area-checkers* name proc))
+
+;; given a runkey, xlatr-key and other info return one of the following:
+;; list of targets, null list to skip processing
+;;
+(define (map-targets mtconf aval-alist runkey area contour #!key (xlatr-key-in #f))
+ (let* ((xlatr-key (or xlatr-key-in
+ (conf-get/default mtconf aval-alist 'targtrans)))
+ (proc (hash-table-ref/default *target-mappers* xlatr-key #f)))
+ (if proc
+ (begin
+ (print "Using target mapper: " area-xlatr)
+ (handle-exceptions
+ exn
+ (begin
+ (print "FAILED TO RUN TARGET MAPPER FOR " area ", called " area-xlatr)
+ (print " function is: " (hash-table-ref/default *target-mappers* xlatr-key #f ) )
+ (print " message: " ((condition-property-accessor 'exn 'message) exn))
+ runkey)
+ (proc runkey area contour)))
+ (begin
+ (if xlatr-key
+ (print "ERROR: Failed to find named target translator " xlatr-key ", using original target."))
+ `(,runkey))))) ;; no proc then use runkey
+;; given mtconf and areaconf extract a translator/filter, first look at areaconf
+;; then if not found look at default
+;;
+(define (conf-get/default mtconf areaconf keyname #!key (default #f))
+ (let ((res (or (alist-ref keyname areaconf)
+ (configf:lookup mtconf "default" (conc keyname))
+ default)))
+ (if res
+ (string->symbol res)
+ res)))
+
;; this needs some thought regarding security implications.
;;
;; i. Check that owner of the file and calling user are same?
;; ii. Check that we are in a legal megatest area?
;; iii. Have some form of authentication or record of the md5sum or similar of the file?
@@ -40,11 +85,11 @@
;;
(if (file-exists? "megatest.config")
(if (file-exists? ".mtutil.so")
(load ".mtutil.so")
(if (file-exists? ".mtutil.scm")
- (load ".mtutil.scm"))))
+ (load ".mtutil.scm"))))
;; Disabled help items
;; -rollup : (currently disabled) fill run (set by :runname) with latest test(s)
;; from prior runs with same keys
;; Contour actions
@@ -56,55 +101,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 <key> 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 <key> 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) " ") "
@@ -153,10 +199,32 @@
(define *action-keys*
'((run . "-run")
(sync . "")
(archive . "-archive")
(set-ss . "-set-state-status")))
+
+;; Card types:
+;;
+;; A action
+;; U username (Unix)
+;; D timestamp
+;; T card type
+
+;; utilitarian alist for standard cards
+;;
+(define *additional-cards*
+ '(
+ ;; Standard Cards
+ (A . action )
+ (D . timestamp )
+ (T . cardtype )
+ (U . user ) ;; username
+ (Z . shar1sum )
+
+ ;; Extras
+ (a . runkey ) ;; needed for matching up pkts with target derived from runkey
+ ))
;; inlst is an alternative input
;;
(define (lookup-param-by-key key #!key (inlst #f))
(fold (lambda (a res)
@@ -259,22 +327,14 @@
(loop (get-line) date node time))))
(else ;; no more datat and last node on branch not found
(close-input-port timeline-port)
(values (common:date-time->seconds (conc date " " time)) node))))))
-
;;======================================================================
;; GLOBALS
;;======================================================================
-;; Card types:
-;;
-;; a action
-;; u username (Unix)
-;; D timestamp
-;; T card type
-
;; process args
(define *action* (if (> (length (argv)) 1)
(cadr (argv))
#f))
(define remargs (args:get-args
@@ -301,10 +361,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 +385,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 +410,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 +450,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
@@ -397,13 +461,14 @@
(if (hash-table? args-alist) ;; seriously?
(hash-table->alist args-alist)
args-alist)
(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
+ '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
@@ -412,12 +477,12 @@
#f)))
(if (or pmeta smeta) ;; construct the switch/param pair.
(list meta value)
'())))
(filter cdr args-data)))))
-;; (print "Alldat: " alldat
-;; " args-data: " args-data)
+ (print "Alldat: " alldat
+ " args-data: " args-data)
(add-z-card
(apply construct-sdat alldat))))
(define (simple-setup start-dir-in)
(let* ((start-dir (or start-dir-in "."))
@@ -446,16 +511,19 @@
;; ii. Pass the pkt keys and values to this proc and go from there.
;; iii. Maybe have an abstraction alist with meaningful names for the pkt keys
;;
;; Override the run start time record with sched. Usually #f is fine.
;;
-(define (create-run-pkt mtconf action area runkey runname mode-patt tag-expr pktsdir reason contour sched dbdest append-conf runtrans)
+(define (create-run-pkt mtconf action area runkey target runname mode-patt
+ tag-expr pktsdir reason contour sched dbdest append-conf
+ runtrans)
(let* ((good-val (lambda (inval)(and inval (string? inval)(not (string-null? inval)))))
(area-dat (val->alist (or (configf:lookup mtconf "areas" area) "")))
(area-path (alist-ref 'path area-dat))
- (area-xlatr (alist-ref 'targtrans area-dat))
- (new-runname (let* ((callname (if (string? runtrans)(string->symbol runtrans) #f))
+ ;; (area-xlatr (alist-ref 'targtrans area-dat))
+ ;; (xlatr-key (if area-xlatr (string->symbol area-xlatr) #f))
+ (new-runname (let* ((callname (if (string? runtrans)(string->symbol runtrans) #f))
(mapper (if callname (hash-table-ref/default *runname-mappers* callname #f) #f)))
;; (print "callname=" callname " runtrans=" runtrans " mapper=" mapper)
(if (and callname
(not (equal? callname "auto"))
(not mapper))
@@ -471,28 +539,11 @@
(print "(mapper " (string-intersperse (list runkey runname area area-path reason contour mode-patt) ", ") ")")
(mapper runkey runname area area-path reason contour mode-patt))
(case callname
((auto) runname)
(else runtrans)))))
- (new-target (if area-xlatr
- (let ((xlatr-key (string->symbol area-xlatr)))
- (if (hash-table-exists? *target-mappers* xlatr-key)
- (begin
- (print "Using target mapper: " area-xlatr)
- (handle-exceptions
- exn
- (begin
- (print "FAILED TO RUN TARGET MAPPER FOR " area ", called " area-xlatr)
- (print " function is: " (hash-table-ref/default *target-mappers* xlatr-key #f ) )
- (print " message: " ((condition-property-accessor 'exn 'message) exn))
- runkey)
- ((hash-table-ref *target-mappers* xlatr-key)
- runkey new-runname area area-path reason contour mode-patt)))
- (begin
- (print "ERROR: Failed to find named target translator " xlatr-key ", using original target.")
- runkey)))
- runkey))
+ (new-target target) ;; I believe we will want target manipulation here .. (map-targets xlatr-key runkey area contour))
(actual-action (if action
(if (equal? action "sync-prepend")
"sync"
action)
"run"))) ;; this has gotten a bit ugly. Need a function to handle actions processing.
@@ -499,11 +550,11 @@
;; some hacks to remove switches not needed in certain cases
(case (string->symbol (or action "run"))
((sync sync-prepend)
(set! new-target #f)
(set! runame #f)))
- (print "area-path: " area-path " area-xlatr: " area-xlatr " orig-target: " runkey " new-target: " new-target)
+ ;; (print "area-path: " area-path " orig-target: " runkey " new-target: " new-target)
(let-values (((uuid pkt)
(command-line->pkt
actual-action
(append
`(("-start-dir" . ,area-path)
@@ -523,15 +574,37 @@
(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))))))
+
+;; look for areas=a1,a2,a3 OR areafn=somefuncname
+;;
+(define (val-alist->areas val-alist)
+ (let ((areas-string (alist-ref 'areas val-alist))
+ (areas-procname (alist-ref 'areafn val-alist)))
+ (if areas-procname ;; areas-procname take precedence
+ areas-procname
+ (string-split (or areas-string "") ","))))
+
+(define (area-allowed? area areas runkey contour)
+ (cond
+ ((not areas) #t) ;; no spec
+ ((string? areas) ;;
+ (let ((check-fn (hash-table-ref/default *area-checkers* areas #f)))
+ (if check-fn
+ (check-fn area runkey contour)
+ #f)))
+ ((list? areas)(member area areas))
+ (else #f))) ;; shouldn't get here
;; (use trace)(trace create-run-pkt)
;; collect all needed data and create run pkts for contours with changed inputs
;;
@@ -564,26 +637,35 @@
(optional (if (> len-key 3)(cadddr keyparts) #f))
;; (val-list (string-split-fields ";\\s*" val #:infix)) ;; (string-split val)) ;; runname-rule params
(val-alist (val->alist val))
(runname (make-runname "" ""))
(runtrans (alist-ref 'runtrans val-alist))
+
+ ;; these may or may not be defined and not all are used in each handler type in the case below
+ (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)) ;; areas can be a single string (a reference to call an areas function), or a list of area names.
+ (dbdest (alist-ref 'dbdest val-alist))
+ (appendconf (alist-ref 'appendconf val-alist))
+ (file-globs (alist-ref 'glob val-alist))
(runstarts (find-pkts pdb '(runstart) `((o . ,contour)
(t . ,runkey))))
(rspkts (get-pkt-alists runstarts))
;; starttimes is for run start times and is used to know when the last run was launched
(starttimes (get-pkt-times rspkts)) ;; sort by age (youngest first) and delete duplicates by target
- (last-run (if (null? starttimes) ;; if '() then it has never been run, else get the max
- 0
- (apply max (map cdr starttimes))))
+ (last-run (if (null? starttimes) ;; if '() then it has never been run, else get the max
+ 0
+ (apply max (map cdr starttimes))))
;; synctimes is for figuring out the last time a sync was done
- (syncstarts (find-pkts pdb '(syncstart) '())) ;; no qualifiers, a sync does all tarets etc.
- (sspkts (get-pkt-alists syncstarts))
- (synctimes (get-pkt-times sspkts))
- (last-sync (if (null? synctimes) ;; if '() then it has never been run, else get the max
- 0
- (apply max (map cdr synctimes))))
+ (syncstarts (find-pkts pdb '(syncstart) '())) ;; no qualifiers, a sync does all tarets etc.
+ (sspkts (get-pkt-alists syncstarts))
+ (synctimes (get-pkt-times sspkts))
+ (last-sync (if (null? synctimes) ;; if '() then it has never been run, else get the max
+ 0
+ (apply max (map cdr synctimes))))
)
(let ((delta (lambda (x)
(round (/ (- (current-seconds) x) 60)))))
(print "runkey: " runkey ", ruletype: " ruletype ", action: " action ", last-run: " last-run " time since; last-run: " (delta last-run) ", last-sync: " (delta last-sync)))
@@ -597,41 +679,53 @@
(case (string->symbol (or ruletype "no-such-rule"))
((no-such-rule) (print "ERROR: no such rule for " sense))
+ ;; Handle crontab like rules
+ ;;
((scheduled)
(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))
+ (let* (
;; (action (alist-ref 'action val-alist))
- (cron-safe-string (string-translate (string-intersperse (string-split (alist-ref 'cron val-alist)) "-") "*" "X"))
+ (cron-safe-string (string-translate (string-intersperse (string-split crontab) "-") "*" "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
(case (string->symbol action)
((sync sync-prepend)
(if (common:extended-cron crontab #f last-sync)
(push-run-spec torun contour runkey
`((message . ,(conc ruletype ":sync-" cron-safe-string))
(action . ,action)
- (dbdest . ,(alist-ref 'dbdest val-alist))
- (append . ,(alist-ref 'appendconf val-alist))))))
+ (dbdest . ,dbdest)
+ (append . ,appendconf)
+ (areas . ,areas)))))
((run)
(if (common:extended-cron crontab #f last-run)
(push-run-spec torun contour runkey
- `((message . ,(conc ruletype ":" cron-safe-string))
- (runname . ,runname)
+ `((message . ,(conc ruletype ":" cron-safe-string))
+ (runname . ,runname)
+ (runtrans . ,runtrans)
+ (action . ,action)
+ (areas . ,areas)
+ (target . ,target)))))
+ ((remove)
+ (push-run-spec torun contour runkey
+ `((message . ,(conc ruletype ":" cron-safe-string))
+ (runname . ,runname)
(runtrans . ,runtrans)
- (action . ,action)
- (target . ,target)))))
+ (action . ,action)
+ (areas . ,areas)
+ (target . ,target))))
(else
(print "ERROR: action \"" action "\" has no scheduled handler")
)))))
+ ;; script based sensors
+ ;;
((script)
;; syntax is a little different here. It is a list of commands to run, "scriptname = extra_parameters;scriptname = ..."
;; where scriptname may be repeated multiple times. The script must return unix-epoch of last change, new-target-name and new-run-name
;; the script is called like this: scriptname contour runkey std-runname action extra_param1 extra_param2 ...
(for-each
@@ -664,19 +758,23 @@
(if need-run
(let* ((key-msg `((message . ,(conc ruletype ":" message))
(runname . ,runname)
(runtrans . ,runtrans)
(action . ,action)
- (target . ,new-target))))
+ (areas . ,areas)
+ (target . ,new-target) ;; overriding with result from runing the script
+ )))
(print "key-msg: " key-msg)
(push-run-spec torun contour
(if optional ;; we need to be able to differentiate same contour, different behavior.
(conc runkey ":" optional) ;; NOTE: NOT COMPLETELY IMPLEMENTED. DO NOT USE
runkey)
key-msg)))))))
val-alist)) ;; iterate over the param split by ;\s*
+ ;; fossil scm based triggers
+ ;;
((fossil)
(for-each
(lambda (fspec)
(print "fspec: " fspec)
(let* ((url (symbol->string (car fspec))) ;; THIS COULD BE TROUBLE. Add option to reading line to return as string.
@@ -688,65 +786,73 @@
(fossil:clone-or-sync url fname fdir) ;; )
(let-values (((datetime node)
(fossil:last-change-node-and-time fdir fname branch)))
(if (null? starttimes)
(push-run-spec torun contour runkey
- `((message . ,(conc "fossil:" branch "-neverrun"))
- (runname . ,(conc runname "-" node))
+ `((message . ,(conc "fossil:" branch "-neverrun"))
+ (runname . ,(conc runname "-" node))
(runtrans . ,runtrans)
- (target . ,runkey)))
+ (areas . ,areas)
+ ;; (target . ,runkey)
+ ))
(if (> datetime last-run) ;; change time is greater than last-run time
(push-run-spec torun contour runkey
- `((message . ,(conc "fossil:" branch "-" node))
- (runname . ,(conc runname "-" node))
+ `((message . ,(conc "fossil:" branch "-" node))
+ (runname . ,(conc runname "-" node))
(runtrans . ,runtrans)
- (target . ,runkey)))))
+ (areas . ,areas)
+ ;; (target . ,runkey)
+ ))))
(print "Got datetime=" datetime " node=" node))))
val-alist))
-
+
+ ;; sensor looking for one or more files newer than reference
+ ;;
((file file-or) ;; one or more files must be newer than the reference
- (let* ((file-globs (alist-ref 'glob val-alist))
- (youngestdat (common:get-youngest (common:bash-glob file-globs)))
+ (let* ((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
- `((message . "file:neverrun")
- (action . ,action)
+ `((message . "file:neverrun")
+ (action . ,action)
(runtrans . ,runtrans)
- (target . ,runkey)
- (runname . ,runname)))
+ ;; (target . ,runkey)
+ (areas . ,areas)
+ (runname . ,runname)))
;; (for-each
;; (lambda (starttime) ;; look at the time the last run was kicked off for this contour
;; (if (> youngestmod (cdr starttime))
;; (begin
;; (print "starttime younger than youngestmod: " starttime " Youngestmod: " youngestmod)
(if (> youngestmod last-run)
(push-run-spec torun contour runkey
- `((message . ,(conc ruletype ":" (cadr youngestdat)))
- (action . ,action)
- (target . ,runkey)
+ `((message . ,(conc ruletype ":" (cadr youngestdat)))
+ (action . ,action)
+ ;; (target . ,runkey)
(runtrans . ,runtrans)
- (runname . ,runname)
+ (areas . ,areas)
+ (runname . ,runname)
))))))
- ;; starttimes))
+ ;; all globbed files must be newer than the reference
+ ;;
((file-and) ;; all files must be newer than the reference
- (let* ((file-globs (alist-ref 'glob val-alist))
- (youngestdat (common:get-youngest file-globs))
+ (let* ((youngestdat (common:get-youngest file-globs))
(youngestmod (car youngestdat))
(success #t)) ;; any cases of not true, set flag to #f for AND
;; (print "youngestmod: " youngestmod " starttimes: " starttimes)
(if (null? starttimes) ;; this target has never been run
(push-run-spec torun contour runkey
- `((message . "file:neverrun")
- (runname . ,runname)
+ `((message . "file:neverrun")
+ (runname . ,runname)
(runtrans . ,runtrans)
- (target . ,runkey)
- (action . ,action)))
+ (areas . ,areas)
+ ;; (target . ,runkey)
+ (action . ,action)))
;; NB// I think this is wrong. It should be looking at last-run only.
- (if (> youngestmod last-run)
+ (if (> youngestmod last-run) ;; WAIT!! Shouldn't file-and be looking at the *oldest* file (thus all are younger than ...)
;; (for-each
;; (lambda (starttime) ;; look at the time the last run was kicked off for this contour
;; (if (< youngestmod (cdr starttime))
;; (set! success #f)))
@@ -753,76 +859,89 @@
;; starttimes))
;; (if success
;; (begin
;; (print "starttime younger than youngestmod: " starttime " Youngestmod: " youngestmod)
(push-run-spec torun contour runkey
- `((message . ,(conc ruletype ":" (cadr youngestdat)))
- (runname . ,runname)
+ `((message . ,(conc ruletype ":" (cadr youngestdat)))
+ (runname . ,runname)
(runtrans . ,runtrans)
- (target . ,runkey)
- (action . ,action)
+ ;; (target . ,runkey)
+ (areas . ,areas)
+ (action . ,action)
))))))
(else (print "ERROR: unrecognised rule \"" ruletype)))))
keydats))) ;; sense rules
(hash-table-keys rgconf))
;; now have to run populated
(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) "") ","))
- (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)))))
+ (let* ((cval (or (configf:lookup mtconf "contours" contour) ""))
+ (cval-alist (val->alist cval)) ;; BEWARE ... NOT the same val-alist as above!
+ (areas (val-alist->areas cval-alist))
+ (selector (alist-ref 'selector cval-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)))))
+ (print "contour: " contour " areas=" areas " cval=" cval)
(for-each
(lambda (runkeydatset)
;; (print "runkeydatset: ")(pp runkeydatset)
(let ((runkey (car runkeydatset))
(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))
- ((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)
- )))
- all-areas))
+ (if (area-allowed? area areas runkey contour) ;; is this area to be handled (from areas=a,b,c OR using areafn=abcfn and *area-checks* ...)
+ (let* ((aval (or (configf:lookup mtconf "areas" area) ""))
+ (aval-alist (val->alist aval))
+ (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))
+ (targets (or (alist-ref 'target runkeydat)
+ (map-targets mtconf aval-alist runkey area contour)))) ;; override with target if forced
+ ;; NEED TO EXPAND RUNKEY => ALL TARGETS MAPPED AND THEN FOREACH ....
+ (for-each
+ (lambda (target)
+ (print "Creating pkt for runkey=" runkey " target=" target " contour=" contour " area=" area " action=" action " tag-expr=" tag-expr " mode-patt=" mode-patt)
+ (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 target 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)
+ ))
+ targets))
+ (print "NOTE: skipping " runkeydat " for area \"" area "\", not in " areas)))
+ all-areas))
runkeydats)))
(let ((res (configf:get-section torun contour))) ;; each contour / target
;; (print "res=" res)
res))))
(hash-table-keys torun)))))))
(define (pkt->cmdline pkta)
- (let ((action (or (lookup-action-by-key (alist-ref 'a pkta)) "noaction")))
+ (let ((action (or (lookup-action-by-key (alist-ref 'A pkta)) "noaction")))
(fold (lambda (a res)
(let* ((key (car a)) ;; get the key name
(val (cdr a))
(par (or (lookup-param-by-key key) ;; need to check also if it is a switch
(lookup-param-by-key key inlst: *switch-keys*))))
;; (print "key: " key " val: " val " par: " par)
(if par
(conc res " " (param-translate par) " " val)
- (if (member key '(a Z U D T)) ;; a is the action
+ (if (alist-ref key *additional-cards*) ;; these cards do not translate to parameters or switches
res
(begin
(print "ERROR: Unknown key in packet \"" key "\" with value \"" val "\"")
res)))))
(conc "megatest " (if (not (member action '("sync")))
@@ -865,11 +984,11 @@
(torun (make-hash-table)) ;; target => ( ... info ... )
(rgentargs (hash-table-keys rgconf))) ;; these are the targets registered for automatically triggering
(for-each
(lambda (pktdat)
(let* ((pkta (alist-ref 'apkt pktdat))
- (action (alist-ref 'a pkta))
+ (action (alist-ref 'A pkta))
(cmdline (pkt->cmdline pkta))
(uuid (alist-ref 'Z pkta))
(logf (conc logdir "/" uuid "-run.log"))
(fullcmd (conc "NBFAKE_LOG=" logf " nbfake " cmdline)))
(print "RUNNING: " fullcmd)
@@ -896,11 +1015,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 +1042,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 +1104,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
-short:file:run runtrans=short; glob=/home/matt/data/megatest/*.scm
+# commented out for debug
+quick:file:run runtrans=auto; glob=/home/matt/data/megatest/*.scm foo.touchme
+# 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
@@ -21,11 +21,10 @@
(declare (uses runconfig))
(declare (uses tests))
(declare (uses server))
(declare (uses mt))
(declare (uses archive))
-(declare (uses keys))
;; (declare (uses filedb))
(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
@@ -96,18 +95,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 +227,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 +339,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 +414,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 +1760,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
Index: tests/fullrun/runconfigs.config
==================================================================
--- tests/fullrun/runconfigs.config
+++ tests/fullrun/runconfigs.config
@@ -1,10 +1,10 @@
[default]
SOMEVAR This should show up in SOMEVAR3
VARNOVAL
VARNOVAL_WITHSPACE
-QUICK %
+QUICKPATT test_mt_vars,test2,priority_9
# target based getting of config file, look at afs.config and nfs.config
[include #{getenv fsname}.config]
[include #{getenv MT_RUN_AREA_HOME}/common_runconfigs.config]