Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -6,11 +6,11 @@ ods.scm runconfig.scm server.scm configf.scm \ db.scm keys.scm margs.scm megatest-version.scm \ process.scm runs.scm tasks.scm tests.scm genexample.scm \ fs-transport.scm http-transport.scm \ client.scm gutils.scm synchash.scm daemon.scm mt.scm dcommon.scm \ - tree.scm ezsteps.scm lock-queue.scm + tree.scm ezsteps.scm lock-queue.scm sdb.scm GUISRCF = dashboard-tests.scm dashboard-guimonitor.scm OFILES = $(SRCFILES:%.scm=%.o) GOFILES = $(GUISRCF:%.scm=%.o) Index: NOTES ================================================================== --- NOTES +++ NOTES @@ -1,5 +1,9 @@ + +[87cbe68f31] +[be405e8e2e] + # FROM andyjpg on #chicken (let ((original-exit (exit-handler))) (exit-handler (lambda (#!optional (exit-code 0)) (printf "Preparing to exit...\n" exit-code) Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -75,10 +75,14 @@ ;; Testconfig and runconfig caches. (define *testconfigs* (make-hash-table)) ;; test-name => testconfig (define *runconfigs* (make-hash-table)) ;; target => runconfig +;; This is a cache of pre-reqs met, don't re-calc in cases where called with same params less than +;; five seconds ago +(define *pre-reqs-met-cache* (make-hash-table)) + (define (common:clear-caches) (set! *target* (make-hash-table)) (set! *keys* (make-hash-table)) (set! *keyvals* (make-hash-table)) (set! *toptest-paths* (make-hash-table)) @@ -370,13 +374,25 @@ (define (seconds->time-string sec) (time->string (seconds->local-time sec) "%H:%M:%S")) +(define (seconds->work-week/day-time sec) + (time->string + (seconds->local-time sec) "ww%V.%u %H:%M")) + (define (seconds->work-week/day sec) (time->string - (seconds->local-time sec) "%V.%u")) + (seconds->local-time sec) "ww%V.%u")) + +(define (seconds->year-work-week/day sec) + (time->string + (seconds->local-time sec) "%yww%V.%w")) + +(define (seconds->year-work-week/day-time sec) + (time->string + (seconds->local-time sec) "%yww%V.%w %H:%M")) ;;====================================================================== ;; Colors ;;====================================================================== Index: configf.scm ================================================================== --- configf.scm +++ configf.scm @@ -118,20 +118,24 @@ (configf:lookup config "default" var)) (configf:lookup config "default" var)))) (define-inline (configf:read-line p ht allow-processing) (let loop ((inl (read-line p))) - (if (and (string? inl) - (not (string-null? inl)) - (equal? "\\" (string-take-right inl 1))) ;; last character is \ - (let ((nextl (read-line p))) - (if (not (eof-object? nextl)) - (loop (string-append inl nextl)))) - (if (and allow-processing - (not (eq? allow-processing 'return-string))) - (configf:process-line inl ht) - inl)))) + (let ((cont-line (and (string? inl) + (not (string-null? inl)) + (equal? "\\" (string-take-right inl 1))))) + (if cont-line ;; last character is \ + (let ((nextl (read-line p))) + (if (not (eof-object? nextl)) + (loop (string-append (if cont-line + (string-take inl (- (string-length inl) 1)) + inl) + nextl)))) + (if (and allow-processing + (not (eq? allow-processing 'return-string))) + (configf:process-line inl ht) + inl))))) ;; read a config file, returns hash table of alists ;; read a config file, returns hash table of alists ;; adds to ht if given (must be #f otherwise) Index: dashboard-tests.scm ================================================================== --- dashboard-tests.scm +++ dashboard-tests.scm @@ -43,11 +43,12 @@ (list "Testname: " "Item path: " "Current state: " "Current status: " "Test comment: " - "Test id: ")) + "Test id: " + "Test date: ")) (list (iup:label "" #:expand "VERTICAL")))) (apply iup:vbox ; #:expand "YES" (list (store-label "testname" (iup:label (db:test-get-testname testdat) #:expand "HORIZONTAL") @@ -78,10 +79,15 @@ (store-label "testid" (iup:label "TestId " #:expand "HORIZONTAL") (lambda (testdat) (db:test-get-id testdat))) + (store-label "testdate" + (iup:label "TestDate " + #:expand "HORIZONTAL") + (lambda (testdat) + (seconds->work-week/day-time (db:test-get-event_time testdat)))) ))))) ;;====================================================================== ;; Test meta panel ;;====================================================================== @@ -127,26 +133,34 @@ ;;====================================================================== ;; Run info panel ;;====================================================================== (define (run-info-panel keydat testdat runname) - (iup:frame - #:title "Megatest Run Info" ; #:expand "YES" - (iup:hbox ; #:expand "YES" - (apply iup:vbox ; #:expand "YES" - (append (map (lambda (keyval) - (iup:label (conc (car keyval) " ") ; #:expand "HORIZONTAL" - )) - keydat) - (list (iup:label "runname ")(iup:label "run-id")))) - (apply iup:vbox - (append (map (lambda (keyval) - (iup:label (cadr keyval) #:expand "HORIZONTAL")) - keydat) - (list (iup:label runname) - (iup:label (conc (db:test-get-run_id testdat))) - (iup:label "" #:expand "VERTICAL"))))))) + (let* ((run-id (db:test-get-run_id testdat)) + (rundat (cdb:remote-run db:get-run-info #f run-id)) + (header (db:get-header rundat)) + (event_time (db:get-value-by-header (db:get-row rundat) + (db:get-header rundat) + "event_time"))) + (iup:frame + #:title "Megatest Run Info" ; #:expand "YES" + (iup:hbox ; #:expand "YES" + (apply iup:vbox ; #:expand "YES" + (append (map (lambda (keyval) + (iup:label (conc (car keyval) " "))) + keydat) + (list (iup:label "runname ") + (iup:label "run-id") + (iup:label "run-date")))) + (apply iup:vbox + (append (map (lambda (keyval) + (iup:label (cadr keyval) #:expand "HORIZONTAL")) + keydat) + (list (iup:label runname) + (iup:label (conc run-id)) + (iup:label (seconds->year-work-week/day-time event_time)) + (iup:label "" #:expand "VERTICAL")))))))) ;;====================================================================== ;; Host info panel ;;====================================================================== (define (host-info-panel testdat store-label) @@ -355,29 +369,53 @@ (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) + (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 + ;; NOTE: BUG HIDER, try to eliminate this exception handler (handle-exceptions exn - (debug:print-info 2 "test db access issue: " ((condition-property-accessor 'exn 'message) exn)) - (open-run-close db:get-test-info-by-id db test-id ))))) + (debug:print-info 0 "WARNING: test db access issue for test " test-id ": " ((condition-property-accessor 'exn 'message) exn)) + (make-db:test) + (let* ((newdat (open-run-close db:get-test-info-by-id db test-id )) + (tstdat (if newdat + (open-run-close tests:testdat-get-testinfo db test-id #f) + '()))) + (if (and newdat + (not (null? tstdat))) ;; (update-time cpuload diskfree run-duration) + (let* ((rec (car tstdat)) + (cpuload (vector-ref rec 1)) + (diskfree (vector-ref rec 2)) + (run-dur (vector-ref rec 3))) + (db:test-set-run_duration! newdat run-dur) + (db:test-set-diskfree! newdat diskfree) + (db:test-set-cpuload! newdat cpuload))) + ;; (debug:print 0 "newdat=" newdat) + newdat) + ) + #f))) + ;; (debug:print 0 "newtestdat=" newtestdat) (cond ((and need-update newtestdat) (set! testdat newtestdat) (set! teststeps (db:get-compressed-steps test-id work-area: rundir)) (set! logfile (conc (db:test-get-rundir testdat) "/" (db:test-get-final_logf testdat))) (set! rundir (db:test-get-rundir testdat)) (set! testfullname (db:test-get-fullname testdat)) ;; (debug:print 0 "INFO: teststeps=" (intersperse teststeps "\n ")) - (if (eq? curr-mod-time db-mod-time) ;; do only once if same - (set! db-mod-time (+ curr-mod-time 1)) + + ;; I don't see why this was implemented this way. Please comment it ... + ;; (if (eq? curr-mod-time db-mod-time) ;; do only once if same + ;; (set! db-mod-time (+ curr-mod-time 1)) + ;; (set! db-mod-time curr-mod-time)) + + (if (not (eq? curr-mod-time db-mod-time)) (set! db-mod-time curr-mod-time)) (set! last-update (current-milliseconds)) (set! request-update #f) ;; met the need ... ) (need-update ;; if this was true and yet there is no data .... Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -225,14 +225,17 @@ (for-each (lambda (run) (let* ((run-id (db:get-value-by-header run header "id")) (tests (mt:get-tests-for-run run-id testnamepatt states statuses not-in: *hide-not-hide* sort-by: sort-by - sort-order: sort-order)) + sort-order: sort-order + qryvals: 'shortlist)) ;; NOTE: bubble-up also sets the global *all-item-test-names* ;; (tests (bubble-up tmptests priority: bubble-type)) (key-vals (cdb:remote-run db:get-key-vals #f 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) (set! maxtests (length tests))) (if (or (not *hide-empty-runs*) ;; this reduces the data burden when set @@ -459,11 +462,11 @@ (testname (db:test-get-testname test)) (itempath (db:test-get-item-path test)) (testfullname (test:test-get-fullname test)) (teststatus (db:test-get-status test)) (teststate (db:test-get-state test)) - (teststart (db:test-get-event_time test)) + ;;(teststart (db:test-get-event_time test)) (runtime (db:test-get-run_duration test)) (buttontxt (if (equal? teststate "COMPLETED") teststatus teststate)) (button (vector-ref columndat rown)) (color (car (gutils:get-color-for-state-status teststate teststatus))) (curr-color (vector-ref buttondat 1)) ;; (iup:attribute button "BGCOLOR")) Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -78,35 +78,39 @@ 136000)))) ;; 136000))) ;; 136000 = 2.2 minutes (if (and dbexists (not write-access)) (set! *db-write-access* write-access)) ;; only unset so other db's also can use this control (debug:print-info 11 "open-db, dbpath=" dbpath " argv=" (argv)) - (sqlite3:set-busy-handler! db handler) + (if write-access (sqlite3:set-busy-handler! db handler)) (if (not dbexists) (db:initialize db)) - (db:set-sync db) + ;; Moving db:set-sync to a call in run.scm - it is a persistent value and only needs to be set once + ;; (db:set-sync db) db)) ;; keeping it around for debugging purposes only (define (open-run-close-no-exception-handling proc idb . params) (debug:print-info 11 "open-run-close-no-exception-handling START given a db=" (if idb "yes " "no ") ", params=" params) - (let* ((db (if idb - (if (procedure? idb) - (idb) - idb) - (open-db))) - (res #f)) - (set! res (apply proc db params)) - (if (not idb)(sqlite3:finalize! db)) - (debug:print-info 11 "open-run-close-no-exception-handling END" ) - res)) + (if (or *db-write-access* + (not (member proc *db:all-write-procs*))) + (let* ((db (cond + ((sqlite3:database? idb) idb) + ((not idb) (open-db)) + ((procedure? idb) (idb)) + (else (open-db)))) + (res #f)) + (set! res (apply proc db params)) + (if (not idb)(sqlite3:finalize! db)) + (debug:print-info 11 "open-run-close-no-exception-handling END" ) + res) + #f)) (define (open-run-close-exception-handling proc idb . params) (handle-exceptions exn (begin - (debug:print 0 "EXCEPTION: database probably overloaded?") + (debug:print 0 "EXCEPTION: database probably overloaded or unreadable.") (debug:print 0 " " ((condition-property-accessor 'exn 'message) exn)) (print-call-chain) (thread-sleep! (random 120)) (debug:print-info 0 "trying db call one more time....") (apply open-run-close-no-exception-handling proc idb params)) @@ -252,10 +256,11 @@ (debug:print-info 11 "open-test-db " work-area) (if (and work-area (directory? work-area) (file-read-access? work-area)) (let* ((dbpath (conc work-area "/testdat.db")) + (tdb-writeable (file-write-access? dbpath)) (dbexists (file-exists? dbpath)) (handler (make-busy-timeout (if (args:get-arg "-override-timeout") (string->number (args:get-arg "-override-timeout")) 136000)))) (handle-exceptions @@ -263,11 +268,11 @@ (begin (debug:print 2 "ERROR: problem accessing test db " work-area ", you probably should clean and re-run this test" ((condition-property-accessor 'exn 'message) exn)) (set! db (sqlite3:open-database ":memory:"))) ;; open an in-memory db to allow readonly access (set! db (sqlite3:open-database dbpath))) - (sqlite3:set-busy-handler! db handler) + (if *db-write-access* (sqlite3:set-busy-handler! db handler)) (if (not dbexists) (begin (sqlite3:execute db "PRAGMA synchronous = FULL;") (debug:print-info 11 "Initialized test database " dbpath) (db:testdb-initialize db))) @@ -460,10 +465,69 @@ (db:set-var db "MEGATEST_VERSION" 1.37) (sqlite3:execute db "ALTER TABLE tests ADD COLUMN archived INTEGER DEFAULT 0;")) ((< mver megatest-version) (db:set-var db "MEGATEST_VERSION" megatest-version)))))) +;;====================================================================== +;; M A I N T E N A N C E +;;====================================================================== + +;; select end_time-now from +;; (select testname,item_path,event_time+run_duration as +;; end_time,strftime('%s','now') as now from tests where state in +;; ('RUNNING','REMOTEHOSTSTART','LAUNCED')); + + +(define (db:find-and-mark-incomplete db #!key (ovr-deadtime #f)) + (let* ((incompleted '()) + (deadtime-str (configf:lookup *configdat* "setup" "deadtime")) + (deadtime (if (and deadtime-str + (string->number deadtime-str)) + (string->number deadtime-str) + 7200)) ;; two hours + (run-ids (db:get-run-ids db))) ;; iterate over runs to divy up the calls + (if (number? ovr-deadtime)(set! deadtime ovr-deadtime)) + (for-each + (lambda (run-id) + + ;; in RUNNING or REMOTEHOSTSTART for more than 10 minutes + ;; + ;; THIS CANNOT WORK. The run_duration is not updated in the central db due to performance concerns. + ;; The testdat.db file must be consulted. + ;; + ;; HOWEVER: this code in run:test seems to work fine + ;; (> (- (current-seconds)(+ (db:test-get-event_time testdat) + ;; (db:test-get-run_duration testdat))) + ;; 600) + (sqlite3:for-each-row + (lambda (test-id) + (set! incompleted (cons test-id incompleted))) + db + "SELECT id FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time - run_duration) > ? AND state IN ('RUNNING','REMOTEHOSTSTART');" + run-id deadtime) + + ;; in LAUNCHED for more than one day. Could be long due to job queues TODO/BUG: Need override for this in config + ;; + (sqlite3:for-each-row + (lambda (test-id) + (set! incompleted (cons test-id incompleted))) + db + "SELECT id FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time - run_duration) > ? AND state IN ('LAUNCHED');" + run-id (* 60 60 24))) + run-ids) + + ;; These are defunct tests, do not do all the overhead of set-state-status. Force them to INCOMPLETE. + ;; + (if (> (length incompleted) 0) + (begin + (debug:print 0 "WARNING: Marking test(s); " (string-intersperse (map conc incompleted) ", ") " as INCOMPLETE") + (sqlite3:execute + db + (conc "UPDATE tests SET state='INCOMPLETE' WHERE id IN (" + (string-intersperse (map conc incompleted) ",") + ");")))))) + ;; Clean out old junk and vacuum the database ;; ;; Ultimately do something like this: ;; ;; 1. Look at test records either deleted or part of deleted run: @@ -500,14 +564,12 @@ (sqlite3:for-each-row (lambda (tot) (debug:print-info 0 "Records count after clean: " tot)) count-stmt))) (map sqlite3:finalize! statements) (sqlite3:finalize! count-stmt) + (db:find-and-mark-incomplete db) (sqlite3:execute db "VACUUM;"))) - -;; (define (db:report-junk-records db) - ;;====================================================================== ;; meta get and set vars ;;====================================================================== @@ -843,10 +905,18 @@ (sqlite3:execute db "UPDATE runs SET state=? WHERE id=?;" newlockval run-id) (sqlite3:execute db "INSERT INTO access_log (user,accessed,args) VALUES(?,strftime('%s','now'),?);" user (conc newlockval " " run-id)) (debug:print-info 1 "" newlockval " run number " run-id))) +(define (db:get-run-ids db) + (let ((res '())) + (sqlite3:for-each-row + (lambda (id) + (set! res (cons id res))) + db + "SELECT id FROM runs;"))) + ;;====================================================================== ;; K E Y S ;;====================================================================== ;; get key val pairs for a given run-id @@ -907,13 +977,15 @@ ;; i.e. these lists define what to NOT show. ;; states and statuses are required to be lists, empty is ok ;; not-in #t = above behaviour, #f = must match (define (db:get-tests-for-run db run-id testpatt states statuses offset limit not-in sort-by sort-order #!key - (qryvals #f) - ) - (let* ((qryvals (if qryvals qryvals "id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment")) + (qryvals #f)) + (let* ((qryvalstr (case qryvals + ((shortlist) "id,run_id,testname,item_path,state,status") + ((#f) "id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment") + (else qryvals))) (res '()) ;; if states or statuses are null then assume match all when not-in is false (states-qry (if (null? states) #f (conc " state " @@ -938,11 +1010,11 @@ (conc " AND " states-qry)) (statuses-qry (conc " AND " statuses-qry)) (else ""))) (tests-match-qry (tests:match->sqlqry testpatt)) - (qry (conc "SELECT " qryvals + (qry (conc "SELECT " qryvalstr " FROM tests WHERE run_id=? AND state != 'DELETED' " states-statuses-qry (if tests-match-qry (conc " AND (" tests-match-qry ") ") "") (case sort-by ((rundir) " ORDER BY length(rundir) ") @@ -963,16 +1035,57 @@ (set! res (cons (apply vector a b) res))) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment) res))) db qry run-id ) + (case qryvals + ((shortlist)(map db:test-short-record->norm res)) + ((#f) res) + (else res)))) + +(define (db:test-short-record->norm inrec) + ;; "id,run_id,testname,item_path,state,status" + ;; "id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment + (vector (vector-ref inrec 0) ;; id + (vector-ref inrec 1) ;; run_id + (vector-ref inrec 2) ;; testname + (vector-ref inrec 4) ;; state + (vector-ref inrec 5) ;; status + -1 "" -1 -1 "" "-" + (vector-ref inrec 3) ;; item-path + -1 "-" "-")) + + +(define (db:get-tests-for-run-state-status db run-id testpatt) + (let ((res '()) + (tests-match-qry (tests:match->sqlqry testpatt))) + (sqlite3:for-each-row + (lambda (id testname item-path state status) + ;; id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment + (set! res (cons (vector id run-id testname state status -1 "" -1 -1 "" "-" item-path -1 "-" "-") res))) + db + (conc "SELECT id,testname,item_path,state,status FROM tests WHERE run_id=? " + (if tests-match-qry (conc " AND (" tests-match-qry ") ") "")) + run-id) + res)) + +(define (db:get-testinfo-state-status db test-id) + (let ((res #f)) + (sqlite3:for-each-row + (lambda (run-id testname item-path state status) + ;; id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment + (set! res (vector test-id run-id testname state status -1 "" -1 -1 "" "-" item-path -1 "-" "-"))) + db + "SELECT run_id,testname,item_path,state,status FROM tests WHERE id=?;" + test-id) res)) ;; get a useful subset of the tests data (used in dashboard ;; use db:mintests-get-{id ,run_id,testname ...} (define (db:get-tests-for-runs-mindata db run-ids testpatt states status not-in) (db:get-tests-for-runs db run-ids testpatt states status not-in: not-in qryvals: "id,run_id,testname,state,status,event_time,item_path")) + ;; NB // This is get tests for "runs" (note the plural!!) ;; ;; states and statuses are lists, turn them into ("PASS","FAIL"...) and use NOT IN ;; i.e. these lists define what to NOT show. @@ -1027,11 +1140,11 @@ ;; this one is a bit broken BUG FIXME (define (db:delete-test-step-records db test-id #!key (work-area #f)) ;; Breaking it into two queries for better file access interleaving (let* ((tdb (db:open-test-db-by-test-id db test-id work-area: work-area))) ;; test db's can go away - must check every time - (if tdb + (if (sqlite3:database? tdb) (begin (sqlite3:execute tdb "DELETE FROM test_steps;") (sqlite3:execute tdb "DELETE FROM test_data;") (sqlite3:finalize! tdb))))) @@ -1121,14 +1234,14 @@ (if newstate (sqlite3:execute db "UPDATE tests SET state=? WHERE id=?;" newstate test-id)) (if newstatus (sqlite3:execute db "UPDATE tests SET status=? WHERE id=?;" newstatus test-id)) (if newcomment (sqlite3:execute db "UPDATE tests SET comment=? WHERE id=?;" newcomment test-id)))) (mt:process-triggers test-id newstate newstatus)) -;; Never used -;; (define (db:test-set-state-status-by-run-id-testname db run-id test-name item-path status state) -;; (sqlite3:execute db "UPDATE tests SET state=?,status=?,event_time=strftime('%s','now') WHERE run_id=? AND testname=? AND item_path=?;" -;; state status run-id test-name item-path)) +;; Never used, but should be? +(define (db:test-set-state-status-by-run-id-testname db run-id test-name item-path status state) + (sqlite3:execute db "UPDATE tests SET state=?,status=?,event_time=strftime('%s','now') WHERE run_id=? AND testname=? AND item_path=?;" + state status run-id test-name item-path)) (define (db:get-count-tests-running db) (let ((res 0)) (sqlite3:for-each-row (lambda (count) @@ -1588,11 +1701,16 @@ (hash-table-set! *test-info* test-id (vector (current-seconds) test-dat)) ;; cached for use where up-to-date info is not needed test-dat)) ;; db should be db open proc or #f (define (cdb:remote-run proc db . params) - (apply cdb:client-call *runremote* 'immediate #f *default-numtries* open-run-close proc #f params)) + (if (or *db-write-access* + (not (member proc *db:all-write-procs*))) + (apply cdb:client-call *runremote* 'immediate #f *default-numtries* open-run-close proc #f params) + (begin + (debug:print 0 "ERROR: Attempt to access read-only database") + #f))) (define (db:test-get-logfile-info db run-id test-name) (let ((res #f)) (sqlite3:for-each-row (lambda (path final_logf) @@ -1796,11 +1914,11 @@ ;; hand queries off to the write queue (let ((response (case *transport-type* ((http) (debug:print-info 7 "Queuing item " item " for wrapped write") (db:queue-write-and-wait db qry-sig query params)) - (else + (else (apply sqlite3:execute db query params) #t)))) (debug:print-info 7 "Received " response " from wrapped write") (server:reply return-address qry-sig response response)) ;; otherwise if appropriate flush the queue (this is a read or complex query) @@ -1900,11 +2018,11 @@ ;;====================================================================== (define (db:csv->test-data db test-id csvdata #!key (work-area #f)) (debug:print 4 "test-id " test-id ", csvdata: " csvdata) (let ((tdb (db:open-test-db-by-test-id db test-id work-area: work-area))) - (if tdb + (if (sqlite3:database? tdb) (let ((csvlist (csv->list (make-csv-reader (open-input-string csvdata) '((strip-leading-whitespace? #t) (strip-trailing-whitespace? #t)) )))) ;; (csv->list csvdata))) (for-each @@ -1960,11 +2078,11 @@ (sqlite3:finalize! tdb))))) ;; get a list of test_data records matching categorypatt (define (db:read-test-data db test-id categorypatt #!key (work-area #f)) (let ((tdb (db:open-test-db-by-test-id db test-id work-area: work-area))) - (if tdb + (if (sqlite3:database? tdb) (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))) tdb @@ -1992,11 +2110,11 @@ ;; if one or more are fail (any case) then set test status to PASS, non "pass" or "fail" are ignored (define (db:test-data-rollup db test-id status #!key (work-area #f)) (let ((tdb (db:open-test-db-by-test-id db test-id work-area: work-area)) (fail-count 0) (pass-count 0)) - (if tdb + (if (sqlite3:database? tdb) (begin (sqlite3:for-each-row (lambda (fcount pcount) (set! fail-count fcount) (set! pass-count pcount)) @@ -2045,20 +2163,25 @@ ;; db-get-test-steps-for-run (define (db:get-steps-for-test db test-id #!key (work-area #f)) (let* ((tdb (db:open-test-db-by-test-id db test-id work-area: work-area)) (res '())) - (if tdb - (begin - (sqlite3:for-each-row - (lambda (id test-id stepname state status event-time logfile) - (set! res (cons (vector id test-id stepname state status event-time (if (string? logfile) logfile "")) res))) - tdb - "SELECT id,test_id,stepname,state,status,event_time,logfile FROM test_steps WHERE test_id=? ORDER BY id ASC;" ;; event_time DESC,id ASC; - test-id) - (sqlite3:finalize! tdb) - (reverse res)) + (if (sqlite3:database? tdb) + (handle-exceptions + exn + (begin + (debug:print 0 "ERROR: error on access to testdat for test with id " test-id) + '()) + (begin + (sqlite3:for-each-row + (lambda (id test-id stepname state status event-time logfile) + (set! res (cons (vector id test-id stepname state status event-time (if (string? logfile) logfile "")) res))) + tdb + "SELECT id,test_id,stepname,state,status,event_time,logfile FROM test_steps WHERE test_id=? ORDER BY id ASC;" ;; event_time DESC,id ASC; + test-id) + (sqlite3:finalize! tdb) + (reverse res))) '()))) ;; get a pretty table to summarize steps ;; (define (db:get-steps-table db test-id #!key (work-area #f)) @@ -2229,11 +2352,11 @@ (result '())) (for-each (lambda (waitontest-name) ;; by getting the tests with matching name we are looking only at the matching test ;; and related sub items - (let ((tests (mt:get-tests-for-run run-id waitontest-name '() '())) + (let ((tests (cdb:remote-run db:get-tests-for-run-state-status #f run-id waitontest-name)) ;; (mt:get-tests-for-run run-id waitontest-name '() '())) (ever-seen #f) (parent-waiton-met #f) (item-waiton-met #f)) (for-each (lambda (test) @@ -2284,19 +2407,18 @@ (set! result (append (if (null? tests)(list waitontest-name) tests) result))))) waitons) (delete-duplicates result)))) (define (db:teststep-set-status! db test-id teststep-name state-in status-in comment logfile #!key (work-area #f)) - (debug:print 4 "test-id: " test-id " teststep-name: " teststep-name) ;; db:open-test-db-by-test-id does cdb:remote-run (let* ((tdb (db:open-test-db-by-test-id db test-id work-area: work-area)) (state (items:check-valid-items "state" state-in)) (status (items:check-valid-items "status" status-in))) (if (or (not state)(not status)) (debug:print 3 "WARNING: Invalid " (if status "status" "state") " value \"" (if status state-in status-in) "\", update your validvalues section in megatest.config")) - (if tdb + (if (sqlite3:database? tdb) (begin (sqlite3:execute tdb "INSERT OR REPLACE into test_steps (test_id,stepname,state,status,event_time,comment,logfile) VALUES(?,?,?,?,?,?,?);" test-id teststep-name state-in status-in (current-seconds) (if comment comment "") (if logfile logfile "")) @@ -2426,5 +2548,30 @@ results) ;; brutal clean up (system "rm -rf tempdir"))) ;; (db:extract-ods-file db "outputfile.ods" '(("sysname" "%")("fsname" "%")("datapath" "%")) "%") + +;; This is a list of all procs that write to the db +;; +(define *db:all-write-procs* + (list + db:set-var + db:del-var + db:register-run + db:set-comment-for-run + db:delete-run + db:update-run-event_time + db:lock/unlock-run + db:delete-test-step-records + db:delete-test-records + db:delete-tests-for-run + db:delete-old-deleted-test-records + db:set-tests-state-status + db:test-set-state-status-by-id + db:test-set-state-status-by-run-id-testname + db:test-set-comment + db:testmeta-add-record + db:csv->test-data + db:test-data-rollup + db:teststep-set-status! )) + Index: db_records.scm ================================================================== --- db_records.scm +++ db_records.scm @@ -1,6 +1,6 @@ -(define (make-db:test)(make-vector 6)) +(define (make-db:test)(make-vector 20)) (define-inline (db:test-get-id vec) (vector-ref vec 0)) (define-inline (db:test-get-run_id vec) (vector-ref vec 1)) (define-inline (db:test-get-testname vec) (vector-ref vec 2)) (define-inline (db:test-get-state vec) (vector-ref vec 3)) (define-inline (db:test-get-status vec) (vector-ref vec 4)) ADDED fdb_records.scm Index: fdb_records.scm ================================================================== --- /dev/null +++ fdb_records.scm @@ -0,0 +1,19 @@ +;; Single record for managing a filedb +;; make-vector-record "Filedb record" filedb fdb db dbpath pathcache idcache partcache +;; Filedb record +(define (make-filedb:fdb)(make-vector 5)) +(define-inline (filedb:fdb-get-db vec) (vector-ref vec 0)) +(define-inline (filedb:fdb-get-dbpath vec) (vector-ref vec 1)) +(define-inline (filedb:fdb-get-pathcache vec) (vector-ref vec 2)) +(define-inline (filedb:fdb-get-idcache vec) (vector-ref vec 3)) +(define-inline (filedb:fdb-get-partcache vec) (vector-ref vec 4)) +(define-inline (filedb:fdb-set-db! vec val)(vector-set! vec 0 val)) +(define-inline (filedb:fdb-set-dbpath! vec val)(vector-set! vec 1 val)) +(define-inline (filedb:fdb-set-pathcache! vec val)(vector-set! vec 2 val)) +(define-inline (filedb:fdb-set-idcache! vec val)(vector-set! vec 3 val)) +(define-inline (filedb:fdb-set-partcache! vec val)(vector-set! vec 4 val)) + +;; children records, should have use something other than "child" +(define-inline (filedb:child-get-id vec) (vector-ref vec 0)) +(define-inline (filedb:child-get-path vec) (vector-ref vec 1)) +(define-inline (filedb:child-get-parent_id vec)(vector-ref vec 2)) ADDED filedb.scm Index: filedb.scm ================================================================== --- /dev/null +++ filedb.scm @@ -0,0 +1,236 @@ +;; Copyright 2006-2011, 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. + +;; (require-extension synch sqlite3 posix srfi-13 srfi-1 utils regex) +(use sqlite3 srfi-1 posix regex srfi-69 srfi-13 posix-extras) +(import (prefix sqlite3 sqlite3:)) + +(declare (unit filedb)) + +(include "fdb_records.scm") +;; (include "settings.scm") + +(define (filedb:open-db dbpath) + (let* ((fdb (make-filedb:fdb)) + (dbexists (file-exists? dbpath)) + (db (sqlite3:open-database dbpath))) + (filedb:fdb-set-db! fdb db) + (filedb:fdb-set-dbpath! fdb dbpath) + (filedb:fdb-set-pathcache! fdb (make-hash-table)) + (filedb:fdb-set-idcache! fdb (make-hash-table)) + (filedb:fdb-set-partcache! fdb (make-hash-table)) + ;(sqlite3:set-busy-timeout! db 1000000) + (if (not dbexists) + (begin + (sqlite3:execute db "PRAGMA synchronous = OFF;") + (sqlite3:execute db "CREATE TABLE names (id INTEGER PRIMARY KEY,name TEST);") ;; for future use - change path in paths table to path_id + (sqlite3:execute db "CREATE INDEX name_index ON names (name);") + ;; NB// We store a useful subset of file attributes but do not attempt to store all + (sqlite3:execute db "CREATE TABLE paths (id INTEGER PRIMARY KEY, + path TEXT, + parent_id INTEGER, + mode INTEGER DEFAULT -1, + uid INTEGER DEFAULT -1, + gid INTEGER DEFAULT -1, + size INTEGER DEFAULT -1, + mtime INTEGER DEFAULT -1);") + (sqlite3:execute db "CREATE INDEX path_index ON paths (path,parent_id);") + (sqlite3:execute db "CREATE TABLE bases (id INTEGER PRIMARY KEY,base TEXT, updated TIMESTAMP);"))) + fdb)) + +(define (filedb:finalize-db! fdb) + (sqlite3:finalize! (filedb:fdb-get-db fdb))) + +(define (filedb:get-current-time-string) + (string-chomp (time->string (seconds->local-time (current-seconds))))) + +(define (filedb:get-base-id db path) + (let ((stmt (sqlite3:prepare db "SELECT id FROM bases WHERE base=?;")) + (id-num #f)) + (sqlite3:for-each-row + (lambda (num) (set! id-num num)) stmt path) + (sqlite3:finalize! stmt) + id-num)) + +(define (filedb:get-path-id db path parent) + (let ((stmt (sqlite3:prepare db "SELECT id FROM paths WHERE path=? AND parent_id=?;")) + (id-num #f)) + (sqlite3:for-each-row + (lambda (num) (set! id-num num)) stmt path parent) + (sqlite3:finalize! stmt) + id-num)) + +(define (filedb:add-base db path) + (let ((existing (filedb:get-base-id db path))) + (if existing #f + (begin + (sqlite3:execute db "INSERT INTO bases (base,updated) VALUES (?,?);" path (filedb:get-current-time-string)))))) + +;; index value field notes +;; 0 inode number st_ino +;; 1 mode st_mode bitfield combining file permissions and file type +;; 2 number of hard links st_nlink +;; 3 UID of owner st_uid as with file-owner +;; 4 GID of owner st_gid +;; 5 size st_size as with file-size +;; 6 access time st_atime as with file-access-time +;; 7 change time st_ctime as with file-change-time +;; 8 modification time st_mtime as with file-modification-time +;; 9 parent device ID st_dev ID of device on which this file resides +;; 10 device ID st_rdev device ID for special files (i.e. the raw major/minor number) +;; 11 block size st_blksize +;; 12 number of blocks allocated st_blocks + +(define (filedb:add-path-stat db path parent statinfo) + (let ((stmt (sqlite3:prepare db "INSERT INTO paths (path,parent_id,mode,uid,gid,size,mtime) VALUES (?,?,?,?,?,?,?);"))) + (sqlite3:execute stmt + path + parent + (vector-ref statinfo 1) ;; mode + (vector-ref statinfo 3) ;; uid + (vector-ref statinfo 4) ;; gid + (vector-ref statinfo 5) ;; size + (vector-ref statinfo 8) ;; mtime + ) + (sqlite3:finalize! stmt))) ;; (filedb:get-current-time-string)))) + +(define (filedb:add-path db path parent) + (let ((stmt (sqlite3:prepare db "INSERT INTO paths (path,parent_id) VALUES (?,?);"))) + (sqlite3:execute stmt path parent) + (sqlite3:finalize! stmt))) + +(define (filedb:register-path fdb path #!key (save-stat #f)) + (let* ((db (filedb:fdb-get-db fdb)) + (pathcache (filedb:fdb-get-pathcache fdb)) + (stat (if save-stat (file-stat path #t))) + (id (hash-table-ref/default pathcache path #f))) + (if id id + (let ((plist (string-split path "/"))) + (let loop ((head (car plist)) + (tail (cdr plist)) + (parent 0)) + (let ((id (filedb:get-path-id db head parent)) + (done (null? tail))) + (if id ;; we'll have a id if the path is already registered + (if done + (begin + (hash-table-set! pathcache path id) + id) ;; return the last path id for a result + (loop (car tail)(cdr tail) id)) + (begin ;; add the path and then repeat the loop with the same data + (if save-stat + (filedb:add-path-stat db head parent stat) + (filedb:add-path db head parent)) + (loop head tail parent))))))))) + +(define (filedb:update-recursively fdb path #!key (save-stat #f)) + (let ((p (open-input-pipe (string-append "find -L " path)))) ;; (resolve-pathname path)))) ;; (string-append "find " path)))) + (print "processed 0 files...") + (let loop ((l (read-line p)) + (lc 0)) ;; line count + (if (eof-object? l) + (begin + (print " " lc " files") + (close-input-port p)) + (begin + (filedb:register-path fdb l save-stat: save-stat) ;; (get-real-path l)) ;; don't like losing the original path info + (if (= (modulo lc 100) 0) + (print " " lc " files")) + (loop (read-line p)(+ lc 1))))))) + +(define (filedb:update fdb path #!key (save-stat #f)) + ;; first get the realpath and add it to the bases table + (let ((real-path path) ;; (filedb:get-real-path path)) + (db (filedb:fdb-get-db fdb))) + (filedb:add-base db real-path) + (filedb:update-recursively fdb path save-stat: save-stat))) + +;; not used and broken +;; +(define (filedb:get-real-path path) + (let* ((p (open-input-pipe (string-append real-path " " (regexp-escape path)))) + (pth (read-line p))) + (if (eof-object? pth) path + (begin + (close-input-port p) + pth)))) + +(define (filedb:drop-base fdb path) + (print "Sorry, I don't do anything yet")) + +(define (filedb:find-all fdb pattern action) + (let* ((db (filedb:fdb-get-db fdb)) + (stmt (sqlite3:prepare db "SELECT id FROM paths WHERE path like ?;")) + (result '())) + (sqlite3:for-each-row + (lambda (num) + (action num) + (set! result (cons num result))) stmt pattern) + (sqlite3:finalize! stmt) + result)) + +(define (filedb:get-path-record fdb id) + (let* ((db (filedb:fdb-get-db fdb)) + (partcache (filedb:fdb-get-partcache fdb)) + (dat (hash-table-ref/default partcache id #f))) + (if dat dat + (let ((stmt (sqlite3:prepare db "SELECT path,parent_id FROM paths WHERE id=?;")) + (result #f)) + (sqlite3:for-each-row + (lambda (path parent_id)(set! result (list path parent_id))) stmt id) + (hash-table-set! partcache id result) + (sqlite3:finalize! stmt) + result)))) + +(define (filedb:get-children fdb parent-id) + (let* ((db (filedb:fdb-get-db fdb)) + (res '())) + (sqlite3:for-each-row + (lambda (id path parent-id) + (set! res (cons (vector id path parent-id) res))) + db "SELECT id,path,parent_id FROM paths WHERE parent_id=?;" + parent-id) + res)) + +;; retrieve all that have children and those without +;; children that match patt +(define (filedb:get-children-patt fdb parent-id search-patt) + (let* ((db (filedb:fdb-get-db fdb)) + (res '())) + ;; first get the children that have no children + (sqlite3:for-each-row + (lambda (id path parent-id) + (set! res (cons (vector id path parent-id) res))) + db "SELECT id,path,parent_id FROM paths WHERE parent_id=? AND + (id IN (SELECT parent_id FROM paths) OR path LIKE ?);" + parent-id search-patt) + res)) + +(define (filedb:get-path fdb id) + (let* ((db (filedb:fdb-get-db fdb)) + (idcache (filedb:fdb-get-idcache fdb)) + (path (hash-table-ref/default idcache id #f))) + (if path path + (let loop ((curr-id id) + (path "")) + (let ((path-record (filedb:get-path-record fdb curr-id))) + (if (not path-record) #f ;; this id has no path + (let* ((parent-id (list-ref path-record 1)) + (pname (list-ref path-record 0)) + (newpath (string-append "/" pname path))) + (if (= parent-id 0) ;; fields 0=path, 1=parent. root parent=0 + (begin + (hash-table-set! idcache id newpath) + newpath) + (loop parent-id newpath))))))))) + +(define (filedb:search db pattern) + (let ((action (lambda (id)(print (filedb:get-path db id))))) + (filedb:find-all db pattern action))) + Index: items.scm ================================================================== --- items.scm +++ items.scm @@ -69,13 +69,18 @@ (debug:print 6 "item-assoc->item-list x: " x) (if (< (length x) 2) (begin (debug:print 0 "ERROR: malformed items spec " (string-intersperse x " ")) (list (car x)'())) - (let ((name (car x)) - (items (cadr x))) - (list name (string-split items))))) + (let* ((name (car x)) + (items (cadr x)) + (ilist (list name (if (string? items) + (string-split items) + '())))) + (if (null? ilist) + (debug:print 0 "ERROR: No items specified for " name)) + ilist))) itemsdat)))) (let ((debuglevel 5)) (debug:print 5 "item-assoc->item-list: itemsdat => itemlst ") (if (debug:debug-mode 5) (begin @@ -131,12 +136,13 @@ (if (member item valid-values) item #f) item))) (define (items:get-items-from-config tconfig) - (let* (;; db is always at *toppath*/db/megatest.db - (items (hash-table-ref/default tconfig "items" '())) + (let* ((have-items (hash-table-ref/default tconfig "items" #f)) + (have-itable (hash-table-ref/default tconfig "itemstable" #f)) + (items (hash-table-ref/default tconfig "items" '())) (itemstable (hash-table-ref/default tconfig "itemstable" '()))) (debug:print 5 "items: " items " itemstable: " itemstable) (set! items (map (lambda (item) (if (procedure? (cadr item)) (list (car item)((cadr item))) @@ -145,14 +151,16 @@ (set! itemstable (map (lambda (item) (if (procedure? (cadr item)) (list (car item)((cadr item))) item)) itemstable)) + (if (and have-items (null? items)) (debug:print 0 "ERROR: [items] section in testconfig but no entries defined")) + (if (and have-itable (null? itemstable))(debug:print 0 "ERROR: [itemstable] section in testconfig but no entries defined")) (if (or (not (null? items))(not (null? itemstable))) (append (item-assoc->item-list items) (item-table->item-list itemstable)) '(())))) ;; (pp (item-assoc->item-list itemdat)) Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -106,17 +106,27 @@ (let ((var (car varval)) (val (cadr varval))) (debug:print 1 "Adding pre-var/val " var " = " val " to the environment") (setenv var val))))) varpairs))) - (setenv "MT_TEST_RUN_DIR" work-area) - (setenv "MT_TEST_NAME" test-name) - (setenv "MT_ITEM_INFO" (conc itemdat)) - (setenv "MT_RUNNAME" runname) - (setenv "MT_MEGATEST" megatest) - (setenv "MT_TARGET" target) - (setenv "MT_LINKTREE" (configf:lookup *configdat* "setup" "linktree")) + (for-each + (lambda (varval) + (let ((var (car varval)) + (val (cadr varval))) + (if val + (setenv var val) + (begin + (debug:print 0 "ERROR: required variable " var " does not have a valid value. Exiting") + (exit))))) + (list + (list "MT_TEST_RUN_DIR" work-area) + (list "MT_TEST_NAME" test-name) + (list "MT_ITEM_INFO" (conc itemdat)) + (list "MT_RUNNAME" runname) + (list "MT_MEGATEST" megatest) + (list "MT_TARGET" target) + (list "MT_LINKTREE" (configf:lookup *configdat* "setup" "linktree")))) (if mt-bindir-path (setenv "PATH" (conc (getenv "PATH") ":" mt-bindir-path))) ;; (change-directory top-path) (if (not (setup-for-run)) (begin (debug:print 0 "Failed to setup, exiting") @@ -125,17 +135,17 @@ (exit 1))) ;; Can setup as client for server mode now ;; (client:setup) (change-directory *toppath*) - (set-megatest-env-vars run-id) ;; these may be needed by the launching process + (set-megatest-env-vars run-id inkeys: keys inkeyvals: keyvals) ;; these may be needed by the launching process (change-directory work-area) (set-run-config-vars run-id keyvals target) ;; (db:get-target db run-id)) ;; environment overrides are done *before* the remaining critical envars. (alist->env-vars env-ovrd) - (set-megatest-env-vars run-id) + (set-megatest-env-vars run-id inkeys: keys inkeyvals: keyvals) (set-item-env-vars itemdat) (save-environment-as-files "megatest") ;; open-run-close not needed for test-set-meta-info (tests:set-full-meta-info #f test-id run-id 0 work-area) @@ -260,15 +270,15 @@ (next-status (cond ((eq? overall-status 'pass) this-step-status) ((eq? overall-status 'warn) (if (eq? this-step-status 'fail) 'fail 'warn)) (else 'fail))) - (next-state "RUNNING") - ;; (cond - ;; ((null? tal) ;; more to run? - ;; "COMPLETED") - ;; (else "RUNNING")) + (next-state ;; "RUNNING") ;; WHY WAS THIS CHANGED TO NOT USE (null? tal) ?? + (cond + ((null? tal) ;; more to run? + "COMPLETED") + (else "RUNNING"))) ) (debug:print 4 "Exit value received: " (vector-ref exit-info 2) " logpro-used: " logpro-used " this-step-status: " this-step-status " overall-status: " overall-status " next-status: " next-status " rollup-status: " rollup-status) (case next-status @@ -279,12 +289,12 @@ (if (eq? this-step-status 'warn) "Logpro warning found" #f) #f)) ((pass) (tests:test-set-status! test-id next-state "PASS" #f #f)) (else ;; 'fail - (set! rollup-status 1) ;; force fail - (tests:test-set-status! test-id next-state "FAIL" (conc "Failed at step " stepname) #f) + (set! rollup-status 1) ;; force fail, this used to be next-state but that doesn't make sense. should always be "COMPLETED" + (tests:test-set-status! test-id "COMPLETED" "FAIL" (conc "Failed at step " stepname) #f) )))) (if (and (steprun-good? logpro-used (vector-ref exit-info 2)) (not (null? tal))) (loop (car tal) (cdr tal) stepname))) (debug:print 4 "WARNING: a prior step failed, stopping at " ezstep)))))))) @@ -337,19 +347,21 @@ (begin (debug:print 0 "WARNING: Request received to kill job but problem with process, attempting to kill manager process") (tests:test-set-status! test-id "KILLED" "FAIL" (args:get-arg "-m") #f) (sqlite3:finalize! tdb) - (exit 1)))) + (exit 1) ;; IS THIS NECESSARY OR WISE??? + ))) (set! kill-tries (+ 1 kill-tries)) (mutex-unlock! m))) ;; (sqlite3:finalize! db) (if keep-going (begin (thread-sleep! 3) ;; (+ 3 (random 6))) ;; add some jitter to the call home time to spread out the db accesses (if keep-going - (loop (calc-minutes)))))))))) ;; NOTE: Checking twice for keep-going is intentional + (loop (calc-minutes))))))) + (tests:update-central-meta-info test-id (get-cpu-load) (get-df (current-directory))(calc-minutes) #f #f)))) ;; NOTE: Checking twice for keep-going is intentional (th1 (make-thread monitorjob "monitor job")) (th2 (make-thread runit "run job"))) (set! job-thread th2) (thread-start! th1) (thread-start! th2) @@ -357,13 +369,15 @@ (set! keep-going #f) (thread-join! th1) ;; (thread-sleep! 1) ;; (thread-terminate! th1) ;; Not sure if this is a good idea (thread-sleep! 1) ;; give thread th1 a chance to be done TODO: Verify this is needed. At 0.1 I was getting fail to stop, increased to total of 1.1 sec. + ;; (tests:update-central-meta-info test-id cpuload diskfree minutes #f #f) (mutex-lock! m) (let* ((item-path (item-list->path itemdat)) - (testinfo (cdb:get-test-info-by-id *runremote* test-id))) ;; )) ;; run-id test-name item-path))) + ;; only state and status needed - use lazy routine + (testinfo (cdb:remote-run db:get-testinfo-state-status #f test-id))) ;;;(cdb:get-test-info-by-id *runremote* test-id))) ;; )) ;; run-id test-name item-path))) ;; Am I completed? (if (member (db:test-get-state testinfo) '("REMOTEHOSTSTART" "RUNNING")) ;; NOTE: It should *not* be REMOTEHOSTSTART but for reasons I don't yet understand it sometimes gets stuck in that state ;; (not (equal? (db:test-get-state testinfo) "COMPLETED")) (let ((new-state (if kill-job? "KILLED" "COMPLETED") ;; (if (eq? (vector-ref exit-info 2) 0) ;; exited with "good" status ;; "COMPLETED" ;; (db:test-get-state testinfo))) ;; else preseve the state as set within the test @@ -567,11 +581,11 @@ ;; If there is already a symlink delete it and recreate it. (handle-exceptions exn (begin - (debug:print 0 "ERROR: Failed to re-create link " linktarget ((condition-property-accessor 'exn 'message) exn) ", exiting") + (debug:print 0 "ERROR: Failed to re-create link " lnktarget ((condition-property-accessor 'exn 'message) exn) ", exiting") (exit)) (if (symbolic-link? lnktarget) (delete-file lnktarget)) (if (not (file-exists? lnktarget)) (create-symbolic-link test-path lnktarget))))) ;; I suspect this section was deleting test directories under some @@ -629,11 +643,12 @@ (ezsteps (> (length (hash-table-ref/default test-conf "ezsteps" '())) 0)) ;; don't send all the steps, could be big (diskspace (config-lookup test-conf "requirements" "diskspace")) (memory (config-lookup test-conf "requirements" "memory")) (hosts (config-lookup *configdat* "jobtools" "workhosts")) (remote-megatest (config-lookup *configdat* "setup" "executable")) - (run-time-limit (configf:lookup test-conf "requirements" "runtimelim")) + (run-time-limit (or (configf:lookup test-conf "requirements" "runtimelim") + (configf:lookup *configdat* "setup" "runtimelim"))) ;; FIXME SOMEDAY: not good how this is so obtuse, this hack is to ;; allow running from dashboard. Extract the path ;; from the called megatest and convert dashboard ;; or dboard to megatest (local-megatest (let* ((lm (car (argv))) Index: megatest-version.scm ================================================================== --- megatest-version.scm +++ megatest-version.scm @@ -1,7 +1,7 @@ ;; Always use two digit decimal ;; 1.01, 1.02...1.10,1.11 ... 1.99,2.00.. (declare (unit megatest-version)) -(define megatest-version 1.5512) +(define megatest-version 1.5514) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -122,10 +122,11 @@ -list-servers : list the servers -stop-server id : stop server specified by id (see output of -list-servers), use 0 to kill all -repl : start a repl (useful for extending megatest) -load file.scm : load and run file.scm + -mark-incompletes : find and mark incomplete tests Spreadsheet generation -extract-ods fname.ods : extract an open document spreadsheet from the database -pathmod path : insert path, i.e. path/runame/itempath/logfile.html will clear the field if no rundir/testname/itempath/logfile @@ -233,10 +234,11 @@ "-rebuild-db" "-cleanup-db" "-rollup" "-update-meta" "-gen-megatest-area" + "-mark-incompletes" "-logging" "-v" ;; verbose 2, more than normal (normal is 1) "-q" ;; quiet 0, errors/warnings only ) @@ -1090,10 +1092,19 @@ (debug:print 0 "Failed to setup, exiting") (exit 1))) ;; keep this one local (open-run-close db:clean-up #f) (set! *didsomething* #t))) + +(if (args:get-arg "-mark-incompletes") + (begin + (if (not (setup-for-run)) + (begin + (debug:print 0 "Failed to setup, exiting") + (exit 1))) + (open-run-close db:find-and-mark-incomplete #f) + (set! *didsomething* #t))) ;;====================================================================== ;; Wait on a run to complete ;;====================================================================== @@ -1116,11 +1127,11 @@ (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) ;; now can find our db ;; keep this one local - (open-run-close runs:update-all-test_meta db) + (open-run-close runs:update-all-test_meta #f) (set! *didsomething* #t))) ;;====================================================================== ;; Start a repl ;;====================================================================== Index: mt.scm ================================================================== --- mt.scm +++ mt.scm @@ -82,13 +82,48 @@ limit)) full-list)))) (define (mt:get-prereqs-not-met run-id waitons ref-item-path #!key (mode 'normal)) (db:get-prereqs-not-met run-id waitons ref-item-path mode: mode)) + +(define (mt:lazy-get-prereqs-not-met run-id waitons ref-item-path #!key (mode 'normal)) + (let* ((key (list run-id waitons ref-item-path mode)) + (res (hash-table-ref/default *pre-reqs-met-cache* key #f)) + (useres (let ((last-time (if (vector? res) (vector-ref res 0) #f))) + (if last-time + (< (current-seconds)(+ last-time 5)) + #f)))) + (if useres + (let ((result (vector-ref res 1))) + (debug:print 4 "Using lazy value res: " result) + result) + (let ((newres (db:get-prereqs-not-met run-id waitons ref-item-path mode: mode))) + (hash-table-set! *pre-reqs-met-cache* key (vector (current-seconds) newres)) + newres)))) (define (mt:get-run-stats) (cdb:remote-run db:get-run-stats #f)) + +(define (mt:discard-blocked-tests run-id failed-test tests test-records) + (if (null? tests) + tests + (begin + (debug:print-info 1 "Discarding tests from " tests " that are waiting on " failed-test) + (let loop ((testn (car tests)) + (remt (cdr tests)) + (res '())) + (let ((waitons (vector-ref (hash-table-ref/default test-records testn (vector #f #f '())) 2))) + ;; (print "mt:discard-blocked-tests run-id: " run-id " failed-test: " failed-test " testn: " testn " with waitons: " waitons) + (if (null? remt) + (let ((new-res (reverse res))) + ;; (print " new-res: " new-res) + new-res) + (loop (car remt) + (cdr remt) + (if (member failed-test waitons) + res + (cons testn res))))))))) ;;====================================================================== ;; T R I G G E R S ;;====================================================================== Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -114,11 +114,14 @@ ;; from the cached data set the vars (hash-table-for-each vals (lambda (key val) (debug:print 2 "setenv " key " " val) - (setenv key val))) + (if (and (string? key) + (string? val)) + (setenv key val) + (debug:print 0 "ERROR: Malformed environment variable definition: var=" var ", val=" val)))) (if (not (get-environment-variable "MT_TARGET"))(setenv "MT_TARGET" target)) (alist->env-vars (hash-table-ref/default *configdat* "env-override" '())) ;; Lets use this as an opportunity to put MT_RUNNAME in the environment (setenv "MT_RUNNAME" (if inrunname inrunname (cdb:remote-run db:get-run-name-from-id #f run-id))) (setenv "MT_RUN_AREA_HOME" *toppath*))) @@ -205,10 +208,15 @@ (required-tests '()) (test-records (make-hash-table)) (all-tests-registry (tests:get-all)) ;; (tests:get-valid-tests (make-hash-table) test-search-path)) ;; all valid tests to check waiton names (all-test-names (hash-table-keys all-tests-registry)) (test-names (tests:filter-test-names all-test-names test-patts))) + + ;; Update the synchronous setting in the db based on the default or what is set by the user + ;; This is done once here on a call to run tests rather than on every call to open-db + (cdb:remote-run db:set-sync #f) + (set-megatest-env-vars run-id inkeys: keys) ;; these may be needed by the launching process (if (file-exists? runconfigf) (setup-env-defaults runconfigf run-id *already-seen-runconfig-info* keyvals "pre-launch-env-vars") (debug:print 0 "WARNING: You do not have a run config file: " runconfigf)) @@ -226,10 +234,13 @@ ;; get stuck due to becoming inaccessible from a failed test. I.e. if test B depends ;; 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. (cdb:delete-tests-in-state *runremote* run-id "NOT_STARTED") (cdb:remote-run db:set-tests-state-status #f run-id test-names #f "FAIL" "NOT_STARTED" "FAIL"))) + + ;; Ensure all tests are registered in the test_meta table + (runs:update-all-test_meta #f) ;; now add non-directly referenced dependencies (i.e. waiton) ;;====================================================================== ;; refactoring this block into tests:get-full-data ;; @@ -367,13 +378,13 @@ '() reg))) (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) +(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) (let* ((loop-list (list hed tal reg reruns)) - (prereqs-not-met (mt:get-prereqs-not-met run-id waitons item-path mode: testmode)) + (prereqs-not-met (mt:lazy-get-prereqs-not-met run-id waitons item-path mode: testmode)) (fails (runs:calc-fails prereqs-not-met)) (non-completed (runs:calc-not-completed prereqs-not-met))) (debug:print-info 4 "START OF INNER COND #2 " "\n can-run-more: " can-run-more "\n testname: " hed @@ -388,11 +399,11 @@ "\n can-run-more: " can-run-more) (cond ;; all prereqs met, fire off the test ;; or, if it is a 'toplevel test and all prereqs not met are COMPLETED then launch - + ((member (hash-table-ref/default test-registry (runs:make-full-test-name hed item-path) 'n/a) '(DONOTRUN removed)) ;; *common:cant-run-states-sym*) ;; '(COMPLETED KILLED WAIVED UNKNOWN INCOMPLETE)) ;; try to catch repeat processing of COMPLETED tests here (debug:print-info 1 "Test " hed " set to \"" (hash-table-ref test-registry (runs:make-full-test-name hed item-path)) "\". Removing it from the queue") (if (or (not (null? tal)) (not (null? reg))) @@ -425,11 +436,11 @@ (if (list? items-list) (begin (tests:testqueue-set-items! test-record items-list) (list hed tal reg reruns)) (begin - (debug:print 0 "ERROR: The proc from reading the setup did not yield a list - please report this") + (debug:print 0 "ERROR: The proc from reading the items table did not yield a list - please report this") (exit 1)))))) ((and (null? fails) (not (null? non-completed))) (let* ((allinqueue (map (lambda (x)(if (string? x) x (db:test-get-testname x))) @@ -450,18 +461,21 @@ (if (eq? (hash-table-ref/default test-registry prereq 'justfine) 'CANNOTRUN) (set! give-up #t))) prereqstrs) (if (and give-up (not (and (null? tal)(null? reg)))) - (begin - (debug:print 1 "WARNING: test " hed " has no discarded prerequisites, removing it from the queue") - (list (runs:queue-next-hed tal reg reglen regfull) - (runs:queue-next-tal tal reg reglen regfull) - (runs:queue-next-reg tal reg reglen regfull) - reruns)) - (list (car newtal)(append (cdr newtal) reg) '() reruns)))) - + (let ((trimmed-tal (mt:discard-blocked-tests run-id hed tal test-records)) + (trimmed-reg (mt:discard-blocked-tests run-id hed reg test-records))) + (debug:print 1 "WARNING: test " hed " has discarded prerequisites, removing it from the queue") + (if (and (null? trimmed-tal) + (null? trimmed-reg)) + #f + (list (runs:queue-next-hed trimmed-tal trimmed-reg reglen regfull) + (runs:queue-next-tal trimmed-tal trimmed-reg reglen regfull) + (runs:queue-next-reg trimmed-tal trimmed-reg reglen regfull) + reruns))) + (list (car newtal)(append (cdr newtal) reg) '() reruns)))) ;; (debug:print-info 1 "allinqueue: " allinqueue) ;; (debug:print-info 1 "prereqstrs: " prereqstrs) ;; (debug:print-info 1 "notinqueue: " notinqueue) ;; (debug:print-info 1 "tal: " tal) @@ -571,11 +585,11 @@ (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 (mt:get-prereqs-not-met run-id waitons item-path mode: testmode)) + (prereqs-not-met (mt:lazy-get-prereqs-not-met run-id waitons item-path mode: testmode)) (fails (runs:calc-fails prereqs-not-met)) (non-completed (runs:calc-not-completed prereqs-not-met)) (loop-list (list hed tal reg reruns))) (debug:print-info 4 "have-resources: " have-resources " prereqs-not-met: (" (string-intersperse @@ -668,10 +682,14 @@ ;; ((and have-resources (or (null? prereqs-not-met) (and (eq? testmode 'toplevel) (null? non-completed)))) + ;; (hash-table-delete! *max-tries-hash* (runs:make-full-test-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)) (run:test run-id run-info keyvals runname test-record flags #f test-registry all-tests-registry) (hash-table-set! test-registry (runs:make-full-test-name test-name item-path) 'running) (runs:shrink-can-run-more-tests-count) ;; DELAY TWEAKER (still needed?) ;; (thread-sleep! *global-delta*) (if (or (not (null? tal))(not (null? reg))) @@ -685,13 +703,15 @@ ;; (else (debug:print 4 "FAILS: " fails) ;; If one or more of the prereqs-not-met are FAIL then we can issue ;; a message and drop hed from the items to be processed. - + ;; (runs:mixed-list-testname-and-testrec->list-of-strings prereqs-not-met) (if (not (null? prereqs-not-met)) - (debug:print-info 1 "waiting on tests; " (string-intersperse prereqs-not-met ", "))) + (debug:print-info 1 "waiting on tests; " (string-intersperse + (runs:mixed-list-testname-and-testrec->list-of-strings + prereqs-not-met) ", "))) (if (null? fails) (begin ;; couldn't run, take a breather (debug:print-info 0 "Waiting for more work to do...") @@ -714,16 +734,26 @@ (debug:print 0 "WARNING: Test not processed correctly. Could be a race condition in your test implementation? Dropping test " hed) ;; " as it has prerequistes that are FAIL. (NOTE: hed is not a vector)") (runs:shrink-can-run-more-tests-count) ;; DELAY TWEAKER (still needed?) ;; (list hed tal reg reruns) (list (car newtal)(cdr newtal) reg reruns) )))))))) + +;; every time though the loop increment the test/itempatt val. +;; when the min is > max-allowed and none running then force exit +;; +(define *max-tries-hash* (make-hash-table)) ;; test-records is a hash table testname:item_path => vector < testname testconfig waitons priority items-info ... > (define (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests reglen-in all-tests-registry) ;; At this point the list of parent tests is expanded ;; NB// Should expand items here and then insert into the run queue. (debug:print 5 "test-records: " test-records ", flags: " (hash-table->alist flags)) + + ;; Do mark-and-find clean up of db before starting runing of quue + ;; + ;; (cdb:remote-run db:find-and-mark-incomplete #f) + (let ((run-info (cdb:remote-run db:get-run-info #f run-id)) (tests-info (mt:get-tests-for-run run-id #f '() '())) ;; qryvals: "id,testname,item_path")) (sorted-test-names (tests:sort-by-priority-and-waiton test-records)) (test-registry (make-hash-table)) (registry-mutex (make-mutex)) @@ -731,11 +761,12 @@ (max-retries (config-lookup *configdat* "setup" "maxretries")) (max-concurrent-jobs (let ((mcj (config-lookup *configdat* "setup" "max_concurrent_jobs"))) (if (and mcj (string->number mcj)) (string->number mcj) 1))) ;; length of the register queue ahead - (reglen (if (number? reglen-in) reglen-in 1))) + (reglen (if (number? reglen-in) reglen-in 1)) + (last-time-incomplete (current-seconds))) ;; Initialize the test-registery hash with tests that already have a record ;; convert state to symbol and use that as the hash value (for-each (lambda (trec) (let ((id (db:test-get-id trec)) @@ -750,10 +781,16 @@ (let loop ((hed (car sorted-test-names)) (tal (cdr sorted-test-names)) (reg '()) ;; registered, put these at the head of tal (reruns '())) (if (not (null? reruns))(debug:print-info 4 "reruns=" reruns)) + + ;; Here we mark any old defunct tests as incomplete. Do this every fifteen minutes + ;; (if (> (current-seconds)(+ last-time-incomplete 900)) + ;; (begin + ;; (set! last-time-incomplete (current-seconds)) + ;; (cdb:remote-run db:find-and-mark-incomplete #f))) ;; (print "Top of loop, hed=" hed ", tal=" tal " ,reruns=" reruns) (let* ((test-record (hash-table-ref test-records hed)) (test-name (tests:testqueue-get-testname test-record)) (tconfig (tests:testqueue-get-testconfig test-record)) @@ -766,10 +803,13 @@ (items (tests:testqueue-get-items test-record)) (item-path (item-list->path itemdat)) (tfullname (runs:make-full-test-name test-name item-path)) (newtal (append tal (list hed))) (regfull (>= (length reg) reglen))) + + (hash-table-set! *max-tries-hash* tfullname (+ (hash-table-ref/default *max-tries-hash* tfullname 0) 1)) + ;; (debug:print 0 "max-tries-hash: " (hash-table->alist *max-tries-hash*)) ;; 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 (runs:make-full-test-name test-name "") #f)) (begin @@ -811,10 +851,26 @@ (begin (debug:print 0 "ERROR: test " test-name " has listed itself as a waiton, please correct this!") (set! waiton (filter (lambda (x)(not (equal? x hed))) waitons)))) (cond + + ;; We want to catch tests that have waitons that are NOT in the queue and discard them IFF + ;; they have been through the wringer 10 or more times + ((and (list? waitons) + (not (null? waitons)) + (> (hash-table-ref/default *max-tries-hash* tfullname 0) 10) + (not (null? (filter + number? + (map (lambda (waiton) + (if (and (not (member waiton tal)) ;; this waiton is not in the list to be tried to run + (not (member waiton reruns))) + 1 + #f)) + waitons))))) ;; could do this more elegantly with a marker.... + (debug:print 0 "WARNING: Marking test " tfullname " as not runnable. It is waiting on tests that cannot be run. Giving up now.") + (hash-table-set! test-registry tfullname 'removed)) ;; items is #f then the test is ok to be handed off to launch (but not before) ;; ((not items) (debug:print-info 4 "OUTER COND: (not items)") @@ -874,11 +930,11 @@ ;; EXPAND ITEMS ((or (procedure? items)(eq? items 'have-procedure)) (let ((can-run-more (runs:can-run-more-tests jobgroup max-concurrent-jobs))) (if (and (list? can-run-more) (car can-run-more)) - (let ((loop-list (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))) + (let ((loop-list (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))) (if loop-list (apply loop loop-list))) ;; if can't run more just loop with next possible test (loop (car newtal)(cdr newtal) reg reruns)))) @@ -965,19 +1021,24 @@ (set-megatest-env-vars run-id inrunname: runname) ;; these may be needed by the launching process (change-directory *toppath*) ;; Here is where the test_meta table is best updated ;; Yes, another use of a global for caching. Need a better way? + ;; + ;; There is now a single call to runs:update-all-test_meta and this + ;; per-test call is not needed. Given the delicacy of the move to + ;; v1.55 this code is being left in place for the time being. + ;; (if (not (hash-table-ref/default *test-meta-updated* test-name #f)) (begin (hash-table-set! *test-meta-updated* test-name #t) (runs:update-test_meta test-name test-conf))) ;; itemdat => ((ripeness "overripe") (temperature "cool") (season "summer")) (let* ((new-test-path (string-intersperse (cons test-path (map cadr itemdat)) "/")) - (test-id (cdb:remote-run db:get-test-id #f run-id test-name item-path)) - (testdat (cdb:get-test-info-by-id *runremote* test-id))) + (test-id (cdb:remote-run db:get-test-id-cached #f run-id test-name item-path)) + (testdat (if test-id (cdb:get-test-info-by-id *runremote* test-id) #f))) (if (not testdat) (let loop () ;; ensure that the path exists before registering the test ;; NOPE: Cannot! Don't know yet which disk area will be assigned.... ;; (system (conc "mkdir -p " new-test-path)) @@ -984,16 +1045,16 @@ ;; ;; (open-run-close tests:register-test db run-id test-name item-path) ;; ;; NB// for the above line. I want the test to be registered long before this routine gets called! ;; - (set! test-id (cdb:remote-run db:get-test-id #f run-id test-name item-path)) + (if (not test-id)(set! test-id (cdb:remote-run db:get-test-id-cached #f 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) (cdb:tests-register-test *runremote* run-id test-name item-path) - (set! test-id (cdb:remote-run db:get-test-id #f run-id test-name item-path)))) + (set! test-id (cdb:remote-run db:get-test-id-cached #f 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 (cdb:get-test-info-by-id *runremote* test-id)) (if (not testdat) (begin (debug:print-info 0 "WARNING: server is overloaded, trying again in one second") @@ -1406,17 +1467,17 @@ (cdb:remote-run db:testmeta-update-field #f test-name fld val))))) '(("author" 2)("owner" 3)("description" 4)("reviewed" 5)("tags" 9))))) ;; Update test_meta for all tests (define (runs:update-all-test_meta db) - (let ((test-names (tests:get-valid-tests))) + (let ((test-names (tests:get-all))) ;; (tests:get-valid-tests))) (for-each (lambda (test-name) (let* ((test-conf (mt:lazy-read-test-config test-name))) ;; use the cdb:remote-run instead of passing in db (if test-conf (runs:update-test_meta test-name test-conf)))) - test-names))) + (hash-table-keys test-names)))) ;; This could probably be refactored into one complex query ... (define (runs:rollup-run keys runname user keyvals) (debug:print 4 "runs:rollup-run, keys: " keys " :runname " runname " user: " user) (let* ((db #f) ADDED sdb.scm Index: sdb.scm ================================================================== --- /dev/null +++ sdb.scm @@ -0,0 +1,102 @@ +;;====================================================================== +;; 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. +;;====================================================================== + +;;====================================================================== +;; Simple persistant strings lookup table. Keep out of the main db +;; so writes/reads don't slow down central access. +;;====================================================================== + +(require-extension (srfi 18) extras) +(use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64) +(import (prefix sqlite3 sqlite3:)) +(import (prefix base64 base64:)) + +(declare (unit sdb)) + +;; +(define (sdb:open) ;; (conc *toppath* "/megatest.db") (car *configinfo*))) + (if (not *toppath*) + (if (not (setup-for-run)) + (begin + (debug:print 0 "ERROR: Attempted to open db when not in megatest area. Exiting.") + (exit)))) + (let* ((dbpath (conc *toppath* "/db/sdb.db")) ;; fname) + (dbexists (let ((fe (file-exists? dbpath))) + (if fe + fe + (begin + (create-directory (conc *toppath* "/db") #t) + #f)))) + (sdb (sqlite3:open-database dbpath)) + (handler (make-busy-timeout (if (args:get-arg "-override-timeout") + (string->number (args:get-arg "-override-timeout")) + 136000)))) + (sqlite3:set-busy-handler! sdb handler) + (if (not dbexists) + (sdb:initialize sdb)) + (sqlite3:execute sdb "PRAGMA synchronous = 1;") + sdb)) + +(define (sdb:initialize sdb) + (sqlite3:execute sdb "CREATE TABLE IF NOT EXISTS strs + (id INTEGER PRIMARY KEY, + str TEXT, + CONSTRAINT str UNIQUE (str));") + (sqlite3:execute sdb "CREATE INDEX strindx ON strs (str);")) + +;; (define sumup (let ((a 0))(lambda (x)(set! a (+ x a)) a))) + +(define (sdb:register-string sdb str) + (sqlite3:execute sdb "INSERT OR IGNORE INTO strs (str) VALUES (?);" str)) + +(define (sdb:string->id sdb str-cache str) + (let ((id (hash-table-ref/default str-cache str #f))) + (if (not id) + (sqlite3:for-each-row + (lambda (sid) + (set! id sid) + (hash-table-set! str-cache str id)) + sdb + "SELECT id FROM strs WHERE str=?;" str)) + id)) + +(define (sdb:id->string sdb id-cache id) + (let ((str (hash-table-ref/default id-cache id #f))) + (if (not str) + (sqlite3:for-each-row + (lambda (istr) + (set! str istr) + (hash-table-set! id-cache id str)) + sdb + "SELECT str FROM strs WHERE id=?;" id)) + str)) + +(define sdb:qry + (let ((sdb #f) + (scache (make-hash-table)) + (icache (make-hash-table))) + (lambda (cmd var) + (if (not sdb)(set! sdb (sdb:open))) + (case cmd + ((init) (if (not sdb)(set! sdb (sdb:open)))) + ((finalize!) (if sdb (sqlite3:finalize! sdb))) + ((getid) (let ((id (sdb:string->id sdb scache var))) + (if id + id + (begin + (sdb:register-string sdb var) + (sdb:string->id sdb scache var))))) + ((getstr) (if (or (number? var) + (string->number var)) + (sdb:id->string sdb icache var) + var)) + (else #f))))) + Index: tests.scm ================================================================== --- tests.scm +++ tests.scm @@ -555,12 +555,12 @@ (test-name (tests:testqueue-get-testname test-record)) (itemdat (tests:testqueue-get-itemdat test-record)) (item-path (tests:testqueue-get-item_path test-record)) (waitons (tests:testqueue-get-waitons test-record)) (keep-test #t) - (test-id (cdb:remote-run db:get-test-id #f run-id test-name item-path)) - (tdat (cdb:get-test-info-by-id *runremote* test-id))) + (test-id (cdb:remote-run db:get-test-id-cached #f run-id test-name item-path)) + (tdat (cdb:remote-run db:get-testinfo-state-status #f test-id))) ;; (cdb:get-test-info-by-id *runremote* test-id))) (if tdat (begin ;; Look at the test state and status (if (or (and (member (db:test-get-status tdat) '("PASS" "WARN" "WAIVED" "CHECK" "SKIP")) @@ -572,12 +572,12 @@ ;; examine waitons for any fails. If it is FAIL or INCOMPLETE then eliminate this test ;; from the runnable list (if keep-test (for-each (lambda (waiton) ;; for now we are waiting only on the parent test - (let* ((parent-test-id (cdb:remote-run db:get-test-id #f run-id waiton "")) - (wtdat (cdb:get-test-info-by-id *runremote* test-id))) + (let* ((parent-test-id (cdb:remote-run db:get-test-id-cached #f run-id waiton "")) + (wtdat (cdb:remote-run db:get-testinfo-state-status #f 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) '("KILLED")) (member (db:test-get-state wtdat) '("INCOMPETE"))) ;; (if (or (member (db:test-get-status wtdat) @@ -680,11 +680,11 @@ ;;====================================================================== ;; teststep-set-status! used to be here (define (test-get-kill-request test-id) ;; run-id test-name itemdat) - (let* ((testdat (cdb:get-test-info-by-id *runremote* test-id))) ;; run-id test-name item-path))) + (let* ((testdat (cdb:remote-run db:get-testinfo-state-status #f test-id))) ;; (cdb:get-test-info-by-id *runremote* test-id))) ;; run-id test-name item-path))) (and testdat (equal? (test:get-state testdat) "KILLREQ")))) (define (test:tdb-get-rundat-count tdb) (if tdb @@ -720,18 +720,36 @@ ;; DOES cdb:remote-run under the hood! (let* ((cpuload (get-cpu-load)) (diskfree (get-df (current-directory)))) (tests:update-testdat-meta-info db test-id work-area cpuload diskfree minutes) ;; Update central with uname and hostname = #f - (tests:update-central-meta-info test-id cpuload diskfree minutes #f #f))) + ;; Is this one of the performance problems? This info should come from testdat-meta anyway + ;; (tests:update-central-meta-info test-id cpuload diskfree minutes #f #f) + )) (define (tests:update-testdat-meta-info db test-id work-area cpuload diskfree minutes) (let ((tdb (db:open-test-db-by-test-id db test-id work-area: work-area))) - (sqlite3:execute tdb "INSERT INTO test_rundat (update_time,cpuload,diskfree,run_duration) VALUES (strftime('%s','now'),?,?,?);" - cpuload diskfree minutes) - (sqlite3:finalize! tdb))) - + (if (sqlite3:database? tdb) + (begin + (sqlite3:execute tdb "INSERT INTO test_rundat (update_time,cpuload,diskfree,run_duration) VALUES (strftime('%s','now'),?,?,?);" + cpuload diskfree minutes) + (sqlite3:finalize! tdb)) + (debug:print 2 "Can't update testdat.db for test " test-id " read-only or non-existant")))) + +(define (tests:testdat-get-testinfo db test-id work-area) + (let ((tdb (db:open-test-db-by-test-id db test-id work-area: work-area)) + (res '())) + (if (sqlite3:database? tdb) + (begin + (sqlite3:for-each-row + (lambda (update-time cpuload diskfree run-duration) + (set! res (cons (vector update-time cpuload diskfree run-duration) res))) + tdb + "SELECT update_time,cpuload,diskfree,run_duration FROM test_rundat ORDER BY update_time ASC;") + (sqlite3:finalize! tdb))) + res)) + ;;====================================================================== ;; A R C H I V I N G ;;====================================================================== (define (test:archive db test-id) Index: tests/Makefile ================================================================== --- tests/Makefile +++ tests/Makefile @@ -1,5 +1,6 @@ +# # run some tests BINPATH=$(shell readlink -m $(PWD)/../bin) MEGATEST=$(BINPATH)/megatest PATH := $(BINPATH):$(PATH) @@ -49,12 +50,19 @@ cd fullrun;megatest -runtests runfirst/%,%/ai -target ubuntu/nfs/none :runname $(RUNNAME)_02 -debug $(DEBUG) cd fullrun;megatest -runtests %/,%/winter -target ubuntu/nfs/none :runname $(RUNNAME)_03 -debug $(DEBUG) sleep 40;cd fullrun;megatest -target ubuntu/nfs/none :runname $(RUNNAME) -set-state-status COMPLETED,FORCED :state COMPLETED :status PASS -testpatt ez_p%s,runfirst/ -debug $(DEBUG) $(LOGGING) -test3 : fullprep - cd fullrun;$(MEGATEST) -runtests runfirst -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_b -debug 10 +test3 : fullprep test3a test3b + +test3a : + @echo Run runfirst and any waitons. + cd fullrun;$(MEGATEST) -runtests runfirst -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_b + +test3b : + @echo Run all_toplevel and all waitons + cd fullrun;$(MEGATEST) -runtests all_toplevel -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_c test4 : cleanprep @echo "WARNING: No longer running fullprep, test converage may be lessened" cd fullrun;time $(MEGATEST) -debug $(DEBUG) -runtests % -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_b -m "This is a comment specific to a run" -v $(LOGGING) @@ -99,11 +107,11 @@ cd fullrun;$(MEGATEST) -runtests runfirst/fall 1 -target ubuntu/nfs/none :runname $(RUNNAME)_singleitem cd fullrun;$(MEGATEST) -runtests test_mt_vars/2 -target ubuntu/nfs/none :runname $(RUNNAME)_singleitem_waiton # Some simple checks for bootstrapping and run loop logic -test9 : minsetup test9a test9b test9c test9d +test9 : minsetup test9a test9b test9c test9d test9e test9a : @echo Run super-simple mintest e, no waitons. cd mintest;megatest -runtests e -target $(VER) :runname `date +%H.%M.%S` -debug $(DEBUG) @@ -117,10 +125,14 @@ test9d : @echo Run an itemized test with no items cd mintest;megatest -runtests g -target $(VER) :runname `date +%H.%M.%S` -debug $(DEBUG) +test9e : + @echo Run mintest a1 with full waiton chain with d1fail: a1 -> b1 -> c1 -> d1fail -> e1 + cd mintest;megatest -runtests a1 -target $(VER) :runname `date +%H.%M.%S` -debug $(DEBUG) + test10 : @echo Run a bunch of different targets simultaneously (cd fullrun;$(MEGATEST) -server - ;sleep 2)& for targ in mint/btrfs/mintdir sunos/sshfs/loc; do \ (cd fullrun;$(MEGATEST) -runtests priority_10_waiton_1 -target $$targ :runname $(RUNNAME) &); done Index: tests/fdktestqa/testqa/megatest.config ================================================================== --- tests/fdktestqa/testqa/megatest.config +++ tests/fdktestqa/testqa/megatest.config @@ -1,9 +1,9 @@ [setup] testcopycmd cp --remove-destination -rlv TEST_SRC_PATH/. TEST_TARG_PATH/. >> TEST_TARG_PATH/mt_launch.log 2>> TEST_TARG_PATH/mt_launch.log runqueue 20 -transport http +# transport http launchwait no [include ../fdk.config] [server] Index: tests/fullrun/config/mt_include_1.config ================================================================== --- tests/fullrun/config/mt_include_1.config +++ tests/fullrun/config/mt_include_1.config @@ -8,11 +8,14 @@ useshell yes # ## launcher launches jobs, the job is managed on the target host ## by megatest, comment out launcher to run local # workhosts localhost hermes # launcher exec nbfake + launcher nbfake +# launcher echo + # launcher nbfind # launcher nodanggood ## use "xterm -e csi -- " as a launcher to examine the launch environment. ## exit with (exit) Index: tests/fullrun/megatest.config ================================================================== --- tests/fullrun/megatest.config +++ tests/fullrun/megatest.config @@ -21,18 +21,27 @@ # 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 # Use http instead of direct filesystem access -# transport http -transport fs +transport http +# transport fs # If set to "default" the old code is used. Otherwise defaults to 200 or uses # numeric value given. # runqueue 20 +# Default runtimelim 1d 1h 1m 10s +# +runtimelim 20m + +# Deadtime - when to consider tests dead (i.e. haven't heard from them in too long) +# Number in seconds, set to 20 seconds here to trigger a little trouble. Default is +# 1800 +# +deadtime 600 # It is possible (but not recommended) to override the rsync command used # to populate the test directories. For test development the following # example can be useful # ADDED tests/fullrun/run-each-proc.sh Index: tests/fullrun/run-each-proc.sh ================================================================== --- /dev/null +++ tests/fullrun/run-each-proc.sh @@ -0,0 +1,15 @@ +#!/bin/bash + +for x in `cat all-db-procs.txt`;do + cat > ~/.megatestrc <' '-_g'` + megatest -runtests sqlitespeed,test2,ez% -target ubuntu/nfs/none :runname $fname > $fname.log +done + + ADDED tests/fullrun/tests/all_toplevel/calcresults.logpro Index: tests/fullrun/tests/all_toplevel/calcresults.logpro ================================================================== --- /dev/null +++ tests/fullrun/tests/all_toplevel/calcresults.logpro @@ -0,0 +1,133 @@ +;; (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 "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 "testxz has 1 NOT_STARTED test" #/Test: testxz\s+State: NOT_STARTED/) +(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" "n/a" 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/fullrun/tests/no_items/testconfig Index: tests/fullrun/tests/no_items/testconfig ================================================================== --- /dev/null +++ tests/fullrun/tests/no_items/testconfig @@ -0,0 +1,15 @@ +[ezsteps] +listfiles ls + +[items] +FOO + +[test_meta] +author matt +owner bob +description This test runs a single ezstep which is expected to pass \ +but there is an items definition with no items. This should evoke an \ +error. + +tags first,single +reviewed 09/10/2011, by Matt ADDED tests/fullrun/tests/wait_no_items1/testconfig Index: tests/fullrun/tests/wait_no_items1/testconfig ================================================================== --- /dev/null +++ tests/fullrun/tests/wait_no_items1/testconfig @@ -0,0 +1,17 @@ +[ezsteps] +listfiles ls + +[requirements] +waiton no_items + +[items] + +[test_meta] +author matt +owner bob +description This test runs a single ezstep which is expected to pass \ +but there is an items definition with no items. This should evoke an \ +error. + +tags first,single +reviewed 09/10/2011, by Matt ADDED tests/fullrun/tests/wait_no_items2/testconfig Index: tests/fullrun/tests/wait_no_items2/testconfig ================================================================== --- /dev/null +++ tests/fullrun/tests/wait_no_items2/testconfig @@ -0,0 +1,17 @@ +[ezsteps] +listfiles ls + +[requirements] +waiton wait_no_items1 + +[items] + +[test_meta] +author matt +owner bob +description This test runs a single ezstep which is expected to pass \ +but there is an items definition with no items. This should evoke an \ +error. + +tags first,single +reviewed 09/10/2011, by Matt ADDED tests/fullrun/tests/wait_no_items3/testconfig Index: tests/fullrun/tests/wait_no_items3/testconfig ================================================================== --- /dev/null +++ tests/fullrun/tests/wait_no_items3/testconfig @@ -0,0 +1,17 @@ +[ezsteps] +listfiles ls + +[requirements] +waiton wait_no_items2 + +[items] + +[test_meta] +author matt +owner bob +description This test runs a single ezstep which is expected to pass \ +but there is an items definition with no items. This should evoke an \ +error. + +tags first,single +reviewed 09/10/2011, by Matt ADDED tests/fullrun/tests/wait_no_items4/testconfig Index: tests/fullrun/tests/wait_no_items4/testconfig ================================================================== --- /dev/null +++ tests/fullrun/tests/wait_no_items4/testconfig @@ -0,0 +1,17 @@ +[ezsteps] +listfiles ls + +[requirements] +waiton wait_no_items3 + +[items] + +[test_meta] +author matt +owner bob +description This test runs a single ezstep which is expected to pass \ +but there is an items definition with no items. This should evoke an \ +error. + +tags first,single +reviewed 09/10/2011, by Matt ADDED tests/mintest/tests/a1/testconfig Index: tests/mintest/tests/a1/testconfig ================================================================== --- /dev/null +++ tests/mintest/tests/a1/testconfig @@ -0,0 +1,6 @@ +# Add steps here. Format is "stepname script" +[ezsteps] +step1 echo SUCCESS + +[requirements] +waiton b1 ADDED tests/mintest/tests/b1/testconfig Index: tests/mintest/tests/b1/testconfig ================================================================== --- /dev/null +++ tests/mintest/tests/b1/testconfig @@ -0,0 +1,6 @@ +# Add steps here. Format is "stepname script" +[ezsteps] +step1 echo SUCCESS + +[requirements] +waiton c1 ADDED tests/mintest/tests/c1/testconfig Index: tests/mintest/tests/c1/testconfig ================================================================== --- /dev/null +++ tests/mintest/tests/c1/testconfig @@ -0,0 +1,6 @@ +# Add steps here. Format is "stepname script" +[ezsteps] +step1 echo SUCCESS + +[requirements] +waiton d1fail ADDED tests/mintest/tests/d1fail/testconfig Index: tests/mintest/tests/d1fail/testconfig ================================================================== --- /dev/null +++ tests/mintest/tests/d1fail/testconfig @@ -0,0 +1,7 @@ +# Add steps here. Format is "stepname script" +[ezsteps] +step1 echo SUCCESS +step2 exit 123 + +[requirements] +waiton e1 ADDED tests/mintest/tests/e1/testconfig Index: tests/mintest/tests/e1/testconfig ================================================================== --- /dev/null +++ tests/mintest/tests/e1/testconfig @@ -0,0 +1,4 @@ +# Add steps here. Format is "stepname script" +[ezsteps] +step1 echo SUCCESS + ADDED tests/speedtest/megatest.config Index: tests/speedtest/megatest.config ================================================================== --- /dev/null +++ tests/speedtest/megatest.config @@ -0,0 +1,48 @@ +[fields] +sysname TEXT +fsname TEXT +datapath TEXT + +[setup] +transport #{scheme (if (getenv "USEHTTP") "http" "fs")} + +max_concurrent_jobs 50 + +# It is possible (but not recommended) to override the rsync command used +# to populate the test directories. For test development the following +# example can be useful +# +testcopycmd cp --remove-destination -rsv TEST_SRC_PATH/. TEST_TARG_PATH/. >> TEST_TARG_PATH/mt_launch.log 2>> TEST_TARG_PATH/mt_launch.log + +# FULL or 2, NORMAL or 1, OFF or 0 +synchronous OFF + +# override the logview command +# +logviewer (%MTCMD%) 2> /dev/null > /dev/null + +# override the html viewer launch command +# +# htmlviewercmd firefox -new-window +htmlviewercmd konqueror + +[jobtools] +launcher nbfake + +[server] + +# If the server can't be started on this port it will try the next port until +# it succeeds +port 8080 + +# This server will keep running this number of hours after last access. +# Three minutes is 0.05 hours +timeout 0.025 + +## disks are: +## name host:/path/to/area +## -or- +## name /path/to/area +[disks] +disk0 #{getenv MT_RUN_AREA_HOME}/tmp_run + ADDED tests/speedtest/runconfigs.config Index: tests/speedtest/runconfigs.config ================================================================== --- /dev/null +++ tests/speedtest/runconfigs.config @@ -0,0 +1,3 @@ +[default] +SOMEVAR This should show up in SOMEVAR3 + ADDED tests/speedtest/tests/speedtest/main.sh Index: tests/speedtest/tests/speedtest/main.sh ================================================================== --- /dev/null +++ tests/speedtest/tests/speedtest/main.sh @@ -0,0 +1,10 @@ +#!/bin/bash + +# a bunch of steps in 2 second increments +for i in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17;do + $MT_MEGATEST -step step$i :state start :status running -setlog results$i.html + sleep $TEST_DELAY + $MT_MEGATEST -step step$i :state end :status 0 +done + +exit 0 ADDED tests/speedtest/tests/speedtest/testconfig Index: tests/speedtest/tests/speedtest/testconfig ================================================================== --- /dev/null +++ tests/speedtest/tests/speedtest/testconfig @@ -0,0 +1,18 @@ +[setup] +runscript main.sh + +[requirements] +priority 1 + +[items] +SETLOG 0 1 +TEST_DELAY 0 1 2 3 4 5 6 7 8 9 10 +ITERATIONS 0 1 2 3 4 5 6 7 8 9 10 + +[test_meta] +author matt +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 Index: utils/installall.sh ================================================================== --- utils/installall.sh +++ utils/installall.sh @@ -58,13 +58,14 @@ export KTYPE=26 else echo Using KTYPE=$KTYPE fi -export CHICKEN_VERSION=4.8.0 +export CHICKEN_VERSION=4.8.0.5 +export CHICKEN_BASEVER=4.8.0 if ! [[ -e chicken-${CHICKEN_VERSION}.tar.gz ]]; then - wget http://code.call-cc.org/releases/${CHICKEN_VERSION}/chicken-${CHICKEN_VERSION}.tar.gz + wget http://code.call-cc.org/releases/${CHICKEN_BASEVER}/chicken-${CHICKEN_VERSION}.tar.gz fi BUILDHOME=$PWD DEPLOYTARG=$BUILDHOME/deploy ADDED utils/mtrunscript Index: utils/mtrunscript ================================================================== --- /dev/null +++ utils/mtrunscript @@ -0,0 +1,203 @@ +#!/usr/bin/env bash + +# Copyright 2012, 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. +# +# VERSION: + +# set -e +# set -u +# set -x + +# Usage: mtrunscript scriptname params +# +# Look for scriptname in this order +# +# $MT_TEST_RUN_DIR/scripts => $MT_RUN_AREA_HOME/scripts +# => $MT_RUN_AREA_HOME/../scripts => $PATH +# +# In each area look for the script with the name like this: +# +# scriptname_$TARGET[1]_$TARGET[2]_...$TARGET[n]_$MT_TESTNAME_$MT_ITEMPATH(s#/#_) +# + +echo "NOT IMPLEMENTED YET!" +exit + +case "x$1" in + # repo + xrep*) + fsl_dbinit + case "x$2" in + xhelp) + fsl_help + exit + ;; + + # repo get + xget) + hook_pre_repo_get "$@" + fsl_repo_get $3 $4 + hook_post_repo_get "$@" + exit + ;; + + xaddarea) + fsl_add_area $3 $4 + exit + ;; + + xdroparea) + fsl_remove_area $3 + exit + ;; + + xdbinit) + fsl_dbinit + exit + ;; + + xls|xlist) + shift + shift + fsl_ls "$@" + exit + ;; + + xcreate) + hook_pre_repo_create + fsl_repo_create $3 $4 $5 $6 + hook_post_repo_create + exit + ;; + + ximport) + fsl_repo_import $3 $4 $5 + exit + ;; + + *) + fsl_help + exit + esac + ;; + + "xmv") + if [ "x$2" = "x-f" ];then + # echo "Force mode" + fsl_force=1 + shift + shift + # change this to exec when happy! + # fsl mv -f f1 [f2 f3...] targ + fsl_mv "$@" + # args=("$@") + # echo $@ -> echo $@ + # use $# variable to print out + # number of arguments passed to the bash script + # echo Number of arguments passed: $# -> echo Number of arguments passed: $# + exit + else + # echo No force + shift + fsl_mv "$@" + exit + fi + ;; + + xtim*) + fsl_fork_find + shift + $FOSSILEXE timeline "$@" | sed -e :a -e '$!N;s/\n / /;ta' -e 'P;D' + exit + ;; + + # leaves output needs to be niceified, no need for a function + xle*) + fsl_fork_find + shift + $FOSSILEXE leaves "$@" | sed -e :a -e '$!N;s/\n / /;ta' -e 'P;D' + exit + ;; + + # changes and status + xcha* | xstat*) + fsl_fork_find + fsl_conflicts "$@" + rm -f $CONFLICT_FLAG_FILE + exit + ;; + + # ci/commit + xci | xcom*) + fsl_conflicts changes "$@" + trap "$FOSSILUTIL releaselock $FSLUTIL_PARAMS" SIGINT + # Set up for remote locking + if [ ! -e $CONFLICT_FLAG_FILE ]; then + rm -f $CONFLICT_FLAG_FILE + read -p "ERROR: Conflicts detected. Type \"yes\" to continue: " -e ANSWER + if [ $ANSWER = "yes" ]; then + $FOSSILUTIL commitlock $FSLUTIL_PARAMS + $FOSSILEXE "$@" + $FOSSILUTIL releaselock $FSLUTIL_PARAMS + else + exit 1 + fi + else + $FOSSILUTIL commitlock $FSLUTIL_PARAMS + $FOSSILEXE "$@" + $FOSSILUTIL releaselock $FSLUTIL_PARAMS + fi + exit + ;; + + xtag) + case "x$2" in + xadd | xcancel) + $FOSSILEXE "$@" + $FOSSILEXE sync + exit + ;; + + *) + $FOSSILEXE "$@" + exit + ;; + esac + ;; + + # add mention of repo to help + "xhelp") + if [ $# -gt 1 ]; then + case "x$2" in + xrepo) + fsl_help + exit + ;; + + *) + $FOSSILEXE "$@" + ;; + + esac + else + $FOSSILEXE help | sed -e 's/sync/sync repo/' + fi + exit + ;; + + xup* | xco) + fsl_fork_find + $FOSSILEXE "$@" + exit + ;; + +esac + +exec $FOSSILEXE "$@"