and :runname ,-testpatt and -itempatt
and -testpatt
-rerun FAIL,WARN... : re-run if called on a test that previously ran (nullified
if -keepgoing is also specified)
-rebuild-db : bring the database schema up to date
-rollup : fill run (set by :runname) with latest test(s) from
prior runs with same keys
-lock : lock the run specified by target and runname as locked
which prevents -remove-runs from removing the run
-update-meta : update the tests metadata for all tests
-env2file fname : write the environment to fname.csh and fname.sh
-setvars VAR1=val1,VAR2=val2 : Add environment variables to a run NB// these are
overwritten by values set in config files.
-archive : archive tests, use -target, :runname, -itempatt and -testpatt
-server -|hostname : start the server (reduces contention on megatest.db), use
- to automatically figure out hostname
"-set-values"
"-load-test-data"
"-summarize-items"
"-gui"
;; misc
"-archive"
"-repl"
"-lock"
;; queries
"-test-paths" ;; get path(s) to a test, ordered by youngest first
"-runall" ;; run all tests
"-remove-runs"
"-keepgoing"
"-usequeue"
(runs (vector-ref rundat 1)))
(debug:print 1 "Header: " header)
(for-each
(lambda (run)
(let ((runkey (string-intersperse (map (lambda (k)
(db:get-value-by-header run header (vector-ref k 0))) keys) "/"))
(dirs-to-remove (make-hash-table)))
(let* ((run-id (db:get-value-by-header run header "id"))
(tests (rdb:get-tests-for-run db (db:get-value-by-header run header "id") testpatt itempatt '() '()))
(let* ((run-id (db:get-value-by-header run header "id"))
(run-state (db:get-value-by-header run header "state"))
(tests (if (not (equal? run-state "locked"))
(rdb:get-tests-for-run db (db:get-value-by-header run header "id") testpatt itempatt '() '())
'()))
(lasttpath "/does/not/exist/I/hope"))
(if (not (null? tests))
(begin
(debug:print 1 "Removing tests for run: " runkey " " (db:get-value-by-header run header "runname"))
(for-each
(lambda (test)
(let* ((item-path (db:test-get-item-path test))
(test-name (db:test-get-testname test))
(run-dir (db:test-get-rundir test)))
(debug:print 1 " " (db:test-get-testname test) " id: " (db:test-get-id test) " " item-path)
(rdb:delete-test-records db (db:test-get-id test))
(if (> (string-length run-dir) 5) ;; bad heuristic but should prevent /tmp /home etc.
(let ((fullpath run-dir)) ;; "/" (db:test-get-item-path test))))
(set! lasttpath fullpath)
(hash-table-set! dirs-to-remove fullpath #t)
;; The following was the safe delete code but it was not being exectuted.
;; (let* ((dirs-count (+ 1 (length keys)(length (string-split item-path "/"))))
;; (dir-to-rem (get-dir-up-n fullpath dirs-count))
;; (remainingd (string-substitute (regexp (conc "^" dir-to-rem "/")) "" fullpath))
;; (cmd (conc "cd " dir-to-rem "; rmdir -p " remainingd )))
;; (if (file-exists? fullpath)
;; (begin
;; (debug:print 1 cmd)
;; (system cmd)))
;; ))
))))
tests)))
(if (not (equal? run-state "locked"))
(begin
(if (not (null? tests))
(begin
(debug:print 1 "Removing tests for run: " runkey " " (db:get-value-by-header run header "runname"))
(for-each
(lambda (test)
(let* ((item-path (db:test-get-item-path test))
(test-name (db:test-get-testname test))
(run-dir (db:test-get-rundir test)))
(debug:print 1 " " (db:test-get-testname test) " id: " (db:test-get-id test) " " item-path)
(rdb:delete-test-records db (db:test-get-id test))
(if (> (string-length run-dir) 5) ;; bad heuristic but should prevent /tmp /home etc.
(let ((fullpath run-dir)) ;; "/" (db:test-get-item-path test))))
(set! lasttpath fullpath)
(hash-table-set! dirs-to-remove fullpath #t)
;; The following was the safe delete code but it was not being exectuted.
;; (let* ((dirs-count (+ 1 (length keys)(length (string-split item-path "/"))))
;; (dir-to-rem (get-dir-up-n fullpath dirs-count))
;; (remainingd (string-substitute (regexp (conc "^" dir-to-rem "/")) "" fullpath))
;; (cmd (conc "cd " dir-to-rem "; rmdir -p " remainingd )))
;; (if (file-exists? fullpath)
;; (begin
;; (debug:print 1 cmd)
;; (system cmd)))
;; ))
))))
tests)))
;; look though the dirs-to-remove for candidates for removal. Do this after deleting the records
;; for each test in case we get killed. That should minimize the detritus left on disk
;; process the dirs from longest string length to shortest
(for-each
(lambda (dir-to-remove)
(if (file-exists? dir-to-remove)
(let ((dir-in-db '()))
(sqlite3:for-each-row
(lambda (dir)
(set! dir-in-db (cons dir dir-in-db)))
db "SELECT rundir FROM tests WHERE rundir LIKE ?;"
(conc "%" dir-to-remove "%")) ;; yes, I'm going to bail if there is anything like this dir in the db
(if (null? dir-in-db)
(begin
(debug:print 2 "Removing directory with zero db references: " dir-to-remove)
(system (conc "rm -rf " dir-to-remove))
(hash-table-delete! dirs-to-remove dir-to-remove))
(debug:print 2 "Skipping removal of " dir-to-remove " for now as it still has references in the database")))))
(sort (hash-table-keys dirs-to-remove) (lambda (a b)(> (string-length a)(string-length b)))))
;; look though the dirs-to-remove for candidates for removal. Do this after deleting the records
;; for each test in case we get killed. That should minimize the detritus left on disk
;; process the dirs from longest string length to shortest
(for-each
(lambda (dir-to-remove)
(if (file-exists? dir-to-remove)
(let ((dir-in-db '()))
(sqlite3:for-each-row
(lambda (dir)
(set! dir-in-db (cons dir dir-in-db)))
db "SELECT rundir FROM tests WHERE rundir LIKE ?;"
(conc "%" dir-to-remove "%")) ;; yes, I'm going to bail if there is anything like this dir in the db
(if (null? dir-in-db)
(begin
(debug:print 2 "Removing directory with zero db references: " dir-to-remove)
(system (conc "rm -rf " dir-to-remove))
(hash-table-delete! dirs-to-remove dir-to-remove))
(debug:print 2 "Skipping removal of " dir-to-remove " for now as it still has references in the database")))))
(sort (hash-table-keys dirs-to-remove) (lambda (a b)(> (string-length a)(string-length b)))))
;; remove the run if zero tests remain
(let ((remtests (rdb:get-tests-for-run db (db:get-value-by-header run header "id") #f #f '() '())))
(if (null? remtests) ;; no more tests remaining
(let* ((dparts (string-split lasttpath "/"))
(runpath (conc "/" (string-intersperse
(take dparts (- (length dparts) 1))
"/"))))
(debug:print 1 "Removing run: " runkey " " (db:get-value-by-header run header "runname"))
(db:delete-run db run-id)
;; need to figure out the path to the run dir and remove it if empty
;; (if (null? (glob (conc runpath "/*")))
;; (begin
;; (debug:print 1 "Removing run dir " runpath)
;; (system (conc "rmdir -p " runpath))))
))))
))
;; remove the run if zero tests remain
(let ((remtests (rdb:get-tests-for-run db (db:get-value-by-header run header "id") #f #f '() '())))
(if (null? remtests) ;; no more tests remaining
(let* ((dparts (string-split lasttpath "/"))
(runpath (conc "/" (string-intersperse
(take dparts (- (length dparts) 1))
"/"))))
(debug:print 1 "Removing run: " runkey " " (db:get-value-by-header run header "runname"))
(db:delete-run db run-id)
;; need to figure out the path to the run dir and remove it if empty
;; (if (null? (glob (conc runpath "/*")))
;; (begin
;; (debug:print 1 "Removing run dir " runpath)
;; (system (conc "rmdir -p " runpath))))
))))
))))
runs)))
;;======================================================================
;; Routines for manipulating runs
;;======================================================================
;; Since many calls to a run require pretty much the same setup
' d='M14,14H2V2h12v12z'/%3E%3Cpath style='fill:rgb(64,64,64)' d='M13,13H3V3h10v10z'/%3E%3Cpath style='fill:rgb(248,248,248)' d='M12,12H4V4h8v8z'/%3E%3Cpath style='fill:rgb(80,128,208)' d='M11,9H5V7h6v6z'/%3E%3C/svg%3E)
' d='M14,14H2V2h12v12z'/%3E%3Cpath style='fill:rgb(64,64,64)' d='M13,13H3V3h10v10z'/%3E%3Cpath style='fill:rgb(248,248,248)' d='M12,12H4V4h8v8z'/%3E%3Cpath style='fill:rgb(80,128,208)' d='M5,7h2v-2h2v2h2v2h-2v2h-2v-2h-2z'/%3E%3C/svg%3E)
Overview