Index: .fossil-settings/ignore-glob ================================================================== --- .fossil-settings/ignore-glob +++ .fossil-settings/ignore-glob @@ -39,5 +39,8 @@ tests/megatest.db tests/fdktestqa/simplelinks/* tests/fdktestqa/testqa/megatest.db tests/fdktestqa/testqa/monitor.db megatest-fossil-hash.scm +tests/release/runs/* +tests/release/links/* +tests/release/megatest.db Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -36,19 +36,22 @@ ARCHSTR=$(shell lsb_release -sr) # ARCHSTR=$(shell bash -c "echo \$$MACHTYPE") all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard -mtest: $(OFILES) megatest.o readline-fix.scm +mtest: $(OFILES) readline-fix.scm megatest.o csc $(CSCOPTS) $(OFILES) megatest.o -o mtest dboard : $(OFILES) $(GOFILES) dashboard.scm csc $(OFILES) dashboard.scm $(GOFILES) -o dboard ndboard : newdashboard.scm $(OFILES) $(GOFILES) csc $(OFILES) $(GOFILES) newdashboard.scm -o ndboard +multi-dboard : multi-dboard.scm $(OFILES) $(GOFILES) + csc $(OFILES) $(GOFILES) multi-dboard.scm -o multi-dboard + # # $(PREFIX)/bin/revtagfsl : utils/revtagfsl.scm # csc utils/revtagfsl.scm -o $(PREFIX)/bin/revtagfsl # Special dependencies for the includes @@ -83,10 +86,17 @@ $(INSTALL) ndboard $(PREFIX)/bin/.$(ARCHSTR)/ndboard $(PREFIX)/bin/newdashboard : $(PREFIX)/bin/.$(ARCHSTR)/ndboard utils/mk_wrapper $(PREFIX) ndboard $(PREFIX)/bin/newdashboard chmod a+x $(PREFIX)/bin/newdashboard + +$(PREFIX)/bin/.$(ARCHSTR)/mdboard : multi-dboard + $(INSTALL) multi-dboard $(PREFIX)/bin/.$(ARCHSTR)/mdboard + +$(PREFIX)/bin/mdboard : $(PREFIX)/bin/.$(ARCHSTR)/mdboard + utils/mk_wrapper $(PREFIX) mdboard $(PREFIX)/bin/mdboard + chmod a+x $(PREFIX)/bin/mdboard # $(HELPERS) : utils/% # $(INSTALL) $< $@ # chmod a+x $@ @@ -138,11 +148,11 @@ $(INSTALL) dboard $(PREFIX)/bin/.$(ARCHSTR)/dboard install : $(PREFIX)/bin/.$(ARCHSTR) $(PREFIX)/bin/.$(ARCHSTR)/mtest $(PREFIX)/bin/megatest \ $(PREFIX)/bin/.$(ARCHSTR)/dboard $(PREFIX)/bin/dashboard $(HELPERS) $(PREFIX)/bin/nbfake \ $(PREFIX)/bin/nbfind $(PREFIX)/bin/loadrunner $(PREFIX)/bin/mt_xterm \ - $(PREFIX)/bin/newdashboard + $(PREFIX)/bin/newdashboard $(PREFIX)/bin/mdboard $(PREFIX)/bin/.$(ARCHSTR) : mkdir -p $(PREFIX)/bin/.$(ARCHSTR) test: tests/tests.scm ADDED all-exceptions.ods Index: all-exceptions.ods ================================================================== --- /dev/null +++ all-exceptions.ods cannot compute difference between binary files Index: api.scm ================================================================== --- api.scm +++ api.scm @@ -40,10 +40,11 @@ get-tests-for-run get-test-id get-tests-for-runs-mindata get-run-name-from-id get-runs + get-num-runs get-all-run-ids get-prev-run-ids get-run-ids-matching-target get-runs-by-patt get-steps-data @@ -131,11 +132,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-fail-pass-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)) ((test-set-archive-block-id) (apply db:test-set-archive-block-id dbstruct params)) ;; RUNS ((register-run) (apply db:register-run dbstruct params)) ((set-tests-state-status) (apply db:set-tests-state-status dbstruct params)) @@ -174,10 +175,12 @@ ;;====================================================================== ;; KEYS ((get-key-val-pairs) (apply db:get-key-val-pairs dbstruct params)) ((get-keys) (db:get-keys dbstruct)) + ((get-key-vals) (apply db:get-key-vals dbstruct params)) + ((get-targets) (db:get-targets dbstruct)) ;; ARCHIVES ((test-get-archive-block-info) (apply db:test-get-archive-block-info dbstruct params)) ;; TESTS @@ -205,10 +208,11 @@ ((set-run-status) (apply db:set-run-status dbstruct params)) ((get-tests-for-run) (apply db:get-tests-for-run dbstruct params)) ((get-test-id) (apply db:get-test-id dbstruct params)) ((get-tests-for-run-mindata) (apply db:get-tests-for-run-mindata dbstruct params)) ((get-runs) (apply db:get-runs dbstruct params)) + ((get-num-runs) (apply db:get-num-runs dbstruct params)) ((get-all-run-ids) (db:get-all-run-ids dbstruct)) ((get-prev-run-ids) (apply db:get-prev-run-ids dbstruct params)) ((get-run-ids-matching-target) (apply db:get-run-ids-matching-target dbstruct params)) ((get-runs-by-patt) (apply db:get-runs-by-patt dbstruct params)) ((get-run-name-from-id) (apply db:get-run-name-from-id dbstruct params)) Index: bin/sleeprunner ================================================================== --- bin/sleeprunner +++ bin/sleeprunner @@ -1,7 +1,7 @@ #!/bin/bash if [[ $SLEEPRUNNER == "" ]];then -SLEEPRUNNER=1 +SLEEPRUNNER=0 fi echo "nbfake $@ &> /dev/null" | at now + $SLEEPRUNNER minutes &> /dev/null Index: client.scm ================================================================== --- client.scm +++ client.scm @@ -211,36 +211,38 @@ ;; keep this as a function to ease future (define (client:start run-id server-info) (http-transport:client-connect (tasks:hostinfo-get-interface server-info) (tasks:hostinfo-get-port server-info))) -;; client:signal-handler -(define (client:signal-handler signum) - (signal-mask! signum) - (handle-exceptions - exn - (debug:print " ... exiting ...") - (let ((th1 (make-thread (lambda () - "") ;; do nothing for now (was flush out last call if applicable) - "eat response")) - (th2 (make-thread (lambda () - (debug:print 0 "ERROR: Received ^C, attempting clean exit. Please be patient and wait a few seconds before hitting ^C again.") - (thread-sleep! 1) ;; give the flush one second to do it's stuff - (debug:print 0 " Done.") - (exit 4)) - "exit on ^C timer"))) - (thread-start! th2) - (thread-start! th1) - (thread-join! th2)))) - -;; client:launch -;; Need to set the signal handler somewhere other than here as this -;; routine will go away. -;; -(define (client:launch run-id) - (set-signal-handler! signal/int client:signal-handler) - (if (client:setup run-id) - (debug:print-info 2 "connected as client") - (begin - (debug:print 0 "ERROR: Failed to connect as client") - (exit)))) - +;; ;; client:signal-handler +;; (define (client:signal-handler signum) +;; (signal-mask! signum) +;; (set! *time-to-exit* #t) +;; (handle-exceptions +;; exn +;; (debug:print " ... exiting ...") +;; (let ((th1 (make-thread (lambda () +;; "") ;; do nothing for now (was flush out last call if applicable) +;; "eat response")) +;; (th2 (make-thread (lambda () +;; (debug:print 0 "ERROR: Received ^C, attempting clean exit. Please be patient and wait a few seconds before hitting ^C again.") +;; (thread-sleep! 1) ;; give the flush one second to do it's stuff +;; (debug:print 0 " Done.") +;; (exit 4)) +;; "exit on ^C timer"))) +;; (thread-start! th2) +;; (thread-start! th1) +;; (thread-join! th2)))) +;; +;; ;; client:launch +;; ;; Need to set the signal handler somewhere other than here as this +;; ;; routine will go away. +;; ;; +;; (define (client:launch run-id) +;; (set-signal-handler! signal/int client:signal-handler) +;; (set-signal-handler! signal/term client:signal-handler) +;; (if (client:setup run-id) +;; (debug:print-info 2 "connected as client") +;; (begin +;; (debug:print 0 "ERROR: Failed to connect as client") +;; (exit)))) +;; Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -7,12 +7,12 @@ ;; This program is distributed WITHOUT ANY WARRANTY; without even the ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. ;;====================================================================== -(use sqlite3 srfi-1 posix regex-case base64 format dot-locking csv-xml z3) -(require-extension sqlite3 regex posix) +(use srfi-1 posix regex-case base64 format dot-locking csv-xml z3 nanomsg sql-de-lite hostinfo) +(require-extension regex posix) (require-extension (srfi 18) extras tcp rpc) (import (prefix sqlite3 sqlite3:)) (import (prefix base64 base64:)) @@ -22,10 +22,17 @@ (include "common_records.scm") ;; (require-library margs) ;; (include "margs.scm") +;; (define old-exit exit) +;; +;; (define (exit . code) +;; (if (null? code) +;; (old-exit) +;; (old-exit code))) + (define getenv get-environment-variable) (define (safe-setenv key val) (if (and (string? val)(string? key)) (handle-exceptions exn @@ -151,11 +158,11 @@ (hash-table-set! *common:denoise* key currtime) #t) #f))) (define (common:get-megatest-exe) - (if (getenv "MT_MEGATEST") (getenv "MT_MEGATEST") "megatest")) + (or (getenv "MT_MEGATEST") "megatest")) (define (common:read-encoded-string instr) (handle-exceptions exn (handle-exceptions @@ -242,43 +249,75 @@ ;;====================================================================== ;; E X I T H A N D L I N G ;;====================================================================== +(define (common:legacy-sync-recommended) + (or (args:get-arg "-runtests") + (args:get-arg "-server") + (args:get-arg "-set-run-status") + (args:get-arg "-remove-runs") + (args:get-arg "-get-run-status") + )) + +(define (common:legacy-sync-required) + (configf:lookup *configdat* "setup" "megatest-db")) + (define (std-exit-procedure) - (debug:print-info 2 "starting exit process, finalizing databases.") - (rmt:print-db-stats) - (let ((run-ids (hash-table-keys *db-local-sync*))) - (if (and (not (null? run-ids)) - (configf:lookup *configdat* "setup" "megatest-db")) - (db:multi-db-sync run-ids 'new2old))) - (if *dbstruct-db* (db:close-all *dbstruct-db*)) - (if *inmemdb* (db:close-all *inmemdb*)) - (if (and *megatest-db* - (sqlite3:database? *megatest-db*)) - (begin - (sqlite3:interrupt! *megatest-db*) - (sqlite3:finalize! *megatest-db* #t) - (set! *megatest-db* #f))) - (if *task-db* (let ((db (cdr *task-db*))) - (if (sqlite3:database? db) - (begin - (sqlite3:interrupt! db) - (sqlite3:finalize! db #t) - (vector-set! *task-db* 0 #f)))))) + (let ((no-hurry (if *time-to-exit* ;; hurry up + #f + (begin + (set! *time-to-exit* #t) + #t)))) + (debug:print-info 4 "starting exit process, finalizing databases.") + (if (and no-hurry (debug:debug-mode 18)) + (rmt:print-db-stats)) + (let ((th1 (make-thread (lambda () ;; thread for cleaning up, give it five seconds + (let ((run-ids (hash-table-keys *db-local-sync*))) + (if (and (not (null? run-ids)) + (configf:lookup *configdat* "setup" "megatest-db")) + (if no-hurry (db:multi-db-sync run-ids 'new2old)))) + (if *dbstruct-db* (db:close-all *dbstruct-db*)) + (if *inmemdb* (db:close-all *inmemdb*)) + (if (and *megatest-db* + (sqlite3:database? *megatest-db*)) + (begin + (sqlite3:interrupt! *megatest-db*) + (sqlite3:finalize! *megatest-db* #t) + (set! *megatest-db* #f))) + (if *task-db* + (let ((db (cdr *task-db*))) + (if (sqlite3:database? db) + (begin + (sqlite3:interrupt! db) + (sqlite3:finalize! db #t) + (vector-set! *task-db* 0 #f)))))) "Cleanup db exit thread")) + (th2 (make-thread (lambda () + (debug:print 4 "Attempting clean exit. Please be patient and wait a few seconds...") + (if no-hurry + (thread-sleep! 5) ;; give the clean up few seconds to do it's stuff + (thread-sleep! 2)) + (debug:print 4 " ... done") + ) + "clean exit"))) + (thread-start! th1) + (thread-start! th2) + (thread-join! th1)))) (define (std-signal-handler signum) - (signal-mask! signum) + ;; (signal-mask! signum) + (set! *time-to-exit* #t) (debug:print 0 "ERROR: Received signal " signum " exiting promptly") ;; (std-exit-procedure) ;; shouldn't need this since we are exiting and it will be called anyway (exit)) -(set-signal-handler! signal/int std-signal-handler) +(set-signal-handler! signal/int std-signal-handler) ;; ^C (set-signal-handler! signal/term std-signal-handler) +(set-signal-handler! signal/stop std-signal-handler) ;; ^Z ;;====================================================================== -;; Misc utils +;; M I S C U T I L S ;;====================================================================== ;; Convert strings like "5s 2h 3m" => 60x60x2 + 3x60 + 5 (define (common:hms-string->seconds tstr) (let ((parts (string-split tstr)) @@ -356,27 +395,30 @@ ;;====================================================================== ;; T A R G E T S ;;====================================================================== (define (common:args-get-target #!key (split #f)) - (let* ((target (if (args:get-arg "-reqtarg") + (let* ((keys (keys:config-get-fields *configdat*)) + (numkeys (length keys)) + (target (if (args:get-arg "-reqtarg") (args:get-arg "-reqtarg") (if (args:get-arg "-target") (args:get-arg "-target") (getenv "MT_TARGET")))) (tlist (if target (string-split target "/" #t) '())) (valid (if target (and (not (null? tlist)) + (eq? numkeys (length tlist)) (null? (filter string-null? tlist))) #f))) (if valid (if split tlist target) (if target (begin - (debug:print 0 "ERROR: Invalid target, spaces or blanks not allowed \"" target "\"") + (debug:print 0 "ERROR: Invalid target, spaces or blanks not allowed \"" target "\", target should be: " (string-intersperse keys "/")) #f) #f)))) ;;====================================================================== ;; M I S C L I S T S @@ -709,5 +751,183 @@ ((equal? status "KILLED") "orange") ((equal? status "KILLREQ") "purple") ((equal? status "RUNNING") "blue") ((equal? status "ABORT") "brown") (else "black"))) + +;;====================================================================== +;; N A N O M S G C L I E N T +;;====================================================================== + +(define (server:get-best-guess-address hostname) + (let ((res #f)) + (for-each + (lambda (adr) + (if (not (eq? (u8vector-ref adr 0) 127)) + (set! res adr))) + ;; NOTE: This can fail when there is no mention of the host in /etc/hosts. FIXME + (vector->list (hostinfo-addresses (hostname->hostinfo hostname)))) + (string-intersperse + (map number->string + (u8vector->list + (if res res (hostname->ip hostname)))) "."))) + +(define (common:open-nm-req addr) + (let* ((req (nn-socket 'req)) + (res (nn-connect req addr))) + req)) + +;; (with-output-to-string (lambda ()(serialize obj))) +(define (common:nm-send-receive soc msg) + (nn-send soc msg) + (nn-recv soc)) + +(define (common:close-nm-req soc) + (nn-close soc)) + +(define (common:send-dboard-main-changed) + (let* ((dashboard-ips (mddb:get-dashboards))) + (for-each + (lambda (ipadr) + (let* ((soc (common:open-nm-req (conc "tcp://" ipadr))) + (msg (conc "main " *toppath*)) + (res (common:nm-send-receive-timeout soc msg))) + (if (not res) ;; couldn't reach that dashboard - remove it from db + (print "ERROR: couldn't reach dashboard " ipadr)) + res)) + dashboard-ips))) + +(define (common:nm-send-receive-timeout req msg) + (let* ((key "ping") + (success #f) + (keepwaiting #t) + (result #f) + (sendrec (make-thread + (lambda () + (nn-send req msg) + (set! result (nn-recv req)) + (set! success #t)) + "send-receive")) + (timeout (make-thread (lambda () + (let loop ((count 0)) + (thread-sleep! 1) + (print "still waiting after count seconds...") + (if (and keepwaiting (< count 10)) + (loop (+ count 1)))) + (if keepwaiting + (begin + (print "timeout waiting for reply") + (thread-terminate! sendrec)))) + "timeout"))) + (handle-exceptions + exn + (begin + (print-call-chain) + (print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) + (print "exn=" (condition->list exn))) + (thread-start! timeout) + (thread-start! sendrec) + (thread-join! sendrec) + (if success (thread-terminate! timeout))) + result)) + +(define (common:ping-nm req) + ;; send a random number and check that we get it back + (let* ((key "ping") + (success #f) + (keepwaiting #t) + (ping (make-thread + (lambda () + (print "ping: sending string \"" key "\", expecting " (current-process-id)) + (nn-send req key) + (let ((result (nn-recv req))) + (if (equal? (conc (current-process-id)) result) + (begin + (print "ping, success: received \"" result "\"") + (set! success #t)) + (begin + (print "ping, failed: received key \"" result "\"") + (set! keepwaiting #f) + (set! success #f))))) + "ping")) + (timeout (make-thread (lambda () + (let loop ((count 0)) + (thread-sleep! 1) + (print "still waiting after count seconds...") + (if (and keepwaiting (< count 10)) + (loop (+ count 1)))) + (if keepwaiting + (begin + (print "timeout waiting for ping") + (thread-terminate! ping)))) + "timeout"))) + (handle-exceptions + exn + (begin + (print-call-chain) + (print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) + (print "exn=" (condition->list exn)) + (print "ping failed to connect to tcp://" hostport)) + (thread-start! timeout) + (thread-start! ping) + (thread-join! ping) + (if success (thread-terminate! timeout))) + (if return-socket + (if success req #f) + (begin + (nn-close req) + success)))) + +;;====================================================================== +;; D A S H B O A R D D B +;;====================================================================== + +(define (mddb:open-db) + (let* ((db (open-database (conc (get-environment-variable "HOME") "/.dashboard.db")))) + (set-busy-handler! db (busy-timeout 10000)) + (for-each + (lambda (qry) + (exec (sql db qry))) + (list + "CREATE TABLE IF NOT EXISTS vars (id INTEGER PRIMARY KEY,key TEXT, val TEXT, CONSTRAINT varsconstraint UNIQUE (key));" + "CREATE TABLE IF NOT EXISTS dashboards ( + id INTEGER PRIMARY KEY, + pid INTEGER, + username TEXT, + hostname TEXT, + ipaddr TEXT, + portnum INTEGER, + start_time TIMESTAMP DEFAULT (strftime('%s','now')), + CONSTRAINT hostport UNIQUE (hostname,portnum) + );" + )) + db)) + +;; register a dashboard +;; +(define (mddb:register-dashboard port) + (let* ((pid (current-process-id)) + (hostname (get-host-name)) + (ipaddr (server:get-best-guess-address hostname)) + (username (current-user-name)) ;; (car userinfo))) + (db (mddb:open-db))) + (print "Register monitor, pid: " pid ", hostname: " hostname ", port: " port ", username: " username) + (exec (sql db "INSERT OR REPLACE INTO dashboards (pid,username,hostname,ipaddr,portnum) VALUES (?,?,?,?,?);") + pid username hostname ipaddr port) + (close-database db))) + +;; unregister a monitor +;; +(define (mddb:unregister-dashboard host port) + (let* ((db (mddb:open-db))) + (print "Register unregister monitor, host:port=" host ":" port) + (exec (sql db "DELETE FROM dashboards WHERE hostname=? AND portnum=?;") host port) + (close-database db))) + +;; get registered dashboards +;; +(define (mddb:get-dashboards) + (let ((db (mddb:open-db))) + (query fetch-column + (sql db "SELECT ipaddr || ':' || portnum FROM dashboards;")))) + + Index: dashboard-tests.scm ================================================================== --- dashboard-tests.scm +++ dashboard-tests.scm @@ -95,11 +95,11 @@ (lambda (testdat) (let ((newcomment (db:test-get-comment testdat))) (if *dashboard-comment-share-slot* (if (not (equal? (iup:attribute *dashboard-comment-share-slot* "VALUE") newcomment)) - (iup:attribute-set! *dashboard-comment-slot* + (iup:attribute-set! *dashboard-comment-share-slot* "VALUE" newcomment))) newcomment))) (store-label "testid" (iup:label "TestId " @@ -417,18 +417,18 @@ (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)) - (tdb (tdb:open-test-db-by-test-id-local dbstruct run-id test-id)) + ;; (tdb (tdb:open-test-db-by-test-id-local dbstruct run-id test-id)) ;; These next two are intentional bad values to ensure errors if they should not ;; get filled in properly. (logfile "/this/dir/better/not/exist") (rundir (if testdat (db:test-get-rundir testdat) logfile)) - (testdat-path (conc rundir "/testdat.db")) ;; this gets recalculated until found + ;; (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")) (testmeta (if testdat (let ((tm (db:testmeta-get-record dbstruct testname))) @@ -462,16 +462,16 @@ (system (conc "cd " rundir ";mt_xterm -T \"" (string-translate testfullname "()" " ") "\" " shell "&"))) (message-window (conc "Directory " rundir " not found"))))) (widgets (make-hash-table)) (refreshdat (lambda () - (let* ((curr-mod-time (max (file-modification-time db-path) - (if (file-exists? testdat-path) - (file-modification-time testdat-path) - (begin - (set! testdat-path (conc rundir "/testdat.db")) - 0)))) + (let* ((curr-mod-time (file-modification-time db-path)) + ;; (max ..... (if (file-exists? testdat-path) + ;; (file-modification-time testdat-path) + ;; (begin + ;; (set! testdat-path (conc rundir "/testdat.db")) + ;; 0)))) (need-update (or (and (>= curr-mod-time db-mod-time) (> (current-milliseconds)(+ last-update 250))) ;; every half seconds if db touched (> (current-milliseconds)(+ last-update 10000)) ;; force update even 10 seconds request-update)) (newtestdat (if need-update @@ -694,11 +694,11 @@ (db:test-data-get-tol x) (db:test-data-get-status x) (db:test-data-get-units x) (db:test-data-get-type x) (db:test-data-get-comment x))) - (tdb:open-run-close-db-by-test-id-local dbstruct run-id test-id #f tdb:read-test-data test-id "%"))) + (db:read-test-data dbstruct run-id test-id "%"))) "\n"))) (if (not (equal? currval newval)) (iup:attribute-set! test-data "VALUE" newval ))))) ;; "TITLE" newval))))) test-data)) ;;(dashboard:run-controls) Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -85,10 +85,13 @@ (if (not (launch:setup-for-run)) (begin (print "Failed to find megatest.config, exiting") (exit 1))) +(define *useserver* (or (args:get-arg "-use-server") + (configf:lookup *configdat* "dashboard" "use-server"))) + (define *dbdir* (db:dbfile-path #f)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db")) (define *dbstruct-local* (make-dbr:dbstruct path: *dbdir* local: #t)) (define *db-file-path* (db:dbfile-path 0)) @@ -96,11 +99,13 @@ (define *read-only* (not (file-read-access? *db-file-path*))) (define toplevel #f) (define dlg #f) (define max-test-num 0) -(define *keys* (db:get-keys *dbstruct-local*)) +(define *keys* (if *useserver* + (rmt:get-keys) + (db:get-keys *dbstruct-local*))) (define *dbkeys* (append *keys* (list "runname"))) (define *header* #f) (define *allruns* '()) @@ -109,11 +114,14 @@ (define *buttondat* (make-hash-table)) ;; (define *alltestnamelst* '()) (define *searchpatts* (make-hash-table)) (define *num-runs* 8) -(define *tot-run-count* (db:get-num-runs *dbstruct-local* "%")) +(define *tot-run-count* (if *useserver* + (rmt:get-num-runs "%") + (db:get-num-runs *dbstruct-local* "%"))) + ;; (define *tot-run-count* (db:get-num-runs *dbstruct-local* "%")) ;; Update management ;; (define *last-update* (current-seconds)) @@ -209,12 +217,14 @@ (null? (filter (lambda (x)(> x 3)) delta)))) ;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") ) (define (update-rundat runnamepatt numruns testnamepatt keypatts) (let* ((referenced-run-ids '()) - (allruns (db:get-runs *dbstruct-local* runnamepatt numruns ;; (+ numruns 1) ;; (/ numruns 2)) - *start-run-offset* keypatts)) + (allruns (if *useserver* + (rmt:get-runs runnamepatt numruns *start-run-offset* keypatts) + (db:get-runs *dbstruct-local* runnamepatt numruns ;; (+ numruns 1) ;; (/ numruns 2)) + *start-run-offset* keypatts))) (header (db:get-header allruns)) (runs (db:get-rows allruns)) (result '()) (maxtests 0) (states (hash-table-keys *state-ignore-hash*)) @@ -228,19 +238,28 @@ ;; ;; trim runs to only those that are changing often here ;; (for-each (lambda (run) (let* ((run-id (db:get-value-by-header run header "id")) - (tests (db:get-tests-for-run *dbstruct-local* run-id testnamepatt states statuses - #f #f - *hide-not-hide* - sort-by - sort-order - 'shortlist)) + (tests (if *useserver* + (rmt:get-tests-for-run run-id testnamepatt states statuses + #f #f + *hide-not-hide* + sort-by + sort-order + 'shortlist) + (db:get-tests-for-run *dbstruct-local* run-id testnamepatt states statuses + #f #f + *hide-not-hide* + sort-by + sort-order + 'shortlist))) ;; NOTE: bubble-up also sets the global *all-item-test-names* ;; (tests (bubble-up tmptests priority: bubble-type)) - (key-vals (db:get-key-vals *dbstruct-local* run-id))) + (key-vals (if *useserver* + (rmt:get-key-vals run-id) + (db:get-key-vals *dbstruct-local* run-id)))) ;; NOTE: 11/01/2013 This routine is *NOT* getting called excessively. ;; (debug:print 0 "Getting data for run " run-id " with key-vals=" key-vals) ;; Not sure this is needed? (set! referenced-run-ids (cons run-id referenced-run-ids)) (if (> (length tests) maxtests) @@ -572,11 +591,13 @@ (iup:attribute-set! lb "VALUE" newval) newval)))))) (define (dashboard:update-target-selector key-lbs #!key (action-proc #f)) (let* ((runconf-targs (common:get-runconfig-targets)) - (db-target-dat (db:get-targets *dbstruct-local*)) + (db-target-dat (if *useserver* + (rmt:get-targets) + (db:get-targets *dbstruct-local*))) (header (vector-ref db-target-dat 0)) (db-targets (vector-ref db-target-dat 1)) (all-targets (append db-targets (map (lambda (x) (list->vector @@ -804,11 +825,13 @@ (iup:attribute-set! tb "VALUE" val) (dboard:data-set-run-name! *data* val) (dashboard:update-run-command)))) (refresh-runs-list (lambda () (let* ((target (dboard:data-get-target-string *data*)) - (runs-for-targ (db:get-runs-by-patt *dbstruct-local* *keys* "%" target #f #f)) + (runs-for-targ (if *useserver* + (rmt:get-runs-by-patt *keys* "%" target #f #f #f) + (db:get-runs-by-patt *dbstruct-local* *keys* "%" target #f #f #f))) (runs-header (vector-ref runs-for-targ 0)) (runs-dat (vector-ref runs-for-targ 1)) (run-names (cons default-run-name (map (lambda (x) (db:get-value-by-header x runs-header "runname")) @@ -1031,16 +1054,17 @@ #:selection-cb (lambda (obj id state) ;; (print "obj: " obj ", id: " id ", state: " state) (let* ((run-path (tree:node->path obj id)) (run-id (tree-path->run-id (cdr run-path)))) - (if run-id + (if (number? run-id) (begin (dboard:data-set-curr-run-id! *data* run-id) - (dashboard:update-run-summary-tab))) + (dashboard:update-run-summary-tab)) + (debug:print 0 "ERROR: tree-path->run-id returned non-number " run-id))) ;; (print "path: " (tree:node->path obj id) " run-id: " run-id) - )))) + ))) (cell-lookup (make-hash-table)) (run-matrix (iup:matrix #:expand "YES" #:click-cb (lambda (obj lin col status) @@ -1048,11 +1072,11 @@ (key (conc lin ":" col)) (test-id (hash-table-ref/default cell-lookup key -1)) (cmd (conc toolpath " -test " (dboard:data-get-curr-run-id *data*) "," test-id "&"))) (system cmd))))) (updater (lambda () - (let* ((runs-dat (db:get-runs-by-patt db *keys* "%" #f #f #f)) + (let* ((runs-dat (db:get-runs-by-patt db *keys* "%" #f #f #f #f)) (runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records (run-id (dboard:data-get-curr-run-id *data*)) (tests-dat (let ((tdat (db:get-tests-for-run db run-id (hash-table-ref/default *searchpatts* "test-name" "%/%") (hash-table-keys *state-ignore-hash*) ;; '() @@ -1526,11 +1550,14 @@ (examine-run *dbstruct-local* runid))) (begin (print "ERROR: runid is not a number " (args:get-arg "-run")) (exit 1))))) ((args:get-arg "-test") ;; run-id,test-id - (let* ((dat (map string->number (string-split (args:get-arg "-test") ","))) + (let* ((dat (let ((d (map string->number (string-split (args:get-arg "-test") ",")))) + (if (> (length d) 1) + d + (list #f #f)))) (run-id (car dat)) (test-id (cadr dat))) (if (and (number? run-id) (number? test-id) (>= test-id 0)) Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -162,29 +162,32 @@ ;; open an sql database inside a file lock ;; ;; returns: db existed-prior-to-opening ;; (define (db:lock-create-open fname initproc) - (if (file-exists? fname) - (let ((db (sqlite3:open-database fname))) - (sqlite3:set-busy-handler! db (make-busy-timeout 136000)) - (db:set-sync db) ;; (sqlite3:execute db "PRAGMA synchronous = 0;") - db) - (let* ((parent-dir (pathname-directory fname)) - (dir-writable (file-write-access? parent-dir))) - (if dir-writable - (let ((exists (file-exists? fname)) - (lock (obtain-dot-lock fname 1 5 10)) - (db (sqlite3:open-database fname))) - (sqlite3:set-busy-handler! db (make-busy-timeout 136000)) - (db:set-sync db) ;; (sqlite3:execute db "PRAGMA synchronous = 0;") - (if (not exists)(initproc db)) - (release-dot-lock fname) - db) - (begin - (debug:print 0 "ERROR: no such db in non-writable dir " fname) - (sqlite3:open-database fname)))))) + ;; (if (file-exists? fname) + ;; (let ((db (sqlite3:open-database fname))) + ;; (sqlite3:set-busy-handler! db (make-busy-timeout 136000)) + ;; (db:set-sync db) ;; (sqlite3:execute db "PRAGMA synchronous = 0;") + ;; db) + (let* ((parent-dir (pathname-directory fname)) + (dir-writable (file-write-access? parent-dir)) + (file-exists (file-exists? fname)) + (file-write (if file-exists + (file-write-access? fname) + dir-writable ))) + (if file-write ;; dir-writable + (let (;; (lock (obtain-dot-lock fname 1 5 10)) + (db (sqlite3:open-database fname))) + (sqlite3:set-busy-handler! db (make-busy-timeout 136000)) + (db:set-sync db) ;; (sqlite3:execute db "PRAGMA synchronous = 0;") + (if (not file-exists)(initproc db)) + ;; (release-dot-lock fname) + db) + (begin + (debug:print 2 "WARNING: opening db in non-writable dir " fname) + (sqlite3:open-database fname))))) ;; ) ;; This routine creates the db. It is only called if the db is not already opened ;; (define (db:open-rundb dbstruct run-id #!key (attemptnum 0)(do-not-open #f)) ;; (conc *toppath* "/megatest.db") (car *configinfo*))) (let* ((local (dbr:dbstruct-get-local dbstruct)) @@ -203,11 +206,11 @@ (db (db:lock-create-open dbpath ;; this is the database physically on disk (lambda (db) (handle-exceptions exn (begin - (release-dot-lock dbpath) + ;; (release-dot-lock dbpath) (if (> attemptnum 2) (debug:print 0 "ERROR: tried twice, cannot create/initialize db for run-id " run-id ", at path " dbpath) (db:open-rundb dbstruct run-id attemptnum (+ attemptnum 1)))) (db:initialize-run-id-db db) (sqlite3:execute @@ -486,31 +489,114 @@ '("iterated" #f) '("avg_runtime" #f) '("avg_disk" #f) '("tags" #f) '("jobgroup" #f))))) + +;; use bunch of Unix commands to try to break the lock and recreate the db +;; +(define (db:move-and-recreate-db dbdat) + (let* ((dbpath (db:dbdat-get-path dbdat)) + (dbdir (pathname-directory dbpath)) + (fname (pathname-strip-directory dbpath)) + (fnamejnl (conc fname "-journal")) + (tmpname (conc fname "." (current-process-id))) + (tmpjnl (conc fnamejnl "." (current-process-id)))) + (debug:print 0 "ERROR: " fname " appears corrupted. Making backup \"old/" fname "\"") + (system (conc "cd " dbdir ";mkdir -p old;cat " fname " > old/" tmpname)) + (system (conc "rm -f " dbpath)) + (if (file-exists? fnamejnl) + (begin + (debug:print 0 "ERROR: " fnamejnl " found, moving it to old dir as " tmpjnl) + (system (conc "cd " dbdir ";mkdir -p old;cat " fnamejnl " > old/" tmpjnl)) + (system (conc "rm -f " dbdir "/" fnamejnl)))) + ;; attempt to recreate database + (system (conc "cd " dbdir ";sqlite3 old/" tmpname " .dump | sqlite3 " fname)))) + +;; return #f to indicate the dbdat should be closed/reopened +;; else return dbdat +;; +(define (db:repair-db dbdat #!key (numtries 1)) + (let* ((dbpath (db:dbdat-get-path dbdat)) + (dbdir (pathname-directory dbpath)) + (fname (pathname-strip-directory dbpath))) + (debug:print-info 0 "Checking db " dbpath " for errors.") + (cond + ((not (file-write-access? dbdir)) + (debug:print 0 "WARNING: can't write to " dbdir ", can't fix " fname) + #f) + + ;; handle special cases, megatest.db and monitor.db + ;; + ;; NOPE: apply this same approach to all db files + ;; + (else ;; ((equal? fname "megatest.db") ;; this file can be regenerated if needed + (handle-exceptions + exn + (begin + ;; (db:move-and-recreate-db dbdat) + (if (> numtries 0) + (db:repair-db dbdat numtries: (- numtries 1)) + #f) + (debug:print 0 "FATAL: file " dbpath " was found corrupted, an attempt to fix has been made but you must start over.") + (debug:print 0 + " check the following:\n" + " 1. full directories, look in ~/ /tmp and " dbdir "\n" + " 2. write access to " dbdir "\n\n" + " if the automatic recovery failed you may be able to recover data by doing \"" + (if (member fname '("megatest.db" "monitor.db")) + "megatest -cleanup-db" + "megatest -import-megatest.db;megatest -cleanup-db") + "\"\n") + (exit) ;; we can not safely continue when a db was corrupted - even if fixed. + ) + ;; test read/write access to the database + (let ((db (sqlite3:open-database dbpath))) + (cond + ((equal? fname "megatest.db") + (sqlite3:execute db "DELETE FROM tests WHERE state='DELETED';")) + ((equal? fname "main.db") + (sqlite3:execute db "DELETE FROM runs WHERE state='deleted';")) + ((string-match "\\d.db" fname) + (sqlite3:execute db "UPDATE tests SET state='DELETED' WHERE state='DELETED';")) + ((equal? fname "monitor.db") + (sqlite3:execute "DELETE FROM servers WHERE state LIKE 'defunct%';")) + (else + (sqlite3:execute db "vacuum;"))) + + (finalize! db) + #t)))))) ;; tbls is ( ("tablename" ( "field1" [#f|proc1] ) ( "field2" [#f|proc2] ) .... ) ) ;; db's are dbdat's ;; (define (db:sync-tables tbls fromdb todb . slave-dbs) (mutex-lock! *db-sync-mutex*) (handle-exceptions exn (begin + (mutex-unlock! *db-sync-mutex*) (debug:print 0 "EXCEPTION: database probably overloaded or unreadable in db:sync-tables.") (print-call-chain (current-error-port)) (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) (print "exn=" (condition->list exn)) (debug:print 0 " status: " ((condition-property-accessor 'sqlite3 'status) exn)) (debug:print 0 " src db: " (db:dbdat-get-path fromdb)) (for-each (lambda (dbdat) - (debug:print 0 " dbpath: " (db:dbdat-get-path dbdat))) + (let ((dbpath (db:dbdat-get-path dbdat))) + (debug:print 0 " dbpath: " dbpath) + (if (not (db:repair-db dbdat)) + (begin + (debug:print 0 "ERROR: Failed to rebuild " dbpath ", exiting now.") + (exit))))) (cons todb slave-dbs)) - (if *server-run* ;; we are inside a server, throw a sync-failed error - (signal (make-composite-condition - (make-property-condition 'sync-failed 'message "db:sync-tables failed in a server context."))))) + + 0) +;; (if *server-run* ;; we are inside a server, throw a sync-failed error +;; (signal (make-composite-condition +;; (make-property-condition 'sync-failed 'message "db:sync-tables failed in a server context."))) +;; 0)) ;; return zero for num synced ;; (set! *time-to-exit* #t) ;; let watch dog know that it is time to die. ;; (tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "shutting-down") ;; (portlogger:open-run-close portlogger:set-port port "released") ;; (exit 1))) @@ -566,11 +652,11 @@ ;; tack on remaining records in fromdat (if (not (null? fromdat)) (set! fromdats (cons fromdat fromdats))) - (debug:print-info 2 "found " totrecords " records to sync") + (debug:print-info 4 "found " totrecords " records to sync") ;; read the target table (sqlite3:for-each-row (lambda (a . b) (hash-table-set! todat a (apply vector a b))) @@ -1252,12 +1338,16 @@ (db:delay-if-busy dbdat) (for-each (lambda (toptest) (let ((test-name (list-ref toptest 3))) ;; (run-id (list-ref toptest 5))) - (db:general-call db 'top-test-set-per-pf-counts (list test-name run-id test-name test-name test-name)))) ;; (list run-id test-name)))) + (db:top-test-set-per-pf-counts dbdat run-id test-name))) toplevels))) + +(define (db:top-test-set-per-pf-counts dbdat run-id test-name) + (db:general-call dbdat 'top-test-set-per-pf-counts (list test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name))) + ;; Clean out old junk and vacuum the database ;; ;; Ultimately do something like this: ;; @@ -1608,10 +1698,26 @@ db qrystr ))) (debug:print-info 11 "db:get-runs END qrystr: " qrystr " keypatts: " keypatts " offset: " offset " limit: " count) (vector header res))) + +(define (db:get-changed-run-ids since-time) + (let* ((dbdir (db:dbfile-path #f)) ;; (configf:lookup *configdat* "setup" "dbdir")) + (alldbs (glob (conc dbdir "/[0-9]*.db"))) + (changed (filter (lambda (dbfile) + (> (file-modification-time dbfile) since-time)) + alldbs))) + (delete-duplicates + (map (lambda (dbfile) + (let* ((res (string-match ".*\\/(\\d)*\\.db" dbfile))) + (if res + (string->number (cadr res)) + (begin + (debug:print 2 "WARNING: Failed to process " dbfile " for run-id") + 0)))) + changed)))) ;; db:get-runs-by-patt ;; get runs by list of criteria ;; register a test run with the db ;; @@ -1728,11 +1834,11 @@ (db:delay-if-busy dbdat) (sqlite3:for-each-row (lambda (run-id runname) (set! runs-info (cons (list run-id runname) runs-info))) db - "SELECT id,runname FROM runs WHERE state != 'deleted';") + "SELECT id,runname FROM runs WHERE state != 'deleted' ORDER BY event_time DESC;") ;; If you change this to the more logical ASC please adjust calls to db:get-run-stats ;; for each run get stats data (for-each (lambda (run-info) ;; get the net state/status counts for this run (let* ((run-id (car run-info)) @@ -1767,12 +1873,12 @@ ;; register a test run with the db ;; ;; Use: (db:get-value-by-header (db:get-header runinfo)(db:get-rows runinfo)) ;; to extract info from the structure returned ;; -(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"))) +(define (db:get-runs-by-patt dbstruct keys runnamepatt targpatt offset limit fields) ;; test-name) + (let* ((tmp (runs:get-std-run-fields keys (or fields '("id" "runname" "state" "status" "owner" "event_time")))) (keystr (car tmp)) (header (cadr tmp)) (res '()) (key-patt "") (runwildtype (if (substring-index "%" runnamepatt) "like" "glob")) @@ -2611,10 +2717,24 @@ ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment) (db:delay-if-busy dbdat) (sqlite3:execute db "INSERT OR REPLACE INTO test_data (test_id,category,variable,value,expected,tol,units,comment,status,type) VALUES (?,?,?,?,?,?,?,?,?,?);" test-id category variable value expected tol units (if comment comment "") status type))) csvlist))) + +;; This routine moved from tdb.scm, tdb:read-test-data +;; +(define (db:read-test-data dbstruct run-id test-id categorypatt) + (let* ((dbdat (db:get-db dbstruct run-id)) + (db (db:dbdat-get-db dbdat)) + (res '())) + (db:delay-if-busy dbdat) + (sqlite3:for-each-row + (lambda (id test_id category variable value expected tol units comment status type) + (set! res (cons (vector id test_id category variable value expected tol units comment status type) res))) + db + "SELECT id,test_id,category,variable,value,expected,tol,units,comment,status,type FROM test_data WHERE test_id=? AND category LIKE ? ORDER BY category,variable;" test-id categorypatt) + (reverse res))) ;;====================================================================== ;; Misc. test related queries ;;====================================================================== @@ -2711,22 +2831,38 @@ (db:general-call dbdat 'set-test-start-time (list test-id))) (if msg (db:general-call dbdat 'state-status-msg (list state status msg test-id)) (db:general-call dbdat 'state-status (list state status test-id))))) -(define (db:roll-up-pass-fail-counts dbstruct run-id test-name item-path status) - (if (and (not (equal? item-path "")) - (member status '("PASS" "WARN" "FAIL" "WAIVED" "RUNNING" "CHECK" "SKIP" "LAUNCHED"))) +;; call with state = #f to roll up with out accounting for state/status of this item +;; +(define (db:roll-up-pass-fail-counts dbstruct run-id test-name item-path state status) + (if (not (equal? item-path "")) (let ((dbdat (db:get-db dbstruct run-id))) + ;; (db (db:dbdat-get-db dbdat))) (db:general-call dbdat 'update-pass-fail-counts (list test-name test-name test-name)) - (if (equal? status "RUNNING") - (db:general-call dbdat 'top-test-set-running (list test-name)) - (if (equal? status "LAUNCHED") - (db:general-call dbdat 'top-test-set (list "LAUNCHED" test-name)) - (db:general-call dbdat 'top-test-set-per-pf-counts (list test-name run-id test-name test-name test-name)))) - #f) - #f)) + (db:top-test-set-per-pf-counts dbdat run-id test-name)))) + +;; (case (string->symbol status) +;; ((RUNNING) (db:general-call dbdat 'top-test-set-running (list test-name))) +;; ((LAUNCHED) (db:general-call dbdat 'top-test-set (list "LAUNCHED" test-name))) +;; ((ABORT INCOMPLETE) (db:general-call dbdat 'top-test-set (list status test-name)))) + +;; (if (or (not state) +;; (not (equal? item-path ""))) +;; ;; just do a rollup +;; (begin +;; (db:top-test-set-per-pf-counts dbdat run-id test-name) +;; #f) +;; (begin +;; ;; NOTE: No else clause needed for this case +;; (case (string->symbol status) +;; ((RUNNING) (db:general-call dbdat 'top-test-set-running (list test-name))) +;; ((LAUNCHED) (db:general-call dbdat 'top-test-set (list "LAUNCHED" test-name))) +;; ((ABORT INCOMPLETE) (db:general-call dbdat 'top-test-set (list status test-name)))) +;; #f) +;; ))) (define (db:test-get-logfile-info dbstruct run-id test-name) (db:with-db dbstruct run-id @@ -2785,34 +2921,103 @@ '(update-uname-host "UPDATE tests SET uname=?,host=? WHERE id=?;") ;; DONE '(update-test-state "UPDATE tests SET state=? WHERE state=? AND run_id=? AND testname=? AND NOT (item_path='' AND testname IN (SELECT DISTINCT testname FROM tests WHERE testname=? AND item_path != ''));") '(update-test-status "UPDATE tests SET status=? WHERE status like ? AND run_id=? AND testname=? AND NOT (item_path='' AND testname IN (SELECT DISTINCT testname FROM tests WHERE testname=? AND item_path != ''));") ;; stuff for roll-up-pass-fail-counts '(update-pass-fail-counts "UPDATE tests - SET fail_count=(SELECT count(id) FROM tests WHERE testname=? AND item_path != '' AND status IN ('FAIL','CHECK')), + SET fail_count=(SELECT count(id) FROM tests WHERE testname=? AND item_path != '' AND status IN ('FAIL','CHECK','INCOMPLETE','ABORT')), pass_count=(SELECT count(id) FROM tests WHERE testname=? AND item_path != '' AND status IN ('PASS','WARN','WAIVED')) WHERE testname=? AND item_path='';") ;; DONE '(top-test-set "UPDATE tests SET state=? WHERE testname=? AND item_path='';") ;; DONE '(top-test-set-running "UPDATE tests SET state='RUNNING' WHERE testname=? AND item_path='';") ;; DONE + + + ;; Might be the following top-test-set-per-pf-counts query could be better based off of something like this: + ;; + ;; select state,status,count(state) from tests where run_id=59 AND testname='runfirst' group by state,status; + ;; '(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 'INCOMPLETE' + WHEN (SELECT count(id) FROM tests WHERE testname=? AND item_path != '' AND status NOT IN ('TEN_STRIKES','BLOCKED') AND state in ('RUNNING','NOT_STARTED','LAUNCHED','REMOTEHOSTSTART')) > 0 THEN 'RUNNING' - ELSE 'COMPLETED' END, + WHEN (SELECT count(id) FROM tests + WHERE testname=? + AND item_path != '' + AND state != 'COMPLETED') = 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, status=CASE - WHEN (SELECT count(id) FROM tests - WHERE run_id=? AND testname=? - AND item_path != '' - AND state IN ('NOT_STARTED','BLOCKED')) > 0 THEN 'FAIL' WHEN fail_count > 0 THEN 'FAIL' - WHEN pass_count > 0 AND fail_count=0 THEN 'PASS' + WHEN (SELECT count(id) FROM tests + WHERE testname=? + AND item_path != '' + AND state IN ('BLOCKED','INCOMPLETE')) > 0 THEN 'FAIL' + WHEN (SELECT count(id) FROM tests + WHERE testname=? + AND item_path != '' + AND state NOT IN ('DELETED') + AND status = 'ABORT') > 0 THEN 'ABORT' + WHEN (SELECT count(id) FROM tests + WHERE testname=? + AND item_path != '' + AND state NOT IN ('DELETED') + AND status = 'AUTO') > 0 THEN 'AUTO' + WHEN (SELECT count(id) FROM tests + WHERE testname=? + AND item_path != '' + AND state NOT IN ('DELETED') + AND status IN ('STUCK/INCOMPLETE', 'INCOMPLETE')) > 0 THEN 'INCOMPLETE' + WHEN (SELECT count(id) FROM tests + WHERE testname=? + AND item_path != '' + AND state IN ('COMPLETED','STUCK/INCOMPLETE','INCOMPLETE') + AND status = 'FAIL') > 0 THEN 'FAIL' + WHEN (SELECT count(id) FROM tests + WHERE testname=? + AND item_path != '' + AND state NOT IN ('DELETED') + AND status = 'CHECK') > 0 THEN 'CHECK' + WHEN (SELECT count(id) FROM tests + WHERE testname=? + AND item_path != '' + AND state NOT IN ('DELETED') + AND status = 'SKIP') > 0 THEN 'SKIP' + WHEN (SELECT count(id) FROM tests + WHERE testname=? + AND item_path != '' + AND state NOT IN ('DELETED') + AND status = 'WARN') > 0 THEN 'WARN' + WHEN (SELECT count(id) FROM tests + WHERE testname=? + AND item_path != '' + AND state NOT IN ('DELETED') + AND status = 'WAIVED') > 0 THEN 'WAIVED' + WHEN (SELECT count(id) FROM tests + WHERE testname=? + AND item_path != '' + AND state NOT IN ('DELETED') + AND status NOT IN ('PASS','FAIL','WARN','WAIVED')) > 0 THEN 'ABORT' + WHEN (SELECT count(id) FROM tests + WHERE testname=? + AND item_path != '' + AND state='NOT_STARTED') > 0 THEN 'n/a' WHEN (SELECT count(id) FROM tests WHERE testname=? AND item_path != '' - AND status = 'SKIP') > 0 THEN 'SKIP' + AND state = 'COMPLETED' + AND status = 'PASS') > 0 THEN 'PASS' + WHEN pass_count > 0 AND fail_count=0 THEN 'PASS' ELSE 'UNKNOWN' END WHERE testname=? AND item_path='';") ;; DONE ;; STEPS '(delete-test-step-records "UPDATE test_steps SET status='DELETED' WHERE test_id=?;") @@ -2852,11 +3057,50 @@ stmtname) db:queries))) (if q (car q) #f)))) (db:delay-if-busy dbdat) (apply sqlite3:execute (db:dbdat-get-db dbdat) query params) - #t)) ;; BUG or Sillyness, why do I return #t instead of the query result? + #t)) + +;; get a summary of state and status counts to calculate a rollup +;; +;; NOTE: takes a db, not a dbstruct +;; +(define (db:get-state-status-summary db run-id testname) + (let ((res '())) + (sqlite3:for-each-row + (lambda (state status count) + (set! res (cons (vector state status count) res))) + db + "SELECT state,status,count(state) FROM tests WHERE run_id=? AND testname=? AND item_path='' GROUP BY state,status;" + run-id testname) + res)) + +(define (db:set-top-level-from-items dbstruct run-id testname) + (let* ((dbdat (db:get-db dbstruct run-id)) + (db (db:dbdat-get-db dbdat)) + (summ (db:get-state-status-summary db run-id testname)) + (find (lambda (state status) + (if (null? summ) + #f + (let loop ((hed (car summ)) + (tal (cdr summ))) + (if (and (string-match state (vector-ref hed 0)) + (string-match status (vector-ref hed 1))) + hed + (if (null? tal) + #f + (loop (car tal)(cdr tal))))))))) + + + ;;; E D I T M E ! ! + + + (cond + ((> (find "COMPLETED" ".*") 0) #f)))) + + ;; get the previous records for when these tests were run where all keys match but runname ;; NB// Merge this with test:get-previous-test-run-records? This one looks for all matching tests ;; can use wildcards. Also can likely be factored in with get test paths? ;; @@ -3037,11 +3281,11 @@ ;; Note: mode 'normal means that tests must be COMPLETED and ok (i.e. PASS, WARN, CHECK, SKIP or WAIVED) ;; mode 'toplevel means that tests must be COMPLETED only ;; mode 'itemmatch or 'itemwait means that tests items must be COMPLETED and (PASS|WARN|WAIVED|CHECK) [[ NB// NOT IMPLEMENTED YET ]] ;; ;; (define (db:get-prereqs-not-met dbstruct run-id waitons ref-item-path mode) -(define (db:get-prereqs-not-met dbstruct run-id waitons ref-item-path #!key (mode '(normal))(itemmap #f)) +(define (db:get-prereqs-not-met dbstruct run-id waitons ref-item-path mode itemmap) ;; #!key (mode '(normal))(itemmap #f)) (if (or (not waitons) (null? waitons)) '() (let* ((unmet-pre-reqs '()) (result '())) Index: docs/manual/Makefile ================================================================== --- docs/manual/Makefile +++ docs/manual/Makefile @@ -1,14 +1,29 @@ -all : server.pdf megatest_manual.html client.pdf + +ASCPATH = $(shell which asciidoc) +EXEPATH = $(shell realpath $(ASCPATH)) +BINPATH = $(shell dirname $(EXEPATH)) +DISPATH = $(shell dirname $(BINPATH)) + +# broad_goals.csv needed_features.csv : tables/*.dat +# ./refdb2csv tables + +# in a makefile recipe, $< denotes the first dependency; $@ the target + +# design_spec.html : $(SRCFILES) $(CSVFILES) +# 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 - asciidoc megatest_manual.txt - dos2unix megatest_manual.html - -server.pdf : server.dot - dot -Tpdf server.dot > server.pdf - -client.pdf : client.dot - dot -Tpdf client.dot > client.pdf + 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 + +client.ps : client.dot + dot -Tps client.dot > client.ps clean: rm -f megatest_manual.html Index: docs/manual/megatest_manual.html ================================================================== --- docs/manual/megatest_manual.html +++ docs/manual/megatest_manual.html @@ -1,1374 +1,1420 @@ - - - - - -The Megatest Users Manual - - - - - -
-
-

Preface

-
-

This book is organised as three sub-books; getting started, writing tests and reference.

-
-

Why Megatest?

-

The Megatest project was started for two reasons, the first was an -immediate and pressing need for a generalized tool to manage a suite -of regression tests and the second was the fact that the author had -written or maintained several such tools at different companies over -the years and it seemed a good thing to have a single open source -tool, flexible enough to meet the needs of any team doing continuous -integrating and or running a complex suite of tests for release -qualification.

-
-
-

Megatest Design Philosophy

-

Megatest is intended to provide the minimum needed resources to make -writing a suite of tests and tasks for implementing continuous build -for software, design engineering or process control (via owlfs for -example) without being specialized for any specific problem -space. Megatest in of itself does not know what constitutes a PASS or -FAIL of a test. In most cases megatest is best used in conjunction -with logpro or a similar tool to parse, analyze and decide on the test -outcome.

-
-
-

Megatest Architecture

-

All data to specify the tests and configure the system is stored in -plain text files. All system state is stored in an sqlite3 -database. Tests are launched using the launching system available for -the distributed compute platform in use. A template script is provided -which can launch jobs on local and remote Linux hosts. Currently -megatest uses the network filesystem to call home to your master -sqlite3 database.

-
-
-
-

Road Map

-

Note 1: This road-map is tentative and subject to change without notice.

-

Note 2: Starting over. Old plan is commented out.

-
-

Current Items

-
-
-

ww05 - migrate to inmem-db

-

Keep as much the same as possible. Add internal reference to almost -eliminate contention on db(s).

-
    -
  1. -

    -Add internal reference db -

    -
    2. -
  2. -

    -Verify that actions are accessing correct db -

    -
      -
    1. -

      --runtests - inmem -

      -
      2. -
    2. -

      --list-runs - local (but not megatest.db) -

      -
      3. -
    3. -

      -dashboard - local (but not megatest.db) -

      -
      4. -
    -
    3. -
  3. -

    -Mirror db to /var/tmp… -

    -
    4. -
  4. -

    -Dashboard read db from per-run db. -

    -
    5. -
  5. -

    -Dashboard read db from /var/tmp -

    -
    6. -
  6. -

    -Runs register in tasks table in monitor.db -

    -
    7. -
  7. -

    -Server polls tasks table for next action (in addition?) -

    -
    8. -
  8. -

    -Change run loop to execute in server, triggered by call to polling of tasks table -

    -
    9. -
-
-
-
-

Getting Started

-
-
Getting started with Megatest
-
-

How to install Megatest and set it up for running your regressions and continuous integration process.

-
-
-

Installation

-
-
-

Dependencies

-

Chicken scheme and a number of "eggs" are required for building -Megatest. See the script installall.sch in the utils directory of the -distribution for a mostly automated way to install everything needed -for building Megatest on Linux.

-


[An example footnote.]

-

And now for something completely different: monkeys, lions and -tigers (Bengal and Siberian) using the alternative syntax index -entries. - - - -Note that multi-entry terms generate separate index entries.

-

Here are a couple of image examples: an -images/smallnew.png - -example inline image followed by an example block image:

-
-
-Tiger image -
-
Figure 1. Tiger block image
-
-

Followed by an example table:

-
- - --- - - - - - - - - - - - - - - - -
Table 1. An example table
Option Description

-a USER GROUP

Add USER to GROUP.

-R GROUP

Disables access to GROUP.

-
-
-
Example 1. An example example
-
-

Lorum ipum…

-
-
-
-

Sub-section with Anchor

-

Sub-section at level 2.

-
-

Chapter Sub-section

-

Sub-section at level 3.

-
-
Chapter Sub-section
-

Sub-section at level 4.

-

This is the maximum sub-section depth supported by the distributed -AsciiDoc configuration. -
[A second example footnote.]

-
-
-
-
-
-
-

The Second Chapter

-
-

An example link to anchor at start of the first sub-section.

-

An example link to a bibliography entry [taoup].

-
-
-

Writing Tests

-
-

The First Chapter of the Second Part

-
-

Chapters grouped into book parts are at level 1 and can contain -sub-sections.

-
-
-

How To Do Things

-
-

Tricks

-
-

This section is a compendium of a various useful tricks for debugging, -configuring and generally getting the most out of Megatest.

-
-
-
-

Limiting your running jobs

-
-

The following example will limit a test in the jobgroup "group1" to no more than 10 tests simultaneously.

-

In your testconfig:

-
-
-
[test_meta]
-jobgroup group1
-
-

In your megatest.config:

-
-
-
[jobgroups]
-group1 10
-custdes 4
-
-
-
-
-

Debugging Tricks

-
-
-

Examining The Environment

-
-

During Config File Processing

-
-
-

Organising Your Tests and Tasks

-
-
-
[tests-paths]
-1 #{get misc parent}/simplerun/tests
-
-
-
-
[setup]
-
-

The runscript method is a brute force way to run scripts where the -user is responsible for setting STATE and STATUS

-
-
-
runscript main.csh
-
-
-
-
-

Debugging Server Problems

-
-
-
sudo lsof -i
-sudo netstat -lptu
-sudo netstat -tulpn
-
-
-
-
-

Reference

-
-

Config File Settings

-
-
-

Trim trailing spaces

-
-
-
[configf:settings trim-trailing-spaces yes]
-
-
-
-
-
-

The testconfig File

-
-
-

Setup section

-
-

Header

-
-
-
[setup]
-
-

The runscript method is a brute force way to run scripts where the -user is responsible for setting STATE and STATUS

-
-
-
runscript main.csh
-
-
-
-
-

Requirements section

-
-

Header

-
-
-
[requirements]
-
-
-
-

Wait on Other Tests

-
-
-
# A normal waiton waits for the prior tests to be COMPLETED
-# and PASS, CHECK or WAIVED
-waiton test1 test2
-
-
-
-

Mode

-

The default (i.e. if mode is not specified) is normal. All pre-dependent tests -must be COMPLETED and PASS, CHECK or WAIVED before the test will start

-
-
-
mode   normal
-
-

The toplevel mode requires only that the prior tests are COMPLETED.

-
-
-
mode toplevel
-
-

A item based waiton will start items in a test when the -same-named item is COMPLETED and PASS, CHECK or WAIVED -in the prior test

-
-
-
mode itemmatch
-
-
-
-
# With a toplevel test you may wish to generate your list
-# of tests to run dynamically
-#
-# waiton #{shell get-valid-tests-to-run.sh}
-
-
-
-

Run time limit

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

Skip

-
-
-

Header

-
-
-
[skip]
-
-
-
-

Skip on Still-running Tests

-
-
-
# NB// If the prevrunning line exists with *any* value the test will
-# automatically SKIP if the same-named test is currently RUNNING
-
-prevrunning x
-
-
-
-

Skip if a File Exists

-
-
-
fileexists /path/to/a/file # skip if /path/to/a/file exists
-
-
-
-

Controlled waiver propagation

-

If test is FAIL and previous test in run with same MT_TARGET is WAIVED then apply the following rules from the testconfig: -If a waiver check is specified in the testconfig apply the check and if it passes then set this FAIL to WAIVED

-

Waiver check has two parts, 1) a list of waiver, rulename, filepatterns and 2) the rulename script spec (note that "diff" and "logpro" are predefined)

-
-
-
###### EXAMPLE FROM testconfig #########
-# matching file(s) will be diff'd with previous run and logpro applied
-# if PASS or WARN result from logpro then WAIVER state is set
-#
-[waivers]
-# logpro_file    rulename      input_glob
-waiver_1         logpro        lookittmp.log
-
-[waiver_rules]
-
-# This builtin rule is the default if there is no <waivername>.logpro file
-# diff   diff %file1% %file2%
-
-# This builtin rule is applied if a <waivername>.logpro file exists
-# logpro diff %file1% %file2% | logpro %waivername%.logpro %waivername%.html
-
-
-
-
-

Ezsteps

-

To transfer the environment to the next step you can do the following:

-
-
-
$MT_MEGATEST -env2file .ezsteps/${stepname}
-
-
-
-

Triggers

-

In your testconfig triggers can be specified

-
-
-
[triggers]
-
-# Call script running.sh when test goes to state=RUNNING, status=PASS
-RUNNING/PASS running.sh
-
-# Call script running.sh any time state goes to RUNNING
-RUNNING/ running.sh
-
-# Call script onpass.sh any time status goes to PASS
-PASS/ onpass.sh
-
-

Scripts called will have; test-id test-rundir trigger, added to the commandline.

-

HINT

-

To start an xterm (useful for debugging), use a command line like the following:

-
-
-
[triggers]
-COMPLETED/ xterm -e bash -s --
-
-
- - - -
-
Note
-		There is a trailing space after the --
-
-
-
-
-
-

Programming API

-
-

These routines can be called from the megatest repl.

-
- - ----- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Table 2. API Server Management Calls
API Call Purpose comments Returns Comments

(rmt:login run-id)

Verify the the version, testsuite area etc. are correct.

#( #t "successful login" )

(rmt:start-server run-id)

#( success/fail n/a )

(rmt:kill-server run-id)

#( success/fail n/a )

Works only if the server is still reachable

-
-
- - ----- - - - - - - - - - - - - - - - - - - - - - - - -
Table 3. API Keys Related Calls
API Call Purpose comments Returns Comments

(rmt:get-key-val-pairs run-id)

#t=success/#f=fail

Works only if the server is still reachable

(rmt:get-keys run-id)

( key1 key2 … )

-
-
-

Megatest Internals

-
-
-server.png -
-
-
-
-
-
-

Appendix A: Example Appendix

-
-

One or more optional appendixes go here at section level zero.

-
-

Appendix Sub-section

-
- - - -
-
Note
-		Preface and appendix subsections start out of sequence at level -2 (level 1 is skipped). This only applies to multi-part book -documents.
-
-
-
-
-
-

Example Bibliography

-
-

The bibliography list is a style of AsciiDoc bulleted list.

-
    -
  • -

    -[taoup] Eric Steven Raymond. The Art of Unix - Programming. Addison-Wesley. ISBN 0-13-142901-9. -

    -
    • -
  • -

    -[walsh-muellner] Norman Walsh & Leonard Muellner. - DocBook - The Definitive Guide. O’Reilly & Associates. 1999. - ISBN 1-56592-580-7. -

    -
    • -
-
-
-
-

Example Glossary

-
-

Glossaries are optional. Glossaries entries are an example of a style -of AsciiDoc labeled lists.

-
-
-A glossary term -
-
-

- The corresponding (indented) definition. -

-
-
-A second glossary term -
-
-

- The corresponding (indented) definition. -

-
-
-
-
-
-

Example Colophon

-
-

Text at the end of a book describing facts about its production.

-
-
-
-

Example Index

-
-
-
-
-
- - - + + + + + +The Megatest Users Manual + + + + + +
+
+

Preface

+
+

This book is organised as three sub-books; getting started, writing tests and reference.

+
+

Why Megatest?

+

The Megatest project was started for two reasons, the first was an +immediate and pressing need for a generalized tool to manage a suite +of regression tests and the second was the fact that the author had +written or maintained several such tools at different companies over +the years and it seemed a good thing to have a single open source +tool, flexible enough to meet the needs of any team doing continuous +integrating and or running a complex suite of tests for release +qualification.

+
+
+

Megatest Design Philosophy

+

Megatest is intended to provide the minimum needed resources to make +writing a suite of tests and tasks for implementing continuous build +for software, design engineering or process control (via owlfs for +example) without being specialized for any specific problem +space. Megatest in of itself does not know what constitutes a PASS or +FAIL of a test. In most cases megatest is best used in conjunction +with logpro or a similar tool to parse, analyze and decide on the test +outcome.

+
+
+

Megatest Architecture

+

All data to specify the tests and configure the system is stored in +plain text files. All system state is stored in an sqlite3 +database. Tests are launched using the launching system available for +the distributed compute platform in use. A template script is provided +which can launch jobs on local and remote Linux hosts. Currently +megatest uses the network filesystem to call home to your master +sqlite3 database.

+
+
+
+

Road Map

+

Note 1: This road-map is tentative and subject to change without notice.

+

Note 2: Starting over. Old plan is commented out.

+
+

Current Items

+
+
+

ww05 - migrate to inmem-db

+

Keep as much the same as possible. Add internal reference to almost +eliminate contention on db(s).

+
    +
  1. +

    +Add internal reference db +

    +
    2. +
  2. +

    +Verify that actions are accessing correct db +

    +
      +
    1. +

      +-runtests - inmem +

      +
      2. +
    2. +

      +-list-runs - local (but not megatest.db) +

      +
      3. +
    3. +

      +dashboard - local (but not megatest.db) +

      +
      4. +
    +
    3. +
  3. +

    +Mirror db to /var/tmp… +

    +
    4. +
  4. +

    +Dashboard read db from per-run db. +

    +
    5. +
  5. +

    +Dashboard read db from /var/tmp +

    +
    6. +
  6. +

    +Runs register in tasks table in monitor.db +

    +
    7. +
  7. +

    +Server polls tasks table for next action (in addition?) +

    +
    8. +
  8. +

    +Change run loop to execute in server, triggered by call to polling of tasks table +

    +
    9. +
+
+
+
+

Getting Started

+
+
Getting started with Megatest
+
+

How to install Megatest and set it up for running your regressions and continuous integration process.

+
+
+

Installation

+
+
+

Dependencies

+

Chicken scheme and a number of "eggs" are required for building +Megatest. See the script installall.sch in the utils directory of the +distribution for a mostly automated way to install everything needed +for building Megatest on Linux.

+


[An example footnote.]

+

And now for something completely different: monkeys, lions and +tigers (Bengal and Siberian) using the alternative syntax index +entries. + + + +Note that multi-entry terms generate separate index entries.

+

Here are a couple of image examples: an +images/smallnew.png + +example inline image followed by an example block image:

+
+
+Tiger image +
+
Figure 1. Tiger block image
+
+

Followed by an example table:

+ + +++ + + + + + + + + + + + + + + + +
Table 1. An example table
Option Description

-a USER GROUP

Add USER to GROUP.

-R GROUP

Disables access to GROUP.

+
+
Example 1. An example example
+
+

Lorum ipum…

+
+
+
+

Sub-section with Anchor

+

Sub-section at level 2.

+
+

Chapter Sub-section

+

Sub-section at level 3.

+
+
Chapter Sub-section
+

Sub-section at level 4.

+

This is the maximum sub-section depth supported by the distributed +AsciiDoc configuration. +
[A second example footnote.]

+
+
+
+
+
+
+

The Second Chapter

+
+

An example link to anchor at start of the first sub-section.

+

An example link to a bibliography entry [taoup].

+
+
+

Writing Tests

+
+

The First Chapter of the Second Part

+
+

Chapters grouped into book parts are at level 1 and can contain +sub-sections.

+
+
+

How To Do Things

+
+

Tricks

+
+

This section is a compendium of a various useful tricks for debugging, +configuring and generally getting the most out of Megatest.

+
+
+
+

Limiting your running jobs

+
+

The following example will limit a test in the jobgroup "group1" to no more than 10 tests simultaneously.

+

In your testconfig:

+
+
+
[test_meta]
+jobgroup group1
+
+

In your megatest.config:

+
+
+
[jobgroups]
+group1 10
+custdes 4
+
+
+
+
+

Debugging Tricks

+
+
+

Examining The Environment

+
+

During Config File Processing

+
+
+

Organising Your Tests and Tasks

+
+
+
[tests-paths]
+1 #{get misc parent}/simplerun/tests
+
+
+
+
[setup]
+
+

The runscript method is a brute force way to run scripts where the +user is responsible for setting STATE and STATUS

+
+
+
runscript main.csh
+
+
+
+
+

Debugging Server Problems

+
+
+
sudo lsof -i
+sudo netstat -lptu
+sudo netstat -tulpn
+
+
+
+
+

Reference

+
+

Config File Settings

+
+
+

Trim trailing spaces

+
+
+
[configf:settings trim-trailing-spaces yes]
+
+
+
+
+
+

The testconfig File

+
+
+

Setup section

+
+

Header

+
+
+
[setup]
+
+

The runscript method is a brute force way to run scripts where the +user is responsible for setting STATE and STATUS

+
+
+
runscript main.csh
+
+
+
+
+

Requirements section

+
+

Header

+
+
+
[requirements]
+
+
+
+

Wait on Other Tests

+
+
+
# A normal waiton waits for the prior tests to be COMPLETED
+# and PASS, CHECK or WAIVED
+waiton test1 test2
+
+
+
+

Mode

+

The default (i.e. if mode is not specified) is normal. All pre-dependent tests +must be COMPLETED and PASS, CHECK or WAIVED before the test will start

+
+
+
mode   normal
+
+

The toplevel mode requires only that the prior tests are COMPLETED.

+
+
+
mode toplevel
+
+

A item based waiton will start items in a test when the +same-named item is COMPLETED and PASS, CHECK or WAIVED +in the prior test

+
+
+
mode itemmatch
+
+
+
+
# With a toplevel test you may wish to generate your list
+# of tests to run dynamically
+#
+# waiton #{shell get-valid-tests-to-run.sh}
+
+
+
+

Run time limit

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

Skip

+
+
+

Header

+
+
+
[skip]
+
+
+
+

Skip on Still-running Tests

+
+
+
# NB// If the prevrunning line exists with *any* value the test will
+# automatically SKIP if the same-named test is currently RUNNING
+
+prevrunning x
+
+
+
+

Skip if a File Exists

+
+
+
fileexists /path/to/a/file # skip if /path/to/a/file exists
+
+
+
+

Controlled waiver propagation

+

If test is FAIL and previous test in run with same MT_TARGET is WAIVED then apply the following rules from the testconfig: +If a waiver check is specified in the testconfig apply the check and if it passes then set this FAIL to WAIVED

+

Waiver check has two parts, 1) a list of waiver, rulename, filepatterns and 2) the rulename script spec (note that "diff" and "logpro" are predefined)

+
+
+
###### EXAMPLE FROM testconfig #########
+# matching file(s) will be diff'd with previous run and logpro applied
+# if PASS or WARN result from logpro then WAIVER state is set
+#
+[waivers]
+# logpro_file    rulename      input_glob
+waiver_1         logpro        lookittmp.log
+
+[waiver_rules]
+
+# This builtin rule is the default if there is no <waivername>.logpro file
+# diff   diff %file1% %file2%
+
+# This builtin rule is applied if a <waivername>.logpro file exists
+# logpro diff %file1% %file2% | logpro %waivername%.logpro %waivername%.html
+
+
+
+
+

Ezsteps

+

To transfer the environment to the next step you can do the following:

+
+
+
$MT_MEGATEST -env2file .ezsteps/${stepname}
+
+
+
+

Triggers

+

In your testconfig triggers can be specified

+
+
+
[triggers]
+
+# Call script running.sh when test goes to state=RUNNING, status=PASS
+RUNNING/PASS running.sh
+
+# Call script running.sh any time state goes to RUNNING
+RUNNING/ running.sh
+
+# Call script onpass.sh any time status goes to PASS
+PASS/ onpass.sh
+
+

Scripts called will have; test-id test-rundir trigger, added to the commandline.

+

HINT

+

To start an xterm (useful for debugging), use a command line like the following:

+
+
+
[triggers]
+COMPLETED/ xterm -e bash -s --
+
+
+ + + +
+Note +There is a trailing space after the --
+
+
+
+

Override the Toplevel HTML File

+

Megatest generates a simple html file summary for top level tests of +iterated tests. The generation can be overridden.

+
+
For test "runfirst" override the toplevel generation with a script "mysummary.sh"
+
+
# Override the rollup for specific tests
+[testrollup]
+runfirst mysummary.sh
+
+
+
+
+
+

Programming API

+
+

These routines can be called from the megatest repl.

+ + +++++ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
Table 2. API Server Management Calls
API Call Purpose comments Returns Comments

(rmt:login run-id)

Verify the the version, testsuite area etc. are correct.

#( #t "successful login" )

(rmt:start-server run-id)

#( success/fail n/a )

(rmt:kill-server run-id)

#( success/fail n/a )

Works only if the server is still reachable

+ + +++++ + + + + + + + + + + + + + + + + + + + + + + + +
Table 3. API Keys Related Calls
API Call Purpose comments Returns Comments

(rmt:get-key-val-pairs run-id)

#t=success/#f=fail

Works only if the server is still reachable

(rmt:get-keys run-id)

( key1 key2 … )

+
+

Megatest Internals

+
+
+server.png +
+
+
+
+
+
+

Appendix A: Example Appendix

+
+

One or more optional appendixes go here at section level zero.

+
+

Appendix Sub-section

+
+ + + +
+Note +Preface and appendix subsections start out of sequence at level +2 (level 1 is skipped). This only applies to multi-part book +documents.
+
+
+
+
+
+

Example Bibliography

+
+

The bibliography list is a style of AsciiDoc bulleted list.

+
    +
  • +

    +[taoup] Eric Steven Raymond. The Art of Unix + Programming. Addison-Wesley. ISBN 0-13-142901-9. +

    +
    • +
  • +

    +[walsh-muellner] Norman Walsh & Leonard Muellner. + DocBook - The Definitive Guide. O’Reilly & Associates. 1999. + ISBN 1-56592-580-7. +

    +
    • +
+
+
+
+

Example Glossary

+
+

Glossaries are optional. Glossaries entries are an example of a style +of AsciiDoc labeled lists.

+
+
+A glossary term +
+
+

+ The corresponding (indented) definition. +

+
+
+A second glossary term +
+
+

+ The corresponding (indented) definition. +

+
+
+
+
+
+

Example Colophon

+
+

Text at the end of a book describing facts about its production.

+
+
+
+

Example Index

+
+
+
+
+
+ + + Index: docs/manual/reference.txt ================================================================== --- docs/manual/reference.txt +++ docs/manual/reference.txt @@ -183,10 +183,24 @@ COMPLETED/ xterm -e bash -s -- ----------------- NOTE: There is a trailing space after the -- + +Override the Toplevel HTML File +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Megatest generates a simple html file summary for top level tests of +iterated tests. The generation can be overridden. + +.For test "runfirst" override the toplevel generation with a script "mysummary.sh" +----------------- +# Override the rollup for specific tests +[testrollup] +runfirst mysummary.sh +----------------- + Programming API --------------- These routines can be called from the megatest repl. DELETED docs/manual/server.pdf Index: docs/manual/server.pdf ================================================================== --- docs/manual/server.pdf +++ /dev/null cannot compute difference between binary files Index: docs/manual/server.png ================================================================== --- docs/manual/server.png +++ docs/manual/server.png cannot compute difference between binary files Index: http-transport.scm ================================================================== --- http-transport.scm +++ http-transport.scm @@ -47,23 +47,10 @@ ;; Call this to start the actual server ;; (define *db:process-queue-mutex* (make-mutex)) -(define (server:get-best-guess-address hostname) - (let ((res #f)) - (for-each - (lambda (adr) - (if (not (eq? (u8vector-ref adr 0) 127)) - (set! res adr))) - ;; NOTE: This can fail when there is no mention of the host in /etc/hosts. FIXME - (vector->list (hostinfo-addresses (hostname->hostinfo hostname)))) - (string-intersperse - (map number->string - (u8vector->list - (if res res (hostname->ip hostname)))) "."))) - (define (http-transport:run hostn run-id server-id) (debug:print 2 "Attempting to start the server ...") (let* ((db #f) ;; (open-db)) ;; we don't want the server to be opening and closing the db unnecesarily (hostname (get-host-name)) (ipaddrstr (let ((ipstr (if (string=? "-" hostn) @@ -422,11 +409,11 @@ (debug:print 0 "ERROR: error from sync code other than 'sync-failed. Attempting to gracefully shutdown the server") (tasks:server-delete-record (db:delay-if-busy tdbdat) server-id " http-transport:keep-running crashed") (exit))) (set! sync-time (- (current-milliseconds) start-time)) (set! rem-time (quotient (- 4000 sync-time) 1000)) - (debug:print 2 "SYNC: time= " sync-time ", rem-time=" rem-time) + (debug:print 4 "SYNC: time= " sync-time ", rem-time=" rem-time) (if (and (<= rem-time 4) (> rem-time 0)) (thread-sleep! rem-time) (thread-sleep! 4))) ;; fallback for if the math is changed ... Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -322,11 +322,11 @@ ;; force RUNNING/n/a ;; (thread-sleep! 0.3) (tests:test-force-state-status! run-id test-id "RUNNING" "n/a") - (rmt:roll-up-pass-fail-counts run-id test-name item-path "RUNNING") + (rmt:roll-up-pass-fail-counts run-id test-name item-path #f "RUNNING") ;; (thread-sleep! 0.3) ;; NFS slowness has caused grief here ;; if there is a runscript do it first (if fullrunscript (let ((pid (process-run fullrunscript))) @@ -848,11 +848,11 @@ (runs:remove-test-directory testinfo 'remove-data-only))) ;; remove data only, do not perturb the record ;; prevent overlapping actions - set to LAUNCHED as early as possible ;; (tests:test-set-status! run-id test-id "LAUNCHED" "n/a" #f #f) ;; (if launch-results launch-results "FAILED")) - (rmt:roll-up-pass-fail-counts run-id test-name item-path "LAUNCHED") + (rmt:roll-up-pass-fail-counts run-id test-name item-path #f "LAUNCHED") (set! diskpath (get-best-disk *configdat*)) (if diskpath (let ((dat (create-work-area run-id run-info keyvals test-id test-path diskpath test-name itemdat))) (set! work-area (car dat)) (set! toptest-work-area (cadr dat)) ADDED loadwatch/Makefile Index: loadwatch/Makefile ================================================================== --- /dev/null +++ loadwatch/Makefile @@ -0,0 +1,11 @@ + +all : launch-many queuefeeder queuefeeder-server + +launch-many : launch-many.scm + csc launch-many.scm + +queuefeeder : queuefeeder.scm + csc queuefeeder.scm + +queuefeeder-server : queuefeeder-server.scm + csc queuefeeder-server.scm ADDED loadwatch/bjob-count.sh Index: loadwatch/bjob-count.sh ================================================================== --- /dev/null +++ loadwatch/bjob-count.sh @@ -0,0 +1,3 @@ +#!/bin/bash + +bqueues | grep normal |awk '{print $8}' ADDED loadwatch/launch-many.scm Index: loadwatch/launch-many.scm ================================================================== --- /dev/null +++ loadwatch/launch-many.scm @@ -0,0 +1,9 @@ +(use posix) + +(let loop ((count 0)) + (if (> count 500000) + (print "DONE") + (let ((cmd (conc "./queuefeeder xena:22022 bsub ./testopenlava.sh " count " " (random 30)))) + (print "Running: " cmd) + (system cmd) + (loop (+ count 1))))) ADDED loadwatch/loadwatch.scm Index: loadwatch/loadwatch.scm ================================================================== --- /dev/null +++ loadwatch/loadwatch.scm @@ -0,0 +1,86 @@ +(use regex srfi-69) + +(define-record processdat + %cpu + virt + res + %mem + count + ) + +(define (pp-processdat dat) + (print "(processdat" + " %cpu=" (processdat-%cpu dat) + " virt=" (processdat-virt dat) + " res=" (processdat-res dat) + " %mem=" (processdat-%mem dat) + " count=" (processdat-count dat))) + + +(define nrex (regexp "^(\\d+[\\d\\.]*)([mkgMKG])$")) + +(define (get-number numstr) + (let ((n (string->number numstr))) + (if n + n + (let ((nmatch (string-match nrex numstr))) + (if nmatch + (* (string->number (cadr nmatch)) + (case (string->symbol (caddr nmatch)) + ((k) 1024) + ((m) 1048576) + ((g) 1073741824) + (else + (print "ERROR: Unrecognised unit: " (caddr nmatch) ", extracted for " numstr) + 1))) + #f))))) + + +(define (snagload) + (let ((dat (make-hash-table)) ;; user => hash-of-processdat + (hdr (regexp "^\\s+PID")) + (rx (regexp "\\s+")) + (wht (regexp "^\\s+")) + ) + (with-input-from-pipe + "top -n 1 -b" + (lambda () + (let loop ((inl (read-line)) + (inbod #f)) + (if (eof-object? inl) + dat + (if (not inbod) + (if (string-search hdr inl) + (loop (read-line) #t) + (loop (read-line) #f)) + (let* ((lparts (map (lambda (x) + (let ((num (get-number x))) + (if num num x))) + (string-split-fields rx (string-substitute wht "" inl) #:infix)))) + (if (> (length lparts) 10) + (let* ((user (list-ref lparts 1)) + (virt (list-ref lparts 4)) + (res (list-ref lparts 5)) + (%cpu (list-ref lparts 8)) + (%mem (list-ref lparts 9)) + (time (list-ref lparts 10)) + (pname (list-ref lparts 11)) + (udat (or (hash-table-ref/default dat user #f) + (let ((u (make-hash-table))) + (hash-table-set! dat user u) + u))) + (pdat (or (hash-table-ref/default udat pname #f) + (let ((p (make-processdat 0 0 0 0 0))) + (hash-table-set! udat pname p) + p)))) + (print "User: " user ", pname: " pname ", virt: " virt ", res: " res ", %cpu: " %cpu ", %mem: " %mem) + (processdat-%cpu-set! pdat (+ (processdat-%cpu pdat) %cpu)) + (processdat-%mem-set! pdat (+ (processdat-%mem pdat) %mem)) + (processdat-virt-set! pdat (+ (processdat-virt pdat) virt)) + (processdat-res-set! pdat (+ (processdat-res pdat) res)) + (processdat-count-set! pdat (+ (processdat-count pdat) 1)) + (loop (read-line) inbod)) + dat))))))))) + +(define x (snagload)) +;; (processdat-%cpu (hash-table-ref (hash-table-ref x "matt") "evolution-calen")) ADDED loadwatch/queuefeeder-server.scm Index: loadwatch/queuefeeder-server.scm ================================================================== --- /dev/null +++ loadwatch/queuefeeder-server.scm @@ -0,0 +1,185 @@ +;;====================================================================== +;; Copyright 2015-2015, Matthew Welland. +;; +;; This program is made available under the GNU GPL version 2.0 or +;; greater. See the accompanying file COPYING for details. +;; +;; This program is distributed WITHOUT ANY WARRANTY; without even the +;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR +;; PURPOSE. +;;====================================================================== + +;; Queue Feeder. Use a crude droop curve to limit feeding jobs into a queue +;; to prevent slamming the queue + +;;====================================================================== +;; Methodology +;; +;; Connect to the server, the server delays the appropriate time (if +;; any) and then launch the task. +;; + +(use nanomsg posix regex) + +;; (use trace) +;; (trace nn-bind nn-socket nn-assert nn-recv nn-send thread-terminate! nn-close ) + +(define port 22022) + +;; get needed stuff from commandline +;; +(define queuelen #f) +(define cmd '()) ;; cmd is run to give a count of the queue length => returns number in queue + +(define usage "Usage: queuefeeder-server port target_queue_length command + where command is a script or program that gives an integer on stdout of current queue length") + +(let ((args (argv))) + (if (> (length args) 3) + (begin + (set! port (cadr args)) + (set! queuelen (string->number (caddr args))) + (set! cmd (cadddr args))) ;; no params supported + (begin + (print usage) + (exit)))) + +(if (not queuelen) + (begin + (print "queuelen must be a number") + (print usage) + (exit))) + +(print "Running queue feeder with port=" port ", command=" cmd) + +(define rep (nn-socket 'rep)) + +(print "connecting, got: " (nn-bind rep (conc "tcp://" "*" ":" port))) + +(define *current-delay* 0) +(define (exp-droop-calc x targ) + (cond + ((> (- x targ) 1) 136) ;; top off at 136 seconds + (else + (let ((res (* 50 (exp (- x targ))))) + (cond + ((and (> res 0)(< res 0.01)) 0.01) + ((> res 45) 45) ;; cap at 45 seconds + (else res)))))) + +;; x input value (current number in the queue) +;; targ is the desired queue length +;; +(define (piecewise-droop-calc x targ) + (let ((top 50)) + (cond + ((> (- x targ) 0) + top) ;; top off at top seconds + ((> x (- targ top)) + (+ (* 1 (- x (- targ top))) + (/ (- top targ) targ))) + (else (let ((res (/ x targ))) + (if (< res 0.01) + 0.01 + res)))))) + +(define (server soc) + (print "server starting") + (let loop ((msg-in (nn-recv soc)) + (count 0)) + (if (eq? 0 (modulo count 1000)) + (print "server received: " msg-in ", count=" count)) + (cond + ((equal? msg-in "quit") + (nn-send soc "Ok, quitting")) + ((and (>= (string-length msg-in) 4) + (equal? (substring msg-in 0 4) "ping")) + (nn-send soc (conc (current-process-id))) + (loop (nn-recv soc)(+ count 1))) + (else + (mutex-lock! *current-delay-mutex*) + (let ((current-delay *current-delay*)) + (mutex-unlock! *current-delay-mutex*) + ;; (thread-sleep! current-delay) + (nn-send soc (conc current-delay " hello " msg-in " you waited " current-delay " seconds")) + (loop (nn-recv soc)(if (> count 20000000) + 0 + (+ count 1)))))))) + +(define (ping-self host port #!key (return-socket #t)) + ;; send a random number along with pid and check that we get it back + (let* ((req (nn-socket 'req)) + (key "ping") + (success #f) + (keepwaiting #t) + (ping (make-thread + (lambda () + (print "ping: sending string \"" key "\", expecting " (current-process-id)) + (nn-send req key) + (let ((result (nn-recv req))) + (if (equal? (conc (current-process-id)) result) + (begin + (print "ping, success: received \"" result "\"") + (set! success #t)) + (begin + (print "ping, failed: received key \"" result "\"") + (set! keepwaiting #f) + (set! success #f))))) + "ping")) + (timeout (make-thread (lambda () + (let loop ((count 0)) + (thread-sleep! 1) + (print "still waiting after " count " seconds...") + (if (and keepwaiting (< count 10)) + (loop (+ count 1)))) + (if keepwaiting + (begin + (print "timeout waiting for ping") + (thread-terminate! ping)))) + "timeout"))) + (nn-connect req (conc "tcp://" host ":" port)) + (handle-exceptions + exn + (begin + (print-call-chain) + (print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) + (print "exn=" (condition->list exn)) + (print "ping failed to connect to " host ":" port)) + (thread-start! timeout) + (thread-start! ping) + (thread-join! ping) + (if success (thread-terminate! timeout))) + (if return-socket + (if success req #f) + (begin + (nn-close req) + success)))) + +(define *current-delay-mutex* (make-mutex)) + +;; update the *current-delay* value every minute or QUEUE_CHK_DELAY seconds +(thread-start! (make-thread (lambda () + (let ((delay-time (string->number (or (get-environment-variable "QUEUE_CHK_DELAY") "30")))) + (let loop () + (with-input-from-pipe + cmd ;;; my query to get queue length + (lambda () + (let* ((val (read)) + (droop-val (if (number? val)(piecewise-droop-calc val queuelen) #f))) + ;; val is number of jobs in queue. Use a linear droop of val/40 + (mutex-lock! *current-delay-mutex*) + (set! *current-delay* (or droop-val 30)) ;; (/ (or droop-val 100) 50)) + (mutex-unlock! *current-delay-mutex*) + (print "droop-val=" droop-val) + (thread-sleep! delay-time)))) + (loop)))))) + +(let ((server-thread (make-thread (lambda ()(server rep)) "server"))) + (thread-start! server-thread) + (if (ping-self (get-host-name) port) + (begin + (thread-join! server-thread) + (nn-close rep)) + (print "ping failed"))) + +(exit) ADDED loadwatch/queuefeeder.scm Index: loadwatch/queuefeeder.scm ================================================================== --- /dev/null +++ loadwatch/queuefeeder.scm @@ -0,0 +1,96 @@ +;;====================================================================== +;; Copyright 2015-2015, Matthew Welland. +;; +;; This program is made available under the GNU GPL version 2.0 or +;; greater. See the accompanying file COPYING for details. +;; +;; This program is distributed WITHOUT ANY WARRANTY; without even the +;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR +;; PURPOSE. +;;====================================================================== + +;; Queue Feeder. Use a crude droop curve to limit feeding jobs into a queue +;; to prevent slamming the queue + +;;====================================================================== +;; Methodology +;; +;; Connect to the server, the server delays the appropriate time (if +;; any) and then launch the task. +;; +(use nanomsg posix regex message-digest md5) + +(define req (nn-socket 'req)) + +;; get needed stuff from commandline +;; +(define hostport #f) +(define cmd '()) + +(let ((args (argv))) + (if (> (length args) 2) + (begin + (set! hostport (cadr args)) + (set! cmd (cddr args))) + (begin + (print "Usage: queuefeeder host:port command params ....") + (exit)))) + +(nn-connect req (conc "tcp://" hostport)) ;; xena:22022") + +(define (client-send-receive soc msg) + (nn-send soc msg) + (nn-recv soc)) + +;; Generate a unique signature for this client location +;; +(define (make-signature) + (message-digest-string (md5-primitive) + (with-output-to-string + (lambda () + (write (current-directory)))))) + +;; (define ((talk-to-server soc)) +;; (let loop ((cnt 200000)) +;; (let ((name (list-ref '("Matt" "Tom" "Bob" "Jill" "James" "Jane")(random 6)))) +;; ;; (print "Sending " name) +;; ;; (print +;; (client-send-receive req name) ;; ) +;; (if (> cnt 0)(loop (- cnt 1))))) +;; (print (client-send-receive req "quit")) +;; (nn-close req) +;; (exit)) +;; + +(define (get-delay signature) + (let* ((full-msg (client-send-receive req (conc (current-user-name) "@" (get-host-name) ":" signature)))) + (print "Got " full-msg) + (let* ((reply-msg (string-match "^([\\d\\.]+)\\s+(.*)$" full-msg)) + (delay-time (if (> (length reply-msg) 2) + (string->number (cadr reply-msg)) + 1)) ;; fall back to one sec delay + (msg (if (> (length reply-msg) 2) + (caddr reply-msg) + full-msg))) + (values delay-time msg)))) + + +(let ((signature (make-signature))) + + (thread-start! (lambda () + (thread-sleep! 60) + (print "Give up on waiting for the server") + ;; (nn-close req) + ;; (exit) + )) + (thread-join! (thread-start! (lambda () + (let-values + (((delay-time msg)(get-delay signature))) + (print "INFO: sleeping " delay-time " seconds per request of queuefeeder server") + (thread-sleep! delay-time) + (print "INFO: done waiting, now executing requested task."))))) + (nn-close req)) + +(process-execute (car cmd) (cdr cmd)) + + ADDED loadwatch/testopenlava.sh Index: loadwatch/testopenlava.sh ================================================================== --- /dev/null +++ loadwatch/testopenlava.sh @@ -0,0 +1,9 @@ +#!/bin/bash + +job_order=$1 +job_length=$2 + +echo "START: $job_order" > $job_order.log +sleep $job_length +echo "END: $job_order" >> $job_order.log + 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.6012) +(define megatest-version 1.6018) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -7,10 +7,14 @@ ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. ;; (include "common.scm") ;; (include "megatest-version.scm") + +(define (toplevel-command . a) #f) + +(define (toplevel-command . a) #f) ;; fake out readline usage of toplevel-command (define (toplevel-command . a) #f) (use sqlite3 srfi-1 posix regex regex-case srfi-69 base64 readline apropos json http-client directory-utils rpc ;; (srfi 18) extras) @@ -68,13 +72,11 @@ Usage: megatest [options] -h : this help -version : print megatest version (currently " megatest-version ") Launching and managing runs - -runall : run all tests that are not state COMPLETED and status PASS, - CHECK or KILLED - -runtests tst1,tst2 ... : run tests + -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) -lock : lock run specified by target and runname @@ -127,10 +129,12 @@ -show-runconfig : dump the internal representation of the runconfigs.config file -dumpmode json : dump in json format instead of sexpr -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 Misc -start-dir path : switch to this directory before running megatest -rebuild-db : bring the database schema up to date -cleanup-db : remove any orphan records, vacuum the db @@ -243,10 +247,12 @@ "-ping" "-refdb2dat" "-o" "-log" "-archive" + "-since" + "-fields" ) (list "-h" "-help" "--help" "-version" "-force" "-xterm" @@ -276,11 +282,12 @@ "-get-run-status" ;; queries "-test-paths" ;; get path(s) to a test, ordered by youngest first - "-runall" ;; run all tests + "-runall" ;; run all tests, respects -testpatt + "-run" ;; alias for -runall "-remove-runs" "-rebuild-db" "-cleanup-db" "-rollup" "-update-meta" @@ -304,53 +311,56 @@ (define *time-zero* (current-seconds)) (define *watchdog* (make-thread (lambda () (thread-sleep! 0.05) ;; delay for startup - (let ((legacy-sync (configf:lookup *configdat* "setup" "megatest-db")) + (let ((legacy-sync (common:legacy-sync-required)) (debug-mode (debug:debug-mode 1)) (last-time (current-seconds))) - (let loop () - ;; sync for filesystem local db writes - ;; - (let ((start-time (current-seconds)) - (servers-started (make-hash-table))) - (for-each - (lambda (run-id) - (mutex-lock! *db-multi-sync-mutex*) - (if (and legacy-sync - (hash-table-ref/default *db-local-sync* run-id #f)) - ;; (if (> (- start-time last-write) 5) ;; every five seconds - (begin ;; let ((sync-time (- (current-seconds) start-time))) - (db:multi-db-sync (list run-id) 'new2old) - (if (common:low-noise-print 30 "sync new to old") - (let ((sync-time (- (current-seconds) start-time))) - (debug:print-info 0 "Sync of newdb to olddb for run-id " run-id " completed in " sync-time " seconds"))) - ;; (if (> sync-time 10) ;; took more than ten seconds, start a server for this run - ;; (begin - ;; (debug:print-info 0 "Sync is taking a long time, start up a server to assist for run " run-id) - ;; (server:kind-run run-id))))) - (hash-table-delete! *db-local-sync* run-id))) - (mutex-unlock! *db-multi-sync-mutex*)) - (hash-table-keys *db-local-sync*)) - (if (and debug-mode - (> (- start-time last-time) 60)) - (begin - (set! last-time start-time) - (debug:print-info 4 "timestamp -> " (seconds->time-string (current-seconds)) ", time since start -> " (seconds->hr-min-sec (- (current-seconds) *time-zero*)))))) - - ;; keep going unless time to exit - ;; - (if (not *time-to-exit*) - (let delay-loop ((count 0)) - (if (and (not *time-to-exit*) - (< count 11)) ;; aprox 5-6 seconds - (begin - (thread-sleep! 1) - (delay-loop (+ count 1)))) - (loop)))))) - "Watchdog thread")) + (if (common:legacy-sync-recommended) + (let loop () + ;; sync for filesystem local db writes + ;; + (let ((start-time (current-seconds)) + (servers-started (make-hash-table))) + (for-each + (lambda (run-id) + (mutex-lock! *db-multi-sync-mutex*) + (if (and legacy-sync + (hash-table-ref/default *db-local-sync* run-id #f)) + ;; (if (> (- start-time last-write) 5) ;; every five seconds + (begin ;; let ((sync-time (- (current-seconds) start-time))) + (db:multi-db-sync (list run-id) 'new2old) + (if (common:low-noise-print 30 "sync new to old") + (let ((sync-time (- (current-seconds) start-time))) + (debug:print-info 0 "Sync of newdb to olddb for run-id " run-id " completed in " sync-time " seconds"))) + ;; (if (> sync-time 10) ;; took more than ten seconds, start a server for this run + ;; (begin + ;; (debug:print-info 0 "Sync is taking a long time, start up a server to assist for run " run-id) + ;; (server:kind-run run-id))))) + (hash-table-delete! *db-local-sync* run-id))) + (mutex-unlock! *db-multi-sync-mutex*)) + (hash-table-keys *db-local-sync*)) + (if (and debug-mode + (> (- start-time last-time) 60)) + (begin + (set! last-time start-time) + (debug:print-info 4 "timestamp -> " (seconds->time-string (current-seconds)) ", time since start -> " (seconds->hr-min-sec (- (current-seconds) *time-zero*)))))) + + ;; keep going unless time to exit + ;; + (if (not *time-to-exit*) + (let delay-loop ((count 0)) + (if (and (not *time-to-exit*) + (< count 11)) ;; aprox 5-6 seconds + (begin + (thread-sleep! 1) + (delay-loop (+ count 1)))) + (loop))) + (if (common:low-noise-print 30) + (debug:print-info 0 "Exiting watchdog timer, *time-to-exit* = " *time-to-exit*))))) + "Watchdog thread"))) (thread-start! *watchdog*) (if (args:get-arg "-log") (let ((oup (open-output-file (args:get-arg "-log")))) @@ -734,14 +744,20 @@ ;;====================================================================== (if (args:get-arg "-list-targets") (let ((targets (common:get-runconfig-targets))) (print "Found "(length targets) " targets") - (for-each (lambda (x) - ;; (print "[" x "]")) - (print x)) - targets) + (case (string->symbol (or (args:get-arg "-dumpmode") "alist")) + ((alist) + (for-each (lambda (x) + ;; (print "[" x "]")) + (print x)) + targets)) + ((json) + (json-write targets)) + (else + (debug:print 0 "ERROR: dump output format " (args:get-arg "-dumpmode") " not supported for -list-targets"))) (set! *didsomething* #t))) (define (full-runconfigs-read) (let* ((keys (rmt:get-keys)) (target (common:args-get-target)) @@ -768,11 +784,11 @@ (let ((val (configf:lookup data (args:get-arg "-section")(args:get-arg "-var")))) (if val (print val)))) ((not (args:get-arg "-dumpmode")) (pp (hash-table->alist data))) ((string=? (args:get-arg "-dumpmode") "json") - (json-write data)) + (json-write data)) (else (debug:print 0 "ERROR: -dumpmode of " (args:get-arg "-dumpmode") " not recognised"))) (set! *didsomething* #t)) (pop-directory))) @@ -794,12 +810,12 @@ (debug:print 0 "ERROR: -dumpmode of " (args:get-arg "-dumpmode") " not recognised"))) (set! *didsomething* #t) (pop-directory))) (if (args:get-arg "-show-cmdinfo") - (if (getenv "MT_CMDINFO") - (let ((data (common:read-encoded-string (getenv "MT_CMDINFO")))) + (if (or (args:get-arg ":value")(getenv "MT_CMDINFO")) + (let ((data (common:read-encoded-string (or (args:get-arg ":value")(getenv "MT_CMDINFO"))))) (if (equal? (args:get-arg "-dumpmode") "json") (json-write data) (pp data)) (set! *didsomething* #t)) (debug:print-info 0 "environment variable MT_CMDINFO is not set"))) @@ -859,11 +875,11 @@ "-set-run-status" "set run status" (lambda (target runname keys keyvals) (let* ((runsdat (rmt:get-runs-by-patt keys runname (common:args-get-target) - #f #f)) + #f #f #f)) (header (vector-ref runsdat 0)) (rows (vector-ref runsdat 1))) (if (null? rows) (begin (debug:print-info 0 "No matching run found.") @@ -876,32 +892,96 @@ ))))))) ;;====================================================================== ;; Query runs ;;====================================================================== + +;; -fields runs:id,target,runname,comment+tests:id,testname,item_path+steps +;; +;; csi> (extract-fields-constraints "runs:id,target,runname,comment+tests:id,testname,item_path+steps") +;; => (("runs" "id" "target" "runname" "comment") ("tests" "id" "testname" "item_path") ("steps")) +;; +;; NOTE: remember that the cdr will be the list you expect (cdr ("runs" "id" "target" "runname" "comment")) => ("id" "target" "runname" "comment") +;; and so alist-ref will yield what you expect +;; +(define (extract-fields-constraints fields-spec) + (map (lambda (table-spec) ;; runs:id,target,runname + (let ((dat (string-split table-spec ":"))) ;; ("runs" "id,target,runname") + (if (> (length dat) 1) + (cons (car dat)(string-split (cadr dat) ",")) ;; "id,target,runname" + dat))) + (string-split fields-spec "+"))) + +(define (get-value-by-fieldname datavec test-field-index fieldname) + (let ((indx (hash-table-ref/default test-field-index fieldname #f))) + (if indx + (if (>= indx (vector-length datavec)) + #f ;; index to high, should raise an error I suppose + (vector-ref datavec indx)) + #f))) ;; NOTE: list-runs and list-db-targets operate on local db!!! ;; (if (or (args:get-arg "-list-runs") (args:get-arg "-list-db-targets")) (if (launch:setup-for-run) - (let* ((dbstruct (make-dbr:dbstruct path: *toppath* local: #t)) - (runpatt (args:get-arg "-list-runs")) - (testpatt (if (args:get-arg "-testpatt") - (args:get-arg "-testpatt") - "%")) - (keys (db:get-keys dbstruct)) - ;; (runsdat (db:get-runs dbstruct runpatt #f #f '())) - (runsdat (db:get-runs-by-patt dbstruct keys (or runpatt "%") (common:args-get-target) - #f #f)) - (runs (db:get-rows runsdat)) - (header (db:get-header runsdat)) - (db-targets (args:get-arg "-list-db-targets")) - (seen (make-hash-table)) - (dmode (let ((d (args:get-arg "-dumpmode"))) - (if d (string->symbol d) #f))) - (data (make-hash-table))) + (let* ((dbstruct (make-dbr:dbstruct path: *toppath* local: #t)) + (runpatt (args:get-arg "-list-runs")) + (testpatt (if (args:get-arg "-testpatt") + (args:get-arg "-testpatt") + "%")) + (keys (db:get-keys dbstruct)) + ;; (runsda t (db:get-runs dbstruct runpatt #f #f '())) + (runsdat (db:get-runs-by-patt dbstruct keys (or runpatt "%") (common:args-get-target) + #f #f '("id" "runname" "state" "status" "owner" "event_time" "comment"))) + (runstmp (db:get-rows runsdat)) + (header (db:get-header runsdat)) + (runs (if (and (not (null? runstmp)) + (args:get-arg "-since")) + (let ((changed-ids (db:get-changed-run-ids (string->number (args:get-arg "-since"))))) + (let loop ((hed (car runstmp)) + (tal (cdr runstmp)) + (res '())) + (let ((new-res (if (member (db:get-value-by-header hed header "id") changed-ids) + (cons hed res) + res))) + (if (null? tal) + (reverse new-res) + (loop (car tal)(cdr tal) new-res))))) + runstmp)) + (db-targets (args:get-arg "-list-db-targets")) + (seen (make-hash-table)) + (dmode (let ((d (args:get-arg "-dumpmode"))) + (if d (string->symbol d) #f))) + (data (make-hash-table)) + (fields-spec (if (args:get-arg "-fields") + (extract-fields-constraints (args:get-arg "-fields")) + (list (cons "runs" (append keys (list "id" "runname" "state" "status" "owner" "event_time" "comment" "fail_count" "pass_count"))) + (cons "tests" db:test-record-fields) ;; "id" "testname" "test_path") + (list "steps" "id" "stepname")))) + (runs-spec (let ((r (alist-ref "runs" fields-spec equal?))) ;; the check is now unnecessary + (if (and r (not (null? r))) r (list "id" )))) + (tests-spec (let ((t (alist-ref "tests" fields-spec equal?))) + (if (and t (null? t)) ;; all fields + db:test-record-fields + t))) + (adj-tests-spec (delete-duplicates (if tests-spec (cons "id" tests-spec) db:test-record-fields))) ;; '("id")))) + (steps-spec (alist-ref "steps" fields-spec equal?)) + (test-field-index (make-hash-table))) + (if (and tests-spec (not (null? tests-spec))) ;; do some validation and processing of the test-spec + (let ((invalid-tests-spec (filter (lambda (x)(not (member x db:test-record-fields))) tests-spec))) + (if (null? invalid-tests-spec) + ;; generate the lookup map test-field-name => index-number + (let loop ((hed (car adj-tests-spec)) + (tal (cdr adj-tests-spec)) + (idx 0)) + (hash-table-set! test-field-index hed idx) + (if (not (null? tal))(loop (car tal)(cdr tal)(+ idx 1)))) + (begin + (debug:print 0 "ERROR: Invalid test fields specified: " (string-intersperse invalid-tests-spec ", ")) + (exit))))) + ;; Each run (for-each (lambda (run) (let ((targetstr (string-intersperse (map (lambda (x) (db:get-value-by-header run header x)) @@ -909,43 +989,85 @@ (if db-targets (if (not (hash-table-ref/default seen targetstr #f)) (begin (hash-table-set! seen targetstr #t) ;; (print "[" targetstr "]")))) - (if (not dmode)(print targetstr)))) + (if (not dmode) + (print targetstr) + (hash-table-set! data "targets" (cons targetstr (hash-table-ref/default data "targets" '()))) + ))) (let* ((run-id (db:get-value-by-header run header "id")) (runname (db:get-value-by-header run header "runname")) - (tests (db:get-tests-for-run dbstruct run-id testpatt '() '() #f #f #f 'testname 'asc #f))) + (tests (if tests-spec + (db:get-tests-for-run dbstruct run-id testpatt '() '() #f #f #f 'testname 'asc + ;; use qryvals if test-spec provided + (if tests-spec + (string-intersperse adj-tests-spec ",") + ;; db:test-record-fields + #f)) + '()))) (case dmode ((json) - (mutils:hierhash-set! data (db:get-value-by-header run header "status") targetstr runname "meta" "status" ) - (mutils:hierhash-set! data (db:get-value-by-header run header "state") targetstr runname "meta" "state" ) - (mutils:hierhash-set! data (conc (db:get-value-by-header run header "id")) targetstr runname "meta" "id" ) - (mutils:hierhash-set! data (db:get-value-by-header run header "event_time") targetstr runname "meta" "event_time" )) + (if runs-spec + (for-each + (lambda (field-name) + (mutils:hierhash-set! data (conc (db:get-value-by-header run header field-name)) targetstr runname "meta" field-name)) + runs-spec))) + ;; (mutils:hierhash-set! data (db:get-value-by-header run header "status") targetstr runname "meta" "status" ) + ;; (mutils:hierhash-set! data (db:get-value-by-header run header "state") targetstr runname "meta" "state" ) + ;; (mutils:hierhash-set! data (conc (db:get-value-by-header run header "id")) targetstr runname "meta" "id" ) + ;; (mutils:hierhash-set! data (db:get-value-by-header run header "event_time") targetstr runname "meta" "event_time" ) + ;; (mutils:hierhash-set! data (db:get-value-by-header run header "comment") targetstr runname "meta" "comment" ) + ;; ;; add last entry twice - seems to be a bug in hierhash? + ;; (mutils:hierhash-set! data (db:get-value-by-header run header "comment") targetstr runname "meta" "comment" ) (else (print "Run: " targetstr "/" runname " status: " (db:get-value-by-header run header "state") " run-id: " run-id ", number tests: " (length tests)))) (for-each (lambda (test) (handle-exceptions exn - (debug:print 0 "ERROR: Bad data in test record? " test) - (let ((test-id (db:test-get-id test)) - (fullname (conc (db:test-get-testname test) - (if (equal? (db:test-get-item-path test) "") - "" - (conc "(" (db:test-get-item-path test) ")")))) - (tstate (db:test-get-state test)) - (tstatus (db:test-get-status test)) - (event-time (db:test-get-event_time test))) + (begin + (debug:print 0 "ERROR: Bad data in test record? " test) + (print "exn=" (condition->list exn)) + (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) + (print-call-chain (current-error-port))) + (let* ((test-id (get-value-by-fieldname test test-field-index "id" )) ;; (db:test-get-id test)) + (testname (get-value-by-fieldname test test-field-index "testname" )) ;; (db:test-get-testname test)) + (itempath (get-value-by-fieldname test test-field-index "item_path")) ;; (db:test-get-item-path test)) + (comment (get-value-by-fieldname test test-field-index "comment" )) ;; (db:test-get-comment test)) + (tstate (get-value-by-fieldname test test-field-index "state" )) ;; (db:test-get-state test)) + (tstatus (get-value-by-fieldname test test-field-index "status" )) ;; (db:test-get-status test)) + (event-time (get-value-by-fieldname test test-field-index "event_time")) ;; (db:test-get-event_time test)) + (rundir (get-value-by-fieldname test test-field-index "rundir" )) ;; (db:test-get-rundir test)) + (final_logf (get-value-by-fieldname test test-field-index "final_logf")) ;; (db:test-get-final_logf test)) + (run_duration (get-value-by-fieldname test test-field-index "run_duration")) ;; (db:test-get-run_duration test)) + (fullname (conc testname + (if (equal? itempath "") + "" + (conc "(" itempath ")"))))) (case dmode ((json) - (mutils:hierhash-set! data fullname targetstr runname "data" (conc test-id) "tname" ) - (mutils:hierhash-set! data tstate targetstr runname "data" (conc test-id) "state" ) - (mutils:hierhash-set! data tstatus targetstr runname "data" (conc test-id) "status" ) - (mutils:hierhash-set! data event-time targetstr runname "data" (conc test-is) "event_time")) + (if tests-spec + (for-each + (lambda (field-name) + (mutils:hierhash-set! data (get-value-by-fieldname test test-field-index field-name) targetstr runname "data" (conc test-id) field-name)) + tests-spec))) + ;; ;; (mutils:hierhash-set! data fullname targetstr runname "data" (conc test-id) "tname" ) + ;; (mutils:hierhash-set! data testname targetstr runname "data" (conc test-id) "testname" ) + ;; (mutils:hierhash-set! data itempath targetstr runname "data" (conc test-id) "itempath" ) + ;; (mutils:hierhash-set! data comment targetstr runname "data" (conc test-id) "comment" ) + ;; (mutils:hierhash-set! data tstate targetstr runname "data" (conc test-id) "state" ) + ;; (mutils:hierhash-set! data tstatus targetstr runname "data" (conc test-id) "status" ) + ;; (mutils:hierhash-set! data rundir targetstr runname "data" (conc test-id) "rundir" ) + ;; (mutils:hierhash-set! data final_logf targetstr runname "data" (conc test-id) "final_logf") + ;; (mutils:hierhash-set! data run_duration targetstr runname "data" (conc test-id) "run_duration") + ;; (mutils:hierhash-set! data event-time targetstr runname "data" (conc test-id) "event_time") + ;; ;; add last entry twice - seems to be a bug in hierhash? + ;; (mutils:hierhash-set! data event-time targetstr runname "data" (conc test-id) "event_time") + ;; ) (else (format #t " Test: ~25a State: ~15a Status: ~15a Runtime: ~5@as Time: ~22a Host: ~10a\n" fullname tstate @@ -979,10 +1101,21 @@ tests))))) runs) (if (eq? dmode 'json)(json-write data)) (set! *didsomething* #t)))) +;; Don't think I need this. Incorporated into -list-runs instead +;; +;; (if (and (args:get-arg "-since") +;; (launch:setup-for-run)) +;; (let* ((since-time (string->number (args:get-arg "-since"))) +;; (run-ids (db:get-changed-run-ids since-time))) +;; ;; (rmt:get-tests-for-runs-mindata run-ids testpatt states status not-in) +;; (print (sort run-ids <)) +;; (set! *didsomething* #t))) + + ;;====================================================================== ;; full run ;;====================================================================== ;; get lock in db for full run for this directory @@ -998,11 +1131,11 @@ ;; put task in deferred queue ;; if still ok to run tasks ;; process deferred tasks per above steps ;; run all tests are are Not COMPLETED and PASS or CHECK -(if (args:get-arg "-runall") +(if (or (args:get-arg "-runall")(args:get-arg "-run")) (general-run-call "-runall" "run all tests" (lambda (target runname keys keyvals) (runs:run-tests target Index: mt.scm ================================================================== --- mt.scm +++ mt.scm @@ -41,11 +41,11 @@ ;; ;; Use: (db-get-value-by-header (db:get-header runinfo)(db:get-rows runinfo)) ;; to extract info from the structure returned ;; (define (mt:get-runs-by-patt keys runnamepatt targpatt) - (let loop ((runsdat (rmt:get-runs-by-patt keys runnamepatt targpatt 0 500)) + (let loop ((runsdat (rmt:get-runs-by-patt keys runnamepatt targpatt 0 500 #f)) (res '()) (offset 0) (limit 500)) ;; (print "runsdat: " runsdat) (let* ((header (vector-ref runsdat 0)) @@ -53,11 +53,11 @@ (full-list (append res runslst)) (have-more (eq? (length runslst) limit))) ;; (debug:print 0 "header: " header " runslst: " runslst " have-more: " have-more) (if have-more (let ((new-offset (+ offset limit)) - (next-batch (rmt:get-runs-by-patt keys runnamepatt targpatt offset limit))) + (next-batch (rmt:get-runs-by-patt keys runnamepatt targpatt offset limit #f))) (debug:print-info 4 "More than " limit " runs, have " (length full-list) " runs so far.") (debug:print-info 0 "next-batch: " next-batch) (loop next-batch full-list new-offset ADDED multi-dboard.scm Index: multi-dboard.scm ================================================================== --- /dev/null +++ multi-dboard.scm @@ -0,0 +1,799 @@ +;;====================================================================== +;; Copyright 2006-2013, Matthew Welland. +;; +;; This program is made available under the GNU GPL version 2.0 or +;; greater. See the accompanying file COPYING for details. +;; +;; This program is distributed WITHOUT ANY WARRANTY; without even the +;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR +;; PURPOSE. +;;====================================================================== + +(use format numbers sql-de-lite srfi-1 posix regex regex-case srfi-69 nanomsg srfi-18 call-with-environment-variables) +(require-library iup) +(import (prefix iup iup:)) +(use canvas-draw) + +(declare (uses margs)) +(declare (uses megatest-version)) +(declare (uses gutils)) +(declare (uses tree)) +(declare (uses configf)) +(declare (uses portlogger)) +(declare (uses keys)) +(declare (uses common)) + +(include "common_records.scm") +;; (include "db_records.scm") +;; (include "key_records.scm") + +(define help (conc + "Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest + version " megatest-version " + license GPL, Copyright (C) Matt Welland 2011 + +Usage: dashboard [options] + -h : this help + -group groupname : display this group of areas + -test testid : control test identified by testid + -guimonitor : control panel for runs + +Misc + -rows N : set number of rows +")) + +;; process args +(define remargs (args:get-args + (argv) + (list "-group" ;; display this group of areas + "-debug" + ) + (list "-h" + "-v" + "-q" + ) + args:arg-hash + 0)) + +(if (args:get-arg "-h") + (begin + (print help) + (exit))) + +;; (if (args:get-arg "-host") +;; (begin +;; (set! (common:get-remote remote) (string-split (args:get-arg "-host" ":"))) +;; (client:launch)) +;; (client:launch)) + +(define *runremote* #f) +(define *windows* (make-hash-table)) +(define *changed-main* (make-hash-table)) ;; set path/... => #t +(define *changed-mutex* (make-mutex)) ;; use for all incoming change requests + +(debug:setup) + +(define *tim* (iup:timer)) +(define *ord* #f) + +(iup:attribute-set! *tim* "TIME" 300) +(iup:attribute-set! *tim* "RUN" "YES") + +(define (message-window msg) + (iup:show + (iup:dialog + (iup:vbox + (iup:label msg #:margin "40x40"))))) + +(define (iuplistbox-fill-list lb items . default) + (let ((i 1) + (selected-item (if (null? default) #f (car default)))) + (iup:attribute-set! lb "VALUE" (if selected-item selected-item "")) + (for-each (lambda (item) + (iup:attribute-set! lb (number->string i) item) + (if selected-item + (if (equal? selected-item item) + (iup:attribute-set! lb "VALUE" item))) ;; (number->string i)))) + (set! i (+ i 1))) + items) + i)) + +(define (pad-list l n)(append l (make-list (- n (length l))))) + + +(define (mkstr . x) + (string-intersperse (map conc x) ",")) + +(define (update-search x val) + (hash-table-set! *searchpatts* x val)) + + +;;====================================================================== +;; R E C O R D S +;;====================================================================== + +;; NOTE: Consider switching to defstruct. + +;; data for an area (regression or testsuite) +;; +(define-record areadat + name ;; area name + path ;; mt run area home + configdat ;; megatest config + denoise ;; focal point for not putting out same messages over and over + client-signature ;; key for client-server conversation + remote ;; hash of all the client side connnections + run-keys ;; target keys for this area + runs ;; used in dashboard, hash of run-ids -> rundat + read-only ;; can I write to this area? + monitordb ;; db handle for monitor.db + maindb ;; db handle for main.db + ) + +;; rundat, basic run data +;; +(define-record rundat + id ;; the run-id + target ;; val1/val2 ... corrosponding to run-keys in areadat + runname + state ;; state of the run, symbol + status ;; status of the run, symbol + event-time ;; when the run was initiated + tests ;; hash of test-id -> testdat, QUESTION: separate by run-id? + db ;; db handle + ) + +;; testdat, basic test data +(define-record testdat + run-id ;; what run is this from + id ;; test id + testname ;; test name + itempath ;; item path + state ;; test state, symbol + status ;; test status, symbol + event-time ;; when the test started + duration ;; how long the test took + ) + +;; general data for the dboard application +;; +(define-record data + cfgdat ;; data from ~/.megatest/.dat + areas ;; hash of areaname -> area-rec + current-window-id ;; + current-tab-id ;; + update-needed ;; flag to indicate that the tab pointed to by current tab id needs refreshing immediately + tabs ;; hash of tab-id -> areaname (??) should be of type "tab" + ) + +;; all the components of an area display, all fits into a tab but +;; parts may be swapped in/out as needed +;; +(define-record tab + tree + matrix ;; the spreadsheet + areadat ;; the one-structure (one day dbstruct will be put in here) + view-path ;; //... + view-type ;; standard, etc. + controls ;; the controls + data ;; all the data kept in sync with db + filters ;; user filters, alist name -> filter record, eventually store these in ~/.megatest/.dat? + run-id ;; the current run-id + test-ids ;; the current test id hash, run-id => test-id + command ;; the command from the entry field + headers ;; hash of header -> colnum + rows ;; hash of rowname -> rownum + ) + +(define-record filter + target ;; hash of widgets for the target + runname ;; the runname widget + testpatt ;; the testpatt widget + ) + +;;====================================================================== +;; D B +;;====================================================================== + +;; These are all using sql-de-lite and independent of area so cannot use stuff +;; from db.scm + +;; NB// run-id=#f => return dbdir only +;; +(define (areadb:dbfile-path areadat run-id) + (let* ((cfgdat (areadat-configdat areadat)) + (dbdir (or (configf:lookup cfgdat "setup" "dbdir") + (conc (configf:lookup cfgdat "setup" "linktree") "/.db"))) + (fname (if run-id + (case run-id + ((-1) "monitor.db") + ((0) "main.db") + (else (conc run-id ".db"))) + #f))) + (handle-exceptions + exn + (begin + (debug:print 0 "ERROR: Couldn't create path to " dbdir) + (exit 1)) + (if (not (directory? dbdir))(create-directory dbdir #t))) + (if fname + (conc dbdir "/" fname) + dbdir))) + +;; -1 => monitor.db +;; 0 => main.db +;; >1 => .db +;; +(define (areadb:open areadat run-id) + (let* ((runs (areadat-runs areadat)) + (rundat (if (> run-id 0) ;; it is a run + (hash-table-ref/default runs run-id #f) + #f)) + (db (case run-id ;; if already opened, get the db and return it + ((-1) (areadat-monitordb areadat)) + ((0) (areadat-maindb areadat)) + (else (if rundat + (rundat-db rundat) + #f))))) + (if db + db ;; merely return the already opened db + (let* ((dbfile (areadb:dbfile-path areadat run-id)) ;; not already opened, so open it + (db (if (file-exists? dbfile) + (open-database dbfile) + (begin + (debug:print 0 "ERROR: I was asked to open " dbfile ", but file does not exist or is not readable.") + #f)))) + (case run-id + ((-1)(areadat-monitordb-set! areadat db)) + ((0) (areadat-maindb-set! areadat db)) + (else (rundat-db-set! rundat db))) + db)))) + +;; populate the areadat tests info, does NOT fill the tests data itself unless asked +;; +(define (areadb:populate-run-info areadat) + (let* ((runs (or (areadat-runs areadat) (make-hash-table))) + (keys (areadat-run-keys areadat)) + (maindb (areadb:open areadat 0))) + (query (for-each-row (lambda (row) + (let ((id (list-ref row 0)) + (dat (apply make-rundat (append row (list #f #f))))) ;; add placeholders for tests and db + (print row) + (hash-table-set! runs id dat)))) + (sql maindb (conc "SELECT id," + (string-intersperse keys "||'/'||") + ",runname,state,status,event_time FROM runs WHERE state != 'deleted';"))) + areadat)) + +;; given an areadat and target/runname patt fill up runs data +;; +;; ?????/ + +;; given a list of run-ids refresh/retrieve runs data into areadat +;; +(define (areadb:fill-tests areadat #!key (run-ids #f)) + (let* ((runs (or (areadat-runs areadat) (make-hash-table)))) + (for-each + (lambda (run-id) + (let* ((rundat (hash-table-ref/default runs run-id #f)) + (tests (if (and rundat + (rundat-tests rundat)) ;; re-use existing hash table? + (rundat-tests rundat) + (let ((ht (make-hash-table))) + (rundat-tests-set! rundat ht) + ht))) + (rundb (areadb:open areadat run-id))) + (query (for-each-row (lambda (row) + (let* ((id (list-ref row 0)) + (testname (list-ref row 1)) + (itempath (list-ref row 2)) + (state (list-ref row 3)) + (status (list-ref row 4)) + (eventtim (list-ref row 5)) + (duration (list-ref row 6))) + (hash-table-set! tests id + (make-testdat run-id id testname itempath state status eventtim duration))))) + (sql rundb "SELECT id,testname,item_path,state,status,event_time,run_duration FROM tests WHERE state != 'DELETED';")))) + (or run-ids (hash-table-keys runs))) + areadat)) + + +;; initialize and refresh data +;; +(define (dboard:general-updater con port) + (for-each + (lambda (window-id) + ;; (print "Processing for window-id " window-id) + (let* ((window-dat (hash-table-ref *windows* window-id)) + (areas (data-areas window-dat)) + ;; (keys (areadat-run-keys area-dat)) + (tabs (data-tabs window-dat)) + (tab-ids (hash-table-keys tabs)) + (current-tab (if (null? tab-ids) + #f + (hash-table-ref tabs (car tab-ids)))) + (current-tree (if (null? tab-ids) #f (tab-tree current-tab))) + (current-node (if (null? tab-ids) 0 (string->number (iup:attribute current-tree "VALUE")))) + (current-path (if (eq? current-node 0) + "Areas" + (string-intersperse (tree:node->path current-tree current-node) "/"))) + (current-matrix (if (null? tab-ids) #f (tab-matrix current-tab))) + (seen-nodes (make-hash-table)) + (path-changed (if current-tab + (equal? current-path (tab-view-path current-tab)) + #t))) + ;; (debug:print-info 0 "Current path: " current-path) + ;; now for each area in the window gather the data + (if path-changed + (begin + (debug:print-info 0 "clearing matrix - path changed") + (dboard:clear-matrix current-tab))) + (for-each + (lambda (area-name) + ;; (print "Processing for area-name " area-name) + (let* ((area-dat (hash-table-ref areas area-name)) + (area-path (areadat-path area-dat)) + (runs (areadat-runs area-dat))) + (if (hash-table-ref/default *changed-main* area-path 'processed) + (begin + (print "Processing " area-dat " for area-name " area-name) + (hash-table-set! *changed-main* area-path #f) + (areadb:populate-run-info area-dat) + (for-each + (lambda (run-id) + (let* ((run (hash-table-ref runs run-id)) + (target (rundat-target run)) + (runname (rundat-runname run))) + (if current-tree + (let* ((partial-path (append (string-split target "/")(list runname))) + (full-path (cons area-name partial-path))) + (if (not (hash-table-exists? seen-nodes full-path)) + (begin + (print "INFO: Adding node " partial-path " to section " area-name) + (tree:add-node current-tree "Areas" full-path) + (areadb:fill-tests area-dat run-ids: (list run-id)))) + (hash-table-set! seen-nodes full-path #t))))) + (hash-table-keys runs)))) + (if (or (equal? "Areas" current-path) + (string-match (conc "^Areas/" area-name "(|\\/.*)$") current-path)) + (dboard:redraw-area area-name area-dat current-tab current-matrix current-path)))) + (hash-table-keys areas)))) + (hash-table-keys *windows*))) + +;;====================================================================== +;; D A S H B O A R D D B +;;====================================================================== + +;; All moved to common.scm + +;;====================================================================== +;; T R E E +;;====================================================================== + +;; - - - - + +(define (dashboard:tree-browser data adat window-id) + ;; (iup:split + (let* ((tb (iup:treebox + #:value 0 + #:title "Areas" + #:expand "YES" + #:addexpanded "NO" + #:selection-cb + (lambda (obj id state) + ;; (print "obj: " obj ", id: " id ", state: " state) + (let* ((tree-path (tree:node->path obj id)) + (area (car tree-path)) + (areadat-path (cdr tree-path))) + #f + ;; (test-id (tree-path->test-id (cdr run-path)))) + ;; (if test-id + ;; (hash-table-set! (dboard:data-get-curr-test-ids *data*) + ;; window-id test-id)) + ;; (print "path: " (tree:node->path obj id) " test-id: " test-id)))))) + ))))) + ;; (iup:attribute-set! tb "VALUE" "0") + ;; (iup:attribute-set! tb "NAME" "Runs") + ;; (iup:attribute-set! tb "ADDEXPANDED" "NO") + ;; (dboard:data-set-tests-tree! *data* tb) + tb)) + +;;====================================================================== +;; M A I N M A T R I X +;;====================================================================== + +;; General displayer +;; +(define (dashboard:main-matrix data adat window-id) + (let* (;; (tab-dat (areadat- + (view-matrix (iup:matrix + ;; (runs-for-targ (db:get-runs-by-patt *dbstruct-local* *keys* "%" target #f #f #f)) + #:expand "YES" + ;; #:fittosize "YES" + #:resizematrix "YES" + #:scrollbar "YES" + #:numcol 100 + #:numlin 100 + #:numcol-visible 3 + #:numlin-visible 20 + #:click-cb (lambda (obj lin col status) + (print "obj: " obj " lin: " lin " col: " col " status: " status " value: " (iup:attribute obj "VALUE")))))) + + ;; (iup:attribute-set! view-matrix "RESIZEMATRIX" "YES") + (iup:attribute-set! view-matrix "WIDTH0" "100") + ;; (dboard:data-set-runs-matrix! *data* runs-matrix) + ;; (iup:hbox + ;; (iup:frame + ;; #:title "Runs browser" + ;; (iup:vbox + view-matrix)) + +;;====================================================================== +;; A R E A S +;;====================================================================== + +(define (dashboard:init-area data area-name apath) + (let* ((mtconf (dboard:read-mtconf apath)) + (area-dat (let ((ad (make-areadat + area-name ;; area name + apath ;; path to area + ;; 'http ;; transport + mtconf ;; megatest.config + (make-hash-table) ;; denoise hash + #f ;; client-signature + #f ;; remote connections + (keys:config-get-fields mtconf) ;; run keys + (make-hash-table) ;; run-id -> (hash of test-ids => dat) + (and (file-exists? apath)(file-write-access? apath)) ;; read-only + #f + #f + ))) + (hash-table-set! (data-areas data) area-name ad) + ad))) + area-dat)) + +;; given the keys for an area and a path from the tree browser +;; return the level: areas area runs run tests test +;; +(define (dboard:get-view-type keys current-path) + (let* ((path-parts (string-split current-path "/")) + (path-len (length path-parts))) + (cond + ((equal? current-path "Areas") 'areas) + ((eq? path-len 2) 'area) + ((<= (+ (length keys) 2) path-len) 'runs) + (else 'run)))) + +(define (dboard:clear-matrix tab) + (if tab + (begin + (iup:attribute-set! (tab-matrix tab) "CLEARVALUE" "ALL") + (tab-headers-set! tab (make-hash-table)) + (tab-rows-set! tab (make-hash-table))))) + +;; full redraw of a given area +;; +(define (dboard:redraw-area area-name area-dat tab-dat current-matrix current-path) + (let* ((keys (areadat-run-keys area-dat)) + (runs (areadat-runs area-dat)) + (headers (tab-headers tab-dat)) + (rows (tab-rows tab-dat)) + (used-cols (hash-table-values headers)) + (used-rows (hash-table-values rows)) + (touched (make-hash-table)) ;; (vector row col) ==> true, touched cell + (view-type (dboard:get-view-type keys current-path)) + (changed #f) + (state-statuses (list "PASS" "FAIL" "WARN" "CHECK" "SKIP" "RUNNING" "LAUNCHED"))) + (debug:print 0 "current-matrix=" current-matrix) + (case view-type + ((areas) ;; find row for this area, if not found, create new entry + (let* ((curr-rownum (hash-table-ref/default rows area-name #f)) + (next-rownum (+ (apply max (cons 0 used-rows)) 1)) + (rownum (or curr-rownum next-rownum)) + (coord (conc rownum ":0"))) + (if (not curr-rownum)(hash-table-set! rows area-name rownum)) + (if (not (equal? (iup:attribute current-matrix coord) area-name)) + (begin + (let loop ((hed (car state-statuses)) + (tal (cdr state-statuses)) + (count 1)) + (if (not (equal? (iup:attribute current-matrix (conc "0:" count)) hed)) + (iup:attribute-set! current-matrix (conc "0:" count) hed)) + (iup:attribute-set! current-matrix (conc rownum ":" count) "0") + (if (not (null? tal)) + (loop (car tal)(cdr tal)(+ count 1)))) + (debug:print-info 0 "view-type=" view-type ", rownum=" rownum ", curr-rownum=" curr-rownum ", next-rownum=" next-rownum ", coord=" coord ", area-name=" area-name) + (iup:attribute-set! current-matrix coord area-name) + (set! changed #t)))))) + (if changed (iup:attribute-set! current-matrix "REDRAW" "ALL")))) + + + + ;; (dboard:clear-matrix current-matrix used-cols used-rows touched) ;; clear all + + + +;;====================================================================== +;; D A S H B O A R D +;;====================================================================== + +(define (dashboard:area-panel aname data window-id) + (let* ((apath (configf:lookup (data-cfgdat data) aname "path")) ;; (hash-table-ref (dboard:data-cfgdat data) area-name)) + ;; (hash-table-ref (dboard:data-cfgdat data) aname)) + (area-dat (dashboard:init-area data aname apath)) + (tb (dashboard:tree-browser data area-dat window-id)) ;; (dboard:areas-tree-browser data) + (ad (dashboard:main-matrix data area-dat window-id)) + (areas (data-areas data)) + (dboard-dat (make-tab + #f ;; tree + #f ;; matrix + area-dat ;; + #f ;; view path + 'default ;; view type + #f ;; controls + (make-hash-table) ;; cached data? not sure how to use this yet :) + #f ;; filters + #f ;; the run-id + (make-hash-table) ;; run-id -> test-id, for current test id + "" + (make-hash-table) ;; headername -> colnum + (make-hash-table) ;; rowname -> rownum + ))) + (hash-table-set! (data-areas data) aname area-dat) ;; dboard-dat) + (hash-table-set! (data-tabs data) window-id dboard-dat) + (tab-tree-set! dboard-dat tb) + (tab-matrix-set! dboard-dat ad) + (iup:split + #:value 200 + tb ad))) + + +;; Main Panel +;; +(define (dashboard:main-panel data window-id) + (iup:dialog + #:title "Megatest Control Panel" +;; #:menu (dcommon:main-menu data) + #:shrink "YES" + (iup:vbox + (let* ((area-names (hash-table-keys (data-cfgdat data))) + (area-panels (map (lambda (aname) + (dashboard:area-panel aname data window-id)) + area-names)) + (tabtop (apply iup:tabs + #:tabchangepos-cb (lambda (obj curr prev) + (data-current-tab-id-set! data curr) + (data-update-needed-set! data #t) + (print "Tab is: " curr ", prev was " prev)) + area-panels)) + (tabs (data-tabs data))) + (if (not (null? area-names)) + (let loop ((index 0) + (hed (car area-names)) + (tal (cdr area-names))) + ;; (hash-table-set! tabs index hed) + (debug:print 0 "Adding area " hed " with index " index " to dashboard") + (iup:attribute-set! tabtop (conc "TABTITLE" index) hed) + (if (not (null? tal)) + (loop (+ index 1)(car tal)(cdr tal))))) + tabtop)))) + + +;;====================================================================== +;; N A N O M S G S E R V E R +;;====================================================================== + +(define (dboard:server-service soc port) + (print "server starting") + (let loop ((msg-in (nn-recv soc)) + (count 0)) + (if (eq? 0 (modulo count 1000)) + (print "server received: " msg-in ", count=" count)) + (cond + ;; + ;; quit + ;; + ((equal? msg-in "quit") + (nn-send soc "Ok, quitting")) + ;; + ;; ping + ;; + ((and (>= (string-length msg-in) 4) + (equal? (substring msg-in 0 4) "ping")) + (nn-send soc (conc (current-process-id))) + (loop (nn-recv soc)(+ count 1))) + ;; + ;; main changed + ;; + ((and (>= (string-length msg-in) 4) + (equal? (substring msg-in 0 4) "main")) + (let ((parts (string-split msg-in " "))) + (hash-table-set! *changed-main* (cadr parts) #t) + (nn-send soc "got it!"))) + ;; + ;; ?? + ;; + (else + (nn-send soc "hello " msg-in " you got to the else clause!"))) + (loop (nn-recv soc)(if (> count 20000000) + 0 + (+ count 1))))) + +(define (dboard:one-time-ping-receive soc port) + (let ((msg-in (nn-recv soc))) + (if (and (>= (string-length msg-in) 4) + (equal? (substring msg-in 0 4) "ping")) + (nn-send soc (conc (current-process-id)))))) + +(define (dboard:server-start given-port #!key (num-tries 200)) + (let* ((rep (nn-socket 'rep)) + (port (or given-port (portlogger:main "find"))) + (con (conc "tcp://*:" port))) + ;; register this connect here .... + (nn-bind rep con) + (thread-start! + (make-thread (lambda () + (dboard:one-time-ping-receive rep port)) + "one time receive thread")) + (if (dboard:ping-self "localhost" port) + (begin + (print "INFO: dashboard nanomsg server started on " port) + (values rep port)) + (begin + (print "WARNING: couldn't create server on port " port) + (portlogger:main "set" "failed") + (if (> num-tries 0) + (dboard:server-start #f (- num-tries 1)) + (begin + (print "ERROR: failed to start nanomsg server") + (values #f #f))))))) + +(define (dboard:server-close con port) + (nn-close con) + (portlogger:main "set" port "released")) + +(define (dboard:ping-self host port #!key (return-socket #t)) + ;; send a random number along with pid and check that we get it back + (let* ((req (nn-socket 'req)) + (key "ping") + (success #f) + (keepwaiting #t) + (ping (make-thread + (lambda () + (print "ping: sending string \"" key "\", expecting " (current-process-id)) + (nn-send req key) + (let ((result (nn-recv req))) + (if (equal? (conc (current-process-id)) result) + (begin + (print "ping, success: received \"" result "\"") + (set! success #t)) + (begin + (print "ping, failed: received key \"" result "\"") + (set! keepwaiting #f) + (set! success #f))))) + "ping")) + (timeout (make-thread (lambda () + (let loop ((count 0)) + (thread-sleep! 1) + (print "still waiting after " count " seconds...") + (if (and keepwaiting (< count 10)) + (loop (+ count 1)))) + (if keepwaiting + (begin + (print "timeout waiting for ping") + (thread-terminate! ping)))) + "timeout"))) + (nn-connect req (conc "tcp://" host ":" port)) + (handle-exceptions + exn + (begin + (print-call-chain) + (print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) + (print "exn=" (condition->list exn)) + (print "ping failed to connect to " host ":" port)) + (thread-start! timeout) + (thread-start! ping) + (thread-join! ping) + (if success (thread-terminate! timeout))) + (if return-socket + (if success req #f) + (begin + (nn-close req) + success)))) + +;;====================================================================== +;; C O N F I G U R A T I O N +;;====================================================================== + +;; Get the configuration file for a group name, if the group name is "default" and it doesn't +;; exist, create it and add the current path if it contains megatest.config +;; +(define (dboard:get-config group-name) + (let* ((fname (conc (getenv "HOME") "/.megatest/" group-name ".dat"))) + (if (file-exists? fname) + (read-config fname (make-hash-table) #t) + (if (dboard:create-config fname) + (dboard:get-config group-name) + (make-hash-table))))) + +(define (dboard:create-config fname) + ;; (handle-exceptions + ;; exn + ;; + ;; #f ;; failed to create - just give up + (let* ((dirname (pathname-directory fname)) + (file-name (pathname-strip-directory fname)) + (curr-mtcfgdat (find-config "megatest.config" + toppath: (or (get-environment-variable "MT_RUN_AREA_HOME")(current-directory)))) + (curr-mtcfg (if (and curr-mtcfgdat (not (null? curr-mtcfgdat)))(cadr curr-mtcfgdat) #f)) + (curr-mtpath (if curr-mtcfg (car curr-mtcfgdat) #f))) + (if curr-mtpath + (begin + (debug:print-info 0 "Creating config file " fname) + (if (not (file-exists? dirname)) + (create-directory dirname #t)) + (with-output-to-file fname + (lambda () + (let ((aname (pathname-strip-directory curr-mtpath))) + (print "[" aname "]") + (print "path " curr-mtpath)))) + #t) + (begin + (debug:print-info 0 "Need to create a config but no megatest.config found: " curr-mtcfgdat) + #f)))) +;; ) + +(define (dboard:read-mtconf apath) + (let* ((mtconffile (conc apath "/megatest.config"))) + (call-with-environment-variables + (list (cons "MT_RUN_AREA_HOME" apath)) + (lambda () + (read-config mtconffile (make-hash-table) #f)) ;; megatest.config + ))) + + +;;====================================================================== +;; G U I S T U F F +;;====================================================================== + +;;; main. Theoretically could have multiple windows (each with a group of tags, thus window-id +;;; +(define (dboard:make-window window-id) + (let* (;; (window-id 0) + (groupn (or (args:get-arg "-group") "default")) + (cfgdat (dboard:get-config groupn)) + ;; (cfgdat (if (file-exists? cfname)(read-config cfname (make-hash-table) #t)(make-hash-table))) + (data (make-data + cfgdat ;; this is the data from ~/.megatest for the selected group + (make-hash-table) ;; areaname -> area-rec + 0 ;; current window id + 0 ;; current tab id + #f ;; redraw needed for current tab id + (make-hash-table) ;; tab-id -> areaname + ))) + (hash-table-set! *windows* window-id data) + (iup:show (dashboard:main-panel data window-id)) + (iup:main-loop))) + + + +;; ease debugging by loading ~/.dashboardrc +(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.dashboardrc"))) + (if (file-exists? debugcontrolf) + (load debugcontrolf))) + +(let-values + (((con port)(dboard:server-start #f))) + (let ((portnum (if (string? port)(string->number port) port))) + ;; got here, monitor/dashboard was started + (mddb:register-dashboard portnum) + (thread-start! (make-thread (lambda ()(dboard:server-service con portnum)) "server service")) + (thread-start! (make-thread (lambda () + (let loop () + (dboard:general-updater con portnum) + (thread-sleep! 1) + (loop))) "general updater")) + (dboard:make-window 0) + (mddb:unregister-dashboard (get-host-name) portnum) + (dboard:server-close con port))) + Index: portlogger.scm ================================================================== --- portlogger.scm +++ portlogger.scm @@ -160,19 +160,21 @@ (begin (debug:print 0 "EXCEPTION: portlogger database at " dbfname " probably overloaded or unreadable. Try removing it.") (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) (print "exn=" (condition->list exn)) (debug:print 0 " status: " ((condition-property-accessor 'sqlite3 'status) exn)) - (print-call-chain (current-error-port))) - (cond - ((> numargs 1) ;; most commands - (case (string->symbol (car args)) ;; commands with two or more params - ((take)(portlogger:take-port db (string->number (cadr args)))) - ((set) (portlogger:set-port db - (string->number (cadr args)) - (caddr args)) - (caddr args)) - ((failed)(portlogger:set-failed db (string->number (cadr args))) 'failed))))))) + (print-call-chain (current-error-port)) + #f) + (case (string->symbol (car args)) ;; commands with two or more params + ((take)(portlogger:take-port db (string->number (cadr args)))) + ((find)(portlogger:find-port db)) + ((set) (let ((port (cadr args)) + (state (caddr args))) + (portlogger:set-port db + (if (number? port) port (string->number port)) + state) + state)) + ((failed)(portlogger:set-failed db (string->number (cadr args))) 'failed))))) (sqlite3:finalize! db) result)) ;; (print (apply portlogger:main (cdr (argv)))) Index: rmt.scm ================================================================== --- rmt.scm +++ rmt.scm @@ -20,11 +20,11 @@ ;; ;; THESE ARE ALL CALLED ON THE CLIENT SIDE!!! ;; ;; ;; For debugging add the following to ~/.megatestrc -;;a +;; ;; (require-library trace) ;; (import trace) ;; (trace ;; rmt:send-receive ;; api:execute-requests @@ -156,13 +156,22 @@ (if (and faststart (equal? faststart "no")) (begin (tasks:start-and-wait-for-server (db:delay-if-busy (tasks:open-db)) run-id 10) (thread-sleep! (random 5)) ;; give some time to settle and minimize collison? (rmt:send-receive cmd rid params attemptnum: (+ attemptnum 1))) - (begin - (server:kind-run run-id) - (rmt:open-qry-close-locally cmd run-id params)))) + (let ((start-time (current-milliseconds)) + (max-query (string->number (or (configf:lookup *configdat* "server" "server-query-threshold") + "300"))) + (newres (rmt:open-qry-close-locally cmd run-id params))) + (let ((delta (- (current-milliseconds) start-time))) + (if (> delta max-query) + (begin + (debug:print-info 0 "Starting server as query time " delta " is over the limit of " max-query) + (server:kind-run run-id))) + ;; return the result! + newres) + ))) (begin ;; (debug:print 0 "ERROR: Communication failed!") ;; (mutex-unlock! *send-receive-mutex*) ;; (exit) (rmt:open-qry-close-locally cmd run-id params) @@ -345,14 +354,24 @@ (rmt:send-receive 'get-key-val-pairs run-id (list run-id))) (define (rmt:get-keys) (rmt:send-receive 'get-keys #f '())) +(define (rmt:get-key-vals run-id) + (rmt:send-receive 'get-key-vals #f (list run-id))) + +(define (rmt:get-targets) + (rmt:send-receive 'get-targets #f '())) + ;;====================================================================== ;; T E S T S ;;====================================================================== +;; Just some syntatic sugar +(define (rmt:register-test run-id test-name item-path) + (rmt:general-call 'register-test run-id run-id test-name item-path)) + (define (rmt:get-test-id run-id testname item-path) (rmt:send-receive 'get-test-id run-id (list run-id testname item-path))) (define (rmt:get-test-info-by-id run-id test-id) (if (and (number? run-id)(number? test-id)) @@ -485,12 +504,12 @@ 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-prereqs-not-met run-id waitons ref-item-path #!key (mode '(normal))) - (rmt:send-receive 'get-prereqs-not-met run-id (list run-id waitons ref-item-path mode))) +(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) (rmt:send-receive 'get-count-tests-running-for-run-id run-id (list run-id))) ;; Statistical queries @@ -502,23 +521,28 @@ (rmt:send-receive 'get-count-tests-running-for-testname run-id (list run-id testname))) (define (rmt:get-count-tests-running-in-jobgroup run-id jobgroup) (rmt:send-receive 'get-count-tests-running-in-jobgroup run-id (list run-id jobgroup))) -(define (rmt:roll-up-pass-fail-counts run-id test-name item-path status) - (rmt:send-receive 'roll-up-pass-fail-counts run-id (list run-id test-name item-path status))) +;; state and status are extra hints not usually used in the calculation +;; +(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-fail-pass-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 (list run-id test-name run-id test-name run-id test-name))) ;;====================================================================== ;; R U N S ;;====================================================================== (define (rmt:get-run-info run-id) (rmt:send-receive 'get-run-info run-id (list run-id))) +(define (rmt:get-num-runs runpatt) + (rmt:send-receive 'get-num-runs #f (list runpatt))) + ;; Use the special run-id == #f scenario here since there is no run yet (define (rmt:register-run keyvals runname state status user) (rmt:send-receive 'register-run #f (list keyvals runname state status user))) (define (rmt:get-run-name-from-id run-id) @@ -553,12 +577,12 @@ (rmt:send-receive 'set-run-status #f (list run-id run-status msg))) (define (rmt:update-run-event_time run-id) (rmt:send-receive 'update-run-event_time #f (list run-id))) -(define (rmt:get-runs-by-patt keys runnamepatt targpatt offset limit) - (rmt:send-receive 'get-runs-by-patt #f (list keys runnamepatt targpatt offset limit))) +(define (rmt:get-runs-by-patt keys runnamepatt targpatt offset limit fields) ;; fields of #f uses default + (rmt:send-receive 'get-runs-by-patt #f (list keys runnamepatt targpatt offset limit fields))) (define (rmt:find-and-mark-incomplete run-id ovr-deadtime) (if (rmt:send-receive 'have-incompletes? run-id (list run-id ovr-deadtime)) (rmt:send-receive 'mark-incomplete run-id (list run-id ovr-deadtime)))) Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -222,18 +222,32 @@ (task-key (conc (hash-table->alist flags) " " (get-host-name) " " (current-process-id))) (tdbdat (tasks:open-db))) (if (tasks:need-server run-id)(tasks:start-and-wait-for-server tdbdat run-id 10)) - (set-signal-handler! signal/int - (lambda (signum) - (signal-mask! signum) - (print "Received signal " signum ", cleaning up before exit. Please wait...") - (let ((tdbdat (tasks:open-db))) - (rmt:tasks-set-state-given-param-key task-key "killed")) - (print "Killed by signal " signum ". Exiting") - (exit))) + (let ((sighand (lambda (signum) + ;; (signal-mask! signum) ;; to mask or not? seems to cause issues in exiting + (if (eq? signum signal/stop) + (debug:print 0 "ERROR: attempt to STOP process. Exiting.")) + (set! *time-to-exit* #t) + (print "Received signal " signum ", cleaning up before exit. Please wait...") + (let ((th1 (make-thread (lambda () + (let ((tdbdat (tasks:open-db))) + (rmt:tasks-set-state-given-param-key task-key "killed")) + (print "Killed by signal " signum ". Exiting") + (thread-sleep! 3) + (exit)))) + (th2 (make-thread (lambda () + (thread-sleep! 5) + (debug:print 0 "Done") + (exit 4))))) + (thread-start! th2) + (thread-start! th1) + (thread-join! th2))))) + (set-signal-handler! signal/int sighand) + (set-signal-handler! signal/term sighand) + (set-signal-handler! signal/stop sighand)) ;; register this run in monitor.db (rmt:tasks-add "run-tests" user target runname test-patts task-key) ;; params) (rmt:tasks-set-state-given-param-key task-key "running") (runs:set-megatest-env-vars run-id inkeys: keys inrunname: runname) ;; these may be needed by the launching process @@ -243,19 +257,24 @@ ;; Now generate all the tests lists (set! all-tests-registry (tests:get-all)) (set! all-test-names (hash-table-keys all-tests-registry)) (set! test-names (tests:filter-test-names all-test-names test-patts)) - (set! required-tests (lset-intersection equal? (string-split test-patts ",") test-names)) + + ;; I think seeding required-tests with all test-names makes sense but lack analysis to back that up. + ;; + (set! required-tests (lset-intersection equal? (string-split test-patts ",") all-test-names)) + ;; (set! required-tests (lset-intersection equal? test-names all-test-names)) ;; look up all tests matching the comma separated list of globs in ;; test-patts (using % as wildcard) ;; (set! test-names (delete-duplicates (tests:get-valid-tests *toppath* test-patts))) - (debug:print-info 0 "tests search path: " (tests:get-tests-search-path *configdat*)) - (debug:print-info 0 "all tests: " (string-intersperse (sort all-test-names string<) " ")) - (debug:print-info 0 "test names: " (string-intersperse (sort test-names string<) " ")) + (debug:print-info 0 "tests search path: " (string-intersperse (tests:get-tests-search-path *configdat*) " ")) + (debug:print-info 0 "all tests: " (string-intersperse (sort all-test-names string<) " ")) + (debug:print-info 0 "test names: " (string-intersperse (sort test-names string<) " ")) + (debug:print-info 0 "required tests: " (string-intersperse (sort required-tests string<) " ")) ;; on the first pass or call to run-tests set FAILS to NOT_STARTED if ;; -keepgoing is specified (if (eq? *passnum* 0) (begin @@ -267,11 +286,11 @@ ;; on test A but test B reached the point on being registered as NOT_STARTED and test ;; A failed for some reason then on re-run using -keepgoing the run can never complete. ;; ;; (rmt:general-call 'delete-tests-in-state run-id "NOT_STARTED") - ;; Now convert FAIL and anything in allow-auto-rerun to NOT_STARTED + ;; Now convert anything in allow-auto-rerun to NOT_STARTED ;; (for-each (lambda (state) (rmt:set-tests-state-status run-id test-names state #f "NOT_STARTED" state)) (string-split (or (configf:lookup *configdat* "setup" "allow-auto-rerun") ""))))) @@ -459,11 +478,11 @@ (define runs:nothing-left-in-queue-count 0) (define (runs:expand-items hed tal reg reruns regfull newtal jobgroup max-concurrent-jobs run-id waitons item-path testmode test-record can-run-more items runname tconfig reglen test-registry test-records itemmap) (let* ((loop-list (list hed tal reg reruns)) - (prereqs-not-met (rmt:get-prereqs-not-met run-id waitons item-path testmode itemmap: itemmap)) + (prereqs-not-met (rmt:get-prereqs-not-met run-id waitons item-path mode: testmode itemmap: itemmap)) ;; (prereqs-not-met (mt:lazy-get-prereqs-not-met run-id waitons item-path mode: testmode itemmap: itemmap)) (fails (runs:calc-fails prereqs-not-met)) (prereq-fails (runs:calc-prereq-fail prereqs-not-met)) (non-completed (runs:calc-not-completed prereqs-not-met)) (runnables (runs:calc-runnable prereqs-not-met))) @@ -544,11 +563,11 @@ (give-up #f)) ;; We can get here when a prereq has not been run due to *it* having a prereq that failed. ;; We need to use this to dequeue this item as CANNOTRUN ;; - (if (member testmode '(toplevel)) + (if (member 'toplevel testmode) ;; '(toplevel)) ;; NOTE: this probably should be (member 'toplevel testmode) (for-each (lambda (prereq) (if (eq? (hash-table-ref/default test-registry prereq 'justfine) 'CANNOTRUN) (set! give-up #t))) prereqstrs)) @@ -647,14 +666,16 @@ (have-resources (car run-limits-info)) (num-running (list-ref run-limits-info 1)) (num-running-in-jobgroup (list-ref run-limits-info 2)) (max-concurrent-jobs (list-ref run-limits-info 3)) (job-group-limit (list-ref run-limits-info 4)) - (prereqs-not-met (rmt:get-prereqs-not-met run-id waitons item-path testmode itemmap: itemmap)) + (prereqs-not-met (rmt:get-prereqs-not-met run-id waitons item-path mode: testmode itemmap: itemmap)) ;; (prereqs-not-met (mt:lazy-get-prereqs-not-met run-id waitons item-path mode: testmode itemmap: itemmap)) (fails (runs:calc-fails prereqs-not-met)) - (non-completed (runs:calc-not-completed prereqs-not-met)) + (non-completed (filter (lambda (x) ;; remove hed from not completed list, duh, of course it is not completed! + (not (equal? x hed))) + (runs:calc-not-completed prereqs-not-met))) (loop-list (list hed tal reg reruns)) ;; configure the load runner (numcpus (common:get-num-cpus)) (maxload (string->number (or (configf:lookup *configdat* "jobtools" "maxload") "3"))) (waitdelay (string->number (or (configf:lookup *configdat* "jobtools" "waitdelay") "60")))) @@ -662,11 +683,15 @@ (string-intersperse (map (lambda (t) (if (vector? t) (conc (db:test-get-state t) "/" (db:test-get-status t)) (conc " WARNING: t is not a vector=" t ))) - prereqs-not-met) ", ") ") fails: " fails) + prereqs-not-met) + ", ") ") fails: " fails + "\nregistered? " (hash-table-ref/default test-registry (db:test-make-full-name test-name item-path) #f)) + + (if (and (not (null? prereqs-not-met)) (runs:lownoise (conc "waiting on tests " prereqs-not-met hed) 60)) (debug:print-info 2 "waiting on tests; " (string-intersperse (runs:mixed-list-testname-and-testrec->list-of-strings prereqs-not-met) ", "))) @@ -693,21 +718,21 @@ ;; ((not (hash-table-ref/default test-registry (db:test-make-full-name test-name item-path) #f)) (debug:print-info 4 "Pre-registering test " test-name "/" item-path " to create placeholder" ) ;; always do firm registration now in v1.60 and greater ;; (eq? *transport-type* 'fs) ;; no point in parallel registration if use fs (let register-loop ((numtries 15)) - (rmt:general-call 'register-test run-id run-id test-name item-path) + (rmt:register-test run-id test-name item-path) (if (rmt:get-test-id run-id test-name item-path) (hash-table-set! test-registry (db:test-make-full-name test-name item-path) 'done) (if (> numtries 0) (begin (thread-sleep! 0.5) (register-loop (- numtries 1))) (debug:print 0 "ERROR: failed to register test " (db:test-make-full-name test-name item-path))))) (if (not (eq? (hash-table-ref/default test-registry (db:test-make-full-name test-name "") #f) 'done)) (begin - (rmt:general-call 'register-test run-id run-id test-name "") + (rmt:register-test run-id test-name "") (if (rmt:get-test-id run-id test-name "") (hash-table-set! test-registry (db:test-make-full-name test-name "") 'done)))) (runs:shrink-can-run-more-tests-count) ;; DELAY TWEAKER (still needed?) (if (and (null? tal)(null? reg)) (list hed tal (append reg (list hed)) reruns) @@ -746,11 +771,11 @@ ;; This is the final stage, everything is in place so launch the test ;; ((and have-resources (or (null? prereqs-not-met) - (and (eq? testmode 'toplevel) + (and (member 'toplevel testmode) ;; 'toplevel) (null? non-completed)))) ;; (hash-table-delete! *max-tries-hash* (db:test-make-full-name test-name item-path)) ;; we are going to reset all the counters for test retries by setting a new hash table ;; this means they will increment only when nothing can be run (set! *max-tries-hash* (make-hash-table)) @@ -779,11 +804,12 @@ (if (and (not (null? prereqs-not-met)) (runs:lownoise (conc "waiting on tests " prereqs-not-met hed) 60)) (debug:print-info 1 "waiting on tests; " (string-intersperse (runs:mixed-list-testname-and-testrec->list-of-strings prereqs-not-met) ", "))) - (if (null? fails) + (if (or (null? fails) + (member 'toplevel testmode)) (begin ;; couldn't run, take a breather (if (runs:lownoise "Waiting for more work to do..." 60) (debug:print-info 0 "Waiting for more work to do...")) (thread-sleep! 1) @@ -851,11 +877,12 @@ (if (runs:lownoise (conc "FAILED prerequitests and we tried" hed) 60) (debug:print 0 "WARNING: test " hed " has FAILED prerequitests and we've tried at least 10 times to run it. Giving up now.")) ;; (debug:print 0 " prereqs: " prereqs-not-met) (hash-table-set! test-registry hed 'removed) (mt:test-set-state-status-by-testname run-id test-name item-path "NOT_STARTED" "TEN_STRIKES" #f) - (mt:roll-up-pass-fail-counts run-id test-name item-path "FAIL") ;; treat as FAIL + ;; I'm unclear on if this roll up is needed - it may be the root cause of the "all set to FAIL" bug. + (rmt:roll-up-pass-fail-counts run-id test-name item-path #f "FAIL") ;; treat as FAIL (list (if (null? tal)(car newtal)(car tal)) tal reg reruns))))) ;; can't drop this - maybe running? Just keep trying @@ -873,11 +900,11 @@ (if (not (vector? t)) t (let ((state (db:test-get-state t)) (status (db:test-get-status t))) (case (string->symbol state) - ((COMPLETED) #f) + ((COMPLETED INCOMPLETE) #f) ((NOT_STARTED) (if (member status '("TEN_STRIKES" "BLOCKED" "PREQ_FAIL" "ZERO_ITEMS" "PREQ_DISCARDED" "TIMED_OUT" )) #f t)) ((DELETED) #f) @@ -975,11 +1002,11 @@ ;; Ensure all top level tests get registered. This way they show up as "NOT_STARTED" on the dashboard ;; and it is clear they *should* have run but did not. (if (not (hash-table-ref/default test-registry (db:test-make-full-name test-name "") #f)) (begin - (rmt:general-call 'register-test run-id run-id test-name "") + (rmt:register-test run-id test-name "") (hash-table-set! test-registry (db:test-make-full-name test-name "") 'done))) ;; Fast skip of tests that are already "COMPLETED" - NO! Cannot do that as the items may not have been expanded yet :( ;; (if (member (hash-table-ref/default test-registry tfullname #f) @@ -1152,11 +1179,11 @@ (debug:print-info 1 "All tests launched"))) (define (runs:calc-fails prereqs-not-met) (filter (lambda (test) (and (vector? test) ;; not (string? test)) - (equal? (db:test-get-state test) "COMPLETED") + (member (db:test-get-state test) '("INCOMPLETE" "COMPLETED")) (not (member (db:test-get-status test) '("PASS" "WARN" "CHECK" "WAIVED" "SKIP"))))) prereqs-not-met)) (define (runs:calc-prereq-fail prereqs-not-met) @@ -1169,19 +1196,19 @@ (define (runs:calc-not-completed prereqs-not-met) (filter (lambda (t) (or (not (vector? t)) - (not (equal? "COMPLETED" (db:test-get-state t))))) + (not (member (db:test-get-state t) '("INCOMPLETE" "COMPLETED"))))) prereqs-not-met)) -(define (runs:calc-not-completed prereqs-not-met) - (filter - (lambda (t) - (or (not (vector? t)) - (not (equal? "COMPLETED" (db:test-get-state t))))) - prereqs-not-met)) +;; (define (runs:calc-not-completed prereqs-not-met) +;; (filter +;; (lambda (t) +;; (or (not (vector? t)) +;; (not (equal? "COMPLETED" (db:test-get-state t))))) +;; prereqs-not-met)) (define (runs:calc-runnable prereqs-not-met) (filter (lambda (t) (or (not (vector? t)) @@ -1257,11 +1284,11 @@ ;; (if (not test-id)(set! test-id (rmt:get-test-id run-id test-name item-path))) (if (not test-id) (begin (debug:print 2 "WARN: Test not pre-created? test-name=" test-name ", item-path=" item-path ", run-id=" run-id) - (rmt:general-call 'register-test run-id run-id test-name item-path) + (rmt:register-test run-id test-name item-path) (set! test-id (rmt:get-test-id run-id test-name item-path)))) (debug:print-info 4 "test-id=" test-id ", run-id=" run-id ", test-name=" test-name ", item-path=\"" item-path "\"") (set! testdat (rmt:get-test-info-by-id run-id test-id)) (if (not testdat) (begin @@ -1281,17 +1308,17 @@ (if testdat (string->symbol (test:get-state testdat)) 'failed-to-insert)) ((failed-to-insert) (debug:print 0 "ERROR: Failed to insert the record into the db")) - ((NOT_STARTED COMPLETED DELETED) + ((NOT_STARTED COMPLETED DELETED INCOMPLETE) (let ((runflag #f)) (cond ;; -force, run no matter what (force (set! runflag #t)) ;; NOT_STARTED, run no matter what - ((member (test:get-state testdat) '("DELETED" "NOT_STARTED"))(set! runflag #t)) + ((member (test:get-state testdat) '("DELETED" "NOT_STARTED" "INCOMPLETE"))(set! runflag #t)) ;; not -rerun and PASS, WARN or CHECK, do no run ((and (or (not rerun) keepgoing) ;; Require to force re-run for COMPLETED or *anything* + PASS,WARN or CHECK (or (member (test:get-status testdat) '("PASS" "WARN" "CHECK" "SKIP" "WAIVED")) @@ -1345,11 +1372,11 @@ ((and skip-check (configf:lookup test-conf "skip" "rundelay")) ;; run-ids = #f means *all* runs (let* ((numseconds (common:hms-string->seconds (configf:lookup test-conf "skip" "rundelay"))) (running-tests (rmt:get-tests-for-runs-mindata #f full-test-name '("RUNNING" "REMOTEHOSTSTART" "LAUNCHED") '() #f)) - (completed-tests (rmt:get-tests-for-runs-mindata #f full-test-name '("COMPLETED") '("PASS" "FAIL" "ABORT") #f)) + (completed-tests (rmt:get-tests-for-runs-mindata #f full-test-name '("COMPLETED" "INCOMPLETE") '("PASS" "FAIL" "ABORT") #f)) ;; ironically INCOMPLETE is same as COMPLETED in this contex (last-run-times (map db:mintest-get-event_time completed-tests)) (time-since-last (- (current-seconds) (if (null? last-run-times) 0 (apply max last-run-times))))) (if (or (not (null? running-tests)) ;; have to skip if test is running (> numseconds time-since-last)) (set! skip-test (conc "Skipping due to previous test run less than " (configf:lookup test-conf "skip" "rundelay") " ago")))))) Index: tasks.scm ================================================================== --- tasks.scm +++ tasks.scm @@ -497,17 +497,17 @@ (set! deadlist (cons id deadlist))) mdb "SELECT id,pid,hostname,last_update,strftime('%s','now')-last_update AS delta FROM monitors WHERE delta > 700;") (sqlite3:execute mdb (conc "DELETE FROM monitors WHERE id IN ('" (string-intersperse (map conc deadlist) "','") "');"))) ) -(define (tasks:register-monitor db mdb) +(define (tasks:register-monitor db port) (let* ((pid (current-process-id)) (hostname (get-host-name)) (userinfo (user-information (current-user-id))) (username (car userinfo))) - (print "Register monitor, pid: " pid ", hostname: " hostname ", username: " username) - (sqlite3:execute mdb "INSERT INTO monitors (pid,start_time,last_update,hostname,username) VALUES (?,strftime('%s','now'),strftime('%s','now'),?,?);" + (print "Register monitor, pid: " pid ", hostname: " hostname ", port: " port ", username: " username) + (sqlite3:execute db "INSERT INTO monitors (pid,start_time,last_update,hostname,username) VALUES (?,strftime('%s','now'),strftime('%s','now'),?,?);" pid hostname username))) (define (tasks:get-num-alive-monitors mdb) (let ((res 0)) (sqlite3:for-each-row Index: tdb.scm ================================================================== --- tdb.scm +++ tdb.scm @@ -40,10 +40,14 @@ ;;====================================================================== ;; T E S T S P E C I F I C D B ;;====================================================================== ;; Create the sqlite db for the individual test(s) +;; +;; Moved these tables into .db +;; THIS CODE TO BE REMOVED +;; (define (open-test-db work-area) (debug:print-info 11 "open-test-db " work-area) (if (and work-area (directory? work-area) (file-read-access? work-area)) @@ -169,10 +173,12 @@ val TEXT, ackstate INTEGER DEFAULT 0, CONSTRAINT metadat_constraint UNIQUE (var));")))) (debug:print 11 "db:testdb-initialize END")) +;; This routine moved to db:read-test-data +;; (define (tdb:read-test-data tdb test-id categorypatt) (let ((res '())) (sqlite3:for-each-row (lambda (id test_id category variable value expected tol units comment status type) (set! res (cons (vector id test_id category variable value expected tol units comment status type) res))) @@ -221,10 +227,12 @@ (define (tdb:step-get-time-as-string vec) (seconds->time-string (tdb:step-get-event_time vec))) ;; get a pretty table to summarize steps +;; +;; NOT USED, WILL BE REMOVED ;; (define (tdb:get-steps-table steps);; organise the steps for better readability (let ((res (make-hash-table))) (for-each (lambda (step) Index: testnanomsg/req-rep-client.scm ================================================================== --- testnanomsg/req-rep-client.scm +++ testnanomsg/req-rep-client.scm @@ -1,7 +1,7 @@ ;; watch nanomsg's pipeline load-balancer in action. -(use nanomsg) +(use nanomsg posix regex) (define req (nn-socket 'req)) (nn-connect req "tcp://localhost:22022") @@ -9,14 +9,15 @@ (define (client-send-receive soc msg) (nn-send soc msg) (nn-recv soc)) (define ((talk-to-server soc)) - (let loop ((cnt 20)) + (let loop ((cnt 200000)) (let ((name (list-ref '("Matt" "Tom" "Bob" "Jill" "James" "Jane")(random 6)))) - (print "Sending " name) - (print (client-send-receive req name)) + ;; (print "Sending " name) + ;; (print + (client-send-receive req name) ;; ) (if (> cnt 0)(loop (- cnt 1))))) (print (client-send-receive req "quit")) (nn-close req) (exit)) Index: testnanomsg/req-rep-server.scm ================================================================== --- testnanomsg/req-rep-server.scm +++ testnanomsg/req-rep-server.scm @@ -1,7 +1,7 @@ ;; watch nanomsg's pipeline load-balancer in action. -(use nanomsg) +(use nanomsg posix regex) ;; (use trace) ;; (trace nn-bind nn-socket nn-assert nn-recv nn-send thread-terminate! nn-close ) (define port 22022) @@ -11,25 +11,29 @@ (print "connecting, got: " (nn-bind rep (conc "tcp://" "*" ":" port))) (define (server soc) (print "server starting") - (let loop ((msg-in (nn-recv soc))) - (print "server received: " msg-in) + (let loop ((msg-in (nn-recv soc)) + (count 0)) + (if (eq? 0 (modulo count 1000)) + (print "server received: " msg-in ", count=" count)) (cond ((equal? msg-in "quit") (nn-send soc "Ok, quitting")) ((and (>= (string-length msg-in) 4) (equal? (substring msg-in 0 4) "ping")) (nn-send soc (conc (current-process-id))) - (loop (nn-recv soc))) + (loop (nn-recv soc)(+ count 1))) ;;((and (>= (string-length msg-in) (else - (let ((this-task (random 15))) - (thread-sleep! this-task) + (let ((this-task (/ (random 10) 200.0)) + (start-time (current-milliseconds))) + ;; (thread-sleep! this-task) (nn-send soc (conc "hello " msg-in " this task took " this-task " seconds to complete")) - (loop (nn-recv soc))))))) + ;; (print "Actual send-receive time: " (- (current-milliseconds) start-time)); + (loop (nn-recv soc)(+ count 1))))))) (define (ping-self host port #!key (return-socket #t)) ;; send a random number along with pid and check that we get it back (let* ((req (nn-socket 'req)) (key "ping") Index: testnanomsg/req-rep.scm ================================================================== --- testnanomsg/req-rep.scm +++ testnanomsg/req-rep.scm Index: tests.scm ================================================================== --- tests.scm +++ tests.scm @@ -32,17 +32,26 @@ (include "db_records.scm") (include "run_records.scm") (include "test_records.scm") ;; Call this one to do all the work and get a standardized list of tests +;; gets paths from configs and finds valid tests +;; returns hash of testname --> fullpath +;; (define (tests:get-all) (let* ((test-search-path (tests:get-tests-search-path *configdat*))) (tests:get-valid-tests (make-hash-table) test-search-path))) (define (tests:get-tests-search-path cfgdat) (let ((paths (map cadr (configf:get-section cfgdat "tests-paths")))) - (append paths (list (conc *toppath* "/tests"))))) + (filter (lambda (d) + (if (directory-exists? d) + d + (begin + (debug:print 0 "WARNING: problem with directory " d ", dropping it from tests path") + #f))) + (append paths (list (conc *toppath* "/tests")))))) (define (tests:get-valid-tests test-registry tests-paths) (if (null? tests-paths) test-registry (let loop ((hed (car tests-paths)) @@ -139,11 +148,11 @@ (testconfig (tests:get-testconfig (db:test-get-testname testdat) test-registry #f)) (test-rundir ;; (sdb:qry 'passstr (db:test-get-rundir testdat)) ;; ) (prev-rundir ;; (sdb:qry 'passstr (db:test-get-rundir prev-testdat)) ;; ) - (waivers (configf:section-vars testconfig "waivers")) + (waivers (if testconfig (configf:section-vars testconfig "waivers") '())) (waiver-rx (regexp "^(\\S+)\\s+(.*)$")) (diff-rule "diff %file1% %file2%") (logpro-rule "diff %file1% %file2% | logpro %waivername%.logpro %waivername%.html")) (if (not (file-exists? test-rundir)) (begin @@ -284,11 +293,11 @@ (rmt:csv->test-data run-id test-id dat)))) ;; need to update the top test record if PASS or FAIL and this is a subtest (if (not (equal? item-path "")) - (rmt:roll-up-pass-fail-counts run-id test-name item-path status)) + (rmt:roll-up-pass-fail-counts run-id test-name item-path state status)) (if (or (and (string? comment) (string-match (regexp "\\S+") comment)) waived) (let ((cmt (if waived waived comment))) @@ -320,13 +329,17 @@ force) (let ((my-start-time (current-seconds)) (lockf (conc outputfilename ".lock"))) (let loop ((have-lock (common:simple-file-lock lockf))) (if have-lock - (begin + (let ((script (configf:lookup *configdat* "testrollup" test-name))) (print "Obtained lock for " outputfilename) - (tests:generate-html-summary-for-iterated-test run-id test-id test-name outputfilename) + ;; (rmt:top-test-set-per-pf-counts run-id test-name) + (rmt:roll-up-pass-fail-counts run-id test-name "" #f #f) + (if script + (system (conc script " > " outputfilename " & ")) + (tests:generate-html-summary-for-iterated-test run-id test-id test-name outputfilename)) (common:simple-file-release-lock lockf) (change-directory orig-dir) ;; NB// tests:test-set-toplog! is remote internal... (tests:test-set-toplog! run-id test-name outputfilename)) ;; didn't get the lock, check to see if current update started later than this @@ -583,10 +596,11 @@ ;; (filter (lambda (testname) ;; (tests:match test-patts testname #f)) ;; (map (lambda (testp) ;; (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))) (test-configf (conc test-path "/testconfig")) (testexists (and (file-exists? test-configf)(file-read-access? test-configf))) @@ -670,11 +684,11 @@ (for-each (lambda (waiton) ;; for now we are waiting only on the parent test (let* ((parent-test-id (rmt:get-test-id run-id waiton "")) (wtdat (rmt:get-testinfo-state-status run-id test-id))) ;; (cdb:get-test-info-by-id *runremote* test-id))) (if (or (and (equal? (db:test-get-state wtdat) "COMPLETED") - (member (db:test-get-status wtdat) '("FAIL"))) + (member (db:test-get-status wtdat) '("FAIL" "ABORT"))) (member (db:test-get-status wtdat) '("KILLED")) (member (db:test-get-state wtdat) '("INCOMPETE"))) ;; (if (or (member (db:test-get-status wtdat) ;; '("FAIL" "KILLED")) ;; (member (db:test-get-state wtdat) Index: tests/Makefile ================================================================== --- tests/Makefile +++ tests/Makefile @@ -19,25 +19,31 @@ # The NEWTARGET causes some tests to fail. Do not use until this is fixed. NEWTARGET = "$(OS)/$(FS)/$(VER)" TARGET = "ubuntu/nfs/none" -all : unit test1 test2 test3 test4 test5 test6 test7 test8 test9 +all : build unit test1 test2 test3 test4 test5 test6 test7 test8 test9 + +unit : basicserver.log runs.log misc.log + +rel : + cd release;dashboard -rows 25 & + +## basicserver.log : unittests/basicserver.scm +## script -c "./rununittest.sh basicserver $(DEBUG)" basicserver.log -unit : - ./rununittest.sh basicserver $(DEBUG) +%.log : build unittests/%.scm + script -c "./rununittest.sh $* $(DEBUG)" $*.log + if logpro unit.logpro $*.html < $*.log > /dev/null;then echo ALLPASS;else echo ALLFAIL;mv $*.log $*.log.FAIL;fi server : - cd ..;make -j;make install cd fullrun;$(MEGATEST) -server - -debug $(DEBUG) -run-id $(RUNID) stopserver : - cd ..;make -j && make install cd fullrun;$(MEGATEST) -stop-server 0 repl : - cd ..;make -j && make install cd fullrun;$(MEGATEST) -:b -repl test0 : cleanprep cd simplerun ; $(MEGATEST) -server - -debug $(DEBUG) @@ -149,21 +155,27 @@ done;done;done test11 : cd fullrun;time (for a in 1 2 3 4 5 6 7 8 9 10 1 2 3 4 5 6 7 8 9 10 1 2 3 4 5 6 7 8 9 10 1 2 3 4 5 6 7 8 9 10 ;do (megatest -test-paths -target %/%/% > /dev/null ) & done; wait; ) -minsetup : +build : ../*.scm cd ..;make -j && make install + touch build + +cleanstart : + if killall mtest -v ;then sleep 5;killall mtest -v -9;fi;true + killall mtest -v;if [ ! $$? ];then sleep 5;killall mtest -v -9;fi + +minsetup : build mkdir -p mintest/runs mintest/links cd mintest;$(MEGATEST) -stop-server 0 cd mintest;$(MEGATEST) -server - -debug $(DEBUG) > server.log 2> server.log & sleep 3 cd mintest;$(DASHBOARD) -rows 18 & -cleanprep : ../*.scm Makefile */*.config +cleanprep : ../*.scm Makefile */*.config build mkdir -p fullrun/tmp/mt_runs fullrun/tmp/mt_links /tmp/$(USER)/adisk1 - cd ..;make -j;make install rm -f */logging.db touch cleanprep fullprep : cleanprep cd fullrun;$(MEGATEST) -remove-runs :runname $(RUNNAME)% -target %/%/% -testpatt %/% @@ -173,10 +185,13 @@ cd fullrun && $(BINPATH)/dashboard -rows $(ROWS) & newdashboard : cleanprep cd fullrun && $(BINPATH)/newdashboard & +mdboard : cleanprep + cd fullrun && $(BINPATH)/mdboard & + remove : cd fullrun;$(MEGATEST) -remove-runs :runname $(RUN) -testpatt % -itempatt % :sysname % :fsname % :datapath % clean : rm cleanprep Index: tests/fdktestqa/fdk.config ================================================================== --- tests/fdktestqa/fdk.config +++ tests/fdktestqa/fdk.config @@ -27,10 +27,10 @@ server-query-threshold 0 [jobtools] # launcher nbq -P ch_vp -C SLES11_EM64T_4G -Q /ciaf/fdk -# launcher nbfake -# maxload 4 +launcher nbfake +maxload 4 -launcher bsub -q priority -o $MT_TEST_RUN_DIR/openlava.log +# launcher bsub -q priority -o $MT_TEST_RUN_DIR/openlava.log Index: tests/fdktestqa/testqa/Makefile ================================================================== --- tests/fdktestqa/testqa/Makefile +++ tests/fdktestqa/testqa/Makefile @@ -2,11 +2,11 @@ PATH := $(BINDIR):$(PATH) MEGATEST = $(BINDIR)/megatest DASHBOARD = $(BINDIR)/dashboard NEWDASHBOARD = $(BINDIR)/newdashboard RUNNAME = a - +NUMTESTS = 20 all : $(MEGATEST) -remove-runs -target a/b :runname c -testpatt %/% $(MEGATEST) -runtests % -target a/b :runname c @@ -14,19 +14,20 @@ for tn in a b c d;do \ ($(MEGATEST) -runtests % -target a/b :runname $tn & ) ; \ done bigrun : - $(MEGATEST) -runtests bigrun -target a/bigrun :runname a$(shell date +%V) + NUMTESTS=$(NUMTESTS) $(MEGATEST) -runtests bigrun -target a/bigrun :runname a$(shell date +%V) bigrun2 : - $(MEGATEST) -runtests bigrun2 -target a/bigrun2 :runname a$(shell date +%V) + NUMTESTS=$(NUMTESTS) $(MEGATEST) -runtests bigrun2 -target a/bigrun2 :runname a$(shell date +%V) bigrun3 : - $(MEGATEST) -runtests bigrun3 -target a/bigrun3 :runname $(RUNNAME) + NUMTESTS=$(NUMTESTS) $(MEGATEST) -runtests bigrun3 -target a/bigrun3 :runname $(RUNNAME) dashboard : + mkdir -p ../simpleruns $(DASHBOARD) -rows 20 & newdashboard : $(NEWDASHBOARD) & Index: tests/fullrun/megatest.config ================================================================== --- tests/fullrun/megatest.config +++ tests/fullrun/megatest.config @@ -28,12 +28,14 @@ # and set the dbdir to /var/tmp/$USER/mt_db to enable keeping # the raw db in /var/tmp/$USER # faststart no monitordir #{getenv MT_RUN_AREA_HOME}/db -# dbdir /var/tmp/#{getenv USER}/mt_db -dbdir #{get setup monitordir} +dbdir #{getenv MT_RUN_AREA_HOME}/db + +# sync more aggressively to megatest-db +megatest-db yes # Set launchwait to no to use the more agressive code that does not wait for the launch to complete before proceeding # this may save a few milliseconds on launching tests # launchwait no waivercommentpatt ^WW\d+ [a-z].* @@ -99,10 +101,18 @@ # These are set before all tests, override them # in the testconfig [pre-launch-env-overrides] section [env-override] + +ALL_TOPLEVEL_TESTS exit_0 exit_1 ez_exit2_fail ez_fail ez_pass ezlog_fail \ + ezlog_fail_then_pass ezlog_pass ezlog_warn lineitem_fail lineitem_pass logpro_required_fail \ + manual_example neverrun priority_1 priority_10 priority_10_waiton_1 \ + priority_3 priority_4 priority_5 priority_6 priority_7 priority_8 \ + priority_9 runfirst singletest singletest2 sqlitespeed test_mt_vars \ + ez_fail_quick test1 test2 + # This variable is honored by the loadrunner script. The value is in percent MAX_ALLOWED_LOAD 200 # MT_XTERM_CMD overrides the terminal command # MT_XTERM_CMD xterm -bg lightgreen -fg black @@ -132,10 +142,13 @@ # XTERM [system xterm] # RUNDEAD [system exit 56] [server] + +# force use of server always +required yes # Use http instead of direct filesystem access transport http # transport fs # transport nmsg @@ -150,15 +163,16 @@ # Three minutes is 0.05 hours # timeout 0.025 timeout 0.061 # faststart; unless no, start server but proceed with writes until server started -faststart yes +faststart no +# faststart yes # Start server when average query takes longer than this # server-query-threshold 55500 -server-query-threshold 100 +server-query-threshold 1000 timeout 0.01 # daemonize yes # hostname #{scheme (get-host-name)} @@ -215,18 +229,31 @@ # /// disk0 /tmp/#{getenv USER}/adisk1 # Uncomment these to emulate a job queue with a long time (look in bin/sleeprunner for the time) [jobtools] -launcher #{scheme (case (string->symbol (conc (getenv "datapath"))) \ - ((none) "nbfake") \ - ((openlava) "bsub") \ - (else "sleeprunner"))} +# launcher #{ scheme (case (string->symbol (conc (getenv "datapath"))) \ +# ((none) "nbfake") \ +# ((openlava) "bsub") \ +# (else "sleeprunner"))} # launcher bsub -q priority -o $MT_TEST_RUN_DIR/openlava.log + +# launcher #{shell if which bsub > /dev/null;then echo bsub -q priority -o openlava.log;else echo sleeprunner;fi} +launcher nbfake [configf:settings trim-trailing-spaces yes] + +# Override the rollup for specific tests +[testrollup] +runfirst ls [test] # VAL1 has trailing spaces VAL1 Foo VAL2 ==>#{get test VAL1}Bar<== no spaces between Foo and Bar to pass + +ltest #{scheme (case (string->symbol (conc (getenv "datapath"))) \ + ((none) "nbfake") \ + ((openlava) "bsub") \ + (else "sleeprunner"))} + Index: tests/fullrun/tests/all_toplevel/calcresults.logpro ================================================================== --- tests/fullrun/tests/all_toplevel/calcresults.logpro +++ tests/fullrun/tests/all_toplevel/calcresults.logpro @@ -13,13 +13,13 @@ ("priority_1" 1 20) ("priority_10" 1 20) ("priority_10_waiton_1" 1 20) ("priority_3" 1 20) ("priority_4" 1 20) - ("priority_5" 1 20) + ;; ("priority_5" 1 20) ("priority_6" 1 20) - ("priority_7" 1 20) +;; ("priority_7" 1 20) ("priority_8" 1 20) ("priority_9" 1 20) ("runfirst" 7 20) ("singletest" 1 20) ("singletest2" 1 20) @@ -40,15 +40,17 @@ ("logpro_required_fail" 1 20) ("manual_example" 1 20) ("neverrun" 1 20))) (define warn-specs '(("ezlog_warn" 1 20))) + (define nost-specs '(("wait_no_items1" 1 20) ("wait_no_items2" 1 20) ("wait_no_items3" 1 20) ("wait_no_items4" 1 20) - ("no_items" 1 20))) + ;; ("no_items" 1 20) + )) (define (check-one-test estate estatus testname count runtime) (let* ((rxe (regexp (conc "^\\s+Test: " testname "(\\(.*|\\s+)\\s+State: " estate "\\s+Status: " estatus "\\s+Runtime:\\s+(\\d+)s"))) (msg1 (conc testname " expecting count of " count)) (msg2 (conc testname " expecting runtime less than " runtime))) @@ -56,14 +58,19 @@ ;;(expect:value in logbody count < msg2 rxe) )) ;; Special cases ;; +(expect:ignore in logbody >= 0 "db_sync test might not have run" #/Test: db_sync/) (expect:ignore in logbody >= 0 "all_toplevel may not yet be done" #/Test: all_toplevel/) (expect:error in logbody = 0 "tests left in RUNNING state" #/State: RUNNING/) -(expect:required in logbody = 1 "priority_2 is KILLED" #/Test: priority_2\s+State: KILLED\s+Status: FAIL/) +(expect:required in logbody = 1 "priority_2 is KILLED" #/Test: priority_2\s+State: KILLED\s+Status: KILLED/) +(expect:required in logbody = 1 "priority_5 is either PASS or SKIP" #/Test: priority_5\s+State: COMPLETED\s+Status: (SKIP|PASS)/) +(expect:required in logbody = 1 "priority_7 is either PASS or SKIP" #/Test: priority_7\s+State: COMPLETED\s+Status: (SKIP|PASS)/) (expect:required in logbody = 1 "testxz has 1 NOT_STARTED test" #/Test: testxz\s+State: NOT_STARTED/) +(expect:required in logbody = 1 "no items" #/Test: no_items\s+State: NOT_STARTED\s+Status: ZERO_ITEMS/) +(expect:warning in logbody = 1 "dynamic waiton" #/Test: dynamic_waiton/) (expect:required in logbody = 29 "blocktestxz has 29 tests" #/Test: blocktestxz/) ;; General cases ;; (for-each @@ -81,11 +88,11 @@ (apply check-one-test "COMPLETED" "WARN" testdat)) warn-specs) (for-each (lambda (testdat) - (apply check-one-test "NOT_STARTED" "n/a" testdat)) + (apply check-one-test "NOT_STARTED" "PREQ_DISCARDED" testdat)) nost-specs) ;; Catch all. ;; (expect:error in logbody = 0 "Tests not accounted for" #/Test: /) Index: tests/fullrun/tests/all_toplevel/testconfig ================================================================== --- tests/fullrun/tests/all_toplevel/testconfig +++ tests/fullrun/tests/all_toplevel/testconfig @@ -1,13 +1,8 @@ [ezsteps] calcresults megatest -list-runs $MT_RUNNAME -target $MT_TARGET [requirements] -waiton all_toplevel exit_0 exit_1 ez_exit2_fail ez_fail ez_pass ezlog_fail \ - ezlog_fail_then_pass ezlog_pass ezlog_warn lineitem_fail lineitem_pass logpro_required_fail \ - manual_example neverrun priority_1 priority_10 priority_10_waiton_1 priority_2 \ - priority_3 priority_4 priority_5 priority_6 priority_7 priority_8 \ - priority_9 runfirst singletest singletest2 sqlitespeed test_mt_vars \ - ez_fail_quick test1 test2 special blocktestxz +waiton #{getenv ALL_TOPLEVEL_TESTS} # This is a "toplevel" test, it does not require waitons to be non-FAIL to run mode toplevel ADDED tests/fullrun/tests/db_sync/calcresults.logpro Index: tests/fullrun/tests/db_sync/calcresults.logpro ================================================================== --- /dev/null +++ tests/fullrun/tests/db_sync/calcresults.logpro @@ -0,0 +1,44 @@ +;; (c) 2006,2007,2008,2009 Matthew Welland matt@kiatoa.com +;; +;; License GPL. + +;; ;; define your hooks +;; (hook:first-error "echo \"Error hook activated: #{escaped errmsg}\"") +;; (hook:first-warning "echo \"Got warning: #{escaped warnmsg}\"") +;; (hook:value "echo \"Value hook activated: expected=#{expected}, measured=#{measured}, tolerance=#{tolerance}, message=#{message}\"") +;; +;; ;; first ensure your run at least started +;; ;; +;; (trigger "Init" #/This is a header/) +;; (trigger "InitEnd" #/^\s*$/) +;; (section "Init" "Init" "InitEnd") +;; +;; (trigger "Body" #/^.*$/) ;; anything starts the body +;; ;; (trigger "EndBody" #/This had better never match/) +;; +;; (section "Body" "Body" "EndBody") +;; +;; (trigger "Blah2" #/^begin Blah2/) +;; (trigger "Blah2End" #/^end Blah2/) +;; (section "Blah2" "Blah2" "Blah2End") +;; +;; (expect:required in "Init" = 1 "Header" #/This is a header/) +;; (expect:required in "LogFileBody" > 0 "Something required but not found" #/This is required but not found/) +;; (expect:value in "LogFileBody" 1.9 0.1 "Output voltage" #/Measured voltage output:\s*([\d\.\+\-e]+)v/) +;; (expect:value in "LogFileBody" 0.5 0.1 "Output current" #/Measured output current:\s*([\d\.\+\-e]+)mA/) +;; (expect:value in "LogFileBody" 110e9 2e9 "A big number (first)" #/Freq:\s*([\d\.\+\-e]+)\s+Hz/) +;; (expect:value in "LogFileBody" 110e9 1e9 "A big number (second), hook not called" #/Freq:\s*([\d\.\+\-e]+)Hz/) +;; (expect:value in "LogFileBody" 110e9 1e9 "A big number (never activated)" #/Freq:\s*([\d\.\+\-e]+)zH/) +;; +;; ;; Using match number +;; (expect:value in "LogFileBody" 1.9 0.1 "Time Voltage" #/out: (\d+)\s+(\d+)/ match: 2) +;; +;; ;; Comparison instead of tolerance +;; (expect:value in "LogFileBody" 1.9 > "Time voltage" #/out: (\d+)\s+(\d+)/ match: 2) +;; +;; (expect:ignore in "Blah2" < 99 "FALSE ERROR" #/ERROR/) +;; (expect:ignore in "Body" < 99 "Ignore the word error in comments" #/^\/\/.*error/) +;; (expect:warning in "Body" = 0 "Any warning" #/WARNING/) +;; (expect:error in "Body" = 0 "ERROR BLAH" (list #/ERROR/ #/error/)) ;; but disallow any other errors +;; +;; ;(expect in "Init" < 1 "Junk" #/This is bogus/) ADDED tests/fullrun/tests/db_sync/dbdelta.scm Index: tests/fullrun/tests/db_sync/dbdelta.scm ================================================================== --- /dev/null +++ tests/fullrun/tests/db_sync/dbdelta.scm @@ -0,0 +1,44 @@ + +(use sql-de-lite) + +(define megatest.db (conc (get-environment-variable "MT_RUN_AREA_HOME") "/megatest.db")) + +(define runsquery "sysname||'/'||fsname||'/'||datapath||'/'||runname||'/'||runs.state||'-'||runs.status") +(define bigquery + (conc + "SELECT " runsquery "||testname||'/'||item_path||'-'||'-'||tests.state||'-'||tests.status||'-'||runs.id AS outdat FROM runs INNER JOIN tests ON runs.id=tests.run_id WHERE runs.state NOT LIKE 'deleted' AND tests.state NOT LIKE 'deleted' AND testname NOT LIKE 'db_sync' ORDER BY outdat ASC ;")) + +(print "Creating file for legacy db") +(with-output-to-file "legacy-db-dump" + (lambda () + (let ((db (open-database megatest.db))) + (query (for-each-row + (lambda (res) + (print res))) + (sql db bigquery)) + (close-database db)))) + +(define main.db (conc (get-environment-variable "MT_DBDIR") "/main.db")) + +(print "Creating file for current db") +(with-output-to-file "current-db-dump" + (lambda () + (let* ((mdb (open-database main.db)) + (run-ids (query fetch-column (sql mdb (conc "select id," runsquery " AS rq from runs ORDER BY rq ASC;")))) + (dbdir (get-environment-variable "MT_DBDIR"))) + (for-each + (lambda (rid) + (let ((dbfile (conc dbdir "/" rid ".db"))) + (if (file-exists? dbfile) + (begin + (exec (sql mdb (conc "ATTACH DATABASE '" dbfile "' AS testsdb;"))) + (query (for-each-row + (lambda (res) + (print res))) + (sql mdb bigquery)) + (exec (sql mdb "DETACH DATABASE testsdb;"))) + (print "ERROR: No file " dbfile " found")))) + run-ids) + (close-database mdb)))) + + ADDED tests/fullrun/tests/db_sync/getdbdir.scm Index: tests/fullrun/tests/db_sync/getdbdir.scm ================================================================== --- /dev/null +++ tests/fullrun/tests/db_sync/getdbdir.scm @@ -0,0 +1,1 @@ +(db:dbfile-path #f) ADDED tests/fullrun/tests/db_sync/showdiff.logpro Index: tests/fullrun/tests/db_sync/showdiff.logpro ================================================================== --- /dev/null +++ tests/fullrun/tests/db_sync/showdiff.logpro @@ -0,0 +1,46 @@ +;; (c) 2006,2007,2008,2009 Matthew Welland matt@kiatoa.com +;; +;; License GPL. + +;; ;; define your hooks +;; (hook:first-error "echo \"Error hook activated: #{escaped errmsg}\"") +;; (hook:first-warning "echo \"Got warning: #{escaped warnmsg}\"") +;; (hook:value "echo \"Value hook activated: expected=#{expected}, measured=#{measured}, tolerance=#{tolerance}, message=#{message}\"") +;; +;; ;; first ensure your run at least started +;; ;; +;; (trigger "Init" #/This is a header/) +;; (trigger "InitEnd" #/^\s*$/) +;; (section "Init" "Init" "InitEnd") +;; +;; (trigger "Body" #/^.*$/) ;; anything starts the body +;; ;; (trigger "EndBody" #/This had better never match/) +;; +;; (section "Body" "Body" "EndBody") +;; +;; (trigger "Blah2" #/^begin Blah2/) +;; (trigger "Blah2End" #/^end Blah2/) +;; (section "Blah2" "Blah2" "Blah2End") +;; +;; (expect:required in "Init" = 1 "Header" #/This is a header/) +;; (expect:required in "LogFileBody" > 0 "Something required but not found" #/This is required but not found/) +;; (expect:value in "LogFileBody" 1.9 0.1 "Output voltage" #/Measured voltage output:\s*([\d\.\+\-e]+)v/) +;; (expect:value in "LogFileBody" 0.5 0.1 "Output current" #/Measured output current:\s*([\d\.\+\-e]+)mA/) +;; (expect:value in "LogFileBody" 110e9 2e9 "A big number (first)" #/Freq:\s*([\d\.\+\-e]+)\s+Hz/) +;; (expect:value in "LogFileBody" 110e9 1e9 "A big number (second), hook not called" #/Freq:\s*([\d\.\+\-e]+)Hz/) +;; (expect:value in "LogFileBody" 110e9 1e9 "A big number (never activated)" #/Freq:\s*([\d\.\+\-e]+)zH/) +;; +;; ;; Using match number +;; (expect:value in "LogFileBody" 1.9 0.1 "Time Voltage" #/out: (\d+)\s+(\d+)/ match: 2) +;; +;; ;; Comparison instead of tolerance +;; (expect:value in "LogFileBody" 1.9 > "Time voltage" #/out: (\d+)\s+(\d+)/ match: 2) +;; +;; (expect:ignore in "Blah2" < 99 "FALSE ERROR" #/ERROR/) +;; (expect:ignore in "Body" < 99 "Ignore the word error in comments" #/^\/\/.*error/) +;; (expect:warning in "Body" = 0 "Any warning" #/WARNING/) +;; (expect:error in "Body" = 0 "ERROR BLAH" (list #/ERROR/ #/error/)) ;; but disallow any other errors +;; +;; ;(expect in "Init" < 1 "Junk" #/This is bogus/) + +(expect:error in "LogFileBody" = 0 "Any diff is failure" #/.+/) ADDED tests/fullrun/tests/db_sync/testconfig Index: tests/fullrun/tests/db_sync/testconfig ================================================================== --- /dev/null +++ tests/fullrun/tests/db_sync/testconfig @@ -0,0 +1,13 @@ +[pre-launch-env-vars] + +MT_DBDIR #{scheme (db:dbfile-path #f)} + +[ezsteps] +calcresults csi -b dbdelta.scm +showdiff diff current-db-dump legacy-db-dump + +[requirements] +waiton #{getenv ALL_TOPLEVEL_TESTS} + +# This is a "toplevel" test, it does not require waitons to be non-FAIL to run +mode toplevel Index: tests/fullrun/tests/priority_1/testconfig ================================================================== --- tests/fullrun/tests/priority_1/testconfig +++ tests/fullrun/tests/priority_1/testconfig @@ -10,5 +10,8 @@ owner bob description This test checks that a multi-lineitem test with mix of pass and non-fail rolls up a PASS tags first,single reviewed 09/10/2011, by Matt + +[triggers] +COMPLETED/ echo $MT_TEST_NAME > $MT_RUN_AREA_HOME/foo ADDED tests/release/Makefile Index: tests/release/Makefile ================================================================== --- /dev/null +++ tests/release/Makefile @@ -0,0 +1,10 @@ + + +dashboard : compile + dashboard -rows 24 & + +compile : runs + cd ../..;make -j install + +runs : + mkdir -p runs ADDED tests/release/megatest.config Index: tests/release/megatest.config ================================================================== --- /dev/null +++ tests/release/megatest.config @@ -0,0 +1,22 @@ +[fields] +release TEXT +iteration TEXT + +[setup] +linktree #{getenv MT_RUN_AREA_HOME}/links +max_concurrent_jobs 100 +logviewer (%MTCMD%) 2> /dev/null > /dev/null +# htmlviewercmd firefox -new-window +htmlviewercmd arora + +[jobtools] +# launcher #{shell if which bsub > /dev/null;then echo bsub;else echo nbfake;fi} +launcher nbfake +maxload 2.5 + +[server] +required yes + +[disks] +disk0 #{getenv MT_RUN_AREA_HOME}/runs + ADDED tests/release/runconfigs.config Index: tests/release/runconfigs.config ================================================================== --- /dev/null +++ tests/release/runconfigs.config @@ -0,0 +1,9 @@ +[default] +MTRUNNER #{shell readlink -f #{getenv MT_RUN_AREA_HOME}/../../utils/mtrunner} +MTTESTDIR #{shell readlink -f #{getenv MT_RUN_AREA_HOME}/..} +MTPATH #{shell readlink -f #{getenv MT_RUN_AREA_HOME}/../../bin} + +[v1.60/15] + +[include atwork.config] + ADDED tests/release/tests/fullrun/results.logpro Index: tests/release/tests/fullrun/results.logpro ================================================================== --- /dev/null +++ tests/release/tests/fullrun/results.logpro @@ -0,0 +1,140 @@ +;; (c) 2006,2007,2008,2009 Matthew Welland matt@kiatoa.com +;; +;; License GPL. + +(define logbody "LogFileBody") + +(define pass-specs '( ;; testname num-expected max-runtime + ("exit_0" 1 20) + ("ezlog_fail_then_pass" 1 20) + ("ezlog_pass" 1 20) + ("ez_pass" 1 20) + ("lineitem_pass" 1 20) + ("priority_1" 1 20) + ("priority_10" 1 20) + ("priority_10_waiton_1" 1 20) + ("priority_3" 1 20) + ("priority_4" 1 20) + ;; ("priority_5" 1 20) + ("priority_6" 1 20) +;; ("priority_7" 1 20) + ("priority_8" 1 20) + ("priority_9" 1 20) + ("runfirst" 7 20) + ("singletest" 1 20) + ("singletest2" 1 20) + ("special" 1 20) + ("sqlitespeed" 10 20) + ("test1" 1 20) + ("test2" 6 20) + ("test_mt_vars" 6 20) + )) + +(define fail-specs '( ;; testname num-expected max-runtime + ("exit_1" 1 20) + ("ez_exit2_fail" 1 20) + ("ez_fail" 1 20) + ("ez_fail_quick" 1 20) + ("ezlog_fail" 1 20) + ("lineitem_fail" 1 20) + ("logpro_required_fail" 1 20) + ("manual_example" 1 20) + ("neverrun" 1 20))) + +(define warn-specs '(("ezlog_warn" 1 20))) + +(define nost-specs '(("wait_no_items1" 1 20) + ("wait_no_items2" 1 20) + ("wait_no_items3" 1 20) + ("wait_no_items4" 1 20) + ;; ("no_items" 1 20) + )) + +(define (check-one-test estate estatus testname count runtime) + (let* ((rxe (regexp (conc "^\\s+Test: " testname "(\\(.*|\\s+)\\s+State: " estate "\\s+Status: " estatus "\\s+Runtime:\\s+(\\d+)s"))) + (msg1 (conc testname " expecting count of " count)) + (msg2 (conc testname " expecting runtime less than " runtime))) + (expect:required in logbody = count msg1 rxe) + ;;(expect:value in logbody count < msg2 rxe) + )) + +;; Special cases +;; +(expect:ignore in logbody >= 0 "db_sync test might not have run" #/Test: db_sync/) +(expect:ignore in logbody >= 0 "all_toplevel may not yet be done" #/Test: all_toplevel/) +(expect:error in logbody = 0 "tests left in RUNNING state" #/State: RUNNING/) +(expect:required in logbody = 1 "priority_2 is KILLED" #/Test: priority_2\s+State: KILLED\s+Status: KILLED/) +(expect:required in logbody = 1 "priority_5 is either PASS or SKIP" #/Test: priority_5\s+State: COMPLETED\s+Status: (SKIP|PASS)/) +(expect:required in logbody = 1 "priority_7 is either PASS or SKIP" #/Test: priority_7\s+State: COMPLETED\s+Status: (SKIP|PASS)/) +(expect:required in logbody = 1 "testxz has 1 NOT_STARTED test" #/Test: testxz\s+State: NOT_STARTED/) +(expect:required in logbody = 1 "no items" #/Test: no_items\s+State: NOT_STARTED\s+Status: ZERO_ITEMS/) +(expect:warning in logbody = 1 "dynamic waiton" #/Test: dynamic_waiton/) +(expect:required in logbody = 29 "blocktestxz has 29 tests" #/Test: blocktestxz/) + +;; General cases +;; +(for-each + (lambda (testdat) + (apply check-one-test "COMPLETED" "PASS" testdat)) + pass-specs) + +(for-each + (lambda (testdat) + (apply check-one-test "COMPLETED" "FAIL" testdat)) + fail-specs) + +(for-each + (lambda (testdat) + (apply check-one-test "COMPLETED" "WARN" testdat)) + warn-specs) + +(for-each + (lambda (testdat) + (apply check-one-test "NOT_STARTED" "PREQ_DISCARDED" testdat)) + nost-specs) + +;; Catch all. +;; +(expect:error in logbody = 0 "Tests not accounted for" #/Test: /) + + +;; ;; define your hooks +;; (hook:first-error "echo \"Error hook activated: #{escaped errmsg}\"") +;; (hook:first-warning "echo \"Got warning: #{escaped warnmsg}\"") +;; (hook:value "echo \"Value hook activated: expected=#{expected}, measured=#{measured}, tolerance=#{tolerance}, message=#{message}\"") +;; +;; ;; first ensure your run at least started +;; ;; +;; (trigger "Init" #/This is a header/) +;; (trigger "InitEnd" #/^\s*$/) +;; (section "Init" "Init" "InitEnd") +;; +;; (trigger "Body" #/^.*$/) ;; anything starts the body +;; ;; (trigger "EndBody" #/This had better never match/) +;; +;; (section "Body" "Body" "EndBody") +;; +;; (trigger "Blah2" #/^begin Blah2/) +;; (trigger "Blah2End" #/^end Blah2/) +;; (section "Blah2" "Blah2" "Blah2End") +;; +;; (expect:required in "Init" = 1 "Header" #/This is a header/) +;; (expect:required in "LogFileBody" > 0 "Something required but not found" #/This is required but not found/) +;; (expect:value in "LogFileBody" 1.9 0.1 "Output voltage" #/Measured voltage output:\s*([\d\.\+\-e]+)v/) +;; (expect:value in "LogFileBody" 0.5 0.1 "Output current" #/Measured output current:\s*([\d\.\+\-e]+)mA/) +;; (expect:value in "LogFileBody" 110e9 2e9 "A big number (first)" #/Freq:\s*([\d\.\+\-e]+)\s+Hz/) +;; (expect:value in "LogFileBody" 110e9 1e9 "A big number (second), hook not called" #/Freq:\s*([\d\.\+\-e]+)Hz/) +;; (expect:value in "LogFileBody" 110e9 1e9 "A big number (never activated)" #/Freq:\s*([\d\.\+\-e]+)zH/) +;; +;; ;; Using match number +;; (expect:value in "LogFileBody" 1.9 0.1 "Time Voltage" #/out: (\d+)\s+(\d+)/ match: 2) +;; +;; ;; Comparison instead of tolerance +;; (expect:value in "LogFileBody" 1.9 > "Time voltage" #/out: (\d+)\s+(\d+)/ match: 2) +;; +;; (expect:ignore in "Blah2" < 99 "FALSE ERROR" #/ERROR/) +;; (expect:ignore in "Body" < 99 "Ignore the word error in comments" #/^\/\/.*error/) +;; (expect:warning in "Body" = 0 "Any warning" #/WARNING/) +;; (expect:error in "Body" = 0 "ERROR BLAH" (list #/ERROR/ #/error/)) ;; but disallow any other errors +;; +;; ;(expect in "Init" < 1 "Junk" #/This is bogus/) ADDED tests/release/tests/fullrun/testconfig Index: tests/release/tests/fullrun/testconfig ================================================================== --- /dev/null +++ tests/release/tests/fullrun/testconfig @@ -0,0 +1,11 @@ +[ezsteps] +cleantop $MTRUNNER $MTTESTDIR/fullrun $MTPATH megatest -remove-runs -target ubuntu/nfs/none -runname release_toplevel -testpatt % +runall $MTRUNNER $MTTESTDIR/fullrun $MTPATH megatest -run -testpatt % -target ubuntu/nfs/none -runname release_toplevel -runwait +runtop $MTRUNNER $MTTESTDIR/fullrun $MTPATH megatest -run -testpatt all_toplevel -target ubuntu/nfs/none -runname release_toplevel -rerun FAIL -preclean -runwait +results $MTRUNNER $MTTESTDIR/fullrun $MTPATH megatest -list-runs release_toplevel -target ubuntu/nfs/none -runname release_toplevel + +[requirements] +# waiton #{getenv ALL_TOPLEVEL_TESTS} + +# This is a "toplevel" test, it does not require waitons to be non-FAIL to run +# mode toplevel ADDED tests/release/tests/itemwait/testconfig Index: tests/release/tests/itemwait/testconfig ================================================================== --- /dev/null +++ tests/release/tests/itemwait/testconfig @@ -0,0 +1,24 @@ +# test2 from the tests/Makefile + +[var] +tname itemwait + +[pre-launch-env-vars] +NUMTESTS 20 + +[ezsteps] + +# Set things up +clean $MTRUNNER $MTTESTDIR/fdktestqa/testqa $MTPATH megatest -remove-runs -testpatt % -target %/% -runname #{get var tname}% +runbigrun3 $MTRUNNER $MTTESTDIR/fdktestqa/testqa $MTPATH nbfake megatest -run -testpatt bigrun3 -target a/bigrun3 -runname #{get var tname} +# watchrun watches until it sees at least one RUNNING in bigrun and one PASS in bigrun2 +watchrun sleep 15;watchrun.sh #{get var tname} + +[requirements] +# waiton #{getenv ALL_TOPLEVEL_TESTS} + +# This is a "toplevel" test, it does not require waitons to be non-FAIL to run +# mode toplevel + + +# test2 : fullprep ADDED tests/release/tests/itemwait/watchrun.sh Index: tests/release/tests/itemwait/watchrun.sh ================================================================== --- /dev/null +++ tests/release/tests/itemwait/watchrun.sh @@ -0,0 +1,29 @@ +#!/bin/bash + +runname=$1 + +pass=no +alldone=no +while [[ $alldone == no ]];do + sleep 5 + $MTRUNNER $MTTESTDIR/fdktestqa/testqa $MTPATH megatest -list-runs $runname > list-runs.log + bigrun_running=$(cat list-runs.log | egrep 'bigrun\(.*RUNNING'|wc -l) + bigrun2_pass=$(cat list-runs.log | egrep 'bigrun2.*COMPLETED.*PASS'|wc -l) + echo "bigrun_running=$bigrun_running, bigrun2_pass=$bigrun2_pass" + if [[ $bigrun_running -gt 0 ]] && [[ $bigrun2_pass -gt 0 ]];then + pass=yes + alldone=yes + fi + if [[ $bigrun_running -eq 0 ]];then + echo "bigrun all done and no bigrun2 found with PASS." + alldone=yes + fi +done + +if [[ $pass == yes ]];then + echo PASS + exit 0 +else + echo FAIL + exit 1 +fi ADDED tests/release/tests/rollup/firstres.logpro Index: tests/release/tests/rollup/firstres.logpro ================================================================== --- /dev/null +++ tests/release/tests/rollup/firstres.logpro @@ -0,0 +1,144 @@ +;; (c) 2006,2007,2008,2009 Matthew Welland matt@kiatoa.com +;; +;; License GPL. + +(define logbody "LogFileBody") + +(define pass-specs '( ;; testname num-expected max-runtime + ;; ("exit_0" 1 20) + ;; ("ezlog_fail_then_pass" 1 20) + ;; ("ezlog_pass" 1 20) + ;; ("ez_pass" 1 20) + ;; ("lineitem_pass" 1 20) + ;; ("priority_1" 1 20) + ;; ("priority_10" 1 20) + ;; ("priority_10_waiton_1" 1 20) + ;; ("priority_3" 1 20) + ;; ("priority_4" 1 20) + ;; ;; ("priority_5" 1 20) + ;; ("priority_6" 1 20) +;; ;; ("priority_7" 1 20) + ;; ("priority_8" 1 20) + ;; ("priority_9" 1 20) + ("runfirst" 7 20) + ;; ("singletest" 1 20) + ;; ("singletest2" 1 20) + ;; ("special" 1 20) + ;; ("sqlitespeed" 10 20) + ;; ("test1" 1 20) + ;; ("test2" 6 20) + ;; ("test_mt_vars" 6 20) + )) + +(define fail-specs '( ;; testname num-expected max-runtime + ;; ("exit_1" 1 20) + ;; ("ez_exit2_fail" 1 20) + ;; ("ez_fail" 1 20) + ;; ("ez_fail_quick" 1 20) + ;; ("ezlog_fail" 1 20) + ;; ("lineitem_fail" 1 20) + ;; ("logpro_required_fail" 1 20) + ;; ("manual_example" 1 20) + ;; ("neverrun" 1 20) + )) + +(define warn-specs '( + ;; ("ezlog_warn" 1 20) + )) + +(define nost-specs '( + ;; ("wait_no_items1" 1 20) + ;; ("wait_no_items2" 1 20) + ;; ("wait_no_items3" 1 20) + ;; ("wait_no_items4" 1 20) + ;; ("no_items" 1 20) + )) + +(define (check-one-test estate estatus testname count runtime) + (let* ((rxe (regexp (conc "^\\s+Test: " testname "(\\(.*|\\s+)\\s+State: " estate "\\s+Status: " estatus "\\s+Runtime:\\s+(\\d+)s"))) + (msg1 (conc testname " expecting count of " count)) + (msg2 (conc testname " expecting runtime less than " runtime))) + (expect:required in logbody = count msg1 rxe) + ;;(expect:value in logbody count < msg2 rxe) + )) + +;; Special cases +;; +;; (expect:ignore in logbody >= 0 "db_sync test might not have run" #/Test: db_sync/) +;; (expect:ignore in logbody >= 0 "all_toplevel may not yet be done" #/Test: all_toplevel/) +(expect:error in logbody = 0 "tests left in RUNNING state" #/State: RUNNING/) +;; (expect:required in logbody = 1 "priority_2 is KILLED" #/Test: priority_2\s+State: KILLED\s+Status: KILLED/) +;; (expect:required in logbody = 1 "priority_5 is either PASS or SKIP" #/Test: priority_5\s+State: COMPLETED\s+Status: (SKIP|PASS)/) +;; (expect:required in logbody = 1 "priority_7 is either PASS or SKIP" #/Test: priority_7\s+State: COMPLETED\s+Status: (SKIP|PASS)/) +;; (expect:required in logbody = 1 "testxz has 1 NOT_STARTED test" #/Test: testxz\s+State: NOT_STARTED/) +;; (expect:required in logbody = 1 "no items" #/Test: no_items\s+State: NOT_STARTED\s+Status: ZERO_ITEMS/) +;; (expect:warning in logbody = 1 "dynamic waiton" #/Test: dynamic_waiton/) +;; (expect:required in logbody = 29 "blocktestxz has 29 tests" #/Test: blocktestxz/) + +;; General cases +;; +(for-each + (lambda (testdat) + (apply check-one-test "COMPLETED" "PASS" testdat)) + pass-specs) + +(for-each + (lambda (testdat) + (apply check-one-test "COMPLETED" "FAIL" testdat)) + fail-specs) + +(for-each + (lambda (testdat) + (apply check-one-test "COMPLETED" "WARN" testdat)) + warn-specs) + +(for-each + (lambda (testdat) + (apply check-one-test "NOT_STARTED" "PREQ_DISCARDED" testdat)) + nost-specs) + +;; Catch all. +;; +(expect:error in logbody = 0 "Tests not accounted for" #/Test: /) + + +;; ;; define your hooks +;; (hook:first-error "echo \"Error hook activated: #{escaped errmsg}\"") +;; (hook:first-warning "echo \"Got warning: #{escaped warnmsg}\"") +;; (hook:value "echo \"Value hook activated: expected=#{expected}, measured=#{measured}, tolerance=#{tolerance}, message=#{message}\"") +;; +;; ;; first ensure your run at least started +;; ;; +;; (trigger "Init" #/This is a header/) +;; (trigger "InitEnd" #/^\s*$/) +;; (section "Init" "Init" "InitEnd") +;; +;; (trigger "Body" #/^.*$/) ;; anything starts the body +;; ;; (trigger "EndBody" #/This had better never match/) +;; +;; (section "Body" "Body" "EndBody") +;; +;; (trigger "Blah2" #/^begin Blah2/) +;; (trigger "Blah2End" #/^end Blah2/) +;; (section "Blah2" "Blah2" "Blah2End") +;; +;; (expect:required in "Init" = 1 "Header" #/This is a header/) +;; (expect:required in "LogFileBody" > 0 "Something required but not found" #/This is required but not found/) +;; (expect:value in "LogFileBody" 1.9 0.1 "Output voltage" #/Measured voltage output:\s*([\d\.\+\-e]+)v/) +;; (expect:value in "LogFileBody" 0.5 0.1 "Output current" #/Measured output current:\s*([\d\.\+\-e]+)mA/) +;; (expect:value in "LogFileBody" 110e9 2e9 "A big number (first)" #/Freq:\s*([\d\.\+\-e]+)\s+Hz/) +;; (expect:value in "LogFileBody" 110e9 1e9 "A big number (second), hook not called" #/Freq:\s*([\d\.\+\-e]+)Hz/) +;; (expect:value in "LogFileBody" 110e9 1e9 "A big number (never activated)" #/Freq:\s*([\d\.\+\-e]+)zH/) +;; +;; ;; Using match number +;; (expect:value in "LogFileBody" 1.9 0.1 "Time Voltage" #/out: (\d+)\s+(\d+)/ match: 2) +;; +;; ;; Comparison instead of tolerance +;; (expect:value in "LogFileBody" 1.9 > "Time voltage" #/out: (\d+)\s+(\d+)/ match: 2) +;; +;; (expect:ignore in "Blah2" < 99 "FALSE ERROR" #/ERROR/) +;; (expect:ignore in "Body" < 99 "Ignore the word error in comments" #/^\/\/.*error/) +;; (expect:warning in "Body" = 0 "Any warning" #/WARNING/) +;; (expect:error in "Body" = 0 "ERROR BLAH" (list #/ERROR/ #/error/)) ;; but disallow any other errors +;; +;; ;(expect in "Init" < 1 "Junk" #/This is bogus/) ADDED tests/release/tests/rollup/results.logpro Index: tests/release/tests/rollup/results.logpro ================================================================== --- /dev/null +++ tests/release/tests/rollup/results.logpro @@ -0,0 +1,145 @@ +;; (c) 2006,2007,2008,2009 Matthew Welland matt@kiatoa.com +;; +;; License GPL. + +(define logbody "LogFileBody") + +(define pass-specs '( ;; testname num-expected max-runtime + ;; ("exit_0" 1 20) + ;; ("ezlog_fail_then_pass" 1 20) + ;; ("ezlog_pass" 1 20) + ;; ("ez_pass" 1 20) + ;; ("lineitem_pass" 1 20) + ;; ("priority_1" 1 20) + ;; ("priority_10" 1 20) + ;; ("priority_10_waiton_1" 1 20) + ;; ("priority_3" 1 20) + ;; ("priority_4" 1 20) + ;; ;; ("priority_5" 1 20) + ;; ("priority_6" 1 20) +;; ;; ("priority_7" 1 20) + ;; ("priority_8" 1 20) + ;; ("priority_9" 1 20) + ("runfirst" 5 20) + ;; ("singletest" 1 20) + ;; ("singletest2" 1 20) + ;; ("special" 1 20) + ;; ("sqlitespeed" 10 20) + ;; ("test1" 1 20) + ;; ("test2" 6 20) + ;; ("test_mt_vars" 6 20) + )) + +(define fail-specs '( ;; testname num-expected max-runtime + ;; ("exit_1" 1 20) + ;; ("ez_exit2_fail" 1 20) + ;; ("ez_fail" 1 20) + ;; ("ez_fail_quick" 1 20) + ;; ("ezlog_fail" 1 20) + ;; ("lineitem_fail" 1 20) + ;; ("logpro_required_fail" 1 20) + ;; ("manual_example" 1 20) + ;; ("neverrun" 1 20) + )) + +(define warn-specs '( + ;; ("ezlog_warn" 1 20) + )) + +(define nost-specs '( + ;; ("wait_no_items1" 1 20) + ;; ("wait_no_items2" 1 20) + ;; ("wait_no_items3" 1 20) + ;; ("wait_no_items4" 1 20) + ;; ("no_items" 1 20) + )) + +(define (check-one-test estate estatus testname count runtime) + (let* ((rxe (regexp (conc "^\\s+Test: " testname "(\\(.*|\\s+)\\s+State: " estate "\\s+Status: " estatus "\\s+Runtime:\\s+(\\d+)s"))) + (msg1 (conc testname " expecting count of " count)) + (msg2 (conc testname " expecting runtime less than " runtime))) + (expect:required in logbody = count msg1 rxe) + ;;(expect:value in logbody count < msg2 rxe) + )) + +;; Special cases +;; +;; (expect:ignore in logbody >= 0 "db_sync test might not have run" #/Test: db_sync/) +;; (expect:ignore in logbody >= 0 "all_toplevel may not yet be done" #/Test: all_toplevel/) +(expect:error in logbody = 0 "tests left in RUNNING state" #/State: RUNNING/) +;; (expect:required in logbody = 1 "priority_2 is KILLED" #/Test: priority_2\s+State: KILLED\s+Status: KILLED/) +;; (expect:required in logbody = 1 "priority_5 is either PASS or SKIP" #/Test: priority_5\s+State: COMPLETED\s+Status: (SKIP|PASS)/) +;; (expect:required in logbody = 1 "priority_7 is either PASS or SKIP" #/Test: priority_7\s+State: COMPLETED\s+Status: (SKIP|PASS)/) +(expect:required in logbody = 1 "Toplevel will be NOT_STARTED" #/Test: runfirst\s+State: (INCOMPLETE|NOT_STARTED)/) +(expect:required in logbody = 1 "runfirst/b/2 will be NOT_STARTED/INCOMPLETE" #/Test: runfirst.b.2.\s+State: NOT_STARTED\s+Status: INCOMPLETE/) +;; (expect:required in logbody = 1 "no items" #/Test: no_items\s+State: NOT_STARTED\s+Status: ZERO_ITEMS/) +;; (expect:warning in logbody = 1 "dynamic waiton" #/Test: dynamic_waiton/) +;; (expect:required in logbody = 29 "blocktestxz has 29 tests" #/Test: blocktestxz/) + +;; General cases +;; +(for-each + (lambda (testdat) + (apply check-one-test "COMPLETED" "PASS" testdat)) + pass-specs) + +(for-each + (lambda (testdat) + (apply check-one-test "COMPLETED" "FAIL" testdat)) + fail-specs) + +(for-each + (lambda (testdat) + (apply check-one-test "COMPLETED" "WARN" testdat)) + warn-specs) + +(for-each + (lambda (testdat) + (apply check-one-test "NOT_STARTED" "PREQ_DISCARDED" testdat)) + nost-specs) + +;; Catch all. +;; +(expect:error in logbody = 0 "Tests not accounted for" #/Test: /) + + +;; ;; define your hooks +;; (hook:first-error "echo \"Error hook activated: #{escaped errmsg}\"") +;; (hook:first-warning "echo \"Got warning: #{escaped warnmsg}\"") +;; (hook:value "echo \"Value hook activated: expected=#{expected}, measured=#{measured}, tolerance=#{tolerance}, message=#{message}\"") +;; +;; ;; first ensure your run at least started +;; ;; +;; (trigger "Init" #/This is a header/) +;; (trigger "InitEnd" #/^\s*$/) +;; (section "Init" "Init" "InitEnd") +;; +;; (trigger "Body" #/^.*$/) ;; anything starts the body +;; ;; (trigger "EndBody" #/This had better never match/) +;; +;; (section "Body" "Body" "EndBody") +;; +;; (trigger "Blah2" #/^begin Blah2/) +;; (trigger "Blah2End" #/^end Blah2/) +;; (section "Blah2" "Blah2" "Blah2End") +;; +;; (expect:required in "Init" = 1 "Header" #/This is a header/) +;; (expect:required in "LogFileBody" > 0 "Something required but not found" #/This is required but not found/) +;; (expect:value in "LogFileBody" 1.9 0.1 "Output voltage" #/Measured voltage output:\s*([\d\.\+\-e]+)v/) +;; (expect:value in "LogFileBody" 0.5 0.1 "Output current" #/Measured output current:\s*([\d\.\+\-e]+)mA/) +;; (expect:value in "LogFileBody" 110e9 2e9 "A big number (first)" #/Freq:\s*([\d\.\+\-e]+)\s+Hz/) +;; (expect:value in "LogFileBody" 110e9 1e9 "A big number (second), hook not called" #/Freq:\s*([\d\.\+\-e]+)Hz/) +;; (expect:value in "LogFileBody" 110e9 1e9 "A big number (never activated)" #/Freq:\s*([\d\.\+\-e]+)zH/) +;; +;; ;; Using match number +;; (expect:value in "LogFileBody" 1.9 0.1 "Time Voltage" #/out: (\d+)\s+(\d+)/ match: 2) +;; +;; ;; Comparison instead of tolerance +;; (expect:value in "LogFileBody" 1.9 > "Time voltage" #/out: (\d+)\s+(\d+)/ match: 2) +;; +;; (expect:ignore in "Blah2" < 99 "FALSE ERROR" #/ERROR/) +;; (expect:ignore in "Body" < 99 "Ignore the word error in comments" #/^\/\/.*error/) +;; (expect:warning in "Body" = 0 "Any warning" #/WARNING/) +;; (expect:error in "Body" = 0 "ERROR BLAH" (list #/ERROR/ #/error/)) ;; but disallow any other errors +;; +;; ;(expect in "Init" < 1 "Junk" #/This is bogus/) ADDED tests/release/tests/rollup/testconfig Index: tests/release/tests/rollup/testconfig ================================================================== --- /dev/null +++ tests/release/tests/rollup/testconfig @@ -0,0 +1,28 @@ +# test2 from the tests/Makefile + +[var] +tname rollup + +[ezsteps] + +# Set things up +clean $MTRUNNER $MTTESTDIR/fullrun $MTPATH megatest -remove-runs -testpatt % -target ubuntu/nfs/none -runname #{get var tname}% +runfirst $MTRUNNER $MTTESTDIR/fullrun $MTPATH megatest -runtests runfirst/% -reqtarg ubuntu/nfs/none -runname #{get var tname} -preclean +firstres $MTRUNNER $MTTESTDIR/fullrun $MTPATH megatest -list-runs #{get var tname} -target ubuntu/nfs/none + +# Set one test item to INCOMPLETE +setstate $MTRUNNER $MTTESTDIR/fullrun $MTPATH megatest -set-state-status INCOMPLETE,FAIL :state COMPLETED :status PASS -testpatt runfirst/b/2 -target ubuntu/nfs/none -runname #{get var tname} + +# Rerun a different test item +rerun $MTRUNNER $MTTESTDIR/fullrun $MTPATH megatest -run -testpatt runfirst/spring -reqtarg ubuntu/nfs/none -runname #{get var tname} -preclean -rerun PASS + +results $MTRUNNER $MTTESTDIR/fullrun $MTPATH megatest -list-runs #{get var tname} -target ubuntu/nfs/none + +[requirements] +# waiton #{getenv ALL_TOPLEVEL_TESTS} + +# This is a "toplevel" test, it does not require waitons to be non-FAIL to run +# mode toplevel + + +# test2 : fullprep ADDED tests/release/tests/test2/results.logpro Index: tests/release/tests/test2/results.logpro ================================================================== --- /dev/null +++ tests/release/tests/test2/results.logpro @@ -0,0 +1,144 @@ +;; (c) 2006,2007,2008,2009 Matthew Welland matt@kiatoa.com +;; +;; License GPL. + +(define logbody "LogFileBody") + +(define pass-specs '( ;; testname num-expected max-runtime + ;; ("exit_0" 1 20) + ;; ("ezlog_fail_then_pass" 1 20) + ;; ("ezlog_pass" 1 20) + ;; ("ez_pass" 1 20) + ;; ("lineitem_pass" 1 20) + ;; ("priority_1" 1 20) + ;; ("priority_10" 1 20) + ;; ("priority_10_waiton_1" 1 20) + ;; ("priority_3" 1 20) + ;; ("priority_4" 1 20) + ;; ;; ("priority_5" 1 20) + ;; ("priority_6" 1 20) +;; ;; ("priority_7" 1 20) + ;; ("priority_8" 1 20) + ;; ("priority_9" 1 20) + ("runfirst" 2 20) + ;; ("singletest" 1 20) + ;; ("singletest2" 1 20) + ;; ("special" 1 20) + ;; ("sqlitespeed" 10 20) + ;; ("test1" 1 20) + ;; ("test2" 6 20) + ;; ("test_mt_vars" 6 20) + )) + +(define fail-specs '( ;; testname num-expected max-runtime + ;; ("exit_1" 1 20) + ;; ("ez_exit2_fail" 1 20) + ;; ("ez_fail" 1 20) + ;; ("ez_fail_quick" 1 20) + ;; ("ezlog_fail" 1 20) + ;; ("lineitem_fail" 1 20) + ;; ("logpro_required_fail" 1 20) + ;; ("manual_example" 1 20) + ;; ("neverrun" 1 20) + )) + +(define warn-specs '( + ;; ("ezlog_warn" 1 20) + )) + +(define nost-specs '( + ;; ("wait_no_items1" 1 20) + ;; ("wait_no_items2" 1 20) + ;; ("wait_no_items3" 1 20) + ;; ("wait_no_items4" 1 20) + ;; ("no_items" 1 20) + )) + +(define (check-one-test estate estatus testname count runtime) + (let* ((rxe (regexp (conc "^\\s+Test: " testname "(\\(.*|\\s+)\\s+State: " estate "\\s+Status: " estatus "\\s+Runtime:\\s+(\\d+)s"))) + (msg1 (conc testname " expecting count of " count)) + (msg2 (conc testname " expecting runtime less than " runtime))) + (expect:required in logbody = count msg1 rxe) + ;;(expect:value in logbody count < msg2 rxe) + )) + +;; Special cases +;; +;; (expect:ignore in logbody >= 0 "db_sync test might not have run" #/Test: db_sync/) +;; (expect:ignore in logbody >= 0 "all_toplevel may not yet be done" #/Test: all_toplevel/) +(expect:error in logbody = 0 "tests left in RUNNING state" #/State: RUNNING/) +;; (expect:required in logbody = 1 "priority_2 is KILLED" #/Test: priority_2\s+State: KILLED\s+Status: KILLED/) +;; (expect:required in logbody = 1 "priority_5 is either PASS or SKIP" #/Test: priority_5\s+State: COMPLETED\s+Status: (SKIP|PASS)/) +;; (expect:required in logbody = 1 "priority_7 is either PASS or SKIP" #/Test: priority_7\s+State: COMPLETED\s+Status: (SKIP|PASS)/) +;; (expect:required in logbody = 1 "testxz has 1 NOT_STARTED test" #/Test: testxz\s+State: NOT_STARTED/) +;; (expect:required in logbody = 1 "no items" #/Test: no_items\s+State: NOT_STARTED\s+Status: ZERO_ITEMS/) +;; (expect:warning in logbody = 1 "dynamic waiton" #/Test: dynamic_waiton/) +;; (expect:required in logbody = 29 "blocktestxz has 29 tests" #/Test: blocktestxz/) + +;; General cases +;; +(for-each + (lambda (testdat) + (apply check-one-test "COMPLETED" "PASS" testdat)) + pass-specs) + +(for-each + (lambda (testdat) + (apply check-one-test "COMPLETED" "FAIL" testdat)) + fail-specs) + +(for-each + (lambda (testdat) + (apply check-one-test "COMPLETED" "WARN" testdat)) + warn-specs) + +(for-each + (lambda (testdat) + (apply check-one-test "NOT_STARTED" "PREQ_DISCARDED" testdat)) + nost-specs) + +;; Catch all. +;; +(expect:error in logbody = 0 "Tests not accounted for" #/Test: /) + + +;; ;; define your hooks +;; (hook:first-error "echo \"Error hook activated: #{escaped errmsg}\"") +;; (hook:first-warning "echo \"Got warning: #{escaped warnmsg}\"") +;; (hook:value "echo \"Value hook activated: expected=#{expected}, measured=#{measured}, tolerance=#{tolerance}, message=#{message}\"") +;; +;; ;; first ensure your run at least started +;; ;; +;; (trigger "Init" #/This is a header/) +;; (trigger "InitEnd" #/^\s*$/) +;; (section "Init" "Init" "InitEnd") +;; +;; (trigger "Body" #/^.*$/) ;; anything starts the body +;; ;; (trigger "EndBody" #/This had better never match/) +;; +;; (section "Body" "Body" "EndBody") +;; +;; (trigger "Blah2" #/^begin Blah2/) +;; (trigger "Blah2End" #/^end Blah2/) +;; (section "Blah2" "Blah2" "Blah2End") +;; +;; (expect:required in "Init" = 1 "Header" #/This is a header/) +;; (expect:required in "LogFileBody" > 0 "Something required but not found" #/This is required but not found/) +;; (expect:value in "LogFileBody" 1.9 0.1 "Output voltage" #/Measured voltage output:\s*([\d\.\+\-e]+)v/) +;; (expect:value in "LogFileBody" 0.5 0.1 "Output current" #/Measured output current:\s*([\d\.\+\-e]+)mA/) +;; (expect:value in "LogFileBody" 110e9 2e9 "A big number (first)" #/Freq:\s*([\d\.\+\-e]+)\s+Hz/) +;; (expect:value in "LogFileBody" 110e9 1e9 "A big number (second), hook not called" #/Freq:\s*([\d\.\+\-e]+)Hz/) +;; (expect:value in "LogFileBody" 110e9 1e9 "A big number (never activated)" #/Freq:\s*([\d\.\+\-e]+)zH/) +;; +;; ;; Using match number +;; (expect:value in "LogFileBody" 1.9 0.1 "Time Voltage" #/out: (\d+)\s+(\d+)/ match: 2) +;; +;; ;; Comparison instead of tolerance +;; (expect:value in "LogFileBody" 1.9 > "Time voltage" #/out: (\d+)\s+(\d+)/ match: 2) +;; +;; (expect:ignore in "Blah2" < 99 "FALSE ERROR" #/ERROR/) +;; (expect:ignore in "Body" < 99 "Ignore the word error in comments" #/^\/\/.*error/) +;; (expect:warning in "Body" = 0 "Any warning" #/WARNING/) +;; (expect:error in "Body" = 0 "ERROR BLAH" (list #/ERROR/ #/error/)) ;; but disallow any other errors +;; +;; ;(expect in "Init" < 1 "Junk" #/This is bogus/) ADDED tests/release/tests/test2/results_a.logpro Index: tests/release/tests/test2/results_a.logpro ================================================================== --- /dev/null +++ tests/release/tests/test2/results_a.logpro @@ -0,0 +1,144 @@ +;; (c) 2006,2007,2008,2009 Matthew Welland matt@kiatoa.com +;; +;; License GPL. + +(define logbody "LogFileBody") + +(define pass-specs '( ;; testname num-expected max-runtime + ;; ("exit_0" 1 20) + ;; ("ezlog_fail_then_pass" 1 20) + ;; ("ezlog_pass" 1 20) + ;; ("ez_pass" 1 20) + ;; ("lineitem_pass" 1 20) + ;; ("priority_1" 1 20) + ;; ("priority_10" 1 20) + ;; ("priority_10_waiton_1" 1 20) + ;; ("priority_3" 1 20) + ;; ("priority_4" 1 20) + ;; ;; ("priority_5" 1 20) + ;; ("priority_6" 1 20) +;; ;; ("priority_7" 1 20) + ;; ("priority_8" 1 20) + ;; ("priority_9" 1 20) + ("runfirst" 2 20) + ;; ("singletest" 1 20) + ;; ("singletest2" 1 20) + ;; ("special" 1 20) + ;; ("sqlitespeed" 10 20) + ;; ("test1" 1 20) + ;; ("test2" 6 20) + ;; ("test_mt_vars" 6 20) + )) + +(define fail-specs '( ;; testname num-expected max-runtime + ;; ("exit_1" 1 20) + ;; ("ez_exit2_fail" 1 20) + ;; ("ez_fail" 1 20) + ;; ("ez_fail_quick" 1 20) + ;; ("ezlog_fail" 1 20) + ;; ("lineitem_fail" 1 20) + ;; ("logpro_required_fail" 1 20) + ;; ("manual_example" 1 20) + ;; ("neverrun" 1 20) + )) + +(define warn-specs '( + ;; ("ezlog_warn" 1 20) + )) + +(define nost-specs '( + ;; ("wait_no_items1" 1 20) + ;; ("wait_no_items2" 1 20) + ;; ("wait_no_items3" 1 20) + ;; ("wait_no_items4" 1 20) + ;; ("no_items" 1 20) + )) + +(define (check-one-test estate estatus testname count runtime) + (let* ((rxe (regexp (conc "^\\s+Test: " testname "(\\(.*|\\s+)\\s+State: " estate "\\s+Status: " estatus "\\s+Runtime:\\s+(\\d+)s"))) + (msg1 (conc testname " expecting count of " count)) + (msg2 (conc testname " expecting runtime less than " runtime))) + (expect:required in logbody = count msg1 rxe) + ;;(expect:value in logbody count < msg2 rxe) + )) + +;; Special cases +;; +;; (expect:ignore in logbody >= 0 "db_sync test might not have run" #/Test: db_sync/) +;; (expect:ignore in logbody >= 0 "all_toplevel may not yet be done" #/Test: all_toplevel/) +(expect:error in logbody = 0 "tests left in RUNNING state" #/State: RUNNING/) +;; (expect:required in logbody = 1 "priority_2 is KILLED" #/Test: priority_2\s+State: KILLED\s+Status: KILLED/) +;; (expect:required in logbody = 1 "priority_5 is either PASS or SKIP" #/Test: priority_5\s+State: COMPLETED\s+Status: (SKIP|PASS)/) +;; (expect:required in logbody = 1 "priority_7 is either PASS or SKIP" #/Test: priority_7\s+State: COMPLETED\s+Status: (SKIP|PASS)/) +;; (expect:required in logbody = 1 "testxz has 1 NOT_STARTED test" #/Test: testxz\s+State: NOT_STARTED/) +;; (expect:required in logbody = 1 "no items" #/Test: no_items\s+State: NOT_STARTED\s+Status: ZERO_ITEMS/) +;; (expect:warning in logbody = 1 "dynamic waiton" #/Test: dynamic_waiton/) +;; (expect:required in logbody = 29 "blocktestxz has 29 tests" #/Test: blocktestxz/) + +;; General cases +;; +(for-each + (lambda (testdat) + (apply check-one-test "COMPLETED" "PASS" testdat)) + pass-specs) + +(for-each + (lambda (testdat) + (apply check-one-test "COMPLETED" "FAIL" testdat)) + fail-specs) + +(for-each + (lambda (testdat) + (apply check-one-test "COMPLETED" "WARN" testdat)) + warn-specs) + +(for-each + (lambda (testdat) + (apply check-one-test "NOT_STARTED" "PREQ_DISCARDED" testdat)) + nost-specs) + +;; Catch all. +;; +(expect:error in logbody = 0 "Tests not accounted for" #/Test: /) + + +;; ;; define your hooks +;; (hook:first-error "echo \"Error hook activated: #{escaped errmsg}\"") +;; (hook:first-warning "echo \"Got warning: #{escaped warnmsg}\"") +;; (hook:value "echo \"Value hook activated: expected=#{expected}, measured=#{measured}, tolerance=#{tolerance}, message=#{message}\"") +;; +;; ;; first ensure your run at least started +;; ;; +;; (trigger "Init" #/This is a header/) +;; (trigger "InitEnd" #/^\s*$/) +;; (section "Init" "Init" "InitEnd") +;; +;; (trigger "Body" #/^.*$/) ;; anything starts the body +;; ;; (trigger "EndBody" #/This had better never match/) +;; +;; (section "Body" "Body" "EndBody") +;; +;; (trigger "Blah2" #/^begin Blah2/) +;; (trigger "Blah2End" #/^end Blah2/) +;; (section "Blah2" "Blah2" "Blah2End") +;; +;; (expect:required in "Init" = 1 "Header" #/This is a header/) +;; (expect:required in "LogFileBody" > 0 "Something required but not found" #/This is required but not found/) +;; (expect:value in "LogFileBody" 1.9 0.1 "Output voltage" #/Measured voltage output:\s*([\d\.\+\-e]+)v/) +;; (expect:value in "LogFileBody" 0.5 0.1 "Output current" #/Measured output current:\s*([\d\.\+\-e]+)mA/) +;; (expect:value in "LogFileBody" 110e9 2e9 "A big number (first)" #/Freq:\s*([\d\.\+\-e]+)\s+Hz/) +;; (expect:value in "LogFileBody" 110e9 1e9 "A big number (second), hook not called" #/Freq:\s*([\d\.\+\-e]+)Hz/) +;; (expect:value in "LogFileBody" 110e9 1e9 "A big number (never activated)" #/Freq:\s*([\d\.\+\-e]+)zH/) +;; +;; ;; Using match number +;; (expect:value in "LogFileBody" 1.9 0.1 "Time Voltage" #/out: (\d+)\s+(\d+)/ match: 2) +;; +;; ;; Comparison instead of tolerance +;; (expect:value in "LogFileBody" 1.9 > "Time voltage" #/out: (\d+)\s+(\d+)/ match: 2) +;; +;; (expect:ignore in "Blah2" < 99 "FALSE ERROR" #/ERROR/) +;; (expect:ignore in "Body" < 99 "Ignore the word error in comments" #/^\/\/.*error/) +;; (expect:warning in "Body" = 0 "Any warning" #/WARNING/) +;; (expect:error in "Body" = 0 "ERROR BLAH" (list #/ERROR/ #/error/)) ;; but disallow any other errors +;; +;; ;(expect in "Init" < 1 "Junk" #/This is bogus/) ADDED tests/release/tests/test2/results_b.logpro Index: tests/release/tests/test2/results_b.logpro ================================================================== --- /dev/null +++ tests/release/tests/test2/results_b.logpro @@ -0,0 +1,144 @@ +;; (c) 2006,2007,2008,2009 Matthew Welland matt@kiatoa.com +;; +;; License GPL. + +(define logbody "LogFileBody") + +(define pass-specs '( ;; testname num-expected max-runtime + ;; ("exit_0" 1 20) + ;; ("ezlog_fail_then_pass" 1 20) + ;; ("ezlog_pass" 1 20) + ;; ("ez_pass" 1 20) + ;; ("lineitem_pass" 1 20) + ;; ("priority_1" 1 20) + ;; ("priority_10" 1 20) + ;; ("priority_10_waiton_1" 1 20) + ;; ("priority_3" 1 20) + ;; ("priority_4" 1 20) + ;; ;; ("priority_5" 1 20) + ;; ("priority_6" 1 20) +;; ;; ("priority_7" 1 20) + ;; ("priority_8" 1 20) + ;; ("priority_9" 1 20) + ("runfirst" 2 20) + ;; ("singletest" 1 20) + ;; ("singletest2" 1 20) + ;; ("special" 1 20) + ;; ("sqlitespeed" 10 20) + ;; ("test1" 1 20) + ;; ("test2" 6 20) + ;; ("test_mt_vars" 6 20) + )) + +(define fail-specs '( ;; testname num-expected max-runtime + ;; ("exit_1" 1 20) + ;; ("ez_exit2_fail" 1 20) + ;; ("ez_fail" 1 20) + ;; ("ez_fail_quick" 1 20) + ;; ("ezlog_fail" 1 20) + ;; ("lineitem_fail" 1 20) + ;; ("logpro_required_fail" 1 20) + ;; ("manual_example" 1 20) + ;; ("neverrun" 1 20) + )) + +(define warn-specs '( + ;; ("ezlog_warn" 1 20) + )) + +(define nost-specs '( + ;; ("wait_no_items1" 1 20) + ;; ("wait_no_items2" 1 20) + ;; ("wait_no_items3" 1 20) + ;; ("wait_no_items4" 1 20) + ;; ("no_items" 1 20) + )) + +(define (check-one-test estate estatus testname count runtime) + (let* ((rxe (regexp (conc "^\\s+Test: " testname "(\\(.*|\\s+)\\s+State: " estate "\\s+Status: " estatus "\\s+Runtime:\\s+(\\d+)s"))) + (msg1 (conc testname " expecting count of " count)) + (msg2 (conc testname " expecting runtime less than " runtime))) + (expect:required in logbody = count msg1 rxe) + ;;(expect:value in logbody count < msg2 rxe) + )) + +;; Special cases +;; +;; (expect:ignore in logbody >= 0 "db_sync test might not have run" #/Test: db_sync/) +;; (expect:ignore in logbody >= 0 "all_toplevel may not yet be done" #/Test: all_toplevel/) +(expect:error in logbody = 0 "tests left in RUNNING state" #/State: RUNNING/) +;; (expect:required in logbody = 1 "priority_2 is KILLED" #/Test: priority_2\s+State: KILLED\s+Status: KILLED/) +;; (expect:required in logbody = 1 "priority_5 is either PASS or SKIP" #/Test: priority_5\s+State: COMPLETED\s+Status: (SKIP|PASS)/) +;; (expect:required in logbody = 1 "priority_7 is either PASS or SKIP" #/Test: priority_7\s+State: COMPLETED\s+Status: (SKIP|PASS)/) +;; (expect:required in logbody = 1 "testxz has 1 NOT_STARTED test" #/Test: testxz\s+State: NOT_STARTED/) +;; (expect:required in logbody = 1 "no items" #/Test: no_items\s+State: NOT_STARTED\s+Status: ZERO_ITEMS/) +;; (expect:warning in logbody = 1 "dynamic waiton" #/Test: dynamic_waiton/) +;; (expect:required in logbody = 29 "blocktestxz has 29 tests" #/Test: blocktestxz/) + +;; General cases +;; +(for-each + (lambda (testdat) + (apply check-one-test "COMPLETED" "PASS" testdat)) + pass-specs) + +(for-each + (lambda (testdat) + (apply check-one-test "COMPLETED" "FAIL" testdat)) + fail-specs) + +(for-each + (lambda (testdat) + (apply check-one-test "COMPLETED" "WARN" testdat)) + warn-specs) + +(for-each + (lambda (testdat) + (apply check-one-test "NOT_STARTED" "PREQ_DISCARDED" testdat)) + nost-specs) + +;; Catch all. +;; +(expect:error in logbody = 0 "Tests not accounted for" #/Test: /) + + +;; ;; define your hooks +;; (hook:first-error "echo \"Error hook activated: #{escaped errmsg}\"") +;; (hook:first-warning "echo \"Got warning: #{escaped warnmsg}\"") +;; (hook:value "echo \"Value hook activated: expected=#{expected}, measured=#{measured}, tolerance=#{tolerance}, message=#{message}\"") +;; +;; ;; first ensure your run at least started +;; ;; +;; (trigger "Init" #/This is a header/) +;; (trigger "InitEnd" #/^\s*$/) +;; (section "Init" "Init" "InitEnd") +;; +;; (trigger "Body" #/^.*$/) ;; anything starts the body +;; ;; (trigger "EndBody" #/This had better never match/) +;; +;; (section "Body" "Body" "EndBody") +;; +;; (trigger "Blah2" #/^begin Blah2/) +;; (trigger "Blah2End" #/^end Blah2/) +;; (section "Blah2" "Blah2" "Blah2End") +;; +;; (expect:required in "Init" = 1 "Header" #/This is a header/) +;; (expect:required in "LogFileBody" > 0 "Something required but not found" #/This is required but not found/) +;; (expect:value in "LogFileBody" 1.9 0.1 "Output voltage" #/Measured voltage output:\s*([\d\.\+\-e]+)v/) +;; (expect:value in "LogFileBody" 0.5 0.1 "Output current" #/Measured output current:\s*([\d\.\+\-e]+)mA/) +;; (expect:value in "LogFileBody" 110e9 2e9 "A big number (first)" #/Freq:\s*([\d\.\+\-e]+)\s+Hz/) +;; (expect:value in "LogFileBody" 110e9 1e9 "A big number (second), hook not called" #/Freq:\s*([\d\.\+\-e]+)Hz/) +;; (expect:value in "LogFileBody" 110e9 1e9 "A big number (never activated)" #/Freq:\s*([\d\.\+\-e]+)zH/) +;; +;; ;; Using match number +;; (expect:value in "LogFileBody" 1.9 0.1 "Time Voltage" #/out: (\d+)\s+(\d+)/ match: 2) +;; +;; ;; Comparison instead of tolerance +;; (expect:value in "LogFileBody" 1.9 > "Time voltage" #/out: (\d+)\s+(\d+)/ match: 2) +;; +;; (expect:ignore in "Blah2" < 99 "FALSE ERROR" #/ERROR/) +;; (expect:ignore in "Body" < 99 "Ignore the word error in comments" #/^\/\/.*error/) +;; (expect:warning in "Body" = 0 "Any warning" #/WARNING/) +;; (expect:error in "Body" = 0 "ERROR BLAH" (list #/ERROR/ #/error/)) ;; but disallow any other errors +;; +;; ;(expect in "Init" < 1 "Junk" #/This is bogus/) ADDED tests/release/tests/test2/testconfig Index: tests/release/tests/test2/testconfig ================================================================== --- /dev/null +++ tests/release/tests/test2/testconfig @@ -0,0 +1,27 @@ +# test2 from the tests/Makefile + +[var] +tname test2 +mtpath #{shell readlink -f ../../bin} + +[ezsteps] +clean $MTRUNNER $MTTESTDIR/fullrun $MTPATH megatest -remove-runs -testpatt % -target ubuntu/nfs/none -runname #{get var tname}% +part1 $MTRUNNER $MTTESTDIR/fullrun $MTPATH megatest -run -testpatt ez_pass,runfirst/a/% -reqtarg ubuntu/nfs/none -runname #{get var tname} -preclean +part2 $MTRUNNER $MTTESTDIR/fullrun $MTPATH megatest -run -testpatt %/,%/ai -reqtarg ubuntu/nfs/none -runname #{get var tname}_a -preclean +part3 $MTRUNNER $MTTESTDIR/fullrun $MTPATH megatest -runtests %/,%/ai -reqtarg ubuntu/nfs/none -runname #{get var tname}_b -preclean +part4 $MTRUNNER $MTTESTDIR/fullrun $MTPATH megatest -run -testpatt runfirst/%,%/ai -reqtarg ubuntu/nfs/none -runname #{get var tname}_a -preclean +part5 $MTRUNNER $MTTESTDIR/fullrun $MTPATH megatest -run -testpatt %/,%/winter -reqtarg ubuntu/nfs/none -runname #{get var tname}_a -preclean +part6 $MTRUNNER $MTTESTDIR/fullrun $MTPATH megatest -set-state-status COMPLETED,FORCED :state COMPLETED :status PASS -testpatt ez_p%s,runfirst/ -target ubuntu/nfs/none -runname #{get var tname} + +results $MTRUNNER $MTTESTDIR/fullrun $MTPATH megatest -list-runs #{get var tname} -target ubuntu/nfs/none +results_a $MTRUNNER $MTTESTDIR/fullrun $MTPATH megatest -list-runs #{get var tname}_a -target ubuntu/nfs/none +results_b $MTRUNNER $MTTESTDIR/fullrun $MTPATH megatest -list-runs #{get var tname}_b -target ubuntu/nfs/none + +[requirements] +# waiton #{getenv ALL_TOPLEVEL_TESTS} + +# This is a "toplevel" test, it does not require waitons to be non-FAIL to run +# mode toplevel + + +# test2 : fullprep ADDED tests/release/tests/testpatt/cleanres.logpro Index: tests/release/tests/testpatt/cleanres.logpro ================================================================== --- /dev/null +++ tests/release/tests/testpatt/cleanres.logpro @@ -0,0 +1,144 @@ +;; (c) 2006,2007,2008,2009 Matthew Welland matt@kiatoa.com +;; +;; License GPL. + +(define logbody "LogFileBody") + +(define pass-specs '( ;; testname num-expected max-runtime + ;; ("exit_0" 1 20) + ;; ("ezlog_fail_then_pass" 1 20) + ;; ("ezlog_pass" 1 20) + ;; ("ez_pass" 1 20) + ;; ("lineitem_pass" 1 20) + ;; ("priority_1" 1 20) + ;; ("priority_10" 1 20) + ;; ("priority_10_waiton_1" 1 20) + ;; ("priority_3" 1 20) + ;; ("priority_4" 1 20) + ;; ;; ("priority_5" 1 20) + ;; ("priority_6" 1 20) +;; ;; ("priority_7" 1 20) + ;; ("priority_8" 1 20) + ;; ("priority_9" 1 20) + ;; ("runfirst" 2 20) + ;; ("singletest" 1 20) + ;; ("singletest2" 1 20) + ;; ("special" 1 20) + ;; ("sqlitespeed" 10 20) + ;; ("test1" 1 20) + ;; ("test2" 6 20) + ;; ("test_mt_vars" 6 20) + )) + +(define fail-specs '( ;; testname num-expected max-runtime + ;; ("exit_1" 1 20) + ;; ("ez_exit2_fail" 1 20) + ;; ("ez_fail" 1 20) + ;; ("ez_fail_quick" 1 20) + ;; ("ezlog_fail" 1 20) + ;; ("lineitem_fail" 1 20) + ;; ("logpro_required_fail" 1 20) + ;; ("manual_example" 1 20) + ;; ("neverrun" 1 20) + )) + +(define warn-specs '( + ;; ("ezlog_warn" 1 20) + )) + +(define nost-specs '( + ;; ("wait_no_items1" 1 20) + ;; ("wait_no_items2" 1 20) + ;; ("wait_no_items3" 1 20) + ;; ("wait_no_items4" 1 20) + ;; ("no_items" 1 20) + )) + +(define (check-one-test estate estatus testname count runtime) + (let* ((rxe (regexp (conc "^\\s+Test: " testname "(\\(.*|\\s+)\\s+State: " estate "\\s+Status: " estatus "\\s+Runtime:\\s+(\\d+)s"))) + (msg1 (conc testname " expecting count of " count)) + (msg2 (conc testname " expecting runtime less than " runtime))) + (expect:required in logbody = count msg1 rxe) + ;;(expect:value in logbody count < msg2 rxe) + )) + +;; Special cases +;; +;; (expect:ignore in logbody >= 0 "db_sync test might not have run" #/Test: db_sync/) +;; (expect:ignore in logbody >= 0 "all_toplevel may not yet be done" #/Test: all_toplevel/) +(expect:error in logbody = 0 "tests left in RUNNING state" #/State: RUNNING/) +;; (expect:required in logbody = 1 "priority_2 is KILLED" #/Test: priority_2\s+State: KILLED\s+Status: KILLED/) +;; (expect:required in logbody = 1 "priority_5 is either PASS or SKIP" #/Test: priority_5\s+State: COMPLETED\s+Status: (SKIP|PASS)/) +;; (expect:required in logbody = 1 "priority_7 is either PASS or SKIP" #/Test: priority_7\s+State: COMPLETED\s+Status: (SKIP|PASS)/) +;; (expect:required in logbody = 1 "testxz has 1 NOT_STARTED test" #/Test: testxz\s+State: NOT_STARTED/) +;; (expect:required in logbody = 1 "no items" #/Test: no_items\s+State: NOT_STARTED\s+Status: ZERO_ITEMS/) +;; (expect:warning in logbody = 1 "dynamic waiton" #/Test: dynamic_waiton/) +;; (expect:required in logbody = 29 "blocktestxz has 29 tests" #/Test: blocktestxz/) + +;; General cases +;; +(for-each + (lambda (testdat) + (apply check-one-test "COMPLETED" "PASS" testdat)) + pass-specs) + +(for-each + (lambda (testdat) + (apply check-one-test "COMPLETED" "FAIL" testdat)) + fail-specs) + +(for-each + (lambda (testdat) + (apply check-one-test "COMPLETED" "WARN" testdat)) + warn-specs) + +(for-each + (lambda (testdat) + (apply check-one-test "NOT_STARTED" "PREQ_DISCARDED" testdat)) + nost-specs) + +;; Catch all. +;; +(expect:error in logbody = 0 "Tests not accounted for" #/Test: /) + + +;; ;; define your hooks +;; (hook:first-error "echo \"Error hook activated: #{escaped errmsg}\"") +;; (hook:first-warning "echo \"Got warning: #{escaped warnmsg}\"") +;; (hook:value "echo \"Value hook activated: expected=#{expected}, measured=#{measured}, tolerance=#{tolerance}, message=#{message}\"") +;; +;; ;; first ensure your run at least started +;; ;; +;; (trigger "Init" #/This is a header/) +;; (trigger "InitEnd" #/^\s*$/) +;; (section "Init" "Init" "InitEnd") +;; +;; (trigger "Body" #/^.*$/) ;; anything starts the body +;; ;; (trigger "EndBody" #/This had better never match/) +;; +;; (section "Body" "Body" "EndBody") +;; +;; (trigger "Blah2" #/^begin Blah2/) +;; (trigger "Blah2End" #/^end Blah2/) +;; (section "Blah2" "Blah2" "Blah2End") +;; +;; (expect:required in "Init" = 1 "Header" #/This is a header/) +;; (expect:required in "LogFileBody" > 0 "Something required but not found" #/This is required but not found/) +;; (expect:value in "LogFileBody" 1.9 0.1 "Output voltage" #/Measured voltage output:\s*([\d\.\+\-e]+)v/) +;; (expect:value in "LogFileBody" 0.5 0.1 "Output current" #/Measured output current:\s*([\d\.\+\-e]+)mA/) +;; (expect:value in "LogFileBody" 110e9 2e9 "A big number (first)" #/Freq:\s*([\d\.\+\-e]+)\s+Hz/) +;; (expect:value in "LogFileBody" 110e9 1e9 "A big number (second), hook not called" #/Freq:\s*([\d\.\+\-e]+)Hz/) +;; (expect:value in "LogFileBody" 110e9 1e9 "A big number (never activated)" #/Freq:\s*([\d\.\+\-e]+)zH/) +;; +;; ;; Using match number +;; (expect:value in "LogFileBody" 1.9 0.1 "Time Voltage" #/out: (\d+)\s+(\d+)/ match: 2) +;; +;; ;; Comparison instead of tolerance +;; (expect:value in "LogFileBody" 1.9 > "Time voltage" #/out: (\d+)\s+(\d+)/ match: 2) +;; +;; (expect:ignore in "Blah2" < 99 "FALSE ERROR" #/ERROR/) +;; (expect:ignore in "Body" < 99 "Ignore the word error in comments" #/^\/\/.*error/) +;; (expect:warning in "Body" = 0 "Any warning" #/WARNING/) +;; (expect:error in "Body" = 0 "ERROR BLAH" (list #/ERROR/ #/error/)) ;; but disallow any other errors +;; +;; ;(expect in "Init" < 1 "Junk" #/This is bogus/) ADDED tests/release/tests/testpatt/results.logpro Index: tests/release/tests/testpatt/results.logpro ================================================================== --- /dev/null +++ tests/release/tests/testpatt/results.logpro @@ -0,0 +1,144 @@ +;; (c) 2006,2007,2008,2009 Matthew Welland matt@kiatoa.com +;; +;; License GPL. + +(define logbody "LogFileBody") + +(define pass-specs '( ;; testname num-expected max-runtime + ;; ("exit_0" 1 20) + ;; ("ezlog_fail_then_pass" 1 20) + ;; ("ezlog_pass" 1 20) + ;; ("ez_pass" 1 20) + ;; ("lineitem_pass" 1 20) + ;; ("priority_1" 1 20) + ;; ("priority_10" 1 20) + ;; ("priority_10_waiton_1" 1 20) + ;; ("priority_3" 1 20) + ;; ("priority_4" 1 20) + ;; ;; ("priority_5" 1 20) + ;; ("priority_6" 1 20) +;; ;; ("priority_7" 1 20) + ;; ("priority_8" 1 20) + ;; ("priority_9" 1 20) + ("runfirst" 2 20) + ;; ("singletest" 1 20) + ;; ("singletest2" 1 20) + ;; ("special" 1 20) + ;; ("sqlitespeed" 10 20) + ;; ("test1" 1 20) + ;; ("test2" 6 20) + ;; ("test_mt_vars" 6 20) + )) + +(define fail-specs '( ;; testname num-expected max-runtime + ;; ("exit_1" 1 20) + ;; ("ez_exit2_fail" 1 20) + ;; ("ez_fail" 1 20) + ;; ("ez_fail_quick" 1 20) + ;; ("ezlog_fail" 1 20) + ;; ("lineitem_fail" 1 20) + ;; ("logpro_required_fail" 1 20) + ;; ("manual_example" 1 20) + ;; ("neverrun" 1 20) + )) + +(define warn-specs '( + ;; ("ezlog_warn" 1 20) + )) + +(define nost-specs '( + ;; ("wait_no_items1" 1 20) + ;; ("wait_no_items2" 1 20) + ;; ("wait_no_items3" 1 20) + ;; ("wait_no_items4" 1 20) + ;; ("no_items" 1 20) + )) + +(define (check-one-test estate estatus testname count runtime) + (let* ((rxe (regexp (conc "^\\s+Test: " testname "(\\(.*|\\s+)\\s+State: " estate "\\s+Status: " estatus "\\s+Runtime:\\s+(\\d+)s"))) + (msg1 (conc testname " expecting count of " count)) + (msg2 (conc testname " expecting runtime less than " runtime))) + (expect:required in logbody = count msg1 rxe) + ;;(expect:value in logbody count < msg2 rxe) + )) + +;; Special cases +;; +;; (expect:ignore in logbody >= 0 "db_sync test might not have run" #/Test: db_sync/) +;; (expect:ignore in logbody >= 0 "all_toplevel may not yet be done" #/Test: all_toplevel/) +(expect:error in logbody = 0 "tests left in RUNNING state" #/State: RUNNING/) +;; (expect:required in logbody = 1 "priority_2 is KILLED" #/Test: priority_2\s+State: KILLED\s+Status: KILLED/) +;; (expect:required in logbody = 1 "priority_5 is either PASS or SKIP" #/Test: priority_5\s+State: COMPLETED\s+Status: (SKIP|PASS)/) +;; (expect:required in logbody = 1 "priority_7 is either PASS or SKIP" #/Test: priority_7\s+State: COMPLETED\s+Status: (SKIP|PASS)/) +;; (expect:required in logbody = 1 "testxz has 1 NOT_STARTED test" #/Test: testxz\s+State: NOT_STARTED/) +;; (expect:required in logbody = 1 "no items" #/Test: no_items\s+State: NOT_STARTED\s+Status: ZERO_ITEMS/) +;; (expect:warning in logbody = 1 "dynamic waiton" #/Test: dynamic_waiton/) +;; (expect:required in logbody = 29 "blocktestxz has 29 tests" #/Test: blocktestxz/) + +;; General cases +;; +(for-each + (lambda (testdat) + (apply check-one-test "COMPLETED" "PASS" testdat)) + pass-specs) + +(for-each + (lambda (testdat) + (apply check-one-test "COMPLETED" "FAIL" testdat)) + fail-specs) + +(for-each + (lambda (testdat) + (apply check-one-test "COMPLETED" "WARN" testdat)) + warn-specs) + +(for-each + (lambda (testdat) + (apply check-one-test "NOT_STARTED" "PREQ_DISCARDED" testdat)) + nost-specs) + +;; Catch all. +;; +(expect:error in logbody = 0 "Tests not accounted for" #/Test: /) + + +;; ;; define your hooks +;; (hook:first-error "echo \"Error hook activated: #{escaped errmsg}\"") +;; (hook:first-warning "echo \"Got warning: #{escaped warnmsg}\"") +;; (hook:value "echo \"Value hook activated: expected=#{expected}, measured=#{measured}, tolerance=#{tolerance}, message=#{message}\"") +;; +;; ;; first ensure your run at least started +;; ;; +;; (trigger "Init" #/This is a header/) +;; (trigger "InitEnd" #/^\s*$/) +;; (section "Init" "Init" "InitEnd") +;; +;; (trigger "Body" #/^.*$/) ;; anything starts the body +;; ;; (trigger "EndBody" #/This had better never match/) +;; +;; (section "Body" "Body" "EndBody") +;; +;; (trigger "Blah2" #/^begin Blah2/) +;; (trigger "Blah2End" #/^end Blah2/) +;; (section "Blah2" "Blah2" "Blah2End") +;; +;; (expect:required in "Init" = 1 "Header" #/This is a header/) +;; (expect:required in "LogFileBody" > 0 "Something required but not found" #/This is required but not found/) +;; (expect:value in "LogFileBody" 1.9 0.1 "Output voltage" #/Measured voltage output:\s*([\d\.\+\-e]+)v/) +;; (expect:value in "LogFileBody" 0.5 0.1 "Output current" #/Measured output current:\s*([\d\.\+\-e]+)mA/) +;; (expect:value in "LogFileBody" 110e9 2e9 "A big number (first)" #/Freq:\s*([\d\.\+\-e]+)\s+Hz/) +;; (expect:value in "LogFileBody" 110e9 1e9 "A big number (second), hook not called" #/Freq:\s*([\d\.\+\-e]+)Hz/) +;; (expect:value in "LogFileBody" 110e9 1e9 "A big number (never activated)" #/Freq:\s*([\d\.\+\-e]+)zH/) +;; +;; ;; Using match number +;; (expect:value in "LogFileBody" 1.9 0.1 "Time Voltage" #/out: (\d+)\s+(\d+)/ match: 2) +;; +;; ;; Comparison instead of tolerance +;; (expect:value in "LogFileBody" 1.9 > "Time voltage" #/out: (\d+)\s+(\d+)/ match: 2) +;; +;; (expect:ignore in "Blah2" < 99 "FALSE ERROR" #/ERROR/) +;; (expect:ignore in "Body" < 99 "Ignore the word error in comments" #/^\/\/.*error/) +;; (expect:warning in "Body" = 0 "Any warning" #/WARNING/) +;; (expect:error in "Body" = 0 "ERROR BLAH" (list #/ERROR/ #/error/)) ;; but disallow any other errors +;; +;; ;(expect in "Init" < 1 "Junk" #/This is bogus/) ADDED tests/release/tests/testpatt/testconfig Index: tests/release/tests/testpatt/testconfig ================================================================== --- /dev/null +++ tests/release/tests/testpatt/testconfig @@ -0,0 +1,12 @@ +[ezsteps] +clean $MTRUNNER $MTTESTDIR/fullrun $MTPATH megatest -remove-runs -testpatt % -target ubuntu/nfs/none -runname release_testpatt +cleanres $MTRUNNER $MTTESTDIR/fullrun $MTPATH megatest -list-runs release_testpatt -target ubuntu/nfs/none + +runitems $MTRUNNER $MTTESTDIR/fullrun $MTPATH megatest -run -testpatt runfirst/%2 -target ubuntu/nfs/none -runname release_testpatt +results $MTRUNNER $MTTESTDIR/fullrun $MTPATH megatest -list-runs release_testpatt -target ubuntu/nfs/none + +[requirements] +# waiton #{getenv ALL_TOPLEVEL_TESTS} + +# This is a "toplevel" test, it does not require waitons to be non-FAIL to run +# mode toplevel Index: tests/rununittest.sh ================================================================== --- tests/rununittest.sh +++ tests/rununittest.sh @@ -1,13 +1,10 @@ #!/bin/bash # Usage: rununittest.sh testname debuglevel # -# Ensure all is made -(cd ..;make && make install) - # put megatest on path from correct location mtbindir=$(readlink -f ../bin) export PATH="${mtbindir}:$PATH" ADDED tests/unit.logpro Index: tests/unit.logpro ================================================================== --- /dev/null +++ tests/unit.logpro @@ -0,0 +1,8 @@ +;; 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! +(expect:ignore in "LogFileBody" < 99 "Ignore the word error in comments" #/^\/\/.*error/) +(expect:warning in "LogFileBody" = 0 "Any warning" #/warn/) +(expect:error in "LogFileBody" = 0 "Any error" (list #/error/i #/\[.{0,4}FAIL.{0,4}\]/)) ;; but disallow any other errors Index: tests/unittests/misc.scm ================================================================== --- tests/unittests/misc.scm +++ tests/unittests/misc.scm @@ -41,5 +41,8 @@ (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%")) + +(exit) + Index: tests/unittests/runs.scm ================================================================== --- tests/unittests/runs.scm +++ tests/unittests/runs.scm @@ -1,24 +1,23 @@ -(define keys (db:get-keys *db*)) +(define keys (rmt:get-keys)) -(test "get all legal tests" (list "test1" "test2") (sort (get-all-legal-tests) string<=?)) +(test "get all legal tests" (list "test1" "test2") (sort (hash-table-keys (tests:get-all)) string<=?)) (test "register-run" #t (number? - (db:register-run *db* + (rmt:register-run '(("SYSTEM" "key1")("RELEASE" "key2")) "myrun" "new" "n/a" "bob"))) -(test #f #t (cdb:tests-register-test *runremote* 1 "nada" "")) -(test #f 1 (cdb:remote-run db:get-test-id #f 1 "nada" "")) -(test #f "NOT_STARTED" (vector-ref (open-run-close db:get-test-info #f 1 "nada" "") 3)) -(test #f "NOT_STARTED" (vector-ref (cdb:get-test-info *runremote* 1 "nada" "") 3)) +(test #f #t (rmt:register-test 1 "nada" "")) +(test #f 30001 (rmt:get-test-id 1 "nada" "")) +(test #f "NOT_STARTED" (vector-ref (rmt:get-test-info-by-id 1 30001) 3)) ;; "nada" "") 3)) (test #f "FOO LIKE 'abc%def'" (db:patt->like "FOO" "abc%def")) -(test #f "key2" (vector-ref (car (vector-ref (runs:get-runs-by-patt *db* '("SYSTEM" "RELEASE") "%" "key1/key2") 1)) 1)) +(test #f "key2" (vector-ref (car (vector-ref (mt:get-runs-by-patt '("SYSTEM" "RELEASE") "%" "key1/key2") 1)) 1)) (test #f "SYSTEM,RELEASE,id,runname,state,status,owner,event_time" (car (runs:get-std-run-fields keys '("id" "runname" "state" "status" "owner" "event_time")))) (test #f #t (runs:operate-on 'print "%" "%" "%")) ;;(test "update-test-info" #t (test-update-meta-info *db* 1 "nada" @@ -48,16 +47,18 @@ ;; force keepgoing ; (hash-table-set! args:arg-hash "-keepgoing" #t) (hash-table-set! args:arg-hash "-itempatt" "%") (hash-table-set! args:arg-hash "-testpatt" "%") -(hash-table-set! args:arg-hash "-target" "ubuntu/r1.2") -(test "Setup for a run" #t (begin (setup-for-run) #t)) +(hash-table-set! args:arg-hash "-target" "ubuntu/r1.2") ;; SYSTEM/RELEASE +(hash-table-set! args:arg-hash "-runname" "testrun") +(test "Setup for a run" #t (begin (launch:setup-for-run) #t)) (define *tdb* #f) (define keyvals #f) (test "target->keyval" #t (let ((kv (keys:target->keyval keys (args:get-arg "-target")))) + (print "keyvals=" kv ", keys=" keys) (set! keyvals kv)(list? keyvals))) (define testdbpath (conc "/tmp/" (getenv "USER") "/megatest_testing")) (system (conc "rm -f " testdbpath "/testdat.db;mkdir -p " testdbpath)) @@ -67,38 +68,37 @@ (sqlite3#database? db))) (sqlite3#finalize! *tdb*) ;; (test "Remove the rollup run" #t (begin (remove-runs) #t)) (define tconfig #f) -(test "get a testconfig" #t (let ((tconf (tests:get-testconfig "test1" 'return-procs))) +(test "get a testconfig" #t (let ((tconf (tests:get-testconfig "test1" (tests:get-all) 'return-procs ))) (set! tconfig tconf) (hash-table? tconf))) -(db:clean-all-caches) (test "set-megatest-env-vars" "ubuntu" (begin - (set-megatest-env-vars 1 inkeys: keys) + (runs:set-megatest-env-vars 1 inkeys: keys) (get-environment-variable "SYSTEM"))) (test "setup-env-defaults" "see this variable" (begin - (setup-env-defaults "runconfigs.config" 1 *already-seen-runconfig-info* keys keyvals "pre-launch-env-vars") + (setup-env-defaults "runconfigs.config" 1 *already-seen-runconfig-info* keyvals environ-patt: "pre-launch-env-vars") (get-environment-variable "ALLTESTS"))) (test #f "ubuntu" (car (keys:target-set-args keys (args:get-arg "-target") args:arg-hash))) (define rinfo #f) -(test "get-run-info" #f (vector? (vector-ref (let ((rinf (cdb:remote-run db:get-run-info #f 1))) +(test "get-run-info" #f (vector? (vector-ref (let ((rinf (rmt:get-run-info 1))) (set! rinfo rinf) rinf) 0))) -(test "get-key-vals" "key1" (car (cdb:remote-run db:get-key-vals #f 1))) +;; (test "get-key-vals" "key1" (car (db:get-key-vals *dbstruct* 1))) (test "tests:sort-by" '() (tests:sort-by-priority-and-waiton (make-hash-table))) (test "update-test_meta" "test1" (begin (runs:update-test_meta "test1" tconfig) - (let ((dat (cdb:remote-run db:testmeta-get-record #f "test1"))) + (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*))) @@ -105,62 +105,117 @@ (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 '())) -(test "launch-test" #t (string? (file-exists? (launch-test 1 1 rinfo keyvals "run1" tconfig "test1" test-path '() (make-hash-table))))) - - -(test "Run a test" #t (general-run-call - "-runtests" - "run a test" - (lambda (target runname keys keyvallst) - (let ((test-patts "test%")) - ;; (runs:run-tests target runname test-patts user (make-hash-table)) - ;; (run:test run-id run-info key-vals runname test-record flags parent-test) - ;; (set! *verbosity* 22) ;; (list 0 1 2)) - (run:test 1 ;; run-id - #f ;; run-info is yet only a dream - keyvallst ;; (keys:target->keyval keys target) - "run1" ;; runname - (vector ;; test_records.scm tests:testqueue - "test1" ;; testname - tconfig ;; testconfig - '() ;; waitons - 0 ;; priority - #f ;; items - #f ;; itemsdat - "" ;; itempath - ) - args:arg-hash ;; flags (e.g. -itemspatt) - #f) - ;; (set! *verbosity* 0) - )))) - - - - - -(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))) +;;====================================================================== +;; Create a test with multiple items and verify that rollup logic works +;;====================================================================== + +(rmt:register-test 1 "rollup" "") ;; toplevel test +(for-each + (lambda (itempath) + (rmt:register-test 1 "rollup" itempath) + (let ((test-id (rmt:get-test-id 1 "rollup" itempath)) + (comment (conc "This is a comment for itempath " itempath))) + ;; (rmt:test-set-state-status-by-id run-id test-id "COMPLETED" "PASS" comment) + (tests:test-set-status! 1 test-id "COMPLETED" "PASS" comment #f))) ;; #!key (work-area #f)) + '("item/1" "item/2" "item/3" "item/4" "item/5")) + +(test #f #t (number? (rmt:get-test-id 1 "rollup" "item/4"))) + +(define (get-state-status run-id testname itempath) + (let ((tdat (rmt:get-test-info-by-id 1 (rmt:get-test-id run-id testname itempath)))) + (list (db:test-get-state tdat) + (db:test-get-status tdat)))) + +(test "Rollup PASS" '("COMPLETED" "PASS") (get-state-status 1 "rollup" "")) +(let ((test-id (rmt:get-test-id 1 "rollup" "item/4")) + (top-id (rmt:get-test-id 1 "rollup" ""))) + (for-each + (lambda (state status rup-state rup-status) + ;; reset to COMPLETED/PASS + (tests:test-set-status! 1 test-id "COMPLETED" "PASS" #f #f) + (test "Top reset to COMPLETED/PASS" '("COMPLETED" "PASS")(get-state-status 1 "rollup" "")) + (tests:test-set-status! 1 test-id state status #f #f) + (test (conc "Item set to " state "/" status) + (list state status) + (get-state-status 1 "rollup" "item/4")) + (test (conc "Rollup of " state "/" status) + (list rup-state rup-status) + (get-state-status 1 "rollup" ""))) + '("COMPLETED" "COMPLETED" "INCOMPLETE" "INCOMPLETE" "RUNNING" "RUNNING" "COMPLETED" "COMPLETED") + '("ABORT" "FAIL" "PASS" "FAIL" "PASS" "FAIL" "BLAH" "AUTO") + '("COMPLETED" "COMPLETED" "COMPLETED" "COMPLETED" "RUNNING" "RUNNING" "COMPLETED" "COMPLETED") + '("ABORT" "FAIL" "FAIL" "FAIL" "PASS" "FAIL" "ABORT" "AUTO"))) + + +(test "launch-test" #t + (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))))) + + + (exit 1) + + + + +;; (test "Run a test" #t (general-run-call +;; "-runtests" +;; "run a test" +;; (lambda (target runname keys keyvallst) +;; (let ((test-patts "test%")) +;; ;; (runs:run-tests target runname test-patts user (make-hash-table)) +;; ;; (run:test run-id run-info key-vals runname test-record flags parent-test) +;; ;; (set! *verbosity* 22) ;; (list 0 1 2)) +;; (run:test 1 ;; run-id +;; #f ;; run-info is yet only a dream +;; keyvallst ;; (keys:target->keyval keys target) +;; "run1" ;; runname +;; (vector ;; test_records.scm tests:testqueue +;; "test1" ;; testname +;; tconfig ;; testconfig +;; (make-hash-table) ;; flags +;; #f ;; parent test +;; (tests:get-all) ;; test registry +;; 0 ;; priority +;; #f ;; items +;; #f ;; itemsdat +;; "" ;; itempath +;; ) +;; args:arg-hash ;; flags (e.g. -itemspatt) +;; #f) +;; ;; (set! *verbosity* 0) +;; )))) +;; +;; +;; +;; +;; +;; (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))) + ;; (test "cache is coherent" #t (let ((cached-info (db:get-test-info-cached-by-id db 2)) ;; (non-cached (db:get-test-info-not-cached-by-id db 2))) ;; (print "\nCached: " cached-info) ;; (print "Noncached: " non-cached) ;; (equal? cached-info non-cached))) (change-directory test-work-dir) +(test #f #t (> (length (mt:get-tests-for-run 1 "test1" '() '())) 0)) (test "Add a step" #t (begin - (db:teststep-set-status! db 2 "step1" "start" 0 "This is a comment" "mylogfile.html") + (rmt:teststep-set-status! 1 30002 "step1" "start" 0 "This is a comment" "mylogfile.html") (sleep 2) - (db:teststep-set-status! db 2 "step1" "end" "pass" "This is a different comment" "finallogfile.html") - (set! test-id (db:test-get-id (car (cdb:remote-run db:get-tests-for-run #f 1 "test1" '() '())))) + (rmt:teststep-set-status! 1 30002 "step1" "end" "pass" "This is a different comment" "finallogfile.html") + (set! test-id (db:test-get-id (car (mt:get-tests-for-run 1 "test1" '() '())))) (number? test-id))) (test "Get rundir" #t (let ((rundir (cdb:remote-run db:test-get-rundir-from-test-id #f test-id))) (print "Rundir " rundir) (system (conc "mkdir -p " rundir)) Index: tests/unittests/tests.scm ================================================================== --- tests/unittests/tests.scm +++ tests/unittests/tests.scm @@ -0,0 +1,13 @@ +;;====================================================================== +;; itemwait, itemmatch + +(db:compare-itempaths ref-item-path item-path itemmap) + +;; prereqs-not-met + +(rmt:get-prereqs-not-met run-id waitons item-path mode: testmode itemmap: itemmap)) + + (fails (runs:calc-fails prereqs-not-met)) + (prereq-fails (runs:calc-prereq-fail prereqs-not-met)) + (non-completed (runs:calc-not-completed prereqs-not-met)) + (runnables (runs:calc-runnable prereqs-not-met))) Index: tree.scm ================================================================== --- tree.scm +++ tree.scm @@ -65,43 +65,45 @@ (loop hed tal depth (+ nodenum 1))))) #f)))) ;; top is the top node name zeroeth node VALUE=0 (define (tree:add-node obj top nodelst #!key (userdata #f)) - (if (or (not (string? (iup:attribute obj "TITLE0"))) - (string-null? (iup:attribute obj "TITLE0"))) - (iup:attribute-set! obj "ADDBRANCH0" top)) - (cond - ((not (equal? top (iup:attribute obj "TITLE0"))) - (print "ERROR: top name " top " doesn't match " (iup:attribute obj "TITLE0"))) - ((null? nodelst)) - (else - (let loop ((hed (car nodelst)) - (tal (cdr nodelst)) - (depth 1) - (pathl (list top))) - ;; Because the tree dialog changes node numbers when - ;; nodes are added or removed we must look up nodes - ;; each and every time. 0 is the top node so default - ;; to that. - (let* ((newpath (append pathl (list hed))) - (parentnode (tree:find-node obj pathl)) - (nodenum (tree:find-node obj newpath))) - ;; Add the branch under lastnode if not found - (if (not nodenum) - (begin - (iup:attribute-set! obj (conc "ADDBRANCH" parentnode) hed) + (let ((curr-top (iup:attribute obj "TITLE0"))) + (if (or (not (string? curr-top)) + (string-null? curr-top) + (string-match "^\\s*$" curr-top)) + (iup:attribute-set! obj "ADDBRANCH0" top)) + (cond + ((not (equal? top (iup:attribute obj "TITLE0"))) + (print "ERROR: top name " top " doesn't match " (iup:attribute obj "TITLE0"))) + ((null? nodelst)) + (else + (let loop ((hed (car nodelst)) + (tal (cdr nodelst)) + (depth 1) + (pathl (list top))) + ;; Because the tree dialog changes node numbers when + ;; nodes are added or removed we must look up nodes + ;; each and every time. 0 is the top node so default + ;; to that. + (let* ((newpath (append pathl (list hed))) + (parentnode (tree:find-node obj pathl)) + (nodenum (tree:find-node obj newpath))) + ;; Add the branch under lastnode if not found + (if (not nodenum) + (begin + (iup:attribute-set! obj (conc "ADDBRANCH" parentnode) hed) ;; ERROR? ADDING DATA TO PARENT, DONT WE WANT IT ON CREATED NODE? - (if userdata - (iup:attribute-set! obj (conc "USERDATA" parentnode) userdata)) - (if (null? tal) - #t - ;; reset to top - (loop (car nodelst)(cdr nodelst) 1 (list top)))) - (if (null? tal) ;; if null here then this path has already been added - #t - (loop (car tal)(cdr tal)(+ depth 1) newpath)))))))) + (if userdata + (iup:attribute-set! obj (conc "USERDATA" parentnode) userdata)) + (if (null? tal) + #t + ;; reset to top + (loop (car nodelst)(cdr nodelst) 1 (list top)))) + (if (null? tal) ;; if null here then this path has already been added + #t + (loop (car tal)(cdr tal)(+ depth 1) newpath))))))))) (define (tree:node->path obj nodenum) (let loop ((currnode 0) (path '())) (let* ((node-depth (string->number (iup:attribute obj (conc "DEPTH" currnode)))) Index: utils/Makefile.installall ================================================================== --- utils/Makefile.installall +++ utils/Makefile.installall @@ -34,12 +34,13 @@ endif # Set this on the command line of your make call if needed: make PROXY=host.com:1234 PROXY= +# http://code.call-cc.org/dev-snapshots/2015/06/07/chicken-4.10.0rc1.tar.gz # Select version of chicken, sqlite3 etc -CHICKEN_VERSION=4.9.0.1 +CHICKEN_VERSION=4.10.0rc1 SQLITE3_VERSION=3080500 # http://www.sqlite.org/2014/sqlite-autoconf-3080500.tar.gz # Override IUPBRANCH to use other than trunk IUPBRANCH=iup-3.10.1 @@ -136,10 +137,13 @@ wget http://code.call-cc.org/dev-snapshots/2014/04/17/chicken-4.9.0rc1.tar.gz chicken-4.9.0.1.tar.gz : wget http://code.call-cc.org/releases/4.9.0/chicken-4.9.0.1.tar.gz +chicken-4.10.0rc1.tar.gz : + wget http://code.call-cc.org/dev-snapshots/2015/06/07/chicken-4.10.0rc1.tar.gz + # git clone git://code.call-cc.org/chicken-core # git clone http://code.call-cc.org/git/chicken-core.git $(CHICKEN_INSTALL) : chicken-core/chicken.scm $(PREFIX)/setup-chicken4x.sh $(PREFIX)/setup-chicken4x.csh cd chicken-core;make PLATFORM=linux PREFIX=$(PREFIX) ADDED utils/mtrunner Index: utils/mtrunner ================================================================== --- /dev/null +++ utils/mtrunner @@ -0,0 +1,14 @@ +#! /bin/bash + +# Run megatest from within megatest +# Usage: mtrunner testsuite_dir megatest_bin_dir command args .... + +for var in $(env | egrep "^MT_"|cut -d= -f1);do + unset ${var} +done +cd $1 +shift +export PATH="$1:$PATH" +shift + +"$@"