ae6dbecf17 2011-05-02 matt: ae6dbecf17 2011-05-02 matt: ;; Copyright 2006-2011, Matthew Welland. ae6dbecf17 2011-05-02 matt: ;; ae6dbecf17 2011-05-02 matt: ;; This program is made available under the GNU GPL version 2.0 or ae6dbecf17 2011-05-02 matt: ;; greater. See the accompanying file COPYING for details. ae6dbecf17 2011-05-02 matt: ;; ae6dbecf17 2011-05-02 matt: ;; This program is distributed WITHOUT ANY WARRANTY; without even the ae6dbecf17 2011-05-02 matt: ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ae6dbecf17 2011-05-02 matt: ;; PURPOSE. ae6dbecf17 2011-05-02 matt: ae6dbecf17 2011-05-02 matt: ;; strftime('%m/%d/%Y %H:%M:%S','now','localtime') ae6dbecf17 2011-05-02 matt: ae6dbecf17 2011-05-02 matt: ;; register a test run with the db ae6dbecf17 2011-05-02 matt: (define (register-run db keys) ;; test-name) ae6dbecf17 2011-05-02 matt: (let* ((keystr (keys->keystr keys)) ae6dbecf17 2011-05-02 matt: (comma (if (> (length keys) 0) "," "")) ae6dbecf17 2011-05-02 matt: (andstr (if (> (length keys) 0) " AND " "")) ae6dbecf17 2011-05-02 matt: (valslots (keys->valslots keys)) ;; ?,?,? ... ae6dbecf17 2011-05-02 matt: (keyvallst (keys->vallist keys)) ae6dbecf17 2011-05-02 matt: (runname (get-with-default ":runname" #f)) ae6dbecf17 2011-05-02 matt: (state (get-with-default ":state" "no")) ae6dbecf17 2011-05-02 matt: (status (get-with-default ":status" "n/a")) ae6dbecf17 2011-05-02 matt: (allvals (append (list runname state status user) keyvallst)) ae6dbecf17 2011-05-02 matt: (qryvals (append (list runname) keyvallst)) ae6dbecf17 2011-05-02 matt: (key=?str (string-intersperse (map (lambda (k)(conc (key:get-fieldname k) "=?")) keys) " AND "))) ae6dbecf17 2011-05-02 matt: ;; (print "keys: " keys " allvals: " allvals " keyvallst: " keyvallst) ae6dbecf17 2011-05-02 matt: (print "NOTE: using key " (string-intersperse keyvallst "/") " for this run") ae6dbecf17 2011-05-02 matt: (if (and runname (null? (filter (lambda (x)(not x)) keyvallst))) ;; there must be a better way to "apply and" ae6dbecf17 2011-05-02 matt: (let ((res #f)) ae6dbecf17 2011-05-02 matt: (apply sqlite3:execute db (conc "INSERT OR IGNORE INTO runs (runname,state,status,owner,event_time" comma keystr ") VALUES (?,?,?,?,strftime('%s','now')" comma valslots ");") ae6dbecf17 2011-05-02 matt: allvals) ae6dbecf17 2011-05-02 matt: (apply sqlite3:for-each-row ae6dbecf17 2011-05-02 matt: (lambda (id) ae6dbecf17 2011-05-02 matt: (set! res id)) ae6dbecf17 2011-05-02 matt: db ae6dbecf17 2011-05-02 matt: (let ((qry (conc "SELECT id FROM runs WHERE (runname=? " andstr key=?str ");"))) ae6dbecf17 2011-05-02 matt: ;; (print "qry: " qry) ae6dbecf17 2011-05-02 matt: qry) ae6dbecf17 2011-05-02 matt: qryvals) ae6dbecf17 2011-05-02 matt: (sqlite3:execute db "UPDATE runs SET state=?,status=? WHERE id=?;" state status res) ae6dbecf17 2011-05-02 matt: res) ae6dbecf17 2011-05-02 matt: (begin ae6dbecf17 2011-05-02 matt: (print "ERROR: Called without all necessary keys") ae6dbecf17 2011-05-02 matt: #f)))) ae6dbecf17 2011-05-02 matt: ae6dbecf17 2011-05-02 matt: (define (register-test db run-id test-name item-path) ae6dbecf17 2011-05-02 matt: (sqlite3:execute db "INSERT OR IGNORE INTO tests (run_id,testname,event_time,item_path) VALUES (?,?,strftime('%s','now'),?);" run-id test-name item-path)) ae6dbecf17 2011-05-02 matt: ae6dbecf17 2011-05-02 matt: (define (test-set-status! db run-id test-name state status itemdat-or-path . comment) ae6dbecf17 2011-05-02 matt: (let ((item-path (if (string? itemdat-or-path) itemdat-or-path (item-list->path itemdat-or-path)))) ae6dbecf17 2011-05-02 matt: (sqlite3:execute db "UPDATE tests SET state=?,status=?,event_time=strftime('%s','now') WHERE run_id=? AND testname=? AND item_path=?;" ae6dbecf17 2011-05-02 matt: state status run-id test-name item-path) ae6dbecf17 2011-05-02 matt: (if (and (not (null? comment)) ae6dbecf17 2011-05-02 matt: (car comment)) ae6dbecf17 2011-05-02 matt: (sqlite3:execute db "UPDATE tests SET comment=? WHERE run_id=? AND testname=? AND item_path=?;" ae6dbecf17 2011-05-02 matt: (car comment) run-id test-name item-path)))) ae6dbecf17 2011-05-02 matt: ae6dbecf17 2011-05-02 matt: (define (test-set-log! db run-id test-name itemdat logf) ae6dbecf17 2011-05-02 matt: (let ((item-path (item-list->path itemdat))) ae6dbecf17 2011-05-02 matt: (sqlite3:execute db "UPDATE tests SET final_logf=? WHERE run_id=? AND testname=? AND item_path=?;" ae6dbecf17 2011-05-02 matt: logf run-id test-name item-path))) ae6dbecf17 2011-05-02 matt: 7f668b637d 2011-05-06 mrwellan: ;; ;; TODO: Converge this with db:get-test-info 7f668b637d 2011-05-06 mrwellan: ;; (define (runs:get-test-info db run-id test-name item-path) 7f668b637d 2011-05-06 mrwellan: ;; (let ((res #f)) ;; (vector #f #f #f #f #f #f))) 7f668b637d 2011-05-06 mrwellan: ;; (sqlite3:for-each-row 7f668b637d 2011-05-06 mrwellan: ;; (lambda (id run-id test-name state status) 7f668b637d 2011-05-06 mrwellan: ;; (set! res (vector id run-id test-name state status item-path))) 7f668b637d 2011-05-06 mrwellan: ;; db "SELECT id,run_id,testname,state,status FROM tests WHERE run_id=? AND testname=? AND item_path=?;" 7f668b637d 2011-05-06 mrwellan: ;; run-id test-name item-path) 7f668b637d 2011-05-06 mrwellan: ;; res)) ae6dbecf17 2011-05-02 matt: ae6dbecf17 2011-05-02 matt: (define-inline (test:get-id vec) (vector-ref vec 0)) ae6dbecf17 2011-05-02 matt: (define-inline (test:get-run_id vec) (vector-ref vec 1)) ae6dbecf17 2011-05-02 matt: (define-inline (test:get-test-name vec)(vector-ref vec 2)) ae6dbecf17 2011-05-02 matt: (define-inline (test:get-state vec) (vector-ref vec 3)) ae6dbecf17 2011-05-02 matt: (define-inline (test:get-status vec) (vector-ref vec 4)) ae6dbecf17 2011-05-02 matt: (define-inline (test:get-item-path vec)(vector-ref vec 5)) ae6dbecf17 2011-05-02 matt: ae6dbecf17 2011-05-02 matt: (define (runs:test-get-full-path test) ae6dbecf17 2011-05-02 matt: (let* ((testname (db:test-get-testname test)) ae6dbecf17 2011-05-02 matt: (itempath (db:test-get-item-path test))) ae6dbecf17 2011-05-02 matt: (conc testname (if (equal? itempath "") "" (conc "(" itempath ")"))))) ae6dbecf17 2011-05-02 matt: ae6dbecf17 2011-05-02 matt: (define-inline (test:test-get-fullname test) ae6dbecf17 2011-05-02 matt: (conc (db:test-get-testname test) ae6dbecf17 2011-05-02 matt: (if (equal? (db:test-get-item-path test) "") ae6dbecf17 2011-05-02 matt: "" ae6dbecf17 2011-05-02 matt: (conc "(" (db:test-get-item-path test) ")")))) ae6dbecf17 2011-05-02 matt: ae6dbecf17 2011-05-02 matt: (define (check-valid-items class item) ae6dbecf17 2011-05-02 matt: (let ((valid-values (let ((s (config-lookup *configdat* "validvalues" class))) ae6dbecf17 2011-05-02 matt: (if s (string-split s) #f)))) ae6dbecf17 2011-05-02 matt: (if valid-values ae6dbecf17 2011-05-02 matt: (if (member item valid-values) ae6dbecf17 2011-05-02 matt: item #f) ae6dbecf17 2011-05-02 matt: item))) ae6dbecf17 2011-05-02 matt: 1146144d5b 2011-05-05 matt: (define (teststep-set-status! db run-id test-name teststep-name state-in status-in itemdat comment) ae6dbecf17 2011-05-02 matt: ;; (print "run-id: " run-id " test-name: " test-name) ae6dbecf17 2011-05-02 matt: (let* ((state (check-valid-items "state" state-in)) ae6dbecf17 2011-05-02 matt: (status (check-valid-items "status" status-in)) ae6dbecf17 2011-05-02 matt: (item-path (item-list->path itemdat)) 772558f8b5 2011-05-06 mrwellan: (testdat (db:get-test-info db run-id test-name item-path))) ae6dbecf17 2011-05-02 matt: ;; (print "testdat: " testdat) ae6dbecf17 2011-05-02 matt: (if (and testdat ;; if the section exists then force specification BUG, I don't like how this works. ae6dbecf17 2011-05-02 matt: (or (not state)(not status))) ae6dbecf17 2011-05-02 matt: (print "WARNING: Invalid " (if status "status" "state") ae6dbecf17 2011-05-02 matt: " value \"" (if status status-in state-in) "\", update your validstates section in megatest.config")) ae6dbecf17 2011-05-02 matt: (if testdat ae6dbecf17 2011-05-02 matt: (let ((test-id (test:get-id testdat))) ae6dbecf17 2011-05-02 matt: (sqlite3:execute db 1146144d5b 2011-05-05 matt: "INSERT OR REPLACE into test_steps (test_id,stepname,state,status,event_time,comment) VALUES(?,?,?,?,strftime('%s','now'),?);" 1146144d5b 2011-05-05 matt: test-id teststep-name state status (if comment comment ""))) ae6dbecf17 2011-05-02 matt: (print "ERROR: Can't update " test-name " for run " run-id " -> no such test in db")))) ae6dbecf17 2011-05-02 matt: ae6dbecf17 2011-05-02 matt: (define (test-get-kill-request db run-id test-name itemdat) ae6dbecf17 2011-05-02 matt: (let* ((item-path (item-list->path itemdat)) 772558f8b5 2011-05-06 mrwellan: (testdat (db:get-test-info db run-id test-name item-path))) ae6dbecf17 2011-05-02 matt: (equal? (test:get-state testdat) "KILLREQ"))) ae6dbecf17 2011-05-02 matt: ae6dbecf17 2011-05-02 matt: (define (test-set-meta-info db run-id testname itemdat) ae6dbecf17 2011-05-02 matt: (let ((item-path (item-list->path itemdat)) ae6dbecf17 2011-05-02 matt: (cpuload (get-cpu-load)) ae6dbecf17 2011-05-02 matt: (hostname (get-host-name)) ae6dbecf17 2011-05-02 matt: (diskfree (get-df (current-directory))) ae6dbecf17 2011-05-02 matt: (uname (get-uname "-srvpio")) ae6dbecf17 2011-05-02 matt: (runpath (current-directory))) ae6dbecf17 2011-05-02 matt: (sqlite3:execute db "UPDATE tests SET host=?,cpuload=?,diskfree=?,uname=?,rundir=? WHERE run_id=? AND testname=? AND item_path=?;" ae6dbecf17 2011-05-02 matt: hostname ae6dbecf17 2011-05-02 matt: cpuload ae6dbecf17 2011-05-02 matt: diskfree ae6dbecf17 2011-05-02 matt: uname ae6dbecf17 2011-05-02 matt: runpath ae6dbecf17 2011-05-02 matt: run-id ae6dbecf17 2011-05-02 matt: testname ae6dbecf17 2011-05-02 matt: item-path))) ae6dbecf17 2011-05-02 matt: ae6dbecf17 2011-05-02 matt: (define (test-update-meta-info db run-id testname itemdat minutes) ae6dbecf17 2011-05-02 matt: (let ((item-path (item-list->path itemdat)) ae6dbecf17 2011-05-02 matt: (cpuload (get-cpu-load)) ae6dbecf17 2011-05-02 matt: (diskfree (get-df (current-directory)))) ae6dbecf17 2011-05-02 matt: (if (not cpuload) (begin (print "WARNING: CPULOAD not found.") (set! cpuload "n/a"))) ae6dbecf17 2011-05-02 matt: (if (not diskfree) (begin (print "WARNING: DISKFREE not found.") (set! diskfree "n/a"))) ae6dbecf17 2011-05-02 matt: (if (not item-path)(begin (print "WARNING: ITEMPATH not set.") (set! item-path ""))) ae6dbecf17 2011-05-02 matt: ;; (let ((testinfo (db:get-test-info db run-id testname item-path))) ae6dbecf17 2011-05-02 matt: ;; (if (and (not (equal? (db:test-get-status testinfo) "COMPLETED")) ae6dbecf17 2011-05-02 matt: ;; (not (equal? (db:test-get-status testinfo) "KILLREQ")) ae6dbecf17 2011-05-02 matt: (sqlite3:execute ae6dbecf17 2011-05-02 matt: db ae6dbecf17 2011-05-02 matt: "UPDATE tests SET cpuload=?,diskfree=?,run_duration=?,state='RUNNING' WHERE run_id=? AND testname=? AND item_path=? AND state NOT IN ('COMPLETED','KILLREQ','KILLED');" ae6dbecf17 2011-05-02 matt: cpuload ae6dbecf17 2011-05-02 matt: diskfree ae6dbecf17 2011-05-02 matt: minutes ae6dbecf17 2011-05-02 matt: run-id ae6dbecf17 2011-05-02 matt: testname ae6dbecf17 2011-05-02 matt: item-path))) ae6dbecf17 2011-05-02 matt: ae6dbecf17 2011-05-02 matt: (define (set-megatest-env-vars db run-id) ae6dbecf17 2011-05-02 matt: (let ((keys (db-get-keys db))) ae6dbecf17 2011-05-02 matt: (for-each (lambda (key) ae6dbecf17 2011-05-02 matt: (sqlite3:for-each-row ae6dbecf17 2011-05-02 matt: (lambda (val) ae6dbecf17 2011-05-02 matt: (print "setenv " (key:get-fieldname key) " " val) ae6dbecf17 2011-05-02 matt: (setenv (key:get-fieldname key) val)) ae6dbecf17 2011-05-02 matt: db ae6dbecf17 2011-05-02 matt: (conc "SELECT " (key:get-fieldname key) " FROM runs WHERE id=?;") ae6dbecf17 2011-05-02 matt: run-id)) ae6dbecf17 2011-05-02 matt: keys))) ae6dbecf17 2011-05-02 matt: ae6dbecf17 2011-05-02 matt: (define (set-item-env-vars itemdat) ae6dbecf17 2011-05-02 matt: (for-each (lambda (item) ae6dbecf17 2011-05-02 matt: (print "setenv " (car item) " " (cadr item)) ae6dbecf17 2011-05-02 matt: (setenv (car item) (cadr item))) ae6dbecf17 2011-05-02 matt: itemdat)) ae6dbecf17 2011-05-02 matt: ae6dbecf17 2011-05-02 matt: (define (get-all-legal-tests) ae6dbecf17 2011-05-02 matt: (let* ((tests (glob (conc *toppath* "/tests/*"))) ae6dbecf17 2011-05-02 matt: (res '())) ae6dbecf17 2011-05-02 matt: ;; (print "INFO: Looking at tests " (string-intersperse tests ",")) ae6dbecf17 2011-05-02 matt: (for-each (lambda (testpath) ae6dbecf17 2011-05-02 matt: (if (file-exists? (conc testpath "/testconfig")) ae6dbecf17 2011-05-02 matt: (set! res (cons (last (string-split testpath "/")) res)))) ae6dbecf17 2011-05-02 matt: tests) ae6dbecf17 2011-05-02 matt: res)) ae6dbecf17 2011-05-02 matt: ae6dbecf17 2011-05-02 matt: (define (run-tests db test-names) ae6dbecf17 2011-05-02 matt: (for-each ae6dbecf17 2011-05-02 matt: (lambda (test-name) e38c4a9bdd 2011-05-03 matt: (let ((num-running (db:get-count-tests-running db)) e38c4a9bdd 2011-05-03 matt: (max-concurrent-jobs (config-lookup *configdat* "setup" "max_concurrent_jobs"))) e38c4a9bdd 2011-05-03 matt: (print "max-concurrent-jobs: " max-concurrent-jobs ", num-running: " num-running) e38c4a9bdd 2011-05-03 matt: (if (or (not max-concurrent-jobs) e38c4a9bdd 2011-05-03 matt: (and max-concurrent-jobs e38c4a9bdd 2011-05-03 matt: (string->number max-concurrent-jobs) e38c4a9bdd 2011-05-03 matt: (not (> num-running (string->number max-concurrent-jobs))))) e38c4a9bdd 2011-05-03 matt: (run-one-test db test-name) e38c4a9bdd 2011-05-03 matt: (print "WARNING: Max running jobs exceeded, current number running: " num-running e38c4a9bdd 2011-05-03 matt: ", max_concurrent_jobs: " max-concurrent-jobs)))) ae6dbecf17 2011-05-02 matt: test-names)) ae6dbecf17 2011-05-02 matt: ae6dbecf17 2011-05-02 matt: (define (run-one-test db test-name) ae6dbecf17 2011-05-02 matt: (print "Launching test " test-name) ae6dbecf17 2011-05-02 matt: (let* ((test-path (conc *toppath* "/tests/" test-name)) ae6dbecf17 2011-05-02 matt: (test-configf (conc test-path "/testconfig")) ae6dbecf17 2011-05-02 matt: (testexists (and (file-exists? test-configf)(file-read-access? test-configf))) ae6dbecf17 2011-05-02 matt: (test-conf (if testexists (read-config test-configf) (make-hash-table))) ae6dbecf17 2011-05-02 matt: (waiton (let ((w (config-lookup test-conf "requirements" "waiton"))) ae6dbecf17 2011-05-02 matt: (if (string? w)(string-split w)'())))) ae6dbecf17 2011-05-02 matt: (if (not testexists) ae6dbecf17 2011-05-02 matt: (begin ae6dbecf17 2011-05-02 matt: (print "ERROR: Can't find config file " test-configf) ae6dbecf17 2011-05-02 matt: (exit 2)) ae6dbecf17 2011-05-02 matt: ;; put top vars into convenient variables and open the db ae6dbecf17 2011-05-02 matt: (let* (;; db is always at *toppath*/db/megatest.db ae6dbecf17 2011-05-02 matt: (keys (db-get-keys db)) ae6dbecf17 2011-05-02 matt: (keyvallst (keys->vallist keys #t)) ae6dbecf17 2011-05-02 matt: (items (hash-table-ref/default test-conf "items" #f)) ae6dbecf17 2011-05-02 matt: (allitems (item-assoc->item-list items)) ae6dbecf17 2011-05-02 matt: (run-id (register-run db keys)) ;; test-name))) ae6dbecf17 2011-05-02 matt: (runconfigf (conc *toppath* "/runconfigs.config"))) ae6dbecf17 2011-05-02 matt: ;; (print "items: ")(pp allitems) e0413b29e1 2011-05-05 matt: (if (args:get-arg "-m") e0413b29e1 2011-05-05 matt: (db:set-comment-for-run db run-id (args:get-arg "-m"))) ae6dbecf17 2011-05-02 matt: (let loop ((itemdat (car allitems)) ae6dbecf17 2011-05-02 matt: (tal (cdr allitems))) ae6dbecf17 2011-05-02 matt: ;; (lambda (itemdat) ;;; ((ripeness "overripe") (temperature "cool") (season "summer")) ae6dbecf17 2011-05-02 matt: (let* ((item-path (item-list->path itemdat)) ;; (string-intersperse (map cadr itemdat) "/")) ae6dbecf17 2011-05-02 matt: (new-test-path (string-intersperse (cons test-path (map cadr itemdat)) "/")) ae6dbecf17 2011-05-02 matt: (new-test-name (if (equal? item-path "") test-name (conc test-name "/" item-path))) ;; just need it to be unique e38c4a9bdd 2011-05-03 matt: (test-status #f) e38c4a9bdd 2011-05-03 matt: (num-running (db:get-count-tests-running db)) e38c4a9bdd 2011-05-03 matt: (max-concurrent-jobs (config-lookup *configdat* "setup" "max_concurrent_jobs"))) e38c4a9bdd 2011-05-03 matt: (print "max-concurrent-jobs: " max-concurrent-jobs ", num-running: " num-running) e38c4a9bdd 2011-05-03 matt: (if (not (or (not max-concurrent-jobs) e38c4a9bdd 2011-05-03 matt: (and max-concurrent-jobs e38c4a9bdd 2011-05-03 matt: (string->number max-concurrent-jobs) e38c4a9bdd 2011-05-03 matt: (not (> num-running (string->number max-concurrent-jobs)))))) e38c4a9bdd 2011-05-03 matt: (print "WARNING: Max running jobs exceeded, current number running: " num-running e38c4a9bdd 2011-05-03 matt: ", max_concurrent_jobs: " max-concurrent-jobs) e38c4a9bdd 2011-05-03 matt: (begin e38c4a9bdd 2011-05-03 matt: (let loop2 ((ts #f) e38c4a9bdd 2011-05-03 matt: (ct 0)) e38c4a9bdd 2011-05-03 matt: (if (and (not ts) e38c4a9bdd 2011-05-03 matt: (< ct 10)) e38c4a9bdd 2011-05-03 matt: (begin e38c4a9bdd 2011-05-03 matt: (register-test db run-id test-name item-path) e38c4a9bdd 2011-05-03 matt: (db:delete-test-step-records db run-id test-name) ;; clean out if this is a re-run 7f668b637d 2011-05-06 mrwellan: (loop2 (db:get-test-info db run-id test-name item-path) e38c4a9bdd 2011-05-03 matt: (+ ct 1))) e38c4a9bdd 2011-05-03 matt: (if ts e38c4a9bdd 2011-05-03 matt: (set! test-status ts) e38c4a9bdd 2011-05-03 matt: (begin e38c4a9bdd 2011-05-03 matt: (print "WARNING: Couldn't register test " test-name " with item path " item-path ", skipping") e38c4a9bdd 2011-05-03 matt: (if (not (null? tal)) e38c4a9bdd 2011-05-03 matt: (loop (car tal)(cdr tal))))))) e38c4a9bdd 2011-05-03 matt: (change-directory test-path) e38c4a9bdd 2011-05-03 matt: ;; this block is here only to inform the user early on e38c4a9bdd 2011-05-03 matt: (if (file-exists? runconfigf) e38c4a9bdd 2011-05-03 matt: (setup-env-defaults db runconfigf run-id *already-seen-runconfig-info*) e38c4a9bdd 2011-05-03 matt: (print "WARNING: You do not have a run config file: " runconfigf)) e38c4a9bdd 2011-05-03 matt: ;; (print "run-id: " run-id " test-name: " test-name " item-path: " item-path " test-status: " (test:get-status test-status) " test-state: " (test:get-state test-status)) e38c4a9bdd 2011-05-03 matt: (case (if (args:get-arg "-force") e38c4a9bdd 2011-05-03 matt: 'NOT_STARTED e38c4a9bdd 2011-05-03 matt: (if test-status e38c4a9bdd 2011-05-03 matt: (string->symbol (test:get-state test-status)) e38c4a9bdd 2011-05-03 matt: 'failed-to-insert)) e38c4a9bdd 2011-05-03 matt: ((failed-to-insert) e38c4a9bdd 2011-05-03 matt: (print "ERROR: Failed to insert the record into the db")) e38c4a9bdd 2011-05-03 matt: ((NOT_STARTED COMPLETED) ;; (cadr status is the row id for the run record) 8f7db81841 2011-05-06 matt: (if (and (equal? (test:get-state test-status) "COMPLETED") 8f7db81841 2011-05-06 matt: (or (equal? (test:get-status test-status) "PASS") 8f7db81841 2011-05-06 matt: (equal? (test:get-status test-status) "CHECK")) e38c4a9bdd 2011-05-03 matt: (not (args:get-arg "-force"))) 7f668b637d 2011-05-06 mrwellan: (print "NOTE: Not starting test " new-test-name " as it is state \"COMPLETED\" and status \"" (test:get-status test-status) "\", use -force to override") e38c4a9bdd 2011-05-03 matt: (let* ((get-prereqs-cmd (lambda () e38c4a9bdd 2011-05-03 matt: (db-get-prereqs-not-met db run-id waiton))) ;; check before running .... e38c4a9bdd 2011-05-03 matt: (launch-cmd (lambda () e38c4a9bdd 2011-05-03 matt: (launch-test db run-id test-conf keyvallst test-name test-path itemdat))) e38c4a9bdd 2011-05-03 matt: (testrundat (list get-prereqs-cmd launch-cmd))) e38c4a9bdd 2011-05-03 matt: (if (or (args:get-arg "-force") e38c4a9bdd 2011-05-03 matt: (null? ((car testrundat)))) ;; are there any tests that must be run before this one... e38c4a9bdd 2011-05-03 matt: ((cadr testrundat)) ;; this is the line that launches the test to the remote host e38c4a9bdd 2011-05-03 matt: (hash-table-set! *waiting-queue* new-test-name testrundat))))) 7f668b637d 2011-05-06 mrwellan: ((KILLED) e38c4a9bdd 2011-05-03 matt: (print "NOTE: " new-test-name " is already running or was explictly killed, use -force to launch it.")) 7f668b637d 2011-05-06 mrwellan: ((LAUNCHED REMOTEHOSTSTART RUNNING) 7f668b637d 2011-05-06 mrwellan: (if (> (- (current-seconds)(+ (db:test-get-event_time test-status) 7f668b637d 2011-05-06 mrwellan: (db:test-get-run_duration test-status))) 7f668b637d 2011-05-06 mrwellan: 100) ;; i.e. no update for more than 100 seconds 7f668b637d 2011-05-06 mrwellan: (begin 7f668b637d 2011-05-06 mrwellan: (print "WARNING: Test " test-name " appears to be dead.") 7f668b637d 2011-05-06 mrwellan: (test-set-status! db run-id test-name "INCOMPLETE" "STUCK/DEAD" itemdat "Test is stuck or dead")) 7f668b637d 2011-05-06 mrwellan: (print "NOTE: " test-name " is already running"))) e38c4a9bdd 2011-05-03 matt: (else (print "ERROR: Failed to launch test " new-test-name ". Unrecognised state " (test:get-state test-status)))))) e38c4a9bdd 2011-05-03 matt: (if (not (null? tal)) e38c4a9bdd 2011-05-03 matt: (loop (car tal)(cdr tal))))))))) ae6dbecf17 2011-05-02 matt: ae6dbecf17 2011-05-02 matt: (define (run-waiting-tests db) ae6dbecf17 2011-05-02 matt: (let ((numtries 0) ae6dbecf17 2011-05-02 matt: (last-try-time (current-seconds)) ae6dbecf17 2011-05-02 matt: (times (list 1))) ;; minutes to wait before trying again to kick off runs ae6dbecf17 2011-05-02 matt: ;; BUG this hack of brute force retrying works quite well for many cases but ae6dbecf17 2011-05-02 matt: ;; what is needed is to check the db for tests that have failed less than ae6dbecf17 2011-05-02 matt: ;; N times or never been started and kick them off again ae6dbecf17 2011-05-02 matt: (let loop ((waiting-test-names (hash-table-keys *waiting-queue*))) ae6dbecf17 2011-05-02 matt: (cond ae6dbecf17 2011-05-02 matt: ((null? waiting-test-names) ae6dbecf17 2011-05-02 matt: (print "All tests launched")) ae6dbecf17 2011-05-02 matt: ((> numtries 4) ae6dbecf17 2011-05-02 matt: (print "NOTE: Tried launching four times, perhaps run megatest again in a few minutes")) ae6dbecf17 2011-05-02 matt: (else ae6dbecf17 2011-05-02 matt: (set! numtries (+ numtries 1)) ae6dbecf17 2011-05-02 matt: (for-each (lambda (testname) ae6dbecf17 2011-05-02 matt: (let* ((testdat (hash-table-ref *waiting-queue* testname)) ae6dbecf17 2011-05-02 matt: (prereqs ((car testdat))) ae6dbecf17 2011-05-02 matt: (ldb (if db db (open-db)))) ae6dbecf17 2011-05-02 matt: ;; (print "prereqs remaining: " prereqs) ae6dbecf17 2011-05-02 matt: (if (null? prereqs) ae6dbecf17 2011-05-02 matt: (begin ae6dbecf17 2011-05-02 matt: (print "Prerequisites met, launching " testname) ae6dbecf17 2011-05-02 matt: ((cadr testdat)) ae6dbecf17 2011-05-02 matt: (hash-table-delete! *waiting-queue* testname))) ae6dbecf17 2011-05-02 matt: (if (not db) ae6dbecf17 2011-05-02 matt: (sqlite3:finalize! ldb)))) ae6dbecf17 2011-05-02 matt: waiting-test-names) ae6dbecf17 2011-05-02 matt: (sleep 10) ;; no point in rushing things at this stage? ae6dbecf17 2011-05-02 matt: (loop (hash-table-keys *waiting-queue*))))))) ae6dbecf17 2011-05-02 matt:
File Annotation