Index: api.scm ================================================================== --- api.scm +++ api.scm @@ -133,11 +133,11 @@ ((delete-test-records) (apply db:delete-test-records dbstruct params)) ((delete-old-deleted-test-records) (apply db:delete-old-deleted-test-records dbstruct params)) ((test-set-status-state) (apply db:test-set-status-state dbstruct params)) ((test-set-top-process-pid) (apply db:test-set-top-process-pid dbstruct params)) ((roll-up-pass-fail-counts) (apply db:roll-up-pass-fail-counts dbstruct params)) - ((update-pass-fail-counts) (apply db:general-call dbstruct 'update-pass-fail-counts params)) + ;; ((update-pass-fail-counts) (apply db:general-call dbstruct 'update-pass-fail-counts params)) ((top-test-set-per-pf-counts) (apply db:top-test-set-per-pf-counts dbstruct params)) ((test-set-archive-block-id) (apply db:test-set-archive-block-id dbstruct params)) ;; RUNS ((register-run) (apply db:register-run dbstruct params)) Index: dashboard-tests.scm ================================================================== --- dashboard-tests.scm +++ dashboard-tests.scm @@ -209,14 +209,10 @@ (store-label "HostName" (iup:label ;; (sdb:qry 'getstr (db:test-get-host testdat) ;; ) #:expand "HORIZONTAL") (lambda (testdat)(db:test-get-host testdat))) - (store-label "Uname" - (iup:label " " #:expand "HORIZONTAL") - (lambda (testdat) ;; (sdb:qry 'getstr - (db:test-get-uname testdat))) ;; ) (store-label "DiskFree" (iup:label (conc (db:test-get-diskfree testdat)) #:expand "HORIZONTAL") (lambda (testdat)(conc (db:test-get-diskfree testdat)))) (store-label "CPULoad" (iup:label (conc (db:test-get-cpuload testdat)) #:expand "HORIZONTAL") @@ -228,11 +224,30 @@ (iup:label (conc (db:test-get-final_logf testdat)) #:expand "HORIZONTAL") (lambda (testdat)(conc (db:test-get-final_logf testdat)))) (store-label "ProcessId" (iup:label (conc (db:test-get-process_id testdat)) #:expand "HORIZONTAL") (lambda (testdat)(conc (db:test-get-process_id testdat)))) + (store-label "Uname" + (iup:label " " #:expand "HORIZONTAL") ;; #:wordwrap "YES") + (lambda (testdat) ;; (sdb:qry 'getstr + (db:test-get-uname testdat))) ;; ) ))))) + +;; if there is a submegatest create a button to launch dashboard in that area +;; +(define (submegatest-panel dbstruct keydat testdat runname testconfig) + (let* ((subarea (configf:lookup testconfig "setup" "submegatest")) + (area-exists (and subarea (file-exists? subarea)))) + (debug:print-info 0 "Megatest subarea=" subarea ", area-exists=" area-exists) + (if subarea + (iup:frame + #:title "Megatest Run Info" ; #:expand "YES" + (iup:button + "Launch Dashboard" + #:action (lambda (obj) + (system (conc "cd " subarea ";env -i PATH=$PATH DISPLAY=$DISPLAY HOME=$HOME USER=$USER dashboard &"))))) + (iup:vbox)))) ;; use a global for setting the buttons colors ;; state status teststeps (define *state-status* (vector #f #f #f)) (define (update-state-status-buttons testdat) @@ -412,10 +427,11 @@ (if (not testdat) (begin (debug:print 2 "ERROR: No test data found for test " test-id ", exiting") (exit 1)) (let* (;; (run-id (if testdat (db:test-get-run_id testdat) #f)) + (test-registry (tests:get-all)) (keydat (if testdat (db:get-key-val-pairs dbstruct run-id) #f)) (rundat (if testdat (db:get-run-info dbstruct run-id) #f)) (runname (if testdat (db:get-value-by-header (db:get-rows rundat) (db:get-header rundat) "runname") #f)) @@ -428,10 +444,11 @@ logfile)) ;; (testdat-path (conc rundir "/testdat.db")) ;; this gets recalculated until found (teststeps (if testdat (tests:get-compressed-steps dbstruct run-id test-id) '())) (testfullname (if testdat (db:test-get-fullname testdat) "Gathering data ...")) (testname (if testdat (db:test-get-testname testdat) "n/a")) + ;; (tests:get-testconfig testdat testname 'return-procs)) (testmeta (if testdat (let ((tm (db:testmeta-get-record dbstruct testname))) (if tm tm (make-db:testmeta))) (make-db:testmeta))) @@ -440,10 +457,26 @@ ;; (conc ":" (car keyval) " " (cadr keyval))) (cadr keyval)) keydat) "/")) (item-path (db:test-get-item-path testdat)) + ;; this next block was added to fix a bug where variables were + ;; needed. Revisit this. + (runconfig (let ((runconfigf (conc *toppath* "/runconfigs.config"))) + (if (file-exists? runconfigf) + (handle-exceptions + exn + #f ;; do nothing, just keep on trucking .... + (setup-env-defaults runconfigf run-id (make-hash-table) keydat environ-patt: keystring)) + (make-hash-table)))) + (testconfig (begin + ;; (runs:set-megatest-env-vars run-id inrunname: runname testname: test-name itempath: item-path) + (runs:set-megatest-env-vars run-id inkeyvals: keydat inrunname: runname intarget: keystring testname: testname itempath: item-path) ;; these may be needed by the launching process + (handle-exceptions + exn + #f + (tests:get-testconfig (db:test-get-testname testdat) test-registry #t)))) (viewlog (lambda (x) (if (file-exists? logfile) ;(system (conc "firefox " logfile "&")) (dashboard-tests:run-html-viewer logfile) (message-window (conc "File " logfile " not found"))))) @@ -570,11 +603,11 @@ " -testpatt " (conc testname "/" (if (equal? item-path "") "%" item-path)) " -v")))) (clean-run-execute (lambda (x) - (let ((cmd (conc "megatest -remove-runs -target " keystring " -runname " runname + (let ((cmd (conc "bmegatest -remove-runs -target " keystring " -runname " runname " -testpatt " (conc testname "/" (if (equal? item-path "") "%" item-path)) ";megatest -target " keystring " -runname " runname " -runtests " (conc testname "/" (if (equal? item-path "") @@ -612,11 +645,13 @@ ;; The run and test info (iup:hbox ; #:expand "YES" (run-info-panel dbstruct keydat testdat runname) (test-info-panel testdat store-label widgets) (test-meta-panel testmeta store-meta)) - (host-info-panel testdat store-label) + (iup:hbox + (host-info-panel testdat store-label) + (submegatest-panel dbstruct keydat testdat runname testconfig)) ;; The controls (iup:frame #:title "Actions" (iup:vbox (iup:hbox (iup:button "View Log" #:action viewlog #:size "80x") Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -1724,45 +1724,45 @@ ;; Use: (db:get-value-by-header (db:get-header runinfo)(db:get-rows runinfo)) ;; to extract info from the structure returned ;; ;; NOTE: THIS IS COMPLETELY UNFINISHED. IT GOES WITH rmt:get-get-paths-matching-keynames ;; -(define (db:get-run-ids-matching dbstruct keynames target res) -;; (define (db:get-runs-by-patt dbstruct keys runnamepatt targpatt offset limit) ;; test-name) - (let* ((tmp (runs:get-std-run-fields keys '("id" "runname" "state" "status" "owner" "event_time"))) - (keystr (car tmp)) - (header (cadr tmp)) - (res '()) - (key-patt "") - (runwildtype (if (substring-index "%" runnamepatt) "like" "glob")) - (qry-str #f) - (keyvals (if targpatt (keys:target->keyval keys targpatt) '()))) - (for-each (lambda (keyval) - (let* ((key (car keyval)) - (patt (cadr keyval)) - (fulkey (conc ":" key)) - (wildtype (if (substring-index "%" patt) "like" "glob"))) - (if patt - (set! key-patt (conc key-patt " AND " key " " wildtype " '" patt "'")) - (begin - (debug:print 0 "ERROR: searching for runs with no pattern set for " fulkey) - (exit 6))))) - keyvals) - (set! qry-str (conc "SELECT " keystr " FROM runs WHERE state != 'deleted' AND runname " runwildtype " ? " key-patt " ORDER BY event_time " - (if limit (conc " LIMIT " limit) "") - (if offset (conc " OFFSET " offset) "") - ";")) - (debug:print-info 4 "runs:get-runs-by-patt qry=" qry-str " " runnamepatt) - (db:with-db dbstruct #f #f ;; reads db, does not write to it. - (lambda (db) - (sqlite3:for-each-row - (lambda (a . r) - (set! res (cons (list->vector (cons a r)) res))) - (db:get-db dbstruct #f) - qry-str - runnamepatt))) - (vector header res))) +;; (define (db:get-run-ids-matching dbstruct keynames target res) +;; ;; (define (db:get-runs-by-patt dbstruct keys runnamepatt targpatt offset limit) ;; test-name) +;; (let* ((tmp (runs:get-std-run-fields keys '("id" "runname" "state" "status" "owner" "event_time"))) +;; (keystr (car tmp)) +;; (header (cadr tmp)) +;; (res '()) +;; (key-patt "") +;; (runwildtype (if (substring-index "%" runnamepatt) "like" "glob")) +;; (qry-str #f) +;; (keyvals (if targpatt (keys:target->keyval keys targpatt) '()))) +;; (for-each (lambda (keyval) +;; (let* ((key (car keyval)) +;; (patt (cadr keyval)) +;; (fulkey (conc ":" key)) +;; (wildtype (if (substring-index "%" patt) "like" "glob"))) +;; (if patt +;; (set! key-patt (conc key-patt " AND " key " " wildtype " '" patt "'")) +;; (begin +;; (debug:print 0 "ERROR: searching for runs with no pattern set for " fulkey) +;; (exit 6))))) +;; keyvals) +;; (set! qry-str (conc "SELECT " keystr " FROM runs WHERE state != 'deleted' AND runname " runwildtype " ? " key-patt " ORDER BY event_time " +;; (if limit (conc " LIMIT " limit) "") +;; (if offset (conc " OFFSET " offset) "") +;; ";")) +;; (debug:print-info 4 "runs:get-runs-by-patt qry=" qry-str " " runnamepatt) +;; (db:with-db dbstruct #f #f ;; reads db, does not write to it. +;; (lambda (db) +;; (sqlite3:for-each-row +;; (lambda (a . r) +;; (set! res (cons (list->vector (cons a r)) res))) +;; (db:get-db dbstruct #f) +;; qry-str +;; runnamepatt))) +;; (vector header res))) ;; Get all targets from the db ;; (define (db:get-targets dbstruct) (let* ((res '()) @@ -2370,11 +2370,12 @@ (sqlite3:first-result db (conc "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND testname in ('" (string-intersperse testnames "','") "') AND NOT (uname = 'n/a' AND item_path='');")) ;; should this include the (uname = 'n/a' ...) ??? - ))))))) + )) + 0))))) ;; DEBUG FIXME - need to merge this v.155 query correctly ;; AND testname in (SELECT testname FROM test_meta WHERE jobgroup=?) ;; AND NOT (uname = 'n/a' AND item_path = '');" ;; done with run when: @@ -2662,10 +2663,12 @@ ;; Now rollup the counts to the central megatest.db (db:general-call dbdat 'pass-fail-counts (list pass-count fail-count test-id)) ;; if the test is not FAIL then set status based on the fail and pass counts. (db:general-call dbdat 'test_data-pf-rollup (list test-id test-id test-id test-id)))) +;; NOT USED!? +;; (define (db:csv->test-data dbstruct run-id test-id csvdata) (debug:print 4 "test-id " test-id ", csvdata: " csvdata) (let* ((dbdat (db:get-db dbstruct run-id)) (db (db:dbdat-get-db dbdat)) (csvlist (csv->list (make-csv-reader @@ -2693,11 +2696,11 @@ ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment " type: " type) (if (and (or (not expected)(equal? expected "")) (or (not tol) (equal? expected "")) (or (not units) (equal? expected ""))) - (let-values (((new-expected new-tol new-units)(tdb:get-prev-tol-for-test tdb test-id category variable))) + (let-values (((new-expected new-tol new-units)(tdb:get-prev-tol-for-test #f test-id category variable))) (set! expected new-expected) (set! tol new-tol) (set! units new-units))) (debug:print 4 "AFTER: category: " category " variable: " variable " value: " value @@ -2942,21 +2945,21 @@ '(top-test-set-per-pf-counts "UPDATE tests SET state=CASE WHEN (SELECT count(id) FROM tests WHERE testname=? AND item_path != '' - AND status IN ('INCOMPLETE') - AND state in ('RUNNING','NOT_STARTED','LAUNCHED','REMOTEHOSTSTART')) > 0 THEN 'RUNNING' + AND status NOT IN ('n/a') + AND state in ('NOT_STARTED')) > 0 THEN 'UNKNOWN' WHEN (SELECT count(id) FROM tests WHERE testname=? AND item_path != '' - AND status NOT IN ('TEN_STRIKES','BLOCKED') + AND (status NOT IN ('TEN_STRIKES','BLOCKED') OR status IN ('INCOMPLETE')) AND state in ('RUNNING','NOT_STARTED','LAUNCHED','REMOTEHOSTSTART')) > 0 THEN 'RUNNING' WHEN (SELECT count(id) FROM tests WHERE testname=? AND item_path != '' - AND state != 'COMPLETED') = 0 THEN 'COMPLETED' + AND state NOT IN ('COMPLETED','DELETED')) = 0 THEN 'COMPLETED' WHEN (SELECT count(id) FROM tests WHERE testname=? AND item_path != '' AND state = 'NOT_STARTED') > 0 THEN 'NOT_STARTED' ELSE 'UNKNOWN' END, @@ -3113,12 +3116,12 @@ ;; (define (db:get-matching-previous-test-run-records dbstruct run-id test-name item-path) (let* ((dbdat (db:get-db dbstruct #f)) (db (db:dbdat-get-db dbdat)) (keys (db:get-keys db)) - (selstr (string-intersperse (map (lambda (x)(vector-ref x 0)) keys) ",")) - (qrystr (string-intersperse (map (lambda (x)(conc (vector-ref x 0) "=?")) keys) " AND ")) + (selstr (string-intersperse keys ",")) + (qrystr (string-intersperse (map (lambda (x)(conc x "=?")) keys) " AND ")) (keyvals #f) (tests-hash (make-hash-table))) ;; first look up the key values from the run selected by run-id (db:delay-if-busy dbdat) (sqlite3:for-each-row @@ -3139,11 +3142,11 @@ (debug:print 4 "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals ", previous run ids found: " prev-run-ids) (if (null? prev-run-ids) '() ;; no previous runs? return null (let loop ((hed (car prev-run-ids)) (tal (cdr prev-run-ids))) - (let ((results (db:get-tests-for-run dbstruct run-id hed (conc test-name "/" item-path) '() '() #f #f #f #f #f #f))) + (let ((results (db:get-tests-for-run dbstruct hed (conc test-name "/" item-path) '() '() #f #f #f #f #f #f))) (debug:print 4 "Got tests for run-id " run-id ", test-name " test-name ", item-path " item-path " results: " (intersperse results "\n")) ;; Keep only the youngest of any test/item combination (for-each (lambda (testdat) @@ -3266,13 +3269,13 @@ ;; A routine to map itempaths using a itemmap (define (db:compare-itempaths patha pathb itemmap) (debug:print-info 6 "ITEMMAP is " itemmap) (if itemmap - (let ((path-b-mapped (db:convert-test-itempath pathb itemmap))) - (debug:print-info 6 "ITEMMAP is " itemmap ", path: " pathb ", mapped path: " path-b-mapped) - (equal? patha pathb)) + (let ((pathb-mapped (db:multi-pattern-apply pathb itemmap))) + (debug:print-info 6 "ITEMMAP is " itemmap ", path: " pathb ", mapped path: " pathb-mapped) + (equal? patha pathb-mapped)) (equal? patha pathb))) ;; (let* ((mapparts (string-split itemmap)) ;; (pattern (car mapparts)) ;; (replacement (if (> (length mapparts) 1) (cadr mapparts) ""))) @@ -3281,10 +3284,13 @@ ;; (string-substitute pattern replacement pathb)) ;; (equal? (string-substitute pattern "" patha) ;; (string-substitute pattern "" pathb)))) ;; A routine to convert test/itempath using a itemmap +;; NOTE: to process only an itempath (i.e. no prepended testname) +;; just call db:multi-pattern-apply +;; (define (db:convert-test-itempath path-in itemmap) (debug:print-info 6 "ITEMMAP is " itemmap) (let* ((path-parts (string-split path-in "/")) (test-name (if (null? path-parts) "" (car path-parts))) (item-path (string-intersperse (if (null? path-parts) '() (cdr path-parts)) "/"))) @@ -3348,11 +3354,11 @@ (item-path (db:test-get-item-path test)) (is-completed (equal? state "COMPLETED")) (is-running (equal? state "RUNNING")) (is-killed (equal? state "KILLED")) (is-ok (member status '("PASS" "WARN" "CHECK" "WAIVED" "SKIP"))) - (same-itempath (db:compare-itempaths ref-item-path item-path itemmap))) ;; (equal? ref-item-path item-path))) + (same-itempath (db:compare-itempaths item-path ref-item-path itemmap))) ;; (equal? ref-item-path item-path))) (set! ever-seen #t) (cond ;; case 1, non-item (parent test) is ((and (equal? item-path "") ;; this is the parent test of the waiton being examined is-completed Index: docs/manual/Makefile ================================================================== --- docs/manual/Makefile +++ docs/manual/Makefile @@ -13,11 +13,11 @@ # asciidoc -b html5 -a icons -a iconsdir=$(DISPATH)/images/icons -a toc2 design_spec.txt # all : server.ps megatest_manual.html client.ps -megatest_manual.html : megatest_manual.txt getting_started.txt writing_tests.txt reference.txt ../plan.txt howto.txt +megatest_manual.html : megatest_manual.txt getting_started.txt writing_tests.txt reference.txt ../plan.txt howto.txt *png asciidoc -b html5 -a icons -a iconsdir=$(DISPATH)/images/icons -a toc2 megatest_manual.txt # dos2unix megatest_manual.html server.ps : server.dot dot -Tps server.dot > server.ps ADDED docs/manual/complex-itemmap.dot Index: docs/manual/complex-itemmap.dot ================================================================== --- /dev/null +++ docs/manual/complex-itemmap.dot @@ -0,0 +1,35 @@ +digraph G { + + // put client after server so server_start node is visible + // + subgraph cluster_2 { + node [style=filled,shape=box]; + + "test1" -> test2; + runremote_lookup_server -> login_attempt [label="have server"]; + runremote_lookup_server -> monitordb_lookup_server [label="no server"]; + + monitordb_lookup_server -> login_attempt [label="have server"]; + monitordb_lookup_server -> server_start_remote [label="no server"]; + + server_start_remote -> delay_2_sec; + delay_2_sec -> runremote_lookup_server; + + login_attempt -> "rmt:send-receive_start" [label="login sucessful"]; + "rmt:send-receive_start" -> "rmt:send-receive_start"; + + "rmt:send-receive_start" -> runremote_lookup_server [label=exception]; + login_attempt -> clear_runremote [label="login failed"]; + + "remove_running > 5s" -> runremote_lookup_server; + + subgraph cluster_3 { + node [style=filled]; + clear_runremote -> "remove_running > 5s"; + } + + label = "client:setup"; + color=green; + } + +} ADDED docs/manual/itemmap.fig Index: docs/manual/itemmap.fig ================================================================== --- /dev/null +++ docs/manual/itemmap.fig @@ -0,0 +1,129 @@ +#FIG 3.2 Produced by xfig version 3.2.5c +Landscape +Center +Metric +A4 +100.00 +Single +-2 +1200 2 +0 32 #c6b797 +0 33 #eff8ff +0 34 #dccba6 +0 35 #404040 +0 36 #808080 +0 37 #c0c0c0 +0 38 #e0e0e0 +0 39 #8e8f8e +0 40 #aaaaaa +0 41 #555555 +0 42 #c7c3c7 +0 43 #565151 +0 44 #8e8e8e +0 45 #d7d7d7 +0 46 #85807d +0 47 #d2d2d2 +0 48 #3a3a3a +0 49 #4573aa +0 50 #aeaeae +0 51 #7b79a5 +0 52 #444444 +0 53 #73758c +0 54 #f7f7f7 +0 55 #414541 +0 56 #635dce +0 57 #bebebe +0 58 #515151 +0 59 #e7e3e7 +0 60 #000049 +0 61 #797979 +0 62 #303430 +0 63 #414141 +0 64 #c7b696 +6 3600 2700 4455 3555 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 3600 2700 4050 2700 4050 3150 3600 3150 3600 2700 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 3690 3150 3690 3285 4185 3285 4185 2790 4050 2790 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 3825 3285 3825 3420 4320 3420 4320 2925 4185 2925 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 3960 3420 3960 3555 4455 3555 4455 3060 4320 3060 +-6 +6 1845 4500 2700 5355 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 1845 4500 2295 4500 2295 4950 1845 4950 1845 4500 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 1935 4950 1935 5085 2430 5085 2430 4590 2295 4590 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 2070 5085 2070 5220 2565 5220 2565 4725 2430 4725 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 2205 5220 2205 5355 2700 5355 2700 4860 2565 4860 +-6 +6 1800 900 2655 1755 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 1800 900 2250 900 2250 1350 1800 1350 1800 900 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 1890 1350 1890 1485 2385 1485 2385 990 2250 990 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 2025 1485 2025 1620 2520 1620 2520 1125 2385 1125 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 2160 1620 2160 1755 2655 1755 2655 1260 2520 1260 +-6 +6 5400 900 6255 1755 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 5400 900 5850 900 5850 1350 5400 1350 5400 900 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 5490 1350 5490 1485 5985 1485 5985 990 5850 990 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 5625 1485 5625 1620 6120 1620 6120 1125 5985 1125 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 5760 1620 5760 1755 6255 1755 6255 1260 6120 1260 +-6 +6 5400 4500 6255 5355 +2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 5400 4500 5850 4500 5850 4950 5400 4950 5400 4500 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 5490 4950 5490 5085 5985 5085 5985 4590 5850 4590 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 5625 5085 5625 5220 6120 5220 6120 4725 5985 4725 +2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 5760 5220 5760 5355 6255 5355 6255 4860 6120 4860 +-6 +2 1 0 2 0 7 50 -1 -1 0.000 0 0 -1 1 0 2 + 0 0 1.00 60.00 120.00 + 5355 4455 4500 3600 +2 1 0 2 0 7 50 -1 -1 0.000 0 0 -1 1 0 2 + 0 0 1.00 60.00 120.00 + 5400 1800 4500 2700 +2 1 0 2 0 7 50 -1 -1 0.000 0 0 -1 1 0 2 + 0 0 1.00 60.00 120.00 + 3600 3600 2700 4500 +2 1 0 2 0 7 50 -1 -1 0.000 0 0 -1 1 0 2 + 0 0 1.00 60.00 120.00 + 3510 2610 2790 1890 +2 2 0 2 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 1530 675 3060 675 3060 5580 1530 5580 1530 675 +2 2 0 2 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 3195 675 4815 675 4815 5580 3195 5580 3195 675 +2 2 0 2 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 4950 675 6660 675 6660 5580 4950 5580 4950 675 +2 2 0 2 7 7 50 -1 -1 0.000 0 0 -1 0 0 5 + 0 45 8550 45 8550 7245 0 7245 0 45 +2 1 0 2 23 7 50 -1 -1 0.000 0 0 -1 1 0 3 + 0 0 1.00 60.00 120.00 + 5040 6300 4050 5175 4050 3690 +2 1 0 2 23 7 50 -1 -1 0.000 0 0 -1 1 0 3 + 0 0 1.00 60.00 120.00 + 1080 5850 1080 2115 1755 1530 +4 0 0 50 -1 0 16 0.0000 4 135 360 1935 4725 TstB\001 +4 0 0 50 -1 0 16 0.0000 4 135 360 5445 1170 TstC\001 +4 0 0 50 -1 0 16 0.0000 4 135 360 5445 4770 TstD\001 +4 0 0 50 -1 0 16 0.0000 4 135 360 3600 2970 TstE\001 +4 0 0 50 -1 0 16 0.0000 4 135 360 1845 1170 TstA\001 +4 0 0 50 -1 0 16 0.0000 4 180 1260 900 6210 [requirements]\001 +4 0 0 50 -1 0 16 0.0000 4 135 990 900 6405 waiton TstE\001 +4 0 0 50 -1 0 16 0.0000 4 180 2070 900 6600 itemap foo/(\\d+) \\1/bar\001 +4 0 0 50 -1 0 16 0.0000 4 180 810 5220 6165 [itemmap]\001 +4 0 0 50 -1 0 16 0.0000 4 150 1260 5220 6360 TstC .*/ foo/\001 +4 0 0 50 -1 0 16 0.0000 4 165 1080 5220 6555 TstD ab/ xy/\001 ADDED docs/manual/itemmap.png Index: docs/manual/itemmap.png ================================================================== --- /dev/null +++ docs/manual/itemmap.png cannot compute difference between binary files Index: docs/manual/megatest_manual.html ================================================================== --- docs/manual/megatest_manual.html +++ docs/manual/megatest_manual.html @@ -1145,10 +1145,18 @@ 
[setup]
 reruns 5
+
+

Run time limit

+
+
+
[setup]
+runtimelim 1h 2m 3s  # this will automatically kill the test if it runs for more than 1h 2m and 3s
+
+

The testconfig File

@@ -1229,12 +1237,28 @@ # ## Remove everything up to the last / itemmap .*/ # # ## Example # ## Replace foo/ with bar/ -itemmap foo/ bar/ +itemmap foo/ bar/ + +# multi-line; matches are applied in the listed order +# The following would map: +# a123b321 to b321fooa123 then to 321fooa123p +# +itemmap (a\d+)(b\d+) \2foo\1 + b(.*) \1p
+ +
+

Complex mappings

+

Complex mappings can be handled with the [itemmap] section

+
+
+itemmap.png +
+
Autogeneration waiton list for dynamic flow dependency trees
[requirements]
 # With a toplevel test you may wish to generate your list
@@ -1242,11 +1266,11 @@
 #
 # waiton #{shell get-valid-tests-to-run.sh}
-

Run time limit

+

Run time limit

runtimelim 1h 2m 3s  # this will automatically kill the test if it runs for more than 1h 2m and 3s
@@ -1578,10 +1602,10 @@
Index: docs/manual/reference.txt ================================================================== --- docs/manual/reference.txt +++ docs/manual/reference.txt @@ -58,10 +58,18 @@ ------------------ [setup] reruns 5 ------------------ +Run time limit +^^^^^^^^^^^^^^ + +----------------- +[setup] +runtimelim 1h 2m 3s # this will automatically kill the test if it runs for more than 1h 2m and 3s +----------------- + The testconfig File ------------------- Setup section ~~~~~~~~~~~~~ @@ -146,12 +154,27 @@ itemmap .*/ # # ## Example # ## Replace foo/ with bar/ itemmap foo/ bar/ + +# multi-line; matches are applied in the listed order +# The following would map: +# a123b321 to b321fooa123 then to 321fooa123p +# +itemmap (a\d+)(b\d+) \2foo\1 + b(.*) \1p ------------------- +Complex mappings +^^^^^^^^^^^^^^^^ + +Complex mappings can be handled with the [itemmap] section + +image::itemmap.png[] + +.Complex mapping from .Autogeneration waiton list for dynamic flow dependency trees ------------------- [requirements] # With a toplevel test you may wish to generate your list # of tests to run dynamically Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -487,13 +487,12 @@ (args:get-arg "-m") #f) ;; need to update the top test record if PASS or FAIL and this is a subtest ;; NO NEED TO CALL roll-up-pass-fail-counts HERE, THIS IS DONE IN roll-up-pass-fail-counts called by tests:test-set-status! )) ;; for automated creation of the rollup html file this is a good place... - ;; (if (and (not (equal? item-path "")) - ;; (< (random (rmt:get-count-tests-running-for-testname run-id test-name)) 5)) - (tests:summarize-items run-id test-id test-name #f) + (if (not (equal? item-path "")) + (tests:summarize-items run-id test-id test-name #f)) (tests:summarize-test run-id test-id) ;; don't force - just update if no ) (mutex-unlock! m) (debug:print 2 "Output from running " fullrunscript ", pid " (vector-ref exit-info 0) " in work area " work-area ":\n====\n exit code " (vector-ref exit-info 2) "\n" "====\n") @@ -900,10 +899,13 @@ (list 'runname runname) (list 'mt-bindir-path mt-bindir-path)))))))) ;; clean out step records from previous run if they exist ;; (rmt:delete-test-step-records run-id test-id) + ;; if the dir does not exist we may have a itempath where individual variables are a path, launch anyway + (if (file-exists? work-area) + (change-directory work-area)) ;; so that log files from the launch process don't clutter the test dir ;; Moving launch logs to MT_RUN_AREA_HOME/logs ;; (let ((launchdir (configf:lookup *configdat* "setup" "launchdir"))) ;; (change-directory work-area) ;; so that log files from the launch process don't clutter the test dir (if (not launchdir) ;; default Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -77,10 +77,12 @@ -runall : run all tests or as specified by -testpatt -remove-runs : remove the data for a run, requires -runname and -testpatt Optionally use :state and :status -set-state-status X,Y : set state to X and status to Y, requires controls per -remove-runs -rerun FAIL,WARN... : force re-run for tests with specificed status(s) + -rerun-clean : set all tests not COMPLETED+PASS,WARN,WAIVED to NOT_STARTED,n/a + and then run the specified testpatt with -preclean -lock : lock run specified by target and runname -unlock : unlock run specified by target and runname -set-run-status status : sets status for run to status, requires -target and -runname -get-run-status : gets status for run specified by target and runname -run-wait : wait on run specified by target and runname @@ -263,10 +265,12 @@ "-load-test-data" "-summarize-items" "-gui" "-daemonize" "-preclean" + "-rerun-clean" + ;; misc "-repl" "-lock" "-unlock" "-list-servers" @@ -1144,15 +1148,36 @@ ;; process deferred tasks per above steps ;; run all tests are are Not COMPLETED and PASS or CHECK (if (or (args:get-arg "-runall") (args:get-arg "-run") + (args:get-arg "-rerun-clean") (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"))) + (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: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:run-tests target runname #f ;; (common:args-get-testpatt #f) ;; (or (args:get-arg "-testpatt") ;; "%") Index: mt.scm ================================================================== --- mt.scm +++ mt.scm @@ -130,43 +130,44 @@ ;;====================================================================== ;; T R I G G E R S ;;====================================================================== (define (mt:process-triggers run-id test-id newstate newstatus) - (let* ((test-dat (rmt:get-test-info-by-id run-id test-id)) - (test-rundir ;; (rmt:sdb-qry 'getstr ;; (filedb:get-path *fdb* - (db:test-get-rundir test-dat)) ;; ) ;; ) - (test-name (db:test-get-testname test-dat)) - (tconfig #f) - (state (if newstate newstate (db:test-get-state test-dat))) - (status (if newstatus newstatus (db:test-get-status test-dat)))) - (if (and test-rundir ;; #f means no dir set yet - (file-exists? test-rundir) - (directory? test-rundir)) - (call-with-environment-variables - (list (cons "MT_TEST_NAME" test-name) - (cons "MT_TEST_RUN_DIR" test-rundir) - (cons "MT_ITEMPATH" (db:test-get-item-path test-dat))) - (lambda () - (push-directory test-rundir) - (set! tconfig (mt:lazy-read-test-config test-name)) - (for-each (lambda (trigger) - (let ((cmd (configf:lookup tconfig "triggers" trigger)) - (logf (conc test-rundir "/last-trigger.log"))) - (if cmd - ;; Putting the commandline into ( )'s means no control over the shell. - ;; stdout and stderr will be caught in the NBFAKE or mt_launch.log files - ;; or equivalent. No need to do this. Just run it? - (let ((fullcmd (conc cmd " " test-id " " test-rundir " " trigger "&"))) - (debug:print-info 0 "TRIGGERED on " trigger ", running command " fullcmd) - (process-run fullcmd))))) - (list - (conc state "/" status) - (conc state "/") - (conc "/" status))) - (pop-directory)) - )))) + (let* ((test-dat (rmt:get-test-info-by-id run-id test-id))) + (if test-dat + (let* ((test-rundir ;; (rmt:sdb-qry 'getstr ;; (filedb:get-path *fdb* + (db:test-get-rundir test-dat)) ;; ) ;; ) + (test-name (db:test-get-testname test-dat)) + (tconfig #f) + (state (if newstate newstate (db:test-get-state test-dat))) + (status (if newstatus newstatus (db:test-get-status test-dat)))) + (if (and test-rundir ;; #f means no dir set yet + (file-exists? test-rundir) + (directory? test-rundir)) + (call-with-environment-variables + (list (cons "MT_TEST_NAME" test-name) + (cons "MT_TEST_RUN_DIR" test-rundir) + (cons "MT_ITEMPATH" (db:test-get-item-path test-dat))) + (lambda () + (push-directory test-rundir) + (set! tconfig (mt:lazy-read-test-config test-name)) + (for-each (lambda (trigger) + (let ((cmd (configf:lookup tconfig "triggers" trigger)) + (logf (conc test-rundir "/last-trigger.log"))) + (if cmd + ;; Putting the commandline into ( )'s means no control over the shell. + ;; stdout and stderr will be caught in the NBFAKE or mt_launch.log files + ;; or equivalent. No need to do this. Just run it? + (let ((fullcmd (conc cmd " " test-id " " test-rundir " " trigger "&"))) + (debug:print-info 0 "TRIGGERED on " trigger ", running command " fullcmd) + (process-run fullcmd))))) + (list + (conc state "/" status) + (conc state "/") + (conc "/" status))) + (pop-directory)) + )))))) ;;====================================================================== ;; S T A T E A N D S T A T U S F O R T E S T S ;;====================================================================== Index: rmt.scm ================================================================== --- rmt.scm +++ rmt.scm @@ -331,12 +331,12 @@ ;; added run-id to make looking up the correct db possible ;; (define (rmt:general-call stmtname run-id . params) (rmt:send-receive 'general-call run-id (append (list stmtname run-id) params))) -(define (rmt:sync-inmem->db run-id) - (rmt:send-receive 'sync-inmem->db run-id '())) +;; (define (rmt:sync-inmem->db run-id) +;; (rmt:send-receive 'sync-inmem->db run-id '())) (define (rmt:sdb-qry qry val run-id) ;; add caching if qry is 'getid or 'getstr (rmt:send-receive 'sdb-qry run-id (list qry val))) @@ -501,12 +501,12 @@ (apply append (map (lambda (run-id) (rmt:send-receive 'test-get-paths-matching-keynames-target-new run-id (list run-id keynames target res testpatt statepatt statuspatt runname))) run-ids)))) -(define (rmt:get-run-ids-matching keynames target res) - (rmt:send-receive #f 'get-run-ids-matching (list keynames target res))) +;; (define (rmt:get-run-ids-matching keynames target res) +;; (rmt:send-receive #f 'get-run-ids-matching (list keynames target res))) (define (rmt:get-prereqs-not-met run-id waitons ref-item-path #!key (mode '(normal))(itemmap #f)) (rmt:send-receive 'get-prereqs-not-met run-id (list run-id waitons ref-item-path mode itemmap))) (define (rmt:get-count-tests-running-for-run-id run-id) @@ -527,14 +527,14 @@ ;; (define (rmt:roll-up-pass-fail-counts run-id test-name item-path state status) (rmt:send-receive 'roll-up-pass-fail-counts run-id (list run-id test-name item-path state status))) (define (rmt:update-pass-fail-counts run-id test-name) - (rmt:general-call 'update-pass-fail-counts run-id (list run-id test-name run-id test-name run-id test-name))) + (rmt:general-call 'update-pass-fail-counts run-id test-name test-name test-name)) (define (rmt:top-test-set-per-pf-counts run-id test-name) - (rmt:general-call 'top-test-set-per-pf-counts run-id (list run-id test-name))) + (rmt:send-receive 'top-test-set-per-pf-counts run-id (list run-id test-name))) ;;====================================================================== ;; R U N S ;;====================================================================== @@ -555,13 +555,10 @@ (rmt:send-receive 'delete-run run-id (list run-id))) (define (rmt:delete-old-deleted-test-records) (rmt:send-receive 'delete-old-deleted-test-records #f '())) -(define (rmt:get-runs runpatt count offset keypatts) - (rmt:send-receive 'get-runs #f (list runpatt count offset keypatts))) - (define (rmt:get-runs runpatt count offset keypatts) (rmt:send-receive 'get-runs #f (list runpatt count offset keypatts))) (define (rmt:get-all-run-ids) (rmt:send-receive 'get-all-run-ids #f '())) Index: runconfig.scm ================================================================== --- runconfig.scm +++ runconfig.scm @@ -8,13 +8,16 @@ (declare (unit runconfig)) (declare (uses common)) (include "common_records.scm") +;; NB// to process a runconfig ensure to use environ-patt with target! +;; (define (setup-env-defaults fname run-id already-seen keyvals #!key (environ-patt #f)(change-env #t)) (let* ((keys (map car keyvals)) - (thekey (if keyvals (string-intersperse (map (lambda (x)(if x x "-na-")) (map cadr keyvals)) "/") + (thekey (if keyvals + (string-intersperse (map (lambda (x)(if x x "-na-")) (map cadr keyvals)) "/") (or (common:args-get-target) (get-environment-variable "MT_TARGET") (begin (debug:print 0 "ERROR: setup-env-defaults called with no run-id or -target or -reqtarg") "nothing matches this I hope")))) Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -94,17 +94,21 @@ (safe-setenv (car varval)(cadr varval))) (configf:get-section runconfig section))) (list "default" target)) (vector target runname testpatt keys keyvals envdat mconfig runconfig serverdat transport db toppath run-id))) -(define (runs:set-megatest-env-vars run-id #!key (inkeys #f)(inrunname #f)(inkeyvals #f)) - (let* ((target (or (common:args-get-target) +(define (runs:set-megatest-env-vars run-id #!key (inkeys #f)(inrunname #f)(inkeyvals #f)(intarget #f)(testname #f)(itempath #f)) + (let* ((target (or intarget + (common:args-get-target) (get-environment-variable "MT_TARGET"))) - (keys (if inkeys inkeys (rmt:get-keys))) + (keys (if inkeys inkeys (rmt:get-keys))) (keyvals (if inkeyvals inkeyvals (keys:target->keyval keys target))) (vals (hash-table-ref/default *env-vars-by-run-id* run-id #f)) (link-tree (configf:lookup *configdat* "setup" "linktree"))) + (if testname (setenv "MT_TEST_NAME" testname)) + (if itempath (setenv "MT_ITEMPATH" itempath)) + ;; get the info from the db and put it in the cache (if link-tree (setenv "MT_LINKTREE" link-tree) (debug:print 0 "ERROR: linktree not set, should be set in megatest.config in [setup] section.")) (if (not vals) @@ -126,11 +130,24 @@ ;; Lets use this as an opportunity to put MT_RUNNAME in the environment (let ((runname (if inrunname inrunname (rmt:get-run-name-from-id run-id)))) (if runname (setenv "MT_RUNNAME" runname) (debug:print 0 "ERROR: no value for runname for id " run-id))) - (setenv "MT_RUN_AREA_HOME" *toppath*))) + (setenv "MT_RUN_AREA_HOME" *toppath*) + ;; if a testname and itempath are available set the remaining appropriate variables + (if testname (setenv "MT_TEST_NAME" testname)) + (if itempath (setenv "MT_ITEMPATH" itempath)) + (if (and testname link-tree) + (setenv "MT_TEST_RUN_DIR" (conc (getenv "MT_LINKTREE") "/" + (getenv "MT_TARGET") "/" + (getenv "MT_RUNNAME") "/" + (getenv "MT_TEST_NAME") + (if (and itempath + (not (equal? itempath ""))) + (conc "/" itempath) + "")))) + )) (define (set-item-env-vars itemdat) (for-each (lambda (item) (debug:print 2 "setenv " (car item) " " (cadr item)) (setenv (car item) (cadr item))) @@ -1219,10 +1236,11 @@ (else (debug:print-info 4 "Exiting loop with...\n hed=" hed "\n tal=" tal "\n reruns=" reruns)) ))) ;; now *if* -run-wait we wait for all tests to be done ;; Now wait for any RUNNING tests to complete (if in run-wait mode) + (thread-sleep! 5) ;; I think there is a race condition here. Let states/statuses settle (let wait-loop ((num-running (rmt:get-count-tests-running-for-run-id run-id)) (prev-num-running 0)) ;; (debug:print 0 "num-running=" num-running ", prev-num-running=" prev-num-running) (if (and (or (args:get-arg "-run-wait") (equal? (configf:lookup *configdat* "setup" "run-wait") "yes")) @@ -1314,14 +1332,14 @@ "\nTESTNAME: " full-test-name "\n test-config: " (hash-table->alist test-conf) "\n itemdat: " itemdat ) (debug:print 2 "Attempting to launch test " full-test-name) - (setenv "MT_TEST_NAME" test-name) ;; - (setenv "MT_ITEMPATH" item-path) - (setenv "MT_RUNNAME" runname) - (runs:set-megatest-env-vars run-id inrunname: runname) ;; these may be needed by the launching process + ;; (setenv "MT_TEST_NAME" test-name) ;; + ;; (setenv "MT_ITEMPATH" item-path) + ;; (setenv "MT_RUNNAME" runname) + (runs:set-megatest-env-vars run-id inrunname: runname testname: test-name itempath: item-path) ;; these may be needed by the launching process (change-directory *toppath*) ;; Here is where the test_meta table is best updated ;; Yes, another use of a global for caching. Need a better way? ;; Index: tests.scm ================================================================== --- tests.scm +++ tests.scm @@ -88,11 +88,12 @@ (define (tests:extend-test-patts test-patt test-b test-a itemmap) (let* ((patts (string-split test-patt ",")) (test-b-len (+ (string-length test-b) 1)) (patts-b (map (lambda (x) (let* ((modpatt (if itemmap (db:convert-test-itempath x itemmap) x)) - (newpatt (conc test-a "/," test-a "/" (substring modpatt test-b-len (string-length modpatt))))) + (newpatt (conc test-a "/" (substring modpatt test-b-len (string-length modpatt))))) + ;; (conc test-a "/," test-a "/" (substring modpatt test-b-len (string-length modpatt))))) ;; (print "in map, x=" x ", newpatt=" newpatt) newpatt)) (filter (lambda (x) (eq? (substring-index (conc test-b "/") x) 0)) patts)))) @@ -627,11 +628,13 @@ ;; (last (string-split testp "/"))) ;; tests))))) (define (tests:get-testconfig test-name test-registry system-allowed) - (let* ((test-path (hash-table-ref/default test-registry test-name (conc *toppath* "/tests/" test-name))) + (let* ((test-path (hash-table-ref/default + test-registry test-name + (conc *toppath* "/tests/" test-name))) (test-configf (conc test-path "/testconfig")) (testexists (and (file-exists? test-configf)(file-read-access? test-configf))) (tcfg (if testexists (read-config test-configf #f system-allowed environ-patt: (if system-allowed "pre-launch-env-vars" Index: tests/unit.logpro ================================================================== --- tests/unit.logpro +++ tests/unit.logpro @@ -1,5 +1,14 @@ +;; Ignore initial errors +(trigger "ScriptStart" #/^Script started/) +(trigger "TestStart" #/^megatest> \(/) +(section "startup" "ScriptStart" "TestStart") + +(expect:ignore in "startup" >= 0 "Ignore startup errors" #/error/i) + +(expect:ignore in "LogFileBody" >= 0 "Ignore .so files with error in name" #/loading.*error.*\.so/) +; loading /usr/local/lib/chicken/7/type-errors.import.so .. ;; You should have at least one expect:required. This ensures that your process ran (expect:required in "LogFileBody" > 0 "At least one PASS" #/\[.{0,4}PASS.{0,4}\]/) ;; You may need ignores to suppress false error or warning hits from the later expects ;; NOTE: Order is important here! Index: tests/unittests/misc.scm ================================================================== --- tests/unittests/misc.scm +++ tests/unittests/misc.scm @@ -1,5 +1,7 @@ +(use sqlite3) + ;;====================================================================== ;; P R O C E S S E S ;;====================================================================== (test "cmd-run-with-stderr->list" '("No such file or directory") @@ -41,8 +43,187 @@ (test #f "(testname GLOB 'a' AND item_path GLOB 'b') OR (testname LIKE 'a%' AND item_path LIKE '%') OR (testname GLOB '' AND item_path LIKE 'b%')" (tests:match->sqlqry "a/b,a%,/b%")) (test #f "(testname GLOB 'a' AND item_path GLOB 'b') OR (testname LIKE 'a%' AND item_path LIKE '%') OR (testname LIKE '%' AND item_path LIKE 'b%')" (tests:match->sqlqry "a/b,a%,%/b%")) +(let* ((cmd "dunno") + (run-id 1) + (rid 1) + (rawcmd "dunno") + (params '()) + (duration 100) + (connection-info (vector #f #f #f)) + (dat "abc") + (json-str "\"def\"") + (item-path "a/b/c") + (test-id 1) + (testpatt "%/a/%") + (newstate "COMPLETED") + (newstatus "PASS") + (newcomment "Stupid comment") + (testnames '("test1" "test2")) + (currstate "COMPLETED") + (currstatus "FAIL") + (states '("COMPLETED" "RUNNING")) + (statuses '("PASS" "FAIL")) + (offset 100) + (limit 10) + (not-in #t) + (sort-by #f) + (sort-order #f) + (qryvals #f) + (qry 'a) + (synckey #f) + (keynum 1) + (run-ids '(1 2 3)) + (state "RUNNING") + (status "FAIL") + (msg "Sillyness") + (test-name "test184") + (logf "/tmp/a.logfile") + (pid 1234567) + (target "a/b/c") + (res #f) + (runname "myfirstrun") + (statepatt "CO%") + (statuspatt "PA%") + (keynames '("SYSTEM" "RELEASE")) ;; "sysname" "fsname" "datapath")) + (waitons '("a" "b" "c")) + (ref-item-path "/d/e/f") + (jobgroup "anl") + (runpatt "run%") + (keyvals '(("SYSTEM" "a")("RELEASE" "b"))) + (keys (map car keyvals)) + (user "freddy") + (owner "tommy") + (count 100) + (keypatts '(("SYSTEM" "%a")("RELEASE" "%b"))) + (lock #f) + (unlock #t) + (run-status "n/a") + (runnamepatt "b%") + (targpatt "%a/%b") + (fields "id,runname") + (ovr-deadtime 100) + (teststep-name "first") + (state-in "COMPLETED") + (status-in "FAIL") + (comment "This is a comment eh!") + (logfile "/tmp/alogfile.log") + (categorypatt "stats") + (work-area "/tmp") + (fld "owner") + (val 5) + (csvdata "id,meas,val\n1,voltage,2") + (action-patt "%") + (param-key "dunno") + (testname "atest") + (dneeded 10000) + (bdisk-id 1) + (archive-path "tmp") + (block-id 1) + (testsuite-name "fullrun") + (areakey "dunno") + (bdisk-name "what") + (bdisk-path "tmp") + (df 1000000) + (archive-block-id 1) + (stmtname 'blah)) + (test #f #f (rmt:write-frequency-over-limit? cmd run-id)) + (test #f #f (rmt:get-connection-info run-id)) + (test #f #t (rmt:update-db-stats run-id rawcmd params duration)) + (test #f #t (begin (rmt:print-db-stats) #t)) + (test #f '(none . 0) (rmt:get-max-query-average run-id)) + (test #f #f (rmt:send-receive-no-auto-client-setup connection-info cmd run-id params)) + (test #f "\"abc\"" (rmt:dat->json-str dat)) + (test #f "def" (rmt:json-str->dat json-str)) + (test #f #f (rmt:kill-server run-id)) + (test #f #t (begin (rmt:start-server run-id) #t)) + (test #f '(#f "Login failed due to mismatch run-id: " 1 ", " #f) (rmt:login run-id)) + (test #f #f (rmt:login-no-auto-client-setup connection-info run-id)) + (test #f #t (begin (rmt:runtests user run-id testpatt params) #t)) + (test #f '() (rmt:get-key-val-pairs run-id)) + (test #f '("SYSTEM" "RELEASE") (rmt:get-keys)) + (test #f '() (rmt:get-key-vals run-id)) + (test #f (vector '("SYSTEM" "RELEASE") '()) (rmt:get-targets)) + (test #f #t (rmt:register-test run-id test-name item-path)) + (test #f #f (rmt:get-test-id run-id testname item-path)) + (test #f #f (rmt:get-test-info-by-id run-id test-id)) + (test #f #f (rmt:test-get-rundir-from-test-id run-id test-id)) + (test #f #t (database? (rmt:open-test-db-by-test-id run-id test-id work-area: "/tmp"))) + (test #f #t (begin (rmt:set-tests-state-status run-id testnames currstate currstatus newstate newstatus) #t)) + (test #f '() (rmt:get-tests-for-run run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals)) ;;; + (test #f #t (vector? (car (rmt:get-tests-for-runs-mindata run-ids testpatt states statuses not-in)))) + (test #f #t (begin (rmt:delete-test-records run-id test-id) #t)) + (test #f #t (begin (rmt:test-set-status-state run-id test-id status state msg) #t)) + (test #f 1 (rmt:test-toplevel-num-items run-id test-name)) + (test #f '() (rmt:get-matching-previous-test-run-records run-id test-name item-path)) + (test #f #f (rmt:test-get-logfile-info run-id test-name)) + (test #f #t (vector? (car (rmt:test-get-records-for-index-file run-id test-name)))) + (test #f #f (rmt:get-testinfo-state-status run-id test-id)) + (test #f #t (rmt:test-set-log! run-id test-id logf)) + (test #f #t (begin (rmt:test-set-top-process-pid run-id test-id pid) #t)) + (test #f #f (rmt:test-get-top-process-pid run-id test-id)) + (test #f '() (rmt:get-run-ids-matching-target keynames target res runname testpatt statepatt statuspatt)) + (test #f '() (rmt:test-get-paths-matching-keynames-target-new keynames target res testpatt statepatt statuspatt runname)) + (test #f '("c" "b" "a") (rmt:get-prereqs-not-met run-id waitons ref-item-path)) ;; #!key (mode '(normal))(itemmap #f))) + (test #f 0 (rmt:get-count-tests-running-for-run-id run-id)) + (test #f 0 (rmt:get-count-tests-running run-id)) + (test #f 0 (rmt:get-count-tests-running-for-testname run-id testname)) + (test #f 0 (rmt:get-count-tests-running-in-jobgroup run-id jobgroup)) + (test #f #t (rmt:roll-up-pass-fail-counts run-id test-name item-path state status)) + (test #f #t (rmt:update-pass-fail-counts run-id test-name)) + (test #f #t (rmt:top-test-set-per-pf-counts run-id test-name)) + (test #f #t (vector? (rmt:get-run-info run-id))) + (test #f 0 (rmt:get-num-runs runpatt)) + (test #f 1 (rmt:register-run keyvals runname state status user)) + (test #f "myfirstrun" (rmt:get-run-name-from-id run-id)) + (test #f #t (begin (rmt:delete-run run-id) #t)) + (test #f #t (begin (rmt:delete-old-deleted-test-records) #t)) + (test #f #t (vector? (rmt:get-runs runpatt count offset keypatts))) + (test #f '() (rmt:get-all-run-ids)) + (test #f '() (rmt:get-prev-run-ids run-id)) + (test #f #t (begin (rmt:lock/unlock-run run-id lock unlock user) #t)) + (test #f #t (begin (rmt:set-run-status run-id "NONPASS" msg: msg) #t)) ;; run-status + (test #f "NONPASS" (rmt:get-run-status run-id)) + (test #f #t (begin (rmt:update-run-event_time run-id) #t)) + (test #f (vector '("SYSTEM" "RELEASE" "id") '()) (rmt:get-runs-by-patt keys runnamepatt targpatt offset limit '("id"))) ;; fields of #f uses default) + (test #f #t (begin (rmt:find-and-mark-incomplete run-id ovr-deadtime) #t)) + (test #f #t (begin (rmt:find-and-mark-incomplete-all-runs ovr-deadtime: ovr-deadtime) #t)) + (test #f #f (rmt:get-previous-test-run-record run-id test-name item-path)) + (test #f #t (begin (rmt:teststep-set-status! run-id test-id teststep-name state-in status-in comment logfile) #t)) + (test #f #t (vector? (car (rmt:get-steps-for-test run-id test-id)))) + (test #f '() (rmt:read-test-data run-id test-id categorypatt work-area: work-area)) + (test #f #t (begin (rmt:testmeta-add-record testname) #t)) + (test #f (vector 1 "atest" "" "" "" "" "" "" "" "" "default") (rmt:testmeta-get-record testname)) + (test #f #t (begin (rmt:testmeta-update-field test-name fld val) #t)) + (test #f #t (rmt:test-data-rollup run-id test-id status)) + (test #f #t (begin (rmt:csv->test-data run-id test-id csvdata) #t)) + (test #f '() (rmt:tasks-find-task-queue-records target runname testpatt statepatt action-patt)) + (test #f #t (begin (rmt:tasks-add "action" owner target runname testpatt "params") #t)) + (test #f #t (begin (rmt:tasks-set-state-given-param-key param-key newstate) #t)) + (test #f #t (begin (rmt:test-set-state-status-by-id run-id test-id newstate newstatus newcomment) #t)) +;; +;; (test #f #f (rmt:archive-get-allocations testname itempath dneeded)) +;; (test #f #f (rmt:archive-register-block-name bdisk-id archive-path)) +;; (test #f #f (rmt:archive-allocate-testsuite/area-to-block block-id testsuite-name areakey)) +;; (test #f #f (rmt:archive-register-disk bdisk-name bdisk-path df)) +;; (test #f #f (rmt:test-set-archive-block-id run-id test-id archive-block-id)) + ;; (test #f #f (rmt:test-get-archive-block-info archive-block-id)) + + ;; Defer these a little while ... + ;; + ;; (test #f #f (rmt:synchash-get run-id proc synckey keynum params)) + ;; (test #f #f (rmt:send-receive cmd rid params #!key (attemptnum 1)) ;; start attemptnum at 1 so the modulo below works as expected) + ;; (test #f #f (rmt:open-qry-close-locally cmd run-id params #!key (remretries 5))) + ;; (test #f #f (apply rmt:general-call stmtname run-id params)) + ;; (test #f #f (rmt:sync-inmem->db run-id)) + ;; (test #f #f (rmt:sdb-qry qry val run-id)) + + ;; Deprecated or removed + ;; + ;; (test #f #f (rmt:get-run-ids-matching keynames target res)) + + ) (exit) Index: tests/unittests/runs.scm ================================================================== --- tests/unittests/runs.scm +++ tests/unittests/runs.scm @@ -99,11 +99,11 @@ (let ((dat (rmt:testmeta-get-record "test1"))) (vector-ref dat 1)))) (define test-path "tests/test1") (define disk-path #f) -(test "get-best-disk" #t (string? (file-exists? (let ((d (get-best-disk *configdat*))) +(test "get-best-disk" #t (string? (file-exists? (let ((d (get-best-disk *configdat* #f))) (set! disk-path d) d)))) (test "create-work-area" #t (symbolic-link? (car (create-work-area 1 rinfo keyvals 1 test-path disk-path "test1" '())))) (test #f "" (item-list->path '())) @@ -153,12 +153,34 @@ (string? (file-exists? ;; (launch-test test-id run-id run-info keyvals runname test-conf test-name test-path itemdat params) (launch-test 30001 1 rinfo keyvals "run1" tconfig "test1" test-path '() (make-hash-table))))) +;;====================================================================== +;; M O R E R E M O T E C A L L S +;;====================================================================== + +(test #f '("COMPLETED" "PASS") + (begin + (rmt:set-tests-state-status 1 '("rollup") "COMPLETED" "AUTO" "COMPLETED" "PASS") + (get-state-status 1 "rollup" ""))) +(test #f #t (rmt:top-test-set-per-pf-counts 1 "rollup")) + +;;====================================================================== +;; T E S T I T E M M A P +;;====================================================================== +(test #f "a/b/c" (db:multi-pattern-apply "d/e/f" "d a\ne b\nf c")) +(test #f "blah/foo/bar/baz" (db:convert-test-itempath "blah/baz/bar/foo" "^([^/]+)/([^/]+)/([^/]+)$ \\3/\\2/\\1")) +(test #f #t (db:compare-itempaths "abc/def/123" "abc/ghi/123" "ghi def")) +(test #f #f (db:compare-itempaths "some/5" "item/5" ".*/")) +(test #f #t (db:compare-itempaths "some/5" "item/5" ".*/ some/")) +(test #f '() (rmt:get-prereqs-not-met 1 '("rollup") "some/5" mode: '(toplevel) itemmap: ".*/" "/")) +(test #f '() (rmt:get-prereqs-not-met 1 '("rollup") "some/5" mode: '(normal) itemmap: ".*/" "/")) +(test #f '() (rmt:get-prereqs-not-met 1 '("rollup") "some/5" mode: '(itemmatch) itemmap: ".*/" "/")) +(test #f '() (rmt:get-prereqs-not-met 1 '("rollup") "some/5" mode: '(itemwait) itemmap: ".*/" "/")) (exit 1) @@ -320,17 +342,12 @@ (test "server stop" #f (let ((hostname (car *runremote*)) (port (cadr *runremote*))) (tasks:kill-server #t hostname port server-pid 'http) (open-run-close tasks:get-best-server tasks:open-db))) -;;====================================================================== -;; M O R E R E M O T E C A L L S -;;====================================================================== - -(test #f #f (rmt:set-tests-state-status 1 '("runfirst") "RUNNING" "WARN" "COMPLETED" "FAIL")) ;; (cdb:kill-server *runremote*) ;; (thread-join! th1 th2 th3) ;; ADD ME!!!! (db:get-prereqs-not-met *db* 1 '("runfirst") "" mode: 'normal) ;; ADD ME!!!! (rdb:get-tests-for-run *db* 1 "runfirst" #f '() '())