Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -39,11 +39,11 @@ # module source files MSRCFILES = dbfile.scm debugprint.scm mtargs.scm commonmod.scm dbmod.scm \ tcp-transportmod.scm rmtmod.scm portlogger.scm apimod.scm \ configfmod.scm processmod.scm servermod.scm megatestmod.scm \ stml2.scm fsmod.scm cpumod.scm mtmod.scm odsmod.scm tasksmod.scm \ - pkts.scm + pkts.scm testsmod.scm transport-mode.scm : transport-mode.scm.template cp transport-mode.scm.template transport-mode.scm dashboard-transport-mode.scm : dashboard-transport-mode.scm.template @@ -60,10 +60,11 @@ mofiles/servermod.o : mofiles/commonmod.o mofiles/rmtmod.o : mofiles/mtmod.o mofiles/apimod.o mofiles/dbmod.o : mofiles/mtmod.o # mofiles/mtmod.o : mofiles/tcp-transportmod.o mofiles/megatestmod.o : mofiles/pkts.o +mofiles/mtmod.o : mofiles/testsmod.o mofiles/dbfile.o : \ mofiles/debugprint.o mofiles/commonmod.o mofiles/configfmod.o mofiles/apimod.o : mofiles/commonmod.o mofiles/tcp-transportmod.o mofiles/configfmod.o mofiles/megatestmod.o mofiles/rmtmod.o : mofiles/tasksmod.o Index: configf.scm ================================================================== --- configf.scm +++ configf.scm @@ -50,35 +50,10 @@ (include "common_records.scm") (define configf:imports "(import commonmod configfmod processmod (prefix mtargs args:))") -(define (configf:write-alist cdat fname) - (if (not (common:faux-lock fname)) - (debug:print 0 *default-log-port* "INFO: Could not get lock on " fname)) - (let* ((dat (configf:config->alist cdat)) - (res - (begin - (with-output-to-file fname ;; first write out the file - (lambda () - (pp dat))) - - (if (common:file-exists? fname) ;; now verify it is readable - (if (configf:read-alist fname) - #t ;; data is good. - (begin - (handle-exceptions - exn - (begin - (debug:print 0 *default-log-port* "deleting " fname " failed, exn=" exn) - #f) - (debug:print 0 *default-log-port* "WARNING: content " dat " for cache " fname " is not readable. Deleting generated file.") - (delete-file fname)) - #f)) - #f)))) - (common:faux-unlock fname) - res)) ;; pathenvvar will set the named var to the path of the config (define (find-and-read-config fname #!key (environ-patt #f)(given-toppath #f)(pathenvvar #f)) (let* ((curr-dir (current-directory)) (configinfo (find-config fname toppath: given-toppath)) Index: megatestmod.scm ================================================================== --- megatestmod.scm +++ megatestmod.scm @@ -118,11 +118,15 @@ processmod mtmod pkts ) - +(define read-config (lambda ()(assert #f "FATAL: read-config proc not set!"))) + +(define (read-config-set! proc) + (set! read-config proc)) + ;;====================================================================== ;; '(print (string-intersperse (map cadr (hash-table-ref/default (read-config "megatest.config" \#f \#t) "disks" '"'"'("none" ""))) "\n"))' (define (common:get-disks #!key (configf #f)) (hash-table-ref/default (or configf (read-config "megatest.config" #f #t)) @@ -923,10 +927,36 @@ (if (and test-id state status (equal? status "AUTO")) (db:test-data-rollup dbstruct run-id test-id status)) (if new-state-eh ;; moved from db:test-set-state-status (mt:process-triggers dbstruct run-id test-id new-state-eh new-status-eh)) tr-res))))) + +(define (mt:lazy-read-test-config test-name) + (let ((tconf (hash-table-ref/default *testconfigs* test-name #f))) + (if tconf + tconf + (let ((test-dirs (tests:get-tests-search-path *configdat*))) + (let loop ((hed (car test-dirs)) + (tal (cdr test-dirs))) + ;; Setting MT_LINKTREE here is almost certainly unnecessary. + (let ((tconfig-file (conc hed "/" test-name "/testconfig"))) + (if (and (common:file-exists? tconfig-file) + (file-read-access? tconfig-file)) + (let ((link-tree-path (common:get-linktree)) ;; (configf:lookup *configdat* "setup" "linktree")) + (old-link-tree (get-environment-variable "MT_LINKTREE"))) + (if link-tree-path (setenv "MT_LINKTREE" link-tree-path)) + (let ((newtcfg (read-config tconfig-file #f #f))) ;; NOTE: Does NOT run [system ...] + (hash-table-set! *testconfigs* test-name newtcfg) + (if old-link-tree + (setenv "MT_LINKTREE" old-link-tree) + (unsetenv "MT_LINKTREE")) + newtcfg)) + (if (null? tal) + (begin + (debug:print-error 0 *default-log-port* "No readable testconfig found for " test-name) + #f) + (loop (car tal)(cdr tal)))))))))) (define (mt:process-triggers dbstruct run-id test-id newstate newstatus) (if test-id (let* ((test-dat (db:get-test-info-by-id dbstruct run-id test-id))) (if test-dat @@ -987,7 +1017,403 @@ (pop-directory)) )) ;; ) ;; (mutex-unlock! *triggers-mutex*) ))))) + +;; Call this one to do all the work and get a standardized list of tests +;; gets paths from configs and finds valid tests +;; returns hash of testname --> fullpath +;; +(define (tests:get-all) + (let* ((test-search-path (tests:get-tests-search-path *configdat*))) + (debug:print 8 *default-log-port* "test-search-path: " test-search-path) + (tests:get-valid-tests (make-hash-table) test-search-path))) + +(define (tests:get-tests-search-path cfgdat) + (let ((paths (let ((section (if cfgdat + (configf:get-section cfgdat "tests-paths") + #f))) + (if section + (map cadr section) + '())))) + (filter (lambda (d) + (if (directory-exists? d) + d + (begin + ;; (if (common:low-noise-print 60 "tests:get-tests-search-path" d) + ;; (debug:print 0 *default-log-port* "WARNING: problem with directory " d ", dropping it from tests path")) + #f))) + (append paths (list (conc *toppath* "/tests")))))) + +(define (tests:get-valid-tests test-registry tests-paths) + (if (null? tests-paths) + test-registry + (let loop ((hed (car tests-paths)) + (tal (cdr tests-paths))) + (if (common:file-exists? hed) + (for-each (lambda (test-path) + (let* ((tname (last (string-split test-path "/"))) + (tconfig (conc test-path "/testconfig"))) + (if (and (not (hash-table-ref/default test-registry tname #f)) + (common:file-exists? tconfig)) + (hash-table-set! test-registry tname test-path)))) + (glob (conc hed "/*")))) + (if (null? tal) + test-registry + (loop (car tal)(cdr tal)))))) + +(define (tests:filter-test-names-not-matched test-names test-patts) + (delete-duplicates + (filter (lambda (testname) + (not (tests:match test-patts testname #f))) + test-names))) + + +(define (tests:filter-test-names test-names test-patts) + (delete-duplicates + (filter (lambda (testname) + (tests:match test-patts testname #f)) + test-names))) + +;; itemmap is a list of testname patterns to maps +;; test1 .*/bar/(\d+) foo/\1 +;; % foo/([^/]+) \1/bar +;; +;; # NOTE: the line with the single % could be the result of +;; # itemmap entry in requirements (legacy). The itemmap +;; # requirements entry is deprecated +;; +(define (tests:get-itemmaps tconfig) + (let ((base-itemmap (configf:lookup tconfig "requirements" "itemmap")) + (itemmap-table (configf:get-section tconfig "itemmap"))) + (append (if base-itemmap + (list (list "%" base-itemmap)) + '()) + (if itemmap-table + itemmap-table + '())))) + + + +(define (tests:get-global-waitons rconfig) + (let* ((global-waitons (runconfigs-get rconfig "!GLOBAL_WAITONS"))) + (if (string? global-waitons) + (string-split global-waitons) + '()))) + +;; return items given config +;; +(define (tests:get-items tconfig) + (let ((items (hash-table-ref/default tconfig "items" #f)) ;; items 4 + (itemstable (hash-table-ref/default tconfig "itemstable" #f))) + ;; if either items or items table is a proc return it so test running + ;; process can know to call items:get-items-from-config + ;; if either is a list and none is a proc go ahead and call get-items + ;; otherwise return #f - this is not an iterated test + (cond + ((procedure? items) + (debug:print-info 4 *default-log-port* "items is a procedure, will calc later") + items) ;; calc later + ((procedure? itemstable) + (debug:print-info 4 *default-log-port* "itemstable is a procedure, will calc later") + itemstable) ;; calc later + ((filter (lambda (x) + (let ((val (car x))) + (if (procedure? val) val #f))) + (append (if (list? items) items '()) + (if (list? itemstable) itemstable '()))) + 'have-procedure) + ((or (list? items)(list? itemstable)) ;; calc now + (debug:print-info 4 *default-log-port* "items and itemstable are lists, calc now\n" + " items: " items " itemstable: " itemstable) + (items:get-items-from-config tconfig)) + (else #f)))) ;; not iterated + + +;; returns waitons waitors tconfigdat +;; +(define (tests:get-waitons test-name all-tests-registry global-waitons) + (let* ((config (tests:get-testconfig test-name #f all-tests-registry 'return-procs))) ;; assuming no problems with immediate evaluation, this could be simplified ('return-procs -> #t) + (let ((instr (if config + (configf:lookup config "requirements" "waiton") + (begin ;; No config means this is a non-existant test + (debug:print-error 0 *default-log-port* "non-existent required test \"" test-name "\"") + (exit 1)))) + (instr2 (if config + (configf:lookup config "requirements" "waitor") + ""))) + (debug:print-info 8 *default-log-port* "waitons string is " instr ", waitors string is " instr2) + (let* ((newwaitons-tmp + (string-split (cond + ((procedure? instr) ;; here + (let ((res (instr))) + (debug:print-info 8 *default-log-port* "waiton procedure results in string " res " for test " test-name) + res)) + ((string? instr) instr) + (else + ;; NOTE: This is actually the case of *no* waitons! ;; (debug:print-error 0 *default-log-port* "something went wrong in processing waitons for test " test-name) + "")))) + (newwaitors + (string-split (cond + ((procedure? instr2) + (let ((res (instr2))) + (debug:print-info 8 *default-log-port* "waitor procedure results in string " res " for test " test-name) + res)) + ((string? instr2) instr2) + (else + ;; NOTE: This is actually the case of *no* waitons! ;; (debug:print-error 0 *default-log-port* "something went wrong in processing waitons for test " test-name) + "")))) + (newwaitons (if (and (list? global-waitons) + (not (null? global-waitons))) + (begin + (debug:print 0 *default-log-port* "Adding global waitons " global-waitons) + (append newwaitons-tmp (filter (lambda (x) ;; remove self from global waitons + (not (equal? x test-name))) + global-waitons))) + newwaitons-tmp))) + (values + ;; the waitons + (filter (lambda (x) + (if (hash-table-ref/default all-tests-registry x #f) + #t + (begin + (debug:print-error 0 *default-log-port* "test " test-name " has unrecognised waiton testname " x) + #f))) + newwaitons) + (filter (lambda (x) + (if (hash-table-ref/default all-tests-registry x #f) + #t + (begin + (debug:print-error 0 *default-log-port* "test " test-name " has unrecognised waiton testname " x) + #f))) + newwaitors) + config))))) + +;; given waiting-test that is waiting on waiton-test extend test-patt appropriately +;; +;; genlib/testconfig sim/testconfig +;; genlib/sch sim/sch/cell1 +;; +;; [requirements] [requirements] +;; mode itemwait +;; # trim off the cell to determine what to run for genlib +;; itemmap /.* +;; +;; waiting-test is waiting on waiton-test so we need to create a pattern for waiton-test given waiting-test and itemmap +;; BB> (tests:extend-test-patts "normal-second/2" "normal-second" "normal-first" '()) +;; observed -> "normal-first/2,normal-first/,normal-second/2,normal-second/" +;; expected -> "normal-first,normal-second/2,normal-second/" +;; testpatt = normal-second/2 +;; waiting-test = normal-second +;; waiton-test = normal-first +;; itemmaps = () + +(define (tests:extend-test-patts test-patt waiting-test waiton-test itemmaps itemized-waiton) + (cond + (itemized-waiton + (let* ((itemmap (tests:lookup-itemmap itemmaps waiton-test)) + (patts (string-split test-patt ",")) + (waiting-test-len (+ (string-length waiting-test) 1)) + (patts-waiton (map (lambda (x) ;; for each incoming patt that matches the waiting test + (let* ((modpatt (if itemmap (db:convert-test-itempath x itemmap) x)) + (newpatt (conc waiton-test "/" (substring modpatt waiting-test-len (string-length modpatt))))) + ;; (conc waiting-test "/," waiting-test "/" (substring modpatt waiton-test-len (string-length modpatt))))) + ;; (print "in map, x=" x ", newpatt=" newpatt) + newpatt)) + (filter (lambda (x) + (eq? (substring-index (conc waiting-test "/") x) 0)) ;; is this patt pertinent to the waiting test + patts))) + (extended-test-patt (append patts (if (null? patts-waiton) + (list (conc waiton-test "/%")) ;; really shouldn't add the waiton forcefully like this + patts-waiton))) + (extended-test-patt-with-toplevels + (fold (lambda (testpatt-item accum ) + (let ((my-match (string-match "^([^%\\/]+)\\/.+$" testpatt-item))) + (cons testpatt-item + (if my-match + (cons + (conc (cadr my-match) "/") + accum) + accum)))) + '() + extended-test-patt))) + (string-intersperse (delete-duplicates extended-test-patt-with-toplevels) ","))) + (else ;; not waiting on items, waiting on entire waiton test. + (let* ((patts (string-split test-patt ",")) + (new-patts (if (member waiton-test patts) + patts + (cons waiton-test patts)))) + (string-intersperse (delete-duplicates new-patts) ","))))) + +;; Check for waiver eligibility +;; +(define (tests:check-waiver-eligibility testdat prev-testdat) + (let* ((test-registry (make-hash-table)) + (testconfig (tests:get-testconfig (db:test-get-testname testdat) (db:test-get-item-path testdat) test-registry #f)) + (test-rundir ;; (sdb:qry 'passstr + (db:test-get-rundir testdat)) ;; ) + (prev-rundir ;; (sdb:qry 'passstr + (db:test-get-rundir prev-testdat)) ;; ) + (waivers (if testconfig (configf:section-vars testconfig "waivers") '())) + (waiver-rx (regexp "^(\\S+)\\s+(.*)$")) + (diff-rule "diff %file1% %file2%") + (logpro-rule "diff %file1% %file2% | logpro %waivername%.logpro %waivername%.html")) + (if (not (common:file-exists? test-rundir)) + (begin + (debug:print-error 0 *default-log-port* "test run directory is gone, cannot propagate waiver") + #f) + (begin + (push-directory test-rundir) + (let ((result (if (null? waivers) + #f + (let loop ((hed (car waivers)) + (tal (cdr waivers))) + (debug:print 0 *default-log-port* "INFO: Applying waiver rule \"" hed "\"") + (let* ((waiver (configf:lookup testconfig "waivers" hed)) + (wparts (if waiver (string-match waiver-rx waiver) #f)) + (waiver-rule (if wparts (cadr wparts) #f)) + (waiver-glob (if wparts (caddr wparts) #f)) + (logpro-file (if waiver + (let ((fname (conc hed ".logpro"))) + (if (common:file-exists? fname) + fname + (begin + (debug:print 0 *default-log-port* "INFO: No logpro file " fname " falling back to diff") + #f))) + #f)) + ;; if rule by name of waiver-rule is found in testconfig - use it + ;; else if waivername.logpro exists use logpro-rule + ;; else default to diff-rule + (rule-string (let ((rule (configf:lookup testconfig "waiver_rules" waiver-rule))) + (if rule + rule + (if logpro-file + logpro-rule + (begin + (debug:print 0 *default-log-port* "INFO: No logpro file " logpro-file " found, using diff rule") + diff-rule))))) + ;; (string-substitute "%file1%" "foofoo.txt" "This is %file1% and so is this %file1%." #t) + (processed-cmd (string-substitute + "%file1%" (conc test-rundir "/" waiver-glob) + (string-substitute + "%file2%" (conc prev-rundir "/" waiver-glob) + (string-substitute + "%waivername%" hed rule-string #t) #t) #t)) + (res #f)) + (debug:print 0 *default-log-port* "INFO: waiver command is \"" processed-cmd "\"") + (if (eq? (system processed-cmd) 0) + (if (null? tal) + #t + (loop (car tal)(cdr tal))) + #f)))))) + (pop-directory) + result))))) + + +;; if .testconfig exists in test directory read and return it +;; else if have cached copy in *testconfigs* return it IFF there is a section "have fulldata" +;; else read the testconfig file +;; if have path to test directory save the config as .testconfig and return it +;; +(define (tests:get-testconfig test-name item-path test-registry system-allowed #!key (force-create #f)(allow-write-cache #t)(wait-a-minute #f)) + (let* ((use-cache (common:use-cache?)) + (cache-path (tests:get-test-path-from-environment)) + (cache-file (and cache-path (conc cache-path "/.testconfig"))) + (cache-exists (and cache-file + (not force-create) ;; if force-create then pretend there is no cache to read + (common:file-exists? cache-file))) + (cached-dat (if (and (not force-create) + cache-exists + use-cache) + (handle-exceptions + exn + (begin + (debug:print 0 *default-log-port* "failed to read " cache-file ", exn=" exn) + #f) ;; any issues, just give up with the cached version and re-read + (configf:read-alist cache-file)) + #f)) + (test-full-name (if (and item-path (not (string-null? item-path))) + (conc test-name "/" item-path) + test-name))) + (if cached-dat + cached-dat + (let ((dat (hash-table-ref/default *testconfigs* test-full-name #f))) + (if (and dat ;; have a locally cached version + (hash-table-ref/default dat "have fulldata" #f)) ;; marked as good data? + dat + ;; no cached data available + (let* ((treg (or test-registry + (tests:get-all))) + (test-path (or (hash-table-ref/default treg test-name #f) + (let* ((local-tcdir (conc (getenv "MT_LINKTREE") "/" + (getenv "MT_TARGET") "/" + (getenv "MT_RUNNAME") "/" + test-name "/" item-path)) + (local-tcfg (conc local-tcdir "/testconfig"))) + (if (common:file-exists? local-tcfg) + local-tcdir + #f)) + (conc *toppath* "/tests/" test-name))) + (test-configf (conc test-path "/testconfig")) + (testexists (let loopa ((tries-left 30)) + (cond + ( + (and (common:file-exists? test-configf)(file-read-access? test-configf)) + #t) + ( + (common:file-exists? test-configf) + (debug:print 0 *default-log-port* "WARNING: Cannot read testconfig file: "test-configf) + #f) + ( + (and wait-a-minute (> tries-left 0)) + (thread-sleep! 10) + (debug:print 0 *default-log-port* "WARNING: testconfig file does not exist: "test-configf" will retry in 10 seconds. Tries left: "tries-left) ;; BB: this fires + (loopa (sub1 tries-left))) + (else + (debug:print 2 *default-log-port* "WARNING: testconfig file does not exist: "test-configf) ;; BB: this fires + #f)))) + (tcfg (if testexists + (read-config test-configf #f system-allowed + environ-patt: (if system-allowed + "pre-launch-env-vars" + #f)) + #f))) + (if (and tcfg cache-file) (hash-table-set! tcfg "have fulldata" #t)) ;; mark this as fully read data + (if tcfg (hash-table-set! *testconfigs* test-full-name tcfg)) + (if (and testexists + cache-file + (file-write-access? cache-path) + allow-write-cache) + (let ((tpath (conc cache-path "/.testconfig"))) + (debug:print-info 1 *default-log-port* "Caching testconfig for " test-name " in " tpath) + (if (and tcfg (not (common:in-running-test?))) + (configf:write-alist tcfg tpath)))) + tcfg)))))) + +(define (configf:write-alist cdat fname) + (if (not (common:faux-lock fname)) + (debug:print 0 *default-log-port* "INFO: Could not get lock on " fname)) + (let* ((dat (configf:config->alist cdat)) + (res + (begin + (with-output-to-file fname ;; first write out the file + (lambda () + (pp dat))) + + (if (common:file-exists? fname) ;; now verify it is readable + (if (configf:read-alist fname) + #t ;; data is good. + (begin + (handle-exceptions + exn + (begin + (debug:print 0 *default-log-port* "deleting " fname " failed, exn=" exn) + #f) + (debug:print 0 *default-log-port* "WARNING: content " dat " for cache " fname " is not readable. Deleting generated file.") + (delete-file fname)) + #f)) + #f)))) + (common:faux-unlock fname) + res)) ) Index: mt.scm ================================================================== --- mt.scm +++ mt.scm @@ -33,15 +33,20 @@ (declare (uses tests)) (declare (uses server)) (declare (uses runs)) (declare (uses rmt)) (declare (uses rmtmod)) +(declare (uses megatestmod)) (import debugprint commonmod configfmod - rmtmod) + rmtmod + megatestmod) + +;; make mt: calls in megatestmod work +(read-config-set! read-config) (include "common_records.scm") (include "key_records.scm") (include "db_records.scm") (include "run_records.scm") @@ -48,31 +53,5 @@ (include "test_records.scm") ;; This is the Megatest API. All generally "useful" routines will be wrapped or extended ;; here. -(define (mt:lazy-read-test-config test-name) - (let ((tconf (hash-table-ref/default *testconfigs* test-name #f))) - (if tconf - tconf - (let ((test-dirs (tests:get-tests-search-path *configdat*))) - (let loop ((hed (car test-dirs)) - (tal (cdr test-dirs))) - ;; Setting MT_LINKTREE here is almost certainly unnecessary. - (let ((tconfig-file (conc hed "/" test-name "/testconfig"))) - (if (and (common:file-exists? tconfig-file) - (file-read-access? tconfig-file)) - (let ((link-tree-path (common:get-linktree)) ;; (configf:lookup *configdat* "setup" "linktree")) - (old-link-tree (get-environment-variable "MT_LINKTREE"))) - (if link-tree-path (setenv "MT_LINKTREE" link-tree-path)) - (let ((newtcfg (read-config tconfig-file #f #f))) ;; NOTE: Does NOT run [system ...] - (hash-table-set! *testconfigs* test-name newtcfg) - (if old-link-tree - (setenv "MT_LINKTREE" old-link-tree) - (unsetenv "MT_LINKTREE")) - newtcfg)) - (if (null? tal) - (begin - (debug:print-error 0 *default-log-port* "No readable testconfig found for " test-name) - #f) - (loop (car tal)(cdr tal)))))))))) - Index: rmtmod.scm ================================================================== --- rmtmod.scm +++ rmtmod.scm @@ -1217,8 +1217,112 @@ ;(let ((test-id (rmt:get-test-id run-id test-name item-path))) (rmt:set-state-status-and-roll-up-items run-id test-name item-path new-state new-status new-comment) ;; (mt:process-triggers run-id test-id new-state new-status) #t);) ;;(mt:test-set-state-status-by-id run-id test-id new-state new-status new-comment))) + +;; Do not rpc this one, do the underlying calls!!! +(define (tests:test-set-status! run-id test-id state status comment dat #!key (work-area #f)) + (let* ((real-status status) + (otherdat (if dat dat (make-hash-table))) + (testdat (rmt:get-test-info-by-id run-id test-id)) + (test-name (db:test-get-testname testdat)) + (item-path (db:test-get-item-path testdat)) + ;; before proceeding we must find out if the previous test (where all keys matched except runname) + ;; was WAIVED if this test is FAIL + + ;; NOTES: + ;; 1. Is the call to test:get-previous-run-record remotified? + ;; 2. Add test for testconfig waiver propagation control here + ;; + (prev-test (if (equal? status "FAIL") + (rmt:get-previous-test-run-record run-id test-name item-path) + #f)) + (waived (if prev-test + (if prev-test ;; true if we found a previous test in this run series + (let ((prev-status (db:test-get-status prev-test)) + (prev-state (db:test-get-state prev-test)) + (prev-comment (db:test-get-comment prev-test))) + (debug:print 4 *default-log-port* "prev-status " prev-status ", prev-state " prev-state ", prev-comment " prev-comment) + (if (and (equal? prev-state "COMPLETED") + (equal? prev-status "WAIVED")) + (if comment + comment + prev-comment) ;; waived is either the comment or #f + #f)) + #f) + #f))) + (if (and waived + (tests:check-waiver-eligibility testdat prev-test)) + (set! real-status "WAIVED")) + + (debug:print 4 *default-log-port* "real-status " real-status ", waived " waived ", status " status) + + ;; update the primary record IF state AND status are defined + (if (and state status) + (begin + (rmt:set-state-status-and-roll-up-items run-id test-id item-path state real-status (if waived waived comment)) + ;; (mt:process-triggers run-id test-id state real-status) ;; triggers are called in test-set-state-status + )) + + ;; if status is "AUTO" then call rollup (note, this one modifies data in test + ;; run area, it does remote calls under the hood. + ;; (if (and test-id state status (equal? status "AUTO")) + ;; (rmt:test-data-rollup run-id test-id status)) + + ;; add metadata (need to do this way to avoid SQL injection issues) + + ;; :first_err + ;; (let ((val (hash-table-ref/default otherdat ":first_err" #f))) + ;; (if val + ;; (sqlite3:execute db "UPDATE tests SET first_err=? WHERE run_id=? AND testname=? AND item_path=?;" val run-id test-name item-path))) + ;; + ;; ;; :first_warn + ;; (let ((val (hash-table-ref/default otherdat ":first_warn" #f))) + ;; (if val + ;; (sqlite3:execute db "UPDATE tests SET first_warn=? WHERE run_id=? AND testname=? AND item_path=?;" val run-id test-name item-path))) + + (let ((category (hash-table-ref/default otherdat ":category" "")) + (variable (hash-table-ref/default otherdat ":variable" "")) + (value (hash-table-ref/default otherdat ":value" #f)) + (expected (hash-table-ref/default otherdat ":expected" "n/a")) + (tol (hash-table-ref/default otherdat ":tol" "n/a")) + (units (hash-table-ref/default otherdat ":units" "")) + (type (hash-table-ref/default otherdat ":type" "")) + (dcomment (hash-table-ref/default otherdat ":comment" ""))) + (debug:print 4 *default-log-port* + "category: " category ", variable: " variable ", value: " value + ", expected: " expected ", tol: " tol ", units: " units) + (if (and value) ;; require only value; BB was- all three required + (let ((dat (conc category "," + variable "," + value "," + expected "," + tol "," + units "," + dcomment ",," ;; extra comma for status + type ))) + ;; This was run remote, don't think that makes sense. Perhaps not, but that is the easiest path for the moment. + (rmt:csv->test-data run-id test-id + dat) + ;; This was added in check-in a5adfa3f9a. Message was: "...added delay in set-values to allow for delayed write on server start" + ;; I'm inserting an arbitrary rmt: call to force/ensure that the server is available to (hopefully) prevent a communication issue. + (rmt:get-var "MEGATEST_VERSION") ;; this does NOTHING but ensure the server is reachable. This is almost certainly NOT needed :) + ;; BB - commentiong out arbitrary 10 second wait (thread-sleep! 10) ;; add 10 second delay before quit incase rmt needs time to start a server. + ))) + + ;; need to update the top test record if PASS or FAIL and this is a subtest + ;;;;;; (if (not (equal? item-path "")) + ;;;;;; (rmt:set-state-status-and-roll-up-items run-id test-name item-path state status #f) ;;;;;) + + (if (or (and (string? comment) + (string-match (regexp "\\S+") comment)) + waived) + (let ((cmt (if waived waived comment))) + (rmt:general-call 'set-test-comment run-id cmt test-id))))) + +(define (tests:test-set-toplog! run-id test-name logf) + (rmt:general-call 'tests:test-set-toplog run-id logf run-id test-name)) + ) Index: tests.scm ================================================================== --- tests.scm +++ tests.scm @@ -53,403 +53,10 @@ (include "js-path.scm") (define (init-java-script-lib) (set! *java-script-lib* (conc (common:get-install-area) "/share/js/jquery-3.1.0.slim.min.js")) ) - -;; Call this one to do all the work and get a standardized list of tests -;; gets paths from configs and finds valid tests -;; returns hash of testname --> fullpath -;; -(define (tests:get-all) - (let* ((test-search-path (tests:get-tests-search-path *configdat*))) - (debug:print 8 *default-log-port* "test-search-path: " test-search-path) - (tests:get-valid-tests (make-hash-table) test-search-path))) - -(define (tests:get-tests-search-path cfgdat) - (let ((paths (let ((section (if cfgdat - (configf:get-section cfgdat "tests-paths") - #f))) - (if section - (map cadr section) - '())))) - (filter (lambda (d) - (if (directory-exists? d) - d - (begin - ;; (if (common:low-noise-print 60 "tests:get-tests-search-path" d) - ;; (debug:print 0 *default-log-port* "WARNING: problem with directory " d ", dropping it from tests path")) - #f))) - (append paths (list (conc *toppath* "/tests")))))) - -(define (tests:get-valid-tests test-registry tests-paths) - (if (null? tests-paths) - test-registry - (let loop ((hed (car tests-paths)) - (tal (cdr tests-paths))) - (if (common:file-exists? hed) - (for-each (lambda (test-path) - (let* ((tname (last (string-split test-path "/"))) - (tconfig (conc test-path "/testconfig"))) - (if (and (not (hash-table-ref/default test-registry tname #f)) - (common:file-exists? tconfig)) - (hash-table-set! test-registry tname test-path)))) - (glob (conc hed "/*")))) - (if (null? tal) - test-registry - (loop (car tal)(cdr tal)))))) - -(define (tests:filter-test-names-not-matched test-names test-patts) - (delete-duplicates - (filter (lambda (testname) - (not (tests:match test-patts testname #f))) - test-names))) - - -(define (tests:filter-test-names test-names test-patts) - (delete-duplicates - (filter (lambda (testname) - (tests:match test-patts testname #f)) - test-names))) - -;; itemmap is a list of testname patterns to maps -;; test1 .*/bar/(\d+) foo/\1 -;; % foo/([^/]+) \1/bar -;; -;; # NOTE: the line with the single % could be the result of -;; # itemmap entry in requirements (legacy). The itemmap -;; # requirements entry is deprecated -;; -(define (tests:get-itemmaps tconfig) - (let ((base-itemmap (configf:lookup tconfig "requirements" "itemmap")) - (itemmap-table (configf:get-section tconfig "itemmap"))) - (append (if base-itemmap - (list (list "%" base-itemmap)) - '()) - (if itemmap-table - itemmap-table - '())))) - - - -(define (tests:get-global-waitons rconfig) - (let* ((global-waitons (runconfigs-get rconfig "!GLOBAL_WAITONS"))) - (if (string? global-waitons) - (string-split global-waitons) - '()))) - -;; return items given config -;; -(define (tests:get-items tconfig) - (let ((items (hash-table-ref/default tconfig "items" #f)) ;; items 4 - (itemstable (hash-table-ref/default tconfig "itemstable" #f))) - ;; if either items or items table is a proc return it so test running - ;; process can know to call items:get-items-from-config - ;; if either is a list and none is a proc go ahead and call get-items - ;; otherwise return #f - this is not an iterated test - (cond - ((procedure? items) - (debug:print-info 4 *default-log-port* "items is a procedure, will calc later") - items) ;; calc later - ((procedure? itemstable) - (debug:print-info 4 *default-log-port* "itemstable is a procedure, will calc later") - itemstable) ;; calc later - ((filter (lambda (x) - (let ((val (car x))) - (if (procedure? val) val #f))) - (append (if (list? items) items '()) - (if (list? itemstable) itemstable '()))) - 'have-procedure) - ((or (list? items)(list? itemstable)) ;; calc now - (debug:print-info 4 *default-log-port* "items and itemstable are lists, calc now\n" - " items: " items " itemstable: " itemstable) - (items:get-items-from-config tconfig)) - (else #f)))) ;; not iterated - - -;; returns waitons waitors tconfigdat -;; -(define (tests:get-waitons test-name all-tests-registry global-waitons) - (let* ((config (tests:get-testconfig test-name #f all-tests-registry 'return-procs))) ;; assuming no problems with immediate evaluation, this could be simplified ('return-procs -> #t) - (let ((instr (if config - (configf:lookup config "requirements" "waiton") - (begin ;; No config means this is a non-existant test - (debug:print-error 0 *default-log-port* "non-existent required test \"" test-name "\"") - (exit 1)))) - (instr2 (if config - (configf:lookup config "requirements" "waitor") - ""))) - (debug:print-info 8 *default-log-port* "waitons string is " instr ", waitors string is " instr2) - (let* ((newwaitons-tmp - (string-split (cond - ((procedure? instr) ;; here - (let ((res (instr))) - (debug:print-info 8 *default-log-port* "waiton procedure results in string " res " for test " test-name) - res)) - ((string? instr) instr) - (else - ;; NOTE: This is actually the case of *no* waitons! ;; (debug:print-error 0 *default-log-port* "something went wrong in processing waitons for test " test-name) - "")))) - (newwaitors - (string-split (cond - ((procedure? instr2) - (let ((res (instr2))) - (debug:print-info 8 *default-log-port* "waitor procedure results in string " res " for test " test-name) - res)) - ((string? instr2) instr2) - (else - ;; NOTE: This is actually the case of *no* waitons! ;; (debug:print-error 0 *default-log-port* "something went wrong in processing waitons for test " test-name) - "")))) - (newwaitons (if (and (list? global-waitons) - (not (null? global-waitons))) - (begin - (debug:print 0 *default-log-port* "Adding global waitons " global-waitons) - (append newwaitons-tmp (filter (lambda (x) ;; remove self from global waitons - (not (equal? x test-name))) - global-waitons))) - newwaitons-tmp))) - (values - ;; the waitons - (filter (lambda (x) - (if (hash-table-ref/default all-tests-registry x #f) - #t - (begin - (debug:print-error 0 *default-log-port* "test " test-name " has unrecognised waiton testname " x) - #f))) - newwaitons) - (filter (lambda (x) - (if (hash-table-ref/default all-tests-registry x #f) - #t - (begin - (debug:print-error 0 *default-log-port* "test " test-name " has unrecognised waiton testname " x) - #f))) - newwaitors) - config))))) - -;; given waiting-test that is waiting on waiton-test extend test-patt appropriately -;; -;; genlib/testconfig sim/testconfig -;; genlib/sch sim/sch/cell1 -;; -;; [requirements] [requirements] -;; mode itemwait -;; # trim off the cell to determine what to run for genlib -;; itemmap /.* -;; -;; waiting-test is waiting on waiton-test so we need to create a pattern for waiton-test given waiting-test and itemmap -;; BB> (tests:extend-test-patts "normal-second/2" "normal-second" "normal-first" '()) -;; observed -> "normal-first/2,normal-first/,normal-second/2,normal-second/" -;; expected -> "normal-first,normal-second/2,normal-second/" -;; testpatt = normal-second/2 -;; waiting-test = normal-second -;; waiton-test = normal-first -;; itemmaps = () - -(define (tests:extend-test-patts test-patt waiting-test waiton-test itemmaps itemized-waiton) - (cond - (itemized-waiton - (let* ((itemmap (tests:lookup-itemmap itemmaps waiton-test)) - (patts (string-split test-patt ",")) - (waiting-test-len (+ (string-length waiting-test) 1)) - (patts-waiton (map (lambda (x) ;; for each incoming patt that matches the waiting test - (let* ((modpatt (if itemmap (db:convert-test-itempath x itemmap) x)) - (newpatt (conc waiton-test "/" (substring modpatt waiting-test-len (string-length modpatt))))) - ;; (conc waiting-test "/," waiting-test "/" (substring modpatt waiton-test-len (string-length modpatt))))) - ;; (print "in map, x=" x ", newpatt=" newpatt) - newpatt)) - (filter (lambda (x) - (eq? (substring-index (conc waiting-test "/") x) 0)) ;; is this patt pertinent to the waiting test - patts))) - (extended-test-patt (append patts (if (null? patts-waiton) - (list (conc waiton-test "/%")) ;; really shouldn't add the waiton forcefully like this - patts-waiton))) - (extended-test-patt-with-toplevels - (fold (lambda (testpatt-item accum ) - (let ((my-match (string-match "^([^%\\/]+)\\/.+$" testpatt-item))) - (cons testpatt-item - (if my-match - (cons - (conc (cadr my-match) "/") - accum) - accum)))) - '() - extended-test-patt))) - (string-intersperse (delete-duplicates extended-test-patt-with-toplevels) ","))) - (else ;; not waiting on items, waiting on entire waiton test. - (let* ((patts (string-split test-patt ",")) - (new-patts (if (member waiton-test patts) - patts - (cons waiton-test patts)))) - (string-intersperse (delete-duplicates new-patts) ","))))) - -;; Check for waiver eligibility -;; -(define (tests:check-waiver-eligibility testdat prev-testdat) - (let* ((test-registry (make-hash-table)) - (testconfig (tests:get-testconfig (db:test-get-testname testdat) (db:test-get-item-path testdat) test-registry #f)) - (test-rundir ;; (sdb:qry 'passstr - (db:test-get-rundir testdat)) ;; ) - (prev-rundir ;; (sdb:qry 'passstr - (db:test-get-rundir prev-testdat)) ;; ) - (waivers (if testconfig (configf:section-vars testconfig "waivers") '())) - (waiver-rx (regexp "^(\\S+)\\s+(.*)$")) - (diff-rule "diff %file1% %file2%") - (logpro-rule "diff %file1% %file2% | logpro %waivername%.logpro %waivername%.html")) - (if (not (common:file-exists? test-rundir)) - (begin - (debug:print-error 0 *default-log-port* "test run directory is gone, cannot propagate waiver") - #f) - (begin - (push-directory test-rundir) - (let ((result (if (null? waivers) - #f - (let loop ((hed (car waivers)) - (tal (cdr waivers))) - (debug:print 0 *default-log-port* "INFO: Applying waiver rule \"" hed "\"") - (let* ((waiver (configf:lookup testconfig "waivers" hed)) - (wparts (if waiver (string-match waiver-rx waiver) #f)) - (waiver-rule (if wparts (cadr wparts) #f)) - (waiver-glob (if wparts (caddr wparts) #f)) - (logpro-file (if waiver - (let ((fname (conc hed ".logpro"))) - (if (common:file-exists? fname) - fname - (begin - (debug:print 0 *default-log-port* "INFO: No logpro file " fname " falling back to diff") - #f))) - #f)) - ;; if rule by name of waiver-rule is found in testconfig - use it - ;; else if waivername.logpro exists use logpro-rule - ;; else default to diff-rule - (rule-string (let ((rule (configf:lookup testconfig "waiver_rules" waiver-rule))) - (if rule - rule - (if logpro-file - logpro-rule - (begin - (debug:print 0 *default-log-port* "INFO: No logpro file " logpro-file " found, using diff rule") - diff-rule))))) - ;; (string-substitute "%file1%" "foofoo.txt" "This is %file1% and so is this %file1%." #t) - (processed-cmd (string-substitute - "%file1%" (conc test-rundir "/" waiver-glob) - (string-substitute - "%file2%" (conc prev-rundir "/" waiver-glob) - (string-substitute - "%waivername%" hed rule-string #t) #t) #t)) - (res #f)) - (debug:print 0 *default-log-port* "INFO: waiver command is \"" processed-cmd "\"") - (if (eq? (system processed-cmd) 0) - (if (null? tal) - #t - (loop (car tal)(cdr tal))) - #f)))))) - (pop-directory) - result))))) - -;; Do not rpc this one, do the underlying calls!!! -(define (tests:test-set-status! run-id test-id state status comment dat #!key (work-area #f)) - (let* ((real-status status) - (otherdat (if dat dat (make-hash-table))) - (testdat (rmt:get-test-info-by-id run-id test-id)) - (test-name (db:test-get-testname testdat)) - (item-path (db:test-get-item-path testdat)) - ;; before proceeding we must find out if the previous test (where all keys matched except runname) - ;; was WAIVED if this test is FAIL - - ;; NOTES: - ;; 1. Is the call to test:get-previous-run-record remotified? - ;; 2. Add test for testconfig waiver propagation control here - ;; - (prev-test (if (equal? status "FAIL") - (rmt:get-previous-test-run-record run-id test-name item-path) - #f)) - (waived (if prev-test - (if prev-test ;; true if we found a previous test in this run series - (let ((prev-status (db:test-get-status prev-test)) - (prev-state (db:test-get-state prev-test)) - (prev-comment (db:test-get-comment prev-test))) - (debug:print 4 *default-log-port* "prev-status " prev-status ", prev-state " prev-state ", prev-comment " prev-comment) - (if (and (equal? prev-state "COMPLETED") - (equal? prev-status "WAIVED")) - (if comment - comment - prev-comment) ;; waived is either the comment or #f - #f)) - #f) - #f))) - (if (and waived - (tests:check-waiver-eligibility testdat prev-test)) - (set! real-status "WAIVED")) - - (debug:print 4 *default-log-port* "real-status " real-status ", waived " waived ", status " status) - - ;; update the primary record IF state AND status are defined - (if (and state status) - (begin - (rmt:set-state-status-and-roll-up-items run-id test-id item-path state real-status (if waived waived comment)) - ;; (mt:process-triggers run-id test-id state real-status) ;; triggers are called in test-set-state-status - )) - - ;; if status is "AUTO" then call rollup (note, this one modifies data in test - ;; run area, it does remote calls under the hood. - ;; (if (and test-id state status (equal? status "AUTO")) - ;; (rmt:test-data-rollup run-id test-id status)) - - ;; add metadata (need to do this way to avoid SQL injection issues) - - ;; :first_err - ;; (let ((val (hash-table-ref/default otherdat ":first_err" #f))) - ;; (if val - ;; (sqlite3:execute db "UPDATE tests SET first_err=? WHERE run_id=? AND testname=? AND item_path=?;" val run-id test-name item-path))) - ;; - ;; ;; :first_warn - ;; (let ((val (hash-table-ref/default otherdat ":first_warn" #f))) - ;; (if val - ;; (sqlite3:execute db "UPDATE tests SET first_warn=? WHERE run_id=? AND testname=? AND item_path=?;" val run-id test-name item-path))) - - (let ((category (hash-table-ref/default otherdat ":category" "")) - (variable (hash-table-ref/default otherdat ":variable" "")) - (value (hash-table-ref/default otherdat ":value" #f)) - (expected (hash-table-ref/default otherdat ":expected" "n/a")) - (tol (hash-table-ref/default otherdat ":tol" "n/a")) - (units (hash-table-ref/default otherdat ":units" "")) - (type (hash-table-ref/default otherdat ":type" "")) - (dcomment (hash-table-ref/default otherdat ":comment" ""))) - (debug:print 4 *default-log-port* - "category: " category ", variable: " variable ", value: " value - ", expected: " expected ", tol: " tol ", units: " units) - (if (and value) ;; require only value; BB was- all three required - (let ((dat (conc category "," - variable "," - value "," - expected "," - tol "," - units "," - dcomment ",," ;; extra comma for status - type ))) - ;; This was run remote, don't think that makes sense. Perhaps not, but that is the easiest path for the moment. - (rmt:csv->test-data run-id test-id - dat) - ;; This was added in check-in a5adfa3f9a. Message was: "...added delay in set-values to allow for delayed write on server start" - ;; I'm inserting an arbitrary rmt: call to force/ensure that the server is available to (hopefully) prevent a communication issue. - (rmt:get-var "MEGATEST_VERSION") ;; this does NOTHING but ensure the server is reachable. This is almost certainly NOT needed :) - ;; BB - commentiong out arbitrary 10 second wait (thread-sleep! 10) ;; add 10 second delay before quit incase rmt needs time to start a server. - ))) - - ;; need to update the top test record if PASS or FAIL and this is a subtest - ;;;;;; (if (not (equal? item-path "")) - ;;;;;; (rmt:set-state-status-and-roll-up-items run-id test-name item-path state status #f) ;;;;;) - - (if (or (and (string? comment) - (string-match (regexp "\\S+") comment)) - waived) - (let ((cmt (if waived waived comment))) - (rmt:general-call 'set-test-comment run-id cmt test-id))))) - -(define (tests:test-set-toplog! run-id test-name logf) - (rmt:general-call 'tests:test-set-toplog run-id logf run-id test-name)) - (define (tests:summarize-items run-id test-id test-name force) ;; if not force then only update the record if one of these is true: ;; 1. logf is "log/final.log ;; 2. logf is same as outputfilename (let* ((outputfilename (conc "megatest-rollup-" test-name ".html")) @@ -1480,90 +1087,10 @@ (not (string=? "" (getenv "MT_ITEMPATH")))) (conc "/" (getenv "MT_ITEMPATH")) "")) #f)) -;; if .testconfig exists in test directory read and return it -;; else if have cached copy in *testconfigs* return it IFF there is a section "have fulldata" -;; else read the testconfig file -;; if have path to test directory save the config as .testconfig and return it -;; -(define (tests:get-testconfig test-name item-path test-registry system-allowed #!key (force-create #f)(allow-write-cache #t)(wait-a-minute #f)) - (let* ((use-cache (common:use-cache?)) - (cache-path (tests:get-test-path-from-environment)) - (cache-file (and cache-path (conc cache-path "/.testconfig"))) - (cache-exists (and cache-file - (not force-create) ;; if force-create then pretend there is no cache to read - (common:file-exists? cache-file))) - (cached-dat (if (and (not force-create) - cache-exists - use-cache) - (handle-exceptions - exn - (begin - (debug:print 0 *default-log-port* "failed to read " cache-file ", exn=" exn) - #f) ;; any issues, just give up with the cached version and re-read - (configf:read-alist cache-file)) - #f)) - (test-full-name (if (and item-path (not (string-null? item-path))) - (conc test-name "/" item-path) - test-name))) - (if cached-dat - cached-dat - (let ((dat (hash-table-ref/default *testconfigs* test-full-name #f))) - (if (and dat ;; have a locally cached version - (hash-table-ref/default dat "have fulldata" #f)) ;; marked as good data? - dat - ;; no cached data available - (let* ((treg (or test-registry - (tests:get-all))) - (test-path (or (hash-table-ref/default treg test-name #f) - (let* ((local-tcdir (conc (getenv "MT_LINKTREE") "/" - (getenv "MT_TARGET") "/" - (getenv "MT_RUNNAME") "/" - test-name "/" item-path)) - (local-tcfg (conc local-tcdir "/testconfig"))) - (if (common:file-exists? local-tcfg) - local-tcdir - #f)) - (conc *toppath* "/tests/" test-name))) - (test-configf (conc test-path "/testconfig")) - (testexists (let loopa ((tries-left 30)) - (cond - ( - (and (common:file-exists? test-configf)(file-read-access? test-configf)) - #t) - ( - (common:file-exists? test-configf) - (debug:print 0 *default-log-port* "WARNING: Cannot read testconfig file: "test-configf) - #f) - ( - (and wait-a-minute (> tries-left 0)) - (thread-sleep! 10) - (debug:print 0 *default-log-port* "WARNING: testconfig file does not exist: "test-configf" will retry in 10 seconds. Tries left: "tries-left) ;; BB: this fires - (loopa (sub1 tries-left))) - (else - (debug:print 2 *default-log-port* "WARNING: testconfig file does not exist: "test-configf) ;; BB: this fires - #f)))) - (tcfg (if testexists - (read-config test-configf #f system-allowed - environ-patt: (if system-allowed - "pre-launch-env-vars" - #f)) - #f))) - (if (and tcfg cache-file) (hash-table-set! tcfg "have fulldata" #t)) ;; mark this as fully read data - (if tcfg (hash-table-set! *testconfigs* test-full-name tcfg)) - (if (and testexists - cache-file - (file-write-access? cache-path) - allow-write-cache) - (let ((tpath (conc cache-path "/.testconfig"))) - (debug:print-info 1 *default-log-port* "Caching testconfig for " test-name " in " tpath) - (if (and tcfg (not (common:in-running-test?))) - (configf:write-alist tcfg tpath)))) - tcfg)))))) - ;; sort tests by priority and waiton ;; Move test specific stuff to a test unit FIXME one of these days (define (tests:sort-by-priority-and-waiton test-records) (if (eq? (hash-table-size test-records) 0) '() ADDED testsmod.scm Index: testsmod.scm ================================================================== --- /dev/null +++ testsmod.scm @@ -0,0 +1,120 @@ +;;====================================================================== +;; Copyright 2017, Matthew Welland. +;; +;; 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 +;; (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 +;; 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 . + +;;====================================================================== + +;;====================================================================== +;; Cpumod: +;; +;; Put things here don't fit anywhere else +;;====================================================================== + +(declare (unit testsmod)) +(declare (uses debugprint)) +(declare (uses mtargs)) +(declare (uses commonmod)) +(declare (uses configfmod)) +(declare (uses dbmod)) +(declare (uses dbfile)) +;; (declare (uses megatestmod)) + +(use srfi-69) + +(module testsmod + * + +(import scheme) +(cond-expand + (chicken-4 + + (import chicken + ports + (prefix base64 base64:) + + (prefix sqlite3 sqlite3:) + data-structures + extras + files + matchable + md5 + message-digest + pathname-expand + posix + posix-extras + regex + regex-case + sparse-vectors + srfi-1 + srfi-18 + srfi-69 + typed-records + z3 + + debugprint + (prefix mtargs args:) + ) + (use srfi-69)) + (chicken-5 + (import (prefix sqlite3 sqlite3:) + ;; data-structures + ;; extras + ;; files + ;; posix + ;; posix-extras + chicken.base + chicken.condition + chicken.file + chicken.file.posix + chicken.io + chicken.pathname + chicken.port + chicken.process + chicken.process-context + chicken.process-context.posix + chicken.sort + chicken.string + chicken.time + chicken.time.posix + + matchable + md5 + message-digest + pathname-expand + regex + regex-case + srfi-1 + srfi-18 + srfi-69 + typed-records + system-information + + debugprint + ))) + +(import directory-utils + + debugprint + commonmod + configfmod + dbmod + dbfile + ;; megatestmod + ) + + +)