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: e0c173490e 2011-10-09 matt: (use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking) 3469edbbf7 2011-10-09 matt: (import (prefix sqlite3 sqlite3:)) 3469edbbf7 2011-10-09 matt: 3469edbbf7 2011-10-09 matt: (declare (unit runs)) 3469edbbf7 2011-10-09 matt: (declare (uses db)) 3469edbbf7 2011-10-09 matt: (declare (uses common)) 3469edbbf7 2011-10-09 matt: (declare (uses items)) 3469edbbf7 2011-10-09 matt: (declare (uses runconfig)) 3469edbbf7 2011-10-09 matt: 3469edbbf7 2011-10-09 matt: (include "common_records.scm") 3469edbbf7 2011-10-09 matt: (include "key_records.scm") 3469edbbf7 2011-10-09 matt: (include "db_records.scm") e0c173490e 2011-10-09 matt: (include "run_records.scm") 3469edbbf7 2011-10-09 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)) ;; ?,?,? ... 09102f8425 2011-05-11 matt: (keyvallst (keys->vallist keys)) ;; extracts the values from remainder of (argv) 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 "))) bcc1c96231 2011-07-11 mrwellan: (debug:print 3 "keys: " keys " allvals: " allvals " keyvallst: " keyvallst) bcc1c96231 2011-07-11 mrwellan: (debug:print 2 "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 ");"))) bcc1c96231 2011-07-11 mrwellan: ;(debug:print 4 "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 bcc1c96231 2011-07-11 mrwellan: (debug:print 0 "ERROR: Called without all necessary keys") ae6dbecf17 2011-05-02 matt: #f)))) ae6dbecf17 2011-05-02 matt: 09102f8425 2011-05-11 matt: ;; runs:get-runs-by-patt 09102f8425 2011-05-11 matt: ;; get runs by list of criteria 09102f8425 2011-05-11 matt: ;; register a test run with the db 09102f8425 2011-05-11 matt: ;; 09102f8425 2011-05-11 matt: ;; Use: (db-get-value-by-header (db:get-header runinfo)(db:get-row runinfo)) 09102f8425 2011-05-11 matt: ;; to extract info from the structure returned 09102f8425 2011-05-11 matt: ;; 5411a1be29 2011-05-11 mrwellan: (define (runs:get-runs-by-patt db keys runnamepatt . params) ;; test-name) 09102f8425 2011-05-11 matt: (let* ((keyvallst (keys->vallist keys)) 09102f8425 2011-05-11 matt: (tmp (runs:get-std-run-fields keys '("id" "runname" "state" "status" "owner" "event_time"))) 09102f8425 2011-05-11 matt: (keystr (car tmp)) 09102f8425 2011-05-11 matt: (header (cadr tmp)) 09102f8425 2011-05-11 matt: (res '()) 09102f8425 2011-05-11 matt: (key-patt "")) 09102f8425 2011-05-11 matt: (for-each (lambda (keyval) 09102f8425 2011-05-11 matt: (let* ((key (vector-ref keyval 0)) 09102f8425 2011-05-11 matt: (fulkey (conc ":" key)) 09102f8425 2011-05-11 matt: (patt (args:get-arg fulkey))) 09102f8425 2011-05-11 matt: (if patt 09102f8425 2011-05-11 matt: (set! key-patt (conc key-patt " AND " key " like '" patt "'")) 09102f8425 2011-05-11 matt: (begin bcc1c96231 2011-07-11 mrwellan: (debug:print 0 "ERROR: searching for runs with no pattern set for " fulkey) 09102f8425 2011-05-11 matt: (exit 6))))) 09102f8425 2011-05-11 matt: keys) 09102f8425 2011-05-11 matt: (sqlite3:for-each-row 09102f8425 2011-05-11 matt: (lambda (a . r) 09102f8425 2011-05-11 matt: (set! res (cons (list->vector (cons a r)) res))) 09102f8425 2011-05-11 matt: db 09102f8425 2011-05-11 matt: (conc "SELECT " keystr " FROM runs WHERE runname like ? " key-patt ";") 09102f8425 2011-05-11 matt: runnamepatt) 09102f8425 2011-05-11 matt: (vector header res))) 09102f8425 2011-05-11 matt: ebea00e4bb 2011-08-24 mrwellan: (define (register-test db run-id test-name item-path) 00761e1112 2011-05-15 matt: (let ((item-paths (if (equal? item-path "") 00761e1112 2011-05-15 matt: (list item-path) 00761e1112 2011-05-15 matt: (list item-path "")))) 00761e1112 2011-05-15 matt: (for-each 00761e1112 2011-05-15 matt: (lambda (pth) ebea00e4bb 2011-08-24 mrwellan: (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');" 6654e3905e 2011-07-19 matt: run-id 6654e3905e 2011-07-19 matt: test-name 6654e3905e 2011-07-19 matt: pth ebea00e4bb 2011-08-24 mrwellan: ;; (conc "," (string-intersperse tags ",") ",") ebea00e4bb 2011-08-24 mrwellan: )) 6654e3905e 2011-07-19 matt: item-paths ))) 6654e3905e 2011-07-19 matt: 39d81114d3 2011-08-31 matt: ;; get the previous record for when this test was run where all keys match but runname a19566e0b3 2011-09-09 matt: ;; returns #f if no such test found, returns a single test record if found a19566e0b3 2011-09-09 matt: (define (test:get-previous-test-run-record db run-id test-name item-path) 39d81114d3 2011-08-31 matt: (let* ((keys (db:get-keys db)) 39d81114d3 2011-08-31 matt: (selstr (string-intersperse (map (lambda (x)(vector-ref x 0)) keys) ",")) 39d81114d3 2011-08-31 matt: (qrystr (string-intersperse (map (lambda (x)(conc (vector-ref x 0) "=?")) keys) " AND ")) 39d81114d3 2011-08-31 matt: (keyvals #f)) 39d81114d3 2011-08-31 matt: ;; first look up the key values from the run selected by run-id 39d81114d3 2011-08-31 matt: (sqlite3:for-each-row 39d81114d3 2011-08-31 matt: (lambda (a . b) 39d81114d3 2011-08-31 matt: (set! keyvals (cons a b))) 39d81114d3 2011-08-31 matt: db 39d81114d3 2011-08-31 matt: (conc "SELECT " selstr " FROM runs WHERE id=? ORDER BY event_time DESC;") run-id) 39d81114d3 2011-08-31 matt: (if (not keyvals) 39d81114d3 2011-08-31 matt: #f 39d81114d3 2011-08-31 matt: (let ((prev-run-ids '())) 39d81114d3 2011-08-31 matt: (apply sqlite3:for-each-row 39d81114d3 2011-08-31 matt: (lambda (id) 39d81114d3 2011-08-31 matt: (set! prev-run-ids (cons id prev-run-ids))) 39d81114d3 2011-08-31 matt: db 39d81114d3 2011-08-31 matt: (conc "SELECT id FROM runs WHERE " qrystr " AND id != ?;") (append keyvals (list run-id))) 39d81114d3 2011-08-31 matt: ;; for each run starting with the most recent look to see if there is a matching test 39d81114d3 2011-08-31 matt: ;; if found then return that matching test record 39d81114d3 2011-08-31 matt: (debug:print 4 "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals ", previous run ids found: " prev-run-ids) 39d81114d3 2011-08-31 matt: (if (null? prev-run-ids) #f 39d81114d3 2011-08-31 matt: (let loop ((hed (car prev-run-ids)) 39d81114d3 2011-08-31 matt: (tal (cdr prev-run-ids))) a72100abbd 2011-10-12 matt: (let ((results (db-get-tests-for-run db hed test-name item-path '() '()))) 39d81114d3 2011-08-31 matt: (debug:print 4 "Got tests for run-id " run-id ", test-name " test-name ", item-path " item-path ": " results) 39d81114d3 2011-08-31 matt: (if (and (null? results) 39d81114d3 2011-08-31 matt: (not (null? tal))) 39d81114d3 2011-08-31 matt: (loop (car tal)(cdr tal)) d9ed52b665 2011-10-02 matt: (if (null? results) #f d9ed52b665 2011-10-02 matt: (car results)))))))))) 39d81114d3 2011-08-31 matt: a19566e0b3 2011-09-09 matt: ;; get the previous records for when these tests were run where all keys match but runname a19566e0b3 2011-09-09 matt: ;; NB// Merge this with test:get-previous-test-run-records? This one looks for all matching tests a19566e0b3 2011-09-09 matt: ;; can use wildcards. 94a65715c9 2011-09-05 matt: (define (test:get-matching-previous-test-run-records db run-id test-name item-path) 94a65715c9 2011-09-05 matt: (let* ((keys (db:get-keys db)) 94a65715c9 2011-09-05 matt: (selstr (string-intersperse (map (lambda (x)(vector-ref x 0)) keys) ",")) 94a65715c9 2011-09-05 matt: (qrystr (string-intersperse (map (lambda (x)(conc (vector-ref x 0) "=?")) keys) " AND ")) 94a65715c9 2011-09-05 matt: (keyvals #f) 94a65715c9 2011-09-05 matt: (tests-hash (make-hash-table))) 94a65715c9 2011-09-05 matt: ;; first look up the key values from the run selected by run-id 94a65715c9 2011-09-05 matt: (sqlite3:for-each-row 94a65715c9 2011-09-05 matt: (lambda (a . b) 94a65715c9 2011-09-05 matt: (set! keyvals (cons a b))) 94a65715c9 2011-09-05 matt: db 94a65715c9 2011-09-05 matt: (conc "SELECT " selstr " FROM runs WHERE id=? ORDER BY event_time DESC;") run-id) 94a65715c9 2011-09-05 matt: (if (not keyvals) a19566e0b3 2011-09-09 matt: '() 94a65715c9 2011-09-05 matt: (let ((prev-run-ids '())) 94a65715c9 2011-09-05 matt: (apply sqlite3:for-each-row 94a65715c9 2011-09-05 matt: (lambda (id) 94a65715c9 2011-09-05 matt: (set! prev-run-ids (cons id prev-run-ids))) 94a65715c9 2011-09-05 matt: db 94a65715c9 2011-09-05 matt: (conc "SELECT id FROM runs WHERE " qrystr " AND id != ?;") (append keyvals (list run-id))) 94a65715c9 2011-09-05 matt: ;; collect all matching tests for the runs then 94a65715c9 2011-09-05 matt: ;; extract the most recent test and return that. 94a65715c9 2011-09-05 matt: (debug:print 4 "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals 94a65715c9 2011-09-05 matt: ", previous run ids found: " prev-run-ids) a19566e0b3 2011-09-09 matt: (if (null? prev-run-ids) '() ;; no previous runs? return null 94a65715c9 2011-09-05 matt: (let loop ((hed (car prev-run-ids)) 94a65715c9 2011-09-05 matt: (tal (cdr prev-run-ids))) a72100abbd 2011-10-12 matt: (let ((results (db-get-tests-for-run db hed test-name item-path '() '()))) 94a65715c9 2011-09-05 matt: (debug:print 4 "Got tests for run-id " run-id ", test-name " test-name 94a65715c9 2011-09-05 matt: ", item-path " item-path " results: " (intersperse results "\n")) 94a65715c9 2011-09-05 matt: ;; Keep only the youngest of any test/item combination 94a65715c9 2011-09-05 matt: (for-each 94a65715c9 2011-09-05 matt: (lambda (testdat) 94a65715c9 2011-09-05 matt: (let* ((full-testname (conc (db:test-get-testname testdat) "/" (db:test-get-item-path testdat))) 94a65715c9 2011-09-05 matt: (stored-test (hash-table-ref/default tests-hash full-testname #f))) 94a65715c9 2011-09-05 matt: (if (or (not stored-test) 94a65715c9 2011-09-05 matt: (and stored-test 94a65715c9 2011-09-05 matt: (> (db:test-get-event_time testdat)(db:test-get-event_time stored-test)))) 94a65715c9 2011-09-05 matt: ;; this test is younger, store it in the hash 94a65715c9 2011-09-05 matt: (hash-table-set! tests-hash full-testname testdat)))) 94a65715c9 2011-09-05 matt: results) 94a65715c9 2011-09-05 matt: (if (null? tal) 94a65715c9 2011-09-05 matt: (map cdr (hash-table->alist tests-hash)) ;; return a list of the most recent tests 94a65715c9 2011-09-05 matt: (loop (car tal)(cdr tal)))))))))) ebea00e4bb 2011-08-24 mrwellan: ebea00e4bb 2011-08-24 mrwellan: (define (test-set-status! db run-id test-name state status itemdat-or-path comment dat) 39d81114d3 2011-08-31 matt: (let* ((real-status status) 39d81114d3 2011-08-31 matt: (item-path (if (string? itemdat-or-path) itemdat-or-path (item-list->path itemdat-or-path))) 1eb40d3a48 2011-09-11 matt: (testdat (db:get-test-info db run-id test-name item-path)) 1eb40d3a48 2011-09-11 matt: (test-id (if testdat (db:test-get-id testdat) #f)) 39d81114d3 2011-08-31 matt: (otherdat (if dat dat (make-hash-table))) 39d81114d3 2011-08-31 matt: ;; before proceeding we must find out if the previous test (where all keys matched except runname) 39d81114d3 2011-08-31 matt: ;; was WAIVED if this test is FAIL 39d81114d3 2011-08-31 matt: (waived (if (equal? status "FAIL") a19566e0b3 2011-09-09 matt: (let ((prev-test (test:get-previous-test-run-record db run-id test-name item-path))) 39d81114d3 2011-08-31 matt: (if prev-test ;; true if we found a previous test in this run series 39d81114d3 2011-08-31 matt: (let ((prev-status (db:test-get-status prev-test)) 39d81114d3 2011-08-31 matt: (prev-state (db:test-get-state prev-test)) 39d81114d3 2011-08-31 matt: (prev-comment (db:test-get-comment prev-test))) 39d81114d3 2011-08-31 matt: (debug:print 4 "prev-status " prev-status ", prev-state " prev-state ", prev-comment " prev-comment) 39d81114d3 2011-08-31 matt: (if (and (equal? prev-state "COMPLETED") 39d81114d3 2011-08-31 matt: (equal? prev-status "WAIVED")) 39d81114d3 2011-08-31 matt: prev-comment ;; waived is either the comment or #f 39d81114d3 2011-08-31 matt: #f)) 39d81114d3 2011-08-31 matt: #f)) 39d81114d3 2011-08-31 matt: #f))) 39d81114d3 2011-08-31 matt: (if waived (set! real-status "WAIVED")) 39d81114d3 2011-08-31 matt: (debug:print 4 "real-status " real-status ", waived " waived ", status " status) 39d81114d3 2011-08-31 matt: ebea00e4bb 2011-08-24 mrwellan: ;; update the primary record IF state AND status are defined ebea00e4bb 2011-08-24 mrwellan: (if (and state status) ebea00e4bb 2011-08-24 mrwellan: (sqlite3:execute db "UPDATE tests SET state=?,status=?,event_time=strftime('%s','now') WHERE run_id=? AND testname=? AND item_path=?;" 39d81114d3 2011-08-31 matt: state real-status run-id test-name item-path)) 1eb40d3a48 2011-09-11 matt: 1eb40d3a48 2011-09-11 matt: ;; if status is "AUTO" then call rollup 1eb40d3a48 2011-09-11 matt: (if (and test-id state status (equal? status "AUTO")) 1eb40d3a48 2011-09-11 matt: (db:test-data-rollup db test-id)) 1eb40d3a48 2011-09-11 matt: ebea00e4bb 2011-08-24 mrwellan: ;; add metadata (need to do this way to avoid SQL injection issues) 1eb40d3a48 2011-09-11 matt: ebea00e4bb 2011-08-24 mrwellan: ;; :first_err a1371db27a 2011-10-24 matt: ;; (let ((val (hash-table-ref/default otherdat ":first_err" #f))) a1371db27a 2011-10-24 matt: ;; (if val a1371db27a 2011-10-24 matt: ;; (sqlite3:execute db "UPDATE tests SET first_err=? WHERE run_id=? AND testname=? AND item_path=?;" val run-id test-name item-path))) a1371db27a 2011-10-24 matt: ;; a1371db27a 2011-10-24 matt: ;; ;; :first_warn a1371db27a 2011-10-24 matt: ;; (let ((val (hash-table-ref/default otherdat ":first_warn" #f))) a1371db27a 2011-10-24 matt: ;; (if val a1371db27a 2011-10-24 matt: ;; (sqlite3:execute db "UPDATE tests SET first_warn=? WHERE run_id=? AND testname=? AND item_path=?;" val run-id test-name item-path))) 1eb40d3a48 2011-09-11 matt: d406fee8c4 2011-09-12 matt: (let ((category (hash-table-ref/default otherdat ":category" "")) d406fee8c4 2011-09-12 matt: (variable (hash-table-ref/default otherdat ":variable" "")) d406fee8c4 2011-09-12 matt: (value (hash-table-ref/default otherdat ":value" #f)) d406fee8c4 2011-09-12 matt: (expected (hash-table-ref/default otherdat ":expected" #f)) d406fee8c4 2011-09-12 matt: (tol (hash-table-ref/default otherdat ":tol" #f)) c22c4fd813 2011-09-13 mrwellan: (units (hash-table-ref/default otherdat ":units" "")) c22c4fd813 2011-09-13 mrwellan: (dcomment (hash-table-ref/default otherdat ":comment" ""))) d406fee8c4 2011-09-12 matt: (debug:print 4 d406fee8c4 2011-09-12 matt: "category: " category ", variable: " variable ", value: " value d406fee8c4 2011-09-12 matt: ", expected: " expected ", tol: " tol ", units: " units) d406fee8c4 2011-09-12 matt: (if (and value expected tol) ;; all three required d406fee8c4 2011-09-12 matt: (db:csv->test-data db test-id d406fee8c4 2011-09-12 matt: (conc category "," d406fee8c4 2011-09-12 matt: variable "," d406fee8c4 2011-09-12 matt: value "," d406fee8c4 2011-09-12 matt: expected "," d406fee8c4 2011-09-12 matt: tol "," d406fee8c4 2011-09-12 matt: units "," c22c4fd813 2011-09-13 mrwellan: dcomment ",")))) ebea00e4bb 2011-08-24 mrwellan: ebea00e4bb 2011-08-24 mrwellan: ;; need to update the top test record if PASS or FAIL and this is a subtest ebea00e4bb 2011-08-24 mrwellan: (if (and (not (equal? item-path "")) 00761e1112 2011-05-15 matt: (or (equal? status "PASS") 6f9cfc22a7 2011-06-06 mrwellan: (equal? status "WARN") 39d81114d3 2011-08-31 matt: (equal? status "FAIL") a19566e0b3 2011-09-09 matt: (equal? status "WAIVED") a19566e0b3 2011-09-09 matt: (equal? status "RUNNING"))) 00761e1112 2011-05-15 matt: (begin 00761e1112 2011-05-15 matt: (sqlite3:execute 00761e1112 2011-05-15 matt: db 00761e1112 2011-05-15 matt: "UPDATE tests 00761e1112 2011-05-15 matt: SET fail_count=(SELECT count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND status='FAIL'), 39d81114d3 2011-08-31 matt: pass_count=(SELECT count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND (status='PASS' OR status='WARN' OR status='WAIVED')) 00761e1112 2011-05-15 matt: WHERE run_id=? AND testname=? AND item_path='';" 00761e1112 2011-05-15 matt: run-id test-name run-id test-name run-id test-name) a19566e0b3 2011-09-09 matt: (if (equal? status "RUNNING") ;; running takes priority over all other states, force the test state to RUNNING a19566e0b3 2011-09-09 matt: (sqlite3:execute db "UPDATE tests SET state=? WHERE run_id=? AND testname=? AND item_path='';" run-id test-name) a19566e0b3 2011-09-09 matt: (sqlite3:execute a19566e0b3 2011-09-09 matt: db a19566e0b3 2011-09-09 matt: "UPDATE tests a19566e0b3 2011-09-09 matt: SET state=CASE WHEN (SELECT count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND state in ('RUNNING','NOT_STARTED')) > 0 THEN 3c4ef51e14 2011-07-13 mrwellan: 'RUNNING' 3c4ef51e14 2011-07-13 mrwellan: ELSE 'COMPLETED' END, a19566e0b3 2011-09-09 matt: status=CASE WHEN fail_count > 0 THEN 'FAIL' WHEN pass_count > 0 AND fail_count=0 THEN 'PASS' ELSE 'UNKNOWN' END a19566e0b3 2011-09-09 matt: WHERE run_id=? AND testname=? AND item_path='';" a19566e0b3 2011-09-09 matt: run-id test-name run-id test-name)))) 39d81114d3 2011-08-31 matt: (if (or (and (string? comment) 39d81114d3 2011-08-31 matt: (string-match (regexp "\\S+") comment)) 39d81114d3 2011-08-31 matt: waived) ae6dbecf17 2011-05-02 matt: (sqlite3:execute db "UPDATE tests SET comment=? WHERE run_id=? AND testname=? AND item_path=?;" 39d81114d3 2011-08-31 matt: (if waived waived comment) run-id test-name item-path)) ebea00e4bb 2011-08-24 mrwellan: )) 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))) 00761e1112 2011-05-15 matt: 00761e1112 2011-05-15 matt: (define (test-set-toplog! db run-id test-name logf) 00761e1112 2011-05-15 matt: (sqlite3:execute db "UPDATE tests SET final_logf=? WHERE run_id=? AND testname=? AND item_path='';" 00761e1112 2011-05-15 matt: logf run-id test-name)) 00761e1112 2011-05-15 matt: 40fcb78bd6 2011-08-03 matt: (define (tests:summarize-items db run-id test-name force) 40fcb78bd6 2011-08-03 matt: ;; if not force then only update the record if one of these is true: 40fcb78bd6 2011-08-03 matt: ;; 1. logf is "log/final.log 40fcb78bd6 2011-08-03 matt: ;; 2. logf is same as outputfilename 40fcb78bd6 2011-08-03 matt: (let ((outputfilename (conc "megatest-rollup-" test-name ".html")) 40fcb78bd6 2011-08-03 matt: (orig-dir (current-directory)) 40fcb78bd6 2011-08-03 matt: (logf #f)) 40fcb78bd6 2011-08-03 matt: (sqlite3:for-each-row 40fcb78bd6 2011-08-03 matt: (lambda (path final_logf) 40fcb78bd6 2011-08-03 matt: (set! logf final_logf) 40fcb78bd6 2011-08-03 matt: (if (directory? path) 40fcb78bd6 2011-08-03 matt: (begin 40fcb78bd6 2011-08-03 matt: (print "Found path: " path) 40fcb78bd6 2011-08-03 matt: (change-directory path)) 40fcb78bd6 2011-08-03 matt: ;; (set! outputfilename (conc path "/" outputfilename))) 40fcb78bd6 2011-08-03 matt: (print "No such path: " path))) 40fcb78bd6 2011-08-03 matt: db 40fcb78bd6 2011-08-03 matt: "SELECT rundir,final_logf FROM tests WHERE run_id=? AND testname=? AND item_path='';" 40fcb78bd6 2011-08-03 matt: run-id test-name) 40fcb78bd6 2011-08-03 matt: (print "summarize-items with logf " logf) 40fcb78bd6 2011-08-03 matt: (if (or (equal? logf "logs/final.log") 40fcb78bd6 2011-08-03 matt: (equal? logf outputfilename) 40fcb78bd6 2011-08-03 matt: force) 40fcb78bd6 2011-08-03 matt: (begin 40fcb78bd6 2011-08-03 matt: (if (obtain-dot-lock outputfilename 1 20 30) ;; retry every second for 20 seconds, call it dead after 30 seconds and steal the lock 40fcb78bd6 2011-08-03 matt: (print "Obtained lock for " outputfilename) 40fcb78bd6 2011-08-03 matt: (print "Failed to obtain lock for " outputfilename)) 6b05707512 2011-08-03 mrwellan: (let ((oup (open-output-file outputfilename)) 6b05707512 2011-08-03 mrwellan: (counts (make-hash-table)) 6b05707512 2011-08-03 mrwellan: (statecounts (make-hash-table)) 6b05707512 2011-08-03 mrwellan: (outtxt "") 6b05707512 2011-08-03 mrwellan: (tot 0)) 40fcb78bd6 2011-08-03 matt: (with-output-to-port 40fcb78bd6 2011-08-03 matt: oup 40fcb78bd6 2011-08-03 matt: (lambda () 6b05707512 2011-08-03 mrwellan: (set! outtxt (conc outtxt "<html><title>Summary: " test-name 6b05707512 2011-08-03 mrwellan: "</title><body><h2>Summary for " test-name "</h2>")) 40fcb78bd6 2011-08-03 matt: (sqlite3:for-each-row 40fcb78bd6 2011-08-03 matt: (lambda (id itempath state status run_duration logf comment) 6b05707512 2011-08-03 mrwellan: (hash-table-set! counts status (+ 1 (hash-table-ref/default counts status 0))) 6b05707512 2011-08-03 mrwellan: (hash-table-set! statecounts state (+ 1 (hash-table-ref/default statecounts state 0))) 6b05707512 2011-08-03 mrwellan: (set! outtxt (conc outtxt "<tr>" 6b05707512 2011-08-03 mrwellan: "<td><a href=\"" itempath "/" logf "\"> " itempath "</a></td>" 6b05707512 2011-08-03 mrwellan: "<td>" state "</td>" b2ba4571a3 2011-08-03 mrwellan: "<td><font color=" (common:get-color-from-status status) b2ba4571a3 2011-08-03 mrwellan: ">" status "</font></td>" b2ba4571a3 2011-08-03 mrwellan: "<td>" (if (equal? comment "") b2ba4571a3 2011-08-03 mrwellan: " " b2ba4571a3 2011-08-03 mrwellan: comment) "</td>" b2ba4571a3 2011-08-03 mrwellan: "</tr>"))) 40fcb78bd6 2011-08-03 matt: db 40fcb78bd6 2011-08-03 matt: "SELECT id,item_path,state,status,run_duration,final_logf,comment FROM tests WHERE run_id=? AND testname=? AND item_path != '';" 40fcb78bd6 2011-08-03 matt: run-id test-name) 6b05707512 2011-08-03 mrwellan: b2ba4571a3 2011-08-03 mrwellan: (print "<table><tr><td valign=\"top\">") 6b05707512 2011-08-03 mrwellan: ;; Print out stats for status 6b05707512 2011-08-03 mrwellan: (set! tot 0) b2ba4571a3 2011-08-03 mrwellan: (print "<table cellspacing=\"0\" border=\"1\"><tr><td colspan=\"2\"><h2>State stats</h2></td></tr>") 6b05707512 2011-08-03 mrwellan: (for-each (lambda (state) 6b05707512 2011-08-03 mrwellan: (set! tot (+ tot (hash-table-ref statecounts state))) 6b05707512 2011-08-03 mrwellan: (print "<tr><td>" state "</td><td>" (hash-table-ref statecounts state) "</td></tr>")) 6b05707512 2011-08-03 mrwellan: (hash-table-keys statecounts)) 6b05707512 2011-08-03 mrwellan: (print "<tr><td>Total</td><td>" tot "</td></tr></table>") b2ba4571a3 2011-08-03 mrwellan: (print "</td><td valign=\"top\">") 6b05707512 2011-08-03 mrwellan: ;; Print out stats for state 6b05707512 2011-08-03 mrwellan: (set! tot 0) b2ba4571a3 2011-08-03 mrwellan: (print "<table cellspacing=\"0\" border=\"1\"><tr><td colspan=\"2\"><h2>Status stats</h2></td></tr>") 6b05707512 2011-08-03 mrwellan: (for-each (lambda (status) 6b05707512 2011-08-03 mrwellan: (set! tot (+ tot (hash-table-ref counts status))) b2ba4571a3 2011-08-03 mrwellan: (print "<tr><td><font color=\"" (common:get-color-from-status status) "\">" status b2ba4571a3 2011-08-03 mrwellan: "</font></td><td>" (hash-table-ref counts status) "</td></tr>")) 6b05707512 2011-08-03 mrwellan: (hash-table-keys counts)) 6b05707512 2011-08-03 mrwellan: (print "<tr><td>Total</td><td>" tot "</td></tr></table>") b2ba4571a3 2011-08-03 mrwellan: (print "</td></td></tr></table>") 6b05707512 2011-08-03 mrwellan: 6b05707512 2011-08-03 mrwellan: (print "<table cellspacing=\"0\" border=\"1\">" 6b05707512 2011-08-03 mrwellan: "<tr><td>Item</td><td>State</td><td>Status</td><td>Comment</td>" 6b05707512 2011-08-03 mrwellan: outtxt "</table></body></html>") 40fcb78bd6 2011-08-03 matt: (release-dot-lock outputfilename))) 40fcb78bd6 2011-08-03 matt: (close-output-port oup) 40fcb78bd6 2011-08-03 matt: (change-directory orig-dir) 40fcb78bd6 2011-08-03 matt: (test-set-toplog! db run-id test-name outputfilename) 40fcb78bd6 2011-08-03 matt: ))))) 42b834da20 2011-08-02 mrwellan: 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 (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 (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: 52120b2140 2011-10-20 mrwellan: (define (teststep-set-status! db run-id test-name teststep-name state-in status-in itemdat comment logfile) bcc1c96231 2011-07-11 mrwellan: (debug:print 4 "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))) bcc1c96231 2011-07-11 mrwellan: (debug:print 5 "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))) bcc1c96231 2011-07-11 mrwellan: (debug:print 0 "WARNING: Invalid " (if status "status" "state") 06c4198b8e 2011-09-26 matt: " value \"" (if status state-in status-in) "\", update your validvalues section in megatest.config")) ae6dbecf17 2011-05-02 matt: (if testdat ae6dbecf17 2011-05-02 matt: (let ((test-id (test:get-id testdat))) 52120b2140 2011-10-20 mrwellan: ;; FIXME - this should not update the logfile unless it is specified. ae6dbecf17 2011-05-02 matt: (sqlite3:execute db 52120b2140 2011-10-20 mrwellan: "INSERT OR REPLACE into test_steps (test_id,stepname,state,status,event_time,comment,logfile) VALUES(?,?,?,?,strftime('%s','now'),?,?);" 52120b2140 2011-10-20 mrwellan: test-id teststep-name state-in status-in (if comment comment "") (if logfile logfile ""))) bcc1c96231 2011-07-11 mrwellan: (debug:print 0 "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: 598ddd3327 2011-09-11 matt: (define (test-update-meta-info db run-id testname itemdat minutes cpuload diskfree tmpfree) 598ddd3327 2011-09-11 matt: (let ((item-path (item-list->path itemdat))) bcc1c96231 2011-07-11 mrwellan: (if (not item-path)(begin (debug:print 0 "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) bcc1c96231 2011-07-11 mrwellan: (debug:print 2 "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) bcc1c96231 2011-07-11 mrwellan: (debug:print 2 "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 '())) bcc1c96231 2011-07-11 mrwellan: (debug:print 4 "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: d73b2c1642 2011-06-27 mrwellan: (define (runs:can-run-more-tests db) d73b2c1642 2011-06-27 mrwellan: (let ((num-running (db:get-count-tests-running db)) d73b2c1642 2011-06-27 mrwellan: (max-concurrent-jobs (config-lookup *configdat* "setup" "max_concurrent_jobs"))) bcc1c96231 2011-07-11 mrwellan: (debug:print 2 "max-concurrent-jobs: " max-concurrent-jobs ", num-running: " num-running) 70aaddfbce 2011-07-13 matt: (if (not (eq? 0 *globalexitstatus*)) 70aaddfbce 2011-07-13 matt: #f 70aaddfbce 2011-07-13 matt: (if (or (not max-concurrent-jobs) 70aaddfbce 2011-07-13 matt: (and max-concurrent-jobs 70aaddfbce 2011-07-13 matt: (string->number max-concurrent-jobs) 70aaddfbce 2011-07-13 matt: (not (>= num-running (string->number max-concurrent-jobs))))) 70aaddfbce 2011-07-13 matt: #t 70aaddfbce 2011-07-13 matt: (begin 70aaddfbce 2011-07-13 matt: (debug:print 0 "WARNING: Max running jobs exceeded, current number running: " num-running 70aaddfbce 2011-07-13 matt: ", max_concurrent_jobs: " max-concurrent-jobs) 70aaddfbce 2011-07-13 matt: #f))))) 70aaddfbce 2011-07-13 matt: ec6f374d39 2011-10-13 matt: (define (test:get-testconfig test-name system-allowed) ec6f374d39 2011-10-13 matt: (let* ((test-path (conc *toppath* "/tests/" test-name)) ec6f374d39 2011-10-13 matt: (test-configf (conc test-path "/testconfig")) ec6f374d39 2011-10-13 matt: (testexists (and (file-exists? test-configf)(file-read-access? test-configf)))) ec6f374d39 2011-10-13 matt: (if testexists ec6f374d39 2011-10-13 matt: (read-config test-configf #f system-allowed) ec6f374d39 2011-10-13 matt: #f))) ec6f374d39 2011-10-13 matt: ec6f374d39 2011-10-13 matt: ;; sort tests by priority and waiton ec6f374d39 2011-10-13 matt: ;; Move test specific stuff to a test unit FIXME one of these days ec6f374d39 2011-10-13 matt: (define (tests:sort-by-priority-and-waiton test-names) ec6f374d39 2011-10-13 matt: (let ((testdetails (make-hash-table)) ec6f374d39 2011-10-13 matt: (mungepriority (lambda (priority) ec6f374d39 2011-10-13 matt: (if priority ec6f374d39 2011-10-13 matt: (let ((tmp (any->number priority))) ec6f374d39 2011-10-13 matt: (if tmp tmp (begin (debug:print 0 "ERROR: bad priority value " priority ", using 0") 0))) ec6f374d39 2011-10-13 matt: 0)))) ec6f374d39 2011-10-13 matt: (for-each (lambda (test-name) ec6f374d39 2011-10-13 matt: (let ((test-config (test:get-testconfig test-name #f))) ec6f374d39 2011-10-13 matt: (if test-config (hash-table-set! testdetails test-name test-config)))) ec6f374d39 2011-10-13 matt: test-names) ec6f374d39 2011-10-13 matt: (sort ec6f374d39 2011-10-13 matt: (hash-table-keys testdetails) ;; avoid dealing with deleted tests, look at the hash table ec6f374d39 2011-10-13 matt: (lambda (a b) ec6f374d39 2011-10-13 matt: (let* ((tconf-a (hash-table-ref testdetails a)) ec6f374d39 2011-10-13 matt: (tconf-b (hash-table-ref testdetails b)) ec6f374d39 2011-10-13 matt: (a-waiton (config-lookup tconf-a "requirements" "waiton")) ec6f374d39 2011-10-13 matt: (b-waiton (config-lookup tconf-b "requirements" "waiton")) ec6f374d39 2011-10-13 matt: (a-priority (mungepriority (config-lookup tconf-a "requirements" "priority"))) ec6f374d39 2011-10-13 matt: (b-priority (mungepriority (config-lookup tconf-b "requirements" "priority")))) ec6f374d39 2011-10-13 matt: (if (and a-waiton (equal? a-waiton b)) ec6f374d39 2011-10-13 matt: #f ;; cannot have a which is waiting on b happening before b ec6f374d39 2011-10-13 matt: (if (and b-waiton (equal? b-waiton a)) ec6f374d39 2011-10-13 matt: #t ;; this is the correct order, b is waiting on a and b is before a ec6f374d39 2011-10-13 matt: (if (> a-priority b-priority) ec6f374d39 2011-10-13 matt: #t ;; if a is a higher priority than b then we are good to go ec6f374d39 2011-10-13 matt: #f)))))))) ec6f374d39 2011-10-13 matt: f97980cf8c 2011-10-23 matt: ;; This is original run-tests, this routine is deprecated and we will transition to using runs:run-tests (see below) f97980cf8c 2011-10-23 matt: ;; c075ebd51b 2011-06-16 mrwellan: (define (run-tests db test-names) c075ebd51b 2011-06-16 mrwellan: (let* ((keys (db-get-keys db)) c075ebd51b 2011-06-16 mrwellan: (keyvallst (keys->vallist keys #t)) 6b1fa57fcf 2011-08-07 matt: (run-id (register-run db keys)) ;; test-name))) 6b1fa57fcf 2011-08-07 matt: (deferred '())) ;; delay running these since they have a waiton clause d73b2c1642 2011-06-27 mrwellan: ;; on the first pass or call to run-tests set FAILS to NOT_STARTED if d73b2c1642 2011-06-27 mrwellan: ;; -keepgoing is specified d73b2c1642 2011-06-27 mrwellan: (if (and (eq? *passnum* 0) d73b2c1642 2011-06-27 mrwellan: (args:get-arg "-keepgoing")) bcc1c96231 2011-07-11 mrwellan: (begin bcc1c96231 2011-07-11 mrwellan: ;; have to delete test records where NOT_STARTED since they can cause -keepgoing to bcc1c96231 2011-07-11 mrwellan: ;; get stuck due to becoming inaccessible from a failed test. I.e. if test B depends bcc1c96231 2011-07-11 mrwellan: ;; on test A but test B reached the point on being registered as NOT_STARTED and test bcc1c96231 2011-07-11 mrwellan: ;; A failed for some reason then on re-run using -keepgoing the run can never complete. bcc1c96231 2011-07-11 mrwellan: (db:delete-tests-in-state db run-id "NOT_STARTED") bcc1c96231 2011-07-11 mrwellan: (db:set-tests-state-status db run-id test-names #f "FAIL" "NOT_STARTED" "FAIL"))) d73b2c1642 2011-06-27 mrwellan: (set! *passnum* (+ *passnum* 1)) c075ebd51b 2011-06-16 mrwellan: (let loop ((numtimes 0)) c075ebd51b 2011-06-16 mrwellan: (for-each c075ebd51b 2011-06-16 mrwellan: (lambda (test-name) d73b2c1642 2011-06-27 mrwellan: (if (runs:can-run-more-tests db) d73b2c1642 2011-06-27 mrwellan: (run-one-test db run-id test-name keyvallst) d73b2c1642 2011-06-27 mrwellan: ;; add some delay 70aaddfbce 2011-07-13 matt: ;(sleep 2) 70aaddfbce 2011-07-13 matt: )) ec6f374d39 2011-10-13 matt: (tests:sort-by-priority-and-waiton test-names)) d73b2c1642 2011-06-27 mrwellan: ;; (run-waiting-tests db) c075ebd51b 2011-06-16 mrwellan: (if (args:get-arg "-keepgoing") c075ebd51b 2011-06-16 mrwellan: (let ((estrem (db:estimated-tests-remaining db run-id))) 70aaddfbce 2011-07-13 matt: (if (and (> estrem 0) 70aaddfbce 2011-07-13 matt: (eq? *globalexitstatus* 0)) c075ebd51b 2011-06-16 mrwellan: (begin bcc1c96231 2011-07-11 mrwellan: (debug:print 1 "Keep going, estimated " estrem " tests remaining to run, will continue in 3 seconds ...") bcc1c96231 2011-07-11 mrwellan: (sleep 3) d73b2c1642 2011-06-27 mrwellan: (run-waiting-tests db) c075ebd51b 2011-06-16 mrwellan: (loop (+ numtimes 1))))))))) c075ebd51b 2011-06-16 mrwellan: c075ebd51b 2011-06-16 mrwellan: ;; VERY INEFFICIENT! Move stuff that should be done once up to calling proc c075ebd51b 2011-06-16 mrwellan: (define (run-one-test db run-id test-name keyvallst) bcc1c96231 2011-07-11 mrwellan: (debug:print 1 "Launching test " test-name) c075ebd51b 2011-06-16 mrwellan: ;; All these vars might be referenced by the testconfig file reader c075ebd51b 2011-06-16 mrwellan: (setenv "MT_TEST_NAME" test-name) ;; c075ebd51b 2011-06-16 mrwellan: (setenv "MT_RUNNAME" (args:get-arg ":runname")) c075ebd51b 2011-06-16 mrwellan: (set-megatest-env-vars db run-id) ;; these may be needed by the launching process c075ebd51b 2011-06-16 mrwellan: (change-directory *toppath*) ec6f374d39 2011-10-13 matt: (let* ((test-path (conc *toppath* "/tests/" test-name)) ;; could use test:get-testconfig here ... c075ebd51b 2011-06-16 mrwellan: (test-configf (conc test-path "/testconfig")) ae6dbecf17 2011-05-02 matt: (testexists (and (file-exists? test-configf)(file-read-access? test-configf))) ebea00e4bb 2011-08-24 mrwellan: (test-conf (if testexists (read-config test-configf #f #t) (make-hash-table))) ae6dbecf17 2011-05-02 matt: (waiton (let ((w (config-lookup test-conf "requirements" "waiton"))) 6654e3905e 2011-07-19 matt: (if (string? w)(string-split w)'()))) 6654e3905e 2011-07-19 matt: (tags (let ((t (config-lookup test-conf "setup" "tags"))) ebea00e4bb 2011-08-24 mrwellan: ;; we want our tags to be separated by commas and fully delimited by commas ebea00e4bb 2011-08-24 mrwellan: ;; so that queries with "like" can tie to the commas at either end of each tag ebea00e4bb 2011-08-24 mrwellan: ;; while also allowing the end user to freely use spaces and commas to separate tags ebea00e4bb 2011-08-24 mrwellan: (if (string? t)(string-substitute (regexp "[,\\s]+") "," (conc "," t ",") #t) ebea00e4bb 2011-08-24 mrwellan: '())))) ae6dbecf17 2011-05-02 matt: (if (not testexists) ae6dbecf17 2011-05-02 matt: (begin bcc1c96231 2011-07-11 mrwellan: (debug:print 0 "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 8d68c68080 2011-06-07 mrwellan: (items (hash-table-ref/default test-conf "items" '())) 8d68c68080 2011-06-07 mrwellan: (itemstable (hash-table-ref/default test-conf "itemstable" '())) 8d68c68080 2011-06-07 mrwellan: (allitems (if (or (not (null? items))(not (null? itemstable))) 8d68c68080 2011-06-07 mrwellan: (append (item-assoc->item-list items) 8d68c68080 2011-06-07 mrwellan: (item-table->item-list itemstable)) 8d68c68080 2011-06-07 mrwellan: '(()))) ;; a list with one null list is a test with no items ae6dbecf17 2011-05-02 matt: (runconfigf (conc *toppath* "/runconfigs.config"))) bcc1c96231 2011-07-11 mrwellan: (debug:print 1 "items: ") bcc1c96231 2011-07-11 mrwellan: (if (>= *verbosity* 1)(pp allitems)) bcc1c96231 2011-07-11 mrwellan: (if (>= *verbosity* 5) bcc1c96231 2011-07-11 mrwellan: (begin bcc1c96231 2011-07-11 mrwellan: (print "items: ")(pp (item-assoc->item-list items)) bcc1c96231 2011-07-11 mrwellan: (print "itestable: ")(pp (item-table->item-list itemstable)))) 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"))) d7ffcddcac 2011-08-11 matt: d7ffcddcac 2011-08-11 matt: ;; Here is where the test_meta table is best updated ebea00e4bb 2011-08-24 mrwellan: (runs:update-test_meta db test-name test-conf) d7ffcddcac 2011-08-11 matt: bcc1c96231 2011-07-11 mrwellan: ;; braindead work-around for poorly specified allitems list BUG!!! FIXME bcc1c96231 2011-07-11 mrwellan: (if (null? allitems)(set! allitems '(()))) 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")) d73b2c1642 2011-06-27 mrwellan: ;; Handle lists of items 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 d73b2c1642 2011-06-27 mrwellan: (testdat #f) e38c4a9bdd 2011-05-03 matt: (num-running (db:get-count-tests-running db)) d73b2c1642 2011-06-27 mrwellan: (max-concurrent-jobs (config-lookup *configdat* "setup" "max_concurrent_jobs")) d73b2c1642 2011-06-27 mrwellan: (parent-test (and (not (null? items))(equal? item-path ""))) d73b2c1642 2011-06-27 mrwellan: (single-test (and (null? items) (equal? item-path ""))) 99f24d81d1 2011-09-26 matt: (item-test (not (equal? item-path ""))) 99f24d81d1 2011-09-26 matt: (item-patt (args:get-arg "-itempatt")) 99f24d81d1 2011-09-26 matt: (patt-match (if item-patt a1371db27a 2011-10-24 matt: (string-search (glob->regexp 99f24d81d1 2011-09-26 matt: (string-translate item-patt "%" "*")) 99f24d81d1 2011-09-26 matt: item-path) 99f24d81d1 2011-09-26 matt: #t))) bcc1c96231 2011-07-11 mrwellan: (debug:print 3 "max-concurrent-jobs: " max-concurrent-jobs ", num-running: " num-running) 99f24d81d1 2011-09-26 matt: (if (and patt-match (runs:can-run-more-tests db)) e38c4a9bdd 2011-05-03 matt: (begin 51810ab5ab 2011-06-16 mrwellan: (let loop2 ((ts (db:get-test-info db run-id test-name item-path)) ;; #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 ebea00e4bb 2011-08-24 mrwellan: (register-test db run-id test-name item-path) 5411a1be29 2011-05-11 mrwellan: (db:test-set-comment db run-id test-name item-path "") 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 d73b2c1642 2011-06-27 mrwellan: (set! testdat ts) e38c4a9bdd 2011-05-03 matt: (begin bcc1c96231 2011-07-11 mrwellan: (debug:print 0 "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*) bcc1c96231 2011-07-11 mrwellan: (debug:print 0 "WARNING: You do not have a run config file: " runconfigf)) bcc1c96231 2011-07-11 mrwellan: (debug:print 4 "run-id: " run-id " test-name: " test-name " item-path: " item-path " testdat: " (test:get-status testdat) " test-state: " (test:get-state testdat)) e38c4a9bdd 2011-05-03 matt: (case (if (args:get-arg "-force") e38c4a9bdd 2011-05-03 matt: 'NOT_STARTED d73b2c1642 2011-06-27 mrwellan: (if testdat d73b2c1642 2011-06-27 mrwellan: (string->symbol (test:get-state testdat)) e38c4a9bdd 2011-05-03 matt: 'failed-to-insert)) e38c4a9bdd 2011-05-03 matt: ((failed-to-insert) bcc1c96231 2011-07-11 mrwellan: (debug:print 0 "ERROR: Failed to insert the record into the db")) d73b2c1642 2011-06-27 mrwellan: ((NOT_STARTED COMPLETED) bcc1c96231 2011-07-11 mrwellan: (debug:print 6 "Got here, " (test:get-state testdat)) d73b2c1642 2011-06-27 mrwellan: (let ((runflag #f)) d73b2c1642 2011-06-27 mrwellan: (cond d73b2c1642 2011-06-27 mrwellan: ;; i.e. this is the parent test to a suite of items, never "run" it d73b2c1642 2011-06-27 mrwellan: (parent-test d73b2c1642 2011-06-27 mrwellan: (set! runflag #f)) d73b2c1642 2011-06-27 mrwellan: ;; -force, run no matter what d73b2c1642 2011-06-27 mrwellan: ((args:get-arg "-force")(set! runflag #t)) d73b2c1642 2011-06-27 mrwellan: ;; NOT_STARTED, run no matter what d73b2c1642 2011-06-27 mrwellan: ((equal? (test:get-state testdat) "NOT_STARTED")(set! runflag #t)) d73b2c1642 2011-06-27 mrwellan: ;; not -rerun and PASS, WARN or CHECK, do no run d73b2c1642 2011-06-27 mrwellan: ((and (or (not (args:get-arg "-rerun")) d73b2c1642 2011-06-27 mrwellan: (args:get-arg "-keepgoing")) d73b2c1642 2011-06-27 mrwellan: (member (test:get-status testdat) '("PASS" "WARN" "CHECK"))) d73b2c1642 2011-06-27 mrwellan: (set! runflag #f)) d73b2c1642 2011-06-27 mrwellan: ;; -rerun and status is one of the specifed, run it d73b2c1642 2011-06-27 mrwellan: ((and (args:get-arg "-rerun") d73b2c1642 2011-06-27 mrwellan: (let ((rerunlst (string-split (args:get-arg "-rerun") ","))) ;; FAIL, d73b2c1642 2011-06-27 mrwellan: (member (test:get-status testdat) rerunlst))) d73b2c1642 2011-06-27 mrwellan: (set! runflag #t)) d73b2c1642 2011-06-27 mrwellan: ;; -keepgoing, do not rerun FAIL d73b2c1642 2011-06-27 mrwellan: ((and (args:get-arg "-keepgoing") d73b2c1642 2011-06-27 mrwellan: (member (test:get-status testdat) '("FAIL"))) d73b2c1642 2011-06-27 mrwellan: (set! runflag #f)) d73b2c1642 2011-06-27 mrwellan: ((and (not (args:get-arg "-rerun")) d73b2c1642 2011-06-27 mrwellan: (member (test:get-status testdat) '("FAIL" "n/a"))) d73b2c1642 2011-06-27 mrwellan: (set! runflag #t)) d73b2c1642 2011-06-27 mrwellan: (else (set! runflag #f))) bcc1c96231 2011-07-11 mrwellan: (debug:print 6 "RUNNING => runflag: " runflag " STATE: " (test:get-state testdat) " STATUS: " (test:get-status testdat)) d73b2c1642 2011-06-27 mrwellan: (if (not runflag) d73b2c1642 2011-06-27 mrwellan: (if (not parent-test) bcc1c96231 2011-07-11 mrwellan: (debug:print 1 "NOTE: Not starting test " new-test-name " as it is state \"COMPLETED\" and status \"" (test:get-status testdat) "\", use -force to override")) d73b2c1642 2011-06-27 mrwellan: (let* ((get-prereqs-cmd (lambda () d73b2c1642 2011-06-27 mrwellan: (db-get-prereqs-not-met db run-id waiton))) ;; check before running .... d73b2c1642 2011-06-27 mrwellan: (launch-cmd (lambda () 98de2c2f8d 2011-10-24 matt: (launch-test db run-id (args:get-arg ":runname") test-conf keyvallst test-name test-path itemdat))) d73b2c1642 2011-06-27 mrwellan: (testrundat (list get-prereqs-cmd launch-cmd))) d73b2c1642 2011-06-27 mrwellan: (if (or (args:get-arg "-force") 6b1fa57fcf 2011-08-07 matt: (let ((preqs-not-yet-met ((car testrundat)))) 6b1fa57fcf 2011-08-07 matt: (debug:print 2 "Preqrequesites for " test-name ": " preqs-not-yet-met) 6b1fa57fcf 2011-08-07 matt: (null? preqs-not-yet-met))) ;; are there any tests that must be run before this one... 70aaddfbce 2011-07-13 matt: (if (not ((cadr testrundat))) ;; this is the line that launches the test to the remote host 70aaddfbce 2011-07-13 matt: (begin 70aaddfbce 2011-07-13 matt: (print "ERROR: Failed to launch the test. Exiting as soon as possible") 70aaddfbce 2011-07-13 matt: (set! *globalexitstatus* 1) ;; 70aaddfbce 2011-07-13 matt: (process-signal (current-process-id) signal/kill) 70aaddfbce 2011-07-13 matt: ;(exit 1) 70aaddfbce 2011-07-13 matt: )) 1ea16b0407 2011-06-28 mrwellan: (if (not (args:get-arg "-keepgoing")) 1ea16b0407 2011-06-28 mrwellan: (hash-table-set! *waiting-queue* new-test-name testrundat))))))) 7f668b637d 2011-05-06 mrwellan: ((KILLED) bcc1c96231 2011-07-11 mrwellan: (debug:print 1 "NOTE: " new-test-name " is already running or was explictly killed, use -force to launch it.")) 7f668b637d 2011-05-06 mrwellan: ((LAUNCHED REMOTEHOSTSTART RUNNING) d73b2c1642 2011-06-27 mrwellan: (if (> (- (current-seconds)(+ (db:test-get-event_time testdat) d73b2c1642 2011-06-27 mrwellan: (db:test-get-run_duration testdat))) 7f668b637d 2011-05-06 mrwellan: 100) ;; i.e. no update for more than 100 seconds 7f668b637d 2011-05-06 mrwellan: (begin bcc1c96231 2011-07-11 mrwellan: (debug:print 0 "WARNING: Test " test-name " appears to be dead. Forcing it to state INCOMPLETE and status STUCK/DEAD") 39d81114d3 2011-08-31 matt: (test-set-status! db run-id test-name "INCOMPLETE" "STUCK/DEAD" itemdat "Test is stuck or dead" #f)) bcc1c96231 2011-07-11 mrwellan: (debug:print 2 "NOTE: " test-name " is already running"))) bcc1c96231 2011-07-11 mrwellan: (else (debug:print 0 "ERROR: Failed to launch test " new-test-name ". Unrecognised state " (test:get-state testdat)))))) 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 d73b2c1642 2011-06-27 mrwellan: ((not (runs:can-run-more-tests db)) d73b2c1642 2011-06-27 mrwellan: (sleep 2) d73b2c1642 2011-06-27 mrwellan: (loop waiting-test-names)) ae6dbecf17 2011-05-02 matt: ((null? waiting-test-names) bcc1c96231 2011-07-11 mrwellan: (debug:print 1 "All tests launched")) ae6dbecf17 2011-05-02 matt: (else ae6dbecf17 2011-05-02 matt: (set! numtries (+ numtries 1)) ae6dbecf17 2011-05-02 matt: (for-each (lambda (testname) d73b2c1642 2011-06-27 mrwellan: (if (runs:can-run-more-tests db) d73b2c1642 2011-06-27 mrwellan: (let* ((testdat (hash-table-ref *waiting-queue* testname)) d73b2c1642 2011-06-27 mrwellan: (prereqs ((car testdat))) d73b2c1642 2011-06-27 mrwellan: (ldb (if db db (open-db)))) bcc1c96231 2011-07-11 mrwellan: (debug:print 2 "prereqs remaining: " prereqs) d73b2c1642 2011-06-27 mrwellan: (if (null? prereqs) d73b2c1642 2011-06-27 mrwellan: (begin bcc1c96231 2011-07-11 mrwellan: (debug:print 2 "Prerequisites met, launching " testname) d73b2c1642 2011-06-27 mrwellan: ((cadr testdat)) d73b2c1642 2011-06-27 mrwellan: (hash-table-delete! *waiting-queue* testname))) d73b2c1642 2011-06-27 mrwellan: (if (not db) d73b2c1642 2011-06-27 mrwellan: (sqlite3:finalize! ldb))))) ae6dbecf17 2011-05-02 matt: waiting-test-names) d73b2c1642 2011-06-27 mrwellan: ;; (sleep 10) ;; no point in rushing things at this stage? ae6dbecf17 2011-05-02 matt: (loop (hash-table-keys *waiting-queue*))))))) f97980cf8c 2011-10-23 matt: f97980cf8c 2011-10-23 matt: ;;====================================================================== f97980cf8c 2011-10-23 matt: ;; New methodology. These routines will replace the above in time. For f97980cf8c 2011-10-23 matt: ;; now the code is duplicated. This stuff is initially used in the monitor f97980cf8c 2011-10-23 matt: ;; based code. f97980cf8c 2011-10-23 matt: ;;====================================================================== f97980cf8c 2011-10-23 matt: 59034f6b4d 2011-10-24 matt: ;; register a test run with the db 59034f6b4d 2011-10-24 matt: (define (runs:register-run db keys keyvallst runname state status user) 59034f6b4d 2011-10-24 matt: (let* ((keystr (keys->keystr keys)) 59034f6b4d 2011-10-24 matt: (comma (if (> (length keys) 0) "," "")) 59034f6b4d 2011-10-24 matt: (andstr (if (> (length keys) 0) " AND " "")) 59034f6b4d 2011-10-24 matt: (valslots (keys->valslots keys)) ;; ?,?,? ... 59034f6b4d 2011-10-24 matt: (keyvals (map cadr keyvallst)) 59034f6b4d 2011-10-24 matt: (allvals (append (list runname state status user) keyvals)) 59034f6b4d 2011-10-24 matt: (qryvals (append (list runname) keyvals)) 59034f6b4d 2011-10-24 matt: (key=?str (string-intersperse (map (lambda (k)(conc (key:get-fieldname k) "=?")) keys) " AND "))) 59034f6b4d 2011-10-24 matt: (debug:print 3 "keys: " keys " allvals: " allvals " keyvals: " keyvals) 59034f6b4d 2011-10-24 matt: (debug:print 2 "NOTE: using target " (string-intersperse keyvals "/") " for this run") 59034f6b4d 2011-10-24 matt: (if (and runname (null? (filter (lambda (x)(not x)) keyvals))) ;; there must be a better way to "apply and" 59034f6b4d 2011-10-24 matt: (let ((res #f)) 59034f6b4d 2011-10-24 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 ");") 59034f6b4d 2011-10-24 matt: allvals) 59034f6b4d 2011-10-24 matt: (apply sqlite3:for-each-row 59034f6b4d 2011-10-24 matt: (lambda (id) 59034f6b4d 2011-10-24 matt: (set! res id)) 59034f6b4d 2011-10-24 matt: db 59034f6b4d 2011-10-24 matt: (let ((qry (conc "SELECT id FROM runs WHERE (runname=? " andstr key=?str ");"))) 59034f6b4d 2011-10-24 matt: ;(debug:print 4 "qry: " qry) 59034f6b4d 2011-10-24 matt: qry) 59034f6b4d 2011-10-24 matt: qryvals) 59034f6b4d 2011-10-24 matt: (sqlite3:execute db "UPDATE runs SET state=?,status=? WHERE id=?;" state status res) 59034f6b4d 2011-10-24 matt: res) 59034f6b4d 2011-10-24 matt: (begin 59034f6b4d 2011-10-24 matt: (debug:print 0 "ERROR: Called without all necessary keys") 59034f6b4d 2011-10-24 matt: #f)))) 59034f6b4d 2011-10-24 matt: f97980cf8c 2011-10-23 matt: ;; This is a duplicate of run-tests (which has been deprecated). Use this one instead of run tests. f97980cf8c 2011-10-23 matt: ;; keyvals 59034f6b4d 2011-10-24 matt: (define (runs:run-tests db target runname test-patts item-patts user flags) f97980cf8c 2011-10-23 matt: (let* ((keys (db-get-keys db)) f97980cf8c 2011-10-23 matt: (keyvallst (keys:target->keyval keys target)) 59034f6b4d 2011-10-24 matt: (run-id (runs:register-run db keys keyvallst runname "new" "n/a" user)) ;; test-name))) f97980cf8c 2011-10-23 matt: (deferred '()) ;; delay running these since they have a waiton clause 59034f6b4d 2011-10-24 matt: (keepgoing (hash-table-ref/default flags "-keepgoing" #f)) 59034f6b4d 2011-10-24 matt: (test-names '())) 59034f6b4d 2011-10-24 matt: ;; look up all tests matching the comma separated list of globs in 59034f6b4d 2011-10-24 matt: ;; test-patts (using % as wildcard) 59034f6b4d 2011-10-24 matt: (for-each 59034f6b4d 2011-10-24 matt: (lambda (patt) 59034f6b4d 2011-10-24 matt: (let ((tests (glob (conc *toppath* "/tests/" (string-translate patt "%" "*"))))) 59034f6b4d 2011-10-24 matt: (set! tests (filter (lambda (test)(file-exists? (conc test "/testconfig"))) tests)) 59034f6b4d 2011-10-24 matt: (set! test-names (append test-names 59034f6b4d 2011-10-24 matt: (map (lambda (testp) 59034f6b4d 2011-10-24 matt: (last (string-split testp "/"))) 59034f6b4d 2011-10-24 matt: tests))))) 59034f6b4d 2011-10-24 matt: (string-split test-patts ",")) 59034f6b4d 2011-10-24 matt: 59034f6b4d 2011-10-24 matt: ;; now remove duplicates 59034f6b4d 2011-10-24 matt: (set! test-names (delete-duplicates test-names)) 59034f6b4d 2011-10-24 matt: 59034f6b4d 2011-10-24 matt: (debug:print 0 "INFO: test names " test-names) 59034f6b4d 2011-10-24 matt: 59034f6b4d 2011-10-24 matt: ;; now add non-directly referenced dependencies (i.e. waiton) 59034f6b4d 2011-10-24 matt: ;; could cache all these since they need to be read again ... 59034f6b4d 2011-10-24 matt: ;; FIXME SOMEDAY 59034f6b4d 2011-10-24 matt: (for-each 59034f6b4d 2011-10-24 matt: (lambda (test-name) 59034f6b4d 2011-10-24 matt: (let* ((config (test:get-testconfig test-name #f)) 59034f6b4d 2011-10-24 matt: (waiton (config-lookup config "requirements" "waiton"))) 59034f6b4d 2011-10-24 matt: (if (and waiton (not (member waiton test-names))) 59034f6b4d 2011-10-24 matt: (set! test-names (append test-names (list waiton)))))) 59034f6b4d 2011-10-24 matt: test-names) 59034f6b4d 2011-10-24 matt: f97980cf8c 2011-10-23 matt: ;; on the first pass or call to run-tests set FAILS to NOT_STARTED if f97980cf8c 2011-10-23 matt: ;; -keepgoing is specified f97980cf8c 2011-10-23 matt: (if (and (eq? *passnum* 0) f97980cf8c 2011-10-23 matt: keepgoing) f97980cf8c 2011-10-23 matt: (begin f97980cf8c 2011-10-23 matt: ;; have to delete test records where NOT_STARTED since they can cause -keepgoing to f97980cf8c 2011-10-23 matt: ;; get stuck due to becoming inaccessible from a failed test. I.e. if test B depends f97980cf8c 2011-10-23 matt: ;; on test A but test B reached the point on being registered as NOT_STARTED and test f97980cf8c 2011-10-23 matt: ;; A failed for some reason then on re-run using -keepgoing the run can never complete. f97980cf8c 2011-10-23 matt: (db:delete-tests-in-state db run-id "NOT_STARTED") f97980cf8c 2011-10-23 matt: (db:set-tests-state-status db run-id test-names #f "FAIL" "NOT_STARTED" "FAIL"))) f97980cf8c 2011-10-23 matt: (set! *passnum* (+ *passnum* 1)) f97980cf8c 2011-10-23 matt: (let loop ((numtimes 0)) f97980cf8c 2011-10-23 matt: (for-each f97980cf8c 2011-10-23 matt: (lambda (test-name) f97980cf8c 2011-10-23 matt: (if (runs:can-run-more-tests db) 59034f6b4d 2011-10-24 matt: (run:test db run-id runname test-name keyvallst item-patts flags) f97980cf8c 2011-10-23 matt: )) f97980cf8c 2011-10-23 matt: (tests:sort-by-priority-and-waiton test-names)) f97980cf8c 2011-10-23 matt: ;; (run-waiting-tests db) f97980cf8c 2011-10-23 matt: (if keepgoing f97980cf8c 2011-10-23 matt: (let ((estrem (db:estimated-tests-remaining db run-id))) f97980cf8c 2011-10-23 matt: (if (and (> estrem 0) f97980cf8c 2011-10-23 matt: (eq? *globalexitstatus* 0)) f97980cf8c 2011-10-23 matt: (begin f97980cf8c 2011-10-23 matt: (debug:print 1 "Keep going, estimated " estrem " tests remaining to run, will continue in 3 seconds ...") f97980cf8c 2011-10-23 matt: (sleep 3) f97980cf8c 2011-10-23 matt: (run-waiting-tests db) f97980cf8c 2011-10-23 matt: (loop (+ numtimes 1))))))))) f97980cf8c 2011-10-23 matt: 59034f6b4d 2011-10-24 matt: (define (run:test db run-id runname test-name keyvallst item-patts flags) f97980cf8c 2011-10-23 matt: (debug:print 1 "Launching test " test-name) f97980cf8c 2011-10-23 matt: ;; All these vars might be referenced by the testconfig file reader f97980cf8c 2011-10-23 matt: (setenv "MT_TEST_NAME" test-name) ;; f97980cf8c 2011-10-23 matt: (setenv "MT_RUNNAME" runname) f97980cf8c 2011-10-23 matt: (set-megatest-env-vars db run-id) ;; these may be needed by the launching process f97980cf8c 2011-10-23 matt: (change-directory *toppath*) f97980cf8c 2011-10-23 matt: (let* ((test-path (conc *toppath* "/tests/" test-name)) ;; could use test:get-testconfig here ... f97980cf8c 2011-10-23 matt: (test-configf (conc test-path "/testconfig")) f97980cf8c 2011-10-23 matt: (testexists (and (file-exists? test-configf)(file-read-access? test-configf))) f97980cf8c 2011-10-23 matt: (test-conf (if testexists (read-config test-configf #f #t) (make-hash-table))) f97980cf8c 2011-10-23 matt: (waiton (let ((w (config-lookup test-conf "requirements" "waiton"))) f97980cf8c 2011-10-23 matt: (if (string? w)(string-split w)'()))) 59034f6b4d 2011-10-24 matt: (force (hash-table-ref/default flags "-force" #f)) 59034f6b4d 2011-10-24 matt: (rerun (hash-table-ref/default flags "-rerun" #f)) 59034f6b4d 2011-10-24 matt: (keepgoing (hash-table-ref/default flags "-keepgoing" #f)) f97980cf8c 2011-10-23 matt: ;; Are these tags still used? I don't think so... f97980cf8c 2011-10-23 matt: ;;(tags (let ((t (config-lookup test-conf "setup" "tags"))) f97980cf8c 2011-10-23 matt: ;; ;; we want our tags to be separated by commas and fully delimited by commas f97980cf8c 2011-10-23 matt: ;; ;; so that queries with "like" can tie to the commas at either end of each tag f97980cf8c 2011-10-23 matt: ;; ;; while also allowing the end user to freely use spaces and commas to separate tags f97980cf8c 2011-10-23 matt: ;; (if (string? t)(string-substitute (regexp "[,\\s]+") "," (conc "," t ",") #t) f97980cf8c 2011-10-23 matt: ;; '())))) f97980cf8c 2011-10-23 matt: ) f97980cf8c 2011-10-23 matt: (if (not testexists) f97980cf8c 2011-10-23 matt: ;; if the test is ill defined spit out an error but keep going (different from how done previously f97980cf8c 2011-10-23 matt: (debug:print 0 "ERROR: Can't find config file " test-configf) f97980cf8c 2011-10-23 matt: ;; put top vars into convenient variables and open the db f97980cf8c 2011-10-23 matt: (let* (;; db is always at *toppath*/db/megatest.db f97980cf8c 2011-10-23 matt: (items (hash-table-ref/default test-conf "items" '())) f97980cf8c 2011-10-23 matt: (itemstable (hash-table-ref/default test-conf "itemstable" '())) f97980cf8c 2011-10-23 matt: (allitems (if (or (not (null? items))(not (null? itemstable))) f97980cf8c 2011-10-23 matt: (append (item-assoc->item-list items) f97980cf8c 2011-10-23 matt: (item-table->item-list itemstable)) f97980cf8c 2011-10-23 matt: '(()))) ;; a list with one null list is a test with no items f97980cf8c 2011-10-23 matt: (runconfigf (conc *toppath* "/runconfigs.config"))) f97980cf8c 2011-10-23 matt: (debug:print 1 "items: ") f97980cf8c 2011-10-23 matt: (if (>= *verbosity* 1)(pp allitems)) f97980cf8c 2011-10-23 matt: (if (>= *verbosity* 5) f97980cf8c 2011-10-23 matt: (begin f97980cf8c 2011-10-23 matt: (print "items: ")(pp (item-assoc->item-list items)) f97980cf8c 2011-10-23 matt: (print "itemstable: ")(pp (item-table->item-list itemstable)))) f97980cf8c 2011-10-23 matt: f97980cf8c 2011-10-23 matt: ;; Comments are loaded by the test run, not at launch time (in general) f97980cf8c 2011-10-23 matt: ;;(if (args:get-arg "-m") f97980cf8c 2011-10-23 matt: ;; (db:set-comment-for-run db run-id (args:get-arg "-m"))) f97980cf8c 2011-10-23 matt: f97980cf8c 2011-10-23 matt: ;; Here is where the test_meta table is best updated f97980cf8c 2011-10-23 matt: (runs:update-test_meta db test-name test-conf) f97980cf8c 2011-10-23 matt: f97980cf8c 2011-10-23 matt: ;; braindead work-around for poorly specified allitems list BUG!!! FIXME f97980cf8c 2011-10-23 matt: (if (null? allitems)(set! allitems '(()))) f97980cf8c 2011-10-23 matt: (let loop ((itemdat (car allitems)) f97980cf8c 2011-10-23 matt: (tal (cdr allitems))) f97980cf8c 2011-10-23 matt: ;; (lambda (itemdat) ;;; ((ripeness "overripe") (temperature "cool") (season "summer")) f97980cf8c 2011-10-23 matt: ;; Handle lists of items f97980cf8c 2011-10-23 matt: (let* ((item-path (item-list->path itemdat)) ;; (string-intersperse (map cadr itemdat) "/")) f97980cf8c 2011-10-23 matt: (new-test-path (string-intersperse (cons test-path (map cadr itemdat)) "/")) f97980cf8c 2011-10-23 matt: (new-test-name (if (equal? item-path "") test-name (conc test-name "/" item-path))) ;; just need it to be unique f97980cf8c 2011-10-23 matt: (testdat #f) f97980cf8c 2011-10-23 matt: (num-running (db:get-count-tests-running db)) f97980cf8c 2011-10-23 matt: (max-concurrent-jobs (config-lookup *configdat* "setup" "max_concurrent_jobs")) f97980cf8c 2011-10-23 matt: (parent-test (and (not (null? items))(equal? item-path ""))) f97980cf8c 2011-10-23 matt: (single-test (and (null? items) (equal? item-path ""))) f97980cf8c 2011-10-23 matt: (item-test (not (equal? item-path ""))) f97980cf8c 2011-10-23 matt: ;; look through all the item-patts if defined, format is patt1,patt2,patt3 ... wildcard is % f97980cf8c 2011-10-23 matt: (item-matches (if item-patts f97980cf8c 2011-10-23 matt: (let ((res #f)) f97980cf8c 2011-10-23 matt: (for-each f97980cf8c 2011-10-23 matt: (lambda (patt) a1371db27a 2011-10-24 matt: (if (string-search (glob->regexp a1371db27a 2011-10-24 matt: (string-translate patt "%" "*")) a1371db27a 2011-10-24 matt: item-path) f97980cf8c 2011-10-23 matt: (set! res #t))) a1371db27a 2011-10-24 matt: (string-split item-patts ",")) a1371db27a 2011-10-24 matt: res) a1371db27a 2011-10-24 matt: #t))) f97980cf8c 2011-10-23 matt: (debug:print 3 "max-concurrent-jobs: " max-concurrent-jobs ", num-running: " num-running) f97980cf8c 2011-10-23 matt: (if (and item-matches (runs:can-run-more-tests db)) f97980cf8c 2011-10-23 matt: (begin f97980cf8c 2011-10-23 matt: (let loop2 ((ts (db:get-test-info db run-id test-name item-path)) ;; #f) f97980cf8c 2011-10-23 matt: (ct 0)) f97980cf8c 2011-10-23 matt: (if (and (not ts) f97980cf8c 2011-10-23 matt: (< ct 10)) f97980cf8c 2011-10-23 matt: (begin f97980cf8c 2011-10-23 matt: (register-test db run-id test-name item-path) f97980cf8c 2011-10-23 matt: ;; Why did I set the comment here?!? POSSIBLE BUG BUT I'M REMOVING IT FOR NOW 10/23/2011 f97980cf8c 2011-10-23 matt: ;; (db:test-set-comment db run-id test-name item-path "") f97980cf8c 2011-10-23 matt: (loop2 (db:get-test-info db run-id test-name item-path) f97980cf8c 2011-10-23 matt: (+ ct 1))) f97980cf8c 2011-10-23 matt: (if ts f97980cf8c 2011-10-23 matt: (set! testdat ts) f97980cf8c 2011-10-23 matt: (begin f97980cf8c 2011-10-23 matt: (debug:print 0 "WARNING: Couldn't register test " test-name " with item path " item-path ", skipping") f97980cf8c 2011-10-23 matt: (if (not (null? tal)) f97980cf8c 2011-10-23 matt: (loop (car tal)(cdr tal))))))) f97980cf8c 2011-10-23 matt: (change-directory test-path) f97980cf8c 2011-10-23 matt: ;; this block is here only to inform the user early on f97980cf8c 2011-10-23 matt: (if (file-exists? runconfigf) f97980cf8c 2011-10-23 matt: (setup-env-defaults db runconfigf run-id *already-seen-runconfig-info*) f97980cf8c 2011-10-23 matt: (debug:print 0 "WARNING: You do not have a run config file: " runconfigf)) f97980cf8c 2011-10-23 matt: (debug:print 4 "run-id: " run-id " test-name: " test-name " item-path: " item-path " testdat: " (test:get-status testdat) " test-state: " (test:get-state testdat)) 59034f6b4d 2011-10-24 matt: (case (if force ;; (args:get-arg "-force") f97980cf8c 2011-10-23 matt: 'NOT_STARTED f97980cf8c 2011-10-23 matt: (if testdat f97980cf8c 2011-10-23 matt: (string->symbol (test:get-state testdat)) f97980cf8c 2011-10-23 matt: 'failed-to-insert)) f97980cf8c 2011-10-23 matt: ((failed-to-insert) f97980cf8c 2011-10-23 matt: (debug:print 0 "ERROR: Failed to insert the record into the db")) f97980cf8c 2011-10-23 matt: ((NOT_STARTED COMPLETED) f97980cf8c 2011-10-23 matt: (debug:print 6 "Got here, " (test:get-state testdat)) f97980cf8c 2011-10-23 matt: (let ((runflag #f)) f97980cf8c 2011-10-23 matt: (cond f97980cf8c 2011-10-23 matt: ;; i.e. this is the parent test to a suite of items, never "run" it f97980cf8c 2011-10-23 matt: (parent-test f97980cf8c 2011-10-23 matt: (set! runflag #f)) f97980cf8c 2011-10-23 matt: ;; -force, run no matter what f97980cf8c 2011-10-23 matt: (force (set! runflag #t)) f97980cf8c 2011-10-23 matt: ;; NOT_STARTED, run no matter what f97980cf8c 2011-10-23 matt: ((equal? (test:get-state testdat) "NOT_STARTED")(set! runflag #t)) f97980cf8c 2011-10-23 matt: ;; not -rerun and PASS, WARN or CHECK, do no run f97980cf8c 2011-10-23 matt: ((and (or (not rerun) f97980cf8c 2011-10-23 matt: keepgoing) f97980cf8c 2011-10-23 matt: (member (test:get-status testdat) '("PASS" "WARN" "CHECK"))) f97980cf8c 2011-10-23 matt: (set! runflag #f)) f97980cf8c 2011-10-23 matt: ;; -rerun and status is one of the specifed, run it f97980cf8c 2011-10-23 matt: ((and rerun f97980cf8c 2011-10-23 matt: (let ((rerunlst (string-split rerun ","))) ;; FAIL, f97980cf8c 2011-10-23 matt: (member (test:get-status testdat) rerunlst))) f97980cf8c 2011-10-23 matt: (set! runflag #t)) f97980cf8c 2011-10-23 matt: ;; -keepgoing, do not rerun FAIL f97980cf8c 2011-10-23 matt: ((and keepgoing f97980cf8c 2011-10-23 matt: (member (test:get-status testdat) '("FAIL"))) f97980cf8c 2011-10-23 matt: (set! runflag #f)) f97980cf8c 2011-10-23 matt: ((and (not rerun) f97980cf8c 2011-10-23 matt: (member (test:get-status testdat) '("FAIL" "n/a"))) f97980cf8c 2011-10-23 matt: (set! runflag #t)) f97980cf8c 2011-10-23 matt: (else (set! runflag #f))) f97980cf8c 2011-10-23 matt: (debug:print 6 "RUNNING => runflag: " runflag " STATE: " (test:get-state testdat) " STATUS: " (test:get-status testdat)) f97980cf8c 2011-10-23 matt: (if (not runflag) f97980cf8c 2011-10-23 matt: (if (not parent-test) f97980cf8c 2011-10-23 matt: (debug:print 1 "NOTE: Not starting test " new-test-name " as it is state \"COMPLETED\" and status \"" (test:get-status testdat) "\", use -force to override")) f97980cf8c 2011-10-23 matt: (let* ((get-prereqs-cmd (lambda () f97980cf8c 2011-10-23 matt: (db-get-prereqs-not-met db run-id waiton))) ;; check before running .... f97980cf8c 2011-10-23 matt: (launch-cmd (lambda () 98de2c2f8d 2011-10-24 matt: (launch-test db run-id runname test-conf keyvallst test-name test-path itemdat))) f97980cf8c 2011-10-23 matt: (testrundat (list get-prereqs-cmd launch-cmd))) f97980cf8c 2011-10-23 matt: (if (or force f97980cf8c 2011-10-23 matt: (let ((preqs-not-yet-met ((car testrundat)))) f97980cf8c 2011-10-23 matt: (debug:print 2 "Preqrequesites for " test-name ": " preqs-not-yet-met) f97980cf8c 2011-10-23 matt: (null? preqs-not-yet-met))) ;; are there any tests that must be run before this one... f97980cf8c 2011-10-23 matt: (if (not ((cadr testrundat))) ;; this is the line that launches the test to the remote host f97980cf8c 2011-10-23 matt: (begin f97980cf8c 2011-10-23 matt: (print "ERROR: Failed to launch the test. Exiting as soon as possible") f97980cf8c 2011-10-23 matt: (set! *globalexitstatus* 1) ;; f97980cf8c 2011-10-23 matt: (process-signal (current-process-id) signal/kill) f97980cf8c 2011-10-23 matt: ;(exit 1) f97980cf8c 2011-10-23 matt: )) f97980cf8c 2011-10-23 matt: (if (not keepgoing) f97980cf8c 2011-10-23 matt: (hash-table-set! *waiting-queue* new-test-name testrundat))))))) f97980cf8c 2011-10-23 matt: ((KILLED) f97980cf8c 2011-10-23 matt: (debug:print 1 "NOTE: " new-test-name " is already running or was explictly killed, use -force to launch it.")) f97980cf8c 2011-10-23 matt: ((LAUNCHED REMOTEHOSTSTART RUNNING) f97980cf8c 2011-10-23 matt: (if (> (- (current-seconds)(+ (db:test-get-event_time testdat) f97980cf8c 2011-10-23 matt: (db:test-get-run_duration testdat))) f97980cf8c 2011-10-23 matt: 100) ;; i.e. no update for more than 100 seconds f97980cf8c 2011-10-23 matt: (begin f97980cf8c 2011-10-23 matt: (debug:print 0 "WARNING: Test " test-name " appears to be dead. Forcing it to state INCOMPLETE and status STUCK/DEAD") f97980cf8c 2011-10-23 matt: (test-set-status! db run-id test-name "INCOMPLETE" "STUCK/DEAD" itemdat "Test is stuck or dead" #f)) f97980cf8c 2011-10-23 matt: (debug:print 2 "NOTE: " test-name " is already running"))) f97980cf8c 2011-10-23 matt: (else (debug:print 0 "ERROR: Failed to launch test " new-test-name ". Unrecognised state " (test:get-state testdat)))))) f97980cf8c 2011-10-23 matt: (if (not (null? tal)) f97980cf8c 2011-10-23 matt: (loop (car tal)(cdr tal))))))))) f97980cf8c 2011-10-23 matt: f97980cf8c 2011-10-23 matt: ;;====================================================================== f97980cf8c 2011-10-23 matt: ;; END OF NEW STUFF f97980cf8c 2011-10-23 matt: ;;====================================================================== a72100abbd 2011-10-12 matt: bcc1c96231 2011-07-11 mrwellan: (define (get-dir-up-n dir . params) bcc1c96231 2011-07-11 mrwellan: (let ((dparts (string-split dir "/")) bcc1c96231 2011-07-11 mrwellan: (count (if (null? params) 1 (car params)))) 79c34d7700 2011-05-11 matt: (conc "/" (string-intersperse bcc1c96231 2011-07-11 mrwellan: (take dparts (- (length dparts) count)) 79c34d7700 2011-05-11 matt: "/")))) 09102f8425 2011-05-11 matt: ;; Remove runs 09102f8425 2011-05-11 matt: ;; fields are passing in through 09102f8425 2011-05-11 matt: (define (runs:remove-runs db runnamepatt testpatt itempatt) 09102f8425 2011-05-11 matt: (let* ((keys (db-get-keys db)) 09102f8425 2011-05-11 matt: (rundat (runs:get-runs-by-patt db keys runnamepatt)) 09102f8425 2011-05-11 matt: (header (vector-ref rundat 0)) 09102f8425 2011-05-11 matt: (runs (vector-ref rundat 1))) bcc1c96231 2011-07-11 mrwellan: (debug:print 1 "Header: " header) 09102f8425 2011-05-11 matt: (for-each 09102f8425 2011-05-11 matt: (lambda (run) 09102f8425 2011-05-11 matt: (let ((runkey (string-intersperse (map (lambda (k) 94a65715c9 2011-09-05 matt: (db:get-value-by-header run header (vector-ref k 0))) keys) "/")) 94a65715c9 2011-09-05 matt: (dirs-to-remove (make-hash-table))) d73b2c1642 2011-06-27 mrwellan: (let* ((run-id (db:get-value-by-header run header "id") ) a72100abbd 2011-10-12 matt: (tests (db-get-tests-for-run db (db:get-value-by-header run header "id") testpatt itempatt '() '())) 5411a1be29 2011-05-11 mrwellan: (lasttpath "/does/not/exist/I/hope")) 94a65715c9 2011-09-05 matt: 09102f8425 2011-05-11 matt: (if (not (null? tests)) 09102f8425 2011-05-11 matt: (begin bcc1c96231 2011-07-11 mrwellan: (debug:print 1 "Removing tests for run: " runkey " " (db:get-value-by-header run header "runname")) 09102f8425 2011-05-11 matt: (for-each 09102f8425 2011-05-11 matt: (lambda (test) bcc1c96231 2011-07-11 mrwellan: (let* ((item-path (db:test-get-item-path test)) bcc1c96231 2011-07-11 mrwellan: (test-name (db:test-get-testname test)) bcc1c96231 2011-07-11 mrwellan: (run-dir (db:test-get-rundir test))) bcc1c96231 2011-07-11 mrwellan: (debug:print 1 " " (db:test-get-testname test) " id: " (db:test-get-id test) " " item-path) bcc1c96231 2011-07-11 mrwellan: (db:delete-test-records db (db:test-get-id test)) bcc1c96231 2011-07-11 mrwellan: (if (> (string-length run-dir) 5) ;; bad heuristic but should prevent /tmp /home etc. bcc1c96231 2011-07-11 mrwellan: (let ((fullpath run-dir)) ;; "/" (db:test-get-item-path test)))) bcc1c96231 2011-07-11 mrwellan: (set! lasttpath fullpath) 94a65715c9 2011-09-05 matt: (hash-table-set! dirs-to-remove fullpath #t) 94a65715c9 2011-09-05 matt: ;; The following was the safe delete code but it was not being exectuted. 94a65715c9 2011-09-05 matt: ;; (let* ((dirs-count (+ 1 (length keys)(length (string-split item-path "/")))) 94a65715c9 2011-09-05 matt: ;; (dir-to-rem (get-dir-up-n fullpath dirs-count)) 94a65715c9 2011-09-05 matt: ;; (remainingd (string-substitute (regexp (conc "^" dir-to-rem "/")) "" fullpath)) 94a65715c9 2011-09-05 matt: ;; (cmd (conc "cd " dir-to-rem "; rmdir -p " remainingd ))) 94a65715c9 2011-09-05 matt: ;; (if (file-exists? fullpath) 94a65715c9 2011-09-05 matt: ;; (begin 94a65715c9 2011-09-05 matt: ;; (debug:print 1 cmd) 94a65715c9 2011-09-05 matt: ;; (system cmd))) 94a65715c9 2011-09-05 matt: ;; )) 94a65715c9 2011-09-05 matt: )))) bcc1c96231 2011-07-11 mrwellan: tests))) 94a65715c9 2011-09-05 matt: 94a65715c9 2011-09-05 matt: ;; look though the dirs-to-remove for candidates for removal. Do this after deleting the records 94a65715c9 2011-09-05 matt: ;; for each test in case we get killed. That should minimize the detritus left on disk 94a65715c9 2011-09-05 matt: ;; process the dirs from longest string length to shortest 94a65715c9 2011-09-05 matt: (for-each 94a65715c9 2011-09-05 matt: (lambda (dir-to-remove) 94a65715c9 2011-09-05 matt: (if (file-exists? dir-to-remove) 94a65715c9 2011-09-05 matt: (let ((dir-in-db '())) 94a65715c9 2011-09-05 matt: (sqlite3:for-each-row 94a65715c9 2011-09-05 matt: (lambda (dir) 94a65715c9 2011-09-05 matt: (set! dir-in-db (cons dir dir-in-db))) 94a65715c9 2011-09-05 matt: db "SELECT rundir FROM tests WHERE rundir LIKE ?;" 94a65715c9 2011-09-05 matt: (conc "%" dir-to-remove "%")) ;; yes, I'm going to bail if there is anything like this dir in the db 94a65715c9 2011-09-05 matt: (if (null? dir-in-db) 94a65715c9 2011-09-05 matt: (begin 94a65715c9 2011-09-05 matt: (debug:print 2 "Removing directory with zero db references: " dir-to-remove) 94a65715c9 2011-09-05 matt: (system (conc "rm -rf " dir-to-remove)) 94a65715c9 2011-09-05 matt: (hash-table-delete! dirs-to-remove dir-to-remove)) 94a65715c9 2011-09-05 matt: (debug:print 2 "Skipping removal of " dir-to-remove " for now as it still has references in the database"))))) 94a65715c9 2011-09-05 matt: (sort (hash-table-keys dirs-to-remove) (lambda (a b)(> (string-length a)(string-length b))))) 94a65715c9 2011-09-05 matt: 94a65715c9 2011-09-05 matt: ;; remove the run if zero tests remain a72100abbd 2011-10-12 matt: (let ((remtests (db-get-tests-for-run db (db:get-value-by-header run header "id") #f #f '() '()))) 79c34d7700 2011-05-11 matt: (if (null? remtests) ;; no more tests remaining 79c34d7700 2011-05-11 matt: (let* ((dparts (string-split lasttpath "/")) 79c34d7700 2011-05-11 matt: (runpath (conc "/" (string-intersperse 79c34d7700 2011-05-11 matt: (take dparts (- (length dparts) 1)) 79c34d7700 2011-05-11 matt: "/")))) bcc1c96231 2011-07-11 mrwellan: (debug:print 1 "Removing run: " runkey " " (db:get-value-by-header run header "runname")) 79c34d7700 2011-05-11 matt: (db:delete-run db run-id) 79c34d7700 2011-05-11 matt: ;; need to figure out the path to the run dir and remove it if empty bcc1c96231 2011-07-11 mrwellan: ;; (if (null? (glob (conc runpath "/*"))) bcc1c96231 2011-07-11 mrwellan: ;; (begin bcc1c96231 2011-07-11 mrwellan: ;; (debug:print 1 "Removing run dir " runpath) bcc1c96231 2011-07-11 mrwellan: ;; (system (conc "rmdir -p " runpath)))) bcc1c96231 2011-07-11 mrwellan: )))) bcc1c96231 2011-07-11 mrwellan: )) 09102f8425 2011-05-11 matt: runs))) d7ffcddcac 2011-08-11 matt: d7ffcddcac 2011-08-11 matt: ;;====================================================================== d7ffcddcac 2011-08-11 matt: ;; Routines for manipulating runs d7ffcddcac 2011-08-11 matt: ;;====================================================================== d7ffcddcac 2011-08-11 matt: d7ffcddcac 2011-08-11 matt: ;; Since many calls to a run require pretty much the same setup d7ffcddcac 2011-08-11 matt: ;; this wrapper is used to reduce the replication of code d7ffcddcac 2011-08-11 matt: (define (general-run-call switchname action-desc proc) d7ffcddcac 2011-08-11 matt: (if (not (args:get-arg ":runname")) d7ffcddcac 2011-08-11 matt: (begin d7ffcddcac 2011-08-11 matt: (debug:print 0 "ERROR: Missing required parameter for " switchname ", you must specify the run name with :runname runname") d7ffcddcac 2011-08-11 matt: (exit 2)) c5b61052dd 2011-10-13 matt: (let ((db #f) c5b61052dd 2011-10-13 matt: (keys #f)) d7ffcddcac 2011-08-11 matt: (if (not (setup-for-run)) d7ffcddcac 2011-08-11 matt: (begin d7ffcddcac 2011-08-11 matt: (debug:print 0 "Failed to setup, exiting") d7ffcddcac 2011-08-11 matt: (exit 1))) c5b61052dd 2011-10-13 matt: (set! db (open-db)) c5b61052dd 2011-10-13 matt: (set! keys (db-get-keys db)) c5b61052dd 2011-10-13 matt: ;; have enough to process -target or -reqtarg here c5b61052dd 2011-10-13 matt: (if (args:get-arg "-reqtarg") c5b61052dd 2011-10-13 matt: (let* ((runconfigf (conc *toppath* "/runconfigs.config")) c5b61052dd 2011-10-13 matt: (runconfig (read-config runconfigf #f #f))) c5b61052dd 2011-10-13 matt: (if (hash-table-ref/default runconfig (args:get-arg "-reqtarg") #f) c5b61052dd 2011-10-13 matt: (keys:target-set-args keys (args:get-arg "-reqtarg") args:arg-hash) c5b61052dd 2011-10-13 matt: (begin c5b61052dd 2011-10-13 matt: (debug:print 0 "ERROR: [" (args:get-arg "-reqtarg") "] not found in " runconfigf) c5b61052dd 2011-10-13 matt: (sqlite3:finalize! db) c5b61052dd 2011-10-13 matt: (exit 1)))) c5b61052dd 2011-10-13 matt: (if (args:get-arg "-target") c5b61052dd 2011-10-13 matt: (keys:target-set-args keys (args:get-arg "-target" args:arg-hash) args:arg-hash))) d7ffcddcac 2011-08-11 matt: (if (not (car *configinfo*)) d7ffcddcac 2011-08-11 matt: (begin d7ffcddcac 2011-08-11 matt: (debug:print 0 "ERROR: Attempted to " action-desc " but run area config file not found") d7ffcddcac 2011-08-11 matt: (exit 1)) d7ffcddcac 2011-08-11 matt: ;; Extract out stuff needed in most or many calls d7ffcddcac 2011-08-11 matt: ;; here then call proc c5b61052dd 2011-10-13 matt: (let* ((keynames (map key:get-fieldname keys)) d7ffcddcac 2011-08-11 matt: (keyvallst (keys->vallist keys #t))) d7ffcddcac 2011-08-11 matt: (proc db keys keynames keyvallst))) d7ffcddcac 2011-08-11 matt: (sqlite3:finalize! db) d7ffcddcac 2011-08-11 matt: (set! *didsomething* #t)))) d7ffcddcac 2011-08-11 matt: ebea00e4bb 2011-08-24 mrwellan: ;;====================================================================== ebea00e4bb 2011-08-24 mrwellan: ;; Rollup runs ebea00e4bb 2011-08-24 mrwellan: ;;====================================================================== ebea00e4bb 2011-08-24 mrwellan: ebea00e4bb 2011-08-24 mrwellan: ;; Update the test_meta table for this test ebea00e4bb 2011-08-24 mrwellan: (define (runs:update-test_meta db test-name test-conf) ebea00e4bb 2011-08-24 mrwellan: (let ((currrecord (db:testmeta-get-record db test-name))) ebea00e4bb 2011-08-24 mrwellan: (if (not currrecord) ebea00e4bb 2011-08-24 mrwellan: (begin ebea00e4bb 2011-08-24 mrwellan: (set! currrecord (make-vector 10 #f)) ebea00e4bb 2011-08-24 mrwellan: (db:testmeta-add-record db test-name))) ebea00e4bb 2011-08-24 mrwellan: (for-each ebea00e4bb 2011-08-24 mrwellan: (lambda (key) ebea00e4bb 2011-08-24 mrwellan: (let* ((idx (cadr key)) ebea00e4bb 2011-08-24 mrwellan: (fld (car key)) ebea00e4bb 2011-08-24 mrwellan: (val (config-lookup test-conf "test_meta" fld))) ebea00e4bb 2011-08-24 mrwellan: (if (and val (not (equal? (vector-ref currrecord idx) val))) ebea00e4bb 2011-08-24 mrwellan: (begin ebea00e4bb 2011-08-24 mrwellan: (print "Updating " test-name " " fld " to " val) ebea00e4bb 2011-08-24 mrwellan: (db:testmeta-update-field db test-name fld val))))) ebea00e4bb 2011-08-24 mrwellan: '(("author" 2)("owner" 3)("description" 4)("reviewed" 5)("tags" 9))))) ebea00e4bb 2011-08-24 mrwellan: ebea00e4bb 2011-08-24 mrwellan: ;; Update test_meta for all tests ebea00e4bb 2011-08-24 mrwellan: (define (runs:update-all-test_meta db) ebea00e4bb 2011-08-24 mrwellan: (let ((test-names (get-all-legal-tests))) ebea00e4bb 2011-08-24 mrwellan: (for-each ebea00e4bb 2011-08-24 mrwellan: (lambda (test-name) ebea00e4bb 2011-08-24 mrwellan: (let* ((test-path (conc *toppath* "/tests/" test-name)) ebea00e4bb 2011-08-24 mrwellan: (test-configf (conc test-path "/testconfig")) ebea00e4bb 2011-08-24 mrwellan: (testexists (and (file-exists? test-configf)(file-read-access? test-configf))) ebea00e4bb 2011-08-24 mrwellan: ;; read configs with tricks turned off (i.e. no system) ebea00e4bb 2011-08-24 mrwellan: (test-conf (if testexists (read-config test-configf #f #f)(make-hash-table)))) ebea00e4bb 2011-08-24 mrwellan: (runs:update-test_meta db test-name test-conf))) ebea00e4bb 2011-08-24 mrwellan: test-names))) ebea00e4bb 2011-08-24 mrwellan: 94a65715c9 2011-09-05 matt: ;; This could probably be refactored into one complex query ... 94a65715c9 2011-09-05 matt: (define (runs:rollup-run db keys) a19566e0b3 2011-09-09 matt: (let* ((new-run-id (register-run db keys)) a19566e0b3 2011-09-09 matt: (prev-tests (test:get-matching-previous-test-run-records db new-run-id "%" "%")) a72100abbd 2011-10-12 matt: (curr-tests (db-get-tests-for-run db new-run-id "%" "%" '() '())) 94a65715c9 2011-09-05 matt: (curr-tests-hash (make-hash-table))) 41350e06ff 2011-10-14 matt: (db:update-run-event_time db new-run-id) 94a65715c9 2011-09-05 matt: ;; index the already saved tests by testname and itempath in curr-tests-hash 94a65715c9 2011-09-05 matt: (for-each 94a65715c9 2011-09-05 matt: (lambda (testdat) 94a65715c9 2011-09-05 matt: (let* ((testname (db:test-get-testname testdat)) 94a65715c9 2011-09-05 matt: (item-path (db:test-get-item-path testdat)) 94a65715c9 2011-09-05 matt: (full-name (conc testname "/" item-path))) 94a65715c9 2011-09-05 matt: (hash-table-set! curr-tests-hash full-name testdat))) 94a65715c9 2011-09-05 matt: curr-tests) 94a65715c9 2011-09-05 matt: ;; NOPE: Non-optimal approach. Try this instead. 94a65715c9 2011-09-05 matt: ;; 1. tests are received in a list, most recent first 94a65715c9 2011-09-05 matt: ;; 2. replace the rollup test with the new *always* d7ffcddcac 2011-08-11 matt: (for-each 94a65715c9 2011-09-05 matt: (lambda (testdat) 94a65715c9 2011-09-05 matt: (let* ((testname (db:test-get-testname testdat)) 94a65715c9 2011-09-05 matt: (item-path (db:test-get-item-path testdat)) 94a65715c9 2011-09-05 matt: (full-name (conc testname "/" item-path)) 94a65715c9 2011-09-05 matt: (prev-test-dat (hash-table-ref/default curr-tests-hash full-name #f)) 94a65715c9 2011-09-05 matt: (test-steps (db:get-steps-for-test db (db:test-get-id testdat))) 94a65715c9 2011-09-05 matt: (new-test-record #f)) 94a65715c9 2011-09-05 matt: ;; replace these with insert ... select 94a65715c9 2011-09-05 matt: (apply sqlite3:execute 94a65715c9 2011-09-05 matt: db a1371db27a 2011-10-24 matt: (conc "INSERT OR REPLACE INTO tests (run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment) " a1371db27a 2011-10-24 matt: "VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?);") 94a65715c9 2011-09-05 matt: new-run-id (cddr (vector->list testdat))) a72100abbd 2011-10-12 matt: (set! new-testdat (car (db-get-tests-for-run db new-run-id testname item-path '() '()))) 94a65715c9 2011-09-05 matt: (hash-table-set! curr-tests-hash full-name new-testdat) ;; this could be confusing, which record should go into the lookup table? 94a65715c9 2011-09-05 matt: ;; Now duplicate the test steps 94a65715c9 2011-09-05 matt: (debug:print 4 "Copying records in test_steps from test_id=" (db:test-get-id testdat) " to " (db:test-get-id new-testdat)) 94a65715c9 2011-09-05 matt: (sqlite3:execute 94a65715c9 2011-09-05 matt: db 94a65715c9 2011-09-05 matt: (conc "INSERT OR REPLACE INTO test_steps (test_id,stepname,state,status,event_time,comment) " 94a65715c9 2011-09-05 matt: "SELECT " (db:test-get-id new-testdat) ",stepname,state,status,event_time,comment FROM test_steps WHERE test_id=?;") 9bc4b32214 2011-09-06 matt: (db:test-get-id testdat)) 9bc4b32214 2011-09-06 matt: ;; Now duplicate the test data 9bc4b32214 2011-09-06 matt: (debug:print 4 "Copying records in test_data from test_id=" (db:test-get-id testdat) " to " (db:test-get-id new-testdat)) 9bc4b32214 2011-09-06 matt: (sqlite3:execute 9bc4b32214 2011-09-06 matt: db d90aea75ce 2011-09-13 mrwellan: (conc "INSERT OR REPLACE INTO test_data (test_id,category,variable,value,expected,tol,units,comment) " d90aea75ce 2011-09-13 mrwellan: "SELECT " (db:test-get-id new-testdat) ",category,variable,value,expected,tol,units,comment FROM test_data WHERE test_id=?;") 94a65715c9 2011-09-05 matt: (db:test-get-id testdat)) 94a65715c9 2011-09-05 matt: )) 94a65715c9 2011-09-05 matt: prev-tests))) 94a65715c9 2011-09-05 matt: 94a65715c9 2011-09-05 matt:
File Annotation