Index: archive.scm ================================================================== --- archive.scm +++ archive.scm @@ -99,25 +99,23 @@ ;; 1. create the bup dir if not exists ;; 2. start the du of each directory ;; 3. gen index ;; 4. save ;; -(define (archive:run-bup archive-dir-in run-id run-name tests) +(define (archive:run-bup archive-command run-id run-name tests) ;; move the getting of archive space down into the below block so that a single run can ;; allocate as needed should a disk fill up ;; - (let* ((min-space (string->number (or (configf:lookup *configdat* "archive" "minspace") "1000"))) - (archive-info (if (equal? archive-dir-in "-") ;; auto allocate an archive dir - (archive:allocate-new-archive-block *toppath* (common:get-testsuite-name) min-space) - (cons archive-dir-in 0))) ;; THIS WONT WORK!!! - (archive-dir (if archive-info (cdr archive-info) archive-dir-in)) - (archive-id (if archive-info (car archive-info) -1)) - (disk-groups (make-hash-table)) - (test-groups (make-hash-table)) ;; these two (disk and test groups) could be combined nicely - (bup-exe (or (configf:lookup *configdat* "archive" "bup") "bup")) - (compress (or (configf:lookup *configdat* "archive" "compress") "9")) - (linktree (configf:lookup *configdat* "setup" "linktree"))) + (let* ((min-space (string->number (or (configf:lookup *configdat* "archive" "minspace") "1000"))) + (archive-info (archive:allocate-new-archive-block *toppath* (common:get-testsuite-name) min-space)) + (archive-dir (if archive-info (cdr archive-info) #f)) + (archive-id (if archive-info (car archive-info) -1)) + (disk-groups (make-hash-table)) + (test-groups (make-hash-table)) ;; these two (disk and test groups) could be combined nicely + (bup-exe (or (configf:lookup *configdat* "archive" "bup") "bup")) + (compress (or (configf:lookup *configdat* "archive" "compress") "9")) + (linktree (configf:lookup *configdat* "setup" "linktree"))) (if (not archive-dir) ;; no archive disk found, this is fatal (begin (debug:print 0 "FATAL: No archive disks found. Please add disks with at least " min-space " MB space to the [archive-disks] section of megatest.config") (debug:print 0 " use [archive] minspace to specify minimum available space") @@ -191,9 +189,11 @@ (run-n-wait bup-exe params: bup-save-params print-cmd: print-prefix) (for-each (lambda (test-dat) (let ((test-id (db:test-get-id test-dat)) (run-id (db:test-get-run_id test-dat))) - (rmt:test-set-archive-block-id run-id test-id archive-id))) + (rmt:test-set-archive-block-id run-id test-id archive-id) + (if (member archive-command '("save-remove")) + (runs:remove-test-directory test-dat 'archive-remove)))) (hash-table-ref test-groups disk-group)))) (hash-table-keys disk-groups)) #t)) Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -177,11 +177,12 @@ (2 "RUNNING") (3 "REMOTEHOSTSTART") (4 "LAUNCHED") (5 "KILLED") (6 "KILLREQ") - (7 "STUCK"))) + (7 "STUCK") + (8 "ARCHIVED"))) (define *common:std-statuses* '((0 "PASS") (1 "WARN") (2 "FAIL") @@ -193,11 +194,11 @@ (8 "STUCK/DEAD") (9 "ABORT"))) ;; These are stopping conditions that prevent a test from being run (define *common:cant-run-states-sym* - '(COMPLETED KILLED WAIVED UNKNOWN INCOMPLETE ABORT)) + '(COMPLETED KILLED WAIVED UNKNOWN INCOMPLETE ABORT ARCHIVED)) ;;====================================================================== ;; D E B U G G I N G S T U F F ;;====================================================================== Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -475,11 +475,11 @@ (teststatus (db:test-get-status test)) (teststate (db:test-get-state test)) ;;(teststart (db:test-get-event_time test)) ;;(runtime (db:test-get-run_duration test)) (buttontxt (cond - ((equal? teststate "COMPLETED") teststatus) + ((member teststate '("COMPLETED" "ARCHIVED")) teststatus) ((and (equal? teststate "NOT_STARTED") (member teststatus '("ZERO_ITEMS" "BLOCKED" "PREQ_FAIL" "PREQ_DISCARDED" "TIMED_OUT" "KEEP_TRYING" "TEN_STRIKES"))) teststatus) (else teststate))) Index: dcommon.scm ================================================================== --- dcommon.scm +++ dcommon.scm @@ -253,11 +253,11 @@ )) ;; set the cell text and color ;; (debug:print 2 "rownum:colnum=" rownum ":" colnum ", state=" status) (iup:attribute-set! (dboard:data-get-runs-matrix *data*) (conc rownum ":" colnum) - (if (string=? state "COMPLETED") + (if (member state '("ARCHIVED" "COMPLETED")) status state)) (iup:attribute-set! (dboard:data-get-runs-matrix *data*) (conc "BGCOLOR" rownum ":" colnum) (car (gutils:get-color-for-state-status state status))) Index: gutils.scm ================================================================== --- gutils.scm +++ gutils.scm @@ -23,11 +23,11 @@ (null? (filter (lambda (x)(> x 3)) delta)))) (define (gutils:get-color-for-state-status state status);; #!key (get-label #f)) ;; ((if get-label cadr car) (case (string->symbol state) - ((COMPLETED) + ((COMPLETED ARCHIVED) (case (string->symbol status) ((PASS) (list "70 249 73" status)) ((WARN WAIVED) (list "255 172 13" status)) ((SKIP) (list "230 230 0" status)) (else (list "223 33 49" status)))) Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -798,11 +798,11 @@ ;; set up the run work area for this test (if (and (args:get-arg "-preclean") ;; user has requested to preclean for this run (not (member (db:test-get-rundir testinfo)(list "n/a" "/tmp/badname")))) ;; n/a is a placeholder and thus not a read dir (begin (debug:print-info 0 "attempting to preclean directory " (db:test-get-rundir testinfo) " for test " test-name "/" item-path) - (runs:remove-test-directory #f testinfo #t))) ;; remove data only, do not perturb the record + (runs:remove-test-directory #f testinfo 'remove-data-only))) ;; remove data only, do not perturb the record ;; prevent overlapping actions - set to LAUNCHED as early as possible ;; (tests:test-set-status! run-id test-id "LAUNCHED" "n/a" #f #f) ;; (if launch-results launch-results "FAILED")) (rmt:roll-up-pass-fail-counts run-id test-name item-path "LAUNCHED") Index: megatest-version.scm ================================================================== --- megatest-version.scm +++ megatest-version.scm @@ -1,7 +1,7 @@ ;; Always use two or four digit decimal ;; 1.01, 1.02...1.10,1.11,1,1101 ... 1.99,2.00.. (declare (unit megatest-version)) -(define megatest-version 1.6006) +(define megatest-version 1.6007) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -149,13 +149,17 @@ -ping run-id|host:port : ping server, exit with 0 if found Utilities -env2file fname : write the environment to fname.csh and fname.sh -refdb2dat refdb : convert refdb to sexp or to format specified by -dumpmode - formats: perl, ruby, sqlite3, csv + formats: perl, ruby, sqlite3, csv (for csv the -o param + will substitute %s for the sheet name in generating + multiple sheets) -o : output file for refdb2dat (defaults to stdout) - -archive targdir : archive runs specified by selectors to targdir using bup + -archive cmd : archive runs specified by selectors to one of disks specified + in the [archive-disks] section. + cmd: keep-html, restore, save, save-remove Spreadsheet generation -extract-ods fname.ods : extract an open document spreadsheet from the database -pathmod path : insert path, i.e. path/runame/itempath/logfile.html will clear the field if no rundir/testname/itempath/logfile @@ -221,11 +225,10 @@ "-pathmod" "-env2file" "-setvars" "-set-state-status" "-set-run-status" - "-archive" "-debug" ;; for *verbosity* > 2 "-gen-megatest-test" "-override-timeout" "-test-files" ;; -test-paths is for listing all "-load" ;; load and exectute a scheme file @@ -235,10 +238,11 @@ "-run-id" "-ping" "-refdb2dat" "-o" "-log" + "-archive" ) (list "-h" "-help" "--help" "-version" "-force" "-xterm" Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -1415,11 +1415,11 @@ ;; 'remove-runs ;; 'set-state-status ;; ;; NB// should pass in keys? ;; -(define (runs:operate-on action target runnamepatt testpatt #!key (state #f)(status #f)(new-state-status #f)(remove-data-only #f)(options '())) +(define (runs:operate-on action target runnamepatt testpatt #!key (state #f)(status #f)(new-state-status #f)(mode 'remove-all)(options '())) (common:clear-caches) ;; clear all caches (let* ((db #f) (tdbdat (tasks:open-db)) (keys (rmt:get-keys)) (rundat (mt:get-runs-by-patt keys runnamepatt target)) @@ -1546,11 +1546,11 @@ ;; NOTE: This is suboptimal as the testdata will be used later and the state/status may have changed ... (if (null? tal) (loop new-test-dat tal) (loop (car tal)(append tal (list new-test-dat))))) (begin - (runs:remove-test-directory db new-test-dat remove-data-only) + (runs:remove-test-directory new-test-dat mode) ;; 'remove-all) (if (not (null? tal)) (loop (car tal)(cdr tal)))))))) ((set-state-status) (debug:print-info 2 "new state " (car state-status) ", new status " (cadr state-status)) (mt:test-set-state-status-by-id run-id (db:test-get-id test) (car state-status)(cadr state-status) #f) @@ -1595,18 +1595,19 @@ runs) ;; (sqlite3:finalize! (db:delay-if-busy tdbdat)) ) #t) -(define (runs:remove-test-directory db test remove-data-only) +(define (runs:remove-test-directory test mode) ;; remove-data-only) (let* ((run-dir (db:test-get-rundir test)) ;; run dir is from the link tree (real-dir (if (file-exists? run-dir) (resolve-pathname run-dir) #f))) - (if remove-data-only - (mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "CLEANING" "LOCKED" #f) - (mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "REMOVING" "LOCKED" #f)) + (case mode + ((remove-data-only)(mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "CLEANING" "LOCKED" #f)) + ((remove-all) (mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "REMOVING" "LOCKED" #f)) + ((archive-remove) (mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "ARCHIVE_REMOVING" #f #f))) (debug:print-info 1 "Attempting to remove " (if real-dir (conc " dir " real-dir " and ") "") " link " run-dir) (if (and real-dir (> (string-length real-dir) 5) (file-exists? real-dir)) ;; bad heuristic but should prevent /tmp /home etc. (begin ;; let* ((realpath (resolve-pathname run-dir))) @@ -1635,13 +1636,14 @@ (not (member run-dir (list "n/a" "/tmp/badname")))) (debug:print 0 "WARNING: not removing " run-dir " as it either doesn't exist or is not a symlink") (debug:print 0 "NOTE: the run dir for this test is undefined. Test may have already been deleted.")) )) ;; Only delete the records *after* removing the directory. If things fail we have a record - (if remove-data-only - (mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "NOT_STARTED" "n/a" #f) - (rmt:delete-test-records (db:test-get-run_id test) (db:test-get-id test))))) + (case mode + ((remove-data-only)(mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "NOT_STARTED" "n/a" #f)) + ((archive-remove) (mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "ARCHIVED" #f #f)) + (else (rmt:delete-test-records (db:test-get-run_id test) (db:test-get-id test)))))) ;;====================================================================== ;; Routines for manipulating runs ;;======================================================================