Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -412,38 +412,22 @@ (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) (if newstate (sqlite3:execute db "UPDATE tests SET state=? WHERE id=?;" newstate test-id)) (if newstatus (sqlite3:execute db "UPDATE tests SET status=? WHERE id=?;" newstatus test-id)) (if newcomment (sqlite3:execute db "UPDATE tests SET comment=? WHERE id=?;" newcomment test-id))) + +(define (db:test-set-state-status-by-run-id-testname db run-id test-name item-path status state) + (sqlite3:execute db "UPDATE tests SET state=?,status=?,event_time=strftime('%s','now') WHERE run_id=? AND testname=? AND item_path=?;" + state status run-id test-name item-path)) (define (db:get-count-tests-running db) (let ((res 0)) (sqlite3:for-each-row (lambda (count) @@ -588,10 +572,25 @@ (lambda (p) (set! res (cons p res))) db qrystr) res)) + +(define (db:test-update-meta-info db run-id testname item-path minutes cpuload diskfree tmpfree) + (if (not item-path)(begin (debug:print 0 "WARNING: ITEMPATH not set.") (set! item-path ""))) + ;; (let ((testinfo (db:get-test-info db run-id testname item-path))) + ;; (if (and (not (equal? (db:test-get-status testinfo) "COMPLETED")) + ;; (not (equal? (db:test-get-status testinfo) "KILLREQ")) + (sqlite3:execute + db + "UPDATE tests SET cpuload=?,diskfree=?,run_duration=?,state='RUNNING' WHERE run_id=? AND testname=? AND item_path=? AND state NOT IN ('COMPLETED','KILLREQ','KILLED');" + cpuload + diskfree + minutes + run-id + testname + item-path)) ;;====================================================================== ;; Tests meta data ;;====================================================================== @@ -874,10 +873,29 @@ ;; if the test is not found then clearly the waiton is not met... (if (not ever-seen)(set! result (cons waitontest-name result))))) waitons) (delete-duplicates result)))) +(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")))) + ;;====================================================================== ;; Extract ods file from the db ;;====================================================================== ;; runspatt is a comma delimited list of run patterns @@ -1004,64 +1022,38 @@ ;;====================================================================== ;; 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) + 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:test-update-meta-info db run-id testname itemdat minutes cpuload diskfree tmpfree) + (let ((item-path (item-list->path itemdat))) + (if *runremote* + (let ((host (vector-ref *runremote* 0)) + (port (vector-ref *runremote* 1))) + ((rpc:procedure 'rdb:test-update-meta-info host port) + run-id testname itemdat minutes cpuload diskfree tmpfree)) + (db:test-update-meta-info db run-id testname item-path minutes cpuload diskfree tmpfree)))) + +(define (rdb:test-set-state-status-by-run-id-testname db run-id test-name item-path status state) + (if *runremote* + (let ((host (vector-ref *runremote* 0)) + (port (vector-ref *runremote* 1))) + ((rpc:procedure 'rdb:test-set-state-status-by-run-id-testname host port) + run-id test-name item-path status state)) + (db:test-set-state-status-by-run-id-testname db run-id test-name item-path status state))) Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -247,11 +247,11 @@ (diskfree (get-df (current-directory))) (tmpfree (get-df "/tmp"))) (if (not cpuload) (begin (debug:print 0 "WARNING: CPULOAD not found.") (set! cpuload "n/a"))) (if (not diskfree) (begin (debug:print 0 "WARNING: DISKFREE not found.") (set! diskfree "n/a"))) (set! kill-job? (test-get-kill-request db run-id test-name itemdat)) - (test-update-meta-info db run-id test-name itemdat minutes cpuload diskfree tmpfree) + (rdb:test-update-meta-info db run-id test-name itemdat minutes cpuload diskfree tmpfree) (if kill-job? (begin (mutex-lock! m) (let* ((pid (vector-ref exit-info 0))) (if (number? pid) Index: server.scm ================================================================== --- server.scm +++ server.scm @@ -51,19 +51,27 @@ ;;====================================================================== ;; ** set-tests-state-status (rpc:publish-procedure! 'rdb:set-tests-state-status (lambda (run-id testnames currstate currstatus newstate newstatus) - ;; (debug:print 2 "rdb:set-tests-state-status newstate: " newstate " newstatus: " newstatus) (db:set-tests-state-status db run-id testnames currstate currstatus newstate newstatus))) (rpc:publish-procedure! 'rdb:teststep-set-status! (lambda (run-id test-name teststep-name state-in status-in item-path comment logfile) - ;; (debug:print 2 "rdb:teststep-state-set-status! test-name: " test-name " teststep-name: " teststep-name) (db:teststep-set-status! db run-id test-name teststep-name state-in status-in item-path comment logfile))) + (rpc:publish-procedure! + 'rdb:test-update-meta-info + (lambda (run-id testname itemdat minutes cpuload diskfree tmpfree) + (db:test-update-meta-info db run-id testname item-path minutes cpuload diskfree tmpfree))) + + (rpc:publish-procedure! + 'rdb:test-set-state-status-by-run-id-testname + (lambda (run-id test-name item-path status state) + (db:test-set-state-status-by-run-id-testname db run-id test-name item-path status state))) + (set! *rpc:listener* rpc:listener) (on-exit (lambda () (sqlite3:execute db "DELETE FROM metadat WHERE var='SERVER' and val=?;" host:port) (sqlite3:finalize! db))) (thread-start! th1) Index: tests.scm ================================================================== --- tests.scm +++ tests.scm @@ -108,10 +108,11 @@ results) (if (null? tal) (map cdr (hash-table->alist tests-hash)) ;; return a list of the most recent tests (loop (car tal)(cdr tal)))))))))) +;; (define (test-set-status! db run-id test-name state status itemdat-or-path comment dat) (let* ((real-status status) (item-path (if (string? itemdat-or-path) itemdat-or-path (item-list->path itemdat-or-path))) (testdat (db:get-test-info db run-id test-name item-path)) (test-id (if testdat (db:test-get-id testdat) #f)) @@ -134,12 +135,11 @@ (if waived (set! real-status "WAIVED")) (debug:print 4 "real-status " real-status ", waived " waived ", status " status) ;; update the primary record IF state AND status are defined (if (and state status) - (sqlite3:execute db "UPDATE tests SET state=?,status=?,event_time=strftime('%s','now') WHERE run_id=? AND testname=? AND item_path=?;" - state real-status run-id test-name item-path)) + (db:test-set-state-status-by-run-id-testname db run-id test-name item-path real-status state)) ;; if status is "AUTO" then call rollup (if (and test-id state status (equal? status "AUTO")) (db:test-data-rollup db test-id status)) @@ -392,30 +392,14 @@ runpath run-id testname item-path))) -(define (test-update-meta-info db run-id testname itemdat minutes cpuload diskfree tmpfree) - (let ((item-path (item-list->path itemdat))) - (if (not item-path)(begin (debug:print 0 "WARNING: ITEMPATH not set.") (set! item-path ""))) - ;; (let ((testinfo (db:get-test-info db run-id testname item-path))) - ;; (if (and (not (equal? (db:test-get-status testinfo) "COMPLETED")) - ;; (not (equal? (db:test-get-status testinfo) "KILLREQ")) - (sqlite3:execute - db - "UPDATE tests SET cpuload=?,diskfree=?,run_duration=?,state='RUNNING' WHERE run_id=? AND testname=? AND item_path=? AND state NOT IN ('COMPLETED','KILLREQ','KILLED');" - cpuload - diskfree - minutes - run-id - testname - item-path))) - ;;====================================================================== ;; A R C H I V I N G ;;====================================================================== (define (test:archive db test-id) #f) (define (test:archive-tests db keynames target) #f)