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