File Annotation
Not logged in
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)) ;; ?,?,? ...
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)))
39d81114d3 2011-08-31          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)))
94a65715c9 2011-09-05          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
ebea00e4bb 2011-08-24      mrwellan:     (let ((val (hash-table-ref/default otherdat ":first_err" #f)))
ebea00e4bb 2011-08-24      mrwellan:       (if val
ebea00e4bb 2011-08-24      mrwellan: 	  (sqlite3:execute db "UPDATE tests SET first_err=? WHERE run_id=? AND testname=? AND item_path=?;" val run-id test-name item-path)))
1eb40d3a48 2011-09-11          matt: 
ebea00e4bb 2011-08-24      mrwellan:     ;; :first_warn
ebea00e4bb 2011-08-24      mrwellan:     (let ((val (hash-table-ref/default otherdat ":first_warn" #f)))
ebea00e4bb 2011-08-24      mrwellan:       (if val
ebea00e4bb 2011-08-24      mrwellan: 	  (sqlite3:execute db "UPDATE tests SET first_warn=? WHERE run_id=? AND testname=? AND item_path=?;" val run-id test-name item-path)))
d406fee8c4 2011-09-12          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))
42b834da20 2011-08-02      mrwellan: 
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: 						 "&nbsp;"
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: 	    )))))
7f668b637d 2011-05-06      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-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)
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)))
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'),?);"
06c4198b8e 2011-09-26          matt: 			test-id teststep-name state-in status-in (if comment comment "")))
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)))))
d73b2c1642 2011-06-27      mrwellan: 
ae6dbecf17 2011-05-02          matt: (define (run-tests db test-names)
b5bfe140e0 2011-05-24          matt:   (let* ((keys        (db-get-keys db))
b5bfe140e0 2011-05-24          matt: 	 (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: 	     ))
c075ebd51b 2011-06-16      mrwellan:        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)))))))))
0d6213c6ea 2011-05-18          matt: 
0d6213c6ea 2011-05-18          matt: ;; VERY INEFFICIENT! Move stuff that should be done once up to calling proc
b5bfe140e0 2011-05-24          matt: (define (run-one-test db run-id test-name keyvallst)
bcc1c96231 2011-07-11      mrwellan:   (debug:print 1 "Launching test " test-name)
b5bfe140e0 2011-05-24          matt:   ;; All these vars might be referenced by the testconfig file reader
b5bfe140e0 2011-05-24          matt:   (setenv "MT_TEST_NAME" test-name) ;;
b5bfe140e0 2011-05-24          matt:   (setenv "MT_RUNNAME"   (args:get-arg ":runname"))
b5bfe140e0 2011-05-24          matt:   (set-megatest-env-vars db run-id) ;; these may be needed by the launching process
b5bfe140e0 2011-05-24          matt:   (change-directory *toppath*)
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)))
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
99f24d81d1 2011-09-26          matt: 				    (string-match (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 ()
d73b2c1642 2011-06-27      mrwellan: 						       (launch-test db run-id 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*)))))))
09102f8425 2011-05-11          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") )
d73b2c1642 2011-06-27      mrwellan: 		(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
d9ed52b665 2011-10-02          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))
d7ffcddcac 2011-08-11          matt:       (let ((db #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)))
d7ffcddcac 2011-08-11          matt: 	(set! db (open-db))
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
d7ffcddcac 2011-08-11          matt: 	    (let* ((keys       (db-get-keys db))
d7ffcddcac 2011-08-11          matt: 		   (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 "%" "%"))
a19566e0b3 2011-09-09          matt: 	 (curr-tests      (db-get-tests-for-run db new-run-id "%" "%"))
94a65715c9 2011-09-05          matt: 	 (curr-tests-hash (make-hash-table)))
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
a19566e0b3 2011-09-09          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,first_err,first_warn) "
a19566e0b3 2011-09-09          matt: 		      "VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?);")
94a65715c9 2011-09-05          matt: 		new-run-id (cddr (vector->list testdat)))
94a65715c9 2011-09-05          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: