@@ -10,10 +10,13 @@ ;;====================================================================== ;;====================================================================== ;; Database access ;;====================================================================== + +(require-extension (srfi 18) extras tcp rpc) +(import (prefix rpc rpc:)) (use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml) (import (prefix sqlite3 sqlite3:)) (declare (unit db)) @@ -22,10 +25,11 @@ (declare (uses ods)) (include "common_records.scm") (include "db_records.scm") (include "key_records.scm") +(include "run_records.scm") (define (open-db) ;; (conc *toppath* "/megatest.db") (car *configinfo*))) (let* ((dbpath (conc *toppath* "/megatest.db")) ;; fname) (configdat (car *configinfo*)) (dbexists (file-exists? dbpath)) @@ -131,10 +135,11 @@ type TEXT DEFAULT '', CONSTRAINT test_data_constraint UNIQUE (test_id,category,variable));") ;; Must do this *after* running patch db !! No more. (db:set-var db "MEGATEST_VERSION" megatest-version) )) + (server:client-setup db) db)) ;;====================================================================== ;; TODO: ;; put deltas into an assoc list with version numbers @@ -407,10 +412,30 @@ (if currstatus (conc "status='" currstatus "' AND ") "") " run_id=? AND testname=? AND NOT (item_path='' AND testname in (SELECT DISTINCT testname FROM tests WHERE testname=? AND item_path != ''));"))) ;;(debug:print 0 "QRY: " qry) (sqlite3:execute db qry run-id newstate newstatus testname testname))) testnames)) + +(define (db:teststep-set-status! db run-id test-name teststep-name state-in status-in item-path comment logfile) + (debug:print 4 "run-id: " run-id " test-name: " test-name) + (let* ((state (check-valid-items "state" state-in)) + (status (check-valid-items "status" status-in)) + (testdat (db:get-test-info db run-id test-name item-path))) + (debug:print 5 "testdat: " testdat) + (if (and testdat ;; if the section exists then force specification BUG, I don't like how this works. + (or (not state)(not status))) + (debug:print 0 "WARNING: Invalid " (if status "status" "state") + " value \"" (if status state-in status-in) "\", update your validvalues section in megatest.config")) + (if testdat + (let ((test-id (test:get-id testdat))) + ;; FIXME - this should not update the logfile unless it is specified. + (sqlite3:execute db + "INSERT OR REPLACE into test_steps (test_id,stepname,state,status,event_time,comment,logfile) VALUES(?,?,?,?,strftime('%s','now'),?,?);" + test-id teststep-name state-in status-in (if comment comment "") (if logfile logfile "")) + #t) ;; fake out a #t - could be execute is returning something complicated + (debug:print 0 "ERROR: Can't update " test-name " for run " run-id " -> no such test in db")))) + (define (db:delete-tests-in-state db run-id state) (sqlite3:execute db "DELETE FROM tests WHERE state=? AND run_id=?;" state run-id)) (define (db:test-set-state-status-by-id db test-id newstate newstatus newcomment) @@ -973,5 +998,70 @@ results) ;; brutal clean up (system "rm -rf tempdir"))) ;; (db:extract-ods-file db "outputfile.ods" '(("sysname" "%")("fsname" "%")("datapath" "%")) "%") + + +;;====================================================================== +;; REMOTE DB ACCESS VIA RPC +;;====================================================================== + +;; (define (rdb:get-var db var) +;; (define (rdb:set-var db var val) +;; (define (rdb-get-keys db) +;; (define (rdb:get-value-by-header row header field) +;; (define (rruns:get-std-run-fields keys remfields) +;; (define (rdb:get-runs db runpatt count offset keypatts) +;; (define (rdb:get-num-runs db runpatt) +;; (define (rdb:get-run-info db run-id) +;; (define (rdb:set-comment-for-run db run-id comment) +;; (define (rdb:delete-run db run-id) +;; (define (rdb:update-run-event_time db run-id) +;; (define (rdb-get-tests-for-run db run-id testpatt itempatt states statuses) +;; (define (rdb:delete-test-step-records db run-id test-name itemdat) +;; (define (rdb:delete-test-records db test-id) + +(define (rdb:set-tests-state-status db run-id testnames currstate currstatus newstate newstatus) + (if *runremote* + (let ((host (vector-ref *runremote* 0)) + (port (vector-ref *runremote* 1))) + ((rpc:procedure 'rdb:set-tests-state-status host port) + run-id testnames currstate currstatus newstate newstatus)) + (db:set-tests-state-status db run-id testnames currstate currstatus newstate newstatus))) + +(define (rdb:teststep-set-status! db run-id test-name teststep-name state-in status-in itemdat comment logfile) + (print "teststep-set-status!:" run-id test-name teststep-name state-in status-in itemdat comment logfile) + (let ((item-path (item-list->path itemdat))) + (if *runremote* + (let ((host (vector-ref *runremote* 0)) + (port (vector-ref *runremote* 1))) + ((rpc:procedure 'rdb:teststep-set-status! host port) + run-id test-name teststep-name state-in status-in item-path comment logfile) + (db:teststep-set-status! db run-id test-name teststep-name state-in status-in item-path comment logfile))))) + + +;; (define (rdb:delete-tests-in-state db run-id state) +;; (define (rdb:test-set-state-status-by-id db test-id newstate newstatus newcomment) +;; (define (rdb:get-count-tests-running db) +;; (define (rdb:get-count-tests-running-in-jobgroup db jobgroup) +;; (define (rdb:estimated-tests-remaining db run-id) +;; (define (rdb:get-test-info db run-id testname item-path) +;; (define (rdb:get-test-data-by-id db test-id) +;; (define (rdb:test-set-comment db run-id testname item-path comment) +;; (define (rdb:test-set-rundir! db run-id testname item-path rundir) +;; (define (rdb:test-get-paths-matching db keynames target) +;; (define (rdb:test-get-test-records-matching db keynames target) +;; (define (rdb:testmeta-get-record db testname) +;; (define (rdb:testmeta-add-record db testname) +;; (define (rdb:testmeta-update-field db testname field value) +;; (define (rdb:csv->test-data db test-id csvdata) +;; (define (rdb:read-test-data db test-id categorypatt) +;; (define (rdb:load-test-data db run-id test-name itemdat) +;; (define (rdb:test-data-rollup db test-id status) +;; (define (rdb:get-prev-tol-for-test db test-id category variable) +;; (define (rdb:step-get-time-as-string vec) +;; (define (rdb:get-steps-for-test db test-id) +;; (define (rdb:get-steps-table db test-id) +;; (define (rdb-get-prereqs-not-met db run-id waiton) +;; (define (rdb:get-prereqs-not-met db run-id waitons ref-item-path) +;; (define (rdb:extract-ods-file db outputfile keypatt-alist runspatt pathmod)