ae6dbecf17 2011-05-02 matt: 0a116daff3 2012-04-02 mrwellan: ;; Copyright 2006-2012, 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: 3e2cee87de 2012-03-13 matt: (use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking (srfi 18)) 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)) ad71efd688 2012-02-24 matt: (declare (uses server)) 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: fa52f9444d 2011-10-26 mrwellan: (define (runs:test-get-full-path test) fa52f9444d 2011-10-26 mrwellan: (let* ((testname (db:test-get-testname test)) fa52f9444d 2011-10-26 mrwellan: (itempath (db:test-get-item-path test))) fa52f9444d 2011-10-26 mrwellan: (conc testname (if (equal? itempath "") "" (conc "(" itempath ")"))))) 39d81114d3 2011-08-31 matt: fa52f9444d 2011-10-26 mrwellan: fa52f9444d 2011-10-26 mrwellan: (define (set-megatest-env-vars db run-id) 2c8647e6a0 2012-02-26 matt: (let ((keys (rdb:get-keys db))) fa52f9444d 2011-10-26 mrwellan: (for-each (lambda (key) fa52f9444d 2011-10-26 mrwellan: (sqlite3:for-each-row fa52f9444d 2011-10-26 mrwellan: (lambda (val) fa52f9444d 2011-10-26 mrwellan: (debug:print 2 "setenv " (key:get-fieldname key) " " val) fa52f9444d 2011-10-26 mrwellan: (setenv (key:get-fieldname key) val)) fa52f9444d 2011-10-26 mrwellan: db fa52f9444d 2011-10-26 mrwellan: (conc "SELECT " (key:get-fieldname key) " FROM runs WHERE id=?;") fa52f9444d 2011-10-26 mrwellan: 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: )) fa52f9444d 2011-10-26 mrwellan: fa52f9444d 2011-10-26 mrwellan: (define (set-item-env-vars itemdat) fa52f9444d 2011-10-26 mrwellan: (for-each (lambda (item) fa52f9444d 2011-10-26 mrwellan: (debug:print 2 "setenv " (car item) " " (cadr item)) fa52f9444d 2011-10-26 mrwellan: (setenv (car item) (cadr item))) fa52f9444d 2011-10-26 mrwellan: itemdat)) fa52f9444d 2011-10-26 mrwellan: 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))) fa52f9444d 2011-10-26 mrwellan: (debug:print 2 "max-concurrent-jobs: " max-concurrent-jobs ", num-running: " num-running) fa52f9444d 2011-10-26 mrwellan: (if (not (eq? 0 *globalexitstatus*)) 39d81114d3 2011-08-31 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))))) fa52f9444d 2011-10-26 mrwellan: fa52f9444d 2011-10-26 mrwellan: ;;====================================================================== fa52f9444d 2011-10-26 mrwellan: ;; New methodology. These routines will replace the above in time. For fa52f9444d 2011-10-26 mrwellan: ;; now the code is duplicated. This stuff is initially used in the monitor fa52f9444d 2011-10-26 mrwellan: ;; based code. fa52f9444d 2011-10-26 mrwellan: ;;====================================================================== fa52f9444d 2011-10-26 mrwellan: fa52f9444d 2011-10-26 mrwellan: ;; register a test run with the db fa52f9444d 2011-10-26 mrwellan: (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) fa52f9444d 2011-10-26 mrwellan: (let* ((keystr (keys->keystr keys)) fa52f9444d 2011-10-26 mrwellan: (comma (if (> (length keys) 0) "," "")) fa52f9444d 2011-10-26 mrwellan: (andstr (if (> (length keys) 0) " AND " "")) fa52f9444d 2011-10-26 mrwellan: (valslots (keys->valslots keys)) ;; ?,?,? ... fa52f9444d 2011-10-26 mrwellan: (keyvals (map cadr keyvallst)) fa52f9444d 2011-10-26 mrwellan: (allvals (append (list runname state status user) keyvals)) fa52f9444d 2011-10-26 mrwellan: (qryvals (append (list runname) keyvals)) fa52f9444d 2011-10-26 mrwellan: (key=?str (string-intersperse (map (lambda (k)(conc (key:get-fieldname k) "=?")) keys) " AND "))) fa52f9444d 2011-10-26 mrwellan: (debug:print 3 "keys: " keys " allvals: " allvals " keyvals: " keyvals) fa52f9444d 2011-10-26 mrwellan: (debug:print 2 "NOTE: using target " (string-intersperse keyvals "/") " for this run") fa52f9444d 2011-10-26 mrwellan: (if (and runname (null? (filter (lambda (x)(not x)) keyvals))) ;; there must be a better way to "apply and" fa52f9444d 2011-10-26 mrwellan: (let ((res #f)) fa52f9444d 2011-10-26 mrwellan: (apply sqlite3:execute db (conc "INSERT OR IGNORE INTO runs (runname,state,status,owner,event_time" comma keystr ") VALUES (?,?,?,?,strftime('%s','now')" comma valslots ");") fa52f9444d 2011-10-26 mrwellan: allvals) 39d81114d3 2011-08-31 matt: (apply sqlite3:for-each-row fa52f9444d 2011-10-26 mrwellan: (lambda (id) fa52f9444d 2011-10-26 mrwellan: (set! res id)) fa52f9444d 2011-10-26 mrwellan: db fa52f9444d 2011-10-26 mrwellan: (let ((qry (conc "SELECT id FROM runs WHERE (runname=? " andstr key=?str ");"))) fa52f9444d 2011-10-26 mrwellan: ;(debug:print 4 "qry: " qry) fa52f9444d 2011-10-26 mrwellan: qry) fa52f9444d 2011-10-26 mrwellan: qryvals) fa52f9444d 2011-10-26 mrwellan: (sqlite3:execute db "UPDATE runs SET state=?,status=? WHERE id=?;" state status res) fa52f9444d 2011-10-26 mrwellan: res) fa52f9444d 2011-10-26 mrwellan: (begin fa52f9444d 2011-10-26 mrwellan: (debug:print 0 "ERROR: Called without all necessary keys") fa52f9444d 2011-10-26 mrwellan: #f)))) fa52f9444d 2011-10-26 mrwellan: fa52f9444d 2011-10-26 mrwellan: ;; This is a duplicate of run-tests (which has been deprecated). Use this one instead of run tests. fa52f9444d 2011-10-26 mrwellan: ;; keyvals fa52f9444d 2011-10-26 mrwellan: (define (runs:run-tests db target runname test-patts item-patts user flags) 2c8647e6a0 2012-02-26 matt: (let* ((keys (rdb:get-keys db)) fa52f9444d 2011-10-26 mrwellan: (keyvallst (keys:target->keyval keys target)) fa52f9444d 2011-10-26 mrwellan: (run-id (runs:register-run db keys keyvallst runname "new" "n/a" user)) ;; test-name))) fa52f9444d 2011-10-26 mrwellan: (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: fa52f9444d 2011-10-26 mrwellan: ;; look up all tests matching the comma separated list of globs in fa52f9444d 2011-10-26 mrwellan: ;; test-patts (using % as wildcard) fa52f9444d 2011-10-26 mrwellan: (for-each fa52f9444d 2011-10-26 mrwellan: (lambda (patt) fa52f9444d 2011-10-26 mrwellan: (let ((tests (glob (conc *toppath* "/tests/" (string-translate patt "%" "*"))))) fa52f9444d 2011-10-26 mrwellan: (set! tests (filter (lambda (test)(file-exists? (conc test "/testconfig"))) tests)) fa52f9444d 2011-10-26 mrwellan: (set! test-names (append test-names fa52f9444d 2011-10-26 mrwellan: (map (lambda (testp) fa52f9444d 2011-10-26 mrwellan: (last (string-split testp "/"))) fa52f9444d 2011-10-26 mrwellan: tests))))) 3ca3391a4e 2011-11-26 matt: (if test-patts (string-split test-patts ",")(list "%"))) fa52f9444d 2011-10-26 mrwellan: 9d2d6dc7a4 2011-11-02 matt: ;; now remove duplicates fa52f9444d 2011-10-26 mrwellan: (set! test-names (delete-duplicates test-names)) fa52f9444d 2011-10-26 mrwellan: fa52f9444d 2011-10-26 mrwellan: (debug:print 0 "INFO: test names " test-names) fa52f9444d 2011-10-26 mrwellan: fa52f9444d 2011-10-26 mrwellan: ;; on the first pass or call to run-tests set FAILS to NOT_STARTED if fa52f9444d 2011-10-26 mrwellan: ;; -keepgoing is specified 3ca3391a4e 2011-11-26 matt: (if (eq? *passnum* 0) e38c4a9bdd 2011-05-03 matt: (begin fa52f9444d 2011-10-26 mrwellan: ;; have to delete test records where NOT_STARTED since they can cause -keepgoing to fa52f9444d 2011-10-26 mrwellan: ;; get stuck due to becoming inaccessible from a failed test. I.e. if test B depends fa52f9444d 2011-10-26 mrwellan: ;; on test A but test B reached the point on being registered as NOT_STARTED and test fa52f9444d 2011-10-26 mrwellan: ;; A failed for some reason then on re-run using -keepgoing the run can never complete. fa52f9444d 2011-10-26 mrwellan: (db:delete-tests-in-state db run-id "NOT_STARTED") ad71efd688 2012-02-24 matt: (rdb: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 5501f178c7 2012-03-26 matt: (let* ((config (tests: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 5501f178c7 2012-03-26 matt: #f ;; spare - used for item-path 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) 3e2cee87de 2012-03-13 matt: (if *rpc:listener* (server:keep-running db)) 3c6e3ca6c4 2011-12-06 matt: (debug:print 4 "INFO: All done by here"))) 3ca3391a4e 2011-11-26 matt: 5501f178c7 2012-03-26 matt: ;; test-records is a hash table testname:item_path => vector < testname testconfig waitons priority items-info ... > 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)) 5501f178c7 2012-03-26 matt: (itemdat (tests:testqueue-get-itemdat test-record)) ;; itemdat can be a string, list or #f 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 f6681ce535 2012-03-26 matt: (if (patt-list-match item-path item-patts) f6681ce535 2012-03-26 matt: (run:test db run-id runname keyvallst test-record flags #f) f6681ce535 2012-03-26 matt: (debug:print 1 "INFO: Skipping " (tests:testqueue-get-testname test-record) " " item-path " as it doesn't match " item-patts)) 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 5501f178c7 2012-03-26 matt: (thread-sleep! 0.5) 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 b3c755e579 2012-03-26 matt: (if (and (>= *verbosity* 1) b3c755e579 2012-03-26 matt: (> (length items) 0) b3c755e579 2012-03-26 matt: (> (length (car items)) 0)) b3c755e579 2012-03-26 matt: (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)) f6681ce535 2012-03-26 matt: (my-item-path (item-list->path my-itemdat))) f6681ce535 2012-03-26 matt: (if (patt-list-match my-item-path item-patts) ;; yes, we want to process this item 5501f178c7 2012-03-26 matt: (let ((newtestname (conc hed "/" my-item-path))) ;; test names are unique on testname/item-path 5501f178c7 2012-03-26 matt: (tests:testqueue-set-items! new-test-record #f) 5501f178c7 2012-03-26 matt: (tests:testqueue-set-itemdat! new-test-record my-itemdat) 5501f178c7 2012-03-26 matt: (tests:testqueue-set-item_path! new-test-record my-item-path) 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 5501f178c7 2012-03-26 matt: (thread-sleep! 0.5) 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!!!!!!! 3e2cee87de 2012-03-13 matt: (debug:print 1 "INFO: All tests launched") 5501f178c7 2012-03-26 matt: (thread-sleep! 0.5) 5501f178c7 2012-03-26 matt: ;; FIXME! This harsh exit should not be necessary.... 5501f178c7 2012-03-26 matt: (if (not *runremote*)(exit)) ;; 5501f178c7 2012-03-26 matt: #f) ;; return a #f as a hint that we are done 5501f178c7 2012-03-26 matt: ;; Here we need to check that all the tests remaining to be run are eligible to run 5501f178c7 2012-03-26 matt: ;; and are not blocked by failed 5501f178c7 2012-03-26 matt: (let ((newlst (tests:filter-non-runnable db run-id tal test-records))) ;; i.e. not FAIL, WAIVED, INCOMPLETE, PASS, KILLED, 5501f178c7 2012-03-26 matt: (thread-sleep! 0.5) 5501f178c7 2012-03-26 matt: (if (not (null? newlst)) 5501f178c7 2012-03-26 matt: (loop (car newlst)(cdr newlst)))))))) 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) fa52f9444d 2011-10-26 mrwellan: ;; 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)) 5501f178c7 2012-03-26 matt: (test-path (conc *toppath* "/tests/" test-name)) ;; could use tests:get-testconfig here ... fa52f9444d 2011-10-26 mrwellan: (force (hash-table-ref/default flags "-force" #f)) fa52f9444d 2011-10-26 mrwellan: (rerun (hash-table-ref/default flags "-rerun" #f)) fa52f9444d 2011-10-26 mrwellan: (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 3e2cee87de 2012-03-13 matt: ;; Yes, another use of a global for caching. Need a better way? 3e2cee87de 2012-03-13 matt: (if (not (hash-table-ref/default *test-meta-updated* test-name #f)) 3e2cee87de 2012-03-13 matt: (begin 3e2cee87de 2012-03-13 matt: (hash-table-set! *test-meta-updated* test-name #t) 3e2cee87de 2012-03-13 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 3e2cee87de 2012-03-13 matt: (testdat (db:get-test-info db run-id test-name item-path)) 3e2cee87de 2012-03-13 matt: (test-id #f)) 3ca3391a4e 2011-11-26 matt: (if (not testdat) 3ca3391a4e 2011-11-26 matt: (begin ad71efd688 2012-02-24 matt: ;; ensure that the path exists before registering the test 65ae97a3b1 2012-02-26 matt: ;; NOPE: Cannot! Don't know yet which disk area will be assigned.... 65ae97a3b1 2012-02-26 matt: ;; (system (conc "mkdir -p " new-test-path)) 35d5a09470 2012-02-26 matt: (rtests:register-test db run-id test-name item-path) 29dd546414 2012-03-01 mrwellan: (set! testdat (db:get-test-info db run-id test-name item-path)))) 3e2cee87de 2012-03-13 matt: (set! test-id (db:test-get-id testdat)) 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")))) 0e00d7e0c2 2012-02-27 matt: (debug:print 2 "INFO: running test " test-name "/" item-path " suppressed as it is COMPLETED and " (test:get-state testdat)) 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 0e00d7e0c2 2012-02-27 matt: (let* ((rerunlst (string-split rerun ",")) 0e00d7e0c2 2012-02-27 matt: (must-rerun (member (test:get-status testdat) rerunlst))) 0e00d7e0c2 2012-02-27 matt: (debug:print 3 "INFO: -rerun list: " rerun ", test-status: " (test:get-status testdat)", must-rerun: " must-rerun) 0e00d7e0c2 2012-02-27 matt: must-rerun)) 0e00d7e0c2 2012-02-27 matt: (debug:print 2 "INFO: Rerun forced for test " test-name "/" item-path) 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) 3e2cee87de 2012-03-13 matt: "\" and status \"" (test:get-status testdat) "\", use -rerun \"" (test:get-status testdat) 3e2cee87de 2012-03-13 matt: "\" 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") 3e2cee87de 2012-03-13 matt: (test-set-status! db test-id "INCOMPLETE" "STUCK/DEAD" "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))))))) fa52f9444d 2011-10-26 mrwellan: fa52f9444d 2011-10-26 mrwellan: ;;====================================================================== fa52f9444d 2011-10-26 mrwellan: ;; END OF NEW STUFF fa52f9444d 2011-10-26 mrwellan: ;;====================================================================== 94a65715c9 2011-09-05 matt: fa52f9444d 2011-10-26 mrwellan: (define (get-dir-up-n dir . params) fa52f9444d 2011-10-26 mrwellan: (let ((dparts (string-split dir "/")) fa52f9444d 2011-10-26 mrwellan: (count (if (null? params) 1 (car params)))) fa52f9444d 2011-10-26 mrwellan: (conc "/" (string-intersperse fa52f9444d 2011-10-26 mrwellan: (take dparts (- (length dparts) count)) fa52f9444d 2011-10-26 mrwellan: "/")))) fa52f9444d 2011-10-26 mrwellan: ;; Remove runs fa52f9444d 2011-10-26 mrwellan: ;; fields are passing in through fa52f9444d 2011-10-26 mrwellan: (define (runs:remove-runs db runnamepatt testpatt itempatt) 2c8647e6a0 2012-02-26 matt: (let* ((keys (rdb:get-keys db)) fa52f9444d 2011-10-26 mrwellan: (rundat (runs:get-runs-by-patt db keys runnamepatt)) fa52f9444d 2011-10-26 mrwellan: (header (vector-ref rundat 0)) fa52f9444d 2011-10-26 mrwellan: (runs (vector-ref rundat 1))) fa52f9444d 2011-10-26 mrwellan: (debug:print 1 "Header: " header) fa52f9444d 2011-10-26 mrwellan: (for-each fa52f9444d 2011-10-26 mrwellan: (lambda (run) fa52f9444d 2011-10-26 mrwellan: (let ((runkey (string-intersperse (map (lambda (k) fa52f9444d 2011-10-26 mrwellan: (db:get-value-by-header run header (vector-ref k 0))) keys) "/")) fa52f9444d 2011-10-26 mrwellan: (dirs-to-remove (make-hash-table))) f07eeb7fa5 2012-04-03 matt: (let* ((run-id (db:get-value-by-header run header "id")) f07eeb7fa5 2012-04-03 matt: (run-state (db:get-value-by-header run header "state")) f07eeb7fa5 2012-04-03 matt: (tests (if (not (equal? run-state "locked")) f07eeb7fa5 2012-04-03 matt: (rdb:get-tests-for-run db (db:get-value-by-header run header "id") testpatt itempatt '() '()) f07eeb7fa5 2012-04-03 matt: '())) fa52f9444d 2011-10-26 mrwellan: (lasttpath "/does/not/exist/I/hope")) f07eeb7fa5 2012-04-03 matt: (if (not (equal? run-state "locked")) fa52f9444d 2011-10-26 mrwellan: (begin f07eeb7fa5 2012-04-03 matt: (if (not (null? tests)) f07eeb7fa5 2012-04-03 matt: (begin f07eeb7fa5 2012-04-03 matt: (debug:print 1 "Removing tests for run: " runkey " " (db:get-value-by-header run header "runname")) f07eeb7fa5 2012-04-03 matt: (for-each f07eeb7fa5 2012-04-03 matt: (lambda (test) f07eeb7fa5 2012-04-03 matt: (let* ((item-path (db:test-get-item-path test)) f07eeb7fa5 2012-04-03 matt: (test-name (db:test-get-testname test)) f07eeb7fa5 2012-04-03 matt: (run-dir (db:test-get-rundir test))) f07eeb7fa5 2012-04-03 matt: (debug:print 1 " " (db:test-get-testname test) " id: " (db:test-get-id test) " " item-path) f07eeb7fa5 2012-04-03 matt: (rdb:delete-test-records db (db:test-get-id test)) f07eeb7fa5 2012-04-03 matt: (if (> (string-length run-dir) 5) ;; bad heuristic but should prevent /tmp /home etc. f07eeb7fa5 2012-04-03 matt: (let ((fullpath run-dir)) ;; "/" (db:test-get-item-path test)))) f07eeb7fa5 2012-04-03 matt: (set! lasttpath fullpath) f07eeb7fa5 2012-04-03 matt: (hash-table-set! dirs-to-remove fullpath #t) f07eeb7fa5 2012-04-03 matt: ;; The following was the safe delete code but it was not being exectuted. f07eeb7fa5 2012-04-03 matt: ;; (let* ((dirs-count (+ 1 (length keys)(length (string-split item-path "/")))) f07eeb7fa5 2012-04-03 matt: ;; (dir-to-rem (get-dir-up-n fullpath dirs-count)) f07eeb7fa5 2012-04-03 matt: ;; (remainingd (string-substitute (regexp (conc "^" dir-to-rem "/")) "" fullpath)) f07eeb7fa5 2012-04-03 matt: ;; (cmd (conc "cd " dir-to-rem "; rmdir -p " remainingd ))) f07eeb7fa5 2012-04-03 matt: ;; (if (file-exists? fullpath) f07eeb7fa5 2012-04-03 matt: ;; (begin f07eeb7fa5 2012-04-03 matt: ;; (debug:print 1 cmd) f07eeb7fa5 2012-04-03 matt: ;; (system cmd))) f07eeb7fa5 2012-04-03 matt: ;; )) f07eeb7fa5 2012-04-03 matt: )))) f07eeb7fa5 2012-04-03 matt: tests))) 39d81114d3 2011-08-31 matt: f07eeb7fa5 2012-04-03 matt: ;; look though the dirs-to-remove for candidates for removal. Do this after deleting the records f07eeb7fa5 2012-04-03 matt: ;; for each test in case we get killed. That should minimize the detritus left on disk f07eeb7fa5 2012-04-03 matt: ;; process the dirs from longest string length to shortest f07eeb7fa5 2012-04-03 matt: (for-each f07eeb7fa5 2012-04-03 matt: (lambda (dir-to-remove) f07eeb7fa5 2012-04-03 matt: (if (file-exists? dir-to-remove) f07eeb7fa5 2012-04-03 matt: (let ((dir-in-db '())) f07eeb7fa5 2012-04-03 matt: (sqlite3:for-each-row f07eeb7fa5 2012-04-03 matt: (lambda (dir) f07eeb7fa5 2012-04-03 matt: (set! dir-in-db (cons dir dir-in-db))) f07eeb7fa5 2012-04-03 matt: db "SELECT rundir FROM tests WHERE rundir LIKE ?;" f07eeb7fa5 2012-04-03 matt: (conc "%" dir-to-remove "%")) ;; yes, I'm going to bail if there is anything like this dir in the db f07eeb7fa5 2012-04-03 matt: (if (null? dir-in-db) f07eeb7fa5 2012-04-03 matt: (begin f07eeb7fa5 2012-04-03 matt: (debug:print 2 "Removing directory with zero db references: " dir-to-remove) f07eeb7fa5 2012-04-03 matt: (system (conc "rm -rf " dir-to-remove)) f07eeb7fa5 2012-04-03 matt: (hash-table-delete! dirs-to-remove dir-to-remove)) f07eeb7fa5 2012-04-03 matt: (debug:print 2 "Skipping removal of " dir-to-remove " for now as it still has references in the database"))))) f07eeb7fa5 2012-04-03 matt: (sort (hash-table-keys dirs-to-remove) (lambda (a b)(> (string-length a)(string-length b))))) d406fee8c4 2011-09-12 matt: f07eeb7fa5 2012-04-03 matt: ;; remove the run if zero tests remain f07eeb7fa5 2012-04-03 matt: (let ((remtests (rdb:get-tests-for-run db (db:get-value-by-header run header "id") #f #f '() '()))) f07eeb7fa5 2012-04-03 matt: (if (null? remtests) ;; no more tests remaining f07eeb7fa5 2012-04-03 matt: (let* ((dparts (string-split lasttpath "/")) f07eeb7fa5 2012-04-03 matt: (runpath (conc "/" (string-intersperse f07eeb7fa5 2012-04-03 matt: (take dparts (- (length dparts) 1)) f07eeb7fa5 2012-04-03 matt: "/")))) f07eeb7fa5 2012-04-03 matt: (debug:print 1 "Removing run: " runkey " " (db:get-value-by-header run header "runname")) f07eeb7fa5 2012-04-03 matt: (db:delete-run db run-id) f07eeb7fa5 2012-04-03 matt: ;; need to figure out the path to the run dir and remove it if empty f07eeb7fa5 2012-04-03 matt: ;; (if (null? (glob (conc runpath "/*"))) f07eeb7fa5 2012-04-03 matt: ;; (begin f07eeb7fa5 2012-04-03 matt: ;; (debug:print 1 "Removing run dir " runpath) f07eeb7fa5 2012-04-03 matt: ;; (system (conc "rmdir -p " runpath)))) f07eeb7fa5 2012-04-03 matt: )))) f07eeb7fa5 2012-04-03 matt: )))) fa52f9444d 2011-10-26 mrwellan: runs))) d7ffcddcac 2011-08-11 matt: fa52f9444d 2011-10-26 mrwellan: ;;====================================================================== fa52f9444d 2011-10-26 mrwellan: ;; Routines for manipulating runs fa52f9444d 2011-10-26 mrwellan: ;;====================================================================== d7ffcddcac 2011-08-11 matt: fa52f9444d 2011-10-26 mrwellan: ;; Since many calls to a run require pretty much the same setup fa52f9444d 2011-10-26 mrwellan: ;; this wrapper is used to reduce the replication of code fa52f9444d 2011-10-26 mrwellan: (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") 3e2cee87de 2012-03-13 matt: (args:get-arg "-reqtarg"))) 3e2cee87de 2012-03-13 matt: (th1 #f)) 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 fa52f9444d 2011-10-26 mrwellan: (let ((db #f) fa52f9444d 2011-10-26 mrwellan: (keys #f)) fa52f9444d 2011-10-26 mrwellan: (if (not (setup-for-run)) d7ffcddcac 2011-08-11 matt: (begin fa52f9444d 2011-10-26 mrwellan: (debug:print 0 "Failed to setup, exiting") fa52f9444d 2011-10-26 mrwellan: (exit 1))) fa52f9444d 2011-10-26 mrwellan: (set! db (open-db)) 3e2cee87de 2012-03-13 matt: (if (args:get-arg "-server") 3e2cee87de 2012-03-13 matt: (server:start db (args:get-arg "-server")) 3e2cee87de 2012-03-13 matt: (if (not (or (args:get-arg "-runall") 3e2cee87de 2012-03-13 matt: (args:get-arg "-runtests"))) 3e2cee87de 2012-03-13 matt: (server:client-setup db))) c810f51721 2012-02-26 matt: (set! keys (rdb:get-keys db)) fa52f9444d 2011-10-26 mrwellan: ;; have enough to process -target or -reqtarg here fa52f9444d 2011-10-26 mrwellan: (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))) fa52f9444d 2011-10-26 mrwellan: (if (hash-table-ref/default runconfig (args:get-arg "-reqtarg") #f) fa52f9444d 2011-10-26 mrwellan: (keys:target-set-args keys (args:get-arg "-reqtarg") args:arg-hash) d406fee8c4 2011-09-12 matt: (begin fa52f9444d 2011-10-26 mrwellan: (debug:print 0 "ERROR: [" (args:get-arg "-reqtarg") "] not found in " runconfigf) fa52f9444d 2011-10-26 mrwellan: (sqlite3:finalize! db) fa52f9444d 2011-10-26 mrwellan: (exit 1)))) fa52f9444d 2011-10-26 mrwellan: (if (args:get-arg "-target") fa52f9444d 2011-10-26 mrwellan: (keys:target-set-args keys (args:get-arg "-target" args:arg-hash) args:arg-hash))) fa52f9444d 2011-10-26 mrwellan: (if (not (car *configinfo*)) fa52f9444d 2011-10-26 mrwellan: (begin fa52f9444d 2011-10-26 mrwellan: (debug:print 0 "ERROR: Attempted to " action-desc " but run area config file not found") fa52f9444d 2011-10-26 mrwellan: (exit 1)) fa52f9444d 2011-10-26 mrwellan: ;; Extract out stuff needed in most or many calls fa52f9444d 2011-10-26 mrwellan: ;; here then call proc fa52f9444d 2011-10-26 mrwellan: (let* ((keynames (map key:get-fieldname keys)) fa52f9444d 2011-10-26 mrwellan: (keyvallst (keys->vallist keys #t))) 3ca3391a4e 2011-11-26 matt: (proc db target runname keys keynames keyvallst))) 3e2cee87de 2012-03-13 matt: (if th1 (thread-join! th1)) fa52f9444d 2011-10-26 mrwellan: (sqlite3:finalize! db) 3ca3391a4e 2011-11-26 matt: (set! *didsomething* #t)))))) fa52f9444d 2011-10-26 mrwellan: fa52f9444d 2011-10-26 mrwellan: ;;====================================================================== fa52f9444d 2011-10-26 mrwellan: ;; Rollup runs fa52f9444d 2011-10-26 mrwellan: ;;====================================================================== fa52f9444d 2011-10-26 mrwellan: fa52f9444d 2011-10-26 mrwellan: ;; Update the test_meta table for this test fa52f9444d 2011-10-26 mrwellan: (define (runs:update-test_meta db test-name test-conf) 5d93144663 2012-02-27 matt: (let ((currrecord (db:testmeta-get-record db test-name))) fa52f9444d 2011-10-26 mrwellan: (if (not currrecord) fa52f9444d 2011-10-26 mrwellan: (begin fa52f9444d 2011-10-26 mrwellan: (set! currrecord (make-vector 10 #f)) 5d93144663 2012-02-27 matt: (db:testmeta-add-record db test-name))) fa52f9444d 2011-10-26 mrwellan: (for-each fa52f9444d 2011-10-26 mrwellan: (lambda (key) fa52f9444d 2011-10-26 mrwellan: (let* ((idx (cadr key)) fa52f9444d 2011-10-26 mrwellan: (fld (car key)) fa52f9444d 2011-10-26 mrwellan: (val (config-lookup test-conf "test_meta" fld))) 3ca3391a4e 2011-11-26 matt: ;; (debug:print 5 "idx: " idx " fld: " fld " val: " val) fa52f9444d 2011-10-26 mrwellan: (if (and val (not (equal? (vector-ref currrecord idx) val))) fa52f9444d 2011-10-26 mrwellan: (begin fa52f9444d 2011-10-26 mrwellan: (print "Updating " test-name " " fld " to " val) fa52f9444d 2011-10-26 mrwellan: (db:testmeta-update-field db test-name fld val))))) fa52f9444d 2011-10-26 mrwellan: '(("author" 2)("owner" 3)("description" 4)("reviewed" 5)("tags" 9))))) fa52f9444d 2011-10-26 mrwellan: fa52f9444d 2011-10-26 mrwellan: ;; Update test_meta for all tests fa52f9444d 2011-10-26 mrwellan: (define (runs:update-all-test_meta db) fa52f9444d 2011-10-26 mrwellan: (let ((test-names (get-all-legal-tests))) fa52f9444d 2011-10-26 mrwellan: (for-each fa52f9444d 2011-10-26 mrwellan: (lambda (test-name) fa52f9444d 2011-10-26 mrwellan: (let* ((test-path (conc *toppath* "/tests/" test-name)) fa52f9444d 2011-10-26 mrwellan: (test-configf (conc test-path "/testconfig")) fa52f9444d 2011-10-26 mrwellan: (testexists (and (file-exists? test-configf)(file-read-access? test-configf))) fa52f9444d 2011-10-26 mrwellan: ;; read configs with tricks turned off (i.e. no system) fa52f9444d 2011-10-26 mrwellan: (test-conf (if testexists (read-config test-configf #f #f)(make-hash-table)))) fa52f9444d 2011-10-26 mrwellan: (runs:update-test_meta db test-name test-conf))) fa52f9444d 2011-10-26 mrwellan: test-names))) d7ffcddcac 2011-08-11 matt: fa52f9444d 2011-10-26 mrwellan: ;; 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)) fa52f9444d 2011-10-26 mrwellan: (prev-tests (test:get-matching-previous-test-run-records db new-run-id "%" "%")) c810f51721 2012-02-26 matt: (curr-tests (rdb:get-tests-for-run db new-run-id "%" "%" '() '())) fa52f9444d 2011-10-26 mrwellan: (curr-tests-hash (make-hash-table))) fa52f9444d 2011-10-26 mrwellan: (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 fa52f9444d 2011-10-26 mrwellan: (for-each fa52f9444d 2011-10-26 mrwellan: (lambda (testdat) fa52f9444d 2011-10-26 mrwellan: (let* ((testname (db:test-get-testname testdat)) fa52f9444d 2011-10-26 mrwellan: (item-path (db:test-get-item-path testdat)) fa52f9444d 2011-10-26 mrwellan: (full-name (conc testname "/" item-path))) fa52f9444d 2011-10-26 mrwellan: (hash-table-set! curr-tests-hash full-name testdat))) fa52f9444d 2011-10-26 mrwellan: curr-tests) fa52f9444d 2011-10-26 mrwellan: ;; NOPE: Non-optimal approach. Try this instead. fa52f9444d 2011-10-26 mrwellan: ;; 1. tests are received in a list, most recent first fa52f9444d 2011-10-26 mrwellan: ;; 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))) c810f51721 2012-02-26 matt: (set! new-testdat (car (rdb:get-tests-for-run db new-run-id testname item-path '() '()))) 94a65715c9 2011-09-05 matt: (hash-table-set! curr-tests-hash full-name new-testdat) ;; this could be confusing, which record should go into the lookup table? 94a65715c9 2011-09-05 matt: ;; Now duplicate the test steps 94a65715c9 2011-09-05 matt: (debug:print 4 "Copying records in test_steps from test_id=" (db:test-get-id testdat) " to " (db:test-get-id new-testdat)) 94a65715c9 2011-09-05 matt: (sqlite3:execute 94a65715c9 2011-09-05 matt: db 94a65715c9 2011-09-05 matt: (conc "INSERT OR REPLACE INTO test_steps (test_id,stepname,state,status,event_time,comment) " 94a65715c9 2011-09-05 matt: "SELECT " (db:test-get-id new-testdat) ",stepname,state,status,event_time,comment FROM test_steps WHERE test_id=?;") 9bc4b32214 2011-09-06 matt: (db:test-get-id testdat)) 9bc4b32214 2011-09-06 matt: ;; Now duplicate the test data 9bc4b32214 2011-09-06 matt: (debug:print 4 "Copying records in test_data from test_id=" (db:test-get-id testdat) " to " (db:test-get-id new-testdat)) 9bc4b32214 2011-09-06 matt: (sqlite3:execute 9bc4b32214 2011-09-06 matt: db d90aea75ce 2011-09-13 mrwellan: (conc "INSERT OR REPLACE INTO test_data (test_id,category,variable,value,expected,tol,units,comment) " d90aea75ce 2011-09-13 mrwellan: "SELECT " (db:test-get-id new-testdat) ",category,variable,value,expected,tol,units,comment FROM test_data WHERE test_id=?;") 94a65715c9 2011-09-05 matt: (db:test-get-id testdat)) 94a65715c9 2011-09-05 matt: )) 94a65715c9 2011-09-05 matt: prev-tests))) 94a65715c9 2011-09-05 matt: 94a65715c9 2011-09-05 matt:
File Annotation