Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -963,23 +963,27 @@ (begin (if message (debug:print-info 0 *default-log-port* message)) #f) (thunk) )) -(define (common:file-exists? path-string) +(define (common:file-exists? path-string #!key (quiet-mode #f)) ;; this avoids stack dumps in the case where ;;;; TODO: catch permission denied exceptions and emit appropriate warnings, eg: system error while trying to access file: "/nfs/pdx/disks/icf_env_disk001/bjbarcla/gwa/issues/mtdev/randy-slow/reproduce/q... - (common:false-on-exception (lambda () (file-exists? path-string)) - message: (conc "Unable to access path: " path-string) - )) + (common:false-on-exception + (lambda () (file-exists? path-string)) + message: (if quiet-mode + #f + (conc "Unable to access path: " path-string)))) -(define (common:directory-exists? path-string) +(define (common:directory-exists? path-string #!key (quiet-mode #f)) ;;;; TODO: catch permission denied exceptions and emit appropriate warnings, eg: system error while trying to access file: "/nfs/pdx/disks/icf_env_disk001/bjbarcla/gwa/issues/mtdev/randy-slow/reproduce/q... - (common:false-on-exception (lambda () (directory-exists? path-string)) - message: (conc "Unable to access path: " path-string) - )) + (common:false-on-exception + (lambda () (directory-exists? path-string)) + message: (if quiet-mode + #f + (conc "Unable to access path: " path-string)))) ;; does the directory exist and do we have write access? ;; ;; returns the directory or #f ;; @@ -1093,17 +1097,46 @@ (equal? homehost bestadrs)))) (set! *home-host* (cons homehost at-home)) (mutex-unlock! *homehost-mutex*) *home-host*)))) +;; get homehost info for a given area - but only if .homehost file already exists +(define (common:minimal-get-homehost toppath) + (let ((hh-file (conc toppath "/.homehost"))) + (if (common:file-exists? hh-file quiet-mode: #t) + (with-input-from-file hh-file read-line) + #f))) + +;; are we on the given host? +(define (common:on-host? hh) + (let* ((currhost (get-host-name)) + (bestadrs (server:get-best-guess-address currhost))) + (or (equal? hh currhost) + (equal? hh bestadrs)))) + ;; am I on the homehost? ;; (define (common:on-homehost?) (let ((hh (common:get-homehost))) (if hh (cdr hh) #f))) + +;; minimal loading of megatest.config +;; +(define (common:simple-setup toppath #!key (cfgf-ovrd #f)) + (let* ((mtconfigf (or cfgf-ovrd "megatest.config")) + (mtconfdat (find-and-read-config + mtconfigf + ;; environ-patt: "env-override" + given-toppath: toppath + ;; pathenvvar: "MT_RUN_AREA_HOME" + )) + (mtconf (if mtconfdat (car mtconfdat) #f))) + (if mtconf + (configf:section-var-set! mtconf "dyndat" "toppath" start-dir)) + mtconfdat)) ;; do we honor the caches of the config files? ;; (define (common:use-cache?) (let ((res #t)) ;; priority by order of evaluation Index: dashboard-areas.scm ================================================================== --- dashboard-areas.scm +++ dashboard-areas.scm @@ -4,11 +4,11 @@ (define (dashboard:areas-summary-updater commondat tabdat tb cell-lookup run-matrix) (dashboard:areas-do-update-rundat tabdat) ;; ) (dboard:areas-summary-control-panel-updater tabdat) (let* ((last-runs-update (dboard:tabdat-last-runs-update tabdat)) - (runs-dat (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update)) + (runs-dat (mrmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update)) (runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records (runs (vector-ref runs-dat 1)) (run-id (dboard:tabdat-curr-run-id tabdat)) (runs-hash (dashboard:areas-get-runs-hash tabdat)) ;; (runs-hash (let ((ht (make-hash-table))) @@ -129,24 +129,24 @@ ;; status is corrupted on Brandon's home machine. will have to wait until after shutdown to see if it is still broken in PDX SLES (let* ((toolpath (car (argv))) (key (conc lin ":" col)) (test-id (hash-table-ref/default cell-lookup key -1)) (run-id (dboard:tabdat-curr-run-id tabdat)) - (run-info (rmt:get-run-info run-id)) - (target (rmt:get-target run-id)) + (run-info (mrmt:get-run-info run-id)) + (target (mrmt:get-target run-id)) (runname (db:get-value-by-header (db:get-rows run-info) (db:get-header run-info) "runname")) - (test-info (rmt:get-test-info-by-id run-id test-id)) + (test-info (mrmt:get-test-info-by-id run-id test-id)) (test-name (db:test-get-testname test-info)) - (testpatt (let ((tlast (rmt:tasks-get-last target runname))) + (testpatt (let ((tlast (mrmt:tasks-get-last target runname))) (if tlast (let ((tpatt (tasks:task-get-testpatt tlast))) (if (member tpatt '("0" 0)) ;; known bad historical value - remove in 2017 "%" tpatt)) "%"))) - (item-path (db:test-get-item-path (rmt:get-test-info-by-id run-id test-id))) + (item-path (db:test-get-item-path (mrmt:get-test-info-by-id run-id test-id))) (item-test-path (conc test-name "/" (if (equal? item-path "") "%" item-path))) (status-chars (char-set->list (string->char-set status))) (testpanel-cmd (conc toolpath " -test " (dboard:tabdat-curr-run-id tabdat) "," test-id " &"))) @@ -232,13 +232,13 @@ ;; (define (dboard:areas-update-rundat tabdat runnamepatt numruns testnamepatt keypatts) (let* ((access-mode (dboard:tabdat-access-mode tabdat)) (keys (dboard:tabdat-keys tabdat)) (last-runs-update (- (dboard:tabdat-last-runs-update tabdat) 2)) - (allruns (rmt:get-runs runnamepatt numruns (dboard:tabdat-start-run-offset tabdat) keypatts)) - ;;(allruns-tree (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f)) - (allruns-tree (rmt:get-runs-by-patt keys "%" #f #f #f #f 0)) ;; last-runs-update));;'("id" "runname") + (allruns (mrmt:get-runs runnamepatt numruns (dboard:tabdat-start-run-offset tabdat) keypatts)) + ;;(allruns-tree (mrmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f)) + (allruns-tree (mrmt:get-runs-by-patt keys "%" #f #f #f #f 0)) ;; last-runs-update));;'("id" "runname") (header (db:get-header allruns)) (runs (db:get-rows allruns)) ;; RA => Filtered as per runpatt selected (runs-tree (db:get-rows allruns-tree)) ;; RA => Returns complete list of runs (start-time (current-seconds)) (runs-hash (let ((ht (make-hash-table))) @@ -263,11 +263,11 @@ (res '()) (maxtests 0)) (let* ((run-id (db:get-value-by-header run header "id")) (run-struct (hash-table-ref/default (dboard:tabdat-allruns-by-id tabdat) run-id #f)) ;; (last-update (if run-struct (dboard:rundat-last-update run-struct) 0)) - (key-vals (rmt:get-key-vals run-id)) + (key-vals (mrmt:get-key-vals run-id)) (tests-ht (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals)) ;; GET RID OF dboard:get-tests-dat - it is superceded by dboard:get-tests-for-run-duplicate ;; dboard:get-tests-for-run-duplicate - returns a hash table ;; (dboard:get-tests-dat tabdat run-id last-update)) (all-test-ids (hash-table-keys tests-ht)) @@ -339,11 +339,11 @@ fres)))) (define (dashboard:areas-get-runs-hash tabdat) (let* ((access-mode (dboard:tabdat-access-mode tabdat)) (last-runs-update 0);;(dboard:tabdat-last-runs-update tabdat)) - (runs-dat (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update)) + (runs-dat (mrmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update)) (runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records (runs (vector-ref runs-dat 1)) (run-id (dboard:tabdat-curr-run-id tabdat)) (runs-hash (let ((ht (make-hash-table))) (for-each (lambda (run) @@ -376,11 +376,11 @@ (time-a (db:get-value-by-header record-a runs-header "event_time")) (time-b (db:get-value-by-header record-b runs-header "event_time"))) (< time-a time-b))))) (changed #f) (last-runs-update (dboard:tabdat-last-runs-update tabdat)) - (runs-dat (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f 0)) ;; last-runs-update)) + (runs-dat (mrmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f 0)) ;; last-runs-update)) (runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records (runs (vector-ref runs-dat 1)) (new-run-ids (map (lambda (run) (db:get-value-by-header run runs-header "id")) runs)) @@ -419,11 +419,11 @@ )))) (append new-run-ids run-ids)))) ;; for-each run-id (define (dashboard:areas-run-id->tests-mindat run-id tabdat runs-hash) (let* ((run (hash-table-ref/default runs-hash run-id #f)) - (key-vals (rmt:get-key-vals run-id)) + (key-vals (mrmt:get-key-vals run-id)) (testnamepatt (or (dboard:tabdat-test-patts tabdat) "%/%")) (tests-ht (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals)) (tests-dat (dashboard:tests-ht->tests-dat tests-ht)) (tests-mindat (dcommon:minimize-test-data tests-dat))) ;; reduces data for display (dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2)) @@ -503,11 +503,11 @@ (iup:menu-item (conc "Kill " item-test-path) #:action (lambda (obj) - ;; (rmt:test-set-state-status-by-id run-id test-id "KILLREQ" #f #f) + ;; (mrmt:test-set-state-status-by-id run-id test-id "KILLREQ" #f #f) (common:run-a-command (conc "megatest -set-state-status KILLREQ,n/a -target " target " -runname " runname " -testpatt " item-test-path " -state RUNNING,REMOTEHOSTSTART,LAUNCHED,NOT_STARTED")))) @@ -576,11 +576,11 @@ " -preclean -clean-cache")))) (iup:menu-item (conc "Kill " item-test-path) #:action (lambda (obj) - ;; (rmt:test-set-state-status-by-id run-id test-id "KILLREQ" #f #f) + ;; (mrmt:test-set-state-status-by-id run-id test-id "KILLREQ" #f #f) (common:run-a-command (conc "megatest -set-state-status KILLREQ,n/a -target " target " -runname " runname " -testpatt " item-test-path " -state RUNNING,REMOTEHOSTSTART,LAUNCHED")))) @@ -692,14 +692,14 @@ (case mode ((xor-two-runs xor-two-runs-hide-clean) (let* ((curr-run-id (dboard:tabdat-curr-run-id tabdat)) (prev-run-id (dboard:tabdat-prev-run-id tabdat)) (curr-runname (if curr-run-id - (rmt:get-run-name-from-id curr-run-id) + (mrmt:get-run-name-from-id curr-run-id) "None")) (prev-runname (if prev-run-id - (rmt:get-run-name-from-id prev-run-id) + (mrmt:get-run-name-from-id prev-run-id) "None"))) (iup:attribute-set! source-runname-label "TITLE" (conc " SRC: "prev-runname" ")) (iup:attribute-set! dest-runname-label "TITLE" (conc "DEST: "curr-runname" ")))) (else (iup:attribute-set! source-runname-label "TITLE" "") Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -49,10 +49,13 @@ (mtdb #f) (refndb #f) (homehost #f) ;; not used yet (on-homehost #f) ;; not used yet (read-only #f) + (configdat #f) + (keys #f) + (area-path #f) ) ;; goal is to converge on one struct for an area but for now it is too confusing ;; record for keeping state,status and count for doing roll-ups in ;; iterated tests @@ -73,12 +76,36 @@ ;; no-sync-db - ;; on-homehost - enable reading from other users /tmp db if files are readable ;; ;; areas is hash of areas => dbstruct, the dashboard-open-db will register the dbstruct in that hash ;; +;; NOTE: This returns the tmpdb path/handle pair. +;; NOTE: This does do a sync (the db:open-db proc only does an initial sync if called with do-sync: #t +;; NOTE: Longer term consider replacing db:open-db with this +;; (define (db:dashboard-open-db areas area-path) - #f) + ;; 0. check for already existing dbstruct in areas hash, return it if found + ;; 1. do minimal read of megatest.config, store configdat, keys in dbstruct + ;; 2. get homehost + ;; 3. create /tmp db area (if needed) + ;; 4. sync data to /tmp db (or update if exists) + ;; 5. return dbstruct + (if (hash-table-exists? areas area-path) + (hash-table-ref areas area-path) + (if (common:file-exists? (conc area-path "/megatest.config") quiet-mode: #t) + (let* ((homehost (common:minimal-get-homehost toppath)) + (on-hh (common:on-host? homehost)) + (mtconfig (common:simple-setup area-path)) ;; returns ( configdat toppath configfile configf-name ) + (dbstruct (make-dbr:dbstruct + area-path: area-path + homehost: homehost + configdat: (car mtconfig))) + (tmpdb (db:open-db dbstruct area-path: area-path do-sync: #t))) + tmpdb) + (begin + (debug:print-info 0 *default-log-port* "attempt to open megatest.db in " area-path " but no megatest.config found.") + #f)))) ;; sync all the areas listed in area-paths ;; (define (db:dashboard-sync-dbs areas area-paths) #f) @@ -325,21 +352,22 @@ ;; (db:sync-tables db:sync-tests-only *megatest-db* db) ;; db)) ;; This routine creates the db if not already present. It is only called if the db is not already opened ;; -(define (db:open-db dbstruct #!key (areapath #f)(do-sync #t)) ;; TODO: actually use areapath +(define (db:open-db dbstruct #!key (area-path #f)(do-sync #t)) ;; TODO: actually use areapath (let ((tmpdb-stack (dbr:dbstruct-dbstack dbstruct))) ;; RA => Returns the first reference in dbstruct (if (stack? tmpdb-stack) (db:get-db tmpdb-stack) ;; get previously opened db (will create new db handle if all in the stack are already used - (let* ((dbpath (db:dbfile-path )) ;; path to tmp db area + (let* ((toppath (or area-path (dbr:dbstruct-area-path dbstruct) *toppath*)) + (dbpath (db:dbfile-path )) ;; path to tmp db area (dbexists (common:file-exists? dbpath)) (tmpdbfname (conc dbpath "/megatest.db")) (dbfexists (common:file-exists? tmpdbfname)) ;; (conc dbpath "/megatest.db"))) - (mtdbexists (common:file-exists? (conc *toppath* "/megatest.db"))) + (mtdbexists (common:file-exists? (conc toppath "/megatest.db"))) - (mtdb (db:open-megatest-db)) + (mtdb (db:open-megatest-db path: area-path)) (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)) Index: mtut.scm ================================================================== --- mtut.scm +++ mtut.scm @@ -439,14 +439,15 @@ ;; (print "Alldat: " alldat ;; " args-data: " args-data) (add-z-card (apply construct-sdat alldat)))) +;; merge/consolidate with common:simple-setup (define (simple-setup start-dir-in) (let* ((start-dir (or start-dir-in ".")) (mtconfig (or (args:get-arg "-config") "megatest.config")) - (mtconfdat (find-and-read-config ;; NB// sets MT_RUN_AREA_HOME as side effect + (mtconfdat (find-and-read-config ;; NB// sets MT_RUN_AREA_HOME as side effect -> NOPE! Not if pathenvvar is #f mtconfig ;; environ-patt: "env-override" given-toppath: start-dir ;; pathenvvar: "MT_RUN_AREA_HOME" ))