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: 
e0c173490e 2011-10-09          matt: (use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking)
3469edbbf7 2011-10-09          matt: (import (prefix sqlite3 sqlite3:))
3469edbbf7 2011-10-09          matt: 
3469edbbf7 2011-10-09          matt: (declare (unit runs))
3469edbbf7 2011-10-09          matt: (declare (uses db))
3469edbbf7 2011-10-09          matt: (declare (uses common))
3469edbbf7 2011-10-09          matt: (declare (uses items))
3469edbbf7 2011-10-09          matt: (declare (uses runconfig))
47e2caaf9c 2011-11-17          matt: (declare (uses tests))
3469edbbf7 2011-10-09          matt: 
3469edbbf7 2011-10-09          matt: (include "common_records.scm")
3469edbbf7 2011-10-09          matt: (include "key_records.scm")
3469edbbf7 2011-10-09          matt: (include "db_records.scm")
e0c173490e 2011-10-09          matt: (include "run_records.scm")
3ca3391a4e 2011-11-26          matt: (include "test_records.scm")
09102f8425 2011-05-11          matt: 
09102f8425 2011-05-11          matt: ;; runs:get-runs-by-patt
09102f8425 2011-05-11          matt: ;; get runs by list of criteria
ae6dbecf17 2011-05-02          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)))
ae6dbecf17 2011-05-02          matt: 
e0c173490e 2011-10-09          matt: ;; ;; TODO: Converge this with db:get-test-info
e0c173490e 2011-10-09          matt: ;; (define (runs:get-test-info db run-id test-name item-path)
e0c173490e 2011-10-09          matt: ;;   (let ((res #f)) ;; (vector #f #f #f #f #f #f)))
e0c173490e 2011-10-09          matt: ;;     (sqlite3:for-each-row
e0c173490e 2011-10-09          matt: ;;      (lambda (id run-id test-name state status)
e0c173490e 2011-10-09          matt: ;;        (set! res (vector id run-id test-name state status item-path)))
e0c173490e 2011-10-09          matt: ;;      db "SELECT id,run_id,testname,state,status FROM tests WHERE run_id=? AND testname=? AND item_path=?;"
e0c173490e 2011-10-09          matt: ;;      run-id test-name item-path)
e0c173490e 2011-10-09          matt: ;;     res))
e0c173490e 2011-10-09          matt: 
e0c173490e 2011-10-09          matt: (define (runs:test-get-full-path test)
e0c173490e 2011-10-09          matt:   (let* ((testname (db:test-get-testname   test))
e0c173490e 2011-10-09          matt: 	 (itempath (db:test-get-item-path test)))
e0c173490e 2011-10-09          matt:     (conc testname (if (equal? itempath "") "" (conc "(" itempath ")")))))
e0c173490e 2011-10-09          matt: 
e0c173490e 2011-10-09          matt: 
e0c173490e 2011-10-09          matt: (define (set-megatest-env-vars db run-id)
e0c173490e 2011-10-09          matt:   (let ((keys (db-get-keys db)))
e0c173490e 2011-10-09          matt:     (for-each (lambda (key)
e0c173490e 2011-10-09          matt: 		(sqlite3:for-each-row
e0c173490e 2011-10-09          matt: 		 (lambda (val)
e0c173490e 2011-10-09          matt: 		   (debug:print 2 "setenv " (key:get-fieldname key) " " val)
e0c173490e 2011-10-09          matt: 		   (setenv (key:get-fieldname key) val))
ae6dbecf17 2011-05-02          matt: 		 db
e0c173490e 2011-10-09          matt: 		 (conc "SELECT " (key:get-fieldname key) " FROM runs WHERE id=?;")
e0c173490e 2011-10-09          matt: 		 run-id))
38766f7852 2011-12-05      mrwellan: 	      keys)
38766f7852 2011-12-05      mrwellan:     ;; Lets use this as an opportunity to put MT_RUNNAME in the environment
38766f7852 2011-12-05      mrwellan:     (sqlite3:for-each-row
38766f7852 2011-12-05      mrwellan:      (lambda (runname)
38766f7852 2011-12-05      mrwellan:        (setenv "MT_RUNNAME" runname))
38766f7852 2011-12-05      mrwellan:      db
38766f7852 2011-12-05      mrwellan:      "SELECT runname FROM runs WHERE id=?;"
38766f7852 2011-12-05      mrwellan:      run-id)
38766f7852 2011-12-05      mrwellan:     ))
e0c173490e 2011-10-09          matt: 
e0c173490e 2011-10-09          matt: (define (set-item-env-vars itemdat)
e0c173490e 2011-10-09          matt:   (for-each (lambda (item)
e0c173490e 2011-10-09          matt: 	      (debug:print 2 "setenv " (car item) " " (cadr item))
e0c173490e 2011-10-09          matt: 	      (setenv (car item) (cadr item)))
e0c173490e 2011-10-09          matt: 	    itemdat))
e0c173490e 2011-10-09          matt: 
3ca3391a4e 2011-11-26          matt: (define (runs:can-run-more-tests db test-record)
3ca3391a4e 2011-11-26          matt:   (let* ((tconfig                 (tests:testqueue-get-testconfig test-record))
3ca3391a4e 2011-11-26          matt: 	 (jobgroup                (config-lookup tconfig "requirements" "jobgroup"))
3ca3391a4e 2011-11-26          matt: 	 (num-running             (db:get-count-tests-running db))
3ca3391a4e 2011-11-26          matt: 	 (num-running-in-jobgroup (db:get-count-tests-running-in-jobgroup db jobgroup))
3ca3391a4e 2011-11-26          matt: 	 (max-concurrent-jobs     (config-lookup *configdat* "setup"     "max_concurrent_jobs"))
3ca3391a4e 2011-11-26          matt: 	 (job-group-limit         (config-lookup *configdat* "jobgroups" jobgroup)))
e0c173490e 2011-10-09          matt:     (debug:print 2 "max-concurrent-jobs: " max-concurrent-jobs ", num-running: " num-running)
e0c173490e 2011-10-09          matt:     (if (not (eq? 0 *globalexitstatus*))
e0c173490e 2011-10-09          matt: 	#f
3ca3391a4e 2011-11-26          matt: 	(let ((can-not-run-more (cond
3ca3391a4e 2011-11-26          matt: 				 ;; if max-concurrent-jobs is set and the number running is greater
3ca3391a4e 2011-11-26          matt: 				 ;; than it than cannot run more jobs
3ca3391a4e 2011-11-26          matt: 				 ((and max-concurrent-jobs
3ca3391a4e 2011-11-26          matt: 				       (string->number max-concurrent-jobs)
3ca3391a4e 2011-11-26          matt: 				       (>= num-running (string->number max-concurrent-jobs)))
3ca3391a4e 2011-11-26          matt: 				  (debug:print 0 "WARNING: Max running jobs exceeded, current number running: " num-running
3ca3391a4e 2011-11-26          matt: 					       ", max_concurrent_jobs: " max-concurrent-jobs)
3ca3391a4e 2011-11-26          matt: 				  #t)
3ca3391a4e 2011-11-26          matt: 				 ;; if job-group-limit is set and number of jobs in the group is greater
3ca3391a4e 2011-11-26          matt: 				 ;; than the limit then cannot run more jobs of this kind
3ca3391a4e 2011-11-26          matt: 				 ((and job-group-limit
3ca3391a4e 2011-11-26          matt: 				       (>= num-running-in-jobgroup job-group-limit))
3ca3391a4e 2011-11-26          matt: 				  (debug:print 1 "WARNING: number of jobs " num-running-in-jobgroup
3ca3391a4e 2011-11-26          matt: 					       " in " jobgroup " exceeded, will not run " (tests:testqueue-get-testname test-record))
3ca3391a4e 2011-11-26          matt: 				  #t)
3ca3391a4e 2011-11-26          matt: 				 (else #f))))
3ca3391a4e 2011-11-26          matt: 	  (not can-not-run-more)))))
59034f6b4d 2011-10-24          matt: 
59034f6b4d 2011-10-24          matt: ;;======================================================================
59034f6b4d 2011-10-24          matt: ;; New methodology. These routines will replace the above in time. For
59034f6b4d 2011-10-24          matt: ;; now the code is duplicated. This stuff is initially used in the monitor
59034f6b4d 2011-10-24          matt: ;; based code.
59034f6b4d 2011-10-24          matt: ;;======================================================================
59034f6b4d 2011-10-24          matt: 
59034f6b4d 2011-10-24          matt: ;; register a test run with the db
59034f6b4d 2011-10-24          matt: (define (runs:register-run db keys keyvallst runname state status user)
fa52f9444d 2011-10-26      mrwellan:   (debug:print 3 "runs:register-run, keys: " keys " keyvallst: " keyvallst " runname: " runname " state: " state " status: " status " user: " user)
59034f6b4d 2011-10-24          matt:   (let* ((keystr    (keys->keystr keys))
59034f6b4d 2011-10-24          matt: 	 (comma     (if (> (length keys) 0) "," ""))
59034f6b4d 2011-10-24          matt: 	 (andstr    (if (> (length keys) 0) " AND " ""))
59034f6b4d 2011-10-24          matt: 	 (valslots  (keys->valslots keys)) ;; ?,?,? ...
59034f6b4d 2011-10-24          matt: 	 (keyvals   (map cadr keyvallst))
59034f6b4d 2011-10-24          matt: 	 (allvals   (append (list runname state status user) keyvals))
59034f6b4d 2011-10-24          matt: 	 (qryvals   (append (list runname) keyvals))
59034f6b4d 2011-10-24          matt: 	 (key=?str  (string-intersperse (map (lambda (k)(conc (key:get-fieldname k) "=?")) keys) " AND ")))
59034f6b4d 2011-10-24          matt:     (debug:print 3 "keys: " keys " allvals: " allvals " keyvals: " keyvals)
59034f6b4d 2011-10-24          matt:     (debug:print 2 "NOTE: using target " (string-intersperse keyvals "/") " for this run")
59034f6b4d 2011-10-24          matt:     (if (and runname (null? (filter (lambda (x)(not x)) keyvals))) ;; there must be a better way to "apply and"
59034f6b4d 2011-10-24          matt: 	(let ((res #f))
59034f6b4d 2011-10-24          matt: 	  (apply sqlite3:execute db (conc "INSERT OR IGNORE INTO runs (runname,state,status,owner,event_time" comma keystr ") VALUES (?,?,?,?,strftime('%s','now')" comma valslots ");")
59034f6b4d 2011-10-24          matt: 		 allvals)
59034f6b4d 2011-10-24          matt: 	  (apply sqlite3:for-each-row
59034f6b4d 2011-10-24          matt: 	   (lambda (id)
59034f6b4d 2011-10-24          matt: 	     (set! res id))
59034f6b4d 2011-10-24          matt: 	   db
59034f6b4d 2011-10-24          matt: 	   (let ((qry (conc "SELECT id FROM runs WHERE (runname=? " andstr key=?str ");")))
59034f6b4d 2011-10-24          matt: 	     ;(debug:print 4 "qry: " qry)
59034f6b4d 2011-10-24          matt: 	     qry)
59034f6b4d 2011-10-24          matt: 	   qryvals)
59034f6b4d 2011-10-24          matt: 	  (sqlite3:execute db "UPDATE runs SET state=?,status=? WHERE id=?;" state status res)
59034f6b4d 2011-10-24          matt: 	  res)
59034f6b4d 2011-10-24          matt: 	(begin
59034f6b4d 2011-10-24          matt: 	  (debug:print 0 "ERROR: Called without all necessary keys")
59034f6b4d 2011-10-24          matt: 	  #f))))
59034f6b4d 2011-10-24          matt: 
59034f6b4d 2011-10-24          matt: ;; This is a duplicate of run-tests (which has been deprecated). Use this one instead of run tests.
59034f6b4d 2011-10-24          matt: ;; keyvals
59034f6b4d 2011-10-24          matt: (define (runs:run-tests db target runname test-patts item-patts user flags)
e0c173490e 2011-10-09          matt:   (let* ((keys        (db-get-keys db))
59034f6b4d 2011-10-24          matt: 	 (keyvallst   (keys:target->keyval keys target))
59034f6b4d 2011-10-24          matt: 	 (run-id      (runs:register-run db keys keyvallst runname "new" "n/a" user))  ;;  test-name)))
59034f6b4d 2011-10-24          matt: 	 (deferred    '()) ;; delay running these since they have a waiton clause
3ca3391a4e 2011-11-26          matt: 	 ;; keepgoing is the defacto modality now, will add hit-n-run a bit later
3ca3391a4e 2011-11-26          matt: 	 ;; (keepgoing   (hash-table-ref/default flags "-keepgoing" #f))
9d2d6dc7a4 2011-11-02          matt: 	 (test-names  '())
9d2d6dc7a4 2011-11-02          matt: 	 (runconfigf   (conc  *toppath* "/runconfigs.config"))
3ca3391a4e 2011-11-26          matt: 	 (required-tests '())
3ca3391a4e 2011-11-26          matt: 	 (test-records (make-hash-table)))
da715ac6ab 2011-11-03          matt: 
da715ac6ab 2011-11-03          matt:     (set-megatest-env-vars db run-id) ;; these may be needed by the launching process
9d2d6dc7a4 2011-11-02          matt: 
9d2d6dc7a4 2011-11-02          matt:     (if (file-exists? runconfigf)
da715ac6ab 2011-11-03          matt: 	(setup-env-defaults db runconfigf run-id *already-seen-runconfig-info* "pre-launch-env-vars")
9d2d6dc7a4 2011-11-02          matt: 	(debug:print 0 "WARNING: You do not have a run config file: " runconfigf))
9d2d6dc7a4 2011-11-02          matt: 
59034f6b4d 2011-10-24          matt:     ;; look up all tests matching the comma separated list of globs in
59034f6b4d 2011-10-24          matt:     ;; test-patts (using % as wildcard)
59034f6b4d 2011-10-24          matt:     (for-each
59034f6b4d 2011-10-24          matt:      (lambda (patt)
59034f6b4d 2011-10-24          matt:        (let ((tests (glob (conc *toppath* "/tests/" (string-translate patt "%" "*")))))
59034f6b4d 2011-10-24          matt: 	 (set! tests (filter (lambda (test)(file-exists? (conc test "/testconfig"))) tests))
59034f6b4d 2011-10-24          matt: 	 (set! test-names (append test-names
59034f6b4d 2011-10-24          matt: 				  (map (lambda (testp)
59034f6b4d 2011-10-24          matt: 					 (last (string-split testp "/")))
59034f6b4d 2011-10-24          matt: 				       tests)))))
3ca3391a4e 2011-11-26          matt:      (if test-patts (string-split test-patts ",")(list "%")))
59034f6b4d 2011-10-24          matt: 
9d2d6dc7a4 2011-11-02          matt:      ;; now remove duplicates
59034f6b4d 2011-10-24          matt:     (set! test-names (delete-duplicates test-names))
59034f6b4d 2011-10-24          matt: 
59034f6b4d 2011-10-24          matt:     (debug:print 0 "INFO: test names " test-names)
59034f6b4d 2011-10-24          matt: 
e0c173490e 2011-10-09          matt:     ;; on the first pass or call to run-tests set FAILS to NOT_STARTED if
e0c173490e 2011-10-09          matt:     ;; -keepgoing is specified
3ca3391a4e 2011-11-26          matt:     (if (eq? *passnum* 0)
ae6dbecf17 2011-05-02          matt: 	(begin
e0c173490e 2011-10-09          matt: 	  ;; have to delete test records where NOT_STARTED since they can cause -keepgoing to
e0c173490e 2011-10-09          matt: 	  ;; get stuck due to becoming inaccessible from a failed test. I.e. if test B depends
e0c173490e 2011-10-09          matt: 	  ;; on test A but test B reached the point on being registered as NOT_STARTED and test
e0c173490e 2011-10-09          matt: 	  ;; A failed for some reason then on re-run using -keepgoing the run can never complete.
e0c173490e 2011-10-09          matt: 	  (db:delete-tests-in-state db run-id "NOT_STARTED")
e0c173490e 2011-10-09          matt: 	  (db:set-tests-state-status db run-id test-names #f "FAIL" "NOT_STARTED" "FAIL")))
3ca3391a4e 2011-11-26          matt: 
3ca3391a4e 2011-11-26          matt:     ;; now add non-directly referenced dependencies (i.e. waiton)
3ca3391a4e 2011-11-26          matt:     (if (not (null? test-names))
3ca3391a4e 2011-11-26          matt: 	(let loop ((hed (car test-names))
3ca3391a4e 2011-11-26          matt: 		   (tal (cdr test-names)))         ;; 'return-procs tells the config reader to prep running system but return a proc
3ca3391a4e 2011-11-26          matt: 	  (let* ((config  (test:get-testconfig hed 'return-procs))
3ca3391a4e 2011-11-26          matt: 		 (waitons (string-split (let ((w (config-lookup config "requirements" "waiton")))
3ca3391a4e 2011-11-26          matt: 					  (if w w "")))))
38766f7852 2011-12-05      mrwellan: 	    ;; (items   (items:get-items-from-config config)))
3ca3391a4e 2011-11-26          matt: 	    (if (not (hash-table-ref/default test-records hed #f))
3ca3391a4e 2011-11-26          matt: 		(hash-table-set! test-records
3ca3391a4e 2011-11-26          matt: 				 hed (vector hed     ;; 0
3ca3391a4e 2011-11-26          matt: 					     config  ;; 1
3ca3391a4e 2011-11-26          matt: 					     waitons ;; 2
3ca3391a4e 2011-11-26          matt: 					     (config-lookup config "requirements" "priority")     ;; priority 3
3ca3391a4e 2011-11-26          matt: 					     (let ((items      (hash-table-ref/default config "items" #f)) ;; items 4
3ca3391a4e 2011-11-26          matt: 						   (itemstable (hash-table-ref/default config "itemstable" #f)))
3ca3391a4e 2011-11-26          matt: 					       ;; if either items or items table is a proc return it so test running
3ca3391a4e 2011-11-26          matt: 					       ;; process can know to call items:get-items-from-config
3ca3391a4e 2011-11-26          matt: 					       ;; if either is a list and none is a proc go ahead and call get-items
3ca3391a4e 2011-11-26          matt: 					       ;; otherwise return #f - this is not an iterated test
3ca3391a4e 2011-11-26          matt: 					       (cond
7bbcfa08c8 2011-12-06          matt: 						((procedure? items)
7bbcfa08c8 2011-12-06          matt: 						 (debug:print 4 "INFO: items is a procedure, will calc later")
7bbcfa08c8 2011-12-06          matt: 						 items)            ;; calc later
7bbcfa08c8 2011-12-06          matt: 						((procedure? itemstable)
7bbcfa08c8 2011-12-06          matt: 						 (debug:print 4 "INFO: itemstable is a procedure, will calc later")
7bbcfa08c8 2011-12-06          matt: 						 itemstable)       ;; calc later
7bbcfa08c8 2011-12-06          matt: 						((filter (lambda (x)
7bbcfa08c8 2011-12-06          matt: 							   (let ((val (car x)))
7bbcfa08c8 2011-12-06          matt: 							     (if (procedure? val) val #f)))
7bbcfa08c8 2011-12-06          matt: 							 (append (if (list? items) items '())
7bbcfa08c8 2011-12-06          matt: 								 (if (list? itemstable) itemstable '())))
7bbcfa08c8 2011-12-06          matt: 						 'have-procedure)
3ca3391a4e 2011-11-26          matt: 						((or (list? items)(list? itemstable)) ;; calc now
7bbcfa08c8 2011-12-06          matt: 						 (debug:print 4 "INFO: items and itemstable are lists, calc now\n"
7bbcfa08c8 2011-12-06          matt: 							      "    items: " items " itemstable: " itemstable)
3ca3391a4e 2011-11-26          matt: 						 (items:get-items-from-config config))
3ca3391a4e 2011-11-26          matt: 						(else #f)))                           ;; not iterated
3ca3391a4e 2011-11-26          matt: 					     #f      ;; itemsdat 5
3ca3391a4e 2011-11-26          matt: 					     ;; #f      ;; spare
3ca3391a4e 2011-11-26          matt: 					     )))
3ca3391a4e 2011-11-26          matt: 	    (for-each
3ca3391a4e 2011-11-26          matt: 	     (lambda (waiton)
3ca3391a4e 2011-11-26          matt: 	       (if (and waiton (not (member waiton test-names)))
3ca3391a4e 2011-11-26          matt: 		   (begin
3ca3391a4e 2011-11-26          matt: 		     (set! required-tests (cons waiton required-tests))
2de3c08fbd 2011-12-07      mrwellan: 		     (set! test-names (cons waiton test-names))))) ;; was an append, now a cons
3ca3391a4e 2011-11-26          matt: 	     waitons)
3ca3391a4e 2011-11-26          matt: 	    (let ((remtests (delete-duplicates (append waitons tal))))
3ca3391a4e 2011-11-26          matt: 	      (if (not (null? remtests))
3ca3391a4e 2011-11-26          matt: 		  (loop (car remtests)(cdr remtests)))))))
3ca3391a4e 2011-11-26          matt: 
3ca3391a4e 2011-11-26          matt:     (if (not (null? required-tests))
3ca3391a4e 2011-11-26          matt: 	(debug:print 1 "INFO: Adding " required-tests " to the run queue"))
3ca3391a4e 2011-11-26          matt:     ;; NOTE: these are all parent tests, items are not expanded yet.
3c6e3ca6c4 2011-12-06          matt:     (runs:run-tests-queue db run-id runname test-records keyvallst flags)
3c6e3ca6c4 2011-12-06          matt:     (debug:print 4 "INFO: All done by here")))
3ca3391a4e 2011-11-26          matt: 
3ca3391a4e 2011-11-26          matt: (define (runs:run-tests-queue db run-id runname test-records keyvallst flags)
3ca3391a4e 2011-11-26          matt:     ;; At this point the list of parent tests is expanded
3ca3391a4e 2011-11-26          matt:     ;; NB// Should expand items here and then insert into the run queue.
3ca3391a4e 2011-11-26          matt:   (debug:print 5 "test-records: " test-records ", keyvallst: " keyvallst)
3ca3391a4e 2011-11-26          matt:   (let ((sorted-test-names (tests:sort-by-priority-and-waiton test-records))
3ca3391a4e 2011-11-26          matt: 	(item-patts        (hash-table-ref/default flags "-itempatt" #f)))
3ca3391a4e 2011-11-26          matt:     (let loop (; (numtimes 0) ;; shouldn't need this
3ca3391a4e 2011-11-26          matt: 	       (hed         (car sorted-test-names))
3ca3391a4e 2011-11-26          matt: 	       (tal         (cdr sorted-test-names)))
3ca3391a4e 2011-11-26          matt:       (let* ((test-record (hash-table-ref test-records hed))
3ca3391a4e 2011-11-26          matt: 	     (tconfig     (tests:testqueue-get-testconfig test-record))
3ca3391a4e 2011-11-26          matt: 	     (waitons     (tests:testqueue-get-waitons    test-record))
3ca3391a4e 2011-11-26          matt: 	     (priority    (tests:testqueue-get-priority   test-record))
3ca3391a4e 2011-11-26          matt: 	     (itemdat     (tests:testqueue-get-itemdat    test-record))
3ca3391a4e 2011-11-26          matt: 	     (items       (tests:testqueue-get-items      test-record))
3ca3391a4e 2011-11-26          matt: 	     (item-path   (item-list->path itemdat)))
3ca3391a4e 2011-11-26          matt: 	(debug:print 6
3ca3391a4e 2011-11-26          matt: 		     "itemdat:     " itemdat
3ca3391a4e 2011-11-26          matt: 		     "\n  items:     " items
3ca3391a4e 2011-11-26          matt: 		     "\n  item-path: " item-path)
3ca3391a4e 2011-11-26          matt: 	(cond
3ca3391a4e 2011-11-26          matt: 	 ((not items) ;; when false the test is ok to be handed off to launch (but not before)
3ca3391a4e 2011-11-26          matt: 	  (let ((have-resources  (runs:can-run-more-tests db test-record)) ;; look at the test jobgroup and tot jobs running
3ca3391a4e 2011-11-26          matt: 		(prereqs-not-met (db:get-prereqs-not-met db run-id waitons item-path)))
5b8b902667 2011-12-05      mrwellan: 	    ;; Don't know at this time if the test have been launched at some time in the past
5b8b902667 2011-12-05      mrwellan: 	    ;; i.e. is this a re-launch?
3ca3391a4e 2011-11-26          matt: 	    (if (and have-resources
3ca3391a4e 2011-11-26          matt: 		     (null? prereqs-not-met))
3ca3391a4e 2011-11-26          matt: 		;; no loop - drop though and use the loop at the bottom
3ca3391a4e 2011-11-26          matt: 		(run:test db run-id runname keyvallst test-record flags #f)
3ca3391a4e 2011-11-26          matt: 		;; else the run is stuck, temporarily or permanently
3ca3391a4e 2011-11-26          matt: 		(let ((newtal (append tal (list hed))))
3ca3391a4e 2011-11-26          matt: 		  ;; couldn't run, take a breather
2de3c08fbd 2011-12-07      mrwellan: 		  (thread-sleep! 4)
428bbd9b36 2011-12-05      mrwellan: 		  (loop (car newtal)(cdr newtal))))))
3ca3391a4e 2011-11-26          matt: 
3ca3391a4e 2011-11-26          matt: 	 ;; case where an items came in as a list been processed
3ca3391a4e 2011-11-26          matt: 	 ((and (list? items)     ;; thus we know our items are already calculated
3ca3391a4e 2011-11-26          matt: 	       (not   itemdat)) ;; and not yet expanded into the list of things to be done
3ca3391a4e 2011-11-26          matt: 	  (if (>= *verbosity* 1)(pp items))
3ca3391a4e 2011-11-26          matt: 	  ;; (if (>= *verbosity* 5)
3ca3391a4e 2011-11-26          matt: 	  ;;     (begin
3ca3391a4e 2011-11-26          matt: 	  ;;       (print "items: ")     (pp (item-assoc->item-list items))
3ca3391a4e 2011-11-26          matt: 	  ;;       (print "itemstable: ")(pp (item-table->item-list itemstable))))
3ca3391a4e 2011-11-26          matt: 	  (for-each
3ca3391a4e 2011-11-26          matt: 	   (lambda (my-itemdat)
3ca3391a4e 2011-11-26          matt: 	     (let* ((new-test-record (let ((newrec (make-tests:testqueue)))
3ca3391a4e 2011-11-26          matt: 				       (vector-copy! test-record newrec)
3ca3391a4e 2011-11-26          matt: 				       newrec))
3ca3391a4e 2011-11-26          matt: 		    (my-item-path (item-list->path my-itemdat))
3ca3391a4e 2011-11-26          matt: 		    (item-matches (if item-patts       ;; here we are filtering for matches with -itempatt
3ca3391a4e 2011-11-26          matt: 				      (let ((res #f))	 ;; look through all the item-patts if defined, format is patt1,patt2,patt3 ... wildcard is %
3ca3391a4e 2011-11-26          matt: 					(for-each
3ca3391a4e 2011-11-26          matt: 					 (lambda (patt)
3ca3391a4e 2011-11-26          matt: 					   (if (string-search (glob->regexp
3ca3391a4e 2011-11-26          matt: 							       (string-translate patt "%" "*"))
3ca3391a4e 2011-11-26          matt: 							      item-path)
3ca3391a4e 2011-11-26          matt: 					       (set! res #t)))
3ca3391a4e 2011-11-26          matt: 					 (string-split item-patts ","))
3ca3391a4e 2011-11-26          matt: 					res)
3ca3391a4e 2011-11-26          matt: 				      #t)))
3ca3391a4e 2011-11-26          matt: 	       (if item-matches ;; yes, we want to process this item
3ca3391a4e 2011-11-26          matt: 		   (let ((newtestname (conc hed "/" my-item-path)))
3ca3391a4e 2011-11-26          matt: 		     (tests:testqueue-set-items!   new-test-record #f)
3ca3391a4e 2011-11-26          matt: 		     (tests:testqueue-set-itemdat! new-test-record my-itemdat)
3ca3391a4e 2011-11-26          matt: 		     (hash-table-set! test-records newtestname new-test-record)
3ca3391a4e 2011-11-26          matt: 		     (set! tal (cons newtestname tal)))))) ;; since these are itemized create new test names testname/itempath
3ca3391a4e 2011-11-26          matt: 	   items)
3ca3391a4e 2011-11-26          matt: 	  (loop (car tal)(cdr tal)))
3ca3391a4e 2011-11-26          matt: 
3ca3391a4e 2011-11-26          matt: 	 ;; if items is a proc then need to run items:get-items-from-config, get the list and loop
3ca3391a4e 2011-11-26          matt: 	 ;;    - but only do that if resources exist to kick off the job
7bbcfa08c8 2011-12-06          matt: 	 ((or (procedure? items)(eq? items 'have-procedure))
2de3c08fbd 2011-12-07      mrwellan: 	  (if (and (runs:can-run-more-tests db test-record)
2de3c08fbd 2011-12-07      mrwellan: 		   (null? (db:get-prereqs-not-met db run-id waitons item-path)))
2de3c08fbd 2011-12-07      mrwellan: 	      (let ((test-name (tests:testqueue-get-testname test-record)))
2de3c08fbd 2011-12-07      mrwellan: 		(setenv "MT_TEST_NAME" test-name) ;;
2de3c08fbd 2011-12-07      mrwellan: 		(setenv "MT_RUNNAME"   runname)
2de3c08fbd 2011-12-07      mrwellan: 		(set-megatest-env-vars db run-id) ;; these may be needed by the launching process
2de3c08fbd 2011-12-07      mrwellan: 		(let ((items-list (items:get-items-from-config tconfig)))
2de3c08fbd 2011-12-07      mrwellan: 		  (if (list? items-list)
2de3c08fbd 2011-12-07      mrwellan: 		      (begin
2de3c08fbd 2011-12-07      mrwellan: 			(tests:testqueue-set-items! test-record items-list)
2de3c08fbd 2011-12-07      mrwellan: 			(loop hed tal))
2de3c08fbd 2011-12-07      mrwellan: 		      (begin
2de3c08fbd 2011-12-07      mrwellan: 			(debug:print 0 "ERROR: The proc from reading the setup did not yield a list - please report this")
2de3c08fbd 2011-12-07      mrwellan: 			(exit 1)))))
3ca3391a4e 2011-11-26          matt: 	      (let ((newtal (append tal (list hed))))
3ca3391a4e 2011-11-26          matt: 		;; if can't run more tests, lets take a breather
3ca3391a4e 2011-11-26          matt: 		(thread-sleep! 1)
3ca3391a4e 2011-11-26          matt: 		(loop (car newtal)(cdr newtal)))))
3ca3391a4e 2011-11-26          matt: 
3ca3391a4e 2011-11-26          matt: 	 ;; this case should not happen, added to help catch any bugs
3ca3391a4e 2011-11-26          matt: 	 ((and (list? items) itemdat)
3ca3391a4e 2011-11-26          matt: 	  (debug:print 0 "ERROR: Should not have a list of items in a test and the itemspath set - please report this")
7bbcfa08c8 2011-12-06          matt: 	  (exit 1))))
3ca3391a4e 2011-11-26          matt: 
7bbcfa08c8 2011-12-06          matt:       ;; we get here on "drop through" - loop for next test in queue
7bbcfa08c8 2011-12-06          matt:       (if (null? tal)
3c6e3ca6c4 2011-12-06          matt: 	  (begin
3c6e3ca6c4 2011-12-06          matt: 	    ;; FIXME!!!! THIS SHOULD NOT REQUIRE AN EXIT!!!!!!!
3c6e3ca6c4 2011-12-06          matt: 	    (debug:print 1 "INFO: All tests launched, exiting")
3c6e3ca6c4 2011-12-06          matt: 	    (exit 0))
7bbcfa08c8 2011-12-06          matt: 	  (loop (car tal)(cdr tal))))))
3ca3391a4e 2011-11-26          matt: 
3ca3391a4e 2011-11-26          matt: ;; parent-test is there as a placeholder for when parent-tests can be run as a setup step
3ca3391a4e 2011-11-26          matt: (define (run:test db run-id runname keyvallst test-record flags parent-test)
e0c173490e 2011-10-09          matt:   ;; All these vars might be referenced by the testconfig file reader
3ca3391a4e 2011-11-26          matt:   (let* ((test-name    (tests:testqueue-get-testname   test-record))
3ca3391a4e 2011-11-26          matt: 	 (test-waitons (tests:testqueue-get-waitons    test-record))
3ca3391a4e 2011-11-26          matt: 	 (test-conf    (tests:testqueue-get-testconfig test-record))
3ca3391a4e 2011-11-26          matt: 	 (itemdat      (tests:testqueue-get-itemdat    test-record))
3ca3391a4e 2011-11-26          matt: 	 (test-path    (conc *toppath* "/tests/" test-name)) ;; could use test:get-testconfig here ...
59034f6b4d 2011-10-24          matt: 	 (force        (hash-table-ref/default flags "-force" #f))
59034f6b4d 2011-10-24          matt: 	 (rerun        (hash-table-ref/default flags "-rerun" #f))
59034f6b4d 2011-10-24          matt: 	 (keepgoing    (hash-table-ref/default flags "-keepgoing" #f))
3ca3391a4e 2011-11-26          matt: 	 (item-path     ""))
3ca3391a4e 2011-11-26          matt:     (debug:print 5
3ca3391a4e 2011-11-26          matt: 		 "test-config: " (hash-table->alist test-conf)
3ca3391a4e 2011-11-26          matt: 		 "\n   itemdat: " itemdat
3ca3391a4e 2011-11-26          matt: 		 )
3ca3391a4e 2011-11-26          matt:     ;; setting itemdat to a list if it is #f
3ca3391a4e 2011-11-26          matt:     (if (not itemdat)(set! itemdat '()))
3ca3391a4e 2011-11-26          matt:     (set! item-path (item-list->path itemdat))
5b8b902667 2011-12-05      mrwellan:     (debug:print 2 "Attempting to launch test " test-name "/" item-path)
3ca3391a4e 2011-11-26          matt:     (setenv "MT_TEST_NAME" test-name) ;;
3ca3391a4e 2011-11-26          matt:     (setenv "MT_RUNNAME"   runname)
3ca3391a4e 2011-11-26          matt:     (set-megatest-env-vars db run-id) ;; these may be needed by the launching process
3ca3391a4e 2011-11-26          matt:     (change-directory *toppath*)
3ca3391a4e 2011-11-26          matt: 
3ca3391a4e 2011-11-26          matt:     ;; Here is where the test_meta table is best updated
3ca3391a4e 2011-11-26          matt:     (runs:update-test_meta db test-name test-conf)
3ca3391a4e 2011-11-26          matt: 
3ca3391a4e 2011-11-26          matt:     ;; (lambda (itemdat) ;;; ((ripeness "overripe") (temperature "cool") (season "summer"))
3ca3391a4e 2011-11-26          matt:     (let* ((new-test-path (string-intersperse (cons test-path (map cadr itemdat)) "/"))
3ca3391a4e 2011-11-26          matt: 	   (new-test-name (if (equal? item-path "") test-name (conc test-name "/" item-path))) ;; just need it to be unique
3ca3391a4e 2011-11-26          matt: 	   (testdat       (db:get-test-info db run-id test-name item-path)))
3ca3391a4e 2011-11-26          matt:       (if (not testdat)
3ca3391a4e 2011-11-26          matt: 	  (begin
3ca3391a4e 2011-11-26          matt: 	    (register-test db run-id test-name item-path)
3ca3391a4e 2011-11-26          matt: 	    (set! testdat (db:get-test-info db run-id test-name item-path))))
3ca3391a4e 2011-11-26          matt:       (change-directory test-path)
3ca3391a4e 2011-11-26          matt:       (case (if force ;; (args:get-arg "-force")
3ca3391a4e 2011-11-26          matt: 		'NOT_STARTED
3ca3391a4e 2011-11-26          matt: 		(if testdat
3ca3391a4e 2011-11-26          matt: 		    (string->symbol (test:get-state testdat))
3ca3391a4e 2011-11-26          matt: 		    'failed-to-insert))
3ca3391a4e 2011-11-26          matt: 	((failed-to-insert)
3ca3391a4e 2011-11-26          matt: 	 (debug:print 0 "ERROR: Failed to insert the record into the db"))
3ca3391a4e 2011-11-26          matt: 	((NOT_STARTED COMPLETED)
3ca3391a4e 2011-11-26          matt: 	 (debug:print 6 "Got here, " (test:get-state testdat))
3ca3391a4e 2011-11-26          matt: 	 (let ((runflag #f))
3ca3391a4e 2011-11-26          matt: 	   (cond
3ca3391a4e 2011-11-26          matt: 	    ;; -force, run no matter what
3ca3391a4e 2011-11-26          matt: 	    (force (set! runflag #t))
3ca3391a4e 2011-11-26          matt: 	    ;; NOT_STARTED, run no matter what
3ca3391a4e 2011-11-26          matt: 	    ((equal? (test:get-state testdat) "NOT_STARTED")(set! runflag #t))
3ca3391a4e 2011-11-26          matt: 	    ;; not -rerun and PASS, WARN or CHECK, do no run
3ca3391a4e 2011-11-26          matt: 	    ((and (or (not rerun)
3ca3391a4e 2011-11-26          matt: 		      keepgoing)
5b8b902667 2011-12-05      mrwellan: 		  ;; Require to force re-run for COMPLETED or *anything* + PASS,WARN or CHECK
5b8b902667 2011-12-05      mrwellan: 		  (or (member (test:get-status testdat) '("PASS" "WARN" "CHECK"))
5b8b902667 2011-12-05      mrwellan: 		      (member (test:get-state  testdat) '("COMPLETED"))))
3ca3391a4e 2011-11-26          matt: 	     (set! runflag #f))
3ca3391a4e 2011-11-26          matt: 	    ;; -rerun and status is one of the specifed, run it
3ca3391a4e 2011-11-26          matt: 	    ((and rerun
3ca3391a4e 2011-11-26          matt: 		  (let ((rerunlst (string-split rerun ","))) ;; FAIL,
3ca3391a4e 2011-11-26          matt: 		    (member (test:get-status testdat) rerunlst)))
3ca3391a4e 2011-11-26          matt: 	     (set! runflag #t))
3ca3391a4e 2011-11-26          matt: 	    ;; -keepgoing, do not rerun FAIL
3ca3391a4e 2011-11-26          matt: 	    ((and keepgoing
3ca3391a4e 2011-11-26          matt: 		  (member (test:get-status testdat) '("FAIL")))
3ca3391a4e 2011-11-26          matt: 	     (set! runflag #f))
3ca3391a4e 2011-11-26          matt: 	    ((and (not rerun)
3ca3391a4e 2011-11-26          matt: 		  (member (test:get-status testdat) '("FAIL" "n/a")))
3ca3391a4e 2011-11-26          matt: 	     (set! runflag #t))
3ca3391a4e 2011-11-26          matt: 	    (else (set! runflag #f)))
3ca3391a4e 2011-11-26          matt: 	   (debug:print 6 "RUNNING => runflag: " runflag " STATE: " (test:get-state testdat) " STATUS: " (test:get-status testdat))
3ca3391a4e 2011-11-26          matt: 	   (if (not runflag)
3ca3391a4e 2011-11-26          matt: 	       (if (not parent-test)
5b8b902667 2011-12-05      mrwellan: 		   (debug:print 1 "NOTE: Not starting test " new-test-name " as it is state \"" (test:get-state testdat)
5b8b902667 2011-12-05      mrwellan: 				"\" and status \"" (test:get-status testdat) "\", use -rerun \"" (test:get-state testdat) "\" or -force to override"))
3ca3391a4e 2011-11-26          matt: 	       ;; NOTE: No longer be checking prerequisites here! Will never get here unless prereqs are
3ca3391a4e 2011-11-26          matt: 	       ;;       already met.
3ca3391a4e 2011-11-26          matt: 	       (if (not (launch-test db run-id runname test-conf keyvallst test-name test-path itemdat flags))
3ca3391a4e 2011-11-26          matt: 		   (begin
3ca3391a4e 2011-11-26          matt: 		     (print "ERROR: Failed to launch the test. Exiting as soon as possible")
3ca3391a4e 2011-11-26          matt: 		     (set! *globalexitstatus* 1) ;;
3ca3391a4e 2011-11-26          matt: 		     (process-signal (current-process-id) signal/kill))))))
3ca3391a4e 2011-11-26          matt: 	((KILLED)
3ca3391a4e 2011-11-26          matt: 	 (debug:print 1 "NOTE: " new-test-name " is already running or was explictly killed, use -force to launch it."))
3ca3391a4e 2011-11-26          matt: 	((LAUNCHED REMOTEHOSTSTART RUNNING)
3ca3391a4e 2011-11-26          matt: 	 (if (> (- (current-seconds)(+ (db:test-get-event_time testdat)
3ca3391a4e 2011-11-26          matt: 				       (db:test-get-run_duration testdat)))
3ca3391a4e 2011-11-26          matt: 		600) ;; i.e. no update for more than 600 seconds
3ca3391a4e 2011-11-26          matt: 	     (begin
3ca3391a4e 2011-11-26          matt: 	       (debug:print 0 "WARNING: Test " test-name " appears to be dead. Forcing it to state INCOMPLETE and status STUCK/DEAD")
3ca3391a4e 2011-11-26          matt: 	       (test-set-status! db run-id test-name "INCOMPLETE" "STUCK/DEAD" itemdat "Test is stuck or dead" #f))
3ca3391a4e 2011-11-26          matt: 	     (debug:print 2 "NOTE: " test-name " is already running")))
3ca3391a4e 2011-11-26          matt: 	(else       (debug:print 0 "ERROR: Failed to launch test " new-test-name ". Unrecognised state " (test:get-state testdat)))))))
f97980cf8c 2011-10-23          matt: 
f97980cf8c 2011-10-23          matt: ;;======================================================================
f97980cf8c 2011-10-23          matt: ;; END OF NEW STUFF
f97980cf8c 2011-10-23          matt: ;;======================================================================
09102f8425 2011-05-11          matt: 
94a65715c9 2011-09-05          matt: (define (get-dir-up-n dir . params)
94a65715c9 2011-09-05          matt:   (let ((dparts  (string-split dir "/"))
94a65715c9 2011-09-05          matt: 	(count   (if (null? params) 1 (car params))))
94a65715c9 2011-09-05          matt:     (conc "/" (string-intersperse
94a65715c9 2011-09-05          matt: 	       (take dparts (- (length dparts) count))
94a65715c9 2011-09-05          matt: 	       "/"))))
94a65715c9 2011-09-05          matt: ;; Remove runs
94a65715c9 2011-09-05          matt: ;; fields are passing in through
94a65715c9 2011-09-05          matt: (define (runs:remove-runs db runnamepatt testpatt itempatt)
09102f8425 2011-05-11          matt:   (let* ((keys        (db-get-keys db))
94a65715c9 2011-09-05          matt: 	 (rundat      (runs:get-runs-by-patt db keys runnamepatt))
94a65715c9 2011-09-05          matt: 	 (header      (vector-ref rundat 0))
94a65715c9 2011-09-05          matt: 	 (runs        (vector-ref rundat 1)))
94a65715c9 2011-09-05          matt:     (debug:print 1 "Header: " header)
94a65715c9 2011-09-05          matt:     (for-each
94a65715c9 2011-09-05          matt:      (lambda (run)
94a65715c9 2011-09-05          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)))
94a65715c9 2011-09-05          matt: 	 (let* ((run-id (db:get-value-by-header run header "id") )
a72100abbd 2011-10-12          matt: 		(tests  (db-get-tests-for-run db (db:get-value-by-header run header "id") testpatt itempatt '() '()))
94a65715c9 2011-09-05          matt: 		(lasttpath "/does/not/exist/I/hope"))
94a65715c9 2011-09-05          matt: 
94a65715c9 2011-09-05          matt: 	   (if (not (null? tests))
94a65715c9 2011-09-05          matt: 	       (begin
94a65715c9 2011-09-05          matt: 		 (debug:print 1 "Removing tests for run: " runkey " " (db:get-value-by-header run header "runname"))
94a65715c9 2011-09-05          matt: 		 (for-each
94a65715c9 2011-09-05          matt: 		  (lambda (test)
94a65715c9 2011-09-05          matt: 		    (let* ((item-path (db:test-get-item-path test))
94a65715c9 2011-09-05          matt: 			   (test-name (db:test-get-testname test))
94a65715c9 2011-09-05          matt: 			   (run-dir   (db:test-get-rundir test)))
94a65715c9 2011-09-05          matt: 		      (debug:print 1 "  " (db:test-get-testname test) " id: " (db:test-get-id test) " " item-path)
94a65715c9 2011-09-05          matt: 		      (db:delete-test-records db (db:test-get-id test))
94a65715c9 2011-09-05          matt: 		      (if (> (string-length run-dir) 5) ;; bad heuristic but should prevent /tmp /home etc.
94a65715c9 2011-09-05          matt: 			  (let ((fullpath run-dir)) ;; "/" (db:test-get-item-path test))))
94a65715c9 2011-09-05          matt: 			    (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: 			    ))))
94a65715c9 2011-09-05          matt: 		    tests)))
39d81114d3 2011-08-31          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)))))
39d81114d3 2011-08-31          matt: 
94a65715c9 2011-09-05          matt: 	   ;; remove the run if zero tests remain
a72100abbd 2011-10-12          matt: 	   (let ((remtests (db-get-tests-for-run db (db:get-value-by-header run header "id") #f #f '() '())))
79c34d7700 2011-05-11          matt: 	     (if (null? remtests) ;; no more tests remaining
79c34d7700 2011-05-11          matt: 		 (let* ((dparts  (string-split lasttpath "/"))
79c34d7700 2011-05-11          matt: 			(runpath (conc "/" (string-intersperse
79c34d7700 2011-05-11          matt: 					    (take dparts (- (length dparts) 1))
79c34d7700 2011-05-11          matt: 					    "/"))))
bcc1c96231 2011-07-11      mrwellan: 		   (debug:print 1 "Removing run: " runkey " " (db:get-value-by-header run header "runname"))
79c34d7700 2011-05-11          matt: 		   (db:delete-run db run-id)
79c34d7700 2011-05-11          matt: 		   ;; need to figure out the path to the run dir and remove it if empty
bcc1c96231 2011-07-11      mrwellan: 		   ;;    (if (null? (glob (conc runpath "/*")))
bcc1c96231 2011-07-11      mrwellan: 		   ;;        (begin
bcc1c96231 2011-07-11      mrwellan: 		   ;; 	 (debug:print 1 "Removing run dir " runpath)
bcc1c96231 2011-07-11      mrwellan: 		   ;; 	 (system (conc "rmdir -p " runpath))))
bcc1c96231 2011-07-11      mrwellan: 		   ))))
bcc1c96231 2011-07-11      mrwellan: 	 ))
09102f8425 2011-05-11          matt:      runs)))
d7ffcddcac 2011-08-11          matt: 
d7ffcddcac 2011-08-11          matt: ;;======================================================================
d7ffcddcac 2011-08-11          matt: ;; Routines for manipulating runs
d7ffcddcac 2011-08-11          matt: ;;======================================================================
d7ffcddcac 2011-08-11          matt: 
d7ffcddcac 2011-08-11          matt: ;; Since many calls to a run require pretty much the same setup
d7ffcddcac 2011-08-11          matt: ;; this wrapper is used to reduce the replication of code
d7ffcddcac 2011-08-11          matt: (define (general-run-call switchname action-desc proc)
3ca3391a4e 2011-11-26          matt:   (let ((runname (args:get-arg ":runname"))
3ca3391a4e 2011-11-26          matt: 	(target  (if (args:get-arg "-target")
3ca3391a4e 2011-11-26          matt: 		     (args:get-arg "-target")
3ca3391a4e 2011-11-26          matt: 		     (args:get-arg "-reqtarg"))))
3ca3391a4e 2011-11-26          matt:     (cond
3ca3391a4e 2011-11-26          matt:      ((not target)
3ca3391a4e 2011-11-26          matt:       (debug:print 0 "ERROR: Missing required parameter for " switchname ", you must specify the target with -target")
3ca3391a4e 2011-11-26          matt:       (exit 3))
3ca3391a4e 2011-11-26          matt:      ((not runname)
3ca3391a4e 2011-11-26          matt:       (debug:print 0 "ERROR: Missing required parameter for " switchname ", you must specify the run name with :runname runname")
3ca3391a4e 2011-11-26          matt:       (exit 3))
3ca3391a4e 2011-11-26          matt:      (else
c5b61052dd 2011-10-13          matt:       (let ((db   #f)
c5b61052dd 2011-10-13          matt: 	    (keys #f))
d7ffcddcac 2011-08-11          matt: 	(if (not (setup-for-run))
d7ffcddcac 2011-08-11          matt: 	    (begin
d7ffcddcac 2011-08-11          matt: 	      (debug:print 0 "Failed to setup, exiting")
d7ffcddcac 2011-08-11          matt: 	      (exit 1)))
c5b61052dd 2011-10-13          matt: 	(set! db   (open-db))
c5b61052dd 2011-10-13          matt: 	(set! keys (db-get-keys db))
c5b61052dd 2011-10-13          matt: 	;; have enough to process -target or -reqtarg here
c5b61052dd 2011-10-13          matt: 	(if (args:get-arg "-reqtarg")
da715ac6ab 2011-11-03          matt: 	    (let* ((runconfigf (conc  *toppath* "/runconfigs.config")) ;; DO NOT EVALUATE ALL
da715ac6ab 2011-11-03          matt: 		   (runconfig  (read-config runconfigf #f #f environ-patt: #f)))
c5b61052dd 2011-10-13          matt: 	      (if (hash-table-ref/default runconfig (args:get-arg "-reqtarg") #f)
c5b61052dd 2011-10-13          matt: 		  (keys:target-set-args keys (args:get-arg "-reqtarg") args:arg-hash)
c5b61052dd 2011-10-13          matt: 		  (begin
c5b61052dd 2011-10-13          matt: 		    (debug:print 0 "ERROR: [" (args:get-arg "-reqtarg") "] not found in " runconfigf)
c5b61052dd 2011-10-13          matt: 		    (sqlite3:finalize! db)
c5b61052dd 2011-10-13          matt: 		    (exit 1))))
c5b61052dd 2011-10-13          matt: 	    (if (args:get-arg "-target")
c5b61052dd 2011-10-13          matt: 		(keys:target-set-args keys (args:get-arg "-target" args:arg-hash) args:arg-hash)))
d7ffcddcac 2011-08-11          matt: 	(if (not (car *configinfo*))
d7ffcddcac 2011-08-11          matt: 	    (begin
d7ffcddcac 2011-08-11          matt: 	      (debug:print 0 "ERROR: Attempted to " action-desc " but run area config file not found")
d7ffcddcac 2011-08-11          matt: 	      (exit 1))
d7ffcddcac 2011-08-11          matt: 	    ;; Extract out stuff needed in most or many calls
d7ffcddcac 2011-08-11          matt: 	    ;; here then call proc
c5b61052dd 2011-10-13          matt: 	    (let* ((keynames   (map key:get-fieldname keys))
d7ffcddcac 2011-08-11          matt: 		   (keyvallst  (keys->vallist keys #t)))
3ca3391a4e 2011-11-26          matt: 	      (proc db target runname keys keynames keyvallst)))
d7ffcddcac 2011-08-11          matt: 	(sqlite3:finalize! db)
3ca3391a4e 2011-11-26          matt: 	(set! *didsomething* #t))))))
ebea00e4bb 2011-08-24      mrwellan: 
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)))
3ca3391a4e 2011-11-26          matt: 	 ;; (debug:print 5 "idx: " idx " fld: " fld " val: " val)
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)))
d7ffcddcac 2011-08-11          matt: 
94a65715c9 2011-09-05          matt: ;; This could probably be refactored into one complex query ...
fa52f9444d 2011-10-26      mrwellan: (define (runs:rollup-run db keys keyvallst runname user) ;; was target, now keyvallst
fa52f9444d 2011-10-26      mrwellan:   (debug:print 4 "runs:rollup-run, keys: " keys " keyvallst: " keyvallst " :runname " runname " user: " user)
fa52f9444d 2011-10-26      mrwellan:   (let* (; (keyvalllst      (keys:target->keyval keys target))
fa52f9444d 2011-10-26      mrwellan: 	 (new-run-id      (runs:register-run db keys keyvallst runname "new" "n/a" user))
a19566e0b3 2011-09-09          matt: 	 (prev-tests      (test:get-matching-previous-test-run-records db new-run-id "%" "%"))
a72100abbd 2011-10-12          matt: 	 (curr-tests      (db-get-tests-for-run db new-run-id "%" "%" '() '()))
94a65715c9 2011-09-05          matt: 	 (curr-tests-hash (make-hash-table)))
41350e06ff 2011-10-14          matt:     (db:update-run-event_time db new-run-id)
3ca3391a4e 2011-11-26          matt:     ;; index the already saved tests by testname and itemdat in curr-tests-hash
94a65715c9 2011-09-05          matt:     (for-each
94a65715c9 2011-09-05          matt:      (lambda (testdat)
94a65715c9 2011-09-05          matt:        (let* ((testname  (db:test-get-testname testdat))
94a65715c9 2011-09-05          matt: 	      (item-path (db:test-get-item-path testdat))
94a65715c9 2011-09-05          matt: 	      (full-name (conc testname "/" item-path)))
94a65715c9 2011-09-05          matt: 	 (hash-table-set! curr-tests-hash full-name testdat)))
94a65715c9 2011-09-05          matt:      curr-tests)
94a65715c9 2011-09-05          matt:     ;; NOPE: Non-optimal approach. Try this instead.
94a65715c9 2011-09-05          matt:     ;;   1. tests are received in a list, most recent first
94a65715c9 2011-09-05          matt:     ;;   2. replace the rollup test with the new *always*
d7ffcddcac 2011-08-11          matt:     (for-each
94a65715c9 2011-09-05          matt:      (lambda (testdat)
94a65715c9 2011-09-05          matt:        (let* ((testname  (db:test-get-testname testdat))
94a65715c9 2011-09-05          matt: 	      (item-path (db:test-get-item-path testdat))
94a65715c9 2011-09-05          matt: 	      (full-name (conc testname "/" item-path))
94a65715c9 2011-09-05          matt: 	      (prev-test-dat (hash-table-ref/default curr-tests-hash full-name #f))
94a65715c9 2011-09-05          matt: 	      (test-steps      (db:get-steps-for-test db (db:test-get-id testdat)))
94a65715c9 2011-09-05          matt: 	      (new-test-record #f))
94a65715c9 2011-09-05          matt: 	 ;; replace these with insert ... select
94a65715c9 2011-09-05          matt: 	 (apply sqlite3:execute
94a65715c9 2011-09-05          matt: 		db
a1371db27a 2011-10-24          matt: 		(conc "INSERT OR REPLACE INTO tests (run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment) "
a1371db27a 2011-10-24          matt: 		      "VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?);")
94a65715c9 2011-09-05          matt: 		new-run-id (cddr (vector->list testdat)))
a72100abbd 2011-10-12          matt: 	 (set! new-testdat (car (db-get-tests-for-run db new-run-id testname item-path '() '())))
94a65715c9 2011-09-05          matt: 	 (hash-table-set! curr-tests-hash full-name new-testdat) ;; this could be confusing, which record should go into the lookup table?
94a65715c9 2011-09-05          matt: 	 ;; Now duplicate the test steps
94a65715c9 2011-09-05          matt: 	 (debug:print 4 "Copying records in test_steps from test_id=" (db:test-get-id testdat) " to " (db:test-get-id new-testdat))
94a65715c9 2011-09-05          matt: 	 (sqlite3:execute
94a65715c9 2011-09-05          matt: 	  db
94a65715c9 2011-09-05          matt: 	  (conc "INSERT OR REPLACE INTO test_steps (test_id,stepname,state,status,event_time,comment) "
94a65715c9 2011-09-05          matt: 		"SELECT " (db:test-get-id new-testdat) ",stepname,state,status,event_time,comment FROM test_steps WHERE test_id=?;")
9bc4b32214 2011-09-06          matt: 	  (db:test-get-id testdat))
9bc4b32214 2011-09-06          matt: 	 ;; Now duplicate the test data
9bc4b32214 2011-09-06          matt: 	 (debug:print 4 "Copying records in test_data from test_id=" (db:test-get-id testdat) " to " (db:test-get-id new-testdat))
9bc4b32214 2011-09-06          matt: 	 (sqlite3:execute
9bc4b32214 2011-09-06          matt: 	  db
d90aea75ce 2011-09-13      mrwellan: 	  (conc "INSERT OR REPLACE INTO test_data (test_id,category,variable,value,expected,tol,units,comment) "
d90aea75ce 2011-09-13      mrwellan: 		"SELECT " (db:test-get-id new-testdat) ",category,variable,value,expected,tol,units,comment FROM test_data WHERE test_id=?;")
94a65715c9 2011-09-05          matt: 	  (db:test-get-id testdat))
94a65715c9 2011-09-05          matt: 	 ))
94a65715c9 2011-09-05          matt:      prev-tests)))
94a65715c9 2011-09-05          matt: 
94a65715c9 2011-09-05          matt: