Index: archive.scm ================================================================== --- archive.scm +++ archive.scm @@ -21,10 +21,13 @@ (use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 format md5 message-digest srfi-18) (declare (unit archive)) (declare (uses db)) (declare (uses common)) + +(declare (uses commonmod)) +(import commonmod) (include "common_records.scm") (include "db_records.scm") ;;====================================================================== @@ -132,11 +135,11 @@ (define (archive:run-bup archive-command run-id run-name tests rp-mutex bup-mutex) ;; 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* ((blockid-cache (make-hash-table)) - (tsname (common:get-area-name)) + (tsname (common:get-area-name *alldat*)) (min-space (string->number (or (configf:lookup *configdat* "archive" "minspace") "1000"))) (arch-groups (make-hash-table)) ;; archive groups, each corrosponds to a bup area (disk-groups (make-hash-table)) ;; (test-groups (make-hash-table)) ;; these two (disk and test groups) could be combined nicely (test-dirs (make-hash-table)) @@ -255,11 +258,11 @@ ((bup) ;; Archive using bup (let* ((bup-init-params (list "-d" archive-dir "init")) (bup-index-params (append (list "-d" archive-dir "index") test-paths)) (bup-save-params (append (list "-d" archive-dir "save" ;; (conc "--strip-path=" linktree) (conc "-" compress) ;; or (conc "--compress=" compress) - "-n" (conc (common:get-area-name) "-" run-id) + "-n" (conc (common:get-area-name *alldat*) "-" run-id) (conc "--strip-path=" test-base) ;; if we push to the directory do we need this? ) test-paths))) (if (not (common:file-exists? (conc archive-dir "/HEAD"))) (begin @@ -343,11 +346,11 @@ (archive-block-id (db:test-get-archived test-dat)) (archive-block-info (rmt:test-get-archive-block-info archive-block-id)) (archive-path (if (vector? archive-block-info) (vector-ref archive-block-info 2) ;; look in db.scm for test-get-archive-block-info for the vector record info #f)) ;; no archive found? - (archive-internal-path (conc (common:get-area-name) "-" run-id "/latest/" test-partial-path))) + (archive-internal-path (conc (common:get-area-name *alldat*) "-" run-id "/latest/" test-partial-path))) ;; some sanity checks, move an existing path out of the way - iif it is not a toplevel with children ;; (if (and (not toplevel/children) ;; special handling needed for toplevel with children prev-test-physical-path Index: commonmod.scm ================================================================== --- commonmod.scm +++ commonmod.scm @@ -33,16 +33,18 @@ (define (db:dbdat-get-path dbdat) (if (pair? dbdat) (cdr dbdat) #f)) -(define (common:get-area-name alldat) +(define (common:get-area-name alldat #!optional (areapath-in #f)) (let* ((configdat (alldat-mtconfig alldat)) - (areapath (alldat-areapath alldat))) + (areapath (or (alldat-areapath alldat) + (get-environment-variable "MT_RUN_AREA_HOME") + areapath-in))) (or (configf:lookup configdat "setup" "area-name") ;; megatest is a flexible tool, testsuite is too limiting a description. (configf:lookup configdat "setup" "testsuite" ) - (get-environment-variable "MT_TESTSUITE_NAME") + (get-environment-variable "MT_TESTSUITENAME") ;; circulat? (if (string? areapath ) (pathname-file areapath) #f)))) ;; (pathname-file (current-directory))))) ;; return first path that can be created or already exists and is writable @@ -78,19 +80,21 @@ (alldat-tmppath alldat) (if (alldat-areapath alldat) ;; common:get-create-writeable-dir (handle-exceptions exn (begin + (print-call-chain) + (print ((condition-property-accessor 'exn 'message) exn)) (debug:print-error 0 log-port "Couldn't create path to " dbdir) (exit 1)) (let ((dbpath (common:get-create-writeable-dir (list (conc "/tmp/" (current-user-name) "/megatest_localdb/" (common:get-area-name alldat) "/" (string-translate (alldat-areapath alldat) "/" ".")))))) ;; #t)))) (set! dbdir dbpath) - (alldat-tmppath alldat dbpath) + (alldat-tmppath-set! alldat dbpath) dbpath)) #f)))) ;; (define (debug:print . params) #f) ;; (define (debug:print-info . params) #f) Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -293,15 +293,27 @@ (mtdb (db:open-megatest-db)) (mtdbpath (db:dbdat-get-path mtdb)) (tmpdb (db:open-megatest-db path: dbpath)) ;; lock-create-open dbpath db:initialize-main-db)) (refndb (db:open-megatest-db path: dbpath name: "megatest_ref.db")) (write-access (file-write-access? mtdbpath)) - ;(mtdbmodtime (if mtdbexists (common:lazy-sqlite-db-modification-time mtdbpath) #f)) ; moving this before db:open-megatest-db is called. if wal mode is on -WAL and -shm file get created with causing the tmpdbmodtime timestamp always greater than mtdbmodtime - ;(tmpdbmodtime (if dbfexists (common:lazy-sqlite-db-modification-time tmpdbfname) #f)) - ;if wal mode is on -WAL and -shm file get created when db:open-megatest-db is called. modtimedelta will always be < 10 so db in tmp not get synced - ;(tmpdbmodtime (if dbfexists (db:get-last-update-time (car tmpdb)) #f)) - ;(fmt (file-modification-time tmpdbfname)) + + ;;(mtdbmodtime (if mtdbexists + ;;(common:lazy-sqlite-db-modification-time mtdbpath) + ;;#f)) ; moving this before db:open-megatest-db is + ;;called. if wal mode is on -WAL and -shm file get + ;;created with causing the tmpdbmodtime timestamp + ;;always greater than mtdbmodtime (tmpdbmodtime (if + ;;dbfexists (common:lazy-sqlite-db-modification-time + ;;tmpdbfname) #f)) + + ;;if wal mode is on -WAL and -shm file get created when + ;;db:open-megatest-db is called. modtimedelta will + ;;always be < 10 so db in tmp not get synced + ;;(tmpdbmodtime (if dbfexists (db:get-last-update-time + ;;(car tmpdb)) #f)) (fmt (file-modification-time + ;;tmpdbfname)) + (modtimedelta (and mtdbmodtime tmpdbmodtime (- mtdbmodtime tmpdbmodtime)))) (handle-exceptions exn (let ((call-chain (get-call-chain)) @@ -310,19 +322,22 @@ (set! write-access #f)) ;; if we failed to drop the triggers then we probably don't have write access (when write-access (sqlite3:execute (car mtdb) "drop trigger if exists update_tests_trigger") (sqlite3:execute (car mtdb) "drop trigger if exists update_runs_trigger"))) - ;(print "mtdbmodtime " mtdbmodtime " tmpdbmodtime " tmpdbmodtime " mtdbpath " mtdbpath " " (conc *toppath* "/megatest.db")) - ;;(debug:print-info 13 *default-log-port* "db:open-db>> mtdbpath="mtdbpath" mtdbexists="mtdbexists" and write-access="write-access) + ;;(print "mtdbmodtime " mtdbmodtime " tmpdbmodtime " + ;;tmpdbmodtime " mtdbpath " mtdbpath " " (conc *toppath* + ;;"/megatest.db")) (debug:print-info 13 *default-log-port* + ;;"db:open-db>> mtdbpath="mtdbpath" mtdbexists="mtdbexists" + ;;and write-access="write-access) (if (and dbexists (not write-access)) (begin (set! *db-write-access* #f) (dbr:dbstruct-read-only-set! dbstruct #t))) (dbr:dbstruct-mtdb-set! dbstruct mtdb) (dbr:dbstruct-tmpdb-set! dbstruct tmpdb) - (dbr:dbstruct-dbstack-set! dbstruct (make-stack)) ;; BB: why a stack? Why would the number of db's be indeterminate? Is this a legacy of 1.db 2.db .. ? + (dbr:dbstruct-dbstack-set! dbstruct (make-stack)) ;; why a stack? (stack-push! (dbr:dbstruct-dbstack dbstruct) tmpdb) ;; olddb is already a (cons db path) (dbr:dbstruct-refndb-set! dbstruct refndb) ;; (mutex-unlock! *rundb-mutex*) (if (and (or (not dbfexists) (and modtimedelta @@ -329,31 +344,27 @@ (> modtimedelta max-stale-tmp))) ;; if db in tmp is over ten seconds older than the file in MTRA then do a sync back do-sync) (begin (debug:print 1 *default-log-port* "filling db " (db:dbdat-get-path tmpdb) " with data \n from " (db:dbdat-get-path mtdb) " mod time delta: " modtimedelta) (db:sync-tables (db:sync-all-tables-list dbstruct) #f mtdb refndb tmpdb) - ;touch tmp db to avoid wal mode wierdness - (set! (file-modification-time tmpdbfname) (current-seconds)) + ;touch tmp db to avoid wal mode wierdness + (set! (file-modification-time tmpdbfname) (current-seconds)) (debug:print-info 13 *default-log-port* "db:sync-all-tables-list done.") ) (debug:print 4 *default-log-port* " db, " (db:dbdat-get-path tmpdb) " already exists or fresh enough, not propogating data from\n " (db:dbdat-get-path mtdb) " mod time delta: " modtimedelta) ) ;; (db:multi-db-sync dbstruct 'old2new)) ;; migrate data from megatest.db automatically tmpdb)))) (define (db:get-last-update-time db) -; (db:with-db -; dbstruct #f #f -; (lambda (db) - (let ((last-update-time #f)) - (sqlite3:for-each-row - (lambda (lup) - (set! last-update-time lup)) - db - "select max(lup) from ( select max(last_update) as lup from tests union select max(last_update) as lup from runs);") - last-update-time)) -;)) + (let ((last-update-time #f)) + (sqlite3:for-each-row + (lambda (lup) + (set! last-update-time lup)) + db + "select max(lup) from ( select max(last_update) as lup from tests union select max(last_update) as lup from runs);") + last-update-time)) ;; Make the dbstruct, setup up auxillary db's and call for main db at least once ;; ;; called in http-transport and replicated in rmt.scm for *local* access. ;; Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -30,10 +30,13 @@ (declare (unit launch)) (declare (uses subrun)) (declare (uses common)) (declare (uses configf)) (declare (uses db)) + +(declare (uses commonmod)) +(import commonmod) (include "common_records.scm") (include "key_records.scm") (include "db_records.scm") @@ -735,11 +738,11 @@ (list "MT_ITEMPATH" item-path) (list "MT_RUNNAME" runname) (list "MT_MEGATEST" megatest) (list "MT_TARGET" target) (list "MT_LINKTREE" (common:get-linktree)) ;; (configf:lookup *configdat* "setup" "linktree")) - (list "MT_TESTSUITENAME" (common:get-area-name)))) + (list "MT_TESTSUITENAME" (common:get-area-name *alldat*)))) ;;(bb-check-path msg: "launch:execute post block 3") (if mt-bindir-path (setenv "PATH" (conc (getenv "PATH") ":" mt-bindir-path))) ;;(bb-check-path msg: "launch:execute post block 4") ;; (change-directory top-path) @@ -1024,28 +1027,54 @@ (define (launch:setup-body #!key (force-reread #f) (areapath #f)) (if (and (eq? *configstatus* 'fulldata) *toppath* (not force-reread)) ;; no need to reprocess *toppath* ;; return toppath - (let* ((use-cache (common:use-cache?)) ;; BB- use-cache checks *configdat* for use-cache setting. We do not have *configdat*. Bootstrapping problem here. + (let* ((use-cache (common:use-cache?)) ;; BB- use-cache checks + ;; *configdat* for + ;; use-cache setting. + ;; We do not have + ;; *configdat*. + ;; Bootstrapping problem + ;; here. (toppath (or *toppath* areapath (getenv "MT_RUN_AREA_HOME"))) ;; preserve toppath (target (common:args-get-target)) (sections (if target (list "default" target) #f)) ;; for runconfigs (mtconfig (or (args:get-arg "-config") "megatest.config")) ;; allow overriding megatest.config (cachefiles (launch:get-cache-file-paths areapath toppath target mtconfig)) - ;; checking for null cachefiles should not be necessary, I was seeing error car of '(), might be a chicken bug or a red herring ... + ;; checking for null cachefiles should not be necessary, + ;; I was seeing error car of '(), might be a chicken bug + ;; or a red herring ... (mtcachef (if (null? cachefiles) #f - (car cachefiles))) ;; (and cachedir (conc cachedir "/" ".megatest.cfg-" megatest-version "-" megatest-fossil-hash))) + (car cachefiles))) ;; (and cachedir (conc + ;; cachedir "/" + ;; ".megatest.cfg-" + ;; megatest-version + ;; "-" + ;; megatest-fossil-hash))) (rccachef (if (null? cachefiles) #f - (cdr cachefiles)))) ;; (and cachedir (conc cachedir "/" ".runconfigs.cfg-" megatest-version "-" megatest-fossil-hash))) - ;; (cancreate (and cachedir (common:file-exists? cachedir)(file-write-access? cachedir) (not (common:in-running-test?))))) - (set! *toppath* toppath) ;; This is needed when we are running as a test using CMDINFO as a datasource - ;;(BB> "launch:setup-body -- cachefiles="cachefiles) + (cdr cachefiles)))) ;; (and cachedir + ;; (conc cachedir "/" + ;; ".runconfigs.cfg-" + ;; megatest-version + ;; "-" + ;; megatest-fossil-hash))) + ;; (cancreate (and + ;; cachedir + ;; (common:file-exists? + ;; cachedir)(file-write-access? + ;; cachedir) (not + ;; (common:in-running-test?))))) + (set! *toppath* toppath) ;; This is needed when we are running + ;; as a test using CMDINFO as a + ;; datasource (BB> "launch:setup-body + ;; -- cachefiles="cachefiles) (cond - ;; if mtcachef exists just read it, however we need to assume toppath is available in $MT_RUN_AREA_HOME + ;; if mtcachef exists just read it, however we need to assume + ;; toppath is available in $MT_RUN_AREA_HOME ((and (not force-reread) mtcachef rccachef use-cache (get-environment-variable "MT_RUN_AREA_HOME") (common:file-exists? mtcachef) @@ -1056,12 +1085,13 @@ (set! *runconfigdat* (configf:read-alist rccachef)) (set! *configinfo* (list *configdat* (get-environment-variable "MT_RUN_AREA_HOME"))) (set! *configstatus* 'fulldata) (set! *toppath* (get-environment-variable "MT_RUN_AREA_HOME")) *toppath*) - ;; there are no existing cached configs, do full reads of the configs and cache them - ;; we have all the info needed to fully process runconfigs and megatest.config + ;; there are no existing cached configs, do full reads of the + ;; configs and cache them we have all the info needed to + ;; fully process runconfigs and megatest.config ((and ;; (not force-reread) ;; force-reread is irrelevant in the AND, could however OR it? mtcachef rccachef) ;; BB- why are we doing this without asking if caching is desired? ;;(BB> "launch:setup-body -- cond branch 2") (let* ((first-pass (find-and-read-config ;; NB// sets MT_RUN_AREA_HOME as side effect @@ -1150,11 +1180,17 @@ "/runconfigs.config") *runconfigdat* #t sections: sections))) (set! *configinfo* cfgdat) (set! *configdat* (car cfgdat)) (set! *runconfigdat* rdat) (set! *toppath* toppath) - (set! *configstatus* 'partial)) + (set! *configstatus* 'partial) + ;; set up as many vars in *alldat* as possible here + (alldat-areapath-set! *alldat* toppath) + (alldat-log-port-set! *alldat* *default-log-port*) + (alldat-mtconfig-set! *alldat* *configdat*) + + ) (begin (debug:print-error 0 *default-log-port* "No " mtconfig " file found. Giving up.") (exit 2)))))) ;; COND ends here. @@ -1185,11 +1221,11 @@ ))) (if (and *toppath* (directory-exists? *toppath*)) (begin (setenv "MT_RUN_AREA_HOME" *toppath*) - (setenv "MT_TESTSUITENAME" (common:get-area-name))) + (setenv "MT_TESTSUITENAME" (common:get-area-name *alldat*))) (begin (debug:print-error 0 *default-log-port* "failed to find the top path to your Megatest area.") (set! *toppath* #f) ;; force it to be false so we return #f #f)) @@ -1540,11 +1576,11 @@ ((dboard) "../megatest") ((mtest) "../megatest") ((dashboard) "megatest") (else exe))))) (launcher (common:get-launcher *configdat* test-name item-path)) ;; (config-lookup *configdat* "jobtools" "launcher")) - (test-sig (conc (common:get-area-name) ":" test-name ":" item-path)) ;; (item-list->path itemdat))) ;; test-path is the full path including the item-path + (test-sig (conc (common:get-area-name *alldat*) ":" test-name ":" item-path)) ;; (item-list->path itemdat))) ;; test-path is the full path including the item-path (work-area #f) (toptest-work-area #f) ;; for iterated tests the top test contains data relevant for all (diskpath #f) (cmdparms #f) (fullcmd #f) ;; (define a (with-output-to-string (lambda ()(write x)))) @@ -1593,11 +1629,11 @@ (car hhdat) #f))) (list 'serverurl (if *runremote* (remote-server-url *runremote*) #f)) ;; - (list 'areaname (common:get-area-name)) + (list 'areaname (common:get-area-name *alldat*)) (list 'toppath *toppath*) (list 'work-area work-area) (list 'test-name test-name) (list 'runscript runscript) (list 'run-id run-id ) Index: server.scm ================================================================== --- server.scm +++ server.scm @@ -27,15 +27,15 @@ (declare (unit server)) (declare (uses common)) (declare (uses db)) (declare (uses tasks)) ;; tasks are where stuff is maintained about what is running. -;; (declare (uses synchash)) (declare (uses http-transport)) -;;(declare (uses rpc-transport)) (declare (uses launch)) -;; (declare (uses daemon)) + +(declare (uses commonmod)) +(import commonmod) (include "common_records.scm") (include "db_records.scm") (define (server:make-server-url hostport) @@ -124,11 +124,11 @@ ;; (dot-server-url (server:check-if-running areapath)) (curr-ip (server:get-best-guess-address curr-host)) (curr-pid (current-process-id)) (homehost (common:get-homehost)) ;; configf:lookup *configdat* "server" "homehost" )) (target-host (car homehost)) - (testsuite (common:get-area-name)) + (testsuite (common:get-area-name *alldat*)) (logfile (conc areapath "/logs/server.log")) ;; -" curr-pid "-" target-host ".log")) (cmdln (conc (common:get-megatest-exe) " -server " (or target-host "-") (if (equal? (configf:lookup *configdat* "server" "daemonize") "yes") " -daemonize " "") Index: tasks.scm ================================================================== --- tasks.scm +++ tasks.scm @@ -26,10 +26,12 @@ (declare (uses rmt)) (declare (uses common)) (declare (uses pgdb)) ;; (import pgdb) ;; pgdb is a module +(declare (uses commonmod)) +(import commonmod) (include "task_records.scm") (include "db_records.scm") ;;====================================================================== @@ -613,11 +615,11 @@ ;; attempt to automatically set up an area. call only if get area by path ;; returns naught of interest ;; (define (tasks:set-area dbh configdat #!key (toppath #f)) ;; could I safely put *toppath* in for the default for toppath? when would it be evaluated? (let loop ((area-name (or (configf:lookup configdat "setup" "area-name") - (common:get-area-name))) + (common:get-area-name *alldat*))) (modifier 'none)) (let ((success (handle-exceptions exn (begin (debug:print 0 *default-log-port* "ERROR: cannot create area entry, " ((condition-property-accessor 'exn 'message) exn)) @@ -769,11 +771,11 @@ "")) (last-update (db:get-value-by-header row header "last_update")) (keytarg (if (or (args:get-arg "-prepend-contour") (args:get-arg "-prefix-target")) (conc "MT_CONTOUR/MT_AREA/" (string-intersperse (rmt:get-keys) "/")) (string-intersperse (rmt:get-keys) "/"))) ;; e.g. version/iteration/platform (target (if (or (args:get-arg "-prepend-contour") (args:get-arg "-prefix-target")) - (conc (or (args:get-arg "-prefix-target") (conc contour "/" (common:get-area-name) "/")) (rmt:get-target run-id)) (rmt:get-target run-id))) ;; e.g. v1.63/a3e1/ubuntu + (conc (or (args:get-arg "-prefix-target") (conc contour "/" (common:get-area-name *alldat*) "/")) (rmt:get-target run-id)) (rmt:get-target run-id))) ;; e.g. v1.63/a3e1/ubuntu (spec-id (pgdb:get-ttype dbh keytarg)) (publish-time (if (args:get-arg "-cp-eventtime-to-publishtime") event-time (current-seconds))) (new-run-id (pgdb:get-run-id dbh spec-id target run-name area-id))) Index: tcmt.scm ================================================================== --- tcmt.scm +++ tcmt.scm @@ -30,10 +30,13 @@ (declare (uses margs)) (declare (uses rmt)) (declare (uses common)) (declare (uses megatest-version)) + +(declare (uses commonmod)) +(import commonmod) (include "megatest-fossil-hash.scm") (include "db_records.scm") (define origargs (cdr (argv))) @@ -291,11 +294,11 @@ (tdelay (string->number (or (args:get-arg "-delay") "15")))) (if (and target runname) (begin (launch:setup) (set! keys (rmt:get-keys)))) - (set! tsname (common:get-area-name)) + (set! tsname (common:get-area-name *alldat*)) (print "TCMT: for testsuite=" tsname " found runname=" runname ", target=" target ", keys=" keys " and successfully ran launch:setup. Using " flowid " as the flowId.") (let loop () ;;;;;; (handle-exceptions ;;;;;; exn ;;;;;; ;; (print "Process done.") Index: tests.scm ================================================================== --- tests.scm +++ tests.scm @@ -29,15 +29,16 @@ (declare (unit tests)) (declare (uses lock-queue)) (declare (uses db)) (declare (uses tdb)) (declare (uses common)) -;; (declare (uses dcommon)) ;; needed for the steps processing (declare (uses items)) (declare (uses runconfig)) -;; (declare (uses sdb)) (declare (uses server)) + +(declare (uses commonmod)) +(import commonmod) (include "common_records.scm") (include "key_records.scm") (include "db_records.scm") (include "run_records.scm") @@ -855,11 +856,11 @@ ;; (define (tests:create-html-tree outf) (let* ((lockfile (conc outf ".lock")) (runs-to-process '()) (linktree (common:get-linktree)) - (area-name (common:get-area-name)) + (area-name (common:get-area-name *alldat*)) (keys (rmt:get-keys)) (numkeys (length keys)) (run-patt (or (args:get-arg "-run-patt") (args:get-arg "-runname") "%")) @@ -948,11 +949,11 @@ (define (tests:dynamic-dboard page) ;(define (tests:create-html-tree o) (let* ( ;(page "1") (linktree (common:get-linktree)) - (area-name (common:get-area-name)) + (area-name (common:get-area-name *alldat*)) (keys (rmt:get-keys)) (numkeys (length keys)) (targtweaked (make-list numkeys "%")) (target-patt (string-join targtweaked "/")) (total-runs (rmt:get-num-runs "%")) @@ -979,11 +980,11 @@ (define (tests:create-html-summary outf) (let* ((lockfile (conc outf ".lock")) (linktree (common:get-linktree)) (keys (rmt:get-keys)) - (area-name (common:get-area-name)) + (area-name (common:get-area-name *alldat*)) (run-patt (or (args:get-arg "-run-patt") (args:get-arg "-runname") "%")) (target (or (args:get-arg "-target-patt") (args:get-arg "-target") @@ -1174,11 +1175,11 @@ (let* ((lockfile (conc outf ".lock")) (runs-to-process '())) (if (common:simple-file-lock lockfile) (let* ((linktree (common:get-linktree)) (oup (open-output-file (or outf (conc linktree "/runs-index.html")))) - (area-name (common:get-area-name)) + (area-name (common:get-area-name *alldat*)) (keys (rmt:get-keys)) (numkeys (length keys)) (runsdat (rmt:get-runs "%" #f #f (map (lambda (x)(list x "%")) keys))) (header (vector-ref runsdat 0)) (runs (vector-ref runsdat 1))