Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -131,10 +131,14 @@ chmod a+x $@ $(PREFIX)/bin/nbfake : utils/nbfake $(INSTALL) $< $@ chmod a+x $@ + +$(PREFIX)/bin/remrun : utils/remrun + $(INSTALL) $< $@ + chmod a+x $@ $(PREFIX)/bin/viewscreen : utils/viewscreen $(INSTALL) $< $@ chmod a+x $@ @@ -169,11 +173,11 @@ $(INSTALL) dboard $(PREFIX)/bin/.$(ARCHSTR)/dboard install : $(PREFIX)/bin/.$(ARCHSTR) $(PREFIX)/bin/.$(ARCHSTR)/mtest $(PREFIX)/bin/megatest \ $(PREFIX)/bin/.$(ARCHSTR)/dboard $(PREFIX)/bin/dashboard $(HELPERS) $(PREFIX)/bin/nbfake \ $(PREFIX)/bin/nbfind $(PREFIX)/bin/loadrunner $(PREFIX)/bin/viewscreen $(PREFIX)/bin/mt_xterm \ - $(PREFIX)/share/docs/megatest_manual.html + $(PREFIX)/share/docs/megatest_manual.html $(PREFIX)/bin/remrun $(PREFIX)/bin/.$(ARCHSTR) : mkdir -p $(PREFIX)/bin/.$(ARCHSTR) test: tests/tests.scm @@ -211,11 +215,11 @@ # chicken-install -prefix deploytarg -deploy $$i;done # deploytarg/libsqlite3.so : # CSC_OPTIONS="-Ideploytarg -Ldeploytarg" $CHICKEN_INSTALL -prefix deploytarg -deploy sqlite3 -deploy : deploytarg/mtest deploytarg/dboard $(DEPLOYHELPERS) deploytarg/nbfake deploytarg/viewsceen deploytarg/nbfind deploytarg/apropos.so +deploy : deploytarg/mtest deploytarg/dboard $(DEPLOYHELPERS) deploytarg/nbfake deploytarg/remrun deploytarg/viewsceen deploytarg/nbfind deploytarg/apropos.so # deploytarg/libiupcd.so : $(CKPATH)/lib/libiupcd.so # for i in iup im cd av call sqlite; do \ # cp $(CKPATH)/lib/lib$$i* deploytarg/ ; \ # done Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -131,28 +131,37 @@ (define *toptest-paths* (make-hash-table)) ;; cache toptest path settings here (define *test-paths* (make-hash-table)) ;; cache test-id to test run paths here (define *test-ids* (make-hash-table)) ;; cache run-id, testname, and item-path => test-id (define *test-info* (make-hash-table)) ;; cache the test info records, update the state, status, run_duration etc. from testdat.db -(define *run-info-cache* (make-hash-table)) ;; run info is stable, no need to reget +(define *run-info-cache* (make-hash-table)) ;; run info is stable, no need to reget (define *launch-setup-mutex* (make-mutex)) ;; need to be able to call launch:setup often so mutex it and re-call the real deal only if *toppath* not set (define *homehost-mutex* (make-mutex)) +;; launching and hosts +(defstruct host + (reachable #f) + (last-update 0) + (last-used 0) + (last-cpuload 1)) + +(define *host-loads* (make-hash-table)) + ;; cache environment vars for each run here (define *env-vars-by-run-id* (make-hash-table)) ;; Testconfig and runconfig caches. -(define *testconfigs* (make-hash-table)) ;; test-name => testconfig -(define *runconfigs* (make-hash-table)) ;; target => runconfig +(define *testconfigs* (make-hash-table)) ;; test-name => testconfig +(define *runconfigs* (make-hash-table)) ;; target => runconfig ;; This is a cache of pre-reqs met, don't re-calc in cases where called with same params less than ;; five seconds ago (define *pre-reqs-met-cache* (make-hash-table)) ;; cache of verbosity given string ;; -(define *verbosity-cache* (make-hash-table)) +(define *verbosity-cache* (make-hash-table)) (define (common:clear-caches) (set! *target* (make-hash-table)) (set! *keys* (make-hash-table)) (set! *keyvals* (make-hash-table)) @@ -1127,10 +1136,55 @@ (core-rx ( x c ) (loop (car tal)(cdr tal) loads proc-num phys-num (max-num c core-num))) (else (begin ;; (print "NO MATCH: " hed) (loop (car tal)(cdr tal) loads proc-num phys-num core-num))))))))) + +(define (common:unix-ping hostname) + (let ((res (system (conc "ping -c 1 " hostname " > /dev/null")))) + (eq? res 0))) + +;; ideally put all this info into the db, no need to preserve it across moving homehost +;; +(define (common:get-least-loaded-host hosts) + (if (null? hosts) + #f + ;; + ;; stategy: + ;; sort by last-used and normalized-load + ;; if last-updated > 15 seconds then re-update + ;; take the host with the lowest load with the lowest last-used (i.e. not used for longest time) + ;; + (let ((best-host #f) + (curr-time (current-seconds))) + (for-each + (lambda (hostname) + (let* ((rec (let ((h (hash-table-ref/default *host-loads* hostname #f))) + (if h + h + (let ((h (make-host))) + (hash-table-set! *host-loads* hostname h) + h)))) + ;; if host hasn't been pinged in 15 sec update it's data + (ping-good (if (< (- curr-time (host-last-update rec)) 15) + (host-reachable rec) + (or (host-reachable rec) + (begin + (host-reachable-set! rec (common:unix-ping hostname)) + (host-last-update-set! rec curr-time) + (host-last-cpuload-set! rec (common:get-normalized-cpu-load hostname)) + (host-reachable rec)))))) + (cond + ((not best-host) + (set! best-host hostname)) + ((and ping-good + (< (alist-ref 'adj-core-load (host-last-cpuload rec)) + (alist-ref 'adj-core-load + (host-last-cpuload (hash-table-ref *host-loads* best-host))))) + (set! best-host rec))))) + hosts) + best-host))) (define (common:wait-for-cpuload maxload numcpus waitdelay #!key (count 1000) (msg #f)(remote-host #f)) (let* ((loadavg (common:get-cpu-load remote-host)) (first (car loadavg)) (next (cadr loadavg)) @@ -1629,28 +1683,30 @@ ;;====================================================================== ;; T E S T L A U N C H I N G P E R I T E M W I T H H O S T T Y P E S ;;====================================================================== ;; -;; [host-types] -;; general ssh #{getbgesthost general} -;; nbgeneral nbjob run JOBCOMMAND -log $MT_LINKTREE/$MT_TARGET/$MT_RUNNAME.$MT_TESTNAME-$MT_ITEM_PATH.lgo +;; [hosts] +;; arm cubie01 cubie02 +;; x86_64 zeus xena myth01 +;; allhosts #{g hosts arm} #{g hosts x86_64} ;; -;; [hosts] -;; general cubian xena +;; [host-types] +;; general #MTLOWESTLOAD #{g hosts allhosts} +;; arm #MTLOWESTLOAD #{g hosts arm} +;; nbgeneral nbjob run JOBCOMMAND -log $MT_LINKTREE/$MT_TARGET/$MT_RUNNAME.$MT_TESTNAME-$MT_ITEM_PATH.lgo ;; ;; [launchers] ;; envsetup general ;; xor/%/n 4C16G ;; % nbgeneral ;; ;; [jobtools] -;; launcher bsub -;; # if defined and not "no" flexi-launcher will bypass launcher unless there is no -;; # match. +;; # if defined and not "no" flexi-launcher will bypass "launcher" unless no match. ;; flexi-launcher yes - +;; launcher nbfake +;; (define (common:get-launcher configdat testname itempath) (let ((fallback-launcher (configf:lookup configdat "jobtools" "launcher"))) (if (and (configf:lookup configdat "jobtools" "flexi-launcher") ;; overrides launcher (not (equal? (configf:lookup configdat "jobtools" "flexi-launcher") "no"))) (let* ((launchers (hash-table-ref/default configdat "launchers" '()))) @@ -1663,11 +1719,16 @@ (if (tests:match patt testname itempath) (begin (debug:print-info 2 *default-log-port* "Have flexi-launcher match for " testname "/" itempath " = " host-type) (let ((launcher (configf:lookup configdat "host-types" host-type))) (if launcher - launcher + (let* ((launcher-parts (string-split launcher)) + (launcher-exe (car launcher-parts))) + (if (equal? launcher-exe "#MTLOWESTLOAD") ;; this is our special case, we will find the lowest load and craft a nbfake commandline + (let ((targ-host (common:get-least-loaded-host (cdr launcher-parts)))) + (conc "remrun " targ-host)) + launcher)) (begin (debug:print-info 0 *default-log-port* "WARNING: no launcher found for host-type " host-type) (if (null? tal) fallback-launcher (loop (car tal)(cdr tal))))))) Index: configf.scm ================================================================== --- configf.scm +++ configf.scm @@ -57,10 +57,11 @@ ;;====================================================================== ;; Make the regexp's needed globally available ;;====================================================================== (define configf:include-rx (regexp "^\\[include\\s+(.*)\\]\\s*$")) +(define configf:script-rx (regexp "^\\[scriptinc\\s+(.*)\\]\\s*$")) ;; include output from a script (define configf:section-rx (regexp "^\\[(.*)\\]\\s*$")) (define configf:blank-l-rx (regexp "^\\s*$")) (define configf:key-sys-pr (regexp "^(\\S+)\\s+\\[system\\s+(\\S+.*)\\]\\s*$")) (define configf:key-val-pr (regexp "^(\\S+)(\\s+(.*)|())$")) (define configf:key-no-val (regexp "^(\\S+)(\\s*)$")) @@ -68,11 +69,11 @@ (define configf:cont-ln-rx (regexp "^(\\s+)(\\S+.*)$")) (define configf:settings (regexp "^\\[configf:settings\\s+(\\S+)\\s+(\\S+)]\\s*$")) ;; read a line and process any #{ ... } constructs -(define configf:var-expand-regex (regexp "^(.*)#\\{(scheme|system|shell|getenv|get|runconfigs-get|rget)\\s+([^\\}\\{]*)\\}(.*)")) +(define configf:var-expand-regex (regexp "^(.*)#\\{(scheme|system|shell|getenv|get|runconfigs-get|rget|scm|sh|rp|gv|g|mtrah)\\s+([^\\}\\{]*)\\}(.*)")) (define (configf:process-line l ht allow-system #!key (linenum #f)) (let loop ((res l)) (if (string? res) (let ((matchdat (string-search configf:var-expand-regex res))) @@ -83,36 +84,42 @@ (poststr (list-ref matchdat 4)) (result #f) (start-time (current-seconds)) (cmdsym (string->symbol cmdtype)) (fullcmd (case cmdsym - ((scheme)(conc "(lambda (ht)" cmd ")")) - ((system)(conc "(lambda (ht)(system \"" cmd "\"))")) - ((shell) (conc "(lambda (ht)(shell \"" cmd "\"))")) - ((getenv)(conc "(lambda (ht)(get-environment-variable \"" cmd "\"))")) - ((get) + ((scheme scm) (conc "(lambda (ht)" cmd ")")) + ((system) (conc "(lambda (ht)(system \"" cmd "\"))")) + ((shell sh) (conc "(lambda (ht)(string-translate (shell \"" cmd "\") \"\n\" \" \"))")) + ((realpath rp)(conc "(lambda (ht)(common:nice-path \"" cmd "\"))")) + ((getenv gv) (conc "(lambda (ht)(get-environment-variable \"" cmd "\"))")) + ((mtrah) (conc "(lambda (ht)" + " (let ((extra \"" cmd "\"))" + " (conc (or *toppath* (get-environment-variable \"MT_RUN_AREA_HOME\"))" + " (if (string-null? extra) \"\" \"/\")" + " extra)))")) + ((get g) (let* ((parts (string-split cmd)) (sect (car parts)) (var (cadr parts))) (conc "(lambda (ht)(config-lookup ht \"" sect "\" \"" var "\"))"))) - ((runconfigs-get) (conc "(lambda (ht)(runconfigs-get ht \"" cmd "\"))")) - ((rget) (conc "(lambda (ht)(runconfigs-get ht \"" cmd "\"))")) + ((runconfigs-get rget) (conc "(lambda (ht)(runconfigs-get ht \"" cmd "\"))")) + ;; ((rget) (conc "(lambda (ht)(runconfigs-get ht \"" cmd "\"))")) (else "(lambda (ht)(print \"ERROR\") \"ERROR\")")))) ;; (print "fullcmd=" fullcmd) (handle-exceptions exn (begin (debug:print 0 *default-log-port* "WARNING: failed to process config input \"" l "\"") (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) ;; (print "exn=" (condition->list exn)) - (set! result (conc "#{( " cmdtype ") " cmd"}"))) + (set! result (conc "#{( " cmdtype ") " cmd "}, full expansion: " fullcmd))) (if (or allow-system - (not (member cmdtype '("system" "shell")))) + (not (member cmdtype '("system" "shell" "sh")))) (with-input-from-string fullcmd (lambda () (set! result ((eval (read)) ht)))) - (set! result (conc "#{(" cmdtype ") " cmd "}")))) + (set! result (conc "#{(" cmdtype ") " cmd "}")))) (case cmdsym ((system shell scheme) (let ((delta (- (current-seconds) start-time))) (if (> delta 2) (debug:print-info 0 *default-log-port* "for line \"" l "\"\n command: " cmd " took " delta " seconds to run with output:\n " result) @@ -182,16 +189,19 @@ ;; post-section-procs alist of section-pattern => proc, where: (proc section-name next-section-name ht curr-path) ;; (define (read-config path ht allow-system #!key (environ-patt #f)(curr-section #f)(sections #f)(settings (make-hash-table))(keep-filenames #f)(post-section-procs '())) (debug:print-info 5 *default-log-port* "read-config " path " allow-system " allow-system " environ-patt " environ-patt " curr-section: " curr-section " sections: " sections " pwd: " (current-directory)) (debug:print 9 *default-log-port* "START: " path) - (if (not (file-exists? path)) + (if (and (not (port? path)) + (not (file-exists? path))) ;; for case where we are handed a port (begin (debug:print-info 1 *default-log-port* "read-config - file not found " path " current path: " (current-directory)) ;; WARNING: This is a risky change but really, we should not return an empty hash table if no file read? #f) ;; (if (not ht)(make-hash-table) ht)) - (let ((inp (open-input-file path)) + (let ((inp (if (string? path) + (open-input-file path) + path)) ;; we can be handed a port (res (if (not ht)(make-hash-table) ht)) (metapath (if (or (debug:debug-mode 9) keep-filenames) path #f))) (let loop ((inl (configf:read-line inp res (calc-allow-system allow-system curr-section sections) settings)) ;; (read-line inp)) @@ -199,11 +209,12 @@ (var-flag #f);; turn on for key-var-pr and cont-ln-rx, turn off elsewhere (lead #f)) (debug:print-info 8 *default-log-port* "curr-section-name: " curr-section-name " var-flag: " var-flag "\n inl: \"" inl "\"") (if (eof-object? inl) (begin - (close-input-port inp) + (if (string? path) ;; we received a path, not a port, thus we are responsible for closing it. + (close-input-port inp)) (hash-table-delete! res "") ;; we are using "" as a dumping ground and must remove it before returning the ht (debug:print 9 *default-log-port* "END: " path) res) (regex-case inl @@ -229,10 +240,26 @@ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)) (begin (debug:print '(2 9) #f "INFO: include file " include-file " not found (called from " path ")") (debug:print 2 *default-log-port* " " full-conf) (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))))) + (configf:script-rx ( x include-script );; handle-exceptions + ;; exn + ;; (begin + ;; (debug:print '(0 2 9) #f "INFO: include from script " include-script " failed.") + ;; (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)) + (if (and (file-exists? include-script)(file-execute-access? include-script)) + (let* ((new-inp-port (open-input-pipe include-script))) + (debug:print '(2 9) *default-log-port* "Including from script output: " include-script) + ;; (print "We got here, calling read-config next. Port is: " new-inp-port) + (read-config new-inp-port res allow-system environ-patt: environ-patt curr-section: curr-section-name sections: sections settings: settings keep-filenames: keep-filenames) + (close-input-port new-inp-port) + (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)) + (begin + (debug:print 0 *default-log-port* "Script not found or not exectutable: " include-script) + (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))) + ) ;; ) (configf:section-rx ( x section-name ) (begin ;; call post-section-procs (for-each (lambda (dat) (let ((patt (car dat)) Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -18,10 +18,13 @@ (require-extension (srfi 18) extras tcp) ;; RADT => use of require-extension? (use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64 format dot-locking z3 typed-records) (import (prefix sqlite3 sqlite3:)) (import (prefix base64 base64:)) ;; RADT => prefix?? +(include "/nfs/site/disks/icf_fdk_cw_gwa002/srehman/fossil/dbi/dbi.scm") +(import (prefix dbi dbi:)) + (declare (unit db)) (declare (uses common)) (declare (uses keys)) (declare (uses ods)) (declare (uses client)) @@ -82,11 +85,12 @@ default (begin (debug:print-error 0 *default-log-port* " query " stmt " failed, params: " params ", error: " ((condition-property-accessor 'exn 'message) exn)) (print-call-chain (current-error-port)) default))) - (apply sqlite3:first-result db stmt params))) + ;;(apply dbi:get-one db stmt params))) + (apply dbi:get-one db stmt params))) ;; Get/open a database ;; if run-id => get run specific db ;; if #f => get main db ;; if db already open - return inmem @@ -131,11 +135,11 @@ (db:get-db dbstruct run-id) (begin (print-call-chain) (print "db:with-db called with dbdat instead of dbstruct, FIXME!!") dbstruct))) ;; cheat, allow for passing in a dbdat - (db (db:dbdat-get-db dbdat))) + (db (db:dbdat-get-db dbdat))) (handle-exceptions exn (begin (debug:print-error 0 *default-log-port* "sqlite3 issue in db:with-db, dbstruct=" dbstruct ", run-id=" run-id ", proc=" proc ", params=" params " error: " ((condition-property-accessor 'exn 'message) exn)) (print-call-chain (current-error-port))) @@ -193,11 +197,11 @@ ;; (or (configf:lookup *configdat* "setup" "dbdir") ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db"))) (define (db:set-sync db) (let ((syncprag (configf:lookup *configdat* "setup" "sychronous"))) - (sqlite3:execute db (conc "PRAGMA synchronous = " (or syncprag 0) ";")))) + (dbi:exec db (conc "PRAGMA synchronous = " (or syncprag 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 ;; @@ -205,28 +209,31 @@ (let* ((parent-dir (or (pathname-directory fname)(current-directory))) ;; no parent? go local (dir-writable (file-write-access? parent-dir)) (file-exists (file-exists? fname)) (file-write (if file-exists (file-write-access? fname) - dir-writable ))) + dir-writable )) + (dbdat (cons (cons 'dbname fname) '()))) (if file-write ;; dir-writable (let (;; (lock (obtain-dot-lock fname 1 5 10)) - (db (sqlite3:open-database fname))) - (sqlite3:set-busy-handler! db (make-busy-timeout 136000)) + (db (dbi:open 'sqlite3 dbdat))) + ;;(db (sqlite3:open-database fname))) + ;;(sqlite3:set-busy-handler! db (make-busy-timeout 136000)) ;; (db:set-sync db) - (sqlite3:execute db "PRAGMA synchronous = 0;") + (dbi:exec db "PRAGMA synchronous = 0;") (if (not file-exists) (begin (if (string-match "^/tmp/.*" fname) ;; this is a file in /tmp - (sqlite3:execute db "PRAGMA journal_mode=WAL;") + (dbi:exec db "PRAGMA journal_mode=WAL;") (print "Creating " fname " in NON-WAL mode.")) (initproc db))) ;; (release-dot-lock fname) db) (begin (debug:print 2 *default-log-port* "WARNING: opening db in non-writable dir " fname) - (sqlite3:open-database fname))))) ;; ) + (dbi:open 'sqlite3 dbdat))))) + ;;(sqlite3:open-database fname))))) ;; ) ;; ;; This routine creates the db. It is only called if the db is not already opened ;; ;; ;; (define (db:open-rundb dbstruct run-id #!key (attemptnum 0)(do-not-open #f)) ;; (conc *toppath* "/megatest.db") (car *configinfo*))) ;; (let* ((dbfile (db:dbfile-path run-id)) ;; (conc toppath "/db/" run-id ".db")) @@ -238,17 +245,17 @@ ;; ;; (release-dot-lock dbpath) ;; (if (> attemptnum 2) ;; (debug:print-error 0 *default-log-port* "tried twice, cannot create/initialize db for run-id " run-id ", at path " dbpath) ;; (db:open-rundb dbstruct run-id attemptnum (+ attemptnum 1)))) ;; (db:initialize-run-id-db db) -;; (sqlite3:execute +;; (dbi:exec ;; db ;; "INSERT OR IGNORE INTO tests (id,run_id,testname,event_time,item_path,state,status) VALUES (?,?,'bogustest',strftime('%s','now'),'nowherepath','DELETED','n/a');" ;; (* run-id 30000) ;; allow for up to 30k tests per run ;; run-id) ;; ;; do a dummy query to test that the table exists and the db is truly readable -;; (sqlite3:execute db "SELECT * FROM tests WHERE id=?;" (* run-id 30000)) +;; (dbi:exec db "SELECT * FROM tests WHERE id=?;" (* run-id 30000)) ;; )))) ;; add strings db to rundb, not in use yet ;; (olddb (if *megatest-db* ;; *megatest-db* ;; (let ((db (db:open-megatest-db))) ;; (set! *megatest-db* db) @@ -345,13 +352,16 @@ (begin ;; (db:sync-touched dbstruct 0 force-sync: #t) ;; NO. Do not do this here. Instead we rely on a server to be started when there are writes, even if the server itself is not going to be used as a server. (let ((tdb (db:dbdat-get-db (dbr:dbstruct-tmpdb dbstruct))) (mdb (db:dbdat-get-db (dbr:dbstruct-mtdb dbstruct))) (rdb (db:dbdat-get-db (dbr:dbstruct-refndb dbstruct)))) - (if tdb (sqlite3:finalize! tdb)) - (if mdb (sqlite3:finalize! mdb)) - (if rdb (sqlite3:finalize! rdb)))))) + (if tdb (dbi:close tdb)) + (if mdb (dbi:close mdb)) + (if rdb (dbi:close rdb)))))) + ;;(if tdb (dbi:close tdb)) + ;;(if mdb (dbi:close mdb)) + ;;(if rdb (dbi:close rdb)))))) ;; (let ((locdbs (dbr:dbstruct-locdbs dbstruct))) ;; (if (hash-table? locdbs) ;; (for-each (lambda (run-id) ;; (db:close-run-db dbstruct run-id)) @@ -469,11 +479,12 @@ ;; else return dbdat ;; (define (db:repair-db dbdat #!key (numtries 1)) (let* ((dbpath (db:dbdat-get-path dbdat)) (dbdir (pathname-directory dbpath)) - (fname (pathname-strip-directory dbpath))) + (fname (pathname-strip-directory dbpath)) + (dbdat '())) (debug:print-info 0 *default-log-port* "Checking db " dbpath " for errors.") (cond ((not (file-write-access? dbdir)) (debug:print 0 *default-log-port* "WARNING: can't write to " dbdir ", can't fix " fname) #f) @@ -501,24 +512,24 @@ "megatest -import-megatest.db;megatest -cleanup-db") "\"\n") (exit) ;; we can not safely continue when a db was corrupted - even if fixed. ) ;; test read/write access to the database - (let ((db (sqlite3:open-database dbpath))) + (let ((db (dbi:open 'sqlite3 (cons (cons ('dbname dbpath) '()))))) (cond ((equal? fname "megatest.db") - (sqlite3:execute db "DELETE FROM tests WHERE state='DELETED';")) + (dbi:exec db "DELETE FROM tests WHERE state='DELETED';")) ((equal? fname "main.db") - (sqlite3:execute db "DELETE FROM runs WHERE state='deleted';")) + (dbi:exec db "DELETE FROM runs WHERE state='deleted';")) ((string-match "\\d.db" fname) - (sqlite3:execute db "UPDATE tests SET state='DELETED' WHERE state='DELETED';")) + (dbi:exec db "UPDATE tests SET state='DELETED' WHERE state='DELETED';")) ((equal? fname "monitor.db") - (sqlite3:execute "DELETE FROM servers WHERE state LIKE 'defunct%';")) + (dbi:exec "DELETE FROM servers WHERE state LIKE 'defunct%';")) (else - (sqlite3:execute db "vacuum;"))) + (dbi:exec db "vacuum;"))) - (finalize! db) + (dbi:close db) #t)))))) ;; tbls is ( ("tablename" ( "field1" [#f|proc1] ) ( "field2" [#f|proc2] ) .... ) ) ;; db's are dbdat's ;; @@ -548,13 +559,13 @@ 0) ;; this is the work to be done (cond ((not fromdb) (debug:print 3 *default-log-port* "WARNING: db:sync-tables called with fromdb missing") -1) ((not todb) (debug:print 3 *default-log-port* "WARNING: db:sync-tables called with todb missing") -2) - ((not (sqlite3:database? (db:dbdat-get-db fromdb))) + ((not (eq? 'sqlite3 (dbi:db-dbtype fromdb))) (debug:print-error 0 *default-log-port* "db:sync-tables called with fromdb not a database " fromdb) -3) - ((not (sqlite3:database? (db:dbdat-get-db todb))) + ((not (eq? 'sqlite3 (dbi:db-dbtype todb))) (debug:print-error 0 *default-log-port* "db:sync-tables called with todb not a database " todb) -4) (else (let ((stmts (make-hash-table)) ;; table-field => stmt (all-stmts '()) ;; ( ( stmt1 value1 ) ( stml2 value2 )) (numrecs (make-hash-table)) @@ -595,11 +606,11 @@ (hash-table-set! field->num field count) (set! count (+ count 1))) fields) ;; read the source table - (sqlite3:for-each-row + (dbi:for-each-row (lambda (a . b) (set! fromdat (cons (apply vector a b) fromdat)) (if (> (length fromdat) batch-len) (begin (set! fromdats (cons fromdat fromdats)) @@ -614,11 +625,11 @@ (if (common:low-noise-print 120 "sync-records") (debug:print-info 4 *default-log-port* "found " totrecords " records to sync")) ;; read the target table - (sqlite3:for-each-row + (dbi:for-each-row (lambda (a . b) (hash-table-set! todat a (apply vector a b))) (db:dbdat-get-db todb) full-sel) @@ -628,11 +639,11 @@ (let* ((db (db:dbdat-get-db targdb)) (stmth (sqlite3:prepare db full-ins))) ;; (db:delay-if-busy targdb) ;; NO WAITING (for-each (lambda (fromdat-lst) - (sqlite3:with-transaction + (dbi:with-transaction db (lambda () (for-each ;; (lambda (fromrow) (let* ((a (vector-ref fromrow 0)) @@ -645,16 +656,16 @@ (if (and same (< i (- num-fields 1))) (loop (+ i 1)))) (if (not same) (begin - (apply sqlite3:execute stmth (vector->list fromrow)) + (apply dbi:exec stmth (vector->list fromrow)) (hash-table-set! numrecs tablename (+ 1 (hash-table-ref/default numrecs tablename 0))))))) fromdat-lst)) )) fromdats) - (sqlite3:finalize! stmth))) + (dbi:close stmth))) (append (list todb) slave-dbs)))) tbls) (let* ((runtime (- (current-milliseconds) start-time)) (should-print (or (debug:debug-mode 12) (common:low-noise-print 120 "db sync" (> runtime 500))))) ;; low and high sync times treated as separate. @@ -678,17 +689,17 @@ (handle-exceptions exn (if (string-match ".*duplicate.*" ((condition-property-accessor 'exn 'message) exn)) (debug:print 0 *default-log-port* "Column last_update already added to " table-name " table") (db:general-sqlite-error-dump exn "alter table " table-name " ..." #f "none")) - (sqlite3:execute + (dbi:exec frundb (conc "ALTER TABLE " table-name " ADD COLUMN last_update INTEGER DEFAULT 0"))) - (sqlite3:execute + (dbi:exec frundb (conc "DROP TRIGGER IF EXISTS update_" table-name "_trigger;")) - (sqlite3:execute + (dbi:exec frundb (conc "CREATE TRIGGER IF NOT EXISTS update_" table-name "_trigger AFTER UPDATE ON " table-name " FOR EACH ROW BEGIN UPDATE " table-name " SET last_update=(strftime('%s','now')) @@ -704,30 +715,30 @@ (handle-exceptions exn (if (string-match ".*duplicate.*" ((condition-property-accessor 'exn 'message) exn)) (debug:print 0 *default-log-port* "Column last_update already added to runs table") (db:general-sqlite-error-dump exn "alter table runs ..." #f "none")) - (sqlite3:execute + (dbi:exec maindb "ALTER TABLE runs ADD COLUMN last_update INTEGER DEFAULT 0")) ;; these schema changes don't need exception handling - (sqlite3:execute + (dbi:exec maindb "CREATE TRIGGER IF NOT EXISTS update_runs_trigger AFTER UPDATE ON runs FOR EACH ROW BEGIN UPDATE runs SET last_update=(strftime('%s','now')) WHERE id=old.id; END;") - (sqlite3:execute maindb "CREATE TABLE IF NOT EXISTS run_stats ( + (dbi:exec maindb "CREATE TABLE IF NOT EXISTS run_stats ( id INTEGER PRIMARY KEY, run_id INTEGER, state TEXT, status TEXT, count INTEGER, last_update INTEGER DEFAULT (strftime('%s','now')))") - (sqlite3:execute maindb "CREATE TRIGGER IF NOT EXISTS update_run_stats_trigger AFTER UPDATE ON run_stats + (dbi:exec maindb "CREATE TRIGGER IF NOT EXISTS update_run_stats_trigger AFTER UPDATE ON run_stats FOR EACH ROW BEGIN UPDATE run_stats SET last_update=(strftime('%s','now')) WHERE id=old.id; END;")) @@ -739,11 +750,11 @@ ;; Add db direct ;; (define (db:dispatch-query access-mode rmt-cmd db-cmd . params) (if (eq? access-mode 'cached) - (print "not doing cached calls right now")) + (debug:print 2 *default-log-port* "not doing cached calls right now")) ;; (apply db:call-with-cached-db db-cmd params) (apply rmt-cmd params)) ;;) ;; return the target db handle so it can be used @@ -857,11 +868,11 @@ ;; (db:delay-if-busy mtdb) ;; (let ((testrecs (db:get-all-tests-info-by-run-id mtdb run-id))) ;; ;; (dbstruct (if toppath (make-dbr:dbstruct path: toppath local: #t) #f))) ;; (debug:print 0 *default-log-port* "INFO: Propagating " (length testrecs) " records for run-id=" run-id " to run specific db") ;; (db:replace-test-records dbstruct run-id testrecs) -;; (sqlite3:finalize! (db:dbdat-get-db (dbr:dbstruct-rundb dbstruct))))) +;; (dbi:close (db:dbdat-get-db (dbr:dbstruct-rundb dbstruct))))) ;; run-ids))) ;; now ensure all newdb data are synced to megatest.db ;; do not use the run-ids list passed in to the function ;; @@ -941,11 +952,11 @@ ;; (debug:print 0 *default-log-port* "Removing database file for deleted run " fullname) ;; (delete-file fullname))))) ;; dead-runs)))) ;; ;; (db:close-all dbstruct) - ;; (sqlite3:finalize! mdb) + ;; (dbi:close mdb) data-synced))) ;; keeping it around for debugging purposes only (define (open-run-close-no-exception-handling proc idb . params) (debug:print-info 11 *default-log-port* "open-run-close-no-exception-handling START given a db=" (if idb "yes " "no ") ", params=" params) @@ -953,17 +964,17 @@ (exit) (if (or *db-write-access* (not #t)) ;; was: (member proc * db:all-write-procs *))) (let* ((db (cond ((pair? idb) (db:dbdat-get-db idb)) - ((sqlite3:database? idb) idb) + ((dbi:database? idb) idb) ((not idb) (debug:print-error 0 *default-log-port* "cannot open-run-close with #f anymore")) ((procedure? idb) (idb)) (else (debug:print-error 0 *default-log-port* "cannot open-run-close with #f anymore")))) (res #f)) (set! res (apply proc db params)) - (if (not idb)(sqlite3:finalize! dbstruct)) + (if (not idb)(dbi:close dbstruct)) (debug:print-info 11 *default-log-port* "open-run-close-no-exception-handling END" ) res) #f)) (define (open-run-close-exception-handling proc idb . params) @@ -1005,18 +1016,18 @@ "pass_count")) (begin (print "ERROR: your key cannot be named " keyn " as this conflicts with the same named field in the runs table, you must remove your megatest.db and /.db before trying again.") (exit 1))))) keys) - (sqlite3:with-transaction + (dbi:with-transaction db (lambda () - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS keys (id INTEGER PRIMARY KEY, fieldname TEXT, fieldtype TEXT, CONSTRAINT keyconstraint UNIQUE (fieldname));") + (dbi:exec db "CREATE TABLE IF NOT EXISTS keys (id INTEGER PRIMARY KEY, fieldname TEXT, fieldtype TEXT, CONSTRAINT keyconstraint UNIQUE (fieldname));") (for-each (lambda (key) - (sqlite3:execute db "INSERT OR REPLACE INTO keys (fieldname,fieldtype) VALUES (?,?);" key "TEXT")) + (dbi:exec db "INSERT OR REPLACE INTO keys (fieldname,fieldtype) VALUES (?,?);" key "TEXT")) keys) - (sqlite3:execute db (conc + (dbi:exec db (conc "CREATE TABLE IF NOT EXISTS runs (id INTEGER PRIMARY KEY, \n " fieldstr (if havekeys "," "") " runname TEXT DEFAULT 'norun', state TEXT DEFAULT '', status TEXT DEFAULT '', @@ -1025,30 +1036,30 @@ comment TEXT DEFAULT '', fail_count INTEGER DEFAULT 0, pass_count INTEGER DEFAULT 0, last_update INTEGER DEFAULT (strftime('%s','now')), CONSTRAINT runsconstraint UNIQUE (runname" (if havekeys "," "") keystr "));")) - (sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_runs_trigger AFTER UPDATE ON runs + (dbi:exec db "CREATE TRIGGER IF NOT EXISTS update_runs_trigger AFTER UPDATE ON runs FOR EACH ROW BEGIN UPDATE runs SET last_update=(strftime('%s','now')) WHERE id=old.id; END;") - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS run_stats ( + (dbi:exec db "CREATE TABLE IF NOT EXISTS run_stats ( id INTEGER PRIMARY KEY, run_id INTEGER, state TEXT, status TEXT, count INTEGER, last_update INTEGER DEFAULT (strftime('%s','now')))") - (sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_run_stats_trigger AFTER UPDATE ON run_stats + (dbi:exec db "CREATE TRIGGER IF NOT EXISTS update_run_stats_trigger AFTER UPDATE ON run_stats FOR EACH ROW BEGIN UPDATE run_stats SET last_update=(strftime('%s','now')) WHERE id=old.id; END;") - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_meta ( + (dbi:exec db "CREATE TABLE IF NOT EXISTS test_meta ( id INTEGER PRIMARY KEY, testname TEXT DEFAULT '', author TEXT DEFAULT '', owner TEXT DEFAULT '', description TEXT DEFAULT '', @@ -1057,11 +1068,11 @@ avg_runtime REAL, avg_disk REAL, tags TEXT DEFAULT '', jobgroup TEXT DEFAULT 'default', CONSTRAINT test_meta_constraint UNIQUE (testname));") - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS tasks_queue (id INTEGER PRIMARY KEY, + (dbi:exec db "CREATE TABLE IF NOT EXISTS tasks_queue (id INTEGER PRIMARY KEY, action TEXT DEFAULT '', owner TEXT, state TEXT DEFAULT 'new', target TEXT DEFAULT '', name TEXT DEFAULT '', @@ -1069,56 +1080,56 @@ keylock TEXT, params TEXT, creation_time TIMESTAMP DEFAULT (strftime('%s','now')), execution_time TIMESTAMP);") ;; archive disk areas, cached info from [archive-disks] - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS archive_disks ( + (dbi:exec db "CREATE TABLE IF NOT EXISTS archive_disks ( id INTEGER PRIMARY KEY, archive_area_name TEXT, disk_path TEXT, last_df INTEGER DEFAULT -1, last_df_time TIMESTAMP DEFAULT (strftime('%s','now')), creation_time TIMESTAMP DEFAULT (strftime('%','now')));") ;; individual bup (or tar) data chunks - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS archive_blocks ( + (dbi:exec db "CREATE TABLE IF NOT EXISTS archive_blocks ( id INTEGER PRIMARY KEY, archive_disk_id INTEGER, disk_path TEXT, last_du INTEGER DEFAULT -1, last_du_time TIMESTAMP DEFAULT (strftime('%s','now')), creation_time TIMESTAMP DEFAULT (strftime('%','now')));") ;; tests allocated to what chunks. reusing a chunk for a test/item_path is very efficient ;; NB// the per run/test recording of where the archive is stored is done in the test ;; record. - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS archive_allocations ( + (dbi:exec db "CREATE TABLE IF NOT EXISTS archive_allocations ( id INTEGER PRIMARY KEY, archive_block_id INTEGER, testname TEXT, item_path TEXT, creation_time TIMESTAMP DEFAULT (strftime('%','now')));") ;; move this clean up call somewhere else - (sqlite3:execute db "DELETE FROM tasks_queue WHERE state='done' AND creation_time < ?;" (- (current-seconds)(* 24 60 60))) ;; remove older than 24 hrs - (sqlite3:execute db (conc "CREATE INDEX IF NOT EXISTS runs_index ON runs (runname" (if havekeys "," "") keystr ");")) - ;; (sqlite3:execute db "CREATE VIEW runs_tests AS SELECT * FROM runs INNER JOIN tests ON runs.id=tests.run_id;") - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS extradat (id INTEGER PRIMARY KEY, run_id INTEGER, key TEXT, val TEXT);") - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS metadat (id INTEGER PRIMARY KEY, var TEXT, val TEXT, + (dbi:exec db "DELETE FROM tasks_queue WHERE state='done' AND creation_time < ?;" (- (current-seconds)(* 24 60 60))) ;; remove older than 24 hrs + (dbi:exec db (conc "CREATE INDEX IF NOT EXISTS runs_index ON runs (runname" (if havekeys "," "") keystr ");")) + ;; (dbi:exec db "CREATE VIEW runs_tests AS SELECT * FROM runs INNER JOIN tests ON runs.id=tests.run_id;") + (dbi:exec db "CREATE TABLE IF NOT EXISTS extradat (id INTEGER PRIMARY KEY, run_id INTEGER, key TEXT, val TEXT);") + (dbi:exec db "CREATE TABLE IF NOT EXISTS metadat (id INTEGER PRIMARY KEY, var TEXT, val TEXT, CONSTRAINT metadat_constraint UNIQUE (var));") - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS access_log (id INTEGER PRIMARY KEY, user TEXT, accessed TIMESTAMP, args TEXT);") + (dbi:exec db "CREATE TABLE IF NOT EXISTS access_log (id INTEGER PRIMARY KEY, user TEXT, accessed TIMESTAMP, args TEXT);") ;; Must do this *after* running patch db !! No more. ;; cannot use db:set-var since it will deadlock, hardwire the code here - (sqlite3:execute db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" "MEGATEST_VERSION" (common:version-signature)) + (dbi:exec db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" "MEGATEST_VERSION" (common:version-signature)) (debug:print-info 11 *default-log-port* "db:initialize END"))))) ;;====================================================================== ;; R U N S P E C I F I C D B ;;====================================================================== (define (db:initialize-run-id-db db) - (sqlite3:with-transaction + (dbi:with-transaction db (lambda () - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS tests + (dbi:exec db "CREATE TABLE IF NOT EXISTS tests (id INTEGER PRIMARY KEY, run_id INTEGER DEFAULT -1, testname TEXT DEFAULT 'noname', host TEXT DEFAULT 'n/a', cpuload REAL DEFAULT -1, @@ -1138,18 +1149,18 @@ fail_count INTEGER DEFAULT 0, pass_count INTEGER DEFAULT 0, archived INTEGER DEFAULT 0, -- 0=no, > 1=archive block id where test data can be found last_update INTEGER DEFAULT (strftime('%s','now')), CONSTRAINT testsconstraint UNIQUE (run_id, testname, item_path));") - (sqlite3:execute db "CREATE INDEX IF NOT EXISTS tests_index ON tests (run_id, testname, item_path);") - (sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_tests_trigger AFTER UPDATE ON tests + (dbi:exec db "CREATE INDEX IF NOT EXISTS tests_index ON tests (run_id, testname, item_path);") + (dbi:exec db "CREATE TRIGGER IF NOT EXISTS update_tests_trigger AFTER UPDATE ON tests FOR EACH ROW BEGIN UPDATE tests SET last_update=(strftime('%s','now')) WHERE id=old.id; END;") - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_steps + (dbi:exec db "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', @@ -1156,18 +1167,18 @@ event_time TIMESTAMP, comment TEXT DEFAULT '', logfile TEXT DEFAULT '', last_update INTEGER DEFAULT (strftime('%s','now')), CONSTRAINT test_steps_constraint UNIQUE (test_id,stepname,state));") - (sqlite3:execute db "CREATE INDEX IF NOT EXISTS teststeps_index ON tests (run_id, testname, item_path);") - (sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_teststeps_trigger AFTER UPDATE ON test_steps + (dbi:exec db "CREATE INDEX IF NOT EXISTS teststeps_index ON tests (run_id, testname, item_path);") + (dbi:exec db "CREATE TRIGGER IF NOT EXISTS update_teststeps_trigger AFTER UPDATE ON test_steps FOR EACH ROW BEGIN UPDATE test_steps SET last_update=(strftime('%s','now')) WHERE id=old.id; END;") - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_data (id INTEGER PRIMARY KEY, + (dbi:exec db "CREATE TABLE IF NOT EXISTS test_data (id INTEGER PRIMARY KEY, test_id INTEGER, category TEXT DEFAULT '', variable TEXT, value REAL, expected REAL, @@ -1176,26 +1187,26 @@ comment TEXT DEFAULT '', status TEXT DEFAULT 'n/a', type TEXT DEFAULT '', last_update INTEGER DEFAULT (strftime('%s','now')), CONSTRAINT test_data_constraint UNIQUE (test_id,category,variable));") - (sqlite3:execute db "CREATE INDEX IF NOT EXISTS test_data_index ON test_data (test_id);") - (sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_test_data_trigger AFTER UPDATE ON test_data + (dbi:exec db "CREATE INDEX IF NOT EXISTS test_data_index ON test_data (test_id);") + (dbi:exec db "CREATE TRIGGER IF NOT EXISTS update_test_data_trigger AFTER UPDATE ON test_data FOR EACH ROW BEGIN UPDATE test_data SET last_update=(strftime('%s','now')) WHERE id=old.id; END;") - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_rundat ( + (dbi:exec db "CREATE TABLE IF NOT EXISTS test_rundat ( id INTEGER PRIMARY KEY, test_id INTEGER, update_time TIMESTAMP, cpuload INTEGER DEFAULT -1, diskfree INTEGER DEFAULT -1, diskusage INTGER DEFAULT -1, run_duration INTEGER DEFAULT 0);") - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS archives ( + (dbi:exec db "CREATE TABLE IF NOT EXISTS archives ( id INTEGER PRIMARY KEY, test_id INTEGER, state TEXT DEFAULT 'new', status TEXT DEFAULT 'n/a', archive_type TEXT DEFAULT 'bup', @@ -1214,11 +1225,11 @@ (define (db:archive-get-allocations dbstruct testname itempath dneeded) (let* ((dbdat (db:get-db dbstruct #f)) ;; archive tables are in main.db (db (db:dbdat-get-db dbdat)) (res '()) (blocks '())) ;; a block is an archive chunck that can be added too if there is space - (sqlite3:for-each-row + (dbi:for-each-row (lambda (id archive-disk-id disk-path last-du last-du-time) (set! res (cons (vector id archive-disk-id disk-path last-du last-du-time) res))) db "SELECT b.id,b.archive_disk_id,b.disk_path,b.last_du,b.last_du_time FROM archive_blocks AS b INNER JOIN archive_allocations AS a ON a.archive_block_id=b.id @@ -1225,11 +1236,11 @@ WHERE a.testname=? AND a.item_path=?;" testname itempath) ;; Now res has list of candidate paths, look in archive_disks for candidate with potential free space (if (null? res) '() - (sqlite3:for-each-row + (dbi:for-each-row (lambda (id archive-area-name disk-path last-df last-df-time) (set! blocks (cons (vector id archive-area-name disk-path last-df last-df-time) blocks))) db (conc "SELECT d.id,d.archive_area_name,disk_path,last_df,last_df_time FROM archive_disks AS d @@ -1244,24 +1255,24 @@ ;; (define (db:archive-register-disk dbstruct bdisk-name bdisk-path df) (let* ((dbdat (db:get-db dbstruct #f)) ;; archive tables are in main.db (db (db:dbdat-get-db dbdat)) (res #f)) - (sqlite3:for-each-row + (dbi:for-each-row (lambda (id) (set! res id)) db "SELECT id FROM archive_disks WHERE archive_area_name=? AND disk_path=?;" bdisk-name bdisk-path) (if res ;; record exists, update df and return id (begin - (sqlite3:execute db "UPDATE archive_disks SET last_df=?,last_df_time=(strftime('%s','now')) + (dbi:exec db "UPDATE archive_disks SET last_df=?,last_df_time=(strftime('%s','now')) WHERE archive_area_name=? AND disk_path=?;" df bdisk-name bdisk-path) res) (begin - (sqlite3:execute + (dbi:exec db "INSERT OR REPLACE INTO archive_disks (archive_area_name,disk_path,last_df) VALUES (?,?,?);" bdisk-name bdisk-path df) (db:archive-register-disk dbstruct bdisk-name bdisk-path df))))) @@ -1273,24 +1284,24 @@ (define (db:archive-register-block-name dbstruct bdisk-id archive-path #!key (du #f)) (let* ((dbdat (db:get-db dbstruct #f)) ;; archive tables are in main.db (db (db:dbdat-get-db dbdat)) (res #f)) ;; first look to see if this path is already registered - (sqlite3:for-each-row + (dbi:for-each-row (lambda (id) (set! res id)) db "SELECT id FROM archive_blocks WHERE archive_disk_id=? AND disk_path=?;" bdisk-id archive-path) (if res ;; record exists, update du if applicable and return res (begin - (if du (sqlite3:exectute db "UPDATE archive_blocks SET last_du=?,last_du_time=(strftime('%s','now')) + (if du (dbi:exec db "UPDATE archive_blocks SET last_du=?,last_du_time=(strftime('%s','now')) WHERE archive_disk_id=? AND disk_path=?;" bdisk-id archive-path du)) res) (begin - (sqlite3:execute db "INSERT OR REPLACE INTO archive_blocks (archive_disk_id,disk_path,last_du) + (dbi:exec db "INSERT OR REPLACE INTO archive_blocks (archive_disk_id,disk_path,last_du) VALUES (?,?,?);" bdisk-id archive-path (or du 0)) (db:archive-register-block-name dbstruct bdisk-id archive-path du: du))))) @@ -1300,11 +1311,11 @@ (db:with-db dbstruct run-id #f (lambda (db) - (sqlite3:execute db "UPDATE tests SET archived=? WHERE id=?;" + (dbi:exec db "UPDATE tests SET archived=? WHERE id=?;" archive-block-id test-id)))) ;; Look up the archive block info given a block-id ;; (define (db:test-get-archive-block-info dbstruct archive-block-id) @@ -1312,11 +1323,11 @@ dbstruct #f #f (lambda (db) (let ((res #f)) - (sqlite3:for-each-row + (dbi:for-each-row ;; 0 1 2 3 4 5 (lambda (id archive-disk-id disk-path last-du last-du-time creation-time) (set! res (vector id archive-disk-id disk-path last-du last-du-time creation-time))) db "SELECT id,archive_disk_id,disk_path,last_du,last_du_time,creation_time FROM archive_blocks WHERE id=?;" @@ -1326,43 +1337,43 @@ ;; (define (db:archive-allocate-testsuite/area-to-block block-id testsuite-name areakey) ;; (let* ((dbdat (db:get-db dbstruct #f)) ;; archive tables are in main.db ;; (db (db:dbdat-get-db dbdat)) ;; (res '()) ;; (blocks '())) ;; a block is an archive chunck that can be added too if there is space -;; (sqlite3:for-each-row #f) +;; (dbi:for-each-row #f) ;;====================================================================== ;; L O G G I N G D B ;;====================================================================== (define (open-logging-db) (let* ((dbpath (conc (if *toppath* (conc *toppath* "/") "") "logging.db")) ;; fname) (dbexists (file-exists? dbpath)) - (db (sqlite3:open-database dbpath)) + (db (dbi:open 'sqlite3 (cons (cons ('dbname dbpath) '())))) (handler (make-busy-timeout (if (args:get-arg "-override-timeout") (string->number (args:get-arg "-override-timeout")) 136000)))) ;; 136000))) - (sqlite3:set-busy-handler! db handler) + ;;(sqlite3:set-busy-handler! db handler) (if (not dbexists) (begin - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS log (id INTEGER PRIMARY KEY,event_time TIMESTAMP DEFAULT (strftime('%s','now')),logline TEXT,pwd TEXT,cmdline TEXT,pid INTEGER);") - (db:set-sync db) ;; (sqlite3:execute db (conc "PRAGMA synchronous = 0;")) + (dbi:exec db "CREATE TABLE IF NOT EXISTS log (id INTEGER PRIMARY KEY,event_time TIMESTAMP DEFAULT (strftime('%s','now')),logline TEXT,pwd TEXT,cmdline TEXT,pid INTEGER);") + (db:set-sync db) ;; (dbi:exec db (conc "PRAGMA synchronous = 0;")) )) db)) (define (db:log-local-event . loglst) (let ((logline (apply conc loglst))) (db:log-event logline))) (define (db:log-event logline) (let ((db (open-logging-db))) - (sqlite3:execute db "INSERT INTO log (logline,pwd,cmdline,pid) VALUES (?,?,?,?);" + (dbi:exec db "INSERT INTO log (logline,pwd,cmdline,pid) VALUES (?,?,?,?);" logline (current-directory) (string-intersperse (argv) " ") (current-process-id)) - (sqlite3:finalize! db) + (dbi:close db) logline)) ;;====================================================================== ;; D B U T I L S ;;====================================================================== @@ -1389,11 +1400,11 @@ ;; HOWEVER: this code in run:test seems to work fine ;; (> (- (current-seconds)(+ (db:test-get-event_time testdat) ;; (db:test-get-run_duration testdat))) ;; 600) ;; (db:delay-if-busy dbdat) - (sqlite3:for-each-row + (dbi:for-each-row (lambda (test-id run-dir uname testname item-path) (if (and (equal? uname "n/a") (equal? item-path "")) ;; this is a toplevel test ;; what to do with toplevel? call rollup? (begin @@ -1405,11 +1416,11 @@ run-id deadtime) ;; in LAUNCHED for more than one day. Could be long due to job queues TODO/BUG: Need override for this in config ;; ;; (db:delay-if-busy dbdat) - (sqlite3:for-each-row + (dbi:for-each-row (lambda (test-id run-dir uname testname item-path) (if (and (equal? uname "n/a") (equal? item-path "")) ;; this is a toplevel test ;; what to do with toplevel? call rollup? (set! toplevels (cons (list test-id run-dir uname testname item-path run-id) toplevels)) @@ -1453,11 +1464,11 @@ ;; HOWEVER: this code in run:test seems to work fine ;; (> (- (current-seconds)(+ (db:test-get-event_time testdat) ;; (db:test-get-run_duration testdat))) ;; 600) ;; (db:delay-if-busy dbdat) - (sqlite3:for-each-row + (dbi:for-each-row (lambda (test-id run-dir uname testname item-path) (if (and (equal? uname "n/a") (equal? item-path "")) ;; this is a toplevel test ;; what to do with toplevel? call rollup? (begin @@ -1469,11 +1480,11 @@ run-id deadtime) ;; in LAUNCHED for more than one day. Could be long due to job queues TODO/BUG: Need override for this in config ;; ;; (db:delay-if-busy dbdat) - (sqlite3:for-each-row + (dbi:for-each-row (lambda (test-id run-dir uname testname item-path) (if (and (equal? uname "n/a") (equal? item-path "")) ;; this is a toplevel test ;; what to do with toplevel? call rollup? (set! toplevels (cons (list test-id run-dir uname testname item-path run-id) toplevels)) @@ -1497,11 +1508,11 @@ (min-incompleted-ids (map car incompleted)) ;; do 'em all (all-ids (append min-incompleted-ids (map car oldlaunched)))) (if (> (length all-ids) 0) (begin (debug:print 0 *default-log-port* "WARNING: Marking test(s); " (string-intersperse (map conc all-ids) ", ") " as INCOMPLETE") - (sqlite3:execute + (dbi:exec db (conc "UPDATE tests SET state='INCOMPLETE' WHERE run_id=? AND id IN (" (string-intersperse (map conc all-ids) ",") ");") run-id)))) @@ -1534,14 +1545,14 @@ ;; b. .... ;; (define (db:clean-up dbdat) ;; (debug:print 0 *default-log-port* "WARNING: db clean up not fully ported to v1.60, cleanup action will be on megatest.db") (let* ((db (db:dbdat-get-db dbdat)) - (count-stmt (sqlite3:prepare db "SELECT (SELECT count(id) FROM tests)+(SELECT count(id) FROM runs);")) + (count (dbi:get-one db "SELECT (SELECT count(id) FROM tests)+(SELECT count(id) FROM runs);")) (statements (map (lambda (stmt) - (sqlite3:prepare db stmt)) + (dbi:exec db stmt)) (list ;; delete all tests that belong to runs that are 'deleted' "DELETE FROM tests WHERE run_id in (SELECT id FROM runs WHERE state='deleted');" ;; delete all tests that are 'DELETED' "DELETE FROM tests WHERE state='DELETED';" @@ -1551,25 +1562,25 @@ "DELETE FROM runs WHERE state='deleted';" ;; delete empty runs "DELETE FROM runs WHERE id NOT IN (SELECT DISTINCT r.id FROM runs AS r INNER JOIN tests AS t ON t.run_id=r.id);" )))) ;; (db:delay-if-busy dbdat) - (sqlite3:with-transaction + (dbi:with-transaction db (lambda () - (sqlite3:for-each-row (lambda (tot) + (dbi:for-each-row (lambda (tot) (debug:print-info 0 *default-log-port* "Records count before clean: " tot)) count-stmt) - (map sqlite3:execute statements) - (sqlite3:for-each-row (lambda (tot) + (map dbi:exec statements) + (dbi:for-each-row (lambda (tot) (debug:print-info 0 *default-log-port* "Records count after clean: " tot)) count-stmt))) - (map sqlite3:finalize! statements) - (sqlite3:finalize! count-stmt) + (map dbi:close statements) + (dbi:close count-stmt) ;; (db:find-and-mark-incomplete db) ;; (db:delay-if-busy dbdat) - (sqlite3:execute db "VACUUM;"))) + (dbi:exec db "VACUUM;"))) ;; Clean out old junk and vacuum the database ;; ;; Ultimately do something like this: ;; @@ -1592,25 +1603,25 @@ ;; (conc "DELETE FROM tests WHERE run_id NOT IN (" (string-intersperse (map conc valid-runs) ",") ");") ;; delete all tests that are 'DELETED' "DELETE FROM tests WHERE state='DELETED';" )))) ;; (db:delay-if-busy dbdat) - (sqlite3:with-transaction + (dbi:with-transaction db (lambda () - (sqlite3:for-each-row (lambda (tot) + (dbi:for-each-row (lambda (tot) (debug:print-info 0 *default-log-port* "Records count before clean: " tot)) count-stmt) - (map sqlite3:execute statements) - (sqlite3:for-each-row (lambda (tot) + (map dbi:exec statements) + (dbi:for-each-row (lambda (tot) (debug:print-info 0 *default-log-port* "Records count after clean: " tot)) count-stmt))) - (map sqlite3:finalize! statements) - (sqlite3:finalize! count-stmt) + (map dbi:close statements) + (dbi:close count-stmt) ;; (db:find-and-mark-incomplete db) ;; (db:delay-if-busy dbdat) - (sqlite3:execute db "VACUUM;"))) + (dbi:exec db "VACUUM;"))) ;; Clean out old junk and vacuum the database ;; ;; Ultimately do something like this: ;; @@ -1633,31 +1644,31 @@ ;; (conc "DELETE FROM tests WHERE run_id NOT IN (" (string-intersperse (map conc valid-runs) ",") ");") ;; delete all tests that are 'DELETED' "DELETE FROM runs WHERE state='deleted';" ))) (dead-runs '())) - (sqlite3:for-each-row + (dbi:for-each-row (lambda (run-id) (set! dead-runs (cons run-id dead-runs))) db "SELECT id FROM runs WHERE state='deleted';") ;; (db:delay-if-busy dbdat) - (sqlite3:with-transaction + (dbi:with-transaction db (lambda () - (sqlite3:for-each-row (lambda (tot) + (dbi:for-each-row (lambda (tot) (debug:print-info 0 *default-log-port* "Records count before clean: " tot)) count-stmt) - (map sqlite3:execute statements) - (sqlite3:for-each-row (lambda (tot) + (map dbi:exec statements) + (dbi:for-each-row (lambda (tot) (debug:print-info 0 *default-log-port* "Records count after clean: " tot)) count-stmt))) - (map sqlite3:finalize! statements) - (sqlite3:finalize! count-stmt) + (map dbi:close statements) + (dbi:close count-stmt) ;; (db:find-and-mark-incomplete db) ;; (db:delay-if-busy dbdat) - (sqlite3:execute db "VACUUM;") + (dbi:exec db "VACUUM;") dead-runs)) ;;====================================================================== ;; M E T A G E T A N D S E T V A R S ;;====================================================================== @@ -1667,11 +1678,11 @@ ;; (define (db:get-var dbstruct var) (let* ((res #f) (dbdat (db:get-db dbstruct #f)) (db (db:dbdat-get-db dbdat))) - (sqlite3:for-each-row + (dbi:for-each-row (lambda (val) (set! res val)) db "SELECT val FROM metadat WHERE var=?;" var) ;; convert to number if can @@ -1693,17 +1704,17 @@ ;; (set! *last-global-delta-printed* *global-delta*))) (define (db:set-var dbstruct var val) (let* ((dbdat (db:get-db dbstruct #f)) (db (db:dbdat-get-db dbdat))) - (sqlite3:execute db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" var val))) + (dbi:exec db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" var val))) (define (db:del-var dbstruct var) ;; (db:delay-if-busy) (db:with-db dbstruct #f #t (lambda (db) - (sqlite3:execute db "DELETE FROM metadat WHERE var=?;" var)))) + (dbi:exec db "DELETE FROM metadat WHERE var=?;" var)))) ;; use a global for some primitive caching, it is just silly to ;; re-read the db over and over again for the keys since they never ;; change @@ -1713,11 +1724,11 @@ (define (db:get-keys dbstruct) (if *db-keys* *db-keys* (let ((res '())) (db:with-db dbstruct #f #f (lambda (db) - (sqlite3:for-each-row + (dbi:for-each-row (lambda (key) (set! res (cons key res))) db "SELECT fieldname FROM keys ORDER BY id DESC;"))) (set! *db-keys* res) @@ -1748,11 +1759,11 @@ dbstruct #f ;; this is for the main runs db #f ;; does not modify db (lambda (db) (let ((res #f)) - (sqlite3:for-each-row + (dbi:for-each-row (lambda (runname) (set! res runname)) db "SELECT runname FROM runs WHERE id=?;" run-id) @@ -1763,11 +1774,11 @@ dbstruct #f #f (lambda (db) (let ((res #f)) - (sqlite3:for-each-row + (dbi:for-each-row (lambda (val) (set! res val)) db (conc "SELECT " key " FROM runs WHERE id=?;") run-id) @@ -1811,23 +1822,23 @@ (debug:print 3 *default-log-port* "keys: " keys " allvals: " allvals " keyvals: " keyvals " key=?str is " key=?str) (debug:print 2 *default-log-port* "NOTE: using target " (string-intersperse (map cadr keyvals) "/") " for this run") (if (and runname (null? (filter (lambda (x)(not x)) keyvals))) ;; there must be a better way to "apply and" (let ((res #f)) ;; (db:delay-if-busy dbdat) - (apply sqlite3:execute db (conc "INSERT OR IGNORE INTO runs (runname,state,status,owner,event_time" comma keystr ") VALUES (?,?,?,?,strftime('%s','now')" comma valslots ");") + (apply dbi:exec db (conc "INSERT OR IGNORE INTO runs (runname,state,status,owner,event_time" comma keystr ") VALUES (?,?,?,?,strftime('%s','now')" comma valslots ");") allvals) ;; (db:delay-if-busy dbdat) - (apply sqlite3:for-each-row + (apply dbi:for-each-row (lambda (id) (set! res id)) db (let ((qry (conc "SELECT id FROM runs WHERE (runname=? " andstr key=?str ");"))) ;(debug:print 4 *default-log-port* "qry: " qry) qry) qryvals) ;; (db:delay-if-busy dbdat) - (sqlite3:execute db "UPDATE runs SET state=?,status=?,event_time=strftime('%s','now') WHERE id=? AND state='deleted';" state status res) + (dbi:exec db "UPDATE runs SET state=?,status=?,event_time=strftime('%s','now') WHERE id=? AND state='deleted';" state status res) res) (begin (debug:print-error 0 *default-log-port* "Called without all necessary keys") #f)))) @@ -1863,11 +1874,11 @@ (conc " OFFSET " offset) "")))) (debug:print-info 11 *default-log-port* "db:get-runs START qrystr: " qrystr " keypatts: " keypatts " offset: " offset " limit: " count) (db:with-db dbstruct #f #f (lambda (db) - (sqlite3:for-each-row + (dbi:for-each-row (lambda (a . x) (set! res (cons (apply vector a x) res))) db qrystr ))) @@ -1904,11 +1915,11 @@ (db:with-db dbstruct #f #f (lambda (db) - (sqlite3:for-each-row + (dbi:for-each-row (lambda (a . x) (let ((targ (cons a x))) (if (not (hash-table-ref/default seen targ #f)) (begin (hash-table-set! seen targ #t) @@ -1925,11 +1936,11 @@ #f #f (lambda (db) (let ((numruns 0)) (debug:print-info 11 *default-log-port* "db:get-num-runs START " runpatt) - (sqlite3:for-each-row + (dbi:for-each-row (lambda (count) (set! numruns count)) db "SELECT COUNT(id) FROM runs WHERE runname LIKE ? AND state != 'deleted';" runpatt) (debug:print-info 11 *default-log-port* "db:get-num-runs END " runpatt) @@ -1962,20 +1973,20 @@ (lambda (db) ;; remove previous data (let* ((stmt1 (sqlite3:prepare db "DELETE FROM run_stats WHERE run_id=? AND state=? AND status=?;")) (stmt2 (sqlite3:prepare db "INSERT INTO run_stats (run_id,state,status,count) VALUES (?,?,?,?);")) (res - (sqlite3:with-transaction + (dbi:with-transaction db (lambda () (for-each (lambda (dat) - (sqlite3:execute stmt1 run-id (car dat)(cadr dat)) - (apply sqlite3:execute stmt2 run-id dat)) + (dbi:exec stmt1 run-id (car dat)(cadr dat)) + (apply dbi:exec stmt2 run-id dat)) stats))))) - (sqlite3:finalize! stmt1) - (sqlite3:finalize! stmt2) + (dbi:close stmt1) + (dbi:close stmt2) res)))) (define (db:get-main-run-stats dbstruct run-id) (db:with-db dbstruct @@ -1995,11 +2006,11 @@ dbstruct #f #f (lambda (db) (let ((run-ids '())) - (sqlite3:for-each-row + (dbi:for-each-row (lambda (run-id) (set! run-ids (cons run-id run-ids))) db "SELECT id FROM runs WHERE state != 'deleted' ORDER BY event_time DESC;") (reverse run-ids))))) @@ -2015,11 +2026,11 @@ (curr (make-hash-table)) (res '()) (runs-info '())) ;; First get all the runname/run-ids ;; (db:delay-if-busy dbdat) - (sqlite3:for-each-row + (dbi:for-each-row (lambda (run-id runname) (set! runs-info (cons (list run-id runname) runs-info))) db "SELECT id,runname FROM runs WHERE state != 'deleted' ORDER BY event_time DESC;") ;; If you change this to the more logical ASC please adjust calls to db:get-run-stats ;; for each run get stats data @@ -2031,11 +2042,11 @@ (db:with-db dbstruct run-id #f (lambda (db) - (sqlite3:for-each-row + (dbi:for-each-row (lambda (state status count) (let ((netstate (if (equal? state "COMPLETED") status state))) (if (string? netstate) (begin (hash-table-set! totals netstate (+ (hash-table-ref/default totals netstate 0) count)) @@ -2112,11 +2123,11 @@ (header (append keys remfields)) (keystr (conc (keys->keystr keys) "," (string-intersperse remfields ",")))) (debug:print-info 11 *default-log-port* "db:get-run-info run-id: " run-id " header: " header " keystr: " keystr) ;; (db:delay-if-busy dbdat) - (sqlite3:for-each-row + (dbi:for-each-row (lambda (a . x) (set! res (apply vector a x))) db (conc "SELECT " keystr " FROM runs WHERE id=? AND state != 'deleted';") run-id) @@ -2129,11 +2140,11 @@ (db:with-db dbstruct #f #f (lambda (db) - (sqlite3:execute db "UPDATE runs SET comment=? WHERE id=?;" comment ;; (sdb:qry 'getid comment) + (dbi:exec db "UPDATE runs SET comment=? WHERE id=?;" comment ;; (sdb:qry 'getid comment) run-id)))) ;; does not (obviously!) removed dependent data. But why not!!? (define (db:delete-run dbstruct run-id) ;; First set any related tests to DELETED @@ -2140,26 +2151,26 @@ (let* ((rdbdat (db:get-db dbstruct run-id)) (rdb (db:dbdat-get-db rdbdat)) (dbdat (db:get-db dbstruct #f)) (db (db:dbdat-get-db dbdat))) ;; (db:delay-if-busy rdbdat) - (sqlite3:with-transaction + (dbi:with-transaction db (lambda () - (sqlite3:execute rdb "DELETE FROM test_steps WHERE test_id IN (SELECT id FROM tests WHERE run_id=?);" run-id) - (sqlite3:execute rdb "DELETE FROM test_data WHERE test_id IN (SELECT id FROM tests WHERE run_id=?);" run-id) - (sqlite3:execute rdb "UPDATE tests SET state='DELETED',comment='' WHERE run_id=?;" run-id) + (dbi:exec rdb "DELETE FROM test_steps WHERE test_id IN (SELECT id FROM tests WHERE run_id=?);" run-id) + (dbi:exec rdb "DELETE FROM test_data WHERE test_id IN (SELECT id FROM tests WHERE run_id=?);" run-id) + (dbi:exec rdb "UPDATE tests SET state='DELETED',comment='' WHERE run_id=?;" run-id) ;; (db:delay-if-busy dbdat) - (sqlite3:execute db "UPDATE runs SET state='deleted',comment='' WHERE id=?;" run-id))))) + (dbi:exec db "UPDATE runs SET state='deleted',comment='' WHERE id=?;" run-id))))) (define (db:update-run-event_time dbstruct run-id) (db:with-db dbstruct #f #t (lambda (db) - (sqlite3:execute db "UPDATE runs SET event_time=strftime('%s','now') WHERE id=?;" run-id)))) + (dbi:exec db "UPDATE runs SET event_time=strftime('%s','now') WHERE id=?;" run-id)))) (define (db:lock/unlock-run dbstruct run-id lock unlock user) (db:with-db dbstruct #f @@ -2167,31 +2178,31 @@ (lambda (db) (let ((newlockval (if lock "locked" (if unlock "unlocked" "locked")))) ;; semi-failsafe - (sqlite3:execute db "UPDATE runs SET state=? WHERE id=?;" newlockval run-id) - (sqlite3:execute db "INSERT INTO access_log (user,accessed,args) VALUES(?,strftime('%s','now'),?);" + (dbi:exec db "UPDATE runs SET state=? WHERE id=?;" newlockval run-id) + (dbi:exec db "INSERT INTO access_log (user,accessed,args) VALUES(?,strftime('%s','now'),?);" user (conc newlockval " " run-id)) (debug:print-info 1 *default-log-port* "" newlockval " run number " run-id))))) (define (db:set-run-status dbstruct run-id status msg) (let* ((dbdat (db:get-db dbstruct #f)) (db (db:dbdat-get-db dbdat))) ;; (db:delay-if-busy dbdat) (if msg - (sqlite3:execute db "UPDATE runs SET status=?,comment=? WHERE id=?;" status msg run-id) - (sqlite3:execute db "UPDATE runs SET status=? WHERE id=?;" status run-id)))) + (dbi:exec db "UPDATE runs SET status=?,comment=? WHERE id=?;" status msg run-id) + (dbi:exec db "UPDATE runs SET status=? WHERE id=?;" status run-id)))) (define (db:get-run-status dbstruct run-id) (let ((res "n/a")) (db:with-db dbstruct #f #f (lambda (db) - (sqlite3:for-each-row + (dbi:for-each-row (lambda (status) (set! res status)) db "SELECT status FROM runs WHERE id=?;" run-id) @@ -2210,11 +2221,11 @@ (db (db:dbdat-get-db dbdat))) (for-each (lambda (key) (let ((qry (conc "SELECT " key " FROM runs WHERE id=?;"))) ;; (db:delay-if-busy dbdat) - (sqlite3:for-each-row + (dbi:for-each-row (lambda (key-val) (set! res (cons (list key key-val) res))) db qry run-id))) keys) (reverse res))) @@ -2227,11 +2238,11 @@ (db (db:dbdat-get-db dbdat))) (for-each (lambda (key) (let ((qry (conc "SELECT " key " FROM runs WHERE id=?;"))) ;; (db:delay-if-busy dbdat) - (sqlite3:for-each-row + (dbi:for-each-row (lambda (key-val) (set! res (cons key-val res))) db qry run-id))) keys) (let ((final-res (reverse res))) @@ -2252,11 +2263,11 @@ (keys (rmt:get-keys)) (qrystr (string-intersperse (map (lambda (x)(conc x "=?")) keys) " AND "))) (let ((prev-run-ids '())) (db:with-db dbstruct #f #f ;; #f means work with the zeroth db - i.e. the runs db (lambda (db) - (apply sqlite3:for-each-row + (apply dbi:for-each-row (lambda (id) (set! prev-run-ids (cons id prev-run-ids))) db (conc "SELECT id FROM runs WHERE " qrystr " AND state != 'deleted' AND id != ?;") (append kvalues (list run-id))))) prev-run-ids))) @@ -2349,11 +2360,11 @@ ";" ))) (debug:print-info 8 *default-log-port* "db:get-tests-for-run run-id=" run-id ", qry=" qry) (db:with-db dbstruct run-id #f (lambda (db) - (sqlite3:for-each-row + (dbi:for-each-row (lambda (a . b) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment) (set! res (cons (apply vector a b) res))) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment) res))) db qry run-id @@ -2381,11 +2392,11 @@ (qry (conc "SELECT id,testname,item_path,state,status FROM tests WHERE run_id=? " (if tests-match-qry (conc " AND (" tests-match-qry ") ") "")))) (debug:print-info 8 *default-log-port* "db:get-tests-for-run qry=" qry) (db:with-db dbstruct run-id #f (lambda (db) - (sqlite3:for-each-row + (dbi:for-each-row (lambda (id testname item-path state status) ;; id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment (set! res (cons (vector id run-id testname state status -1 "" -1 -1 "" "-" item-path -1 "-" "-") res))) db qry @@ -2394,11 +2405,11 @@ (define (db:get-testinfo-state-status dbstruct run-id test-id) (let ((res #f)) (db:with-db dbstruct run-id #f (lambda (db) - (sqlite3:for-each-row + (dbi:for-each-row (lambda (run-id testname item-path state status) ;; id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment (set! res (vector test-id run-id testname state status -1 "" -1 -1 "" "-" item-path -1 "-" "-"))) db "SELECT run_id,testname,item_path,state,status FROM tests WHERE id=?;" @@ -2433,11 +2444,11 @@ (let* ((dbdat (db:get-db dbstruct run-id)) (db (db:dbdat-get-db dbdat))) (db:general-call dbdat 'delete-test-step-records (list test-id)) ;; (db:delay-if-busy) (db:general-call dbdat 'delete-test-data-records (list test-id)) - (sqlite3:execute db "UPDATE tests SET state='DELETED',status='n/a',comment='' WHERE id=?;" test-id))) + (dbi:exec db "UPDATE tests SET state='DELETED',status='n/a',comment='' WHERE id=?;" test-id))) ;; (define (db:delete-old-deleted-test-records dbstruct) (let (;; (run-ids (db:get-all-run-ids dbstruct)) (targtime (- (current-seconds)(* 30 24 60 60)))) ;; one month in the past @@ -2444,16 +2455,16 @@ (db:with-db dbstruct 0 #t (lambda (db) - (sqlite3:with-transaction + (dbi:with-transaction db (lambda () - (sqlite3:execute db "DELETE FROM test_steps WHERE test_id IN (SELECT id FROM tests WHERE state='DELETED' AND event_timelist rec)) ",") "\n") - (apply sqlite3:execute qry (vector->list rec))) + (apply dbi:exec qry (vector->list rec))) testrecs))) - (sqlite3:finalize! qry))))) + (dbi:close qry))))) ;; map a test-id into the proper range ;; (define (db:adj-test-id mtdb min-test-id test-id) (if (>= test-id min-test-id) test-id (let loop ((new-id min-test-id)) (let ((test-id-found #f)) - (sqlite3:for-each-row + (dbi:for-each-row (lambda (id) (set! test-id-found id)) (db:dbdat-get-db mtdb) "SELECT id FROM tests WHERE id=?;" new-id) @@ -2713,11 +2724,11 @@ ;; if test-id-found then need to try again (if test-id-found (loop (+ new-id 1)) (begin (debug:print-info 0 *default-log-port* "New test id " new-id " selected for test with id " test-id) - (sqlite3:execute mtdb "UPDATE tests SET id=? WHERE id=?;" new-id test-id))))))) + (dbi:exec mtdb "UPDATE tests SET id=? WHERE id=?;" new-id test-id))))))) ;; move test ids into the 30k * run_id range ;; (define (db:prep-megatest.db-adj-test-ids mtdb run-id testrecs) (debug:print-info 0 *default-log-port* "Adjusting test ids in megatest.db for run " run-id) @@ -2745,11 +2756,11 @@ dbstruct run-id #f (lambda (db) (let ((res #f)) - (sqlite3:for-each-row ;; attemptnum added to hold pid of top process (not Megatest) controlling a test + (dbi:for-each-row ;; attemptnum added to hold pid of top process (not Megatest) controlling a test (lambda (id run-id testname state status event-time host cpuload diskfree uname rundir-id item-path run_duration final-logf-id comment short-dir-id attemptnum archived) ;; 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 (set! res (vector id run-id testname state status event-time host cpuload diskfree uname rundir-id item-path run_duration final-logf-id comment short-dir-id attemptnum archived))) db (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE id=?;") @@ -2764,11 +2775,11 @@ dbstruct run-id #f (lambda (db) (let ((res '())) - (sqlite3:for-each-row + (dbi:for-each-row (lambda (a . b) ;; 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 (set! res (cons (apply vector a b) res))) db (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE id in (" @@ -2780,11 +2791,11 @@ dbstruct run-id #f (lambda (db) (let ((res #f)) - (sqlite3:for-each-row + (dbi:for-each-row (lambda (a . b) (set! res (apply vector a b))) db (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE testname=? AND item_path=? AND run_id=?;") test-name item-path run-id) @@ -2810,11 +2821,11 @@ (db:with-db dbstruct run-id #t (lambda (db) - (sqlite3:execute + (dbi:exec db "INSERT OR REPLACE into test_steps (test_id,stepname,state,status,event_time,comment,logfile) VALUES(?,?,?,?,?,?,?);" test-id teststep-name state-in status-in (current-seconds) (if comment comment "") (if logfile logfile ""))))) @@ -2825,11 +2836,11 @@ dbstruct run-id #f (lambda (db) (let* ((res '())) - (sqlite3:for-each-row + (dbi:for-each-row (lambda (id test-id stepname state status event-time logfile comment) (set! res (cons (vector id test-id stepname state status event-time (if (string? logfile) logfile "") comment) res))) db "SELECT id,test_id,stepname,state,status,event_time,logfile,comment FROM test_steps WHERE status != 'DELETED' AND test_id=? ORDER BY id ASC;" ;; event_time DESC,id ASC; test-id) @@ -2840,11 +2851,11 @@ dbstruct run-id #f (lambda (db) (let ((res '())) - (sqlite3:for-each-row + (dbi:for-each-row (lambda (id test-id stepname state status event-time logfile) (set! res (cons (vector id test-id stepname state status event-time (if (string? logfile) logfile "")) res))) db "SELECT id,test_id,stepname,state,status,event_time,logfile FROM test_steps WHERE status != 'DELETED' AND test_id=? ORDER BY id ASC;" ;; event_time DESC,id ASC; test-id) @@ -2863,11 +2874,11 @@ (let* ((dbdat (db:get-db dbstruct run-id)) (db (db:dbdat-get-db dbdat)) (fail-count 0) (pass-count 0)) ;; (db:delay-if-busy dbdat) - (sqlite3:for-each-row + (dbi:for-each-row (lambda (fcount pcount) (set! fail-count fcount) (set! pass-count pcount)) db "SELECT (SELECT count(id) FROM test_data WHERE test_id=? AND status like 'fail') AS fail_count, @@ -3013,11 +3024,11 @@ ((<=) (if (<= value expected) "pass" "fail")) (else (conc "ERROR: bad tol comparator " tol)))))) (debug:print 4 *default-log-port* "AFTER2: category: " category " variable: " variable " value: " value ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment) ;; (db:delay-if-busy dbdat) - (sqlite3:execute db "INSERT OR REPLACE INTO test_data (test_id,category,variable,value,expected,tol,units,comment,status,type) VALUES (?,?,?,?,?,?,?,?,?,?);" + (dbi:exec db "INSERT OR REPLACE INTO test_data (test_id,category,variable,value,expected,tol,units,comment,status,type) VALUES (?,?,?,?,?,?,?,?,?,?);" test-id category variable value expected tol units (if comment comment "") status type))) csvlist))) ;; This routine moved from tdb.scm, tdb:read-test-data ;; @@ -3024,11 +3035,11 @@ (define (db:read-test-data dbstruct run-id test-id categorypatt) (let* ((dbdat (db:get-db dbstruct run-id)) (db (db:dbdat-get-db dbdat)) (res '())) ;; (db:delay-if-busy dbdat) - (sqlite3:for-each-row + (dbi: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))) db "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) (reverse res))) @@ -3048,40 +3059,43 @@ (string-split target "/")) " AND ")) ;; (testqry (tests:match->sqlqry testpatt)) (runsqry (sqlite3:prepare db (conc "SELECT id FROM runs WHERE " keystr " AND runname LIKE '" runname "';")))) ;; (debug:print 8 *default-log-port* "db:test-get-paths-matching-keynames-target-new\n runsqry=" runsqry "\n tstsqry=" testqry) - (sqlite3:for-each-row + (dbi:for-each-row (lambda (rid) (set! row-ids (cons rid row-ids))) runsqry) - (sqlite3:finalize! runsqry) + (dbi:close runsqry) row-ids)) +;; finds latest matching all patts for given run-id +;; (define (db:test-get-paths-matching-keynames-target-new dbstruct run-id keynames target res testpatt statepatt statuspatt runname) (let* ((testqry (tests:match->sqlqry testpatt)) - (tstsqry (conc "SELECT rundir FROM tests WHERE " testqry " AND state LIKE '" statepatt "' AND status LIKE '" statuspatt "' ORDER BY event_time ASC;"))) + (tstsqry (conc "SELECT rundir FROM tests WHERE run_id=? AND " testqry " AND state LIKE '" statepatt "' AND status LIKE '" statuspatt "' ORDER BY event_time ASC;"))) (db:with-db dbstruct run-id #f (lambda (db) - (sqlite3:for-each-row + (dbi:for-each-row (lambda (p) (set! res (cons p res))) db - tstsqry) + tstsqry + run-id) res)))) (define (db:test-toplevel-num-items dbstruct run-id testname) (db:with-db dbstruct run-id #f (lambda (db) (let ((res 0)) - (sqlite3:for-each-row + (dbi:for-each-row (lambda (num-items) (set! res num-items)) db "SELECT count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND state NOT IN ('DELETED');" run-id @@ -3156,11 +3170,11 @@ (db:test-get-testname testdat) test-name)) (item-path (db:test-get-item-path testdat)) (tl-testdat (db:get-test-info dbstruct run-id test-name "")) (tl-test-id (db:test-get-id tl-testdat))) - (sqlite3:with-transaction + (dbi:with-transaction db (lambda () (db:test-set-state-status-by-id dbstruct run-id test-id state status comment) (if (not (equal? item-path "")) ;; only roll up IF incoming test is an item (let* ((state-status-counts (db:get-all-state-status-counts-for-test db run-id test-name item-path)) ;; item-path is used to exclude current state/status of THIS test @@ -3261,11 +3275,11 @@ dbstruct run-id #f (lambda (db) (let ((res #f)) - (sqlite3:for-each-row + (dbi:for-each-row (lambda (path final_logf) ;; (let ((path (sdb:qry 'getstr path-id)) ;; (final_logf (sdb:qry 'getstr final_logf-id))) (set! logf final_logf) (set! res (list path final_logf)) @@ -3450,20 +3464,20 @@ (string->symbol stmtname) stmtname) db:queries))) (if q (car q) #f)))) ;; (db:delay-if-busy dbdat) - (apply sqlite3:execute (db:dbdat-get-db dbdat) query params) + (apply dbi:exec (db:dbdat-get-db dbdat) query params) #t)) ;; get a summary of state and status counts to calculate a rollup ;; ;; NOTE: takes a db, not a dbstruct ;; (define (db:get-state-status-summary db run-id testname) (let ((res '())) - (sqlite3:for-each-row + (dbi:for-each-row (lambda (state status count) (set! res (cons (vector state status count) res))) db "SELECT state,status,count(state) FROM tests WHERE run_id=? AND testname=? AND item_path='' GROUP BY state,status;" run-id testname) @@ -3508,19 +3522,19 @@ (qrystr (string-intersperse (map (lambda (x)(conc x "=?")) keys) " AND ")) (keyvals #f) (tests-hash (make-hash-table))) ;; first look up the key values from the run selected by run-id ;; (db:delay-if-busy dbdat) - (sqlite3:for-each-row + (dbi:for-each-row (lambda (a . b) (set! keyvals (cons a b))) db (conc "SELECT " selstr " FROM runs WHERE id=? ORDER BY event_time DESC;") run-id) (if (not keyvals) '() (let ((prev-run-ids '())) - (apply sqlite3:for-each-row + (apply dbi:for-each-row (lambda (id) (set! prev-run-ids (cons id prev-run-ids))) db (conc "SELECT id FROM runs WHERE " qrystr " AND id != ?;") (append keyvals (list run-id))) ;; collect all matching tests for the runs then @@ -3595,11 +3609,11 @@ (db:with-db dbstruct run-id #f (lambda (db) - (sqlite3:for-each-row + (dbi:for-each-row (lambda (id itempath state status run_duration logf comment) (set! res (cons (vector id itempath state status run_duration logf comment) res))) db "SELECT id,item_path,state,status,run_duration,final_logf,comment FROM tests WHERE testname=? AND item_path != '';" test-name) @@ -3615,11 +3629,11 @@ (db:with-db dbstruct #f #f (lambda (db) - (sqlite3:for-each-row + (dbi:for-each-row (lambda (id testname author owner description reviewed iterated avg_runtime avg_disk tags jobgroup) (set! res (vector id testname author owner description reviewed iterated avg_runtime avg_disk tags jobgroup))) db "SELECT id,testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags,jobgroup FROM test_meta WHERE testname=?;" testname) @@ -3627,27 +3641,27 @@ ;; create a new record for a given testname (define (db:testmeta-add-record dbstruct testname) (db:with-db dbstruct #f #f (lambda (db) - (sqlite3:execute + (dbi:exec db "INSERT OR IGNORE INTO test_meta (testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags) VALUES (?,'','','','','','','','');" testname)))) ;; update one of the testmeta fields (define (db:testmeta-update-field dbstruct testname field value) (db:with-db dbstruct #f #f (lambda (db) - (sqlite3:execute + (dbi:exec db (conc "UPDATE test_meta SET " field "=? WHERE testname=?;") value testname)))) (define (db:testmeta-get-all dbstruct) (db:with-db dbstruct #f #f (lambda (db) (let ((res '())) - (sqlite3:for-each-row + (dbi:for-each-row (lambda (a . b) (set! res (cons (apply vector a b) res))) db "SELECT id,testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags,jobgroup FROM test_meta;") res)))) @@ -3838,11 +3852,11 @@ (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 + (apply dbi: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 @@ -3882,11 +3896,11 @@ ;; 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 + (dbi: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=?;" Index: docs/manual/megatest_manual.html ================================================================== --- docs/manual/megatest_manual.html +++ docs/manual/megatest_manual.html @@ -1,10 +1,10 @@ - + The Megatest Users Manual