Index: TODO
==================================================================
--- TODO
+++ TODO
@@ -13,66 +13,10 @@
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with Megatest. If not, see .
-NOTE: This file gets copied occasionally into the wiki as "Roadmap".
- Do not make changes in the wiki, they will be lost!
-
-See the file "DONE" to see completed items.
-FIXME
-====
-
-.dump
-----------------
-WARNING: disk disk0 at path "/mfs/tmp/archive" is not a directory - ignoring it.
-
-Warning (#): in thread: unbound variable: block-id
-
- Call history:
-
- common.scm:693: hash-table-ref/default
- common.scm:694: current-seconds
- common.scm:697: hash-table-set!
- common.scm:2232: debug:print
- common_records.scm:140: debug:debug-mode
- common_records.scm:141: with-output-to-port
- common.scm:2245: directory?
- common.scm:2246: common:low-noise-print
- common.scm:692: g2022
- common.scm:692: g2022
- common.scm:692: string-intersperse
- common.scm:693: hash-table-ref/default
- common.scm:694: current-seconds
- common.scm:2261: debug:print
- common_records.scm:140: debug:debug-mode
- archive.scm:125: debug:print <--
-INFO: (0) Estimating disk space usage for scriptinc/: 184
-
-Error: uncaught exception: #
-
- Call history:
-
- common.scm:1299: ##sys#get-keyword
- common.scm:1299: call-with-current-continuation
- common.scm:1299: with-exception-handler
- common.scm:1299: ##sys#call-with-values
- common.scm:1304: thunk
- common.scm:1310: file-exists?
- common.scm:1299: k2554
- common.scm:1299: g2558
- runs.scm:2438: common:get-disk-space-used
- common.scm:2128: conc
- common.scm:2128: with-input-from-pipe
- runs.scm:2438: debug:print-info
- common_records.scm:235: debug:debug-mode
- common_records.scm:236: port?
- common_records.scm:236: with-output-to-port
- runs.scm:2443: thread-join! <--
-Press any key to continue
-----------------
-
TODO
====
WW15
. fill newview matrix with data, filter pipeline gui elements
@@ -106,7 +50,9 @@
-------------------------------------
. Re-work the dbstruct data structure?
.. Move main.db to global?
.. [ run-id.db inmemdb last-mod last-read last-sync inuse ]
+. Re-work all queries to use run-id to dereference server
. Open main.db directly in calls to -runtests etc. No need to talk remote?
+. remove common:faux-lock
Index: api.scm
==================================================================
--- api.scm
+++ api.scm
@@ -120,10 +120,13 @@
test-data-rollup
csv->test-data
;; MISC
sync-inmem->db
+ drop-all-triggers
+ create-all-triggers
+ update-tesdata-on-repilcate-db
;; TESTMETA
testmeta-add-record
testmeta-update-field
@@ -213,11 +216,14 @@
((delete-run) (apply db:delete-run dbstruct params))
((lock/unlock-run) (apply db:lock/unlock-run dbstruct params))
((update-run-event_time) (apply db:update-run-event_time dbstruct params))
((update-run-stats) (apply db:update-run-stats dbstruct params))
((set-var) (apply db:set-var dbstruct params))
+ ((inc-var) (apply db:inc-var dbstruct params))
+ ((dec-var) (apply db:dec-var dbstruct params))
((del-var) (apply db:del-var dbstruct params))
+ ((add-var) (apply db:add-var dbstruct params))
;; STEPS
((teststep-set-status!) (apply db:teststep-set-status! dbstruct params))
((delete-steps-for-test!) (apply db:delete-steps-for-test! dbstruct params))
@@ -227,10 +233,12 @@
;; MISC
((sync-inmem->db) (let ((run-id (car params)))
(db:sync-touched dbstruct run-id force-sync: #t)))
((mark-incomplete) (apply db:find-and-mark-incomplete dbstruct params))
+ ((create-all-triggers) (db:create-all-triggers dbstruct))
+ ((drop-all-triggers) (db:drop-all-triggers dbstruct))
;; TESTMETA
((testmeta-add-record) (apply db:testmeta-add-record dbstruct params))
((testmeta-update-field) (apply db:testmeta-update-field dbstruct params))
((get-tests-tags) (db:get-tests-tags dbstruct))
@@ -292,10 +300,11 @@
((get-run-info) (apply db:get-run-info dbstruct params))
((get-run-status) (apply db:get-run-status dbstruct params))
((get-run-state) (apply db:get-run-state dbstruct params))
((set-run-status) (apply db:set-run-status dbstruct params))
((set-run-state-status) (apply db:set-run-state-status dbstruct params))
+ ((update-tesdata-on-repilcate-db) (apply db:update-tesdata-on-repilcate-db dbstruct params))
((get-tests-for-run) (apply db:get-tests-for-run dbstruct params))
((get-tests-for-run-state-status) (apply db:get-tests-for-run-state-status dbstruct params))
((get-test-id) (apply db:get-test-id dbstruct params))
((get-tests-for-run-mindata) (apply db:get-tests-for-run-mindata dbstruct params))
;; ((get-tests-for-runs-mindata) (apply db:get-tests-for-runs-mindata dbstruct params))
Index: archive.scm
==================================================================
--- archive.scm
+++ archive.scm
@@ -136,10 +136,11 @@
;; 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-testsuite-name))
+ (target (string-intersperse (map cadr (rmt:get-key-val-pairs run-id)) "/"))
(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))
@@ -150,13 +151,16 @@
(if s (string->symbol s) 'bup)))
(archiver-cmd (case archiver
((tar) "tar cfj ARCHIVE_NAME.tar.bz2 ")
((7z) " 7z u -t7z -m0=lzma -mx=9 -mfb=64 -md=32m -ms=on ARCHIVE_NAME.7z ")
(else #f)))
+ (src-archive-linktree (rmt:get-var "src-archive-linktree"))
(print-prefix "Running: ") ;; change to #f to turn off printing
(preclean-spec (configf:get-section *configdat* "archive-preclean")))
+ (if (or (not src-archive-linktree) (not (equal? src-archive-linktree linktree)))
+ (rmt:set-var "src-archive-linktree" linktree))
;; (tests:match patt testname itempath)
;; from the test info bin the path to the test by stem
;;
(for-each
@@ -163,12 +167,11 @@
(lambda (test-dat)
(let* ((item-path (db:test-get-item-path test-dat))
(test-name (db:test-get-testname test-dat))
(test-id (db:test-get-id 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)))
(test-partial-path (conc target "/" run-name "/" (db:test-make-full-name test-name item-path)))
;; note the trailing slash to get the dir inspite of it being a link
(test-path (conc linktree "/" test-partial-path))
@@ -185,13 +188,11 @@
partial-path-index)
#f))
;; we need our archive dir checked for every test to enable folks who want to store other ways.
(archive-info (archive:allocate-new-archive-block blockid-cache *toppath* tsname min-space target run-name test-name))
(archive-dir (if archive-info (cdr archive-info) #f))
- (archive-id (if archive-info (car archive-info) -1))
-
- )
+ (archive-id (if archive-info (car archive-info) -1)))
(if (not archive-dir) ;; no archive disk found, this is fatal
(begin
(debug:print 0 *default-log-port* "FATAL: No archive disks found. Please add disks with at least "
min-space " MB space to the [archive-disks] section of megatest.config")
@@ -312,16 +313,131 @@
(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)
- (if (member archive-command '("save-remove"))
- (runs:remove-test-directory test-dat 'archive-remove))))
+ (if (member (symbol->string archive-command) '("save-remove"))
+ (begin
+ (debug:print-info 0 *default-log-port* "remove testdat")
+ (runs:remove-test-directory test-dat 'archive-remove)))))
(hash-table-ref test-groups test-base)))))
(hash-table-keys disk-groups))
#t))
+(define (archive:megatest-db target-patt run-patt)
+ (let* ((blockid-cache (make-hash-table))
+ (tsname (common:get-testsuite-name))
+ (min-space (string->number (or (configf:lookup *configdat* "archive" "minspace") "1000")))
+ (bup-exe (or (configf:lookup *configdat* "archive" "bup") "bup"))
+ (compress (or (configf:lookup *configdat* "archive" "compress") "9"))
+ (archiver (let ((s (configf:lookup *configdat* "archive" "archiver")))
+ (if s (string->symbol s) 'bup)))
+ (rsync-exe (or (configf:lookup *configdat* "archive" "rsync") "rsync"))
+ (print-prefix "Running: ")
+ (archive-info (archive:allocate-new-archive-block blockid-cache *toppath* tsname min-space target-patt run-patt "megatest-db"))
+ (archive-dir (if archive-info (cdr archive-info) #f))
+ (archive-id (if archive-info (car archive-info) -1))
+ (home-host (common:get-homehost))
+ (archive-time (seconds->std-time-str (current-seconds)))
+ (archive-staging-db (conc *toppath* "/logs/archive_" archive-time))
+ (tmp-db-path (conc (common:get-db-tmp-area) "/megatest.db"))
+ (dbfile (conc archive-staging-db "/megatest.db")))
+ (create-directory archive-staging-db #t)
+ (let-values (((pid-val exit-status exit-code) (run-n-wait rsync-exe params: (list "-v" (conc (car home-host) ":"tmp-db-path) archive-staging-db) print-cmd: print-prefix)))
+ (if (eq? exit-code 0)
+ (case archiver
+ ((bup) ;; Archive using bup
+ (let* ((bup-init-params (list "-d" archive-dir "init"))
+ (bup-index-params (list "-d" archive-dir "index" archive-staging-db))
+ (bup-save-params (list "-d" archive-dir "save" ;; (conc "--strip-path=" linktree)
+ (conc "-" compress) ;; or (conc "--compress=" compress)
+ "-n" (conc tsname "-megatest-db" )
+ (conc "--strip-path=" archive-staging-db ) ;; if we push to the directory do we need this?
+ dbfile)))
+ (if (not (common:file-exists? (conc archive-dir "/HEAD")))
+ (begin
+ ;; replace this with jobrunner stuff enventually
+ (debug:print-info 0 *default-log-port* "Init bup in " archive-dir)
+ (run-n-wait bup-exe params: bup-init-params print-cmd: print-prefix)))
+ (debug:print-info 0 *default-log-port* "Indexing data to be archived")
+ (run-n-wait bup-exe params: bup-index-params print-cmd: print-prefix)
+ (debug:print-info 0 *default-log-port* "Archiving data with bup")
+ (run-n-wait bup-exe params: bup-save-params print-cmd: print-prefix)))
+ (else
+ (debug:print-info 0 *default-log-port* "No support for databse archiving with " archiver)))
+ (debug:print-error 0 *default-log-port* "There was an error rsyncing tmp database")))))
+
+(define (archive:restore-db archive-path ts)
+ (let* ((bup-exe (or (configf:lookup *configdat* "archive" "bup") "bup"))
+ (archive-internal-path (conc (common:get-testsuite-name) "-megatest-db/" ts "/megatest.db" ))
+ (bup-restore-params (list "-d" archive-path "restore" "-C" *toppath* archive-internal-path)))
+ (debug:print-info 0 *default-log-port* "Restoring archived data to " *toppath* " from archive in " archive-path " ... " archive-internal-path)
+ (run-n-wait bup-exe params: bup-restore-params print-cmd: #f))
+ (db:multi-db-sync
+ (db:setup #f)
+ 'killservers
+ ;'dejunk
+ ;'adj-testids
+ 'old2new
+ )
+ (debug:print-info 1 *default-log-port* "dropping trigerrs to update linktree")
+ (rmt:drop-all-triggers)
+
+ (let* ((linktree (common:get-linktree)) ;; (configf:lookup *configdat* "setup" "linktree")))
+ (src-archive-linktree (rmt:get-var "src-archive-linktree")))
+ (if (not (equal? src-archive-linktree linktree))
+ (rmt:update-tesdata-on-repilcate-db src-archive-linktree linktree))
+ (debug:print-info 1 *default-log-port* "creating triggers after updating linktree")
+ (rmt:create-all-triggers)
+))
+
+(define (archive:ls->list bup-exe archive-dir internal-path)
+ (let ((cmd (conc bup-exe " -d " archive-dir " ls -l " internal-path "| awk '{print $6}' | sort"))
+ (res '()))
+ (handle-exceptions
+ exn
+ #f ;; anything goes wrong - assume the process in NOT running.
+ (with-input-from-pipe
+ cmd
+ (lambda ()
+ (let* ((inl (read-lines)))
+ (reverse inl)))))))
+
+(define (time-string->seconds tstr ds-flag)
+ (let* ((atime (string->time tstr "%Y-%m-%d-%H%M%S")))
+ (vector-set! atime 8 ds-flag)
+ (local-time->seconds atime)))
+
+(define (seconds->std-time-str sec)
+ (time->string
+ (seconds->local-time sec)
+ "%Y-%m-%d-%H%M%S"))
+
+
+(define (archive:get-timestamp-dir bup-exe archive-dir testsuite-name run-id test-partial-path test-last-update)
+ (print (seconds->std-time-str test-last-update))
+ (let* ((internal-path (conc testsuite-name "-" run-id))
+ (ts-list (archive:ls->list bup-exe archive-dir internal-path))
+ (ds-flag (vector-ref (seconds->local-time) 8)))
+ (let loop ((hed (car ts-list))
+ (tail (cdr ts-list)))
+ (if (and (null? tail) (equal? hed "latest"))
+ #f
+ (if (and (not (null? tail)) (equal? hed "latest"))
+ (loop (car tail) (cdr tail))
+ (let* ((archive-seconds (time-string->seconds hed ds-flag)))
+ (if (< (abs (- archive-seconds test-last-update)) 120)
+ (let* ((test-list (archive:ls->list bup-exe archive-dir (conc internal-path "/" hed "/" test-partial-path))))
+ (if (> (length test-list) 0)
+ hed
+ (if (not (null? tail))
+ (loop (car tail) (cdr tail))
+ #f)))
+ (if (null? tail)
+ #f
+ (loop (car tail) (cdr tail))))))))))
+
(define (archive:bup-restore 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* ((bup-exe (or (configf:lookup *configdat* "archive" "bup") "bup"))
(linktree (common:get-linktree))) ;; (configf:lookup *configdat* "setup" "linktree")))
@@ -351,21 +467,24 @@
(common:real-path test-path)
#f))
(mutex-unlock! rp-mutex)
(new-test-physical-path (conc best-disk "/" test-partial-path))
(archive-block-id (db:test-get-archived test-dat))
+ (test-last-update (db:test-get-last_update 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-testsuite-name) "-" run-id "/latest/" test-partial-path))
+ (archive-timestamp-dir (if archive-path (archive:get-timestamp-dir bup-exe archive-path (common:get-testsuite-name) run-id test-partial-path test-last-update) #f))
+ (archive-internal-path (conc (common:get-testsuite-name) "-" run-id "/" archive-timestamp-dir "/" test-partial-path))
(include-paths (args:get-arg "-include"))
(exclude-pattern (args:get-arg "-exclude-rx"))
(exclude-file (args:get-arg "-exclude-rx-from")))
-
+ (if (not archive-timestamp-dir)
+ (debug:print-error 0 *default-log-port* "Archive not found for testsuite" (common:get-testsuite-name) " run/test/itempath" test-partial-path)
+ (begin
;; 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
(common:file-exists? prev-test-physical-path)) ;; what to do? abort or clean up or link it in?
(let* ((base (pathname-directory prev-test-physical-path))
(dirn (pathname-file prev-test-physical-path))
@@ -378,17 +497,14 @@
(begin
;; CREATE WORK AREA
;; test-src-path == #f ==> don't copy in data from tests directory
;; itemdat == string ==> use directly
(create-work-area run-id run-name keyvals test-id #f best-disk test-name item-path) ;; #!key (remtries 2))
-
;; 1. Get the block id from the test info
;; 2. Get the block data given the block id
;; 3. Construct the paths etc. for the following command:
- ;;
;; bup -d /tmp/matt/adisk1/2015_q1/fullrun_e1a40/ restore -C /tmp/seeme fullrun-30/latest/ubuntu/nfs/none/w02.1.20.54_b/
-
;; DO BUP RESTORE
(let* ((new-test-dat (rmt:get-test-info-by-id run-id test-id))
(new-test-path (if (vector? new-test-dat )
(db:test-get-rundir new-test-dat)
(begin
@@ -395,15 +511,16 @@
(debug:print-error 0 *default-log-port* "unable to get data for run-id=" run-id ", test-id=" test-id)
(exit 1))))
;; new-test-path won't work - must use best-disk instead? Nope, new-test-path but tack on /..
(bup-restore-params (list "-d" archive-path "restore" "-C" (conc new-test-path "/..") archive-internal-path)))
(debug:print-info 0 *default-log-port* "Restoring archived data to " new-test-physical-path " from archive in " archive-path " ... " archive-internal-path)
+ (debug:print-info 0 *default-log-port* bup-exe " " (string-join bup-restore-params " "))
;; (mutex-lock! bup-mutex)
(run-n-wait bup-exe params: bup-restore-params print-cmd: #f)
;; (mutex-unlock! bup-mutex)
(mt:test-set-state-status-by-id run-id test-id "COMPLETED" #f #f)))
- (debug:print-error 0 *default-log-port* "No archive path in the record for run-id=" run-id " test-id=" test-id))))
+ (debug:print-error 0 *default-log-port* "No archive path in the record for run-id=" run-id " test-id=" test-id))))))
(filter vector? tests))))
(define (common:get-youngest-test tests)
(if (null? tests)
#f
Index: common.scm
==================================================================
--- common.scm
+++ common.scm
@@ -514,17 +514,19 @@
(debug:print 2 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
;; (print-call-chain (current-error-port)) ;;
)
(let* ((fullname (conc "logs/" file))
(mod-time (file-modification-time fullname))
- (file-age (- (current-seconds) mod-time)))
+ (file-age (- (current-seconds) mod-time))
+ (file-old (> file-age (* 48 60 60)))
+ (file-big (> (file-size fullname) 200000)))
(hash-table-set! all-files file mod-time)
(if (or (and (string-match "^.*.log" file)
- (> (file-size fullname) 200000))
+ file-old
+ file-big)
(and (string-match "^server-.*.log" file)
- (> (- (current-seconds) (file-modification-time fullname))
- (* 8 60 60))))
+ file-old))
(let ((gzfile (conc fullname ".gz")))
(if (common:file-exists? gzfile)
(begin
(debug:print-info 0 *default-log-port* "removing " gzfile)
(delete-file* gzfile)
@@ -534,11 +536,12 @@
(system (conc "gzip " fullname))
(inc-stat "gzipped")
(hash-table-set! all-files (conc file ".gz") file-age) ;; add the .gz file and remove the base file
(hash-table-delete! all-files file)
)
- (if (> file-age (* (string->number (or (configf:lookup *configdat* "setup" "log-expire-days") "30")) 24 3600))
+ (if (and (> file-age (* (string->number (or (configf:lookup *configdat* "setup" "log-expire-days") "30")) 24 3600))
+ (file-exists? fullname)) ;; just in case it was gzipped - will get it next time
(handle-exceptions
exn
#f
(if (directory? fullname)
(begin
@@ -902,11 +905,16 @@
(define (assoc/default key lst . default)
(let ((res (assoc key lst)))
(if res (cadr res)(if (null? default) #f (car default)))))
(define (common:get-testsuite-name)
- (cmod:get-testsuite-name *toppath* *configdat*))
+ (or (configf:lookup *configdat* "setup" "area-name") ;; megatest is a flexible tool, testsuite is too limiting a description.
+ (configf:lookup *configdat* "setup" "testsuite" )
+ (getenv "MT_TESTSUITE_NAME")
+ (if (string? *toppath* )
+ (pathname-file *toppath*)
+ #f))) ;; (pathname-file (current-directory)))))
;; safe getting of toppath
(define (common:get-toppath areapath)
(or *toppath*
(if areapath
@@ -1652,17 +1660,29 @@
))))))
;; if it looks like a number -> convert it to a number, else return it
;;
(define (common:lazy-convert inval)
- (cmod:lazy-convert inval))
+ (let* ((as-num (if (string? inval)(string->number inval) #f)))
+ (or as-num inval)))
;; convert string a=1; b=2; c=a silly thing; d=
;; to '((a . 1)(b . 2)(c . "a silly thing")(d . ""))
;;
(define (common:val->alist val #!key (convert #f))
- (cmod:val->alist val #!key (convert #f)))
+ (let ((val-list (string-split-fields ";\\s*" val #:infix)))
+ (if val-list
+ (map (lambda (x)
+ (let ((f (string-split-fields "\\s*=\\s*" x #:infix)))
+ (case (length f)
+ ((0) `(,#f)) ;; null string case
+ ((1) `(,(string->symbol (car f))))
+ ((2) `(,(string->symbol (car f)) . ,(let ((inval (cadr f)))
+ (if convert (common:lazy-convert inval) inval))))
+ (else f))))
+ val-list)
+ '())))
;;======================================================================
;; S Y S T E M S T U F F
;;======================================================================
Index: configf.scm
==================================================================
--- configf.scm
+++ configf.scm
@@ -9,11 +9,11 @@
;; (at your option) any later version.
;;
;; Megatest is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNnU General Public License for more details.
+;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see .
;;======================================================================
@@ -192,12 +192,12 @@
(configf:process-line inl ht allow-processing))
((return-string)
inl)
(else
(configf:process-line inl ht allow-processing)))))
- (if (and (string? res)
- (not (equal? (hash-table-ref/default settings "trim-trailing-spaces" "no") "yes")))
+ (if (and (string? res) ;; must set to "no" to force NOT trimming trailing spaces
+ (not (equal? (hash-table-ref/default settings "trim-trailing-spaces" "yes") "no")))
(string-substitute "\\s+$" "" res)
res))))))
(define (configf:cfgdat->env-alist section cfgdat-ht allow-system)
(filter
@@ -501,10 +501,22 @@
(if (and toppath pathenvvar)(setenv pathenvvar toppath))
(let ((configdat (if configfile
(read-config configfile #f #t environ-patt: environ-patt post-section-procs: (list (cons "^fields$" set-fields)) #f))))
(if toppath (change-directory curr-dir))
(list configdat toppath configfile fname))))
+
+(define (configf:lookup cfgdat section var)
+ (if (hash-table? cfgdat)
+ (let ((sectdat (hash-table-ref/default cfgdat section '())))
+ (if (null? sectdat)
+ #f
+ (let ((match (assoc var sectdat)))
+ (if match ;; (and match (list? match)(> (length match) 1))
+ (cadr match)
+ #f))
+ ))
+ #f))
;; use to have definitive setting:
;; [foo]
;; var yes
;;
Index: dashboard.scm
==================================================================
--- dashboard.scm
+++ dashboard.scm
@@ -3796,10 +3796,11 @@
(dboard:commondat-add-updater
commondat
(lambda ()
(dashboard:runs-tab-updater commondat 1))
tab-num: 1)
+ ;; may not want this alive (manually merged it from v1.66)
(dboard:commondat-add-updater
commondat
(lambda ()
(dashboard:runs-tab-updater commondat 1))
tab-num: 2)
Index: db.scm
==================================================================
--- db.scm
+++ db.scm
@@ -58,10 +58,11 @@
(mtdb #f)
(refndb #f)
(homehost #f) ;; not used yet
(on-homehost #f) ;; not used yet
(read-only #f)
+ (stmt-cache (make-hash-table))
) ;; 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
@@ -68,10 +69,43 @@
;;
(defstruct dbr:counts
(state #f)
(status #f)
(count 0))
+
+;;======================================================================
+;; alist-of-alists
+;;======================================================================
+;;
+;; (define (db:aa-set! dat key1 key2 val)
+;; (let loop ((
+
+;;======================================================================
+;; hash of hashs
+;;======================================================================
+
+
+(define (db:hoh-set! dat key1 key2 val)
+ (let* ((subhash (hash-table-ref/default dat key1 #f)))
+ (if subhash
+ (hash-table-set! subhash key2 val)
+ (begin
+ (hash-table-set! dat key1 (make-hash-table))
+ (db:hoh-set! dat key1 key2 val)))))
+
+(define (db:hoh-get dat key1 key2)
+ (let* ((subhash (hash-table-ref/default dat key1 #f)))
+ (and subhash
+ (hash-table-ref/default subhash key2 #f))))
+
+(define (db:get-cache-stmth dbstruct db stmt)
+ (let* ((stmt-cache (dbr:dbstruct-stmt-cache dbstruct))
+ (stmth (db:hoh-get stmt-cache db stmt)))
+ (or stmth
+ (let* ((newstmth (sqlite3:prepare db stmt)))
+ (db:hoh-set! stmt-cache db stmt newstmth)
+ newstmth))))
;;======================================================================
;; SQLITE3 HELPERS
;;======================================================================
@@ -415,21 +449,22 @@
(set! *db-last-sync* start-t)
(set! *db-last-access* start-t)
(mutex-unlock! *db-multi-sync-mutex*)
(stack-push! (dbr:dbstruct-dbstack dbstruct) tmpdb)))
-(define (db:safely-close-sqlite3-db db #!key (try-num 3))
+(define (db:safely-close-sqlite3-db db stmt-cache #!key (try-num 3))
(if (<= try-num 0)
#f
(handle-exceptions
exn
(begin
(thread-sleep! 3)
(sqlite3:interrupt! db)
(db:safely-close-sqlite3-db db try-num: (- try-num 1)))
(if (sqlite3:database? db)
- (begin
+ (let* ((stmts (hash-table-ref/default stmt-cache db #f)))
+ (if stmts (map sqlite3:finalize! (hash-table-values stmts)))
(sqlite3:finalize! db)
#t)
#f))))
;; close all opened run-id dbs
@@ -439,21 +474,20 @@
exn
(begin
(debug:print 0 *default-log-port* "WARNING: Finalizing failed, " ((condition-property-accessor 'exn 'message) exn))
(print-call-chain *default-log-port*))
;; (db:sync-touched dbstruct 0 force-sync: #t) ;; NO. Do not do this here. Instead we rely on a server to be started when there are writes, even if the server itself is not going to be used as a server.
- (let ((tdbs (map db:dbdat-get-db
- (stack->list (dbr:dbstruct-dbstack dbstruct))))
- (mdb (db:dbdat-get-db (dbr:dbstruct-mtdb dbstruct)))
- (rdb (db:dbdat-get-db (dbr:dbstruct-refndb dbstruct))))
+ (let ((tdbs (map db:dbdat-get-db
+ (stack->list (dbr:dbstruct-dbstack dbstruct))))
+ (mdb (db:dbdat-get-db (dbr:dbstruct-mtdb dbstruct)))
+ (rdb (db:dbdat-get-db (dbr:dbstruct-refndb dbstruct)))
+ (stmt-cache (dbr:dbstruct-stmt-cache dbstruct)))
(map (lambda (db)
- (db:safely-close-sqlite3-db db))
-;; (if (sqlite3:database? db)
-;; (sqlite3:finalize! db)))
+ (db:safely-close-sqlite3-db stmt-cache db))
tdbs)
- (db:safely-close-sqlite3-db mdb) ;; (if (sqlite3:database? mdb) (sqlite3:finalize! mdb))
- (db:safely-close-sqlite3-db rdb))))) ;; (if (sqlite3:database? rdb) (sqlite3:finalize! rdb))))))
+ (db:safely-close-sqlite3-db stmt-cache mdb) ;; (if (sqlite3:database? mdb) (sqlite3:finalize! mdb))
+ (db:safely-close-sqlite3-db stmt-cache rdb))))) ;; (if (sqlite3:database? rdb) (sqlite3:finalize! rdb))))))
;; (let ((locdbs (dbr:dbstruct-locdbs dbstruct)))
;; (if (hash-table? locdbs)
;; (for-each (lambda (run-id)
;; (db:close-run-db dbstruct run-id))
@@ -532,10 +566,26 @@
(append (list "runs"
'("id" #f))
(map (lambda (k)(list k #f))
(append keys
(list "runname" "state" "status" "owner" "event_time" "comment" "fail_count" "pass_count" "contour" "last_update"))))
+ (list "archive_disks"
+ '("id" #f)
+ '("archive_area_name" #f)
+ '("disk_path" #f)
+ '("last_df" #f)
+ '("last_df_time" #f)
+ '("creation_time" #f))
+
+ (list "archive_blocks"
+ '("id" #f)
+ '("archive_disk_id" #f)
+ '("disk_path" #f)
+ '("last_du" #f)
+ '("last_du_time" #f)
+ '("creation_time" #f))
+
(list "test_meta"
'("id" #f)
'("testname" #f)
'("owner" #f)
'("description" #f)
@@ -696,13 +746,14 @@
(member "last_update" fields))
#t) ;; if given a number, just use it for all fields
((number? last-update) #f) ;; if not matched first entry then ignore last-update for this table
((and (pair? last-update)
(member (car last-update) ;; last-update field name
- (map car fields))) #t)
+ (map car fields)))
+ #t)
(last-update
- (debug:print 0 *default-log-port* "ERROR: parameter last-update for db:sync-tables must be a pair or a number, received: " last-update) ;; found in fields
+ (debug:print 0 *default-log-port* "ERROR: parameter last-update for db:sync-tables must be a pair or a number, received: " last-update);; found in fields
#f)
(else
#f)))
(last-update-value (if use-last-update ;; no need to check for has-last-update - it is already accounted for
(if (number? last-update)
@@ -728,11 +779,11 @@
(fromdats '())
(totrecords 0)
(batch-len (string->number (or (configf:lookup *configdat* "sync" "batchsize") "100")))
(todat (make-hash-table))
(count 0)
-
+ (field-names (map car fields))
(delay-handicap (string->number (or (configf:lookup *configdat* "sync" "delay-handicap") "0")))
)
;; set up the field->num table
(for-each
@@ -775,12 +826,19 @@
;; first pass implementation, just insert all changed rows
(for-each
(lambda (targdb)
(let* ((db (db:dbdat-get-db targdb))
+ (drp-trigger (if (member "last_update" field-names)
+ (db:drop-trigger db tablename)
+ #f))
+ (is-trigger-dropped (if (member "last_update" field-names)
+ (db:is-trigger-dropped db tablename) #f))
(stmth (sqlite3:prepare db full-ins)))
(db:delay-if-busy targdb) ;; NO WAITING
+ (if (member "last_update" field-names)
+ (debug:print-info 3 *default-log-port* "is-trigger-dropped: " is-trigger-dropped))
(for-each
(lambda (fromdat-lst)
(sqlite3:with-transaction
db
(lambda ()
@@ -798,14 +856,15 @@
(loop (+ i 1))))
(if (not same)
(begin
(apply sqlite3:execute stmth (vector->list fromrow))
(hash-table-set! numrecs tablename (+ 1 (hash-table-ref/default numrecs tablename 0)))))))
- fromdat-lst))
- ))
+ fromdat-lst))))
fromdats)
- (sqlite3:finalize! stmth)))
+ (sqlite3:finalize! stmth)
+ (if (member "last_update" field-names)
+ (db:create-trigger db tablename))))
(append (list todb) slave-dbs))))
tbls)
(let* ((runtime (- (current-milliseconds) start-time))
(should-print (or (debug:debug-mode 12)
(common:low-noise-print 120 "db sync" (> runtime 500))))) ;; low and high sync times treated as separate.
@@ -1156,10 +1215,95 @@
;; (define open-run-close
#;(define open-run-close open-run-close-exception-handling)
;; open-run-close-no-exception-handling
;; open-run-close-exception-handling)
;;)
+
+(define db:trigger-list
+ (list (list "update_runs_trigger" "CREATE TRIGGER IF NOT EXISTS update_runs_trigger AFTER UPDATE ON runs
+ FOR EACH ROW
+ BEGIN
+ UPDATE runs SET last_update=(strftime('%s','now'))
+ WHERE id=old.id;
+ END;" )
+ (list "update_run_stats_trigger" "CREATE TRIGGER IF NOT EXISTS update_run_stats_trigger AFTER UPDATE ON run_stats
+ FOR EACH ROW
+ BEGIN
+ UPDATE run_stats SET last_update=(strftime('%s','now'))
+ WHERE id=old.id;
+ END;" )
+ (list "update_tests_trigger" "CREATE TRIGGER IF NOT EXISTS update_tests_trigger AFTER UPDATE ON tests
+ FOR EACH ROW
+ BEGIN
+ UPDATE tests SET last_update=(strftime('%s','now'))
+ WHERE id=old.id;
+ END;" )
+ (list "update_teststeps_trigger" "CREATE TRIGGER IF NOT EXISTS update_teststeps_trigger AFTER UPDATE ON test_steps
+ FOR EACH ROW
+ BEGIN
+ UPDATE test_steps SET last_update=(strftime('%s','now'))
+ WHERE id=old.id;
+ END;" )
+ (list "update_test_data_trigger" "CREATE TRIGGER IF NOT EXISTS update_test_data_trigger AFTER UPDATE ON test_data
+ FOR EACH ROW
+ BEGIN
+ UPDATE test_data SET last_update=(strftime('%s','now'))
+ WHERE id=old.id;
+ END;" )))
+
+(define (db:create-all-triggers dbstruct)
+(db:with-db
+ dbstruct #f #f
+ (lambda (db)
+(db:create-triggers db))))
+
+(define (db:create-triggers db)
+ (for-each (lambda (key)
+ (sqlite3:execute db (cadr key)))
+ db:trigger-list))
+
+(define (db:drop-all-triggers dbstruct)
+(db:with-db
+ dbstruct #f #f
+ (lambda (db)
+(db:drop-triggers db))))
+
+(define (db:is-trigger-dropped db tbl-name)
+ (let* ((trigger-name (if (equal? tbl-name "test_steps")
+ "update_teststeps_trigger"
+ (conc "update_" tbl-name "_trigger"))))
+ (sqlite3:for-each-row
+ (lambda (name)
+ ;(print name)
+ (set! res (vector name)))
+ db
+ "select name from sqlite_master where type = 'trigger' ;"
+ )))
+
+(define (db:drop-triggers db)
+ (for-each (lambda (key)
+ (sqlite3:execute db (conc "drop trigger " (car key))))
+ db:trigger-list))
+
+(define (db:drop-trigger db tbl-name)
+ (let* ((trigger-name (if (equal? tbl-name "test_steps")
+ "update_teststeps_trigger"
+ (conc "update_" tbl-name "_trigger"))))
+ (for-each (lambda (key)
+ (if (equal? (car key) trigger-name)
+ (sqlite3:execute db (conc "drop trigger " trigger-name))))
+ db:trigger-list)))
+
+(define (db:create-trigger db tbl-name)
+ (let* ((trigger-name (if (equal? tbl-name "test_steps")
+ "update_teststeps_trigger"
+ (conc "update_" tbl-name "_trigger"))))
+ (for-each (lambda (key)
+ (if (equal? (car key) trigger-name)
+ (sqlite3:execute db (cadr key))))
+ db:trigger-list)))
+
(define (db:initialize-main-db dbdat)
(when (not *configinfo*)
(launch:setup)) ;; added because Elena was getting stack dump because *configinfo* below was #f.
(let* ((configdat (car *configinfo*)) ;; tut tut, global warning...
@@ -1201,29 +1345,31 @@
comment TEXT DEFAULT '',
fail_count INTEGER DEFAULT 0,
pass_count INTEGER DEFAULT 0,
last_update INTEGER DEFAULT (strftime('%s','now')),
CONSTRAINT runsconstraint UNIQUE (runname" (if havekeys "," "") keystr "));"))
- (sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_runs_trigger AFTER UPDATE ON runs
- FOR EACH ROW
- BEGIN
- UPDATE runs SET last_update=(strftime('%s','now'))
- WHERE id=old.id;
- END;")
+ ;; All triggers created at once in end
+ ;;(sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_runs_trigger AFTER UPDATE ON runs
+ ;; FOR EACH ROW
+ ;; BEGIN
+ ;; UPDATE runs SET last_update=(strftime('%s','now'))
+ ;; WHERE id=old.id;
+ ;; END;")
(sqlite3:execute db "CREATE TABLE IF NOT EXISTS run_stats (
id INTEGER PRIMARY KEY,
run_id INTEGER,
state TEXT,
status TEXT,
count INTEGER,
last_update INTEGER DEFAULT (strftime('%s','now')))")
- (sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_run_stats_trigger AFTER UPDATE ON run_stats
- FOR EACH ROW
- BEGIN
- UPDATE run_stats SET last_update=(strftime('%s','now'))
- WHERE id=old.id;
- END;")
+ ;; All triggers created at once in end
+ ;; (sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_run_stats_trigger AFTER UPDATE ON run_stats
+ ;; FOR EACH ROW
+ ;; BEGIN
+ ;; UPDATE run_stats SET last_update=(strftime('%s','now'))
+ ;; WHERE id=old.id;
+ ;; END;")
(sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_meta (
id INTEGER PRIMARY KEY,
testname TEXT DEFAULT '',
author TEXT DEFAULT '',
owner TEXT DEFAULT '',
@@ -1319,17 +1465,18 @@
;; deprecated -- (sqlite3:execute db "CREATE INDEX IF NOT EXISTS tests_index ON tests (run_id, testname, item_path, uname);")
(sqlite3:execute db "CREATE INDEX IF NOT EXISTS tests_run_id_index ON tests (run_id);") ;; new
(sqlite3:execute db "CREATE INDEX IF NOT EXISTS tests_testname_index ON tests (testname,item_path);") ;; new
(sqlite3:execute db "CREATE INDEX IF NOT EXISTS tests_state_status_index ON tests (state, status); ") ;; new
-
- (sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_tests_trigger AFTER UPDATE ON tests
- FOR EACH ROW
- BEGIN
- UPDATE tests SET last_update=(strftime('%s','now'))
- WHERE id=old.id;
- END;")
+
+ ;; All triggers created at once in end
+ ;;(sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_tests_trigger AFTER UPDATE ON tests
+ ;; FOR EACH ROW
+ ;; BEGIN
+ ;; UPDATE tests SET last_update=(strftime('%s','now'))
+ ;; WHERE id=old.id;
+ ;; END;")
(sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_steps
(id INTEGER PRIMARY KEY,
test_id INTEGER,
stepname TEXT,
state TEXT DEFAULT 'NOT_STARTED',
@@ -1338,16 +1485,17 @@
comment TEXT DEFAULT '',
logfile TEXT DEFAULT '',
last_update INTEGER DEFAULT (strftime('%s','now')),
CONSTRAINT test_steps_constraint UNIQUE (test_id,stepname,state));")
(sqlite3:execute db "CREATE INDEX IF NOT EXISTS teststeps_index ON tests (run_id, testname, item_path);")
- (sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_teststeps_trigger AFTER UPDATE ON test_steps
- FOR EACH ROW
- BEGIN
- UPDATE test_steps SET last_update=(strftime('%s','now'))
- WHERE id=old.id;
- END;")
+ ;; All triggers created at once in end
+ ;;(sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_teststeps_trigger AFTER UPDATE ON test_steps
+ ;; FOR EACH ROW
+ ;; BEGIN
+ ;; UPDATE test_steps SET last_update=(strftime('%s','now'))
+ ;; WHERE id=old.id;
+ ;; END;")
(sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_data (id INTEGER PRIMARY KEY,
test_id INTEGER,
category TEXT DEFAULT '',
variable TEXT,
value REAL,
@@ -1358,16 +1506,17 @@
status TEXT DEFAULT 'n/a',
type TEXT DEFAULT '',
last_update INTEGER DEFAULT (strftime('%s','now')),
CONSTRAINT test_data_constraint UNIQUE (test_id,category,variable));")
(sqlite3:execute db "CREATE INDEX IF NOT EXISTS test_data_index ON test_data (test_id);")
- (sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_test_data_trigger AFTER UPDATE ON test_data
- FOR EACH ROW
- BEGIN
- UPDATE test_data SET last_update=(strftime('%s','now'))
- WHERE id=old.id;
- END;")
+ ;; All triggers created at once in end
+ ;;(sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_test_data_trigger AFTER UPDATE ON test_data
+ ;; FOR EACH ROW
+ ;; BEGIN
+ ;; UPDATE test_data SET last_update=(strftime('%s','now'))
+ ;; WHERE id=old.id;
+ ;; END;")
(sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_rundat (
id INTEGER PRIMARY KEY,
test_id INTEGER,
update_time TIMESTAMP,
cpuload INTEGER DEFAULT -1,
@@ -1380,10 +1529,12 @@
state TEXT DEFAULT 'new',
status TEXT DEFAULT 'n/a',
archive_type TEXT DEFAULT 'bup',
du INTEGER,
archive_path TEXT);")))
+ (print "creating trigges from init")
+ (db:create-triggers db)
db)) ;; )
;;======================================================================
;; A R C H I V E S
;;======================================================================
@@ -1607,35 +1758,22 @@
(if (and (null? incompleted)
(null? oldlaunched)
(null? toplevels))
#f
#t)))))
-
-;; given a launch delay (minimum time from last launch) return amount of time to wait
-;;
-;; (define (db:launch-delay-left dbstruct run-id launch-delay)
-
-
(define (db:get-status-from-final-status-file run-dir)
- (let (
- (infile (conc run-dir "/.final-status")))
-
- ;; first verify we are able to write the output file
- (if (not (file-read-access? infile))
- (begin
- (debug:print 0 *default-log-port* "ERROR: cannot read " infile)
+ (let ((infile (conc run-dir "/.final-status")))
+ ;; first verify we are able to write the output file
+ (if (not (file-read-access? infile))
+ (begin
+ (debug:print 0 *default-log-port* "ERROR: cannot read " infile)
(debug:print 0 *default-log-port* "ERROR: run-dir is " run-dir)
#f
)
- (with-input-from-file infile read-lines)
- )
- )
-)
-
-
-
+ (with-input-from-file infile read-lines)
+ )))
;; select end_time-now from
;; (select testname,item_path,event_time+run_duration as
;; end_time,strftime('%s','now') as now from tests where state in
;; ('RUNNING','REMOTEHOSTSTART','LAUNCHED'));
@@ -1754,10 +1892,12 @@
(debug:print 0 *default-log-port* "INFO: test " test-id " on host " host " has a process on pid " pid ", NOT setting to DEAD.")
(begin
(debug:print 0 *default-log-port* "INFO: test " test-id " final state/status is not COMPLETED/PASS. It is " result)
(db:set-state-status-and-roll-up-items dbstruct run-id test-id 'foo "COMPLETED" "DEAD"
"Test stopped responding while in RUNNING or REMOTEHOSTSTART; presumed dead.")))))))
+ ;; call end of eud of run detection for posthook - from merge, is it needed?
+ ;; (launch:end-of-run-check run-id)
all-ids)
;;call end of eud of run detection for posthook
(launch:end-of-run-check run-id)
)))))))
@@ -1952,10 +2092,20 @@
(if (string? res)
(let ((valnum (string->number res)))
(if valnum (set! res valnum))))
res))))
+(define (db:inc-var dbstruct var)
+ (db:with-db dbstruct #f #t
+ (lambda (db)
+ (sqlite3:execute db "UPDATE metadat SET val=val+1 WHERE var=?;" var))))
+
+(define (db:dec-var dbstruct var)
+ (db:with-db dbstruct #f #t
+ (lambda (db)
+ (sqlite3:execute db "UPDATE metadat SET val=val-1 WHERE var=?;" var))))
+
;; This was part of db:get-var. It was used to estimate the load on
;; the database files.
;;
;; scale by 10, average with current value.
;; (set! *global-delta* (/ (+ *global-delta* (* (- (current-milliseconds) start-ms)
@@ -1969,10 +2119,15 @@
(define (db:set-var dbstruct var val)
(db:with-db dbstruct #f #t
(lambda (db)
(sqlite3:execute db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" var val))))
+(define (db:add-var dbstruct var val)
+ (db:with-db dbstruct #f #t
+ (lambda (db)
+ (sqlite3:execute db "UPDATE metadat SET val=val+? WHERE var=?;" val var))))
+
(define (db:del-var dbstruct var)
(db:with-db dbstruct #f #t
(lambda (db)
(sqlite3:execute db "DELETE FROM metadat WHERE var=?;" var))))
@@ -2854,23 +3009,27 @@
(if limit (conc " LIMIT " limit) " ")
(if offset (conc " OFFSET " offset) " ")
";"
)))
(debug:print-info 8 *default-log-port* "db:get-tests-for-run run-id=" run-id ", qry=" qry)
- (db:with-db dbstruct run-id #f
- (lambda (db)
- (sqlite3:for-each-row
- (lambda (a . b) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment)
- (set! res (cons (apply vector a b) res))) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment) res)))
- db
- qry
- (or run-id 1) ;; 1 > 0 , for the case where we are seeking tests matching criteral for all runs
- )))
- (case qryvals
- ((shortlist)(map db:test-short-record->norm res))
- ((#f) res)
- (else res))))
+ (let* ((res (db:with-db dbstruct run-id #f
+ (lambda (db)
+ ;; (let* ((stmth (db:get-cache-stmth dbstruct db qry))) ;; due to use of last-update we can't efficiently cache this query
+ (reverse
+ (sqlite3:fold-row
+ (lambda (res . row)
+ ;; id run-id testname state status event-time host cpuload
+ ;; diskfree uname rundir item-path run-duration final-logf comment)
+ (cons (list->vector row) res))
+ '()
+ db qry ;; stmth
+ (or run-id 1) ;; 1 > 0 , for the case where we are seeking tests matching criteral for all runs
+ ))))))
+ (case qryvals
+ ((shortlist)(map db:test-short-record->norm res))
+ ((#f) res)
+ (else res)))))
(define (db:test-short-record->norm inrec)
;; "id,run_id,testname,item_path,state,status"
;; "id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment
(vector (vector-ref inrec 0) ;; id
@@ -2880,26 +3039,38 @@
(vector-ref inrec 5) ;; status
-1 "" -1 -1 "" "-"
(vector-ref inrec 3) ;; item-path
-1 "-" "-"))
-#;(define (db:get-tests-for-run-state-status dbstruct run-id testpatt)
- (let* ((res '())
- (tests-match-qry (tests:match->sqlqry testpatt))
- (qry (conc "SELECT id,testname,item_path,state,status FROM tests WHERE run_id=? "
- (if tests-match-qry (conc " AND (" tests-match-qry ") ") ""))))
- (debug:print-info 8 *default-log-port* "db:get-tests-for-run qry=" qry)
- (db:with-db dbstruct run-id #f
- (lambda (db)
- (sqlite3:for-each-row
- (lambda (id testname item-path state status)
- ;; id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment
- (set! res (cons (vector id run-id testname state status -1 "" -1 -1 "" "-" item-path -1 "-" "-") res)))
- db
- qry
- run-id)))
- res))
+;;
+;; 1. cache tests-match-qry
+;; 2. compile qry and store in hash
+;; 3. convert for-each-row to fold
+;;
+(define (db:get-tests-for-run-state-status dbstruct run-id testpatt)
+ (db:with-db
+ dbstruct run-id #f
+ (lambda (db)
+ (let* ((res '())
+ (stmt-cache (dbr:dbstruct-stmt-cache dbstruct))
+ (stmth (let* ((sh (db:hoh-get stmt-cache db testpatt)))
+ (or sh
+ (let* ((tests-match-qry (tests:match->sqlqry testpatt))
+ (qry (conc "SELECT id,testname,item_path,state,status FROM tests WHERE run_id=? "
+ (if tests-match-qry (conc " AND (" tests-match-qry ") ") "")))
+ (newsh (sqlite3:prepare db qry)))
+ (debug:print-info 8 *default-log-port* "db:get-tests-for-run qry=" qry)
+ (db:hoh-set! stmt-cache db testpatt newsh)
+ newsh)))))
+ (reverse
+ (sqlite3:fold-row
+ (lambda (res id testname item-path state status)
+ ;; id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment
+ (cons (vector id run-id testname state status -1 "" -1 -1 "" "-" item-path -1 "-" "-") res))
+ '()
+ stmth
+ run-id))))))
(define (db:get-tests-for-run-state-status dbstruct run-id testpatt #!optional (last-update 0))
(let* ((res '())
(tests-match-qry (tests:match->sqlqry testpatt))
(qry (conc "SELECT id,testname,item_path,state,status,event_time,run_duration FROM tests WHERE run_id=? "
@@ -3040,23 +3211,21 @@
test-id))))))
(mt:process-triggers dbstruct run-id test-id newstate newstatus))
;; NEW BEHAVIOR: Count tests running in all runs!
;;
-(define (db:get-count-tests-running dbstruct run-id)
+(define (db:get-count-tests-running dbstruct run-id fastmode)
+ (let* ((qry (if fastmode
+ "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND NOT (uname = 'n/a' AND item_path = '') LIMIT 1;"
+ "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND NOT (uname = 'n/a' AND item_path = '');")))
(db:with-db
dbstruct
run-id
#f
(lambda (db)
- (sqlite3:first-result
- db
- ;; WARNING BUG EDIT ME - merged from v1.55 - not sure what is right here ...
- ;; AND run_id NOT IN (SELECT id FROM runs WHERE state='deleted')
- "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND NOT (uname = 'n/a' AND item_path = '');"
- ;; "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND run_id=?;"
- ))))
+ (let* ((stmth (db:get-cache-stmth dbstruct db qry)))
+ (sqlite3:first-result stmth))))))
;; NEW BEHAVIOR: Count tests running in only one run!
;;
(define (db:get-count-tests-actually-running dbstruct run-id)
(db:with-db
@@ -3072,19 +3241,21 @@
run-id)))) ;; NOT IN (SELECT id FROM runs WHERE state='deleted');")
;; NEW BEHAVIOR: Look only at single run with run-id
;;
;; (define (db:get-running-stats dbstruct run-id)
-(define (db:get-count-tests-running-for-run-id dbstruct run-id)
- (db:with-db
- dbstruct
- run-id
- #f
- (lambda (db)
- (sqlite3:first-result
- db
- "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND run_id=?;" run-id))))
+(define (db:get-count-tests-running-for-run-id dbstruct run-id fastmode)
+ (let* ((qry (if fastmode
+ "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND run_id=? LIMIT 1;"
+ "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND run_id=?;")))
+ (db:with-db
+ dbstruct
+ run-id
+ #f
+ (lambda (db)
+ (let* ((stmth (db:get-cache-stmth dbstruct db qry)))
+ (sqlite3:first-result stmth run-id))))))
;; For a given testname how many items are running? Used to determine
;; probability for regenerating html
;;
(define (db:get-count-tests-running-for-testname dbstruct run-id testname)
@@ -3091,14 +3262,14 @@
(db:with-db
dbstruct
run-id
#f
(lambda (db)
- (sqlite3:first-result
- db
- "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND run_id=? AND NOT (uname = 'n/a' AND item_path = '') AND testname=?;" run-id testname))))
-
+ (let* ((stmt "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND run_id=? AND NOT (uname = 'n/a' AND item_path = '') AND testname=?;")
+ (stmth (db:get-cache-stmth dbstruct db stmt)))
+ (sqlite3:first-result
+ stmth run-id testname)))))
(define (db:get-not-completed-cnt dbstruct run-id)
(db:with-db
dbstruct
run-id
@@ -3209,10 +3380,16 @@
#f
(loop (car tal)(cdr tal)(+ indx 1)))))))
(define db:test-record-qry-selector (string-intersperse db:test-record-fields ","))
+(define (db:update-tesdata-on-repilcate-db dbstruct old-lt new-lt)
+ (db:with-db
+ dbstruct #f #f
+ (lambda (db)
+ (sqlite3:execute db "UPDATE tests SET rundir= replace(rundir,?,?), shortdir=replace(shortdir,?,?);"
+ old-lt new-lt old-lt new-lt))))
;; NOTE: Use db:test-get* to access records
;; NOTE: This needs rundir decoding? Decide, decode here or where used? For the moment decode where used.
(define (db:get-all-tests-info-by-run-id dbstruct run-id)
(let* ((res '()))
@@ -3466,25 +3643,25 @@
;;======================================================================
;; T E S T D A T A
;;======================================================================
- (define (db:get-data-info-by-id dbstruct test-data-id)
- (db:with-db
- dbstruct
- #f
- #f
- (lambda (db)
- (let* ((res (vector #f #f #f #f #f #f #f #f #f #f #f #f)))
- (sqlite3:for-each-row
- (lambda (id test-id category variable value expected tol units comment status type last-update)
- (set! res (vector id test-id category variable value expected tol units comment status type last-update)))
- db
- "SELECT id,test_id, category, variable, value, expected, tol, units, comment, status, type, last_update FROM test_data WHERE id=? ORDER BY id ASC;" ;; event_time DESC,id ASC;
- test-data-id)
- res))))
-
+(define (db:get-data-info-by-id dbstruct test-data-id)
+ (let* ((stmt "SELECT id,test_id, category, variable, value, expected, tol, units, comment, status, type, last_update FROM test_data WHERE id=? ORDER BY id ASC;")) ;; event_time DESC,id ASC;
+ (db:with-db
+ dbstruct
+ #f
+ #f
+ (lambda (db)
+ (let* ((stmth (db:get-cache-stmth dbstruct db stmt))
+ (res (sqlite3:fold-row
+ (lambda (res id test-id category variable value expected tol units comment status type last-update)
+ (vector id test-id category variable value expected tol units comment status type last-update))
+ (vector #f #f #f #f #f #f #f #f #f #f #f #f)
+ stmth
+ test-data-id)))
+ res)))))
;; WARNING: Do NOT call this for the parent test on an iterated test
;; Roll up test_data pass/fail results
;; look at the test_data status field,
;; if all are pass (any case) and the test status is PASS or NULL or '' then set test status to PASS.
@@ -3929,10 +4106,13 @@
run-id )))))
test-count-recs))
;; BBnote: db:get-all-state-status-counts-for-test returns dbr:counts object aggregating state and status of items of a given test, *not including rollup state/status*
+;;
+;; NOTE: This is called within a transaction
+;;
(define (db:get-all-state-status-counts-for-test dbstruct run-id test-name item-path item-state-in item-status-in)
(let* ((test-info (db:get-test-info dbstruct run-id test-name item-path))
(item-state (or item-state-in (db:test-get-state test-info)))
(item-status (or item-status-in (db:test-get-status test-info)))
(other-items-count-recs (db:with-db
Index: dcommon.scm
==================================================================
--- dcommon.scm
+++ dcommon.scm
@@ -637,11 +637,11 @@
(iup:attribute-set! stats-matrix "CLEARVALUE" "CONTENTS")
(iup:attribute-set! stats-matrix "NUMCOL" max-col )
(iup:attribute-set! stats-matrix "NUMLIN" (if (< max-row max-visible) max-visible max-row)) ;; min of 20
(iup:attribute-set! stats-matrix "NUMCOL_VISIBLE" max-col-vis)
(iup:attribute-set! stats-matrix "NUMLIN_VISIBLE" (if (> max-row max-visible) max-visible max-row))
- (print "row-indices: " row-indices " col-indices: " col-indices)
+ ;;(print "row-indices: " row-indices " col-indices: " col-indices)
;; Row labels
(for-each (lambda (ind)
(let* ((name (car ind))
(num (cadr ind))
(key (conc num ":0")))
Index: docs/manual/installation.txt
==================================================================
--- docs/manual/installation.txt
+++ docs/manual/installation.txt
@@ -20,10 +20,14 @@
Dependencies
~~~~~~~~~~~~
Chicken scheme and a number of "eggs" are required for building
+Megatest. See the script installall.sh in the utils directory of the
+source distribution for an automated way to install everything
+needed for building Megatest on Linux.
+
Megatest. In the v1.66 and beyond assistance to create the build
system is built into the Makefile.
.Installation steps (overview)
-------------------------------------
Index: docs/manual/plan.txt
==================================================================
--- docs/manual/plan.txt
+++ docs/manual/plan.txt
@@ -1,5 +1,8 @@
+Road Map
+--------
+
// This file is part of Megatest.
//
// Megatest is free software: you can redistribute it and/or modify
// it under the terms of the GNU General Public License as published by
// the Free Software Foundation, either version 3 of the License, or
Index: genexample.scm
==================================================================
--- genexample.scm
+++ genexample.scm
@@ -17,11 +17,13 @@
;; along with Megatest. If not, see .
;;======================================================================
(declare (unit genexample))
-(use posix regex)
+(use posix regex matchable)
+
+(include "db_records.scm")
(define genexample:example-logpro
#<seconds str)
+ (let* ((parts (string-split str))
+ (res 0))
+ (for-each
+ (lambda (part)
+ (set! res
+ (+ res
+ (match (string-match "(\\d+)([a-z])" part)
+ ((_ val units)(* (string->number val)(case (string->symbol units)
+ ((s) 1)
+ ((m) 60)
+ ((h) 3600))))
+ (else 0)))))
+ parts)
+ res))
+
+;; generate a skeleton Megatest area from a current area with runs
+;;
+;; specify target, runname etc to use specific runs for the template
+;;
+(define (genexample:extract-skeleton-area dest-path)
+ (let* ((target (args:get-arg "-target"))
+ (runname (args:get-arg "-runname"))
+ (obtuse (make-hash-table))
+ (obtusef (args:get-arg "-obfuscate"))
+ (letters (string-split-fields "\\S" "abcdefghijklmnopqrstuvwxyz"))
+ (maxletter (- (length letters) 1))
+ (lastlet 0)
+ (lastnum 1)
+ (obfuscate (lambda (instr)
+ (or (hash-table-ref/default obtuse instr #f)
+ (if obtusef
+ (let* ((letter (list-ref letters lastlet))
+ (val (conc letter lastnum)))
+ (if (>= lastlet maxletter)
+ (begin
+ (set! lastlet 0)
+ (set! lastnum (+ lastnum 1)))
+ (set! lastlet (+ lastlet 1)))
+ (hash-table-set! obtuse instr val)
+ val)
+ instr)))))
+ (if (not (and target runname))
+ (debug:print 0 *default-log-port* "WARNING: For best results please specifiy -target and -runname for a good run to use as a template."))
+ (if (not (and (file-exists? "megatest.config")
+ (file-exists? "megatest.db")))
+ (begin
+ (debug:print 0 *default-log-port* "ERROR: this command must be run at the top level of a megatest area where runs have been completed")
+ (exit)))
+
+ ;; first create the dest path and needed subdirectories
+ (if (not (file-exists? dest-path))
+ (begin
+ (create-directory dest-path)
+ (create-directory (conc dest-path "/tests")))
+ (if (file-exists? (conc dest-path "/megatest.config"))
+ (begin
+ (debug:print 0 *default-log-port* "ERROR: destination path already has megatest.config, stopping now.")
+ (exit))))
+
+ ;; dump the config files from this area to the dest area
+ (if (args:get-arg "-obfuscate")
+ (debug:print 0 *default-log-port* "WARNING: obfuscation is NOT done on megatest.config and runconfigs.config. Please edit those files to remove any sensitive information!"))
+ (system (conc "megatest -show-config > " dest-path "/megatest.config"))
+ (system (conc "megatest -show-runconfig > " dest-path "/runconfigs.config"))
+
+ ;; create stepsinfo and items refdbs, some stuff has to be done due to refdb not initing area
+ ;;
+ ;; sheet row col value
+ ;; stepsinfo testname itempath stepname steptime
+ ;; miscinfo "itemsinfo" testname itempath "x"
+ ;;
+ (for-each
+ (lambda (rdbname)
+ (if (not (file-exists? (conc dest-path "/" rdbname)))
+ (begin
+ (create-directory (conc dest-path "/" rdbname "/sxml") #t)
+ (with-output-to-file (conc dest-path "/" rdbname "/sheet-names.cfg")
+ (lambda ()(print))))))
+ '("stepsinfo" "miscinfo"))
+
+ (let* ((runs (rmt:simple-get-runs (or runname "%") #f #f (or target "%")))
+ (tests (make-hash-table)) ;; just tests
+ (fullt (make-hash-table)) ;; all test/items
+ (testreg (make-hash-table)) ;; for the testconfigs
+ (stepsrdb (conc dest-path "/stepsinfo"))
+ (miscrdb (conc dest-path "/miscinfo")))
+ (if (> (length runs) 1)
+ (debug:print-info 0 *default-log-port* "More than one run matches, first found data will be used."))
+ ;; get all testnames
+ (for-each
+ (lambda (run-id)
+ (let* ((tests-data (rmt:get-tests-for-run run-id "%" '() '() #f #f #f #f #f #f #f #f)))
+ (for-each
+ (lambda (testdat)
+ (let* ((test-id (db:test-get-id testdat))
+ (testname (db:test-get-testname testdat))
+ (item-path (db:test-get-item-path testdat))
+ (tlevel (db:test-get-is-toplevel testdat))
+ (tfullname (db:test-get-fullname testdat))
+ ;; now get steps info
+ (test-steps (tests:get-compressed-steps run-id test-id))
+ (testconfig (tests:get-testconfig testname item-path testreg #f)))
+
+
+ (if (not (hash-table-exists? fullt tfullname))
+ ;; do the work for this test if not previously done
+ (let* ((new-test-dir (conc dest-path "/tests/" (obfuscate testname)))
+ (tconfigf (conc new-test-dir "/testconfig")))
+ (print "Analyzing and extracting info for " tfullname " as " (obfuscate testname))
+ (print " toplevel: " (if tlevel "yes" "no"))
+ (hash-table-set! fullt tfullname #t) ;; track that this one has been seen
+ (if (not (directory-exists? new-test-dir))
+ (create-directory new-test-dir #t))
+
+ ;; create the testconfig IIF we are a toplevel or an item AND the testconfig has not been previously created
+ (if (and (or (not tlevel)
+ (not (equal? item-path "")))
+ (not (file-exists? tconfigf)))
+ (with-output-to-file tconfigf
+ (lambda ()
+ ;; first the ezsteps
+ (print "[ezsteps]")
+ (for-each
+ (lambda (teststep)
+ (let* ((step-name (vector-ref teststep 0)))
+ (print (obfuscate step-name)
+ " sleep [refdb lookup #{getenv MT_RUN_AREA_HOME}/stepsinfo "
+ (obfuscate testname) " $MT_ITEMPATH "
+ (obfuscate step-name) "]")))
+ test-steps)
+
+ ;; now the requirements section
+ (if testconfig
+ (begin
+ (print "\n[requirements]")
+ (for-each
+ (lambda (entry)
+ (let* ((key (car entry))
+ (val (cadr entry)))
+ (case (string->symbol key)
+ ((waiton) (print "waiton " (obfuscate val)))
+ (else (print key " " val)))))
+ (configf:get-section testconfig "requirements")))
+ #;(print "WARNING: No testconfig data for " testname ", " item-path))
+
+ (print "\n[items]")
+ (print "THE_ITEM [refdb getrow #{getenv MT_RUN_AREA_HOME}/miscinfo itemsinfo " (obfuscate testname)" | awk '{print $1}']")
+ )))
+
+ ;; fill the stepsrdb
+ (for-each
+ (lambda (teststep)
+ (let* ((step-name (vector-ref teststep 0))
+ (step-duration (hrs-min-sec->seconds (vector-ref teststep 4))))
+
+ (system (conc "refdb set " stepsrdb " " (obfuscate testname)
+ " '" (if (equal? item-path "")
+ "no-item-path"
+ (obfuscate item-path))
+ "' " (obfuscate step-name) " " step-duration))))
+ test-steps)
+
+ ;; miscinfo "itemsinfo" testname itempath "x"
+ (if (not (equal? item-path ""))
+ (system (conc "refdb set " miscrdb " itemsinfo " (obfuscate testname) " " (obfuscate item-path) " x")))
+
+ ))))
+ tests-data)))
+ (map (lambda (runrec)(simple-run-id runrec)) runs)))
+ ))
Index: launch.scm
==================================================================
--- launch.scm
+++ launch.scm
@@ -19,11 +19,12 @@
;;======================================================================
;; launch a task - this runs on the originating host, tests themselves
;;
;;======================================================================
-(use regex regex-case base64 sqlite3 srfi-18 directory-utils posix-extras z3 call-with-environment-variables csv)
+(use regex regex-case base64 sqlite3 srfi-18 directory-utils posix-extras z3
+ call-with-environment-variables csv)
(use typed-records pathname-expand matchable)
(import (prefix base64 base64:))
(import (prefix sqlite3 sqlite3:))
@@ -725,12 +726,12 @@
;; > 3 RUNNING with not test_dead do nothing (run should already be RUNNING/ na
;; > 0 RUNNING and test_dead then send KILLREQ ==> COMPLETED
;; 0 RUNNING ==> this is actually the first condition, should not get here
(define (launch:end-of-run-check run-id )
- (let* ((not-completed-cnt (rmt:get-not-completed-cnt run-id))
- (running-cnt (rmt:get-count-tests-running-for-run-id run-id))
+ (let* ((not-completed-cnt (rmt:get-not-completed-cnt run-id))
+ (running-cnt (rmt:get-count-tests-running-for-run-id run-id #f)) ;; fastmode=no
(all-test-launched (rmt:get-var (conc "lunch-complete-" run-id)))
(current-state (rmt:get-run-state run-id))
(current-status (rmt:get-run-status run-id)))
;;get-vars run-id to query metadata table to check if all completed. if all-test-launched = yes then only not-completed-cnt = 0 means everyting is completed if no entry found in the table do nothing
(debug:print 0 *default-log-port* "Running test cnt :" running-cnt)
@@ -1412,10 +1413,19 @@
;; FIXME SOMEDAY: not good how this is so obtuse, this hack is to
;; allow running from dashboard. Extract the path
;; from the called megatest and convert dashboard
;; or dboard to megatest
(local-megatest (common:find-local-megatest))
+ #;(local-megatest (let* ((lm (car (argv)))
+ (dir (pathname-directory lm))
+ (exe (pathname-strip-directory lm)))
+ (conc (if dir (conc dir "/") "")
+ (case (string->symbol exe)
+ ((dboard) "../megatest")
+ ((mtest) "../megatest")
+ ((dashboard) "megatest")
+ (else exe)))))
(launcher (common:get-launcher *configdat* test-name item-path)) ;; (configf:lookup *configdat* "jobtools" "launcher"))
(test-sig (conc (common:get-testsuite-name) ":" 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)
@@ -1423,11 +1433,14 @@
(fullcmd #f) ;; (define a (with-output-to-string (lambda ()(write x))))
(mt-bindir-path #f)
(testinfo (rmt:get-test-info-by-id run-id test-id))
(mt_target (string-intersperse (map cadr keyvals) "/"))
(debug-param (append (if (args:get-arg "-debug") (list "-debug" (args:get-arg "-debug")) '())
- (if (args:get-arg "-logging")(list "-logging") '()))))
+ (if (args:get-arg "-logging")(list "-logging") '())
+ (if (configf:lookup *configdat* "misc" "profilesw")
+ (list (configf:lookup *configdat* "misc" "profilesw"))
+ '()))))
;; (if hosts (set! hosts (string-split hosts)))
;; set the megatest to be called on the remote host
(if (not remote-megatest)(set! remote-megatest local-megatest)) ;; "megatest"))
(set! mt-bindir-path (pathname-directory remote-megatest))
(if launcher (set! launcher (string-split launcher)))
@@ -1565,11 +1578,12 @@
))
(alist->env-vars miscprevvals)
(alist->env-vars testprevvals)
(alist->env-vars commonprevvals)
launch-results))
- (change-directory *toppath*)))
+ (change-directory *toppath*)
+ (thread-sleep! (configf:lookup-number *configdat* "setup" "inter-test-delay" default: 0.0))))
;; recover a test where the top controlling mtest may have died
;;
(define (launch:recover-test run-id test-id)
;; this function is called on the test run host via ssh
Index: megatest.scm
==================================================================
--- megatest.scm
+++ megatest.scm
@@ -85,12 +85,10 @@
;;
(use sparse-vectors)
(import mutils ducttape-lib stml2)
-;; (use zmq)
-
(define *usage-log-file* #f) ;; put path to file for logging usage in this var in the ~/.megatestrc file
(define *usage-use-seconds* #t) ;; for Epoc seconds in usage logging change this to #t in ~/.megatestrc file
;; load the ~/.megatestrc file, put (use trace)(trace-call-sites #t)(trace function-you-want-to-trace) in this file
;;
@@ -192,12 +190,10 @@
from standard in. Each line is comma delimited with four
fields category,variable,value,comment
Queries
-list-runs patt : list runs matching pattern \"patt\", % is the wildcard
- -fields fieldspec : fields to include in json dump; runs:id,runame+tests:testname+steps
- -dumpmode MODE : dump in MODE format instead of sexpr, MODE=json,ini,sexp etc. (add -debug 0,9 to see which file contributes each line)
-show-keys : show the keys used in this megatest setup
-test-files targpatt : get the most recent test path/file matching targpatt e.g. %/% or '*.log'
returns list sorted by age ascending, see examples below
-test-paths : get the test paths matching target, runname, item and test
patterns.
@@ -204,14 +200,16 @@
-list-disks : list the disks available for storing runs
-list-targets : list the targets in runconfigs.config
-list-db-targets : list the target combinations used in the db
-show-config : dump the internal representation of the megatest.config file
-show-runconfig : dump the internal representation of the runconfigs.config file
+ -dumpmode MODE : dump in MODE format instead of sexpr, MODE=json,ini,sexp etc. (add -debug 0,9 to see which file contributes each line)
-show-cmdinfo : dump the command info for a test (run in test environment)
-section sectionName
-var varName : for config and runconfig lookup value for sectionName varName
-since N : get list of runs changed since time N (Unix seconds)
+ -fields fieldspec : fields to include in json dump; runs:id,runame+tests:testname+steps
-sort fieldname : in -list-runs sort tests by this field
-testdata-csv [categorypatt/]varpatt : dump testdata for given category
Misc
-start-dir path : switch to this directory before running megatest
@@ -253,11 +251,11 @@
will substitute %s for the sheet name in generating
multiple sheets)
-o : output file for refdb2dat (defaults to stdout)
-archive cmd : archive runs specified by selectors to one of disks specified
in the [archive-disks] section.
- cmd: keep-html, restore, save, save-remove, get (use
+ cmd: keep-html, restore, save, save-remove, get, replicate-db (use
-dest to set destination), -include path1,path2... to get or save specific files
-generate-html : create a simple html dashboard for browsing your runs
-generate-html-structure : create a top level html veiw to list targets/runs and a Run view within each run directory.
-list-run-time : list time requered to complete runs. It supports following switches
-run-patt -target-patt -dumpmode
@@ -328,10 +326,12 @@
"-days"
"-rename-run"
"-to"
"-dest"
+ "-source"
+ "-time-stamp"
;; values and messages
":category"
":variable"
":value"
":expected"
@@ -399,10 +399,12 @@
"-sync-to"
"-pgsync"
"-kill-wait" ;; wait this long before removing test (default is 10 sec)
"-diff-html"
+ ;; wizards, area capture, setup new ...
+ "-extract-skeleton"
)
(list "-h" "-help" "--help"
"-manual"
"-version"
"-force"
@@ -476,10 +478,14 @@
"-q" ;; quiet 0, errors/warnings only
"-diff-rep"
"-syscheck"
+ "-obfuscate"
+ ;; junk placeholder
+ ;; "-:p"
+
)
args:arg-hash
0))
;; Add args that use remargs here
@@ -1984,12 +1990,42 @@
;;======================================================================
;; Archive tests
;;======================================================================
;; Archive tests matching target, runname, and testpatt
-(if (args:get-arg "-archive")
+(if (equal? (args:get-arg "-archive") "replicacte-db")
+ (begin
+ ;; check if source
+ ;; check if megatest.db exist
+ (launch:setup)
+ (if (not (args:get-arg "-source"))
+ (begin
+ (debug:print-info 1 *default-log-port* "Missing required argument -source ")
+ (exit 1)))
+ (if (common:file-exists? (conc *toppath* "/megatest.db"))
+ (begin
+ (debug:print-info 1 *default-log-port* "File " (conc *toppath* "/megatest.db") " already exists. Please remove it before trying to replicate db")
+ (exit 1)))
+ (if (and (common:get-db-tmp-area) (> (length (directory (common:get-db-tmp-area) #f)) 0))
+ (begin
+ (debug:print-info 1 *default-log-port* (common:get-db-tmp-area) " not empty. Please remove it before trying to replicate db")
+ (exit 1)))
+ ;; check if timestamp
+ (let* ((source (args:get-arg "-source"))
+ (src (if (not (equal? (substring source 0 1) "/"))
+ (conc (current-directory) "/" source)
+ source))
+ (ts (if (args:get-arg "-time-stamp") (args:get-arg "-time-stamp") "latest")))
+ (if (common:directory-exists? src)
+ (begin
+ (archive:restore-db src ts)
+ (set! *didsomething* #t))
+ (begin
+ (debug:print-error 1 *default-log-port* "Path " source " not found")
+ (exit 1))))))
;; else do a general-run-call
+ (if (and (args:get-arg "-archive") (not (equal? (args:get-arg "-archive") "replicacte-db")))
(begin
;; for the archive get we need to preserve the starting dir as part of the target path
(if (and (args:get-arg "-dest")
(not (equal? (substring (args:get-arg "-dest") 0 1) "/")))
(let ((newpath (conc (current-directory) "/" (args:get-arg "-dest"))))
@@ -2489,10 +2525,15 @@
(begin
(mutils:syscheck common:raw-get-remote-host-load
server:get-best-guess-address
read-config)
(set! *didsomething* #t)))
+
+(if (args:get-arg "-extract-skeleton")
+ (let* ((toppath (launch:setup)))
+ (genexample:extract-skeleton-area (args:get-arg "-extract-skeleton"))
+ (set! *didsomething* #t)))
;;======================================================================
;; Exit and clean up
;;======================================================================
Index: rmt.scm
==================================================================
--- rmt.scm
+++ rmt.scm
@@ -493,10 +493,16 @@
(rmt:send-receive 'get-run-record-ids #f (list target run keynames test-patt)))
(define (rmt:get-changed-record-ids since-time)
(rmt:send-receive 'get-changed-record-ids #f (list since-time)) )
+(define (rmt:drop-all-triggers)
+ (rmt:send-receive 'drop-all-triggers #f '()))
+
+(define (rmt:create-all-triggers)
+ (rmt:send-receive 'create-all-triggers #f '()))
+
;;======================================================================
;; T E S T M E T A
;;======================================================================
(define (rmt:get-tests-tags)
@@ -694,21 +700,21 @@
;; (rmt:send-receive #f 'get-run-ids-matching (list keynames target res)))
(define (rmt:get-prereqs-not-met run-id waitons ref-test-name ref-item-path #!key (mode '(normal))(itemmaps #f))
(rmt:send-receive 'get-prereqs-not-met run-id (list run-id waitons ref-test-name ref-item-path mode itemmaps)))
-(define (rmt:get-count-tests-running-for-run-id run-id)
- (rmt:send-receive 'get-count-tests-running-for-run-id run-id (list run-id)))
+(define (rmt:get-count-tests-running-for-run-id run-id fastmode)
+ (rmt:send-receive 'get-count-tests-running-for-run-id run-id (list run-id fastmode)))
(define (rmt:get-not-completed-cnt run-id)
(rmt:send-receive 'get-not-completed-cnt run-id (list run-id)))
;; Statistical queries
-(define (rmt:get-count-tests-running run-id)
- (rmt:send-receive 'get-count-tests-running run-id (list run-id)))
+(define (rmt:get-count-tests-running run-id fastmode)
+ (rmt:send-receive 'get-count-tests-running run-id (list run-id fastmode)))
(define (rmt:get-count-tests-running-for-testname run-id testname)
(rmt:send-receive 'get-count-tests-running-for-testname run-id (list run-id testname)))
(define (rmt:get-count-tests-running-in-jobgroup run-id jobgroup)
@@ -791,10 +797,12 @@
(rmt:send-receive 'set-run-status #f (list run-id run-status msg)))
(define (rmt:set-run-state-status run-id state status )
(rmt:send-receive 'set-run-state-status #f (list run-id state status)))
+(define (rmt:update-tesdata-on-repilcate-db old-lt new-lt)
+(rmt:send-receive 'update-tesdata-on-repilcate-db #f (list old-lt new-lt)))
(define (rmt:update-run-event_time run-id)
(rmt:send-receive 'update-run-event_time #f (list run-id)))
(define (rmt:get-runs-by-patt keys runnamepatt targpatt offset limit fields last-runs-update #!key (sort-order "asc")) ;; fields of #f uses default
@@ -814,10 +822,19 @@
(rmt:send-receive 'del-var #f (list varname)))
(define (rmt:set-var varname value)
(rmt:send-receive 'set-var #f (list varname value)))
+(define (rmt:inc-var varname)
+ (rmt:send-receive 'inc-var #f (list varname)))
+
+(define (rmt:dec-var varname)
+ (rmt:send-receive 'dec-var #f (list varname)))
+
+(define (rmt:add-var varname value)
+ (rmt:send-receive 'add-var #f (list varname value)))
+
;;======================================================================
;; M U L T I R U N Q U E R I E S
;;======================================================================
;; Need to move this to multi-run section and make associated changes
Index: runs.scm
==================================================================
--- runs.scm
+++ runs.scm
@@ -46,17 +46,96 @@
reglen regfull
runname max-concurrent-jobs run-id
test-patts required-tests test-registry
registry-mutex flags keyvals run-info all-tests-registry
can-run-more-tests
- ((can-run-more-tests-count 0) : fixnum))
+ ((can-run-more-tests-count 0) : fixnum)
+ (last-fuel-check 0) ;; time when we last checked fuel
+ (beginning-of-time (current-seconds))
+ )
(defstruct runs:testdat
hed tal reg reruns test-record
test-name item-path jobgroup
waitons testmode newtal itemmaps prereqs-not-met)
+
+;; look in the $MT_RUN_AREA_HOME/.softlocks directory for key-host-pid.softlock files
+;; - remove any that are over 3600 seconds old
+;; - if there are any that are younger than 10 seconds
+;; * sleep 10 seconds
+;; * touch my key-host-pid.softlock file
+;; * return
+;; - if there are no files younger than 10 seconds
+;; * touch my key-host-pid.softlock file
+;; * return
+;;
+(define (runs:wait-on-softlock rdat key)
+ (if (not (and *toppath* (file-exists? *toppath*))) ;; don't seem to have toppath yet
+ (debug:print-info 0 *default-log-port* "Can't create softlocks - don't see MTRAH yet.")
+ (let* ((softlocks-dir (conc *toppath* "/.softlocks")))
+ (if (not (file-exists? softlocks-dir))
+ (create-directory softlocks-dir #t))
+ (let* ((my-lock-file (conc softlocks-dir "/" key "-" (get-host-name) "-" (current-process-id) ".softlock"))
+ (lock-files (filter (lambda (x)
+ (not (equal? x my-lock-file)))
+ (glob (conc softlocks-dir "/" key "*.softlock"))))
+ (fresh-locks (any (lambda (x) ;; do we have any locks younger than 10 seconds
+ (let* ((mod-time (file-modification-time x))
+ (age (- (current-seconds) mod-time)))
+ (cond
+ ((> age 3600) ;; too old to keep, remove it
+ (delete-file* x) #f)
+ ((< age 10) #t)
+ (else #f))))
+ lock-files)))
+ (if fresh-locks
+ (begin
+ (if (runs:lownoise "runners-softlock-wait" 360)
+ (debug:print-info 0 *default-log-port* "Other runners in flight, giving up some time..."))
+ (thread-sleep! 10))
+ (begin
+ (if (runs:lownoise "runners-softlock-nowait" 360)
+ (debug:print-info 0 *default-log-port* "No runners in flight, updating softlock"))
+ (let* ((ouf (open-output-file my-lock-file)))
+ (with-output-to-port ouf
+ (lambda ()(print (current-seconds))))
+ (close-output-port ouf))))
+ (runs:dat-last-fuel-check-set! rdat (current-seconds))))))
+
+;; Fourth try, do accounting through time
+;;
+(define (runs:parallel-runners-mgmt rdat)
+ (let ((time-to-check (configf:lookup-number *configdat* "runners" "time-to-check" default: 10)) ;; 28
+ (time-to-wait (configf:lookup-number *configdat* "runners" "time-to-wait" default: 30))
+ (now-time (current-seconds)))
+ (if (> (- now-time (runs:dat-last-fuel-check rdat)) time-to-check) ;; time to check
+ (runs:wait-on-softlock rdat "runners"))))
+;; To test parallel-runners management start a repl:
+;; megatest -repl
+;; then run:
+;; (runs:test-parallel-runners 60)
+;;
+(define (runs:test-parallel-runners duration #!optional (proc #f))
+ (let* ((rdat (make-runs:dat))
+ (rtime 0)
+ (startt (current-seconds))
+ (endt (+ startt duration)))
+ ((or proc runs:parallel-runners-mgmt) rdat)
+ (let loop ()
+ (let* ((wstart (current-seconds)))
+ (if (< wstart endt)
+ (let* ((work-time (random 10)))
+ #;(debug:print-info 0 *default-log-port* "working for " work-time
+ " seconds. Total work: " rtime ", elapsed time: " (- wstart startt))
+ (thread-sleep! work-time)
+ (set! rtime (+ rtime work-time))
+ ((or proc runs:parallel-runners-mgmt) rdat)
+ (loop)))))
+ (let* ((done-time (current-seconds)))
+ (debug:print-info 0 *default-log-port* "DONE: rtime=" rtime ", elapsed time=" (- done-time startt)
+ ", ratio=" (/ rtime (- done-time startt))))))
(define (runs:get-mt-env-alist run-id runname target testname itempath)
;;(bb-check-path msg: "runs:set-megatest-env-vars entry")
`(("MT_TEST_NAME" . ,testname)
@@ -87,15 +166,10 @@
,@(map (lambda (var)
(let ((val (configf:lookup *configdat* "env-override" var)))
(cons var val)))
(configf:section-vars *configdat* "env-override"))))
-
-
-
-
-
;; set up needed environment variables given a run-id and optionally a target, itempath etc.
;;
(define (runs:set-megatest-env-vars run-id #!key (inkeys #f)(inrunname #f)(inkeyvals #f)(intarget #f)(testname #f)(itempath #f))
;;(bb-check-path msg: "runs:set-megatest-env-vars entry")
@@ -245,15 +319,16 @@
;; time the and condition above is true (which
;; seems like always)?
((> (runs:dat-can-run-more-tests-count runsdat) 20) ;; original intent was - save cycles, wait a long time
(if (runs:lownoise "waiting on tasks" 60)(debug:print-info 2 *default-log-port* "waiting for tasks to complete, sleeping briefly ..."))
10) ;; obviously haven't had any work to do for a while
- (else
- ;; if have a number for inter-test-delay, use it, else don't delay much, maybe even zero?
- (configf:lookup-number *configdat* "setup" "inter-test-delay" default: 0.01))))
+ (else 0)))
+;; ;; if have a number for inter-test-delay, use it, else don't delay much, maybe even zero?
+;; (configf:lookup-number *configdat* "setup" "inter-test-delay" default: 0.01)
+;; )))
- (let* ((num-running (rmt:get-count-tests-running run-id))
+ (let* ((num-running (rmt:get-count-tests-running run-id #f)) ;; fastmode=no
(num-running-in-jobgroup (rmt:get-count-tests-running-in-jobgroup run-id jobgroup))
(job-group-limit (let ((jobg-count (configf:lookup *configdat* "jobgroups" jobgroup)))
(if (string? jobg-count)
(string->number jobg-count)
jobg-count))))
@@ -1288,12 +1363,13 @@
target: #f
)
)
(define (runs:incremental-print-results run-id)
- (let ((curr-sec (current-seconds)))
- (if (> (- curr-sec (runs:gendat-inc-results-last-update *runs:general-data*)) 5) ;; at least five seconds since last update
+ (let ((curr-sec (current-seconds))
+ (last-update (runs:gendat-inc-results-last-update *runs:general-data*)))
+ (if (> (- curr-sec last-update) 5) ;; at least five seconds since last update
(let* ((run-dat (or (runs:gendat-run-info *runs:general-data*)(rmt:get-run-info run-id)))
(runname (or (runs:gendat-runname *runs:general-data*)
(db:get-value-by-header (db:get-rows run-dat)
(db:get-header run-dat) "runname")))
(target (or (runs:gendat-target *runs:general-data*)(rmt:get-target run-id)))
@@ -1302,19 +1378,20 @@
#f #f ;; offset limit
#f ;; not-in
#f ;; sort-by
#f ;; sort-order
#f ;; get full data (not 'shortlist)
- (runs:gendat-inc-results-last-update *runs:general-data*) ;; last update time
+ last-update
'dashboard)))
(if (list? res)
res
(begin
(debug:print-error
0 *default-log-port*
"FAILED TO GET DATA using rmt:get-tests-for-run. Notify developers if you see this. result: " res)
'())))))
+ (runs:gendat-inc-results-last-update-set! *runs:general-data* (- curr-sec 1))
(if (not (runs:gendat-run-info *runs:general-data*))
(runs:gendat-run-info-set! *runs:general-data* run-dat))
(if (not (runs:gendat-runname *runs:general-data*))
(runs:gendat-runname-set! *runs:general-data* runname))
(if (not (runs:gendat-target *runs:general-data*))
@@ -1346,11 +1423,15 @@
dtime
(seconds->hr-min-sec duration)
(conc "lt/" target "/" runname "/" test-name (if (string-null? item-path) "" (conc "/" item-path))))
(hash-table-set! (runs:gendat-inc-results *runs:general-data*) (conc run-id "," test-id) testdat)))))
testsdat)))
- (runs:gendat-inc-results-last-update-set! *runs:general-data* (- curr-sec 10))))
+
+ ;; I don't think this should be here? -- Matt
+ #;(runs:gendat-inc-results-last-update-set! *runs:general-data* (- curr-sec 10))
+
+ ))
;; every time though the loop increment the test/itempatt val.
;; when the min is > max-allowed and none running then force exit
;;
(define *max-tries-hash* (make-hash-table))
@@ -1474,11 +1555,11 @@
extras)
'())))
(waitons (delete-duplicates (append (tests:testqueue-get-waitons test-record) extra-waits) equal?))
(newtal (append tal (list hed)))
(regfull (>= (length reg) reglen))
- (num-running (rmt:get-count-tests-running-for-run-id run-id))
+ (num-running (rmt:get-count-tests-running-for-run-id run-id #t)) ;; fastmode=yes
(testdat (make-runs:testdat
hed: hed
tal: tal
reg: reg
reruns: reruns
@@ -1546,10 +1627,12 @@
"\n reruns: " reruns
"\n regfull: " regfull
"\n reglen: " reglen
"\n length reg: " (length reg)
)
+
+ (runs:parallel-runners-mgmt runsdat)
;; check for hed in waitons => this would be circular, remove it and issue an
;; error
(if (member test-name waitons)
(begin
@@ -1692,29 +1775,31 @@
(rmt:set-var (conc "lunch-complete-" run-id) "yes")
;; now *if* -run-wait we wait for all tests to be done
;; Now wait for any RUNNING tests to complete (if in run-wait mode)
(thread-sleep! 10) ;; I think there is a race condition here. Let states/statuses settle
- (let wait-loop ((num-running (rmt:get-count-tests-running-for-run-id run-id))
+ (let wait-loop ((num-running (rmt:get-count-tests-running-for-run-id run-id #t)) ;; fastmode=yes
(prev-num-running 0))
;; (debug:print-info 13 *default-log-port* "num-running=" num-running ", prev-num-running=" prev-num-running)
(if (and (or (args:get-arg "-run-wait")
(equal? (configf:lookup *configdat* "setup" "run-wait") "yes"))
(> num-running 0))
(begin
;; Here we mark any old defunct tests as incomplete. Do this every fifteen minutes
;; (debug:print 0 *default-log-port* "Got here eh! num-running=" num-running " (> num-running 0) " (> num-running 0))
(if (> (current-seconds)(+ last-time-incomplete 900))
- (begin
- (debug:print-info 0 *default-log-port* "Marking stuck tests as INCOMPLETE while waiting for run " run-id ". Running as pid " (current-process-id) " on " (get-host-name))
- (set! last-time-incomplete (current-seconds))
- (rmt:find-and-mark-incomplete run-id #f)))
- (if (not (eq? num-running prev-num-running))
- (debug:print-info 0 *default-log-port* "run-wait specified, waiting on " num-running " tests in RUNNING, REMOTEHOSTSTART or LAUNCHED state at " (time->string (seconds->local-time (current-seconds)))))
+ (let ((actual-num-running (rmt:get-count-tests-running-for-run-id run-id #f))) ;; fastmode=no
+ (debug:print-info 0 *default-log-port* "Marking stuck tests as INCOMPLETE while waiting for run " run-id
+ ". Running as pid " (current-process-id) " on " (get-host-name))
+ (set! last-time-incomplete (current-seconds)) ;; FIXME, this might be causing slow down - use of set!
+ (rmt:find-and-mark-incomplete run-id #f)
+ (debug:print-info 0 *default-log-port* "run-wait specified, waiting on " actual-num-running
+ " tests in RUNNING, REMOTEHOSTSTART or LAUNCHED state at "
+ (time->string (seconds->local-time (current-seconds))))))
(thread-sleep! 5)
- ;; (wait-loop (rmt:get-count-tests-running-for-run-id run-id) num-running))))
- (wait-loop (rmt:get-count-tests-running-for-run-id run-id) num-running))))
+ (wait-loop (rmt:get-count-tests-running-for-run-id run-id #t) ;; fastmode=yes
+ num-running))))
;; LET* ((test-record
;; we get here on "drop through". All done!
;; this is moved to runs:run-testes since this function is getting called twice to ensure everthing is completed.
;; (debug:print-info 0 *default-log-port* "Calling Post Hook")
;; (runs:run-post-hook run-id)
@@ -2491,10 +2576,15 @@
))
runs)
;; special case - archive get
(if (equal? (args:get-arg "-archive") "get")
(archive:bup-get-data "get" #f #f test-records rp-mutex bup-mutex))
+ (if (or (equal? (args:get-arg "-archive") "save") (equal? (args:get-arg "-archive") "save-remove"))
+ (begin
+ (print "db archive started")
+ (archive:megatest-db target runnamepatt)
+ (print "db archived")))
)
#t
)
(define (runs:remove-test-directory test mode) ;; remove-data-only)
Index: server.scm
==================================================================
--- server.scm
+++ server.scm
@@ -125,16 +125,20 @@
(curr-pid (current-process-id))
(homehost (common:get-homehost)) ;; configf:lookup *configdat* "server" "homehost" ))
(target-host (car homehost))
(testsuite (common:get-testsuite-name))
(logfile (conc areapath "/logs/server.log")) ;; -" curr-pid "-" target-host ".log"))
+ (profile-mode (or (configf:lookup *configdat* "misc" "profilesw")
+ ""))
(cmdln (conc (common:get-megatest-exe)
" -server " (or target-host "-") (if (equal? (configf:lookup *configdat* "server" "daemonize") "yes")
" -daemonize "
"")
;; " -log " logfile
- " -m testsuite:" testsuite)) ;; (conc " >> " logfile " 2>&1 &")))))
+ " -m testsuite:" testsuite
+ " " profile-mode
+ )) ;; (conc " >> " logfile " 2>&1 &")))))
(log-rotate (make-thread common:rotate-logs "server run, rotate logs thread"))
(load-limit (configf:lookup-number *configdat* "jobtools" "max-server-start-load" default: 3.0)))
;; we want the remote server to start in *toppath* so push there
(push-directory areapath)
(debug:print 0 *default-log-port* "INFO: Trying to start server (" cmdln ") ...")
Index: tcmt.scm
==================================================================
--- tcmt.scm
+++ tcmt.scm
@@ -29,10 +29,11 @@
;; (trace-call-sites #t)
(declare (uses margs))
(declare (uses rmt))
(declare (uses common))
+;; (declare (uses megatest-version))
(include "megatest-version.scm")
(include "megatest-fossil-hash.scm")
(include "db_records.scm")
Index: tests.scm
==================================================================
--- tests.scm
+++ tests.scm
@@ -272,24 +272,29 @@
(new-patts (if (member waiton-test patts)
patts
(cons waiton-test patts))))
(string-intersperse (delete-duplicates new-patts) ",")))))
+(define *glob-like-match-cache* (make-hash-table))
+(define (tests:cache-regexp str-in flag)
+ (let* ((key (conc str-in flag)))
+ (or (hash-table-ref/default *glob-like-match-cache* key #f)
+ (let* ((newrx (regexp str-in flag)))
+ (hash-table-set! *glob-like-match-cache* key newrx)
+ newrx))))
-
;; tests:glob-like-match
(define (tests:glob-like-match patt str)
- (let ((like (substring-index "%" patt)))
- (let* ((notpatt (equal? (substring-index "~" patt) 0))
- (newpatt (if notpatt (substring patt 1) patt))
- (finpatt (if like
- (string-substitute (regexp "%") ".*" newpatt #f)
- (string-substitute (regexp "\\*") ".*" newpatt #f)))
- (res #f))
- ;; (print "tests:glob-like-match => notpatt: " notpatt ", newpatt: " newpatt ", finpatt: " finpatt)
- (set! res (string-match (regexp finpatt (if like #t #f)) str))
- (if notpatt (not res) res))))
+ (let* ((like (substring-index "%" patt))
+ (notpatt (equal? (substring-index "~" patt) 0))
+ (newpatt (if notpatt (substring patt 1) patt))
+ (finpatt (if like
+ (string-substitute (regexp "%") ".*" newpatt #f)
+ (string-substitute (regexp "\\*") ".*" newpatt #f)))
+ (rx (tests:cache-regexp finpatt (if like #t #f)))
+ (res (string-match rx str)))
+ (if notpatt (not res) res)))
;; if itempath is #f then look only at the testname part
;;
(define (tests:match patterns testname itempath #!key (required '()))
(if (string? patterns)
Index: tree.scm
==================================================================
--- tree.scm
+++ tree.scm
@@ -27,10 +27,11 @@
(import (prefix sqlite3 sqlite3:))
(declare (unit tree))
(declare (uses margs))
(declare (uses launch))
+;; (declare (uses megatest-version))
(declare (uses gutils))
(declare (uses db))
(declare (uses server))
;; (declare (uses synchash))
(declare (uses dcommon))