ADDED all-exceptions.ods Index: all-exceptions.ods ================================================================== --- /dev/null +++ all-exceptions.ods cannot compute difference between binary files Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -281,12 +281,23 @@ ;;====================================================================== ;; E X I T H A N D L I N G ;;====================================================================== -(define (std-exit-procedure area-dat) - (let* ((no-hurry (if *time-to-exit* ;; hurry up +(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) + (let ((no-hurry (if *time-to-exit* ;; hurry up #f (begin (set! *time-to-exit* #t) #t))) (configdat (megatest:area-configdat area-dat)) @@ -315,17 +326,17 @@ (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! 1)) - (debug:print 0 " Done.") + (thread-sleep! 2)) + (debug:print 4 " ... done") ) "clean exit"))) - (thread-start! th2) (thread-start! th1) - (thread-join! th2)))) + (thread-start! th2) + (thread-join! th1)))) (define (std-signal-handler signum) ;; (signal-mask! signum) (set! *time-to-exit* #t) (debug:print 0 "ERROR: Received signal " signum " exiting promptly") Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -216,10 +216,11 @@ ;; General displayer ;; (define (dashboard:area-display data adat window-id) (let* ((view-matrix (iup:matrix + ;; (runs-for-targ (db:get-runs-by-patt *dbstruct-local* *keys* "%" target #f #f #f)) #:expand "YES" ;; #:fittosize "YES" #:scrollbar "YES" #:numcol 100 #:numlin 100 @@ -240,10 +241,14 @@ ;; Browse and control a single run ;; (define (runcontrol window-id) (iup:hbox)) +;; NB// Wierd conflict error here +;; +;; (let* ((runs-dat (db:get-runs-by-patt db *keys* "%" #f #f #f #f)) + ;;====================================================================== ;; A R E A S ;;====================================================================== (define (dashboard:init-area data area-name apath) Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -166,29 +166,32 @@ ;; open an sql database inside a file lock ;; ;; returns: db existed-prior-to-opening ;; (define (db:lock-create-open fname initproc area-dat) - (if (file-exists? fname) - (let ((db (sqlite3:open-database fname))) - (sqlite3:set-busy-handler! db (make-busy-timeout 136000)) - (db:set-sync db area-dat) ;; (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 area-dat) ;; (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 area-dat) ;; (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 area-dat) ;; (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 area-dat run-id #!key (attemptnum 0)(do-not-open #f)) ;; (conc toppath "/megatest.db") (car configinfo))) (let* ((local (dbr:dbstruct-get-local dbstruct)) @@ -207,11 +210,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 area-dat run-id attemptnum (+ attemptnum 1)))) (db:initialize-run-id-db db) (sqlite3:execute @@ -496,32 +499,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 area-dat 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)) ;; return zero for num synced + + 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))) @@ -1619,10 +1704,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 ;; @@ -1739,11 +1840,11 @@ (db:delay-if-busy dbdat area-dat) (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)) @@ -1778,12 +1879,13 @@ ;; 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 area-dat 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 area-dat keys runnamepatt targpatt offset limit fields) ;; test-name) +;; (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")) 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.6014) +(define megatest-version 1.6015) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -143,10 +143,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 @@ -259,10 +261,12 @@ "-ping" "-refdb2dat" "-o" "-log" "-archive" + "-since" + "-fields" ) (list "-h" "-help" "--help" "-version" "-force" "-xterm" @@ -324,16 +328,11 @@ (thread-sleep! 0.05) ;; delay for startup ;; the query to get megatest-db setting might not work, forcing it to be default on. Use "no" to turn off (let ((legacy-sync (configf:lookup (megatest:area-configdat *area-dat*) "setup" "megatest-db")) (debug-mode (debug:debug-mode 1)) (last-time (current-seconds))) - (if (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") - ) + (if (common:legacy-sync-recommended) (let loop () ;; sync for filesystem local db writes ;; (let ((start-time (current-seconds)) (servers-started (make-hash-table))) @@ -752,14 +751,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 area-dat) (let* ((toppath (megatest:area-path area-dat)) (keys (rmt:get-keys)) @@ -787,11 +792,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))) @@ -813,12 +818,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"))) @@ -900,32 +905,96 @@ *area-dat*)) ;;====================================================================== ;; 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 *area-dat*) (let* ((dbstruct (make-dbr:dbstruct path: (megatest:area-path *area-dat*) 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))) + (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 (rmt:get-runs-by-patt 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 (list "runs" "id" "target" "runname") + (cons "tests" db:test-record-fields) ;; "id" "testname" "test_path") + (list "steps" "id" "stepname")))) + (runs-spec (let ((r (alist-ref "runs" fields-spec equal?))) + (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)) @@ -936,40 +1005,79 @@ (hash-table-set! seen targetstr #t) ;; (print "[" targetstr "]")))) (if (not dmode)(print targetstr)))) (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 + (rmt:get-tests-for-run 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 @@ -1003,10 +1111,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 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 Index: rmt.scm ================================================================== --- rmt.scm +++ rmt.scm @@ -559,11 +559,11 @@ (rmt:send-receive 'set-run-status #f (list run-id run-status msg) area-dat)) (define (rmt:update-run-event_time run-id area-dat) (rmt:send-receive 'update-run-event_time #f (list run-id) area-dat)) -(define (rmt:get-runs-by-patt keys runnamepatt targpatt offset limit area-dat) +(define (rmt:get-runs-by-patt keys runnamepatt targpatt offset limit area-dat fields) (rmt:send-receive 'get-runs-by-patt #f (list keys runnamepatt targpatt offset limit) area-dat)) (define (rmt:find-and-mark-incomplete run-id ovr-deadtime area-dat) (if (rmt:send-receive 'have-incompletes? run-id (list run-id ovr-deadtime) area-dat) (rmt:send-receive 'mark-incomplete run-id (list run-id ovr-deadtime) area-dat))) Index: tests.scm ================================================================== --- tests.scm +++ tests.scm @@ -139,11 +139,11 @@ (testconfig (tests:get-testconfig (db:test-get-testname testdat) test-registry #f area-dat)) (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 Index: tests/fullrun/megatest.config ================================================================== --- tests/fullrun/megatest.config +++ tests/fullrun/megatest.config @@ -28,11 +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 #{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].* @@ -103,10 +106,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 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 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 +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