Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -4,11 +4,11 @@ INSTALL=install SRCFILES = common.scm items.scm launch.scm \ 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 zmq-transport.scm http-transport.scm \ + fs-transport.scm http-transport.scm \ client.scm gutils.scm synchash.scm daemon.scm GUISRCF = dashboard-tests.scm dashboard-guimonitor.scm OFILES = $(SRCFILES:%.scm=%.o) @@ -109,11 +109,11 @@ chmod a+x $(PREFIX)/bin/dashboard install : bin $(PREFIX)/bin/mtest $(PREFIX)/bin/megatest $(PREFIX)/bin/dboard $(PREFIX)/bin/dashboard $(HELPERS) $(PREFIX)/bin/nbfake $(PREFIX)/bin/nbfind $(PREFIX)/bin/newdboard deploytarg/apropos.so : Makefile - for i in apropos base64 canvas-draw csv-xml directory-utils dot-locking extras fmt format hostinfo http-client intarweb json md5 message-digest posix posix-extras readline regex regex-case s11n spiffy spiffy-request-vars sqlite3 srfi-1 srfi-18 srfi-69 tcp test uri-common zmq check-errors synch matchable sql-null tcp-server rpc blob-utils string-utils variable-item defstruct uri-generic sendfile opensll openssl lookup-table list-utils stack; do \ + for i in apropos base64 canvas-draw csv-xml directory-utils dot-locking extras fmt format hostinfo http-client intarweb json md5 message-digest posix posix-extras readline regex regex-case s11n spiffy spiffy-request-vars sqlite3 srfi-1 srfi-18 srfi-69 tcp test uri-common check-errors synch matchable sql-null tcp-server rpc blob-utils string-utils variable-item defstruct uri-generic sendfile opensll openssl lookup-table list-utils stack; do \ chicken-install -prefix deploytarg -deploy $$i;done deploytarg/libsqlite3.so : CSC_OPTIONS="-Ideploytarg -Ldeploytarg" $CHICKEN_INSTALL -prefix deploytarg -deploy sqlite3 Index: client.scm ================================================================== --- client.scm +++ client.scm @@ -12,11 +12,13 @@ ;; C L I E N T S ;;====================================================================== (require-extension (srfi 18) extras tcp s11n) -(use sqlite3 srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest zmq) +(use sqlite3 srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest) +;; (use zmq) + (import (prefix sqlite3 sqlite3:)) (use spiffy uri-common intarweb http-client spiffy-request-vars) (declare (unit client)) Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -19,11 +19,11 @@ (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:)) ;; Note, try to remove this dependency -(use zmq) +;; (use zmq) (declare (unit db)) (declare (uses common)) (declare (uses keys)) (declare (uses ods)) @@ -241,24 +241,24 @@ ;;====================================================================== ;; T E S T S P E C I F I C D B ;;====================================================================== ;; Create the sqlite db for the individual test(s) -(define (open-test-db testpath) - (debug:print-info 11 "open-test-db " testpath) - (if (and testpath - (directory? testpath) - (file-read-access? testpath)) - (let* ((dbpath (conc testpath "/testdat.db")) +(define (open-test-db work-area) + (debug:print-info 11 "open-test-db " work-area) + (if (and work-area + (directory? work-area) + (file-read-access? work-area)) + (let* ((dbpath (conc work-area "/testdat.db")) (dbexists (file-exists? dbpath)) (handler (make-busy-timeout (if (args:get-arg "-override-timeout") (string->number (args:get-arg "-override-timeout")) 136000)))) (handle-exceptions exn (begin - (debug:print 0 "ERROR: problem accessing test db " testpath ", you probably should clean and re-run this test" + (debug:print 0 "ERROR: problem accessing test db " work-area ", you probably should clean and re-run this test" ((condition-property-accessor 'exn 'message) exn)) #f) (set! db (sqlite3:open-database dbpath))) (sqlite3:set-busy-handler! db handler) (if (not dbexists) @@ -265,29 +265,31 @@ (begin (sqlite3:execute db "PRAGMA synchronous = FULL;") (debug:print-info 11 "Initialized test database " dbpath) (db:testdb-initialize db))) ;; (sqlite3:execute db "PRAGMA synchronous = 0;") - (debug:print-info 11 "open-test-db END (sucessful)" testpath) + (debug:print-info 11 "open-test-db END (sucessful)" work-area) ;; now let's test that everything is correct (handle-exceptions exn (begin - (debug:print 0 "ERROR: problem accessing test db " testpath ", you probably should clean and re-run this test" + (debug:print 0 "ERROR: problem accessing test db " work-area ", you probably should clean and re-run this test" ((condition-property-accessor 'exn 'message) exn)) #f) ;; Is there a cheaper single line operation that will check for existance of a table ;; and raise an exception ? (sqlite3:execute db "SELECT id FROM test_data LIMIT 1;")) db) (begin - (debug:print-info 11 "open-test-db END (unsucessful)" testpath) + (debug:print-info 11 "open-test-db END (unsucessful)" work-area) #f))) ;; find and open the testdat.db file for an existing test -(define (db:open-test-db-by-test-id db test-id) - (let* ((test-path (cdb:remote-run db:test-get-rundir-from-test-id db test-id))) +(define (db:open-test-db-by-test-id db test-id #!key (work-area #f)) + (let* ((test-path (if work-area + work-area + (cdb:remote-run db:test-get-rundir-from-test-id db test-id)))) (debug:print 3 "TEST PATH: " test-path) (open-test-db test-path))) (define (db:testdb-initialize db) (debug:print 11 "db:testdb-initialize START") @@ -541,10 +543,43 @@ (conc fieldname " " wildtype " '" patt "'"))) (if (null? patts) '("") patts)) comparator))) + + +;; register a test run with the db +(define (db:register-run db keys keyvallst runname state status user) + (debug:print 3 "runs:register-run, keys: " keys " keyvallst: " keyvallst " runname: " runname " state: " state " status: " status " user: " user) + (let* ((keystr (keys->keystr keys)) + (comma (if (> (length keys) 0) "," "")) + (andstr (if (> (length keys) 0) " AND " "")) + (valslots (keys->valslots keys)) ;; ?,?,? ... + (keyvals (map cadr keyvallst)) + (allvals (append (list runname state status user) keyvals)) + (qryvals (append (list runname) keyvals)) + (key=?str (string-intersperse (map (lambda (k)(conc (key:get-fieldname k) "=?")) keys) " AND "))) + (debug:print 3 "keys: " keys " allvals: " allvals " keyvals: " keyvals) + (debug:print 2 "NOTE: using target " (string-intersperse keyvals "/") " for this run") + (if (and runname (null? (filter (lambda (x)(not x)) keyvals))) ;; there must be a better way to "apply and" + (let ((res #f)) + (apply sqlite3:execute db (conc "INSERT OR IGNORE INTO runs (runname,state,status,owner,event_time" comma keystr ") VALUES (?,?,?,?,strftime('%s','now')" comma valslots ");") + allvals) + (apply sqlite3:for-each-row + (lambda (id) + (set! res id)) + db + (let ((qry (conc "SELECT id FROM runs WHERE (runname=? " andstr key=?str ");"))) + ;(debug:print 4 "qry: " qry) + qry) + qryvals) + (sqlite3:execute db "UPDATE runs SET state=?,status=? WHERE id=?;" state status res) + res) + (begin + (debug:print 0 "ERROR: Called without all necessary keys") + #f)))) + ;; replace header and keystr with a call to runs:get-std-run-fields ;; ;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") ) ;; runpatts: patt1,patt2 ... @@ -723,25 +758,10 @@ ;;====================================================================== ;; T E S T S ;;====================================================================== -(define (db:tests-register-test db run-id test-name item-path) - (debug:print-info 11 "db:tests-register-test START db=" db ", run-id=" run-id ", test-name=" test-name ", item-path=\"" item-path "\"") - (let ((item-paths (if (equal? item-path "") - (list item-path) - (list item-path "")))) - (for-each - (lambda (pth) - (sqlite3:execute db "INSERT OR IGNORE INTO tests (run_id,testname,event_time,item_path,state,status) VALUES (?,?,strftime('%s','now'),?,'NOT_STARTED','n/a');" - run-id - test-name - pth)) - item-paths) - (debug:print-info 11 "db:tests-register-test END db=" db ", run-id=" run-id ", test-name=" test-name ", item-path=\"" item-path "\"") - #f)) - ;; states and statuses are lists, turn them into ("PASS","FAIL"...) and use NOT IN ;; 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 @@ -846,13 +866,13 @@ ) (debug:print-info 11 "db:get-tests-for-run START run-ids=" run-ids ", testpatt=" testpatt ", states=" states ", statuses=" statuses ", not-in=" not-in ", sort-by=" sort-by) res)) ;; this one is a bit broken BUG FIXME -(define (db:delete-test-step-records db test-id) +(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))) + (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 (begin (sqlite3:execute tdb "DELETE FROM test_steps;") (sqlite3:execute tdb "DELETE FROM test_data;") @@ -896,10 +916,19 @@ testnames)) (define (cdb:delete-tests-in-state serverdat run-id state) (cdb:client-call serverdat 'delete-tests-in-state #t *default-numtries* run-id state)) +(define (cdb:tests-update-cpuload-diskfree serverdat test-id cpuload diskfree) + (cdb:client-call serverdat 'update-cpuload-diskfree #t *default-numtries* cpuload diskfree test-id)) + +(define (cdb:tests-update-run-duration serverdat test-id minutes) + (cdb:client-call serverdat 'update-run-duration #t *default-numtries* minutes test-id)) + +(define (cdb:tests-update-uname-host serverdat test-id uname hostname) + (cdb:client-call serverdat 'update-uname-host #t *default-numtries* test-id uname hostname)) + ;; speed up for common cases with a little logic (define (db:test-set-state-status-by-id db test-id newstate newstatus newcomment) (cond ((and newstate newstatus newcomment) (sqlite3:exectute db "UPDATE tests SET state=?,status=?,comment=? WHERE id=?;" newstate newstatus test-id)) @@ -976,12 +1005,15 @@ (define db:get-test-id db:get-test-id-not-cached) ;; given a test-info record, patch in the latest data from the testdat.db file ;; found in the test run directory -(define (db:patch-tdb-data-into-test-info db test-id res) - (let ((tdb (db:open-test-db-by-test-id db test-id))) +;; +;; NOT USED +;; +(define (db:patch-tdb-data-into-test-info db test-id res #!key (work-area #f)) + (let ((tdb (db:open-test-db-by-test-id db test-id work-area: work-area))) ;; get state and status from megatest.db in real time ;; other fields that perhaps should be updated: ;; fail_count ;; pass_count ;; final_logf @@ -1161,15 +1193,15 @@ ;; NOTE: Can remove the regex and base64 encoding for zmq (define (db:obj->string obj) (case *transport-type* ((fs) obj) - ((http) + ((http) (string-substitute - (regexp "=") "_" - (base64:base64-encode (with-output-to-string (lambda ()(serialize obj)))) - #t)) + (regexp "=") "_" + (base64:base64-encode (with-output-to-string (lambda ()(serialize obj)))) + #t)) ((zmq)(with-output-to-string (lambda ()(serialize obj)))) (else obj))) (define (db:string->obj msg) (case *transport-type* @@ -1218,10 +1250,11 @@ (vector-ref tmp 2)))) ((zmq) (handle-exceptions exn (begin + (debug:print-info 0 "cdb:client-call timeout or error. Trying again in 5 seconds") (thread-sleep! 5) (if (> numretries 0)(apply cdb:client-call serverdat qtype immediate (- numretries 1) params))) (let* ((push-socket (vector-ref serverdat 0)) (sub-socket (vector-ref serverdat 1)) (client-sig (client:get-signature)) @@ -1239,31 +1272,32 @@ (receive-message* sub-socket) ;; now get the actual message (let ((myres (db:string->obj (receive-message* sub-socket)))) (if (equal? query-sig (vector-ref myres 1)) (set! res (vector-ref myres 2)) - (loop)))))) - (timeout (lambda () - (let loop ((n numretries)) - (thread-sleep! 15) - (if (not res) - (if (> numretries 0) - (begin - (debug:print 2 "WARNING: no reply to query " params ", trying resend") - (debug:print-info 11 "re-sending message") - (send-message push-socket zdat) - (debug:print-info 11 "message re-sent") - (loop (- n 1))) - ;; (apply cdb:client-call *runremote* qtype immediate (- numretries 1) params)) - (begin - (debug:print 0 "ERROR: cdb:client-call timed out " params ", exiting.") - (exit 5)))))))) + (loop))))))) + ;; (timeout (lambda () + ;; (let loop ((n numretries)) + ;; (thread-sleep! 15) + ;; (if (not res) + ;; (if (> numretries 0) + ;; (begin + ;; (debug:print 2 "WARNING: no reply to query " params ", trying resend") + ;; (debug:print-info 11 "re-sending message") + ;; (send-message push-socket zdat) + ;; (debug:print-info 11 "message re-sent") + ;; (loop (- n 1))) + ;; ;; (apply cdb:client-call *runremote* qtype immediate (- numretries 1) params)) + ;; (begin + ;; (debug:print 0 "ERROR: cdb:client-call timed out " params ", exiting.") + ;; (exit 5)))))))) (debug:print-info 11 "Starting threads") (let ((th1 (make-thread send-receive "send receive")) - (th2 (make-thread timeout "timeout"))) + ;; (th2 (make-thread timeout "timeout")) + ) (thread-start! th1) - (thread-start! th2) + ;; (thread-start! th2) (thread-join! th1) (debug:print-info 11 "cdb:client-call returning res=" res) res)))))) (define (cdb:set-verbosity serverdat val) @@ -1288,14 +1322,11 @@ (define (cdb:pass-fail-counts serverdat test-id fail-count pass-count) (cdb:client-call serverdat 'pass-fail-counts #t *default-numtries* fail-count pass-count test-id)) (define (cdb:tests-register-test serverdat run-id test-name item-path) - (let ((item-paths (if (equal? item-path "") - (list item-path) - (list item-path "")))) - (cdb:client-call serverdat 'register-test #t *default-numtries* run-id test-name item-path))) + (cdb:client-call serverdat 'register-test #t *default-numtries* run-id test-name item-path)) (define (cdb:flush-queue serverdat) (cdb:client-call serverdat 'flush #f *default-numtries*)) (define (cdb:kill-server serverdat) @@ -1326,10 +1357,14 @@ db "SELECT rundir,final_logf FROM tests WHERE run_id=? AND testname=? AND item_path='';" run-id test-name) res)) +;;====================================================================== +;; A G R E G A T E D T R A N S A C T I O N D B W R I T E S +;;====================================================================== + (define db:queries (list '(register-test "INSERT OR IGNORE INTO tests (run_id,testname,event_time,item_path,state,status) VALUES (?,?,strftime('%s','now'),?,'NOT_STARTED','n/a');") '(state-status "UPDATE tests SET state=?,status=? WHERE id=?;") '(state-status-msg "UPDATE tests SET state=?,status=?,comment=? WHERE id=?;") '(pass-fail-counts "UPDATE tests SET fail_count=?,pass_count=? WHERE id=?;") @@ -1345,10 +1380,13 @@ '(test-set-log "UPDATE tests SET final_logf=? WHERE id=?;") '(test-set-rundir-by-test-id "UPDATE tests SET rundir=? WHERE id=?") '(test-set-rundir "UPDATE tests SET rundir=? WHERE run_id=? AND testname=? AND item_path=?;") '(delete-tests-in-state "DELETE FROM tests WHERE state=? AND run_id=?;") '(tests:test-set-toplog "UPDATE tests SET final_logf=? WHERE run_id=? AND testname=? AND item_path='';") + '(update-cpuload-diskfree "UPDATE tests SET cpuload=?,diskfree=? WHERE id=?;") + '(update-run-duration "UPDATE tests SET run_duration=? WHERE id=?;") + '(update-uname-host "UPDATE tests SET uname=?,host=? WHERE id=?;") )) ;; do not run these as part of the transaction (define db:special-queries '(rollup-tests-pass-fail db:roll-up-pass-fail-counts @@ -1464,11 +1502,11 @@ (< (current-seconds) timeout)) (begin (thread-sleep! 0.01) (loop)))) (set! *number-of-writes* (+ *number-of-writes* 1)) - (set! *writes-total-delay* (+ *writes-total-delay* 1)) + (set! *writes-total-delay* (+ *writes-total-delay* (- (current-milliseconds) start-time))) got-it)) (define (db:process-queue-item db item) (let* ((stmt-key (cdb:packet-get-qtype item)) (qry-sig (cdb:packet-get-query-sig item)) @@ -1551,19 +1589,20 @@ "SELECT id,item_path,state,status,run_duration,final_logf,comment FROM tests WHERE run_id=? AND testname=? AND item_path != '';" run-id test-name) res)) ;; Rollup the pass/fail counts from itemized tests into fail_count and pass_count +;; NOTE: Is this duplicating (db:test-data-rollup db test-id status) ???? (define (db:roll-up-pass-fail-counts db run-id test-name item-path status) ;; (cdb:flush-queue *runremote*) (if (and (not (equal? item-path "")) (member status '("PASS" "WARN" "FAIL" "WAIVED" "RUNNING" "CHECK" "SKIP"))) (begin (sqlite3:execute db "UPDATE tests - SET fail_count=(SELECT count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND status='FAIL'), + SET fail_count=(SELECT count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND status IN ('FAIL','CHECK')), pass_count=(SELECT count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND status IN ('PASS','WARN','WAIVED')) WHERE run_id=? AND testname=? AND item_path='';" run-id test-name run-id test-name run-id test-name) ;; (thread-sleep! 0.1) ;; give other processes a chance here, no, better to be done ASAP? (if (equal? status "RUNNING") ;; running takes priority over all other states, force the test state to RUNNING @@ -1575,16 +1614,20 @@ WHEN (SELECT count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND state in ('RUNNING','NOT_STARTED')) > 0 THEN 'RUNNING' ELSE 'COMPLETED' END, - status=CASE - WHEN fail_count > 0 THEN 'FAIL' - WHEN pass_count > 0 AND fail_count=0 THEN 'PASS' - ELSE 'UNKNOWN' END + status=CASE + WHEN fail_count > 0 THEN 'FAIL' + WHEN pass_count > 0 AND fail_count=0 THEN 'PASS' + WHEN (SELECT count(id) FROM tests + WHERE run_id=? AND testname=? + AND item_path != '' + AND status = 'SKIP') > 0 THEN 'SKIP' + ELSE 'UNKNOWN' END WHERE run_id=? AND testname=? AND item_path='';" - run-id test-name run-id test-name)) + run-id test-name run-id test-name run-id test-name)) #f) #f)) ;;====================================================================== ;; Tests meta data @@ -1610,13 +1653,13 @@ ;;====================================================================== ;; T E S T D A T A ;;====================================================================== -(define (db:csv->test-data db test-id csvdata) +(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))) + (let ((tdb (db:open-test-db-by-test-id db test-id work-area: work-area))) (if tdb (let ((csvlist (csv->list (make-csv-reader (open-input-string csvdata) '((strip-leading-whitespace? #t) (strip-trailing-whitespace? #t)) )))) ;; (csv->list csvdata))) @@ -1666,17 +1709,17 @@ ((<=) (if (<= value expected) "pass" "fail")) (else (conc "ERROR: bad tol comparator " tol)))))) (debug:print 4 "AFTER2: category: " category " variable: " variable " value: " value ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment) (sqlite3:execute tdb "INSERT OR REPLACE INTO test_data (test_id,category,variable,value,expected,tol,units,comment,status,type) VALUES (?,?,?,?,?,?,?,?,?,?);" - test-id category variable value expected tol units (if comment comment "") status type) - (sqlite3:finalize! tdb))) - csvlist))))) + test-id category variable value expected tol units (if comment comment "") status type))) + csvlist) + (sqlite3:finalize! tdb))))) ;; get a list of test_data records matching categorypatt -(define (db:read-test-data db test-id categorypatt) - (let ((tdb (db:open-test-db-by-test-id db test-id))) +(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 (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))) @@ -1685,28 +1728,28 @@ (sqlite3:finalize! tdb) (reverse res)) '()))) ;; NOTE: Run this local with #f for db !!! -(define (db:load-test-data db test-id) +(define (db:load-test-data db test-id #!key (work-area #f)) (let loop ((lin (read-line))) (if (not (eof-object? lin)) (begin (debug:print 4 lin) - (db:csv->test-data db test-id lin) + (db:csv->test-data db test-id lin work-area: work-area) (loop (read-line))))) ;; roll up the current results. ;; FIXME: Add the status to - (db:test-data-rollup db test-id #f)) + (db:test-data-rollup db test-id #f work-area: work-area)) ;; WARNING: Do NOT call this for the parent test on an iterated test ;; Roll up test_data pass/fail results ;; look at the test_data status field, ;; if all are pass (any case) and the test status is PASS or NULL or '' then set test status to PASS. ;; 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) - (let ((tdb (db:open-test-db-by-test-id db test-id)) +(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 (begin (sqlite3:for-each-row @@ -1721,11 +1764,15 @@ ;; Now rollup the counts to the central megatest.db (cdb:pass-fail-counts *runremote* test-id fail-count pass-count) ;; (sqlite3:execute db "UPDATE tests SET fail_count=?,pass_count=? WHERE id=?;" ;; fail-count pass-count test-id) - (cdb:flush-queue *runremote*) + + ;; The flush is not needed with the transaction based write agregation enabled. Remove these commented lines + ;; next time you read this! + ;; + ;; (cdb:flush-queue *runremote*) ;; (thread-sleep! 1) ;; play nice with the queue by ensuring the rollup is at least 10ms later than the set ;; if the test is not FAIL then set status based on the fail and pass counts. (cdb:test-rollup-test_data-pass-fail *runremote* test-id) ;; (sqlite3:execute @@ -1751,12 +1798,12 @@ (define (db:step-get-time-as-string vec) (seconds->time-string (db:step-get-event_time vec))) ;; db-get-test-steps-for-run -(define (db:get-steps-for-test db test-id) - (let* ((tdb (db:open-test-db-by-test-id db test-id)) +(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) @@ -1768,12 +1815,12 @@ (reverse res)) '()))) ;; get a pretty table to summarize steps ;; -(define (db:get-steps-table db test-id) - (let ((steps (db:get-steps-for-test db test-id))) +(define (db:get-steps-table db test-id #!key (work-area #f)) + (let ((steps (db:get-steps-for-test db test-id work-area: work-area))) ;; organise the steps for better readability (let ((res (make-hash-table))) (for-each (lambda (step) (debug:print 6 "step=" step) @@ -1828,12 +1875,12 @@ (else #f))))) res))) ;; get a pretty table to summarize steps ;; -(define (db:get-steps-table-list db test-id) - (let ((steps (db:get-steps-for-test db test-id))) +(define (db:get-steps-table-list db test-id #!key (work-area #f)) + (let ((steps (db:get-steps-for-test db test-id work-area: work-area))) ;; organise the steps for better readability (let ((res (make-hash-table))) (for-each (lambda (step) (debug:print 6 "step=" step) @@ -1970,14 +2017,14 @@ (if (not ever-seen) (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) +(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)) + (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")) Index: http-transport.scm ================================================================== --- http-transport.scm +++ http-transport.scm @@ -206,12 +206,13 @@ (begin (debug:print-info 2 "Logged in and connected to " iface ":" port) (set! *runremote* serverdat) serverdat) (begin - (debug:print-info 2 "Failed to login or connect to " iface ":" port) + (debug:print-info 0 "Failed to login or connect to " iface ":" port) (set! *runremote* #f) + (set! *transport-type* 'fs) #f)))) ;; run http-transport:keep-running in a parallel thread to monitor that the db is being ;; used and to shutdown after sometime if it is not. @@ -231,17 +232,18 @@ (loop)))))) (iface (car server-info)) (port (cadr server-info)) (last-access 0) (tdb (tasks:open-db)) - (spid (tasks:server-get-server-id tdb #f iface port #f)) + (spid ;;(open-run-close tasks:server-get-server-id tasks:open-db #f iface port #f)) + (tasks:server-get-server-id tdb #f iface port #f)) (server-timeout (let ((tmo (config-lookup *configdat* "server" "timeout"))) (if (and (string? tmo) (string->number tmo)) (* 60 60 (string->number tmo)) ;; default to three days - (* 3 24 60))))) + (* 3 24 60 60))))) (debug:print-info 2 "server-timeout: " server-timeout ", server pid: " spid " on " iface ":" port) (let loop ((count 0)) (thread-sleep! 4) ;; no need to do this very often ;; NB// sync currently does NOT return queue-length (let () ;; (queue-len (cdb:client-call server-info 'sync #t 1))) @@ -252,18 +254,20 @@ ;; Check that iface and port have not changed (can happen if server port collides) (mutex-lock! *heartbeat-mutex*) (set! sdat *runremote*) (mutex-unlock! *heartbeat-mutex*) - (if (not (equal? sdat (list iface port))) + (if (or (not (equal? sdat (list iface port))) + (not spid)) (begin - (debug:print-info 1 "interface changed, refreshing iface and port info") + (debug:print-info 0 "interface changed, refreshing iface and port info") (set! iface (car sdat)) (set! port (cadr sdat)) (set! spid (tasks:server-get-server-id tdb #f iface port #f)))) ;; NOTE: Get rid of this mechanism! It really is not needed... + ;; (open-run-close tasks:server-update-heartbeat tasks:open-db spid) (tasks:server-update-heartbeat tdb spid) ;; (if ;; (or (> numrunning 0) ;; stay alive for two days after last access (mutex-lock! *heartbeat-mutex*) (set! last-access *last-db-access*) @@ -276,11 +280,11 @@ (loop 0)) (begin (debug:print-info 0 "Starting to shutdown the server.") ;; need to delete only *my* server entry (future use) (set! *time-to-exit* #t) - (tasks:server-deregister-self tdb (get-host-name)) + (open-run-close tasks:server-deregister-self tasks:open-db (get-host-name)) (thread-sleep! 1) (debug:print-info 0 "Max cached queries was " *max-cache-size*) (debug:print-info 0 "Number of cached writes " *number-of-writes*) (debug:print-info 0 "Average cached write time " (if (eq? *number-of-writes* 0) @@ -329,10 +333,12 @@ (debug:print 0 "ERROR: Failed to setup for megatest"))) (exit))) ;; (use trace) ;; (trace http-transport:keep-running +;; tasks:server-update-heartbeat +;; tasks:server-get-server-id) ;; tasks:get-best-server ;; http-transport:run ;; http-transport:launch ;; http-transport:try-start-server ;; http-transport:client-send-receive Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -53,13 +53,13 @@ (define (launch:execute encoded-cmd) (let* ((cmdinfo (read (open-input-string (base64:base64-decode encoded-cmd))))) (setenv "MT_CMDINFO" encoded-cmd) (if (list? cmdinfo) ;; ((testpath /tmp/mrwellan/jazzmind/src/example_run/tests/sqlitespeed) ;; (test-name sqlitespeed) (runscript runscript.rb) (db-host localhost) (run-id 1)) - (let* ((testpath (assoc/default 'testpath cmdinfo)) ;; How is testpath different from work-area ?? + (let* ((testpath (assoc/default 'testpath cmdinfo)) ;; testpath is the test spec area (top-path (assoc/default 'toppath cmdinfo)) - (work-area (assoc/default 'work-area cmdinfo)) + (work-area (assoc/default 'work-area cmdinfo)) ;; work-area is the test run area (test-name (assoc/default 'test-name cmdinfo)) (runscript (assoc/default 'runscript cmdinfo)) (ezsteps (assoc/default 'ezsteps cmdinfo)) ;; (runremote (assoc/default 'runremote cmdinfo)) (transport (assoc/default 'transport cmdinfo)) @@ -133,11 +133,11 @@ (alist->env-vars env-ovrd) (set-megatest-env-vars run-id) (set-item-env-vars itemdat) (save-environment-as-files "megatest") ;; open-run-close not needed for test-set-meta-info - (test-set-meta-info #f test-id run-id test-name itemdat 0) + (tests:set-meta-info #f test-id run-id test-name itemdat 0 work-area) (tests:test-set-status! test-id "REMOTEHOSTSTART" "n/a" (args:get-arg "-m") #f) (if (args:get-arg "-xterm") (set! fullrunscript "xterm") (if (and fullrunscript (not (file-execute-access? fullrunscript))) (system (conc "chmod ug+x " fullrunscript)))) @@ -208,11 +208,11 @@ ;; call the command using mt_ezstep (set! script (conc "mt_ezstep " stepname " " (if prevstep prevstep "-") " " stepcmd)) (debug:print 4 "script: " script) ;; DO NOT remote - (db:teststep-set-status! #f test-id stepname "start" "-" #f #f) + (db:teststep-set-status! #f test-id stepname "start" "-" #f #f work-area: work-area) ;; now launch (let ((pid (process-run script))) (let processloop ((i 0)) (let-values (((pid-val exit-status exit-code)(process-wait pid #t))) (mutex-lock! m) @@ -226,11 +226,11 @@ (processloop (+ i 1)))) )) (let ((exinfo (vector-ref exit-info 2)) (logfna (if logpro-used (conc stepname ".html") ""))) ;; testing if procedures called in a remote call cause problems (ans: no or so I suspect) - (db:teststep-set-status! #f test-id stepname "end" exinfo #f logfna)) + (db:teststep-set-status! #f test-id stepname "end" exinfo #f logfna work-area: work-area)) (if logpro-used (cdb:test-set-log! *runremote* test-id (conc stepname ".html"))) ;; set the test final status (let* ((this-step-status (cond ((and (eq? (vector-ref exit-info 2) 2) logpro-used) 'warn) @@ -276,11 +276,11 @@ (kill-tries 0)) (let loop ((minutes (calc-minutes))) (begin (set! kill-job? (test-get-kill-request test-id)) ;; run-id test-name itemdat)) ;; open-run-close not needed for test-set-meta-info - (test-set-meta-info #f test-id run-id test-name itemdat minutes) + (tests:set-meta-info #f test-id run-id test-name itemdat minutes work-area) (if kill-job? (begin (mutex-lock! m) (let* ((pid (vector-ref exit-info 0))) (if (number? pid) @@ -537,15 +537,16 @@ (begin (let* ((ovrcmd (let ((cmd (config-lookup *configdat* "setup" "testcopycmd"))) (if cmd ;; substitute the TEST_SRC_PATH and TEST_TARG_PATH (string-substitute "TEST_TARG_PATH" test-path - (string-substitute "TEST_SRC_PATH" test-src-path cmd)) + (string-substitute "TEST_SRC_PATH" test-src-path cmd #t) #t) #f))) (cmd (if ovrcmd ovrcmd - (conc "rsync -av" (if (debug:debug-mode 1) "" "q") " " test-src-path "/ " test-path "/"))) + (conc "rsync -av" (if (debug:debug-mode 1) "" "q") " " test-src-path "/ " test-path "/" + " >> " test-path "/mt_launch.log >>2 " test-path "/mt_launch.log"))) (status (system cmd))) (if (not (eq? status 0)) (debug:print 2 "ERROR: problem with running \"" cmd "\""))) (list lnkpathf lnkpath )) (list #f #f)))) @@ -668,34 +669,37 @@ (list "MT_ITEM_INFO" (conc itemdat)) (list "MT_RUNNAME" runname) (list "MT_TARGET" mt_target) ) itemdat))) - (launch-results (apply cmd-run-with-stderr->list ;; cmd-run-proc-each-line + (launch-results (apply (if (equal? (configf:lookup *configdat* "setup" "launchwait") "yes") + cmd-run-with-stderr->list + process-run) (if useshell (string-intersperse fullcmd " ") (car fullcmd)) - ;; conc (if useshell '() - (cdr fullcmd))))) ;; launcher fullcmd)));; (apply cmd-run-proc-each-line launcher print fullcmd))) ;; (cmd-run->list fullcmd)) - (with-output-to-file "mt_launch.log" - (lambda () - (apply print launch-results))) + (cdr fullcmd))))) + (if (list? launch-results) + (with-output-to-file "mt_launch.log" + (lambda () + (apply print launch-results)) + #:append)) (debug:print 2 "Launching completed, updating db") (debug:print 2 "Launch results: " launch-results) (if (not launch-results) - (begin - (print "ERROR: Failed to run " (string-intersperse fullcmd " ") ", exiting now") - ;; (sqlite3:finalize! db) - ;; good ole "exit" seems not to work - ;; (_exit 9) - ;; but this hack will work! Thanks go to Alan Post of the Chicken email list - ;; NB// Is this still needed? Should be safe to go back to "exit" now? - (process-signal (current-process-id) signal/kill) - )) + (begin + (print "ERROR: Failed to run " (string-intersperse fullcmd " ") ", exiting now") + ;; (sqlite3:finalize! db) + ;; good ole "exit" seems not to work + ;; (_exit 9) + ;; but this hack will work! Thanks go to Alan Post of the Chicken email list + ;; NB// Is this still needed? Should be safe to go back to "exit" now? + (process-signal (current-process-id) signal/kill) + )) (alist->env-vars miscprevvals) (alist->env-vars testprevvals) (alist->env-vars commonprevvals) launch-results)) (change-directory *toppath*)) 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.5415) +(define megatest-version 1.5417) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -12,11 +12,11 @@ (use sqlite3 srfi-1 posix regex regex-case srfi-69 base64 format readline apropos json) ;; (srfi 18) extras) (import (prefix sqlite3 sqlite3:)) (import (prefix base64 base64:)) -(use zmq) +;; (use zmq) (declare (uses common)) (declare (uses megatest-version)) (declare (uses margs)) (declare (uses runs)) @@ -34,12 +34,19 @@ (include "db_records.scm") (include "megatest-fossil-hash.scm") ;; (use trace dot-locking) ;; (trace -;; cdb:client-call -;; cdb:remote-run +;; db:teststep-set-status! +;; db:open-test-db-by-test-id +;; db:test-get-rundir-from-test-id +;; cdb:tests-register-test +;; cdb:tests-update-uname-host +;; cdb:tests-update-run-duration +;; ;; cdb:client-call +;; ;; cdb:remote-run +;; ) ;; cdb:test-set-status-state ;; change-directory ;; db:process-queue-item ;; db:test-get-logfile-info ;; db:teststep-set-status! @@ -119,20 +126,21 @@ -list-targets : list the targets in runconfigs.config -list-db-targets : list the target combinations used in the db -show-config : dump the internal representation of the megatest.config file -show-runconfig : dump the internal representation of the runconfigs.config file -dumpmode json : dump in json format instead of sexpr + -show-cmdinfo : dump the command info for a test (run in test environment) Misc -rebuild-db : bring the database schema up to date -update-meta : update the tests metadata for all tests -env2file fname : write the environment to fname.csh and fname.sh -setvars VAR1=val1,VAR2=val2 : Add environment variables to a run NB// these are overwritten by values set in config files. -server -|hostname : start the server (reduces contention on megatest.db), use - to automatically figure out hostname - -transport http|zmq : use http or zmq for transport (default is http) + -transport http|fs : use http or direct access for transport (default is http) -daemonize : fork into background and disconnect from stdin/out -list-servers : list the servers -stop-server id : stop server specified by id (see output of -list-servers) -repl : start a repl (useful for extending megatest) -load file.scm : load and run file.scm @@ -231,10 +239,11 @@ "-list-disks" "-list-targets" "-list-db-targets" "-show-runconfig" "-show-config" + "-show-cmdinfo" ;; queries "-test-paths" ;; get path(s) to a test, ordered by youngest first "-runall" ;; run all tests "-remove-runs" @@ -431,10 +440,17 @@ ((string=? (args:get-arg "-dumpmode") "json") (json-write data)) (else (debug:print 0 "ERROR: -dumpmode of " (args:get-arg "-dumpmode") " not recognised"))) (set! *didsomething* #t))) + +(if (args:get-arg "-show-cmdinfo") + (let ((data (read (open-input-string (base64:base64-decode (getenv "MT_CMDINFO")))))) + (if (equal? (args:get-arg "-dumpmode") "json") + (json-write data) + (pp data)) + (set! *didsomething* #t))) ;;====================================================================== ;; Remove old run(s) ;;====================================================================== @@ -508,12 +524,13 @@ ;; (print "[" targetstr "]")))) (print targetstr)))) (if (not db-targets) (let* ((run-id (db:get-value-by-header run header "id")) (tests (cdb:remote-run db:get-tests-for-run #f run-id testpatt '() '()))) - (debug:print 1 "Run: " targetstr " status: " (db:get-value-by-header run header "state") - " run-id: " run-id ", number tests: " (length tests)) + (print "Run: " targetstr "/" (db:get-value-by-header run header "runname") + " status: " (db:get-value-by-header run header "state") + " run-id: " run-id ", number tests: " (length tests)) (for-each (lambda (test) (format #t " Test: ~25a State: ~15a Status: ~15a Runtime: ~5@as Time: ~22a Host: ~10a\n" (conc (db:test-get-testname test) @@ -796,21 +813,22 @@ (runscript (assoc/default 'runscript cmdinfo)) (db-host (assoc/default 'db-host cmdinfo)) (run-id (assoc/default 'run-id cmdinfo)) (test-id (assoc/default 'test-id cmdinfo)) (itemdat (assoc/default 'itemdat cmdinfo)) + (work-area (assoc/default 'work-area cmdinfo)) (db #f)) (change-directory testpath) ;; (set! *runremote* runremote) (set! *transport-type* (string->symbol transport)) (if (not (setup-for-run)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) (if (and state status) - ;; DO NOT remote run - (db:teststep-set-status! db test-id step state status msg logfile) + ;; DO NOT remote run, makes calls to the testdat.db test db. + (db:teststep-set-status! db test-id step state status msg logfile work-area: work-area) (begin (debug:print 0 "ERROR: You must specify :state and :status with every call to -step") (exit 6)))))) (if (args:get-arg "-step") @@ -822,11 +840,12 @@ (args:get-arg "-setlog") (args:get-arg "-m")) ;; (if db (sqlite3:finalize! db)) (set! *didsomething* #t))) -(if (or (args:get-arg "-setlog") ;; since setting up is so costly lets piggyback on -test-status +(if (or (and (args:get-arg "-setlog") ;; since setting up is so costly lets piggyback on -test-status + (not (args:get-arg "-step"))) ;; -setlog may have been processed already in the "-step" previous (args:get-arg "-set-toplog") (args:get-arg "-test-status") (args:get-arg "-set-values") (args:get-arg "-load-test-data") (args:get-arg "-runstep") @@ -844,10 +863,11 @@ (runscript (assoc/default 'runscript cmdinfo)) (db-host (assoc/default 'db-host cmdinfo)) (run-id (assoc/default 'run-id cmdinfo)) (test-id (assoc/default 'test-id cmdinfo)) (itemdat (assoc/default 'itemdat cmdinfo)) + (work-area (assoc/default 'work-area cmdinfo)) (db #f) ;; (open-db)) (state (args:get-arg ":state")) (status (args:get-arg ":status"))) (change-directory testpath) ;; (set! *runremote* runremote) @@ -861,11 +881,11 @@ ;; (client:setup) (if (args:get-arg "-load-test-data") ;; has sub commands that are rdb: ;; DO NOT put this one into either cdb:remote-run or open-run-close - (db:load-test-data db test-id)) + (db:load-test-data db test-id work-area: work-area)) (if (args:get-arg "-setlog") (let ((logfname (args:get-arg "-setlog"))) (cdb:test-set-log! *runremote* test-id logfname))) (if (args:get-arg "-set-toplog") ;; DO NOT run remote @@ -893,11 +913,11 @@ (fullcmd (conc "(" (string-intersperse (cons cmd params) " ") ") " redir " " logfile))) ;; mark the start of the test ;; DO NOT run remote - (db:teststep-set-status! db test-id stepname "start" "n/a" (args:get-arg "-m") logfile) + (db:teststep-set-status! db test-id stepname "start" "n/a" (args:get-arg "-m") logfile work-area: work-area) ;; run the test step (debug:print-info 2 "Running \"" fullcmd "\"") (change-directory startingdir) (set! exitstat (system fullcmd)) ;; cmd params)) (set! *globalexitstatus* exitstat) @@ -913,11 +933,11 @@ (set! *globalexitstatus* exitstat) ;; no necessary (change-directory testpath) (cdb:test-set-log! *runremote* test-id htmllogfile))) (let ((msg (args:get-arg "-m"))) ;; DO NOT run remote - (db:teststep-set-status! db test-id stepname "end" exitstat msg logfile)) + (db:teststep-set-status! db test-id stepname "end" exitstat msg logfile work-area: work-area)) ))) (if (or (args:get-arg "-test-status") (args:get-arg "-set-values")) (let ((newstatus (cond ((number? status) (if (equal? status 0) "PASS" "FAIL")) @@ -940,11 +960,11 @@ ;; (sqlite3:finalize! db) (exit 6))) (let* ((msg (args:get-arg "-m")) (numoth (length (hash-table-keys otherdata)))) ;; Convert to rpc inside the tests:test-set-status! call, not here - (tests:test-set-status! test-id state newstatus msg otherdata)))) + (tests:test-set-status! test-id state newstatus msg otherdata work-area: work-area)))) (if db (sqlite3:finalize! db)) (set! *didsomething* #t)))) ;;====================================================================== ;; Various helper commands can go below here Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -171,40 +171,10 @@ ;; New methodology. These routines will replace the above in time. For ;; now the code is duplicated. This stuff is initially used in the monitor ;; based code. ;;====================================================================== -;; register a test run with the db -(define (runs:register-run db keys keyvallst runname state status user) - (debug:print 3 "runs:register-run, keys: " keys " keyvallst: " keyvallst " runname: " runname " state: " state " status: " status " user: " user) - (let* ((keystr (keys->keystr keys)) - (comma (if (> (length keys) 0) "," "")) - (andstr (if (> (length keys) 0) " AND " "")) - (valslots (keys->valslots keys)) ;; ?,?,? ... - (keyvals (map cadr keyvallst)) - (allvals (append (list runname state status user) keyvals)) - (qryvals (append (list runname) keyvals)) - (key=?str (string-intersperse (map (lambda (k)(conc (key:get-fieldname k) "=?")) keys) " AND "))) - (debug:print 3 "keys: " keys " allvals: " allvals " keyvals: " keyvals) - (debug:print 2 "NOTE: using target " (string-intersperse keyvals "/") " for this run") - (if (and runname (null? (filter (lambda (x)(not x)) keyvals))) ;; there must be a better way to "apply and" - (let ((res #f)) - (apply sqlite3:execute db (conc "INSERT OR IGNORE INTO runs (runname,state,status,owner,event_time" comma keystr ") VALUES (?,?,?,?,strftime('%s','now')" comma valslots ");") - allvals) - (apply sqlite3:for-each-row - (lambda (id) - (set! res id)) - db - (let ((qry (conc "SELECT id FROM runs WHERE (runname=? " andstr key=?str ");"))) - ;(debug:print 4 "qry: " qry) - qry) - qryvals) - (sqlite3:execute db "UPDATE runs SET state=?,status=? WHERE id=?;" state status res) - res) - (begin - (debug:print 0 "ERROR: Called without all necessary keys") - #f)))) ;; This is a duplicate of run-tests (which has been deprecated). Use this one instead of run tests. ;; keyvals. ;; ;; test-names: Comma separated patterns same as test-patts but used in selection @@ -214,11 +184,11 @@ (define (runs:run-tests target runname test-names test-patts user flags) (common:clear-caches) ;; clear all caches (let* ((db #f) (keys (cdb:remote-run db:get-keys #f)) (keyvallst (keys:target->keyval keys target)) - (run-id (cdb:remote-run runs:register-run #f keys keyvallst runname "new" "n/a" user)) ;; test-name))) + (run-id (cdb:remote-run db:register-run #f keys keyvallst runname "new" "n/a" user)) ;; test-name))) (keyvals (if run-id (cdb:remote-run db:get-key-vals #f run-id) #f)) (deferred '()) ;; delay running these since they have a waiton clause ;; keepgoing is the defacto modality now, will add hit-n-run a bit later ;; (keepgoing (hash-table-ref/default flags "-keepgoing" #f)) (runconfigf (conc *toppath* "/runconfigs.config")) @@ -295,10 +265,11 @@ ;; 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 ", keyvallst: " keyvallst " flags: " (hash-table->alist flags)) (let ((sorted-test-names (tests:sort-by-priority-and-waiton test-records)) (test-registery (make-hash-table)) + (registery-mutex (make-mutex)) (num-retries 0) (max-retries (config-lookup *configdat* "setup" "maxretries"))) (set! max-retries (if (and max-retries (string->number max-retries))(string->number max-retries) 100)) (if (not (null? sorted-test-names)) (let loop ((hed (car sorted-test-names)) @@ -336,17 +307,17 @@ (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 ;; OUTER COND ((not items) ;; when false the test is ok to be handed off to launch (but not before) - (let* ((run-limits-info (open-run-close runs:can-run-more-tests test-record)) ;; look at the test jobgroup and tot jobs running + (let* ((run-limits-info (runs:can-run-more-tests test-record)) ;; look at the test jobgroup and tot jobs running (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 (open-run-close db:get-prereqs-not-met #f run-id waitons item-path mode: testmode)) + (prereqs-not-met (cdb:remote-run db:get-prereqs-not-met #f 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 8 "have-resources: " have-resources " prereqs-not-met: " (string-intersperse (map (lambda (t) @@ -366,30 +337,60 @@ ;; but should check if it is due to lack of resources vs. prerequisites (debug:print-info 1 "Skipping " (tests:testqueue-get-testname test-record) " " item-path " as it doesn't match " test-patts) ;; (thread-sleep! *global-delta*) (if (not (null? tal)) (loop (car tal)(cdr tal) reruns))) - ( ;; (and - (not (hash-table-ref/default test-registery (runs:make-full-test-name test-name item-path) #f)) - ;; (and max-concurrent-jobs (> (- max-concurrent-jobs num-running) 5))) + ;; Registery has been started for this test but has not yet completed + ;; this should be rare, the case where there are only a couple of tests and the db is slow + ;; delay a short while and continue + ;; ((eq? (hash-table-ref/default test-registery (runs:make-full-test-name test-name item-path) #f) 'start) + ;; (thread-sleep! 0.01) + ;; (loop (car newtal)(cdr newtal) reruns)) + ;; count number of 'done, if more than 100 then skip on through. + (;; (and (< (length (filter (lambda (x)(eq? x 'done))(hash-table-values test-registery))) 100) ;; why get more than 200 ahead? + (not (hash-table-ref/default test-registery (runs:make-full-test-name test-name item-path) #f)) ;; ) ;; too many changes required. Implement later. (debug:print-info 4 "Pre-registering test " test-name "/" item-path " to create placeholder" ) - (open-run-close db:tests-register-test #f run-id test-name item-path) - (hash-table-set! test-registery (runs:make-full-test-name test-name item-path) #t) - ;; (thread-sleep! *global-delta*) -(runs:shrink-can-run-more-tests-delay) + ;; NEED TO THREADIFY THIS + (let ((th (make-thread (lambda () + (mutex-lock! registery-mutex) + (hash-table-set! test-registery (runs:make-full-test-name test-name item-path) 'start) + (mutex-unlock! registery-mutex) + ;; If haven't done it before register a top level test if this is an itemized test + (if (not (eq? (hash-table-ref/default test-registery (runs:make-full-test-name test-name "") #f) 'done)) + (cdb:tests-register-test *runremote* run-id test-name "")) + (cdb:tests-register-test *runremote* run-id test-name item-path) + (mutex-lock! registery-mutex) + (hash-table-set! test-registery (runs:make-full-test-name test-name item-path) 'done) + (mutex-unlock! registery-mutex)) + (conc test-name "/" item-path)))) + (thread-start! th)) + (thread-sleep! *global-delta*) + (runs:shrink-can-run-more-tests-delay) ;; DELAY TWEAKER (still needed?) (loop (car newtal)(cdr newtal) reruns)) + ;; At this point *all* test registrations must be completed. + ((not (null? (filter (lambda (x)(eq? 'start x))(hash-table-values test-registery)))) + (debug:print-info 0 "Waiting on test registrations: " (string-intersperse + (filter (lambda (x) + (eq? (hash-table-ref/default test-registery x #f) 'start)) + (hash-table-keys test-registery)) + ", ")) + (thread-sleep! 0.1) + (loop hed tal reruns)) ((not have-resources) ;; simply try again after waiting a second (debug:print-info 1 "no resources to run new tests, waiting ...") - ;; (thread-sleep! (+ 2 *global-delta*)) + ;; Have gone back and forth on this but db starvation is an issue. + ;; wait one second before looking again to run jobs. + (thread-sleep! 1) ;; (+ 2 *global-delta*)) ;; could have done hed tal here but doing car/cdr of newtal to rotate tests (loop (car newtal)(cdr newtal) reruns)) ((and have-resources (or (null? prereqs-not-met) (and (eq? testmode 'toplevel) (null? non-completed)))) (run:test run-id runname keyvallst test-record flags #f) -(runs:shrink-can-run-more-tests-delay) + (hash-table-set! test-registery (runs:make-full-test-name test-name item-path) 'running) + (runs:shrink-can-run-more-tests-delay) ;; DELAY TWEAKER (still needed?) ;; (thread-sleep! *global-delta*) (if (not (null? tal)) (loop (car tal)(cdr tal) reruns))) (else ;; must be we have unmet prerequisites (debug:print 4 "FAILS: " fails) @@ -403,18 +404,20 @@ ;; we made new tal by sticking hed at the back of the list (loop (car newtal)(cdr newtal) reruns)) ;; the waiton is FAIL so no point in trying to run hed ever again (if (not (null? tal)) (if (vector? hed) - (begin (debug:print 1 "WARN: Dropping test " (db:test-get-testname hed) "/" (db:test-get-item-path hed) - " from the launch list as it has prerequistes that are FAIL") -(runs:shrink-can-run-more-tests-delay) - ;; (thread-sleep! *global-delta*) - (loop (car tal)(cdr tal) (cons hed reruns))) + (begin + (debug:print 1 "WARN: Dropping test " (db:test-get-testname hed) "/" (db:test-get-item-path hed) + " from the launch list as it has prerequistes that are FAIL") + (runs:shrink-can-run-more-tests-delay) ;; DELAY TWEAKER (still needed?) + ;; (thread-sleep! *global-delta*) + (hash-table-set! test-registery (runs:make-full-test-name test-name item-path) 'removed) + (loop (car tal)(cdr tal) (cons hed reruns))) (begin (debug:print 1 "WARN: Test not processed correctly. Could be a race condition in your test implementation? " hed) ;; " as it has prerequistes that are FAIL. (NOTE: hed is not a vector)") -(runs:shrink-can-run-more-tests-delay) + (runs:shrink-can-run-more-tests-delay) ;; DELAY TWEAKER (still needed?) ;; (thread-sleep! (+ 0.01 *global-delta*)) (loop hed tal reruns))))))))) ;; END OF INNER COND ;; case where an items came in as a list been processed ((and (list? items) ;; thus we know our items are already calculated @@ -598,11 +601,11 @@ ;; (set! test-id (open-run-close db:get-test-id db 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) - (open-run-close db:tests-register-test #f run-id test-name item-path) + (cdb:tests-register-test *runremote* run-id test-name item-path) (set! test-id (open-run-close db:get-test-id db 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)))) (set! test-id (db:test-get-id testdat)) (change-directory test-path) @@ -650,10 +653,11 @@ (debug:print 1 "NOTE: Not starting test " new-test-name " as it is state \"" (test:get-state testdat) "\" and status \"" (test:get-status testdat) "\", use -rerun \"" (test:get-status testdat) "\" or -force to override")) ;; NOTE: No longer be checking prerequisites here! Will never get here unless prereqs are ;; already met. + ;; This would be a great place to do the process-fork (if (not (launch-test #f run-id runname test-conf keyvallst test-name test-path itemdat flags)) (begin (print "ERROR: Failed to launch the test. Exiting as soon as possible") (set! *globalexitstatus* 1) ;; (process-signal (current-process-id) signal/kill)))))) @@ -889,25 +893,25 @@ ;; Rollup runs ;;====================================================================== ;; Update the test_meta table for this test (define (runs:update-test_meta db test-name test-conf) - (let ((currrecord (open-run-close db:testmeta-get-record db test-name))) + (let ((currrecord (cdb:remote-run db:testmeta-get-record db test-name))) (if (not currrecord) (begin (set! currrecord (make-vector 10 #f)) - (open-run-close db:testmeta-add-record db test-name))) + (cdb:remote-run db:testmeta-add-record db test-name))) (for-each (lambda (key) (let* ((idx (cadr key)) (fld (car key)) (val (config-lookup test-conf "test_meta" fld))) ;; (debug:print 5 "idx: " idx " fld: " fld " val: " val) (if (and val (not (equal? (vector-ref currrecord idx) val))) (begin (print "Updating " test-name " " fld " to " val) - (open-run-close db:testmeta-update-field db test-name fld val))))) + (cdb:remote-run db:testmeta-update-field db 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))) @@ -924,11 +928,11 @@ ;; This could probably be refactored into one complex query ... (define (runs:rollup-run keys keyvallst runname user) ;; was target, now keyvallst (debug:print 4 "runs:rollup-run, keys: " keys " keyvallst: " keyvallst " :runname " runname " user: " user) (let* ((db #f) ;; (keyvalllst (keys:target->keyval keys target)) - (new-run-id (open-run-close runs:register-run db keys keyvallst runname "new" "n/a" user)) + (new-run-id (cdb:remote-run db:register-run #f keys keyvallst runname "new" "n/a" user)) (prev-tests (open-run-close test:get-matching-previous-test-run-records db new-run-id "%" "%")) (curr-tests (open-run-close db:get-tests-for-run db new-run-id "%/%" '() '())) (curr-tests-hash (make-hash-table))) (open-run-close db:update-run-event_time db new-run-id) ;; index the already saved tests by testname and itemdat in curr-tests-hash Index: server.scm ================================================================== --- server.scm +++ server.scm @@ -8,11 +8,12 @@ ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. (require-extension (srfi 18) extras tcp s11n) -(use srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest zmq) +(use srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest) +;; (use zmq) (use spiffy uri-common intarweb http-client spiffy-request-vars) (declare (unit server)) @@ -19,11 +20,11 @@ (declare (uses common)) (declare (uses db)) (declare (uses tasks)) ;; tasks are where stuff is maintained about what is running. (declare (uses synchash)) (declare (uses http-transport)) -(declare (uses zmq-transport)) +;; (declare (uses zmq-transport)) (declare (uses daemon)) (include "common_records.scm") (include "db_records.scm") Index: tasks.scm ================================================================== --- tasks.scm +++ tasks.scm @@ -26,11 +26,11 @@ (let* ((dbpath (conc *toppath* "/monitor.db")) (exists (file-exists? dbpath)) (mdb (sqlite3:open-database dbpath)) ;; (never-give-up-open-db dbpath)) (handler (make-busy-timeout 36000))) (sqlite3:set-busy-handler! mdb handler) - (sqlite3:execute mdb (conc "PRAGMA synchronous = 0;")) + (sqlite3:execute mdb (conc "PRAGMA synchronous = 1;")) (if (not exists) (begin (sqlite3:execute mdb "CREATE TABLE IF NOT EXISTS tasks_queue (id INTEGER PRIMARY KEY, action TEXT DEFAULT '', owner TEXT, @@ -141,10 +141,11 @@ "SELECT id FROM servers WHERE pid=-999;"))) (if hostname hostname iface)(if pid pid port)) res)) (define (tasks:server-update-heartbeat mdb server-id) + (debug:print-info 0 "Heart beat update of server id=" server-id) (sqlite3:execute mdb "UPDATE servers SET heartbeat=strftime('%s','now') WHERE id=?;" server-id)) ;; alive servers keep the heartbeat field upto date with seconds every 6 or so seconds (define (tasks:server-alive? mdb server-id #!key (iface #f)(hostname #f)(port #f)(pid #f)) (let* ((server-id (if server-id Index: tests.scm ================================================================== --- tests.scm +++ tests.scm @@ -234,11 +234,11 @@ (pop-directory) result))) ;; Do not rpc this one, do the underlying calls!!! -(define (tests:test-set-status! test-id state status comment dat) +(define (tests:test-set-status! test-id state status comment dat #!key (work-area #f)) (debug:print-info 4 "tests:test-set-status! test-id=" test-id ", state=" state ", status=" status ", dat=" dat) (let* ((db #f) (real-status status) (otherdat (if dat dat (make-hash-table))) (testdat (cdb:get-test-info-by-id *runremote* test-id)) @@ -280,11 +280,11 @@ (cdb:test-set-status-state *runremote* test-id real-status state (if waived waived comment))) ;; if status is "AUTO" then call rollup (note, this one modifies data in test ;; run area, it does remote calls under the hood. (if (and test-id state status (equal? status "AUTO")) - (db:test-data-rollup #f test-id status)) + (db:test-data-rollup #f test-id status work-area: work-area)) ;; add metadata (need to do this way to avoid SQL injection issues) ;; :first_err ;; (let ((val (hash-table-ref/default otherdat ":first_err" #f))) @@ -314,11 +314,12 @@ expected "," tol "," units "," dcomment ",," ;; extra comma for status type ))) - (cdb:remote-run db:csv->test-data #f test-id + ;; This was run remote, don't think that makes sense. + (db:csv->test-data #f test-id dat)))) ;; need to update the top test record if PASS or FAIL and this is a subtest (if (not (equal? item-path "")) (cdb:roll-up-pass-fail-counts *runremote* run-id test-name item-path status)) @@ -632,32 +633,41 @@ tdb "SELECT count(id) FROM test_rundat;") res)) 0) -(define (db:update-central-meta-info db test-id cpuload diskfree minutes num-records uname hostname) - (sqlite3:execute db "UPDATE tests SET cpuload=?,diskfree=? WHERE id=?;" - cpuload - diskfree - test-id) - (if minutes (sqlite3:execute db "UPDATE tests SET run_duration=? WHERE id=?;" minutes test-id)) - (if (eq? num-records 0) - (sqlite3:execute db "UPDATE tests SET uname=?,host=? WHERE id=?;" - uname hostname test-id))) - -(define (test-set-meta-info db test-id run-id testname itemdat minutes) +(define (tests:update-central-meta-info test-id cpuload diskfree minutes num-records uname hostname) + ;; This is a good candidate for threading the requests to enable + ;; transactionized write at the server + (cdb:tests-update-cpuload-diskfree *runremote* test-id cpuload diskfree) + ;; (let ((db (open-db))) + ;; (sqlite3:execute db "UPDATE tests SET cpuload=?,diskfree=? WHERE id=?;" + ;; cpuload + ;; diskfree + ;; test-id) + (if minutes + (cdb:tests-update-run-duration *runremote* test-id minutes)) + ;; (sqlite3:execute db "UPDATE tests SET run_duration=? WHERE id=?;" minutes test-id)) + (if (eq? num-records 0) + (cdb:tests-update-uname-host *runremote* test-id uname hostname)) + ;;(sqlite3:execute db "UPDATE tests SET uname=?,host=? WHERE id=?;" uname hostname test-id)) + ;;(sqlite3:finalize! db)) + ) + +(define (tests:set-meta-info db test-id run-id testname itemdat minutes work-area) ;; DOES cdb:remote-run under the hood! - (let* ((tdb (db:open-test-db-by-test-id db test-id)) + (let* ((tdb (db:open-test-db-by-test-id db test-id work-area: work-area)) (num-records (test:tdb-get-rundat-count tdb)) (cpuload (get-cpu-load)) (diskfree (get-df (current-directory)))) (if (eq? (modulo num-records 10) 0) ;; every ten records update central (let ((uname (get-uname "-srvpio")) (hostname (get-host-name))) - (cdb:remote-run db:update-central-meta-info db test-id cpuload diskfree minutes num-records uname hostname))) + (tests:update-central-meta-info test-id cpuload diskfree minutes num-records uname hostname))) (sqlite3:execute tdb "INSERT INTO test_rundat (update_time,cpuload,diskfree,run_duration) VALUES (strftime('%s','now'),?,?,?);" - cpuload diskfree minutes))) + cpuload diskfree minutes) + (sqlite3:finalize! tdb))) ;;====================================================================== ;; A R C H I V I N G ;;====================================================================== Index: tests/Makefile ================================================================== --- tests/Makefile +++ tests/Makefile @@ -44,30 +44,32 @@ test3 : fullprep cd fullrun;$(MEGATEST) -runtests runfirst -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_b -debug 10 -test4 : fullprep - cd fullrun;$(MEGATEST) -debug $(DEBUG) -runall -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_b -m "This is a comment specific to a run" -v $(LOGGING) +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) # NOTE: Only one instance can be a server -test5 : fullprep - cd fullrun;sleep 0;$(MEGATEST) -runtests % -target $(TARGET) :runname $(RUNNAME)_aa -debug $(DEBUG) $(LOGGING) > aa.log 2> aa.log & - cd fullrun;sleep 10;$(MEGATEST) -runtests % -target $(TARGET) :runname $(RUNNAME)_ab -debug $(DEBUG) $(LOGGING) > ab.log 2> ab.log & - cd fullrun;sleep 10;$(MEGATEST) -runtests % -target $(TARGET) :runname $(RUNNAME)_ac -debug $(DEBUG) $(LOGGING) > ac.log 2> ac.log & - cd fullrun;sleep 10;$(MEGATEST) -runtests % -target $(TARGET) :runname $(RUNNAME)_ad -debug $(DEBUG) $(LOGGING) > ad.log 2> ad.log & -# cd fullrun;sleep 10;$(MEGATEST) -runtests % -target $(TARGET) :runname $(RUNNAME)_ae -debug $(DEBUG) $(LOGGING) > ae.log 2> ae.log & -# cd fullrun;sleep 10;$(MEGATEST) -runtests % -target $(TARGET) :runname $(RUNNAME)_af -debug $(DEBUG) $(LOGGING) > af.log 2> af.log & +test5 : cleanprep + @echo "WARNING: No longer running fullprep, test converage may be lessened" + cd fullrun;sleep 0;$(MEGATEST) -runtests % -target $(TARGET) :runname $(RUNNAME)_aa -debug $(DEBUG) $(LOGGING) > aa.log 2> aa.log & + cd fullrun;sleep 0;$(MEGATEST) -runtests % -target $(TARGET) :runname $(RUNNAME)_ab -debug $(DEBUG) $(LOGGING) > ab.log 2> ab.log & + cd fullrun;sleep 0;$(MEGATEST) -runtests % -target $(TARGET) :runname $(RUNNAME)_ac -debug $(DEBUG) $(LOGGING) > ac.log 2> ac.log & + cd fullrun;sleep 0;$(MEGATEST) -runtests % -target $(TARGET) :runname $(RUNNAME)_ad -debug $(DEBUG) $(LOGGING) > ad.log 2> ad.log & +# cd fullrun;sleep 0;$(MEGATEST) -runtests % -target $(TARGET) :runname $(RUNNAME)_ae -debug $(DEBUG) $(LOGGING) > ae.log 2> ae.log & +# cd fullrun;sleep 0;$(MEGATEST) -runtests % -target $(TARGET) :runname $(RUNNAME)_af -debug $(DEBUG) $(LOGGING) > af.log 2> af.log & test6: fullprep cd fullrun;$(MEGATEST) -runtests runfirst -testpatt %/1 -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_itempatt -v cd fullrun;$(MEGATEST) -runtests runfirst -testpatt %blahha% -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_itempatt -debug 10 cd fullrun;$(MEGATEST) -rollup :runname newrun -target ubuntu/nfs/none -debug 10 cleanprep : ../*.scm Makefile */*.config - mkdir -p /tmp/mt_runs /tmp/mt_links + mkdir -p fullrun/tmp/mt_runs fullrun/tmp/mt_links cd ..;make;make install rm -f */logging.db touch cleanprep fullprep : cleanprep Index: tests/fdktestqa/testqa/megatest.config ================================================================== --- tests/fdktestqa/testqa/megatest.config +++ tests/fdktestqa/testqa/megatest.config @@ -1,5 +1,7 @@ [setup] -testcopycmd cp --remove-destination -rlv TEST_SRC_PATH/. TEST_TARG_PATH/. +testcopycmd cp --remove-destination -rlv TEST_SRC_PATH/. TEST_TARG_PATH/. >> TEST_TARG_PATH/mt_launch.log 2>> TEST_TARG_PATH/mt_launch.log [include ../fdk.config] +[server] +timeout 0.01 ADDED tests/fdktestqa/testqa/runsuite.sh Index: tests/fdktestqa/testqa/runsuite.sh ================================================================== --- /dev/null +++ tests/fdktestqa/testqa/runsuite.sh @@ -0,0 +1,18 @@ +#!/bin/bash + +(cd ../../..;make && make install) || exit 1 +export PATH=$PWD/../../../bin:$PATH + +for i in a b c d e f;do + # g h i j k l m n o p q r s t u v w x y z;do + megatest -runtests % -target a/b :runname $i & +done + +echo "" > num-running.log +while true; do + foo=`megatest -list-runs % | grep RUNNING | wc -l` + echo "Num running at `date` $foo" + echo "$foo at `date`" >> num-running.log + # to make the test go at a reasonable clip only gather this info ever minute + sleep 1m +done Index: tests/fdktestqa/testqa/tests/bigrun/step1.sh ================================================================== --- tests/fdktestqa/testqa/tests/bigrun/step1.sh +++ tests/fdktestqa/testqa/tests/bigrun/step1.sh @@ -1,3 +1,8 @@ #!/bin/sh -sleep 10 +if [ $NUMBER -lt 200 ];then + sleep $NUMBER +else + sleep 200 +fi + exit 0 Index: tests/fdktestqa/testqa/tests/bigrun/testconfig ================================================================== --- tests/fdktestqa/testqa/tests/bigrun/testconfig +++ tests/fdktestqa/testqa/tests/bigrun/testconfig @@ -7,11 +7,11 @@ # waiton setup priority 0 # Iteration for your tests are controlled by the items section [items] -NUMBER #{scheme (string-intersperse (map number->string (sort (let loop ((a 0)(res '()))(if (< a 120)(loop (+ a 1)(cons a res)) res)) >)) " ")} +NUMBER #{scheme (string-intersperse (map number->string (sort (let loop ((a 0)(res '()))(if (< a 150)(loop (+ a 1)(cons a res)) res)) >)) " ")} # test_meta is a section for storing additional data on your test [test_meta] author matt owner matt ADDED tests/fdktestqa/testqa/tests/bigrun2/step1.sh Index: tests/fdktestqa/testqa/tests/bigrun2/step1.sh ================================================================== --- /dev/null +++ tests/fdktestqa/testqa/tests/bigrun2/step1.sh @@ -0,0 +1,7 @@ +#!/bin/sh +prev_test=`$MT_MEGATEST -test-paths -target $MT_TARGET :runname $MT_RUNNAME -testpatt bigrun/$NUMBER` +if [ -e $prev_test/testconfig ]; then + exit 0 +else + exit 1 +fi ADDED tests/fdktestqa/testqa/tests/bigrun2/testconfig Index: tests/fdktestqa/testqa/tests/bigrun2/testconfig ================================================================== --- /dev/null +++ tests/fdktestqa/testqa/tests/bigrun2/testconfig @@ -0,0 +1,22 @@ +# Add additional steps here. Format is "stepname script" +[ezsteps] +step1 step1.sh + +# Test requirements are specified here +[requirements] +waiton bigrun +priority 0 +mode itemmatch + + +# Iteration for your tests are controlled by the items section +[items] +NUMBER #{scheme (string-intersperse (map number->string (sort (let loop ((a 0)(res '()))(if (< a 150)(loop (+ a 1)(cons a res)) res)) >)) " ")} + +# test_meta is a section for storing additional data on your test +[test_meta] +author matt +owner matt +description An example test +tags tagone,tagtwo +reviewed never ADDED tests/fslsync/megatest.config Index: tests/fslsync/megatest.config ================================================================== --- /dev/null +++ tests/fslsync/megatest.config @@ -0,0 +1,20 @@ +[fields] +YEAR TEXT +WEEKNUM TEXT +DAY TEXT + +[setup] +# Adjust max_concurrent_jobs to limit how much you load your machines +max_concurrent_jobs 50 + +# This is your link path, you can move it but it is generally better to keep it stable +linktree #{shell readlink -f #{getenv MT_RUN_AREA_HOME}/fslsynclinks} + +# Job tools are more advanced ways to control how your jobs are launched +[jobtools] +useshell yes +launcher nbfind + +# As you run more tests you may need to add additional disks, the names are arbitrary but must be unique +[disks] +disk0 #{shell readlink -f #{getenv MT_RUN_AREA_HOME}/fslsyncruns} ADDED tests/fslsync/runconfigs.config Index: tests/fslsync/runconfigs.config ================================================================== --- /dev/null +++ tests/fslsync/runconfigs.config @@ -0,0 +1,5 @@ +[default] +WORKAREA /tmp/#{getenv USER}/fslsync +FSLSAREA /tmp/#{getenv USER}/fsls +AREANAMES code data +SITENAMES #{shell cat $MT_RUN_AREA_HOME/sites.dat} ADDED tests/fslsync/sites.dat.template Index: tests/fslsync/sites.dat.template ================================================================== --- /dev/null +++ tests/fslsync/sites.dat.template @@ -0,0 +1,1 @@ +site1 ADDED tests/fslsync/tests/setup/mkdirs.logpro Index: tests/fslsync/tests/setup/mkdirs.logpro ================================================================== --- /dev/null +++ tests/fslsync/tests/setup/mkdirs.logpro @@ -0,0 +1,8 @@ +;; You should have at least one expect:required. This ensures that your process ran +(expect:required in "LogFileBody" > 0 "done" #/done/) + +;; You may need ignores to suppress false error or warning hits from the later expects +;; NOTE: Order is important here! +(expect:ignore in "LogFileBody" < 99 "Ignore the word error in comments" #/^\/\/.*error/) +(expect:warning in "LogFileBody" = 0 "Any warning" #/warn/) +(expect:error in "LogFileBody" = 0 "Any error" (list #/ERROR/ #/error/)) ;; but disallow any other errors ADDED tests/fslsync/tests/setup/mkdirs.sh Index: tests/fslsync/tests/setup/mkdirs.sh ================================================================== --- /dev/null +++ tests/fslsync/tests/setup/mkdirs.sh @@ -0,0 +1,11 @@ +#!/usr/bin/env bash + +# Create needed directories both local and remote + +# Remote +ssh $SITENAME mkdir -vp $WORKAREA/$SITENAME/$AREANAME + +# Local +mkdir -vp $WORKAREA/$SITENAME/$AREANAME + +echo done ADDED tests/fslsync/tests/setup/seedcache.logpro Index: tests/fslsync/tests/setup/seedcache.logpro ================================================================== --- /dev/null +++ tests/fslsync/tests/setup/seedcache.logpro @@ -0,0 +1,8 @@ +;; You should have at least one expect:required. This ensures that your process ran +(expect:required in "LogFileBody" > 0 "done" #/done/) + +;; You may need ignores to suppress false error or warning hits from the later expects +;; NOTE: Order is important here! +(expect:ignore in "LogFileBody" < 99 "Ignore the word error in comments" #/^\/\/.*error/) +(expect:warning in "LogFileBody" = 0 "Any warning" #/warn/) +(expect:error in "LogFileBody" = 0 "Any error" (list #/ERROR/ #/error/)) ;; but disallow any other errors ADDED tests/fslsync/tests/setup/seedcache.sh Index: tests/fslsync/tests/setup/seedcache.sh ================================================================== --- /dev/null +++ tests/fslsync/tests/setup/seedcache.sh @@ -0,0 +1,6 @@ +#!/usr/bin/env bash + +# Copy any non-existant files to the cache before doing the rsync +# in the hopes of saving some time. + +echo done ADDED tests/fslsync/tests/setup/testconfig Index: tests/fslsync/tests/setup/testconfig ================================================================== --- /dev/null +++ tests/fslsync/tests/setup/testconfig @@ -0,0 +1,21 @@ +# Add additional steps here. Format is "stepname script" +[ezsteps] +mkdirs mkdirs.sh +seedcache seedcache.sh + +# Test requirements are specified here +[requirements] +priority 0 + +# Iteration for your tests are controlled by the items section +[items] +AREANAME #{getenv AREANAMES} +SITENAME #{getenv SITENAMES} + +# test_meta is a section for storing additional data on your test +[test_meta] +author matt +owner matt +description Setup needed directories and seed the caches +tags tagone,tagtwo +reviewed never ADDED tests/fslsync/tests/sync/fsync.logpro Index: tests/fslsync/tests/sync/fsync.logpro ================================================================== --- /dev/null +++ tests/fslsync/tests/sync/fsync.logpro @@ -0,0 +1,8 @@ +;; You should have at least one expect:required. This ensures that your process ran +(expect:required in "LogFileBody" > 0 "done" #/done/) + +;; You may need ignores to suppress false error or warning hits from the later expects +;; NOTE: Order is important here! +(expect:ignore in "LogFileBody" < 99 "Ignore the word error in comments" #/^\/\/.*error/) +(expect:warning in "LogFileBody" = 0 "Any warning" #/warn/) +(expect:error in "LogFileBody" = 0 "Any error" (list #/ERROR/ #/error/)) ;; but disallow any other errors ADDED tests/fslsync/tests/sync/fsync.sh Index: tests/fslsync/tests/sync/fsync.sh ================================================================== --- /dev/null +++ tests/fslsync/tests/sync/fsync.sh @@ -0,0 +1,33 @@ +#!/usr/bin/env bash + +# Get the list of fossils from the cache + +FILES=$(ls $FSLSAREA/$AREANAME|grep fossil) + +# Do the remote sync from CACHE to FOSSILS +ssh $SITENAME /bin/bash < 0 "done" #/done/) + +;; You may need ignores to suppress false error or warning hits from the later expects +;; NOTE: Order is important here! +(expect:ignore in "LogFileBody" < 99 "Ignore the word error in comments" #/^\/\/.*error/) +(expect:warning in "LogFileBody" = 0 "Any warning" #/warn/) +(expect:error in "LogFileBody" = 0 "Any error" (list #/ERROR/ #/error/)) ;; but disallow any other errors ADDED tests/fslsync/tests/sync/rsync.sh Index: tests/fslsync/tests/sync/rsync.sh ================================================================== --- /dev/null +++ tests/fslsync/tests/sync/rsync.sh @@ -0,0 +1,11 @@ +#!/usr/bin/env bash + +# Sync to remote cache +rsync -avz $FSLSAREA/$AREANAME/ $SITENAME:$WORKAREA/$SITENAME/$AREANAME/ & +# Sync to local cache +rsync -avz $SITENAME:$FSLSAREA/$AREANAME/ $WORKAREA/$SITENAME/$AREANAME/ & + +# Wait until rsyncs complete +wait + +echo done ADDED tests/fslsync/tests/sync/testconfig Index: tests/fslsync/tests/sync/testconfig ================================================================== --- /dev/null +++ tests/fslsync/tests/sync/testconfig @@ -0,0 +1,22 @@ +# Add additional steps here. Format is "stepname script" +[ezsteps] +rsync rsync.sh +fsync fsync.sh + +# Test requirements are specified here +[requirements] +waiton setup +priority 0 + +# Iteration for your tests are controlled by the items section +[items] +AREANAME #{getenv AREANAMES} +SITENAME #{getenv SITENAMES} + +# test_meta is a section for storing additional data on your test +[test_meta] +author matt +owner matt +description Sync fossils to remote +tags tagone,tagtwo +reviewed never Index: tests/fullrun/config/mt_include_1.config ================================================================== --- tests/fullrun/config/mt_include_1.config +++ tests/fullrun/config/mt_include_1.config @@ -1,8 +1,8 @@ [setup] # exectutable /path/to/megatest -max_concurrent_jobs 200 +max_concurrent_jobs 150 linktree #{getenv MT_RUN_AREA_HOME}/tmp/mt_links [jobtools] useshell yes Index: tests/fullrun/megatest.config ================================================================== --- tests/fullrun/megatest.config +++ tests/fullrun/megatest.config @@ -9,16 +9,20 @@ area1 /tmp/oldarea/megatest [include config/mt_include_1.config] [setup] +# Set launchwait to yes to use the old launch run code that waits for the launch process to return before +# proceeding. +# launchwait yes + # 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/. +testcopycmd cp --remove-destination -rsv TEST_SRC_PATH/. TEST_TARG_PATH/. >> TEST_TARG_PATH/mt_launch.log 2>> TEST_TARG_PATH/mt_launch.log # or for hard links # testcopycmd cp --remove-destination -rlv TEST_SRC_PATH/. TEST_TARG_PATH/. ADDED utils/example-launch-dispatcher.scm Index: utils/example-launch-dispatcher.scm ================================================================== --- /dev/null +++ utils/example-launch-dispatcher.scm @@ -0,0 +1,12 @@ + +(let ((target (assoc + ;; Put the variable name here, note: only *one* ' + ;; 'TARGET_OS + 'MANYITEMS + (read (open-input-string (get-environment-variable "MT_ITEM_INFO")))))) + (case (if target target 'var-undef) + ((suse) (system "echo suse-launcher.pl")) + ((redhat) (system "echo red-hat-launcher.pl")) + ((af) (system "echo Got af")) + ((var-undef) (system "echo Variable not in MT_ITEM_INFO list")) + (else (system "echo normal-launcher.pl")))) Index: utils/installall.sh ================================================================== --- utils/installall.sh +++ utils/installall.sh @@ -164,137 +164,137 @@ # CSC_OPTIONS="-I$PREFIX/include -L$CSCLIBS" $CHICKEN_INSTALL $PROX -D no-library-checks -feature disable-iup-web -deploy -prefix $DEPLOYTARG iup # iup:1.0.2 CSC_OPTIONS="-I$PREFIX/include -L$CSCLIBS" $CHICKEN_INSTALL $PROX -D no-library-checks canvas-draw # CSC_OPTIONS="-I$PREFIX/include -L$CSCLIBS" $CHICKEN_INSTALL $PROX -D no-library-checks -deploy -prefix $DEPLOYTARG canvas-draw -#====================================================================== -# Note uuid needed only for zmq 2.x series -#====================================================================== - -# http://download.zeromq.org/zeromq-3.2.1-rc2.tar.gz -# zpatchlev=-rc2 -# http://download.zeromq.org/zeromq-2.2.0.tar.gz - -if [[ -e /usr/lib/libzmq.so ]]; then - echo "Using system installed zmq library" - $CHICKEN_INSTALL zmq -else -ZEROMQ=zeromq-2.2.0 -# ZEROMQ=zeromq-3.2.2 - -# wget http://www.kernel.org/pub/linux/utils/util-linux/v2.22/util-linux-2.22.tar.gz -UTIL_LINUX=2.21 -# UTIL_LINUX=2.20.1 -if ! [[ -e util-linux-${UTIL_LINUX}.tar.gz ]] ; then - # wget http://www.kiatoa.com/matt/util-linux-2.20.1.tar.gz - wget http://www.kernel.org/pub/linux/utils/util-linux/v${UTIL_LINUX}/util-linux-${UTIL_LINUX}.tar.gz -fi - -if [[ -e util-linux-${UTIL_LINUX}.tar.gz ]] ; then - tar xfz util-linux-${UTIL_LINUX}.tar.gz - cd util-linux-${UTIL_LINUX} - mkdir -p build - cd build - if [[ $UTIL_LINUX = "2.22" ]] ; then - ../configure --prefix=$PREFIX \ ---enable-shared \ ---disable-use-tty-group \ ---disable-makeinstall-chown \ ---disable-makeinstall-setuid \ ---disable-libtool-lock \ ---disable-login \ ---disable-sulogin \ ---disable-su \ ---disable-schedutils \ ---disable-libmount \ ---disable-mount \ ---disable-losetup \ ---disable-fsck \ ---disable-partx \ ---disable-mountpoint \ ---disable-fallocate \ ---disable-unshare \ ---disable-eject \ ---disable-agetty \ ---disable-cramfs \ ---disable-switch_root \ ---disable-pivot_root \ ---disable-kill \ ---disable-libblkid \ ---disable-utmpdump \ ---disable-rename \ ---disable-chsh-only-listed \ ---disable-wall \ ---disable-pg-bell \ ---disable-require-password \ ---disable-libtool-lock \ ---disable-nls \ ---disable-dmesg \ ---without-ncurses - else - ../configure --prefix=$PREFIX \ - --enable-shared \ - --disable-mount \ - --disable-fsck \ - --disable-partx \ - --disable-largefile \ - --disable-tls \ - --disable-libmount \ - --disable-mountpoint \ - --disable-nls \ - --disable-rpath \ - --disable-agetty \ - --disable-cramfs \ - --disable-switch_root \ - --disable-pivot_root \ - --disable-fallocate \ - --disable-unshare \ - --disable-rename \ - --disable-schedutils \ - --disable-libblkid \ - --disable-wall CFLAGS='-fPIC' - -# --disable-makeinstall-chown \ -# --disable-makeinstall-setuid \ - -# --disable-chsh-only-listed -# --disable-pg-bell let pg not ring the bell on invalid keys -# --disable-require-password -# --disable-use-tty-group do not install wall and write setgid tty -# --disable-makeinstall-chown -# --disable-makeinstall-setuid - fi - - (cd libuuid;make install) - # make - # make install - cp $PREFIX/include/uuid/uuid.h $PREFIX/include/uuid.h -fi - - -cd $BUILDHOME - -if ! [[ -e ${ZEROMQ}${zpatchlev}.tar.gz ]] ; then - wget http://download.zeromq.org/${ZEROMQ}${zpatchlev}.tar.gz -fi - -if [[ -e ${ZEROMQ}${zpatchlev}.tar.gz ]] ; then - tar xfz ${ZEROMQ}.tar.gz - cd ${ZEROMQ} - ln -s $PREFIX/include/uuid src - # LDFLAGS=-L$PREFIX/lib ./configure --prefix=$PREFIX - - ./configure --enable-static --prefix=$PREFIX --with-uuid=$PREFIX LDFLAGS="-L$PREFIX/lib" CPPFLAGS="-fPIC -I$PREFIX/include" LIBS="-lgcc" - # --disable-shared CPPFLAGS="-fPIC - # LDFLAGS="-L/usr/lib64 -L$PREFIX/lib" ./configure --enable-static --prefix=$PREFIX - make - make install - CSC_OPTIONS="-I$PREFIX/include -L$CSCLIBS" $CHICKEN_INSTALL $PROX zmq - # CSC_OPTIONS="-I$PREFIX/include -L$CSCLIBS" $CHICKEN_INSTALL $PROX -deploy -prefix $DEPLOYTARG zmq -fi -fi # if zmq is in /usr/lib - +# disabled zmq # #====================================================================== +# disabled zmq # # Note uuid needed only for zmq 2.x series +# disabled zmq # #====================================================================== +# disabled zmq # +# disabled zmq # # http://download.zeromq.org/zeromq-3.2.1-rc2.tar.gz +# disabled zmq # # zpatchlev=-rc2 +# disabled zmq # # http://download.zeromq.org/zeromq-2.2.0.tar.gz +# disabled zmq # +# disabled zmq # if [[ -e /usr/lib/libzmq.so ]]; then +# disabled zmq # echo "Using system installed zmq library" +# disabled zmq # $CHICKEN_INSTALL zmq +# disabled zmq # else +# disabled zmq # ZEROMQ=zeromq-2.2.0 +# disabled zmq # # ZEROMQ=zeromq-3.2.2 +# disabled zmq # +# disabled zmq # # wget http://www.kernel.org/pub/linux/utils/util-linux/v2.22/util-linux-2.22.tar.gz +# disabled zmq # UTIL_LINUX=2.21 +# disabled zmq # # UTIL_LINUX=2.20.1 +# disabled zmq # if ! [[ -e util-linux-${UTIL_LINUX}.tar.gz ]] ; then +# disabled zmq # # wget http://www.kiatoa.com/matt/util-linux-2.20.1.tar.gz +# disabled zmq # wget http://www.kernel.org/pub/linux/utils/util-linux/v${UTIL_LINUX}/util-linux-${UTIL_LINUX}.tar.gz +# disabled zmq # fi +# disabled zmq # +# disabled zmq # if [[ -e util-linux-${UTIL_LINUX}.tar.gz ]] ; then +# disabled zmq # tar xfz util-linux-${UTIL_LINUX}.tar.gz +# disabled zmq # cd util-linux-${UTIL_LINUX} +# disabled zmq # mkdir -p build +# disabled zmq # cd build +# disabled zmq # if [[ $UTIL_LINUX = "2.22" ]] ; then +# disabled zmq # ../configure --prefix=$PREFIX \ +# disabled zmq # --enable-shared \ +# disabled zmq # --disable-use-tty-group \ +# disabled zmq # --disable-makeinstall-chown \ +# disabled zmq # --disable-makeinstall-setuid \ +# disabled zmq # --disable-libtool-lock \ +# disabled zmq # --disable-login \ +# disabled zmq # --disable-sulogin \ +# disabled zmq # --disable-su \ +# disabled zmq # --disable-schedutils \ +# disabled zmq # --disable-libmount \ +# disabled zmq # --disable-mount \ +# disabled zmq # --disable-losetup \ +# disabled zmq # --disable-fsck \ +# disabled zmq # --disable-partx \ +# disabled zmq # --disable-mountpoint \ +# disabled zmq # --disable-fallocate \ +# disabled zmq # --disable-unshare \ +# disabled zmq # --disable-eject \ +# disabled zmq # --disable-agetty \ +# disabled zmq # --disable-cramfs \ +# disabled zmq # --disable-switch_root \ +# disabled zmq # --disable-pivot_root \ +# disabled zmq # --disable-kill \ +# disabled zmq # --disable-libblkid \ +# disabled zmq # --disable-utmpdump \ +# disabled zmq # --disable-rename \ +# disabled zmq # --disable-chsh-only-listed \ +# disabled zmq # --disable-wall \ +# disabled zmq # --disable-pg-bell \ +# disabled zmq # --disable-require-password \ +# disabled zmq # --disable-libtool-lock \ +# disabled zmq # --disable-nls \ +# disabled zmq # --disable-dmesg \ +# disabled zmq # --without-ncurses +# disabled zmq # else +# disabled zmq # ../configure --prefix=$PREFIX \ +# disabled zmq # --enable-shared \ +# disabled zmq # --disable-mount \ +# disabled zmq # --disable-fsck \ +# disabled zmq # --disable-partx \ +# disabled zmq # --disable-largefile \ +# disabled zmq # --disable-tls \ +# disabled zmq # --disable-libmount \ +# disabled zmq # --disable-mountpoint \ +# disabled zmq # --disable-nls \ +# disabled zmq # --disable-rpath \ +# disabled zmq # --disable-agetty \ +# disabled zmq # --disable-cramfs \ +# disabled zmq # --disable-switch_root \ +# disabled zmq # --disable-pivot_root \ +# disabled zmq # --disable-fallocate \ +# disabled zmq # --disable-unshare \ +# disabled zmq # --disable-rename \ +# disabled zmq # --disable-schedutils \ +# disabled zmq # --disable-libblkid \ +# disabled zmq # --disable-wall CFLAGS='-fPIC' +# disabled zmq # +# disabled zmq # # --disable-makeinstall-chown \ +# disabled zmq # # --disable-makeinstall-setuid \ +# disabled zmq # +# disabled zmq # # --disable-chsh-only-listed +# disabled zmq # # --disable-pg-bell let pg not ring the bell on invalid keys +# disabled zmq # # --disable-require-password +# disabled zmq # # --disable-use-tty-group do not install wall and write setgid tty +# disabled zmq # # --disable-makeinstall-chown +# disabled zmq # # --disable-makeinstall-setuid +# disabled zmq # fi +# disabled zmq # +# disabled zmq # (cd libuuid;make install) +# disabled zmq # # make +# disabled zmq # # make install +# disabled zmq # cp $PREFIX/include/uuid/uuid.h $PREFIX/include/uuid.h +# disabled zmq # fi +# disabled zmq # +# disabled zmq # +# disabled zmq # cd $BUILDHOME +# disabled zmq # +# disabled zmq # if ! [[ -e ${ZEROMQ}${zpatchlev}.tar.gz ]] ; then +# disabled zmq # wget http://download.zeromq.org/${ZEROMQ}${zpatchlev}.tar.gz +# disabled zmq # fi +# disabled zmq # +# disabled zmq # if [[ -e ${ZEROMQ}${zpatchlev}.tar.gz ]] ; then +# disabled zmq # tar xfz ${ZEROMQ}.tar.gz +# disabled zmq # cd ${ZEROMQ} +# disabled zmq # ln -s $PREFIX/include/uuid src +# disabled zmq # # LDFLAGS=-L$PREFIX/lib ./configure --prefix=$PREFIX +# disabled zmq # +# disabled zmq # ./configure --enable-static --prefix=$PREFIX --with-uuid=$PREFIX LDFLAGS="-L$PREFIX/lib" CPPFLAGS="-fPIC -I$PREFIX/include" LIBS="-lgcc" +# disabled zmq # # --disable-shared CPPFLAGS="-fPIC +# disabled zmq # # LDFLAGS="-L/usr/lib64 -L$PREFIX/lib" ./configure --enable-static --prefix=$PREFIX +# disabled zmq # make +# disabled zmq # make install +# disabled zmq # CSC_OPTIONS="-I$PREFIX/include -L$CSCLIBS" $CHICKEN_INSTALL $PROX zmq +# disabled zmq # # CSC_OPTIONS="-I$PREFIX/include -L$CSCLIBS" $CHICKEN_INSTALL $PROX -deploy -prefix $DEPLOYTARG zmq +# disabled zmq # fi +# disabled zmq # fi # if zmq is in /usr/lib +# disabled zmq # cd $BUILDHOME ## WEBKIT=WebKit-r131972 ## if ! [[ -e ${WEBKIT}.tar.bz2 ]] ; then ## # http://builds.nightly.webkit.org/files/trunk/src/WebKit-r131972.tar.bz2 Index: utils/mk_wrapper ================================================================== --- utils/mk_wrapper +++ utils/mk_wrapper @@ -3,11 +3,14 @@ prefix=$1 cmd=$2 echo "#!/bin/bash" if [ "$LD_LIBRARY_PATH" != "" ];then + echo "INFO: Using LD_LIBRARY_PATH=$LD_LIBRARY_PATH" >&2 echo "export LD_LIBRARY_PATH=$LD_LIBRARY_PATH" +else + echo "INFO: LD_LIBRARY_PATH not set" >&2 fi fullcmd="$prefix/bin/$cmd" echo "$fullcmd \"\$@\""