Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -8,11 +8,11 @@ process.scm runs.scm tasks.scm tests.scm genexample.scm \ http-transport.scm nmsg-transport.scm filedb.scm \ client.scm gutils.scm synchash.scm daemon.scm mt.scm dcommon.scm \ tree.scm ezsteps.scm lock-queue.scm sdb.scm \ rmt.scm api.scm tdb.scm rpc-transport.scm \ - portlogger.scm + portlogger.scm archive.scm # Eggs to install (straightforward ones) EGGS=matchable readline apropos base64 regex-literals format regex-case test coops trace csv \ dot-locking posix-utils posix-extras directory-utils hostinfo tcp-server rpc csv-xml fmt \ json md5 awful http-client spiffy uri-common intarweb spiffy-request-vars \ Index: archive.scm ================================================================== --- archive.scm +++ archive.scm @@ -13,10 +13,13 @@ (import (prefix sqlite3 sqlite3:)) (declare (unit archive)) (declare (uses db)) (declare (uses common)) + +(include "common_records.scm") +(include "db_records.scm") ;;====================================================================== ;; ;;====================================================================== @@ -82,6 +85,45 @@ (allocation-id (rmt:archive-allocate-test-to-block block-id testname itempath))) (if (and block-id allocation-id) archive-path #f))))) - +;; archive - run bup +;; +;; 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 run-name tests) + (let* ((bup-exe (or (configf:lookup *configdat* "archive" "bup") "bup")) + (linktree (configf:lookup *configdat* "setup" "linktree")) + (test-paths (filter + string? + (map (lambda (test-dat) + (let* ((item-path (db:test-get-item-path test-dat)) + (test-name (db:test-get-testname test-dat)) + (run-id (db:test-get-run_id test-dat)) + (target (string-intersperse (map cadr (rmt:get-key-val-pairs run-id)) "/")) + + (toplevel/children (and (db:test-get-is-toplevel test-dat) + (> (rmt:test-toplevel-num-items run-id test-name) 0)))) + (if toplevel/children + #f + (conc linktree "/" target "/" run-name "/" (runs:make-full-test-name test-name item-path) "/")))) ;; note the trailing slash to get the dir inspite of it being a link + tests))) + ;; ((string-intersperse (map cadr (rmt:get-key-val-pairs 1)) "-") + (bup-init-params (list "-d" archive-dir)) + (bup-index-params (append (list "-d" archive-dir "index") test-paths)) + (bup-save-params (append (list "-d" archive-dir "save" "-n" (common:get-testsuite-name)) + test-paths))) + (if (not (file-exists? archive-dir)) + (create-directory archive-dir #t)) + (if (not (file-exists? (conc archive-dir "/HEAD"))) + (begin + ;; replace this with jobrunner stuff enventually + (debug:print-info 0 "Init bup in " archive-dir) + (run-n-wait bup-exe params: bup-init-params))) + (debug:print-info 0 "Indexing data to be archived") + (run-n-wait bup-exe params: bup-index-params) + (debug:print-info 0 "Archiving data with bup") + (run-n-wait bup-exe params: bup-save-params))) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -147,10 +147,11 @@ 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 -o : output file for refdb2dat (defaults to stdout) + -archive targdir : archive runs specified by selectors to targdir using bup 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 @@ -216,10 +217,11 @@ "-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 @@ -244,11 +246,10 @@ "-summarize-items" "-gui" "-daemonize" "-preclean" ;; misc - "-archive" "-repl" "-lock" "-unlock" "-list-servers" "-run-wait" ;; wait on a run to complete (i.e. no RUNNING) @@ -974,50 +975,16 @@ ;;====================================================================== ;; Archive tests ;;====================================================================== ;; Archive tests matching target, runname, and testpatt (if (args:get-arg "-archive") - ;; if we are in a test use the MT_CMDINFO data - (if (getenv "MT_CMDINFO") - (let* ((startingdir (current-directory)) - (cmdinfo (common:read-encoded-string (getenv "MT_CMDINFO"))) - (transport (assoc/default 'transport cmdinfo)) - (testpath (assoc/default 'testpath cmdinfo)) - (test-name (assoc/default 'test-name cmdinfo)) - (runscript (assoc/default 'runscript cmdinfo)) - (db-host (assoc/default 'db-host cmdinfo)) - (run-id (assoc/default 'run-id cmdinfo)) - (itemdat (assoc/default 'itemdat cmdinfo)) - (state (args:get-arg ":state")) - (status (args:get-arg ":status")) - (target (args:get-arg "-target"))) - (change-directory testpath) - (if (not target) - (begin - (debug:print 0 "ERROR: -target is required.") - (exit 1))) - (if (not (launch:setup-for-run)) - (begin - (debug:print 0 "Failed to setup, giving up on -archive, exiting") - (exit 1))) - (let* ((keys (rmt:get-keys)) - (paths (tests:test-get-paths-matching keys target))) - (set! *didsomething* #t) - (for-each (lambda (path) - (print path)) - paths)) - ;; (if (sqlite3:database? db)(sqlite3:finalize! db)) - ) - ;; else do a general-run-call - (general-run-call - "-test-paths" - "Get paths to tests" - (lambda (target runname keys keyvals) - (let* ((paths (tests:test-get-paths-matching keys target))) - (for-each (lambda (path) - (print path)) - paths)))))) + ;; else do a general-run-call + (general-run-call + "-archive" + "Archive" + (lambda (target runname keys keyvals) + (operate-on 'archive)))) ;;====================================================================== ;; Extract a spreadsheet from the runs database ;;====================================================================== Index: process.scm ================================================================== --- process.scm +++ process.scm @@ -101,12 +101,14 @@ (append result (list curr))) result)))) ;; here is an example line where the shell is sh or bash ;; "find / -print 2&>1 > findall.log" -(define (run-n-wait cmdline) - (let ((pid (process-run cmdline))) +(define (run-n-wait cmdline #!key (params #f)) + (let ((pid (if params + (process-run cmdline params) + (process-run cmdline)))) (let loop ((i 0)) (let-values (((pid-val exit-status exit-code) (process-wait pid #t))) (if (eq? pid-val 0) (begin (thread-sleep! 2) Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -19,10 +19,11 @@ (declare (uses items)) (declare (uses runconfig)) (declare (uses tests)) (declare (uses server)) (declare (uses mt)) +(declare (uses archive)) ;; (declare (uses filedb)) (include "common_records.scm") (include "key_records.scm") (include "db_records.scm") @@ -1414,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)) +(define (runs:operate-on action target runnamepatt testpatt #!key (state #f)(status #f)(new-state-status #f)(remove-data-only #f)(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)) @@ -1448,11 +1449,12 @@ (run-state (db:get-value-by-header run header "state")) (run-name (db:get-value-by-header run header "runname")) (tests (if (not (equal? run-state "locked")) (proc-get-tests run-id) '())) - (lasttpath "/does/not/exist/I/hope")) + (lasttpath "/does/not/exist/I/hope") + (worker-thread #f)) (debug:print-info 4 "runs:operate-on run=" run ", header=" header) (if (not (null? tests)) (begin (case action ((remove-runs) @@ -1468,12 +1470,21 @@ ((print-run) (debug:print 1 "Printing info for run " runkey ", run=" run ", tests=" tests ", header=" header) action) ((run-wait) (debug:print 1 "Waiting for run " runkey ", run=" runnamepatt " to complete")) + ((archive) + (debug:print 1 "Archiving data for run: " runkey " " (db:get-value-by-header run header "runname")) + (set! worker-thread (make-thread (lambda () + (archive:run-bup (args:get-arg "-archive") run-name tests)) + "archive-bup-thread")) + (thread-start! worker-thread)) (else (debug:print-info 0 "action not recognised " action))) + + ;; actions that operate on one test at a time can be handled below + ;; (let ((sorted-tests (sort tests (lambda (a b)(let ((dira ;; (rmt:sdb-qry 'getstr (db:test-get-rundir a)) ;; ) ;; (filedb:get-path *fdb* (db:test-get-rundir a))) (dirb ;; (rmt:sdb-qry 'getstr (db:test-get-rundir b))) ;; ) ;; ((filedb:get-path *fdb* (db:test-get-rundir b)))) (if (and (string? dira)(string? dirb)) @@ -1549,11 +1560,17 @@ (debug:print-info 2 "still waiting, " (length tests) " tests still running") (thread-sleep! 10) (let ((new-tests (proc-get-tests run-id))) (if (null? new-tests) (debug:print-info 1 "Run completed according to zero tests matching provided criteria.") - (loop (car new-tests)(cdr new-tests)))))))) + (loop (car new-tests)(cdr new-tests))))) + ((archive) + (if (not toplevel-with-children) + (begin + (debug:print-info 0 "Estimating disk space usage for " test-fulln) + (debug:print-info 0 " " (common:get-disk-space-used run-dir))))) + ))) ))))) ;; remove the run if zero tests remain (if (eq? action 'remove-runs) (let ((remtests (mt:get-tests-for-run (db:get-value-by-header run header "id") #f '("DELETED") '("n/a") not-in: #t))) (if (null? remtests) ;; no more tests remaining