Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -38,11 +38,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 + stml2.scm fsmod.scm cpumod.scm mtmod.scm odsmod.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 @@ -50,16 +50,18 @@ mtest : transport-mode.scm dboard : dashboard-transport-mode.scm # dbmod.import.o is just a hack here -mofiles/portlogger.o : mofiles/dbmod.o -process.o : mofiles/processmod.o + +process.o : mofiles/processmod.o mofiles/configfmod.o : mofiles/processmod.o mofiles/processmod.o : mofiles/commonmod.o mofiles/servermod.o : mofiles/commonmod.o mofiles/rmtmod.o : mofiles/mtmod.o +mofiles/mtmod.o : mofiles/dbmod.o +mofiles/mtmod.o : mofiles/tcp-transportmod.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/dbmod.o : mofiles/dbfile.o Index: common_records.scm ================================================================== --- common_records.scm +++ common_records.scm @@ -18,11 +18,11 @@ ;; ;;====================================================================== ;; (use trace) -(include "altdb.scm") +;; (include "altdb.scm") ;; Some of these routines use: ;; ;; http://www.cs.toronto.edu/~gfb/scheme/simple-macros.html ;; Index: commonmod.scm ================================================================== --- commonmod.scm +++ commonmod.scm @@ -414,10 +414,12 @@ (define home (getenv "HOME")) (define user (getenv "USER")) ;;====================================================================== ;; return a nice clean pathname made absolute +;;====================================================================== + (define (common:nice-path dir) (let ((match (string-match "^(~[^\\/]*)(\\/.*|)$" dir))) (if match ;; using ~ for home? (common:nice-path (conc (common:read-link-f (cadr match)) "/" (caddr match))) (normalize-pathname (if (absolute-pathname? dir) @@ -493,11 +495,12 @@ ;;====================================================================== ;; does the directory exist and do we have write access? ;; ;; returns the directory or #f -;; +;;====================================================================== + (define (common:directory-writable? path-string) (handle-exceptions exn (begin (debug:print 0 *default-log-port* "Failed to identify access to " path-string ", exn=" exn) @@ -592,10 +595,88 @@ (delete-file* fname))) ;;====================================================================== ;; misc conversion, data manipulation functions ;;====================================================================== + +;;====================================================================== +;; old stuff from keys.scm +;;====================================================================== + +(include "key_records.scm") +(include "common_records.scm") + +(define (keys->keystr keys) ;; => key1,key2,key3,additiona1, ... + (string-intersperse keys ",")) + +;; (define (args:usage . a) #f) + +(define (tasks:wait-on-journal path n #!key (remove #f)(waiting-msg #f)) + (if (not (string? path)) + (debug:print-error 0 *default-log-port* "Called tasks:wait-on-journal with path=" path " (not a string)") + (let ((fullpath (conc path "-journal"))) + (handle-exceptions + exn + (begin + (print-call-chain (current-error-port)) + (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 5 *default-log-port* " exn=" (condition->list exn)) + (debug:print 0 *default-log-port* "tasks:wait-on-journal failed. Continuing on, you can ignore this call-chain") + #t) ;; if stuff goes wrong just allow it to move on + (let loop ((journal-exists (file-exists? fullpath)) + (count n)) ;; wait ten times ... + (if journal-exists + (begin + (if (and waiting-msg + (eq? (modulo n 30) 0)) + (debug:print 0 *default-log-port* waiting-msg)) + (if (> count 0) + (begin + (thread-sleep! 1) + (loop (file-exists? fullpath) + (- count 1))) + (begin + (debug:print 0 *default-log-port* "ERROR: removing the journal file " fullpath ", this is not good. Look for disk full, write access and other issues.") + (if remove (system (conc "rm -rf " fullpath))) + #f))) + #t)))))) + +;;====================================================================== +;; key <=> target routines +;;====================================================================== + +;; This invalidates using "/" in item names. Every key will be +;; available via args:get-arg as :keyfield. Since this only needs to +;; be called once let's use it to set the environment vars +;; +;; The setting of :keyfield in args should be turned off ASAP +;; +(define (keys:target-set-args keys target ht) + (if target + (let ((vals (string-split target "/"))) + (if (eq? (length vals)(length keys)) + (for-each (lambda (key val) + (setenv key val) + (if ht (hash-table-set! ht (conc ":" key) val))) + keys + vals) + (debug:print-error 0 *default-log-port* "wrong number of values in " target ", should match " keys)) + vals) + (debug:print 4 *default-log-port* "ERROR: keys:target-set-args called with no target."))) + +;; given the keys (a list of vectors or a list of keys) and a target return a keyval list +;; keyval list ( (key1 val1) (key2 val2) ...) +(define (keys:target->keyval keys target) + (let* ((targlist (string-split target "/")) + (numkeys (length keys)) + (numtarg (length targlist)) + (targtweaked (if (> numkeys numtarg) + (append targlist (make-list (- numkeys numtarg) "")) + targlist))) + (map (lambda (key targ) + (list key targ)) + keys targtweaked))) ;;====================================================================== ;; return first command that exists, else #f ;; (define (common:which cmds) @@ -2500,9 +2581,130 @@ (debug:print 0 *default-log-port* "joining threads failed. exn=" exn) #t) ;; just ignore it, it might have died in the meantime so joining it will throw an exception (thread-join! thread)) ))) (hash-table-keys *common:thread-punchlist*))) + +;; given a list of itemmaps (testname . map), return the first match +;; +(define (tests:lookup-itemmap itemmaps testname) + (let ((best-matches (filter (lambda (itemmap) + (tests:match (car itemmap) testname #f)) + itemmaps))) + (if (null? best-matches) + #f + (let ((res (car best-matches))) + ;; (debug:print 0 *default-log-port* "res=" res) + (cond + ((string? res) res) ;;; FIX THE ROOT CAUSE HERE .... + ((null? res) #f) + ((string? (cdr res)) (cdr res)) ;; it is a pair + ((string? (cadr res))(cadr res)) ;; it is a list + (else cadr res)))))) + +;; if itempath is #f then look only at the testname part +;; +(define (tests:match patterns testname itempath #!key (required '())) + (if (string? patterns) + (let ((patts (append (string-split patterns ",") required))) + (if (null? patts) ;;; no pattern(s) means no match + #f + (let loop ((patt (car patts)) + (tal (cdr patts))) + ;; (print "loop: patt: " patt ", tal " tal) + (if (string=? patt "") + #f ;; nothing ever matches empty string - policy + (let* ((patt-parts (string-match (regexp "^([^\\/]*)(\\/(.*)|)$") patt)) + (test-patt (cadr patt-parts)) + (item-patt (cadddr patt-parts))) + ;; special case: test vs. test/ + ;; test => "test" "%" + ;; test/ => "test" "" + (if (and (not (substring-index "/" patt)) ;; no slash in the original + (or (not item-patt) + (equal? item-patt ""))) ;; should always be true that item-patt is "" + (set! item-patt "%")) + ;; (print "tests:match => patt-parts: " patt-parts ", test-patt: " test-patt ", item-patt: " item-patt) + (if (and (tests:glob-like-match test-patt testname) + (or (not itempath) + (tests:glob-like-match (if item-patt item-patt "") itempath))) + #t + (if (null? tal) + #f + (loop (car tal)(cdr tal))))))))))) + +;; if itempath is #f then look only at the testname part +;; +(define (tests:match->sqlqry patterns) + (if (string? patterns) + (let ((patts (string-split patterns ","))) + (if (null? patts) ;;; no pattern(s) means no match, we will do no query + #f + (let loop ((patt (car patts)) + (tal (cdr patts)) + (res '())) + ;; (print "loop: patt: " patt ", tal " tal) + (let* ((patt-parts (string-match (regexp "^([^\\/]*)(\\/(.*)|)$") patt)) + (test-patt (cadr patt-parts)) + (item-patt (cadddr patt-parts)) + (test-qry (db:patt->like "testname" test-patt)) + (item-qry (db:patt->like "item_path" item-patt)) + (qry (conc "(" test-qry " AND " item-qry ")"))) + ;; (print "tests:match => patt-parts: " patt-parts ", test-patt: " test-patt ", item-patt: " item-patt) + (if (null? tal) + (string-intersperse (append (reverse res)(list qry)) " OR ") + (loop (car tal)(cdr tal)(cons qry res))))))) + #f)) + +(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)) + (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))) + +;; keys list to key1,key2,key3 ... +(define (runs:get-std-run-fields keys remfields) + (let* ((header (append keys remfields)) + (keystr (conc (keys->keystr keys) "," + (string-intersperse remfields ",")))) + (list keystr header))) + +;; make a query (fieldname like 'patt1' OR fieldname +(define (db:patt->like fieldname pattstr #!key (comparator " OR ")) + (let ((patts (if (string? pattstr) + (string-split pattstr ",") + '("%")))) + (string-intersperse (map (lambda (patt) + (let ((wildtype (if (substring-index "%" patt) "LIKE" "GLOB"))) + (conc fieldname " " wildtype " '" patt "'"))) + (if (null? patts) + '("") + patts)) + comparator))) + +;;====================================================================== +;; V E R S I O N +;;====================================================================== + +(define (common:get-full-version) + (conc megatest-version "-" megatest-fossil-hash)) + +(define (common:version-signature) + (conc megatest-version "-" (substring megatest-fossil-hash 0 4))) ) Index: dbfile.scm ================================================================== --- dbfile.scm +++ dbfile.scm @@ -135,12 +135,11 @@ (dbfile #f) ;; path to the db file on disk (dbfname #f) ;; short name of db file on disk (used to validate accessing correct db) (ondiskdb #f) ;; handle for the on-disk file (dbtmpname #f) ;; path to db file in /tmp (non-imem method) (dbdat #f) ;; create a dbdat for the downstream calls such as db:with-db - (last-update 0) - (sync-proc #f) +grep (last-update 0) (sync-proc #f) ) ;; NOTE: Need one dbr:subdb per main.db, 1.db ... ;; (defstruct dbr:subdb @@ -147,10 +146,11 @@ (dbname #f) ;; .mtdb/1.db (mtdbfile #f) ;; mtrah/.mtdb/1.db (mtdbdat #f) ;; only need one of these for syncing ;; (dbdats (make-hash-table)) ;; id => dbdat (tmpdbfile #f) ;; /tmp/.../.mtdb/1.db + (refndb #f) ;; FIX THIS, IT SHOULD NOT BE REFERENCED! ;; (refndbfile #f) ;; /tmp/.../.mtdb/1.db_ref (dbstack (make-stack)) ;; stack for tmp dbr:dbdat, (homehost #f) ;; not used yet (on-homehost #f) ;; not used yet (read-only #f) Index: dbmod.scm ================================================================== --- dbmod.scm +++ dbmod.scm @@ -23,10 +23,11 @@ (declare (uses dbfile)) (declare (uses commonmod)) (declare (uses configfmod)) (declare (uses debugprint)) (declare (uses mtargs)) +(declare (uses mtmod)) (module dbmod * (import scheme) @@ -40,11 +41,13 @@ debugprint extras files (prefix mtargs args:) posix - + ports + csv-xml + )) (chicken-5 (import chicken.base chicken.condition chicken.file @@ -62,18 +65,23 @@ (import format (prefix sqlite3 sqlite3:) matchable typed-records regex + s11n srfi-1 srfi-18 srfi-69 - + z3 + (prefix base64 base64:) + commonmod configfmod dbfile - debugprint) + debugprint + mtmod + ) (include "common_records.scm") (include "db_records.scm") (include "key_records.scm") (include "run_records.scm") @@ -699,40 +707,10 @@ ;; Moved from dbfile ;;====================================================================== ;; wait up to aprox n seconds for a journal to go away ;; -(define (tasks:wait-on-journal path n #!key (remove #f)(waiting-msg #f)) - (if (not (string? path)) - (debug:print-error 0 *default-log-port* "Called tasks:wait-on-journal with path=" path " (not a string)") - (let ((fullpath (conc path "-journal"))) - (handle-exceptions - exn - (begin - (print-call-chain (current-error-port)) - (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) - (debug:print 5 *default-log-port* " exn=" (condition->list exn)) - (debug:print 0 *default-log-port* "tasks:wait-on-journal failed. Continuing on, you can ignore this call-chain") - #t) ;; if stuff goes wrong just allow it to move on - (let loop ((journal-exists (file-exists? fullpath)) - (count n)) ;; wait ten times ... - (if journal-exists - (begin - (if (and waiting-msg - (eq? (modulo n 30) 0)) - (debug:print 0 *default-log-port* waiting-msg)) - (if (> count 0) - (begin - (thread-sleep! 1) - (loop (file-exists? fullpath) - (- count 1))) - (begin - (debug:print 0 *default-log-port* "ERROR: removing the journal file " fullpath ", this is not good. Look for disk full, write access and other issues.") - (if remove (system (conc "rm -rf " fullpath))) - #f))) - #t)))))) - ;;====================================================================== ;; M E T A G E T A N D S E T V A R S ;;====================================================================== @@ -1082,56 +1060,10 @@ (null? toplevels)) #f #t))))) -;; looks up subdb and returns it, if not found then set up -;; and then return it. -;; -#;(define (db:get-db dbstruct run-id) - (let* ((res (dbfile:get-subdb dbstruct run-id))) - (if res - res - (let* ((newsubdb (make-dbr:subdb))) - (dbfile:set-subdb dbstruct run-id newsubdb) - (db:open-db dbstruct run-id areapath: (dbr:dbstruct-areapath dbstruct) do-sync: #t) - newsubdb)))) - -;; Get/open a database -;; if run-id => get run specific db -;; if #f => get main db -;; if run-id is a string treat it as a filename -;; if db already open - return cachedb -;; if db not open, open cachedb, rundb and sync then return cachedb -;; inuse gets set automatically for rundb's -;; -;; (define db:get-db db:get-subdb) - -;; (define (db:get-db subdb #;dbstruct run-id) ;; RENAME TO db:get-dbh -;; ;; (let* ((subdb (dbfile:get-subdb dbstruct run-id))) -;; (if (stack? (dbr:subdb-dbstack subdb)) -;; (if (stack-empty? (dbr:subdb-dbstack subdb)) -;; (let* ((dbname (db:run-id->dbname run-id)) -;; (newdb (db:open-megatest-db path: (db:dbfile-path) -;; name: dbname))) -;; ;; NOTE: pushing on the stack only happens AFTER the handle has been used -;; ;; (stack-push! (dbr:dbstruct-dbstack dbstruct) newdb) -;; newdb) -;; (stack-pop! (dbr:subdb-dbstack subdb))) -;; (db:open-db subdb run-id))) ;; ) - - -#;(define (db:get-db dbstruct run-id) - (let* ((subdb (dbfile:get-subdb dbstruct run-id)) - (dbdat (dbfile:get-dbdat dbstruct run-id))) - (if (dbr:dbdat? dbdat) - dbdat - (dbfile:open-db *dbstruct-dbs* #f db:initialize-main-db) - ) - ) -) - (define-inline (db:generic-error-printout exn . message) (print-call-chain (current-error-port)) (apply debug:print-error 0 *default-log-port* message) (debug:print-error 0 *default-log-port* " params: " params ", error: " ((condition-property-accessor 'exn 'message) exn) @@ -1157,15 +1089,15 @@ ;; Open the classic megatest.db file (defaults to open in toppath) ;; ;; NOTE: returns a dbdat not a dbstruct! ;; -(define (db:open-megatest-db dbpath) +(define (db:open-megatest-db dbpath #!key (launch-setup #f)) (let* ((dbexists (file-exists? dbpath)) (db (db:lock-create-open dbpath (lambda (db) - (db:initialize-main-db db)))) + (db:initialize-main-db db launch-setup: launch-setup)))) (write-access (file-write-access? dbpath))) (debug:print-info 13 *default-log-port* "db:open-megatest-db "dbpath) (if (and dbexists (not write-access)) (set! *db-write-access* #f)) ;; (cons db dbpath))) @@ -1295,15 +1227,17 @@ (apply rmt-cmd params)) ;;) ;; return the target db handle so it can be used ;; -(define (db:cache-for-read-only source target #!key (use-last-update #f)) +(define (db:cache-for-read-only source target #!key (use-last-update #f)(launch-setup #f)) (if (and (hash-table-ref/default *global-db-store* target #f) (>= (file-modification-time target)(file-modification-time source))) (hash-table-ref *global-db-store* target) - (let* ((toppath (launch:setup)) + (let* ((toppath (if *toppath* + *toppath* + (launch-setup))) (targ-db-last-mod (db:get-sqlite3-mod-time target)) ;; (if (common:file-exists? target) ;; BUG: This needs to include wal mode stuff .shm etc. ;; (file-modification-time target) ;; 0)) @@ -1492,11 +1426,11 @@ (define (db:tmp->megatest.db-sync dbstruct run-id last-update) (let* ((subdbs (hash-table-values (dbr:dbstruct-subdbs dbstruct))) (res '())) (for-each (lambda (subdb) - (let* ((mtdb (dbr:subdb-mtdb subdb)) + (let* ((mtdb (dbr:subdb-mtdbdat subdb)) (tmpdb (db:get-subdb dbstruct run-id)) (refndb (dbr:subdb-refndb subdb)) (newres (db:sync-tables (db:sync-all-tables-list (db:get-keys dbstruct)) last-update tmpdb refndb mtdb))) ;; (stack-push! (dbr:subdb-dbstack subdb) tmpdb) ;; BUG: verify this is really needed @@ -1539,13 +1473,15 @@ (debug:print-info 0 *default-log-port* "Sync of " res " records from newdb to olddb completed in " sync-time " seconds pid="(current-process-id)) (debug:print-info 0 *default-log-port* "No sync needed, last updated " (- start-time last-update) " seconds ago"))) res)) -(define (db:initialize-main-db db) +(define (db:initialize-main-db db #!key (launch-setup #f)) (when (not *configinfo*) - (launch:setup)) ;; added because Elena was getting stack dump because *configinfo* below was #f. + (if launch-setup + (launch-setup) ;; added because Elena was getting stack dump because *configinfo* below was #f. + (assert #f "db:initialize-main-db called and needs launch:setup but was not given it"))) (let* ((configdat (car *configinfo*)) ;; tut tut, global warning... (keys (keys:config-get-fields configdat)) (havekeys (> (length keys) 0)) (keystr (keys->keystr keys)) (fieldstr (keys:make-key/field-string configdat)) @@ -2212,30 +2148,10 @@ db (conc "SELECT " key " FROM runs WHERE id=?;") run-id) res)))) -;; keys list to key1,key2,key3 ... -(define (runs:get-std-run-fields keys remfields) - (let* ((header (append keys remfields)) - (keystr (conc (keys->keystr keys) "," - (string-intersperse remfields ",")))) - (list keystr header))) - -;; make a query (fieldname like 'patt1' OR fieldname -(define (db:patt->like fieldname pattstr #!key (comparator " OR ")) - (let ((patts (if (string? pattstr) - (string-split pattstr ",") - '("%")))) - (string-intersperse (map (lambda (patt) - (let ((wildtype (if (substring-index "%" patt) "LIKE" "GLOB"))) - (conc fieldname " " wildtype " '" patt "'"))) - (if (null? patts) - '("") - patts)) - comparator))) - ;; register a test run with the db, this accesses the main.db and does NOT ;; use server api ;; (define (db:register-run dbstruct keyvals runname state status user contour-in) @@ -2292,11 +2208,11 @@ (qrystr (conc "INSERT INTO runs (id,runname,"keystr") VALUES (?,?,"key?str")")) (get-var (lambda (db qrystr) (let* ((res #f)) (sqlite3:for-each-row (lambda row - (set res (car row))) + (set! res (car row))) db qrystr run-id runname) res)))) (if (null? runs) (begin (db:create-initial-run-record dbstruct run-id runname target) @@ -3794,10 +3710,14 @@ ;; foo,alb, 1.2, 1.2, <= , Amps,This is the high power circuit test ;; foo,abl, 1.2, 1.3, 0.1 ;; foo,bra, 1.2, pass, silly stuff ;; faz,bar, 10, 8mA, , ,"this is a comment" ;; EOF + +(define (tdb:get-prev-tol-for-test tdb test-id category variable) + ;; Finish me? + (values #f #f #f)) (define (db:csv->test-data dbstruct run-id test-id csvdata) (debug:print 4 *default-log-port* "test-id " test-id ", csvdata: " csvdata) (db:with-db dbstruct #f #t @@ -4998,177 +4918,46 @@ (lambda (dbdat db) (sqlite3:fold-row backcons '() db "SELECT id FROM runs"))))) all_run_ids)) -;;====================================================================== -;; Extract ods file from the db -;;====================================================================== - -;; NOT REWRITTEN YET!!!!! - -;; runspatt is a comma delimited list of run patterns -;; keypatt-alist must contain *all* keys with an associated pattern: '( ("KEY1" "%") .. ) -(define (db:extract-ods-file dbstruct outputfile keypatt-alist runspatt pathmod) - (assert #f "FATAL: call to db:extract-ods-file which is not ported yet.") - (let* ((keysstr (string-intersperse (map car keypatt-alist) ",")) - (keyqry (string-intersperse (map (lambda (p)(conc (car p) " LIKE ? ")) keypatt-alist) " AND ")) - (numkeys (length keypatt-alist)) - (test-ids '()) - (dbdat (db:get-subdb dbstruct)) - (db (dbr:dbdat-dbh dbdat)) - (windows (and pathmod (substring-index "\\" pathmod))) - (tempdir (conc "/tmp/" (current-user-name) "/" runspatt "_" (random 10000) "_" (current-process-id))) - (runsheader (append (list "Run Id" "Runname") ; 0 1 - (map car keypatt-alist) ; + N = length keypatt-alist - (list "Testname" ; 2 - "Item Path" ; 3 - "Description" ; 4 - "State" ; 5 - "Status" ; 6 - "Final Log" ; 7 - "Run Duration" ; 8 - "When Run" ; 9 - "Tags" ; 10 - "Run Owner" ; 11 - "Comment" ; 12 - "Author" ; 13 - "Test Owner" ; 14 - "Reviewed" ; 15 - "Diskfree" ; 16 - "Uname" ; 17 - "Rundir" ; 18 - "Host" ; 19 - "Cpu Load" ; 20 - ))) - (results (list runsheader)) - (testdata-header (list "Run Id" "Testname" "Item Path" "Category" "Variable" "Value" "Expected" "Tol" "Units" "Status" "Comment")) - (mainqry (conc "SELECT - t.testname,r.id,runname," keysstr ",t.testname, - t.item_path,tm.description,t.state,t.status, - final_logf,run_duration, - strftime('%m/%d/%Y %H:%M:%S',datetime(t.event_time,'unixepoch'),'localtime'), - tm.tags,r.owner,t.comment, - author, - tm.owner,reviewed, - diskfree,uname,rundir, - host,cpuload - FROM tests AS t JOIN runs AS r ON t.run_id=r.id JOIN test_meta AS tm ON tm.testname=t.testname - WHERE runname LIKE ? AND " keyqry ";"))) - (debug:print 2 *default-log-port* "Using " tempdir " for constructing the ods file. keyqry: " keyqry " keystr: " keysstr " with keys: " (map cadr keypatt-alist) - "\n mainqry: " mainqry) - ;; "Expected Value" - ;; "Value Found" - ;; "Tolerance" - (apply sqlite3:for-each-row - (lambda (test-id . b) - (set! test-ids (cons test-id test-ids)) ;; test-id is now testname - (set! results (append results ;; note, drop the test-id - (list - (if pathmod - (let* ((vb (apply vector b)) - (keyvals (let loop ((i 0) - (res '())) - (if (>= i numkeys) - res - (loop (+ i 1) - (append res (list (vector-ref vb (+ i 2)))))))) - (runname (vector-ref vb 1)) - (testname (vector-ref vb (+ 2 numkeys))) - (item-path (vector-ref vb (+ 3 numkeys))) - (final-log (vector-ref vb (+ 7 numkeys))) - (run-dir (vector-ref vb (+ 18 numkeys))) - (log-fpath (conc run-dir "/" final-log))) ;; (string-intersperse keyvals "/") "/" testname "/" item-path "/" - (debug:print 4 *default-log-port* "log: " log-fpath " exists: " (common:file-exists? log-fpath)) - (vector-set! vb (+ 7 numkeys) (if (common:file-exists? log-fpath) - (let ((newpath (conc pathmod "/" - (string-intersperse keyvals "/") - "/" runname "/" testname "/" - (if (string=? item-path "") "" (conc "/" item-path)) - final-log))) - ;; for now throw away newpath and use the log-fpath conc'd with pathmod - (set! newpath (conc pathmod log-fpath)) - (if windows (string-translate newpath "/" "\\") newpath)) - (if (debug:debug-mode 1) - (conc final-log " not-found") - ""))) - (vector->list vb)) - b))))) - db - mainqry - runspatt (map cadr keypatt-alist)) - (debug:print 2 *default-log-port* "Found " (length test-ids) " records") - (set! results (list (cons "Runs" results))) - ;; now, for each test, collect the test_data info and add a new sheet - (for-each - (lambda (test-id) - (let ((test-data (list testdata-header)) - (curr-test-name #f)) - (sqlite3:for-each-row - (lambda (run-id testname item-path category variable value expected tol units status comment) - (set! curr-test-name testname) - (set! test-data (append test-data (list (list run-id testname item-path category variable value expected tol units status comment))))) - db - ;; "SELECT run_id,testname,item_path,category,variable,td.value AS value,expected,tol,units,td.status AS status,td.comment AS comment FROM test_data AS td INNER JOIN tests ON tests.id=td.test_id WHERE test_id=?;" - "SELECT run_id,testname,item_path,category,variable,td.value AS value,td.expected,td.tol,td.units,td.status AS status,td.comment AS comment FROM test_data AS td INNER JOIN tests ON tests.id=td.test_id WHERE testname=?;" - test-id) - (if curr-test-name - (set! results (append results (list (cons curr-test-name test-data))))) - )) - (sort (delete-duplicates test-ids) string<=)) - (system (conc "mkdir -p " tempdir)) - ;; (pp results) - (ods:list->ods - tempdir - (if (string-match (regexp "^[/~]+.*") outputfile) ;; full path? - outputfile - (begin - (debug:print 0 *default-log-port* "WARNING: path given, " outputfile " is relative, prefixing with current directory") - (conc (current-directory) "/" outputfile))) - results) - ;; brutal clean up - (dbfile:add-dbdat dbstruct #f dbdat) - (system "rm -rf tempdir"))) - -;; (db:extract-ods-file db "outputfile.ods" '(("sysname" "%")("fsname" "%")("datapath" "%")) "%") - ;;====================================================================== ;; moving watch dogs here due to dependencies ;;====================================================================== -;;====================================================================== -;; currently the primary job of the watchdog is to run the sync back to megatest.db from the db in /tmp -;; if we are on the homehost and we are a server (by definition we are on the homehost if we are a server) -;; -(define (common:readonly-watchdog dbstruct) - (thread-sleep! 0.05) ;; delay for startup - (debug:print-info 13 *default-log-port* "common:readonly-watchdog entered.") - ;; sync megatest.db to /tmp/.../megatst.db - (let* ((sync-cool-off-duration 3) - (golden-mtdb (dbr:dbstruct-mtdb dbstruct)) - (golden-mtpath (db:dbdat-get-path golden-mtdb)) - (tmp-mtdb (dbr:dbstruct-tmpdb dbstruct)) - (tmp-mtpath (db:dbdat-get-path tmp-mtdb))) - (debug:print-info 0 *default-log-port* "Read-only periodic sync thread started.") - (let loop ((last-sync-time 0)) - (debug:print-info 13 *default-log-port* "loop top tmp-mtpath="tmp-mtpath" golden-mtpath="golden-mtpath) - (let* ((duration-since-last-sync (- (current-seconds) last-sync-time))) - (debug:print-info 13 *default-log-port* "duration-since-last-sync="duration-since-last-sync) - (if (and (not *time-to-exit*) - (< duration-since-last-sync sync-cool-off-duration)) - (thread-sleep! (- sync-cool-off-duration duration-since-last-sync))) - (if (not *time-to-exit*) - (let ((golden-mtdb-mtime (file-modification-time golden-mtpath)) - (tmp-mtdb-mtime (file-modification-time tmp-mtpath))) - (if (> golden-mtdb-mtime tmp-mtdb-mtime) - (if (< golden-mtdb-mtime (- (current-seconds) 3)) ;; file has NOT been touched in past three seconds, this way multiple servers won't fight to sync back - (let ((res (db:multi-db-sync dbstruct 'old2new))) - (debug:print-info 13 *default-log-port* "rosync called, " res " records transferred.")))) - (loop (current-seconds))) - #t))) - (debug:print-info 0 *default-log-port* "Exiting readonly-watchdog timer, *time-to-exit* = " *time-to-exit*" pid="(current-process-id)" mtpath="golden-mtpath))) - +;; =not-used= ;;====================================================================== +;; =not-used= ;; currently the primary job of the watchdog is to run the sync back to megatest.db from the db in /tmp +;; =not-used= ;; if we are on the homehost and we are a server (by definition we are on the homehost if we are a server) +;; =not-used= ;; +;; =not-used= (define (common:readonly-watchdog dbstruct) +;; =not-used= (thread-sleep! 0.05) ;; delay for startup +;; =not-used= (debug:print-info 13 *default-log-port* "common:readonly-watchdog entered.") +;; =not-used= ;; sync megatest.db to /tmp/.../megatst.db +;; =not-used= (let* ((sync-cool-off-duration 3) +;; =not-used= (golden-mtdb (dbr:dbstruct-mtdb dbstruct)) +;; =not-used= (golden-mtpath (db:dbdat-get-path golden-mtdb)) +;; =not-used= (tmp-mtdb (dbr:dbstruct-tmpdb dbstruct)) +;; =not-used= (tmp-mtpath (db:dbdat-get-path tmp-mtdb))) +;; =not-used= (debug:print-info 0 *default-log-port* "Read-only periodic sync thread started.") +;; =not-used= (let loop ((last-sync-time 0)) +;; =not-used= (debug:print-info 13 *default-log-port* "loop top tmp-mtpath="tmp-mtpath" golden-mtpath="golden-mtpath) +;; =not-used= (let* ((duration-since-last-sync (- (current-seconds) last-sync-time))) +;; =not-used= (debug:print-info 13 *default-log-port* "duration-since-last-sync="duration-since-last-sync) +;; =not-used= (if (and (not *time-to-exit*) +;; =not-used= (< duration-since-last-sync sync-cool-off-duration)) +;; =not-used= (thread-sleep! (- sync-cool-off-duration duration-since-last-sync))) +;; =not-used= (if (not *time-to-exit*) +;; =not-used= (let ((golden-mtdb-mtime (file-modification-time golden-mtpath)) +;; =not-used= (tmp-mtdb-mtime (file-modification-time tmp-mtpath))) +;; =not-used= (if (> golden-mtdb-mtime tmp-mtdb-mtime) +;; =not-used= (if (< golden-mtdb-mtime (- (current-seconds) 3)) ;; file has NOT been touched in past three seconds, this way multiple servers won't fight to sync back +;; =not-used= (let ((res (db:multi-db-sync dbstruct 'old2new))) +;; =not-used= (debug:print-info 13 *default-log-port* "rosync called, " res " records transferred.")))) +;; =not-used= (loop (current-seconds))) +;; =not-used= #t))) +;; =not-used= (debug:print-info 0 *default-log-port* "Exiting readonly-watchdog timer, *time-to-exit* = " *time-to-exit*" pid="(current-process-id)" mtpath="golden-mtpath))) +;; =not-used= ;; Get a lock from the no-sync-db for the from-db, then copy the from-db to the to-db, otherwise return #f (define (db:lock-and-sync no-sync-db from-db to-db) (assert (not *db-sync-in-progress*) "FATAL: db:lock-and-sync called while a sync is in progress.") @@ -5225,183 +5014,184 @@ (hash-table-set! sync-durations (conc fname".db") (- (current-milliseconds) start-time))) #;(debug:print-info 0 *default-log-port* "skipping sync...")))) dbfiles) (hash-table->alist sync-durations))) -;; straight forward copy based sync -;; 1. for each .db fil -;; 2. next if file changed since last sync cycle -;; 2. next if time delta /tmp file to MTRA less than 3 seconds -;; 3. get a lock for the file in nosyncdb -;; 4. copy the file -;; 5. when copy is done release the lock -;; -;; DONE -(define (server:writable-watchdog-copysync dbstruct) - (thread-sleep! 0.05) ;; delay for startup - (let ((legacy-sync (common:run-sync?)) - (sync-stale-seconds (configf:lookup-number *configdat* "server" "sync-stale-seconds" default: 300)) - (debug-mode (debug:debug-mode 1)) - (last-time (current-seconds)) ;; last time through the sync loop - (no-sync-db (db:open-no-sync-db)) - (sync-duration 0) ;; run time of the sync in milliseconds - (tmp-area (common:make-tmpdir-name *toppath* ""))) - ;; Sync moved to http-transport keep-running loop - (debug:print-info 2 *default-log-port* "Periodic copy-based sync thread started. syncer is copy-sync, tmp-area is " tmp-area) - (debug:print-info 3 *default-log-port* "watchdog starting. syncer is copy-sync pid="(current-process-id));; " this-wd-num="this-wd-num) - - (if (and legacy-sync (not *time-to-exit*)) - (begin - (debug:print-info 0 *default-log-port* "Server running, periodic copy-based sync started.") - (let loop () - - ;; run the sync and print out durations - (debug:print-info 0 *default-log-port* "Sync durations: "(db:run-lock-and-sync no-sync-db)) - ;; keep going unless time to exit - ;; - (if (not *time-to-exit*) - (let delay-loop ((count 0)) - ;;(debug:print-info 13 *default-log-port* "delay-loop top; count="count" pid="(current-process-id)" this-wd-num="this-wd-num" *time-to-exit*="*time-to-exit*) - - (if (and (not *time-to-exit*) - (< count 6)) ;; was 11, changing to 4. - (begin - (thread-sleep! 1) - (delay-loop (+ count 1)))) - (if (not *time-to-exit*) (loop)))) - - ;; ==> ;; time to exit, close the no-sync db here - ;; ==> (db:no-sync-close-db no-sync-db stmt-cache) - (if (common:low-noise-print 30) - (debug:print-info 0 *default-log-port* "Exiting watchdog timer, *time-to-exit* = " - *time-to-exit*" pid="(current-process-id) ))))))) - - -(define (server:writable-watchdog-deltasync dbstruct) - ;; This is awful complex and convoluted. Plan to redo? - ;; for now ... skip it. - - (thread-sleep! 0.05) ;; delay for startup - (let ((legacy-sync (common:run-sync?))) - (sync-stale-seconds (configf:lookup-number *configdat* "server" "sync-stale-seconds" default: 300)) - (debug-mode (debug:debug-mode 1)) - (last-time (current-seconds)) - (no-sync-db (db:open-no-sync-db)) - (stmt-cache #f) ;; (dbr:dbstruct-stmt-cache dbstruct)) - (sync-duration 0) ;; run time of the sync in milliseconds - (subdbs (hash-table-values (dbr:dbstruct-subdbs dbstruct)))) - (debug:print-info 2 *default-log-port* "Periodic sync thread started.") - (debug:print-info 3 *default-log-port* "watchdog starting. legacy-sync is " legacy-sync" pid="(current-process-id) );; " this-wd-num="this-wd-num) - - (if (and legacy-sync (not *time-to-exit*)) - (begin - (debug:print-info 0 *default-log-port* "Server running, periodic sync started.") - (let loop () - ;; sync for filesystem local db writes - ;; - (mutex-lock! *db-multi-sync-mutex*) - (let* ((start-file (conc tmp-area "/.start-sync")) - (end-file (conc tmp-area "/.end-sync")) - - (need-sync (>= *db-last-access* *db-last-sync*)) ;; no sync since last write - (sync-in-progress *db-sync-in-progress*) - (min-intersync-delay (configf:lookup-number *configdat* "server" "minimum-intersync-delay" default: 5)) - (should-sync (and (not *time-to-exit*) - (> (- (current-seconds) *db-last-sync*) min-intersync-delay))) ;; sync every five seconds minimum, deprecated logic, can probably be removed - (start-time (current-seconds)) - (cpu-load-adj (alist-ref 'adj-proc-load (common:get-normalized-cpu-load #f))) - (mt-mod-time (file-modification-time mtpath)) - (last-sync-start (if (common:file-exists? start-file) - (file-modification-time start-file) - 0)) - (last-sync-end (if (common:file-exists? end-file) - (file-modification-time end-file) - 10)) - (sync-period (+ 3 (* cpu-load-adj 30))) ;; as adjusted load increases increase the sync period - (recently-synced (and (< (- start-time mt-mod-time) sync-period) ;; not useful if sync didn't modify megatest.db! - (< mt-mod-time last-sync-start))) - (sync-done (<= last-sync-start last-sync-end)) - (sync-stale (> start-time (+ last-sync-start sync-stale-seconds))) - (will-sync (and (not *time-to-exit*) ;; do not start a sync if we are in the process of exiting - (or need-sync should-sync) - (or sync-done sync-stale) - (not sync-in-progress) - (not recently-synced)))) - (debug:print-info 13 *default-log-port* "WD writable-watchdog top of loop. need-sync="need-sync" sync-in-progress=" sync-in-progress - " should-sync="should-sync" start-time="start-time" mt-mod-time="mt-mod-time" recently-synced="recently-synced" will-sync="will-sync - " sync-done=" sync-done " sync-period=" sync-period) - (if (and (> sync-period 5) - (common:low-noise-print 30 "sync-period")) - (debug:print-info 0 *default-log-port* "Increased sync period due to long sync times, sync took: " sync-period " seconds.")) - ;; (if recently-synced (debug:print-info 0 *default-log-port* "Skipping sync due to recently-synced flag=" recently-synced)) - ;; (debug:print-info 0 *default-log-port* "need-sync: " need-sync " sync-in-progress: " sync-in-progress " should-sync: " should-sync " will-sync: " will-sync) - (if will-sync (set! *db-sync-in-progress* #t)) - (mutex-unlock! *db-multi-sync-mutex*) - (if will-sync - (let (;; (max-sync-duration (configf:lookup-number *configdat* "server" "max-sync-duration")) ;; KEEPING THIS AVAILABLE BUT SHOULD NOT USE, I'M PRETTY SURE IT DOES NOT WORK! - (sync-start (current-milliseconds))) - (with-output-to-file start-file (lambda ()(print (current-process-id)))) - - ;; put lock here - - ;; (if (or (not max-sync-duration) - ;; (< sync-duration max-sync-duration)) ;; NOTE: db:sync-to-megatest.db keeps track of time of last sync and syncs incrementally - - ;; - - (for-each - (lambda (subdb) - (let* (;;(dbstruct (db:setup)) - (mtdb (dbr:subdb-mtdb subdb)) - (mtpath (db:dbdat-get-path mtdb)) - (tmp-area (common:make-tmpdir-name *toppath* "")) - (res (db:sync-to-megatest.db dbstruct no-sync-db: no-sync-db))) ;; did we sync any data? If so need to set the db touched flag to keep the server alive - (set! sync-duration (- (current-milliseconds) sync-start)) - (if (> res 0) ;; some records were transferred, keep the db alive - (begin - (mutex-lock! *heartbeat-mutex*) - (set! *db-last-access* (current-seconds)) - (mutex-unlock! *heartbeat-mutex*) - (debug:print-info 0 *default-log-port* "sync called, " res " records transferred.")) - (debug:print-info 2 *default-log-port* "sync called but zero records transferred"))) - ) - subdbs))) - - (if will-sync - (begin - (mutex-lock! *db-multi-sync-mutex*) - (set! *db-sync-in-progress* #f) - (set! *db-last-sync* start-time) - (with-output-to-file end-file (lambda ()(print (current-process-id)))) - - ;; release lock here - - (mutex-unlock! *db-multi-sync-mutex*))) - (if (and debug-mode - (> (- start-time last-time) 60)) - (begin - (set! last-time start-time) - (debug:print-info 4 *default-log-port* "timestamp -> " (seconds->time-string (current-seconds)) ", time since start -> " (seconds->hr-min-sec (- (current-seconds) *time-zero*)))))) - - ;; keep going unless time to exit - ;; - (if (not *time-to-exit*) - (let delay-loop ((count 0)) - ;;(debug:print-info 13 *default-log-port* "delay-loop top; count="count" pid="(current-process-id)" this-wd-num="this-wd-num" *time-to-exit*="*time-to-exit*) - - (if (and (not *time-to-exit*) - (< count 6)) ;; was 11, changing to 4. - (begin - (thread-sleep! 1) - (delay-loop (+ count 1)))) - (if (not *time-to-exit*) (loop)))) - -;; ;; time to exit, close the no-sync db here -;; (db:no-sync-close-db no-sync-db stmt-cache) - (if (common:low-noise-print 30) - (debug:print-info 0 *default-log-port* "Exiting watchdog timer, *time-to-exit* = " *time-to-exit*" pid="(current-process-id) )))) -)) +;; =not-used= ;; straight forward copy based sync +;; =not-used= ;; 1. for each .db fil +;; =not-used= ;; 2. next if file changed since last sync cycle +;; =not-used= ;; 2. next if time delta /tmp file to MTRA less than 3 seconds +;; =not-used= ;; 3. get a lock for the file in nosyncdb +;; =not-used= ;; 4. copy the file +;; =not-used= ;; 5. when copy is done release the lock +;; =not-used= ;; +;; =not-used= ;; DONE +;; =not-used= (define (server:writable-watchdog-copysync dbstruct) +;; =not-used= (thread-sleep! 0.05) ;; delay for startup +;; =not-used= (let ((legacy-sync (common:run-sync?)) +;; =not-used= (sync-stale-seconds (configf:lookup-number *configdat* "server" "sync-stale-seconds" default: 300)) +;; =not-used= (debug-mode (debug:debug-mode 1)) +;; =not-used= (last-time (current-seconds)) ;; last time through the sync loop +;; =not-used= (no-sync-db (db:open-no-sync-db)) +;; =not-used= (sync-duration 0) ;; run time of the sync in milliseconds +;; =not-used= (tmp-area (common:make-tmpdir-name *toppath* ""))) +;; =not-used= ;; Sync moved to http-transport keep-running loop +;; =not-used= (debug:print-info 2 *default-log-port* "Periodic copy-based sync thread started. syncer is copy-sync, tmp-area is " tmp-area) +;; =not-used= (debug:print-info 3 *default-log-port* "watchdog starting. syncer is copy-sync pid="(current-process-id));; " this-wd-num="this-wd-num) +;; =not-used= +;; =not-used= (if (and legacy-sync (not *time-to-exit*)) +;; =not-used= (begin +;; =not-used= (debug:print-info 0 *default-log-port* "Server running, periodic copy-based sync started.") +;; =not-used= (let loop () +;; =not-used= +;; =not-used= ;; run the sync and print out durations +;; =not-used= (debug:print-info 0 *default-log-port* "Sync durations: "(db:run-lock-and-sync no-sync-db)) +;; =not-used= ;; keep going unless time to exit +;; =not-used= ;; +;; =not-used= (if (not *time-to-exit*) +;; =not-used= (let delay-loop ((count 0)) +;; =not-used= ;;(debug:print-info 13 *default-log-port* "delay-loop top; count="count" pid="(current-process-id)" this-wd-num="this-wd-num" *time-to-exit*="*time-to-exit*) +;; =not-used= +;; =not-used= (if (and (not *time-to-exit*) +;; =not-used= (< count 6)) ;; was 11, changing to 4. +;; =not-used= (begin +;; =not-used= (thread-sleep! 1) +;; =not-used= (delay-loop (+ count 1)))) +;; =not-used= (if (not *time-to-exit*) (loop)))) +;; =not-used= +;; =not-used= ;; ==> ;; time to exit, close the no-sync db here +;; =not-used= ;; ==> (db:no-sync-close-db no-sync-db stmt-cache) +;; =not-used= (if (common:low-noise-print 30) +;; =not-used= (debug:print-info 0 *default-log-port* "Exiting watchdog timer, *time-to-exit* = " +;; =not-used= *time-to-exit*" pid="(current-process-id) ))))))) + + +;; =not-used= (define (server:writable-watchdog-deltasync dbstruct) +;; =not-used= ;; This is awful complex and convoluted. Plan to redo? +;; =not-used= ;; for now ... skip it. +;; =not-used= +;; =not-used= (thread-sleep! 0.05) ;; delay for startup +;; =not-used= (let ((legacy-sync (common:run-sync?))) +;; =not-used= (sync-stale-seconds (configf:lookup-number *configdat* "server" "sync-stale-seconds" default: 300)) +;; =not-used= (debug-mode (debug:debug-mode 1)) +;; =not-used= (last-time (current-seconds)) +;; =not-used= (no-sync-db (db:open-no-sync-db)) +;; =not-used= (stmt-cache #f) ;; (dbr:dbstruct-stmt-cache dbstruct)) +;; =not-used= (sync-duration 0) ;; run time of the sync in milliseconds +;; =not-used= (subdbs (hash-table-values (dbr:dbstruct-subdbs dbstruct)))) +;; =not-used= (debug:print-info 2 *default-log-port* "Periodic sync thread started.") +;; =not-used= (debug:print-info 3 *default-log-port* "watchdog starting. legacy-sync is " legacy-sync" pid="(current-process-id) );; " this-wd-num="this-wd-num) +;; =not-used= +;; =not-used= (if (and legacy-sync (not *time-to-exit*)) +;; =not-used= (begin +;; =not-used= (debug:print-info 0 *default-log-port* "Server running, periodic sync started.") +;; =not-used= (let loop () +;; =not-used= ;; sync for filesystem local db writes +;; =not-used= ;; +;; =not-used= (mutex-lock! *db-multi-sync-mutex*) +;; =not-used= (let* ((start-file (conc tmp-area "/.start-sync")) +;; =not-used= (end-file (conc tmp-area "/.end-sync")) +;; =not-used= +;; =not-used= (need-sync (>= *db-last-access* *db-last-sync*)) ;; no sync since last write +;; =not-used= (sync-in-progress *db-sync-in-progress*) +;; =not-used= (min-intersync-delay (configf:lookup-number *configdat* "server" "minimum-intersync-delay" default: 5)) +;; =not-used= (should-sync (and (not *time-to-exit*) +;; =not-used= (> (- (current-seconds) *db-last-sync*) min-intersync-delay))) ;; sync every five seconds minimum, deprecated logic, can probably be removed +;; =not-used= (start-time (current-seconds)) +;; =not-used= (cpu-load-adj (alist-ref 'adj-proc-load (common:get-normalized-cpu-load #f))) +;; =not-used= (mt-mod-time (file-modification-time mtpath)) +;; =not-used= (last-sync-start (if (common:file-exists? start-file) +;; =not-used= (file-modification-time start-file) +;; =not-used= 0)) +;; =not-used= (last-sync-end (if (common:file-exists? end-file) +;; =not-used= (file-modification-time end-file) +;; =not-used= 10)) +;; =not-used= (sync-period (+ 3 (* cpu-load-adj 30))) ;; as adjusted load increases increase the sync period +;; =not-used= (recently-synced (and (< (- start-time mt-mod-time) sync-period) ;; not useful if sync didn't modify megatest.db! +;; =not-used= (< mt-mod-time last-sync-start))) +;; =not-used= (sync-done (<= last-sync-start last-sync-end)) +;; =not-used= (sync-stale (> start-time (+ last-sync-start sync-stale-seconds))) +;; =not-used= (will-sync (and (not *time-to-exit*) ;; do not start a sync if we are in the process of exiting +;; =not-used= (or need-sync should-sync) +;; =not-used= (or sync-done sync-stale) +;; =not-used= (not sync-in-progress) +;; =not-used= (not recently-synced)))) +;; =not-used= (debug:print-info 13 *default-log-port* "WD writable-watchdog top of loop. need-sync="need-sync" sync-in-progress=" sync-in-progress +;; =not-used= " should-sync="should-sync" start-time="start-time" mt-mod-time="mt-mod-time" recently-synced="recently-synced" will-sync="will-sync +;; =not-used= " sync-done=" sync-done " sync-period=" sync-period) +;; =not-used= (if (and (> sync-period 5) +;; =not-used= (common:low-noise-print 30 "sync-period")) +;; =not-used= (debug:print-info 0 *default-log-port* "Increased sync period due to long sync times, sync took: " sync-period " seconds.")) +;; =not-used= ;; (if recently-synced (debug:print-info 0 *default-log-port* "Skipping sync due to recently-synced flag=" recently-synced)) +;; =not-used= ;; (debug:print-info 0 *default-log-port* "need-sync: " need-sync " sync-in-progress: " sync-in-progress " should-sync: " should-sync " will-sync: " will-sync) +;; =not-used= (if will-sync (set! *db-sync-in-progress* #t)) +;; =not-used= (mutex-unlock! *db-multi-sync-mutex*) +;; =not-used= (if will-sync +;; =not-used= (let (;; (max-sync-duration (configf:lookup-number *configdat* "server" "max-sync-duration")) ;; KEEPING THIS AVAILABLE BUT SHOULD NOT USE, I'M PRETTY SURE IT DOES NOT WORK! +;; =not-used= (sync-start (current-milliseconds))) +;; =not-used= (with-output-to-file start-file (lambda ()(print (current-process-id)))) +;; =not-used= +;; =not-used= ;; put lock here +;; =not-used= +;; =not-used= ;; (if (or (not max-sync-duration) +;; =not-used= ;; (< sync-duration max-sync-duration)) ;; NOTE: db:sync-to-megatest.db keeps track of time of last sync and syncs incrementally +;; =not-used= +;; =not-used= ;; +;; =not-used= +;; =not-used= (for-each +;; =not-used= (lambda (subdb) +;; =not-used= (let* (;;(dbstruct (db:setup)) +;; =not-used= (mtdb (dbr:subdb-mtdbdat subdb)) +;; =not-used= (mtdb (dbr:subdb-mtdbdat subdb)) +;; =not-used= (mtpath (db:dbdat-get-path mtdb)) +;; =not-used= (tmp-area (common:make-tmpdir-name *toppath* "")) +;; =not-used= (res (db:sync-to-megatest.db dbstruct no-sync-db: no-sync-db))) ;; did we sync any data? If so need to set the db touched flag to keep the server alive +;; =not-used= (set! sync-duration (- (current-milliseconds) sync-start)) +;; =not-used= (if (> res 0) ;; some records were transferred, keep the db alive +;; =not-used= (begin +;; =not-used= (mutex-lock! *heartbeat-mutex*) +;; =not-used= (set! *db-last-access* (current-seconds)) +;; =not-used= (mutex-unlock! *heartbeat-mutex*) +;; =not-used= (debug:print-info 0 *default-log-port* "sync called, " res " records transferred.")) +;; =not-used= (debug:print-info 2 *default-log-port* "sync called but zero records transferred"))) +;; =not-used= ) +;; =not-used= subdbs))) +;; =not-used= +;; =not-used= (if will-sync +;; =not-used= (begin +;; =not-used= (mutex-lock! *db-multi-sync-mutex*) +;; =not-used= (set! *db-sync-in-progress* #f) +;; =not-used= (set! *db-last-sync* start-time) +;; =not-used= (with-output-to-file end-file (lambda ()(print (current-process-id)))) +;; =not-used= +;; =not-used= ;; release lock here +;; =not-used= +;; =not-used= (mutex-unlock! *db-multi-sync-mutex*))) +;; =not-used= (if (and debug-mode +;; =not-used= (> (- start-time last-time) 60)) +;; =not-used= (begin +;; =not-used= (set! last-time start-time) +;; =not-used= (debug:print-info 4 *default-log-port* "timestamp -> " (seconds->time-string (current-seconds)) ", time since start -> " (seconds->hr-min-sec (- (current-seconds) *time-zero*)))))) +;; =not-used= +;; =not-used= ;; keep going unless time to exit +;; =not-used= ;; +;; =not-used= (if (not *time-to-exit*) +;; =not-used= (let delay-loop ((count 0)) +;; =not-used= ;;(debug:print-info 13 *default-log-port* "delay-loop top; count="count" pid="(current-process-id)" this-wd-num="this-wd-num" *time-to-exit*="*time-to-exit*) +;; =not-used= +;; =not-used= (if (and (not *time-to-exit*) +;; =not-used= (< count 6)) ;; was 11, changing to 4. +;; =not-used= (begin +;; =not-used= (thread-sleep! 1) +;; =not-used= (delay-loop (+ count 1)))) +;; =not-used= (if (not *time-to-exit*) (loop)))) +;; =not-used= +;; =not-used= ;; ;; time to exit, close the no-sync db here +;; =not-used= ;; (db:no-sync-close-db no-sync-db stmt-cache) +;; =not-used= (if (common:low-noise-print 30) +;; =not-used= (debug:print-info 0 *default-log-port* "Exiting watchdog timer, *time-to-exit* = " *time-to-exit*" pid="(current-process-id) )))) +;; =not-used= )) (define (std-exit-procedure) ;;(common:telemetry-log-close) (on-exit (lambda () 0)) ;; why is this here? ;;(debug:print-info 13 *default-log-port* "std-exit-procedure called; *time-to-exit*="*time-to-exit*) @@ -5435,11 +5225,13 @@ (if (and (not (args:get-arg "-server")) *runremote* (eq? (rmt:transport-mode) 'http)) (begin (debug:print-info 0 *default-log-port* "Closing all client connections...") - (http-transport:close-connections *runremote*) + + ;; (http-transport:close-connections *runremote*) ;; <== no definition for this + #;(http-client#close-all-connections!))) ;; (if (and *runremote* ;; (remote-conndat *runremote*)) ;; (begin ;; (http-client#close-all-connections!))) ;; for http-client @@ -5462,6 +5254,87 @@ ) ) 0) +;; open an sql database inside a file lock +;; returns: db existed-prior-to-opening +;; RA => Returns a db handler; sets the lock if opened in writable mode +;; +;; (define *db-open-mutex* (make-mutex)) +;; +(define (db:lock-create-open fname initproc) + (let* ((parent-dir (or (pathname-directory fname)(current-directory))) ;; no parent? go local + (raw-fname (pathname-file fname)) + (dir-writable (file-write-access? parent-dir)) + (file-exists (common:file-exists? fname)) + (file-write (if file-exists + (file-write-access? fname) + dir-writable ))) + ;; (mutex-lock! *db-open-mutex*) ;; tried this mutex, not clear it helped. + (if file-write ;; dir-writable + (condition-case + (let* ((lockfname (conc fname ".lock")) + (readyfname (conc parent-dir "/.ready-" raw-fname)) + (readyexists (common:file-exists? readyfname))) + (if (not readyexists) + (common:simple-file-lock-and-wait lockfname)) + (let ((db (sqlite3:open-database fname))) + (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 136000)) + (sqlite3:execute db "PRAGMA synchronous = 0;") + (if (and (configf:lookup *configdat* "setup" "tmp_mode") (string-match "^/tmp/.*" fname)) + (begin + ;;(print "DEBUG: Setting tmp_mode for " fname) + (sqlite3:execute db (configf:lookup *configdat* "setup" "tmp_mode")) + ) + ) + (if (and (configf:lookup *configdat* "setup" "nfs_mode") (not (string-match "^/tmp/.*" fname))) + (begin + ;;(print "DEBUG: Setting nfs_mode for " fname) + (sqlite3:execute db (configf:lookup *configdat* "setup" "nfs_mode")) + ) + ) + (if (and (not (or (configf:lookup *configdat* "setup" "tmp_mode") (configf:lookup *configdat* "setup" "nfs_mode"))) + (configf:lookup *configdat* "setup" "use-wal") + (string-match "^/tmp/.*" fname)) ;; this is a file in /tmp + (sqlite3:execute db "PRAGMA journal_mode=WAL;") + (debug:print 2 *default-log-port* "Creating " fname " in NON-WAL mode.")) + (if (not file-exists) + (initproc db)) + (if (not readyexists) + (begin + (common:simple-file-release-lock lockfname) + (with-output-to-file + readyfname + (lambda () + (print "Ready at " + (seconds->year-work-week/day-time + (current-seconds))))))) + db)) + (exn (io-error) (debug:print 0 *default-log-port* "ERROR: i/o error with " fname ". Check permissions, disk space etc. and try again.")) + (exn (corrupt) (debug:print 0 *default-log-port* "ERROR: database " fname " is corrupt. Repair it to proceed.")) + (exn (busy) (debug:print 0 *default-log-port* "ERROR: database " fname " is locked. Try copying to another location, remove original and copy back.")) + (exn (permission)(debug:print 0 *default-log-port* "ERROR: database " fname " has some permissions problem.")) + (exn () (debug:print 0 *default-log-port* "ERROR: Unknown error with database " fname " message: " ((condition-property-accessor 'exn 'message) exn)))) + + (condition-case + (begin + (debug:print 2 *default-log-port* "WARNING: opening db in non-writable dir " fname) + (let ((db (sqlite3:open-database fname))) + (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 136000)) + (sqlite3:execute db "PRAGMA synchronous = 0;") + ;; (mutex-unlock! *db-open-mutex*) + db)) + (exn (io-error) (debug:print 0 *default-log-port* "ERROR: i/o error with " fname ". Check permissions, disk space etc. and try again.")) + (exn (corrupt) (debug:print 0 *default-log-port* "ERROR: database " fname " is corrupt. Repair it to proceed.")) + (exn (busy) (debug:print 0 *default-log-port* "ERROR: database " fname " is locked. Try copying to another location, remove original and copy back.")) + (exn (permission)(debug:print 0 *default-log-port* "ERROR: database " fname " has some permissions problem.")) + (exn () (debug:print 0 *default-log-port* "ERROR: Unknown error with database " fname " message: " ((condition-property-accessor 'exn 'message) exn)))) + ))) + + +;; traps to catch usage of functions that need to be tracked down + +(define (db:get-subdb . params) + (assert #f "FATAL: Call to db:get-subdb - needs to be fixed.")) + ) Index: keys.scm ================================================================== --- keys.scm +++ keys.scm @@ -34,61 +34,5 @@ (import commonmod configfmod debugprint) -(include "key_records.scm") -(include "common_records.scm") - -(define (keys->keystr keys) ;; => key1,key2,key3,additiona1, ... - (string-intersperse keys ",")) - -(define (args:usage . a) #f) - -;;====================================================================== -;; key <=> target routines -;;====================================================================== - -;; This invalidates using "/" in item names. Every key will be -;; available via args:get-arg as :keyfield. Since this only needs to -;; be called once let's use it to set the environment vars -;; -;; The setting of :keyfield in args should be turned off ASAP -;; -(define (keys:target-set-args keys target ht) - (if target - (let ((vals (string-split target "/"))) - (if (eq? (length vals)(length keys)) - (for-each (lambda (key val) - (setenv key val) - (if ht (hash-table-set! ht (conc ":" key) val))) - keys - vals) - (debug:print-error 0 *default-log-port* "wrong number of values in " target ", should match " keys)) - vals) - (debug:print 4 *default-log-port* "ERROR: keys:target-set-args called with no target."))) - -;; given the keys (a list of vectors or a list of keys) and a target return a keyval list -;; keyval list ( (key1 val1) (key2 val2) ...) -(define (keys:target->keyval keys target) - (let* ((targlist (string-split target "/")) - (numkeys (length keys)) - (numtarg (length targlist)) - (targtweaked (if (> numkeys numtarg) - (append targlist (make-list (- numkeys numtarg) "")) - targlist))) - (map (lambda (key targ) - (list key targ)) - keys targtweaked))) - -;;====================================================================== -;; config file related routines -;;====================================================================== - -(define keys:config-get-fields common:get-fields) -(define (keys:make-key/field-string confdat) - (let ((fields (configf:get-section confdat "fields"))) - (string-join - (map (lambda (field)(conc (car field) " " (cadr field))) - fields) - ","))) - Index: mtmod.scm ================================================================== --- mtmod.scm +++ mtmod.scm @@ -109,10 +109,22 @@ (define (common:get-fields cfgdat) (let ((fields (hash-table-ref/default cfgdat "fields" '()))) (map car fields))) +;;====================================================================== +;; stuff from keys that can't be in commonmod. Maybe move all from commonmod to here? +;;====================================================================== + +(define (keys:make-key/field-string confdat) + (let ((fields (configf:get-section confdat "fields"))) + (string-join + (map (lambda (field)(conc (car field) " " (cadr field))) + fields) + ","))) + +(define keys:config-get-fields common:get-fields) ;;====================================================================== ;; testsuite and area utilites ;;====================================================================== Index: ods.scm ================================================================== --- ods.scm +++ ods.scm @@ -20,208 +20,5 @@ (declare (unit ods)) (declare (uses common)) (declare (uses commonmod)) (import commonmod) -(define ods:dirs - '("Configurations2" - "Configurations2/toolpanel" - "Configurations2/menubar" - "Configurations2/toolbar" - "Configurations2/progressbar" - "Configurations2/floater" - "Configurations2/images" - "Configurations2/images/Bitmaps" - "Configurations2/statusbar" - "Configurations2/popupmenu" - "Configurations2/accelerator" - "META-INF" - "Thumbnails")) - -(define ods:0-len-files - '("Configurations2/accelerator/current.xml" - ;; "Thumbnails/thumbnail.png" - "content.xml" - )) - -(define ods:files - '(("META-INF/manifest.xml" - ("\n" - "\n" - "\n" - "\n" - "\n" - "\n" - "\n" - "\n" - "\n" - "\n" - "\n" - "\n" - "\n" - "\n" - "\n" - "\n" - "\n" - "\n" - "\n" - "\n" - "\n" - "\n")) - ("styles.xml" - ("\n" - "$-$???Page 1??? (???)09/06/2011, 20:48:51Page 1 / 99\n")) - ("settings.xml" - ("\n" - "0045161799view100000020000010060true04000020000010060trueSheet2270010060falsetruetruetrue12632256truetruetruetruefalsefalse1270127011truefalsetrue3falsetruetruetrue12701270false1truetrue1true12632256falsefalsetrue0truetruetruefalsetrue\n")) - ("mimetype" - ("application/vnd.oasis.opendocument.spreadsheet")) - ("meta.xml" - ("\n" - "Matt Welland2011-09-06T20:46:232011-09-06T20:48:51Matt WellandPT2M29S1LibreOffice/3.3$Linux LibreOffice_project/330m19$Build-301\n")))) - -(define ods:content-header - '("\n" - "\n" - "\n" - "\n" - "\n" - "\n" - "\n" - "\n" - "\n" - "\n" - "\n" - "\n" - "\n" - "\n" - "\n" - "\n" - "\n" - "\n" - "\n" - "\n" - "\n" - "\n")) - -(define ods:content-footer - '("\n" - "\n" - "\n")) - -(define (ods:make-thumbnail path) - (let ((oup (open-output-pipe (conc "uudecode -o " path "/Thumbnails/thumbnail.png")))) - (with-output-to-port oup - (lambda () - (print "begin-base64 640 Thumbnail.png -iVBORw0KGgoAAAANSUhEUgAAAL4AAAEACAIAAACCoVt7AAAEWElEQVR4nO3X -MU4bWQCA4bGUo5gUKCcgJwCaVNvShdI06VKmSxNKp6PdKg3xCcgJIhr7Ll6P -DTgBRbv5i11W+r7Gw7yZx0jv5415sV6vB/h9L/7rB+D/apfO4nxy8nk8OPq0 -vDm9Pr8+nc+mv75pcXl5MNtfsLp8fXDxbRjefl3Pj//xb340yW+N8gyM6awu -vxwu1+txnVar1Xj2z7PJpoUxhYNdFmNSs+EukdHRcHpzt7Kr69s/luub6Wa1 -V8Px9tx9TLsSH2a4OxwjWx5+uLgYhtOr4ezXo8Ori4tt0b8XJf+KMZ3p7N3w -ejIZV227hMP3V+/XNweX59erxZddK98uPi5eDvfdbC672u8I09l8tvlYDC/v -z93HNJa4+Hj7fr0+3mxs54vTw1e7BM+vh9n7T8PBbPlx8jD/k9HT4WzsRzfP -0/aFtVi+vNl9W75b4MODhwv2C7c4vz/e7C8/zzK+8Iav6ycLPJ1Ol3/zAPv5 -N5vfo7tnN+vZuIFNJvJ5frYvrOHLh8nJyfjjuOsM1/slPH53uNmPTnYDD8dH -R5ut4uGFdf9F6WQy3C3wdPbmdjKZDNsw7u56PPMw3F6cXS6vDs/u57/66cE2 -o+e3w+fP203p7RvdPDvbF9bx/GY935/bvYDuPsa//IeBH473jufrH+9+cu54 -f9dPM893u9QPcz4dnT+emGfDP+dE0iGSDpF0iKRDJB0i6RBJh0g6RNIhkg6R -dIikQyQdIukQSYdIOkTSIZIOkXSIpEMkHSLpEEmHSDpE0iGSDpF0iKRDJB0i -6RBJh0g6RNIhkg6RdIikQyQdIukQSYdIOkTSIZIOkXSIpEMkHSLpEEmHSDpE -0iGSDpF0iKRDJB0i6RBJh0g6RNIhkg6RdIikQyQdIukQSYdIOkTSIZIOkXSI -pEMkHSLpEEmHSDpE0iGSDpF0iKRDJB0i6RBJh0g6RNIhkg6RdIikQyQdIukQ -SYdIOkTSIZIOkXSIpEMkHSLpEEmHSDpE0iGSDpF0iKRDJB0i6RBJh0g6RNIh -kg6RdIikQyQdIukQSYdIOkTSIZIOkXSIpEMkHSLpEEmHSDpE0iGSDpF0iKRD -JB0i6RBJh0g6RNIhkg6RdIikQyQdIukQSYdIOkTSIZIOkXSIpEMkHSLpEEmH -SDpE0iGSDpF0iKRDJB0i6RBJh0g6RNIhkg6RdIikQyQdIukQSYdIOkTSIZIO -kXSIpEMkHSLpEEmHSDpE0iGSDpF0iKRDJB0i6RBJh0g6RNIhkg6RdIikQyQd -IukQSYdIOkTSIZIOkXSIpEMkHSLpEEmHSDpE0iGSDpF0iKRDJB0i6RBJh0g6 -RNIhkg6RdIikQyQdIukQSYdIOkTSIZIOkXSIpEMkHSLpEEmHSDpE0iGSDpF0 -iKRDJB0i6RBJh0g6RNIhkg6RdIikQyQdIukQSYdIOkTSIZIOkXSIpEMkHSLp -EEmHSDpE0iGSDpF0iKRDJB0i6RBJh+gv8TgE/jVPQbMAAAAASUVORK5CYII= -===="))))) - -;; sheetdat is '("sheetname" (r1c1 r2c2 ...)(r2c1 r2c2 ...) ...) -(define (ods:sheet sheetdat) - (let ((name (car sheetdat)) - (rows (cdr sheetdat))) - (conc "\n" - (conc (ods:column) - (string-join (map ods:row rows) "")) - ""))) - -;; seems to be called once at top of each sheet, i.e. a column of rows -(define (ods:column) - "\n") - -;; cells is a list of ... -(define (ods:row cells) - (conc "\n" - (string-join (map ods:cell cells) "") - "\n")) - -;; types are "string" or "float" -(define (ods:cell value) - (let* ((type (cond - ((string? value) "string") - ((symbol? value) "string") - ((number? value) "float") - (else #f))) - (tmpval (if (symbol? value) - (symbol->string value) - (if type value ""))) ;; convert everything else to an empty string - (escval (if (string? tmpval)(string-substitute (regexp "<") "<" (string-substitute (regexp ">") ">" tmpval)) tmpval))) - (conc "\n" - "" escval "" "\n" - "" "\n"))) - -;; create the directories -(define (ods:construct-dir path) - (for-each - (lambda (subdir) - (system (conc "mkdir -p " path "/" subdir))) - ods:dirs)) - -;; populate the necessary, non-constructed, files -(define (ods:add-non-content-files path) - ;; first the zero-length files, nb// the dir should already be created - (for-each - (lambda (fname) - (system (conc "touch " path "/" fname))) - ods:0-len-files) - ;; create the files with stuff in them - (for-each - (lambda (fdat) - (let* ((name (car fdat)) - (lines (cadr fdat))) - (with-output-to-file (conc path "/" name) - (lambda () - (for-each - (lambda (line) - (display line)) - lines))))) - ods:files)) - -;; data format: -;; '( (sheet1 (r1c1 r1c2 r1c3 ...) -;; (r2c1 r2c3 r2c3 ...) ) -;; (sheet2 ( ... ) -;; ( ... ) ) ) -(define (ods:list->ods path fname data) - (if (not (common:file-exists? path)) - (print "ERROR: path to create ods data must pre-exist") - (begin - (with-output-to-file (conc path "/content.xml") - (lambda () - (ods:construct-dir path) - (ods:add-non-content-files path) - (ods:make-thumbnail path) - (map display ods:content-header) - ;; process each sheet - (map print - (map ods:sheet data)) - (map display ods:content-footer))) - (system (conc "cd " path "; zip " fname " -n mimetype mimetype `find . |grep -v mimetype` > /dev/null"))))) - ADDED odsmod.scm Index: odsmod.scm ================================================================== --- /dev/null +++ odsmod.scm @@ -0,0 +1,362 @@ +;; Copyright 2011, 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 . +;; + +(use csv-xml regex) +(declare (unit ods)) +(declare (uses common)) +(declare (uses commonmod)) +(import commonmod) + +(module odsmod + * + +(define ods:dirs + '("Configurations2" + "Configurations2/toolpanel" + "Configurations2/menubar" + "Configurations2/toolbar" + "Configurations2/progressbar" + "Configurations2/floater" + "Configurations2/images" + "Configurations2/images/Bitmaps" + "Configurations2/statusbar" + "Configurations2/popupmenu" + "Configurations2/accelerator" + "META-INF" + "Thumbnails")) + +(define ods:0-len-files + '("Configurations2/accelerator/current.xml" + ;; "Thumbnails/thumbnail.png" + "content.xml" + )) + +(define ods:files + '(("META-INF/manifest.xml" + ("\n" + "\n" + "\n" + "\n" + "\n" + "\n" + "\n" + "\n" + "\n" + "\n" + "\n" + "\n" + "\n" + "\n" + "\n" + "\n" + "\n" + "\n" + "\n" + "\n" + "\n" + "\n")) + ("styles.xml" + ("\n" + "$-$???Page 1??? (???)09/06/2011, 20:48:51Page 1 / 99\n")) + ("settings.xml" + ("\n" + "0045161799view100000020000010060true04000020000010060trueSheet2270010060falsetruetruetrue12632256truetruetruetruefalsefalse1270127011truefalsetrue3falsetruetruetrue12701270false1truetrue1true12632256falsefalsetrue0truetruetruefalsetrue\n")) + ("mimetype" + ("application/vnd.oasis.opendocument.spreadsheet")) + ("meta.xml" + ("\n" + "Matt Welland2011-09-06T20:46:232011-09-06T20:48:51Matt WellandPT2M29S1LibreOffice/3.3$Linux LibreOffice_project/330m19$Build-301\n")))) + +(define ods:content-header + '("\n" + "\n" + "\n" + "\n" + "\n" + "\n" + "\n" + "\n" + "\n" + "\n" + "\n" + "\n" + "\n" + "\n" + "\n" + "\n" + "\n" + "\n" + "\n" + "\n" + "\n" + "\n")) + +(define ods:content-footer + '("\n" + "\n" + "\n")) + +(define (ods:make-thumbnail path) + (let ((oup (open-output-pipe (conc "uudecode -o " path "/Thumbnails/thumbnail.png")))) + (with-output-to-port oup + (lambda () + (print "begin-base64 640 Thumbnail.png +iVBORw0KGgoAAAANSUhEUgAAAL4AAAEACAIAAACCoVt7AAAEWElEQVR4nO3X +MU4bWQCA4bGUo5gUKCcgJwCaVNvShdI06VKmSxNKp6PdKg3xCcgJIhr7Ll6P +DTgBRbv5i11W+r7Gw7yZx0jv5415sV6vB/h9L/7rB+D/apfO4nxy8nk8OPq0 +vDm9Pr8+nc+mv75pcXl5MNtfsLp8fXDxbRjefl3Pj//xb340yW+N8gyM6awu +vxwu1+txnVar1Xj2z7PJpoUxhYNdFmNSs+EukdHRcHpzt7Kr69s/luub6Wa1 +V8Px9tx9TLsSH2a4OxwjWx5+uLgYhtOr4ezXo8Ori4tt0b8XJf+KMZ3p7N3w +ejIZV227hMP3V+/XNweX59erxZddK98uPi5eDvfdbC672u8I09l8tvlYDC/v +z93HNJa4+Hj7fr0+3mxs54vTw1e7BM+vh9n7T8PBbPlx8jD/k9HT4WzsRzfP +0/aFtVi+vNl9W75b4MODhwv2C7c4vz/e7C8/zzK+8Iav6ycLPJ1Ol3/zAPv5 +N5vfo7tnN+vZuIFNJvJ5frYvrOHLh8nJyfjjuOsM1/slPH53uNmPTnYDD8dH +R5ut4uGFdf9F6WQy3C3wdPbmdjKZDNsw7u56PPMw3F6cXS6vDs/u57/66cE2 +o+e3w+fP203p7RvdPDvbF9bx/GY935/bvYDuPsa//IeBH473jufrH+9+cu54 +f9dPM893u9QPcz4dnT+emGfDP+dE0iGSDpF0iKRDJB0i6RBJh0g6RNIhkg6R +dIikQyQdIukQSYdIOkTSIZIOkXSIpEMkHSLpEEmHSDpE0iGSDpF0iKRDJB0i +6RBJh0g6RNIhkg6RdIikQyQdIukQSYdIOkTSIZIOkXSIpEMkHSLpEEmHSDpE +0iGSDpF0iKRDJB0i6RBJh0g6RNIhkg6RdIikQyQdIukQSYdIOkTSIZIOkXSI +pEMkHSLpEEmHSDpE0iGSDpF0iKRDJB0i6RBJh0g6RNIhkg6RdIikQyQdIukQ +SYdIOkTSIZIOkXSIpEMkHSLpEEmHSDpE0iGSDpF0iKRDJB0i6RBJh0g6RNIh +kg6RdIikQyQdIukQSYdIOkTSIZIOkXSIpEMkHSLpEEmHSDpE0iGSDpF0iKRD +JB0i6RBJh0g6RNIhkg6RdIikQyQdIukQSYdIOkTSIZIOkXSIpEMkHSLpEEmH +SDpE0iGSDpF0iKRDJB0i6RBJh0g6RNIhkg6RdIikQyQdIukQSYdIOkTSIZIO +kXSIpEMkHSLpEEmHSDpE0iGSDpF0iKRDJB0i6RBJh0g6RNIhkg6RdIikQyQd +IukQSYdIOkTSIZIOkXSIpEMkHSLpEEmHSDpE0iGSDpF0iKRDJB0i6RBJh0g6 +RNIhkg6RdIikQyQdIukQSYdIOkTSIZIOkXSIpEMkHSLpEEmHSDpE0iGSDpF0 +iKRDJB0i6RBJh0g6RNIhkg6RdIikQyQdIukQSYdIOkTSIZIOkXSIpEMkHSLp +EEmHSDpE0iGSDpF0iKRDJB0i6RBJh+gv8TgE/jVPQbMAAAAASUVORK5CYII= +===="))))) + +;; sheetdat is '("sheetname" (r1c1 r2c2 ...)(r2c1 r2c2 ...) ...) +(define (ods:sheet sheetdat) + (let ((name (car sheetdat)) + (rows (cdr sheetdat))) + (conc "\n" + (conc (ods:column) + (string-join (map ods:row rows) "")) + ""))) + +;; seems to be called once at top of each sheet, i.e. a column of rows +(define (ods:column) + "\n") + +;; cells is a list of ... +(define (ods:row cells) + (conc "\n" + (string-join (map ods:cell cells) "") + "\n")) + +;; types are "string" or "float" +(define (ods:cell value) + (let* ((type (cond + ((string? value) "string") + ((symbol? value) "string") + ((number? value) "float") + (else #f))) + (tmpval (if (symbol? value) + (symbol->string value) + (if type value ""))) ;; convert everything else to an empty string + (escval (if (string? tmpval)(string-substitute (regexp "<") "<" (string-substitute (regexp ">") ">" tmpval)) tmpval))) + (conc "\n" + "" escval "" "\n" + "" "\n"))) + +;; create the directories +(define (ods:construct-dir path) + (for-each + (lambda (subdir) + (system (conc "mkdir -p " path "/" subdir))) + ods:dirs)) + +;; populate the necessary, non-constructed, files +(define (ods:add-non-content-files path) + ;; first the zero-length files, nb// the dir should already be created + (for-each + (lambda (fname) + (system (conc "touch " path "/" fname))) + ods:0-len-files) + ;; create the files with stuff in them + (for-each + (lambda (fdat) + (let* ((name (car fdat)) + (lines (cadr fdat))) + (with-output-to-file (conc path "/" name) + (lambda () + (for-each + (lambda (line) + (display line)) + lines))))) + ods:files)) + +;; data format: +;; '( (sheet1 (r1c1 r1c2 r1c3 ...) +;; (r2c1 r2c3 r2c3 ...) ) +;; (sheet2 ( ... ) +;; ( ... ) ) ) +(define (ods:list->ods path fname data) + (if (not (common:file-exists? path)) + (print "ERROR: path to create ods data must pre-exist") + (begin + (with-output-to-file (conc path "/content.xml") + (lambda () + (ods:construct-dir path) + (ods:add-non-content-files path) + (ods:make-thumbnail path) + (map display ods:content-header) + ;; process each sheet + (map print + (map ods:sheet data)) + (map display ods:content-footer))) + (system (conc "cd " path "; zip " fname " -n mimetype mimetype `find . |grep -v mimetype` > /dev/null"))))) + +;;====================================================================== +;; Extract ods file from the db +;;====================================================================== + +;; NOT REWRITTEN YET!!!!! + +;; runspatt is a comma delimited list of run patterns +;; keypatt-alist must contain *all* keys with an associated pattern: '( ("KEY1" "%") .. ) +(define (db:extract-ods-file dbstruct outputfile keypatt-alist runspatt pathmod) + (assert #f "FATAL: call to db:extract-ods-file which is not ported yet.") + (let* ((keysstr (string-intersperse (map car keypatt-alist) ",")) + (keyqry (string-intersperse (map (lambda (p)(conc (car p) " LIKE ? ")) keypatt-alist) " AND ")) + (numkeys (length keypatt-alist)) + (test-ids '()) + (dbdat (db:get-subdb dbstruct)) + (db (dbr:dbdat-dbh dbdat)) + (windows (and pathmod (substring-index "\\" pathmod))) + (tempdir (conc "/tmp/" (current-user-name) "/" runspatt "_" (random 10000) "_" (current-process-id))) + (runsheader (append (list "Run Id" "Runname") ; 0 1 + (map car keypatt-alist) ; + N = length keypatt-alist + (list "Testname" ; 2 + "Item Path" ; 3 + "Description" ; 4 + "State" ; 5 + "Status" ; 6 + "Final Log" ; 7 + "Run Duration" ; 8 + "When Run" ; 9 + "Tags" ; 10 + "Run Owner" ; 11 + "Comment" ; 12 + "Author" ; 13 + "Test Owner" ; 14 + "Reviewed" ; 15 + "Diskfree" ; 16 + "Uname" ; 17 + "Rundir" ; 18 + "Host" ; 19 + "Cpu Load" ; 20 + ))) + (results (list runsheader)) + (testdata-header (list "Run Id" "Testname" "Item Path" "Category" "Variable" "Value" "Expected" "Tol" "Units" "Status" "Comment")) + (mainqry (conc "SELECT + t.testname,r.id,runname," keysstr ",t.testname, + t.item_path,tm.description,t.state,t.status, + final_logf,run_duration, + strftime('%m/%d/%Y %H:%M:%S',datetime(t.event_time,'unixepoch'),'localtime'), + tm.tags,r.owner,t.comment, + author, + tm.owner,reviewed, + diskfree,uname,rundir, + host,cpuload + FROM tests AS t JOIN runs AS r ON t.run_id=r.id JOIN test_meta AS tm ON tm.testname=t.testname + WHERE runname LIKE ? AND " keyqry ";"))) + (debug:print 2 *default-log-port* "Using " tempdir " for constructing the ods file. keyqry: " keyqry " keystr: " keysstr " with keys: " (map cadr keypatt-alist) + "\n mainqry: " mainqry) + ;; "Expected Value" + ;; "Value Found" + ;; "Tolerance" + (apply sqlite3:for-each-row + (lambda (test-id . b) + (set! test-ids (cons test-id test-ids)) ;; test-id is now testname + (set! results (append results ;; note, drop the test-id + (list + (if pathmod + (let* ((vb (apply vector b)) + (keyvals (let loop ((i 0) + (res '())) + (if (>= i numkeys) + res + (loop (+ i 1) + (append res (list (vector-ref vb (+ i 2)))))))) + (runname (vector-ref vb 1)) + (testname (vector-ref vb (+ 2 numkeys))) + (item-path (vector-ref vb (+ 3 numkeys))) + (final-log (vector-ref vb (+ 7 numkeys))) + (run-dir (vector-ref vb (+ 18 numkeys))) + (log-fpath (conc run-dir "/" final-log))) ;; (string-intersperse keyvals "/") "/" testname "/" item-path "/" + (debug:print 4 *default-log-port* "log: " log-fpath " exists: " (common:file-exists? log-fpath)) + (vector-set! vb (+ 7 numkeys) (if (common:file-exists? log-fpath) + (let ((newpath (conc pathmod "/" + (string-intersperse keyvals "/") + "/" runname "/" testname "/" + (if (string=? item-path "") "" (conc "/" item-path)) + final-log))) + ;; for now throw away newpath and use the log-fpath conc'd with pathmod + (set! newpath (conc pathmod log-fpath)) + (if windows (string-translate newpath "/" "\\") newpath)) + (if (debug:debug-mode 1) + (conc final-log " not-found") + ""))) + (vector->list vb)) + b))))) + db + mainqry + runspatt (map cadr keypatt-alist)) + (debug:print 2 *default-log-port* "Found " (length test-ids) " records") + (set! results (list (cons "Runs" results))) + ;; now, for each test, collect the test_data info and add a new sheet + (for-each + (lambda (test-id) + (let ((test-data (list testdata-header)) + (curr-test-name #f)) + (sqlite3:for-each-row + (lambda (run-id testname item-path category variable value expected tol units status comment) + (set! curr-test-name testname) + (set! test-data (append test-data (list (list run-id testname item-path category variable value expected tol units status comment))))) + db + ;; "SELECT run_id,testname,item_path,category,variable,td.value AS value,expected,tol,units,td.status AS status,td.comment AS comment FROM test_data AS td INNER JOIN tests ON tests.id=td.test_id WHERE test_id=?;" + "SELECT run_id,testname,item_path,category,variable,td.value AS value,td.expected,td.tol,td.units,td.status AS status,td.comment AS comment FROM test_data AS td INNER JOIN tests ON tests.id=td.test_id WHERE testname=?;" + test-id) + (if curr-test-name + (set! results (append results (list (cons curr-test-name test-data))))) + )) + (sort (delete-duplicates test-ids) string<=)) + (system (conc "mkdir -p " tempdir)) + ;; (pp results) + (ods:list->ods + tempdir + (if (string-match (regexp "^[/~]+.*") outputfile) ;; full path? + outputfile + (begin + (debug:print 0 *default-log-port* "WARNING: path given, " outputfile " is relative, prefixing with current directory") + (conc (current-directory) "/" outputfile))) + results) + ;; brutal clean up + (dbfile:add-dbdat dbstruct #f dbdat) + (system "rm -rf tempdir"))) + +;; (db:extract-ods-file db "outputfile.ods" '(("sysname" "%")("fsname" "%")("datapath" "%")) "%") + +) Index: portlogger.scm ================================================================== --- portlogger.scm +++ portlogger.scm @@ -18,11 +18,12 @@ ;; (declare (unit portlogger)) (declare (uses debugprint)) -(declare (uses dbmod)) +(declare (uses commonmod)) +;; (declare (uses dbmod)) (module portlogger * (import scheme) @@ -35,11 +36,10 @@ ;; dot-locking extras ) (import (prefix sqlite3 sqlite3:)) - (import debugprint dbmod) ) (chicken-5 (import chicken.base chicken.condition chicken.file @@ -58,11 +58,14 @@ )) (import srfi-1 srfi-69 z3 (srfi 18) s11n) (import (prefix sqlite3 sqlite3:)) -(import debugprint dbmod) +(import debugprint + ;; dbmod + commonmod + ) ;; lsof -i (define (portlogger:open-db fname) (let* ((avail (tasks:wait-on-journal fname 5 remove: #t)) ;; wait up to about 10 seconds for the journal to go away Index: rmtmod.scm ================================================================== --- rmtmod.scm +++ rmtmod.scm @@ -1055,20 +1055,10 @@ (substring (common:get-last-run-version) 0 6))) (define (common:set-last-run-version) (rmt:set-var "MEGATEST_VERSION" (common:version-signature))) -;;====================================================================== -;; V E R S I O N -;;====================================================================== - -(define (common:get-full-version) - (conc megatest-version "-" megatest-fossil-hash)) - -(define (common:version-signature) - (conc megatest-version "-" (substring megatest-fossil-hash 0 4))) - ;;====================================================================== ;; postive number if megatest version > db version ;; negative number if megatest version < db version (define (common:version-db-delta) (- megatest-version (common:get-last-run-version-number))) Index: servermod.scm ================================================================== --- servermod.scm +++ servermod.scm @@ -946,14 +946,14 @@ ;;====================================================================== ;; E X I T H A N D L I N G ;;====================================================================== -(define (common:run-sync?) - (and *toppath* ;; gate if called before *toppath* is set - (common:on-homehost?) - (args:get-arg "-server"))) +;; (define (common:run-sync?) +;; (and *toppath* ;; gate if called before *toppath* is set +;; (common:on-homehost?) +;; (args:get-arg "-server"))) (define (std-signal-handler signum) ;; (signal-mask! signum) (set! *time-to-exit* #t) Index: tdb.scm ================================================================== --- tdb.scm +++ tdb.scm @@ -56,155 +56,155 @@ ;;====================================================================== ;; T E S T S P E C I F I C D B ;;====================================================================== -;; Create the sqlite db for the individual test(s) -;; -;; Moved these tables into .db -;; THIS CODE TO BE REMOVED -;; -(define (open-test-db work-area) - (debug:print-info 11 *default-log-port* "open-test-db " work-area) - (if (and work-area - (directory? work-area) - (file-read-access? work-area)) - (let* ((dbpath (conc work-area "/testdat.db")) - (dbexists (common:file-exists? dbpath)) - (work-area-writeable (file-write-access? work-area)) - (db (handle-exceptions ;; open the db if area writeable or db pre-existing. open in-mem otherwise. if exception, open in-mem - exn - (begin - (print-call-chain (current-error-port)) - (debug:print 2 *default-log-port* "ERROR: problem accessing test db " work-area ", you probably should clean and re-run this test" - ((condition-property-accessor 'exn 'message) exn)) - (set! dbexists #f) ;; must force re-creation of tables, more tom-foolery - (sqlite3:open-database ":memory:")) ;; open an in-memory db to allow readonly access - (if (or work-area-writeable - dbexists) - (sqlite3:open-database dbpath) - (sqlite3:open-database ":memory:")))) - (tdb-writeable (and (file-write-access? work-area) - (file-write-access? dbpath))) - (handler (sqlite3:make-busy-timeout (if (args:get-arg "-override-timeout") - (string->number (args:get-arg "-override-timeout")) - 136000)))) - - (if (and tdb-writeable - *db-write-access*) - (sqlite3:set-busy-handler! db handler)) - (if (not dbexists) - (begin - (db:set-sync db) ;; (sqlite3:execute db "PRAGMA synchronous = FULL;") - (debug:print-info 11 *default-log-port* "Initialized test database " dbpath) - (tdb:testdb-initialize db))) - ;; (sqlite3:execute db "PRAGMA synchronous = 0;") - (debug:print-info 11 *default-log-port* "open-test-db END (sucessful)" work-area) - ;; now let's test that everything is correct - (handle-exceptions - exn - (begin - (print-call-chain (current-error-port)) - (debug:print-error 0 *default-log-port* "problem accessing test db " work-area ", you probably should clean and re-run this test or remove the file " - dbpath ".\n " - ((condition-property-accessor 'exn 'message) exn)) - #f) - ;; Is there a cheaper single line operation that will check for existance of a table - ;; and raise an exception ? - (sqlite3:execute db "SELECT id FROM test_data LIMIT 1;")) - db) - ;; no work-area or not readable - create a placeholder to fake rest of world out - (let ((baddb (sqlite3:open-database ":memory:"))) - (debug:print-info 11 *default-log-port* "open-test-db END (unsucessful)" work-area) - ;; provide an in-mem db (this is dangerous!) - (tdb:testdb-initialize baddb) - baddb))) - -;; find and open the testdat.db file for an existing test -(define (tdb:open-test-db-by-test-id test-id #!key (work-area #f)) - (let* ((test-path (if work-area - work-area - (rmt:test-get-rundir-from-test-id test-id)))) - (debug:print 3 *default-log-port* "TEST PATH: " test-path) - (open-test-db test-path))) - -;; find and open the testdat.db file for an existing test -(define (tdb:open-test-db-by-test-id-local dbstruct run-id test-id #!key (work-area #f)) - (let* ((test-path (if work-area - work-area - (db:test-get-rundir-from-test-id dbstruct run-id test-id)))) - (debug:print 3 *default-log-port* "TEST PATH: " test-path) - (open-test-db test-path))) - -;; find and open the testdat.db file for an existing test -(define (tdb:open-run-close-db-by-test-id-local dbstruct run-id test-id work-area proc . params) - (let* ((test-path (if work-area - work-area - (db:test-get-rundir-from-test-id dbstruct run-id test-id))) - (tdb (open-test-db test-path))) - (apply proc tdb params))) - -(define (tdb:testdb-initialize db) - (debug:print 11 *default-log-port* "db:testdb-initialize START") - (sqlite3:with-transaction - db - (lambda () - (for-each - (lambda (sqlcmd) - (sqlite3:execute db sqlcmd)) - (list "CREATE TABLE IF NOT EXISTS test_rundat ( - id INTEGER PRIMARY KEY, - update_time TIMESTAMP, - cpuload INTEGER DEFAULT -1, - diskfree INTEGER DEFAULT -1, - diskusage INTGER DEFAULT -1, - run_duration INTEGER DEFAULT 0);" - "CREATE TABLE IF NOT EXISTS test_data ( - id INTEGER PRIMARY KEY, - test_id INTEGER, - category TEXT DEFAULT '', - variable TEXT, - value REAL, - expected REAL, - tol REAL, - units TEXT, - comment TEXT DEFAULT '', - status TEXT DEFAULT 'n/a', - type TEXT DEFAULT '', - CONSTRAINT test_data_constraint UNIQUE (test_id,category,variable));" - "CREATE TABLE IF NOT EXISTS test_steps ( - id INTEGER PRIMARY KEY, - test_id INTEGER, - stepname TEXT, - state TEXT DEFAULT 'NOT_STARTED', - status TEXT DEFAULT 'n/a', - event_time TIMESTAMP, - comment TEXT DEFAULT '', - logfile TEXT DEFAULT '', - CONSTRAINT test_steps_constraint UNIQUE (test_id,stepname,state));" - ;; test_meta can be used for handing commands to the test - ;; e.g. KILLREQ - ;; the ackstate is set to 1 once the command has been completed - "CREATE TABLE IF NOT EXISTS test_meta ( - id INTEGER PRIMARY KEY, - var TEXT, - val TEXT, - ackstate INTEGER DEFAULT 0, - CONSTRAINT metadat_constraint UNIQUE (var));")))) - (debug:print 11 *default-log-port* "db:testdb-initialize END")) - -;; This routine moved to db:read-test-data -;; -(define (tdb:read-test-data tdb test-id categorypatt) - (let ((res '())) - (sqlite3:for-each-row - (lambda (id test_id category variable value expected tol units comment status type) - (set! res (cons (vector id test_id category variable value expected tol units comment status type) res))) - tdb - "SELECT id,test_id,category,variable,value,expected,tol,units,comment,status,type FROM test_data WHERE test_id=? AND category LIKE ? ORDER BY category,variable;" test-id categorypatt) - (sqlite3:finalize! tdb) - (reverse res))) +;; =not-used= ;; Create the sqlite db for the individual test(s) +;; =not-used= ;; +;; =not-used= ;; Moved these tables into .db +;; =not-used= ;; THIS CODE TO BE REMOVED +;; =not-used= ;; +;; =not-used= (define (open-test-db work-area) +;; =not-used= (debug:print-info 11 *default-log-port* "open-test-db " work-area) +;; =not-used= (if (and work-area +;; =not-used= (directory? work-area) +;; =not-used= (file-read-access? work-area)) +;; =not-used= (let* ((dbpath (conc work-area "/testdat.db")) +;; =not-used= (dbexists (common:file-exists? dbpath)) +;; =not-used= (work-area-writeable (file-write-access? work-area)) +;; =not-used= (db (handle-exceptions ;; open the db if area writeable or db pre-existing. open in-mem otherwise. if exception, open in-mem +;; =not-used= exn +;; =not-used= (begin +;; =not-used= (print-call-chain (current-error-port)) +;; =not-used= (debug:print 2 *default-log-port* "ERROR: problem accessing test db " work-area ", you probably should clean and re-run this test" +;; =not-used= ((condition-property-accessor 'exn 'message) exn)) +;; =not-used= (set! dbexists #f) ;; must force re-creation of tables, more tom-foolery +;; =not-used= (sqlite3:open-database ":memory:")) ;; open an in-memory db to allow readonly access +;; =not-used= (if (or work-area-writeable +;; =not-used= dbexists) +;; =not-used= (sqlite3:open-database dbpath) +;; =not-used= (sqlite3:open-database ":memory:")))) +;; =not-used= (tdb-writeable (and (file-write-access? work-area) +;; =not-used= (file-write-access? dbpath))) +;; =not-used= (handler (sqlite3:make-busy-timeout (if (args:get-arg "-override-timeout") +;; =not-used= (string->number (args:get-arg "-override-timeout")) +;; =not-used= 136000)))) +;; =not-used= +;; =not-used= (if (and tdb-writeable +;; =not-used= *db-write-access*) +;; =not-used= (sqlite3:set-busy-handler! db handler)) +;; =not-used= (if (not dbexists) +;; =not-used= (begin +;; =not-used= (db:set-sync db) ;; (sqlite3:execute db "PRAGMA synchronous = FULL;") +;; =not-used= (debug:print-info 11 *default-log-port* "Initialized test database " dbpath) +;; =not-used= (tdb:testdb-initialize db))) +;; =not-used= ;; (sqlite3:execute db "PRAGMA synchronous = 0;") +;; =not-used= (debug:print-info 11 *default-log-port* "open-test-db END (sucessful)" work-area) +;; =not-used= ;; now let's test that everything is correct +;; =not-used= (handle-exceptions +;; =not-used= exn +;; =not-used= (begin +;; =not-used= (print-call-chain (current-error-port)) +;; =not-used= (debug:print-error 0 *default-log-port* "problem accessing test db " work-area ", you probably should clean and re-run this test or remove the file " +;; =not-used= dbpath ".\n " +;; =not-used= ((condition-property-accessor 'exn 'message) exn)) +;; =not-used= #f) +;; =not-used= ;; Is there a cheaper single line operation that will check for existance of a table +;; =not-used= ;; and raise an exception ? +;; =not-used= (sqlite3:execute db "SELECT id FROM test_data LIMIT 1;")) +;; =not-used= db) +;; =not-used= ;; no work-area or not readable - create a placeholder to fake rest of world out +;; =not-used= (let ((baddb (sqlite3:open-database ":memory:"))) +;; =not-used= (debug:print-info 11 *default-log-port* "open-test-db END (unsucessful)" work-area) +;; =not-used= ;; provide an in-mem db (this is dangerous!) +;; =not-used= (tdb:testdb-initialize baddb) +;; =not-used= baddb))) +;; =not-used= +;; =not-used= ;; find and open the testdat.db file for an existing test +;; =not-used= (define (tdb:open-test-db-by-test-id test-id #!key (work-area #f)) +;; =not-used= (let* ((test-path (if work-area +;; =not-used= work-area +;; =not-used= (rmt:test-get-rundir-from-test-id test-id)))) +;; =not-used= (debug:print 3 *default-log-port* "TEST PATH: " test-path) +;; =not-used= (open-test-db test-path))) +;; =not-used= +;; =not-used= ;; find and open the testdat.db file for an existing test +;; =not-used= (define (tdb:open-test-db-by-test-id-local dbstruct run-id test-id #!key (work-area #f)) +;; =not-used= (let* ((test-path (if work-area +;; =not-used= work-area +;; =not-used= (db:test-get-rundir-from-test-id dbstruct run-id test-id)))) +;; =not-used= (debug:print 3 *default-log-port* "TEST PATH: " test-path) +;; =not-used= (open-test-db test-path))) +;; =not-used= +;; =not-used= ;; find and open the testdat.db file for an existing test +;; =not-used= (define (tdb:open-run-close-db-by-test-id-local dbstruct run-id test-id work-area proc . params) +;; =not-used= (let* ((test-path (if work-area +;; =not-used= work-area +;; =not-used= (db:test-get-rundir-from-test-id dbstruct run-id test-id))) +;; =not-used= (tdb (open-test-db test-path))) +;; =not-used= (apply proc tdb params))) +;; =not-used= +;; =not-used= (define (tdb:testdb-initialize db) +;; =not-used= (debug:print 11 *default-log-port* "db:testdb-initialize START") +;; =not-used= (sqlite3:with-transaction +;; =not-used= db +;; =not-used= (lambda () +;; =not-used= (for-each +;; =not-used= (lambda (sqlcmd) +;; =not-used= (sqlite3:execute db sqlcmd)) +;; =not-used= (list "CREATE TABLE IF NOT EXISTS test_rundat ( +;; =not-used= id INTEGER PRIMARY KEY, +;; =not-used= update_time TIMESTAMP, +;; =not-used= cpuload INTEGER DEFAULT -1, +;; =not-used= diskfree INTEGER DEFAULT -1, +;; =not-used= diskusage INTGER DEFAULT -1, +;; =not-used= run_duration INTEGER DEFAULT 0);" +;; =not-used= "CREATE TABLE IF NOT EXISTS test_data ( +;; =not-used= id INTEGER PRIMARY KEY, +;; =not-used= test_id INTEGER, +;; =not-used= category TEXT DEFAULT '', +;; =not-used= variable TEXT, +;; =not-used= value REAL, +;; =not-used= expected REAL, +;; =not-used= tol REAL, +;; =not-used= units TEXT, +;; =not-used= comment TEXT DEFAULT '', +;; =not-used= status TEXT DEFAULT 'n/a', +;; =not-used= type TEXT DEFAULT '', +;; =not-used= CONSTRAINT test_data_constraint UNIQUE (test_id,category,variable));" +;; =not-used= "CREATE TABLE IF NOT EXISTS test_steps ( +;; =not-used= id INTEGER PRIMARY KEY, +;; =not-used= test_id INTEGER, +;; =not-used= stepname TEXT, +;; =not-used= state TEXT DEFAULT 'NOT_STARTED', +;; =not-used= status TEXT DEFAULT 'n/a', +;; =not-used= event_time TIMESTAMP, +;; =not-used= comment TEXT DEFAULT '', +;; =not-used= logfile TEXT DEFAULT '', +;; =not-used= CONSTRAINT test_steps_constraint UNIQUE (test_id,stepname,state));" +;; =not-used= ;; test_meta can be used for handing commands to the test +;; =not-used= ;; e.g. KILLREQ +;; =not-used= ;; the ackstate is set to 1 once the command has been completed +;; =not-used= "CREATE TABLE IF NOT EXISTS test_meta ( +;; =not-used= id INTEGER PRIMARY KEY, +;; =not-used= var TEXT, +;; =not-used= val TEXT, +;; =not-used= ackstate INTEGER DEFAULT 0, +;; =not-used= CONSTRAINT metadat_constraint UNIQUE (var));")))) +;; =not-used= (debug:print 11 *default-log-port* "db:testdb-initialize END")) +;; =not-used= +;; =not-used= ;; This routine moved to db:read-test-data +;; =not-used= ;; +;; =not-used= (define (tdb:read-test-data tdb test-id categorypatt) +;; =not-used= (let ((res '())) +;; =not-used= (sqlite3:for-each-row +;; =not-used= (lambda (id test_id category variable value expected tol units comment status type) +;; =not-used= (set! res (cons (vector id test_id category variable value expected tol units comment status type) res))) +;; =not-used= tdb +;; =not-used= "SELECT id,test_id,category,variable,value,expected,tol,units,comment,status,type FROM test_data WHERE test_id=? AND category LIKE ? ORDER BY category,variable;" test-id categorypatt) +;; =not-used= (sqlite3:finalize! tdb) +;; =not-used= (reverse res))) ;;====================================================================== ;; T E S T D A T A ;;====================================================================== @@ -248,14 +248,10 @@ (loop (read-line))))) ;; roll up the current results. ;; FIXME: Add the status too (rmt:test-data-rollup run-id test-id #f)) -(define (tdb:get-prev-tol-for-test tdb test-id category variable) - ;; Finish me? - (values #f #f #f)) - ;;====================================================================== ;; S T E P S ;;====================================================================== (define (tdb:step-get-time-as-string vec) Index: tests.scm ================================================================== --- tests.scm +++ tests.scm @@ -127,26 +127,11 @@ '()) (if itemmap-table itemmap-table '())))) -;; given a list of itemmaps (testname . map), return the first match -;; -(define (tests:lookup-itemmap itemmaps testname) - (let ((best-matches (filter (lambda (itemmap) - (tests:match (car itemmap) testname #f)) - itemmaps))) - (if (null? best-matches) - #f - (let ((res (car best-matches))) - ;; (debug:print 0 *default-log-port* "res=" res) - (cond - ((string? res) res) ;;; FIX THE ROOT CAUSE HERE .... - ((null? res) #f) - ((string? (cdr res)) (cdr res)) ;; it is a pair - ((string? (cadr res))(cadr res)) ;; it is a list - (else cadr res)))))) + (define (tests:get-global-waitons rconfig) (let* ((global-waitons (runconfigs-get rconfig "!GLOBAL_WAITONS"))) (if (string? global-waitons) (string-split global-waitons) @@ -294,84 +279,10 @@ (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)) - (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) - (let ((patts (append (string-split patterns ",") required))) - (if (null? patts) ;;; no pattern(s) means no match - #f - (let loop ((patt (car patts)) - (tal (cdr patts))) - ;; (print "loop: patt: " patt ", tal " tal) - (if (string=? patt "") - #f ;; nothing ever matches empty string - policy - (let* ((patt-parts (string-match (regexp "^([^\\/]*)(\\/(.*)|)$") patt)) - (test-patt (cadr patt-parts)) - (item-patt (cadddr patt-parts))) - ;; special case: test vs. test/ - ;; test => "test" "%" - ;; test/ => "test" "" - (if (and (not (substring-index "/" patt)) ;; no slash in the original - (or (not item-patt) - (equal? item-patt ""))) ;; should always be true that item-patt is "" - (set! item-patt "%")) - ;; (print "tests:match => patt-parts: " patt-parts ", test-patt: " test-patt ", item-patt: " item-patt) - (if (and (tests:glob-like-match test-patt testname) - (or (not itempath) - (tests:glob-like-match (if item-patt item-patt "") itempath))) - #t - (if (null? tal) - #f - (loop (car tal)(cdr tal))))))))))) - -;; if itempath is #f then look only at the testname part -;; -(define (tests:match->sqlqry patterns) - (if (string? patterns) - (let ((patts (string-split patterns ","))) - (if (null? patts) ;;; no pattern(s) means no match, we will do no query - #f - (let loop ((patt (car patts)) - (tal (cdr patts)) - (res '())) - ;; (print "loop: patt: " patt ", tal " tal) - (let* ((patt-parts (string-match (regexp "^([^\\/]*)(\\/(.*)|)$") patt)) - (test-patt (cadr patt-parts)) - (item-patt (cadddr patt-parts)) - (test-qry (db:patt->like "testname" test-patt)) - (item-qry (db:patt->like "item_path" item-patt)) - (qry (conc "(" test-qry " AND " item-qry ")"))) - ;; (print "tests:match => patt-parts: " patt-parts ", test-patt: " test-patt ", item-patt: " item-patt) - (if (null? tal) - (string-intersperse (append (reverse res)(list qry)) " OR ") - (loop (car tal)(cdr tal)(cons qry res))))))) - #f)) - ;; 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))