Index: api.scm ================================================================== --- api.scm +++ api.scm @@ -18,11 +18,10 @@ ;; allow these queries through without starting a server ;; (define api:read-only-queries '(get-key-val-pairs - get-var get-keys get-key-vals test-toplevel-num-items get-test-info-by-id test-get-rundir-from-test-id @@ -116,172 +115,163 @@ ;; - returns #( flag result ) ;; (define (api:execute-requests dbstruct dat) (handle-exceptions exn - (let ((call-chain (get-call-chain)) - ) + (let ((call-chain (get-call-chain))) (debug:print 0 *default-log-port* "WARNING: api:execute-requests received an exception from peer") (print-call-chain (current-error-port)) (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) (vector #f (vector exn call-chain dat))) ;; return some stuff for debug if an exception happens - (cond - ((not (vector? dat)) ;; it is an error to not receive a vector - (vector #f #f "remote must be called with a vector") ) - (else - (let* ((cmd-in (vector-ref dat 0)) - (cmd (if (symbol? cmd-in) - cmd-in - (string->symbol cmd-in))) - (params (vector-ref dat 1)) - (start-t (current-milliseconds)) - (readonly-mode (dbr:dbstruct-read-only dbstruct)) - (readonly-command (member cmd api:read-only-queries)) - (writecmd-in-readonly-mode (and readonly-mode (not readonly-command))) - (res - (if writecmd-in-readonly-mode - (conc "attempt to run write command "cmd" on a read-only database") - (case cmd - ;;=============================================== - ;; READ/WRITE QUERIES - ;;=============================================== - - ((get-keys-write) (db:get-keys dbstruct)) ;; force a dummy "write" query to force server; for debug in -repl - - ;; SERVERS - ((start-server) (apply server:kind-run params)) - ((kill-server) (set! *server-run* #f)) - - ;; TESTS - ((test-set-state-status-by-id) (apply db:test-set-state-status-by-id dbstruct params)) - ((delete-test-records) (apply db:delete-test-records dbstruct params)) - ((delete-old-deleted-test-records) (apply db:delete-old-deleted-test-records dbstruct params)) - ((test-set-state-status) (apply db:test-set-state-status dbstruct params)) - ((test-set-top-process-pid) (apply db:test-set-top-process-pid dbstruct params)) - ((set-state-status-and-roll-up-items) (apply db:set-state-status-and-roll-up-items dbstruct params)) - ((top-test-set-per-pf-counts) (apply db:top-test-set-per-pf-counts dbstruct params)) - ((test-set-archive-block-id) (apply db:test-set-archive-block-id dbstruct params)) - - ;; RUNS - ((register-run) (apply db:register-run dbstruct params)) - ((set-tests-state-status) (apply db:set-tests-state-status dbstruct params)) - ((delete-run) (apply db:delete-run dbstruct params)) - ((lock/unlock-run) (apply db:lock/unlock-run dbstruct params)) - ((update-run-event_time) (apply db:update-run-event_time dbstruct params)) - ((update-run-stats) (apply db:update-run-stats dbstruct params)) - ((set-var) (apply db:set-var dbstruct params)) - - ;; STEPS - ((teststep-set-status!) (apply db:teststep-set-status! dbstruct params)) - - ;; TEST DATA - ((test-data-rollup) (apply db:test-data-rollup dbstruct params)) - ((csv->test-data) (apply db:csv->test-data dbstruct params)) - - ;; MISC - ((sync-inmem->db) (let ((run-id (car params))) - (db:sync-touched dbstruct run-id force-sync: #t))) - ((mark-incomplete) (apply db:find-and-mark-incomplete dbstruct params)) - - ;; TESTMETA - ((testmeta-add-record) (apply db:testmeta-add-record dbstruct params)) - ((testmeta-update-field) (apply db:testmeta-update-field dbstruct params)) - ((get-tests-tags) (db:get-tests-tags dbstruct)) - - ;; TASKS - ((tasks-add) (apply tasks:add dbstruct params)) - ((tasks-set-state-given-param-key) (apply tasks:set-state-given-param-key dbstruct params)) - ((tasks-get-last) (apply tasks:get-last dbstruct params)) - - ;; ARCHIVES - ;; ((archive-get-allocations) - ((archive-register-disk) (apply db:archive-register-disk dbstruct params)) - ((archive-register-block-name)(apply db:archive-register-block-name dbstruct params)) - ((archive-allocate-testsuite/area-to-block)(apply db:archive-allocate-testsuite/area-to-block dbstruct block-id testsuite-name areakey)) - - ;;====================================================================== - ;; READ ONLY QUERIES - ;;====================================================================== - - ;; KEYS - ((get-key-val-pairs) (apply db:get-key-val-pairs dbstruct params)) - ((get-keys) (db:get-keys dbstruct)) - ((get-key-vals) (apply db:get-key-vals dbstruct params)) - ((get-target) (apply db:get-target dbstruct params)) - ((get-targets) (db:get-targets dbstruct)) - - ;; ARCHIVES - ((test-get-archive-block-info) (apply db:test-get-archive-block-info dbstruct params)) - - ;; TESTS - ((test-toplevel-num-items) (apply db:test-toplevel-num-items dbstruct params)) - ((get-test-info-by-id) (apply db:get-test-info-by-id dbstruct params)) - ((test-get-rundir-from-test-id) (apply db:test-get-rundir-from-test-id dbstruct params)) - ((get-count-tests-running-for-testname) (apply db:get-count-tests-running-for-testname dbstruct params)) - ((get-count-tests-running) (apply db:get-count-tests-running dbstruct params)) - ((get-count-tests-running-in-jobgroup) (apply db:get-count-tests-running-in-jobgroup dbstruct params)) - ;; ((delete-test-step-records) (apply db:delete-test-step-records dbstruct params)) - ((get-previous-test-run-record) (apply db:get-previous-test-run-record dbstruct params)) - ((get-matching-previous-test-run-records)(apply db:get-matching-previous-test-run-records dbstruct params)) - ((test-get-logfile-info) (apply db:test-get-logfile-info dbstruct params)) - ((test-get-records-for-index-file) (apply db:test-get-records-for-index-file dbstruct params)) - ((get-testinfo-state-status) (apply db:get-testinfo-state-status dbstruct params)) - ((test-get-top-process-pid) (apply db:test-get-top-process-pid dbstruct params)) - ((test-get-paths-matching-keynames-target-new) (apply db:test-get-paths-matching-keynames-target-new dbstruct params)) - ((get-prereqs-not-met) (apply db:get-prereqs-not-met dbstruct params)) - ((get-count-tests-running-for-run-id) (apply db:get-count-tests-running-for-run-id dbstruct params)) - ((synchash-get) (apply synchash:server-get dbstruct params)) - ((get-raw-run-stats) (apply db:get-raw-run-stats dbstruct params)) - - ;; RUNS - ((get-run-info) (apply db:get-run-info dbstruct params)) - ((get-run-status) (apply db:get-run-status dbstruct params)) - ((set-run-status) (apply db:set-run-status dbstruct params)) - ((get-tests-for-run) (apply db:get-tests-for-run dbstruct params)) - ((get-test-id) (apply db:get-test-id dbstruct params)) - ((get-tests-for-run-mindata) (apply db:get-tests-for-run-mindata dbstruct params)) - ((get-runs) (apply db:get-runs dbstruct params)) - ((get-num-runs) (apply db:get-num-runs dbstruct params)) - ((get-all-run-ids) (db:get-all-run-ids dbstruct)) - ((get-prev-run-ids) (apply db:get-prev-run-ids dbstruct params)) - ((get-run-ids-matching-target) (apply db:get-run-ids-matching-target dbstruct params)) - ((get-runs-by-patt) (apply db:get-runs-by-patt dbstruct params)) - ((get-run-name-from-id) (apply db:get-run-name-from-id dbstruct params)) - ((get-main-run-stats) (apply db:get-main-run-stats dbstruct params)) - ((get-var) (apply db:get-var dbstruct params)) - ((get-run-stats) (apply db:get-run-stats dbstruct params)) - - ;; STEPS - ((get-steps-data) (apply db:get-steps-data dbstruct params)) - ((get-steps-for-test) (apply db:get-steps-for-test dbstruct params)) - - ;; TEST DATA - ((read-test-data) (apply db:read-test-data dbstruct params)) - - ;; MISC - ((get-latest-host-load) (apply db:get-latest-host-load dbstruct params)) - ((have-incompletes?) (apply db:have-incompletes? dbstruct params)) - ((login) (apply db:login dbstruct params)) - ((general-call) (let ((stmtname (car params)) - (run-id (cadr params)) - (realparams (cddr params))) - (db:general-call dbstruct stmtname realparams))) - ((sdb-qry) (apply sdb:qry params)) - ((ping) (current-process-id)) - - ;; TESTMETA - ((testmeta-get-record) (apply db:testmeta-get-record dbstruct params)) - - ;; TASKS - ((find-task-queue-records) (apply tasks:find-task-queue-records dbstruct params)))))) - (if (not writecmd-in-readonly-mode) - (let ((delta-t (- (current-milliseconds) - start-t))) - (hash-table-set! *db-api-call-time* cmd - (cons delta-t (hash-table-ref/default *db-api-call-time* cmd '()))) - (vector #t res)) - (vector #f res))))))) + (if (not (vector? dat)) ;; it is an error to not receive a vector + (vector #f #f "remote must be called with a vector") + (vector ;; return a vector + the returned data structure + #t + (let* ((cmd-in (vector-ref dat 0)) + (cmd (if (symbol? cmd-in) + cmd-in + (string->symbol cmd-in))) + (params (vector-ref dat 1)) + (start-t (current-milliseconds)) + (res + (case cmd + ;;=============================================== + ;; READ/WRITE QUERIES + ;;=============================================== + + ;; SERVERS + ((start-server) (apply server:kind-run params)) + ((kill-server) (set! *server-run* #f)) + + ;; TESTS + ((test-set-state-status-by-id) (apply db:test-set-state-status-by-id dbstruct params)) + ((delete-test-records) (apply db:delete-test-records dbstruct params)) + ((delete-old-deleted-test-records) (apply db:delete-old-deleted-test-records dbstruct params)) + ((test-set-state-status) (apply db:test-set-state-status dbstruct params)) + ((test-set-top-process-pid) (apply db:test-set-top-process-pid dbstruct params)) + ((set-state-status-and-roll-up-items) (apply db:set-state-status-and-roll-up-items dbstruct params)) + ((top-test-set-per-pf-counts) (apply db:top-test-set-per-pf-counts dbstruct params)) + ((test-set-archive-block-id) (apply db:test-set-archive-block-id dbstruct params)) + + ;; RUNS + ((register-run) (apply db:register-run dbstruct params)) + ((set-tests-state-status) (apply db:set-tests-state-status dbstruct params)) + ((delete-run) (apply db:delete-run dbstruct params)) + ((lock/unlock-run) (apply db:lock/unlock-run dbstruct params)) + ((update-run-event_time) (apply db:update-run-event_time dbstruct params)) + ((update-run-stats) (apply db:update-run-stats dbstruct params)) + ((set-var) (apply db:set-var dbstruct params)) + + ;; STEPS + ((teststep-set-status!) (apply db:teststep-set-status! dbstruct params)) + + ;; TEST DATA + ((test-data-rollup) (apply db:test-data-rollup dbstruct params)) + ((csv->test-data) (apply db:csv->test-data dbstruct params)) + + ;; MISC + ((sync-inmem->db) (let ((run-id (car params))) + (db:sync-touched dbstruct run-id force-sync: #t))) + ((mark-incomplete) (apply db:find-and-mark-incomplete dbstruct params)) + + ;; TESTMETA + ((testmeta-add-record) (apply db:testmeta-add-record dbstruct params)) + ((testmeta-update-field) (apply db:testmeta-update-field dbstruct params)) + ((get-tests-tags) (db:get-tests-tags dbstruct)) + + ;; TASKS + ((tasks-add) (apply tasks:add dbstruct params)) + ((tasks-set-state-given-param-key) (apply tasks:set-state-given-param-key dbstruct params)) + ((tasks-get-last) (apply tasks:get-last dbstruct params)) + + ;; ARCHIVES + ;; ((archive-get-allocations) + ((archive-register-disk) (apply db:archive-register-disk dbstruct params)) + ((archive-register-block-name)(apply db:archive-register-block-name dbstruct params)) + ((archive-allocate-testsuite/area-to-block)(apply db:archive-allocate-testsuite/area-to-block dbstruct block-id testsuite-name areakey)) + + ;;====================================================================== + ;; READ ONLY QUERIES + ;;====================================================================== + + ;; KEYS + ((get-key-val-pairs) (apply db:get-key-val-pairs dbstruct params)) + ((get-keys) (db:get-keys dbstruct)) + ((get-keys-write) (db:get-keys dbstruct)) ;; force a dummy "write" query to force server + ((get-key-vals) (apply db:get-key-vals dbstruct params)) + ((get-target) (apply db:get-target dbstruct params)) + ((get-targets) (db:get-targets dbstruct)) + + ;; ARCHIVES + ((test-get-archive-block-info) (apply db:test-get-archive-block-info dbstruct params)) + + ;; TESTS + ((test-toplevel-num-items) (apply db:test-toplevel-num-items dbstruct params)) + ((get-test-info-by-id) (apply db:get-test-info-by-id dbstruct params)) + ((test-get-rundir-from-test-id) (apply db:test-get-rundir-from-test-id dbstruct params)) + ((get-count-tests-running-for-testname) (apply db:get-count-tests-running-for-testname dbstruct params)) + ((get-count-tests-running) (apply db:get-count-tests-running dbstruct params)) + ((get-count-tests-running-in-jobgroup) (apply db:get-count-tests-running-in-jobgroup dbstruct params)) + ;; ((delete-test-step-records) (apply db:delete-test-step-records dbstruct params)) + ((get-previous-test-run-record) (apply db:get-previous-test-run-record dbstruct params)) + ((get-matching-previous-test-run-records)(apply db:get-matching-previous-test-run-records dbstruct params)) + ((test-get-logfile-info) (apply db:test-get-logfile-info dbstruct params)) + ((test-get-records-for-index-file) (apply db:test-get-records-for-index-file dbstruct params)) + ((get-testinfo-state-status) (apply db:get-testinfo-state-status dbstruct params)) + ((test-get-top-process-pid) (apply db:test-get-top-process-pid dbstruct params)) + ((test-get-paths-matching-keynames-target-new) (apply db:test-get-paths-matching-keynames-target-new dbstruct params)) + ((get-prereqs-not-met) (apply db:get-prereqs-not-met dbstruct params)) + ((get-count-tests-running-for-run-id) (apply db:get-count-tests-running-for-run-id dbstruct params)) + ((synchash-get) (apply synchash:server-get dbstruct params)) + ((get-raw-run-stats) (apply db:get-raw-run-stats dbstruct params)) + + ;; RUNS + ((get-run-info) (apply db:get-run-info dbstruct params)) + ((get-run-status) (apply db:get-run-status dbstruct params)) + ((set-run-status) (apply db:set-run-status dbstruct params)) + ((get-tests-for-run) (apply db:get-tests-for-run dbstruct params)) + ((get-test-id) (apply db:get-test-id dbstruct params)) + ((get-tests-for-run-mindata) (apply db:get-tests-for-run-mindata dbstruct params)) + ((get-runs) (apply db:get-runs dbstruct params)) + ((get-num-runs) (apply db:get-num-runs dbstruct params)) + ((get-all-run-ids) (db:get-all-run-ids dbstruct)) + ((get-prev-run-ids) (apply db:get-prev-run-ids dbstruct params)) + ((get-run-ids-matching-target) (apply db:get-run-ids-matching-target dbstruct params)) + ((get-runs-by-patt) (apply db:get-runs-by-patt dbstruct params)) + ((get-run-name-from-id) (apply db:get-run-name-from-id dbstruct params)) + ((get-main-run-stats) (apply db:get-main-run-stats dbstruct params)) + ((get-var) (apply db:get-var dbstruct params)) + ((get-run-stats) (apply db:get-run-stats dbstruct params)) + + ;; STEPS + ((get-steps-data) (apply db:get-steps-data dbstruct params)) + ((get-steps-for-test) (apply db:get-steps-for-test dbstruct params)) + + ;; TEST DATA + ((read-test-data) (apply db:read-test-data dbstruct params)) + + ;; MISC + ((get-latest-host-load) (apply db:get-latest-host-load dbstruct params)) + ((have-incompletes?) (apply db:have-incompletes? dbstruct params)) + ((login) (apply db:login dbstruct params)) + ((general-call) (let ((stmtname (car params)) + (run-id (cadr params)) + (realparams (cddr params))) + (db:general-call dbstruct stmtname realparams))) + ((sdb-qry) (apply sdb:qry params)) + ((ping) (current-process-id)) + + ;; TESTMETA + ((testmeta-get-record) (apply db:testmeta-get-record dbstruct params)) + + ;; TASKS + ((find-task-queue-records) (apply tasks:find-task-queue-records dbstruct params))))) + (let ((delta-t (- (current-milliseconds) + start-t))) + (hash-table-set! *db-api-call-time* cmd + (cons delta-t (hash-table-ref/default *db-api-call-time* cmd '())))) + res))))) ;; http-server send-response ;; api:process-request ;; db:* ;; Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -272,46 +272,31 @@ ;; Force a megatest cleanup-db if version is changed and skip-version-check not specified ;; (define (common:exit-on-version-changed) (if (common:version-changed?) (if (common:on-homehost?) - (let* ((mtconf (conc (get-environment-variable "MT_RUN_AREA_HOME") "/megatest.config")) - (dbfile (conc (get-environment-variable "MT_RUN_AREA_HOME") "/megatest.db")) - (read-only (not (file-write-access? dbfile))) - (dbstruct (db:setup))) + (let ((mtconf (conc (get-environment-variable "MT_RUN_AREA_HOME") "/megatest.config")) + (dbstruct (db:setup))) (debug:print 0 *default-log-port* "WARNING: Version mismatch!\n" " expected: " (common:version-signature) "\n" " got: " (common:get-last-run-version)) - (cond - ((get-environment-variable "MT_SKIP_DB_MIGRATE") #t) - ((and (file-exists? mtconf) (file-exists? dbfile) (not read-only) - (eq? (current-user-id)(file-owner mtconf))) ;; safe to run -cleanup-db - (debug:print 0 *default-log-port* " I see you are the owner of megatest.config, attempting to cleanup and reset to new version") - (handle-exceptions - exn - (begin - (debug:print 0 *default-log-port* "Failed to switch versions.") - (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) - (print-call-chain (current-error-port)) - (exit 1)) - (common:cleanup-db dbstruct))) - ((not (file-exists? mtconf)) - (debug:print 0 *default-log-port* " megatest.config does not exist in this area. Cannot proceed with megatest version migration.") - (exit 1)) - ((not (file-exists? dbfile)) - (debug:print 0 *default-log-port* " megatest.db does not exist in this area. Cannot proceed with megatest version migration.") - (exit 1)) - ((not (eq? (current-user-id)(file-owner mtconf))) - (debug:print 0 *default-log-port* " You do not own megatest.db in this area. Cannot proceed with megatest version migration.") - (exit 1)) - (read-only - (debug:print 0 *default-log-port* " You have read-only access to this area. Cannot proceed with megatest version migration.") - (exit 1)) - (else - (debug:print 0 *default-log-port* " to switch versions you can run: \"megatest -cleanup-db\"") - (exit 1)))) + (if (and (file-exists? mtconf) + (eq? (current-user-id)(file-owner mtconf))) ;; safe to run -cleanup-db + (begin + (debug:print 0 *default-log-port* " I see you are the owner of megatest.config, attempting to cleanup and reset to new version") + (handle-exceptions + exn + (begin + (debug:print 0 *default-log-port* "Failed to switch versions.") + (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) + (print-call-chain (current-error-port)) + (exit 1)) + (common:cleanup-db dbstruct))) + (begin + (debug:print 0 *default-log-port* " to switch versions you can run: \"megatest -cleanup-db\"") + (exit 1)))) (begin (debug:print 0 *default-log-port* "ERROR: cannot migrate version unless on homehost. Exiting.") (exit 1))))) ;;====================================================================== @@ -599,50 +584,19 @@ (define *wdnum* 0) (define *wdnum*mutex (make-mutex)) ;; currently the primary job of the watchdog is to run the sync back to megatest.db from the db in /tmp ;; if we are on the homehost and we are a server (by definition we are on the homehost if we are a server) ;; - - -(define (common:readonly-watchdog dbstruct) - (thread-sleep! 0.05) ;; delay for startup - (debug:print-info 13 *default-log-port* "common:readonly-watchdog entered.") - ;; sync megatest.db to /tmp/.../megatst.db - (let* ((sync-cool-off-duration 3) - (golden-mtdb (dbr:dbstruct-mtdb dbstruct)) - (golden-mtpath (db:dbdat-get-path golden-mtdb)) - (tmp-mtdb (dbr:dbstruct-tmpdb dbstruct)) - (tmp-mtpath (db:dbdat-get-path tmp-mtdb))) - (debug:print-info 0 *default-log-port* "Read-only periodic sync thread started.") - (let loop ((last-sync-time 0)) - (debug:print-info 13 *default-log-port* "loop top tmp-mtpath="tmp-mtpath" golden-mtpath="golden-mtpath) - (let* ((duration-since-last-sync (- (current-seconds) last-sync-time))) - (debug:print-info 13 *default-log-port* "duration-since-last-sync="duration-since-last-sync) - (if (and (not *time-to-exit*) - (< duration-since-last-sync sync-cool-off-duration)) - (thread-sleep! (- sync-cool-off-duration duration-since-last-sync))) - (if (not *time-to-exit*) - (let ((golden-mtdb-mtime (file-modification-time golden-mtpath)) - (tmp-mtdb-mtime (file-modification-time tmp-mtpath))) - (if (> golden-mtdb-mtime tmp-mtdb-mtime) - (let ((res (db:multi-db-sync dbstruct 'old2new))) - (debug:print-info 13 *default-log-port* "rosync called, " res " records transferred."))) - (loop (current-seconds))) - #t))) - (debug:print-info 0 *default-log-port* "Exiting readonly-watchdog timer, *time-to-exit* = " *time-to-exit*" pid="(current-process-id)" mtpath="golden-mtpath))) - - - -(define (common:writable-watchdog dbstruct) +(define (common:watchdog) (thread-sleep! 0.05) ;; delay for startup (let ((legacy-sync (common:run-sync?)) (debug-mode (debug:debug-mode 1)) (last-time (current-seconds)) (this-wd-num (begin (mutex-lock! *wdnum*mutex) (let ((x *wdnum*)) (set! *wdnum* (add1 *wdnum*)) (mutex-unlock! *wdnum*mutex) x)))) (debug:print-info 3 *default-log-port* "watchdog starting. legacy-sync is " legacy-sync" pid="(current-process-id)" this-wd-num="this-wd-num) (if (and legacy-sync (not *time-to-exit*)) - (let* (;;(dbstruct (db:setup)) + (let* ((dbstruct (db:setup)) (mtdb (dbr:dbstruct-mtdb dbstruct)) (mtpath (db:dbdat-get-path mtdb))) (debug:print-info 0 *default-log-port* "Server running, periodic sync started.") (let loop () ;; sync for filesystem local db writes @@ -652,15 +606,14 @@ (sync-in-progress *db-sync-in-progress*) (should-sync (and (not *time-to-exit*) (> (- (current-seconds) *db-last-sync*) 5))) ;; sync every five seconds minimum (start-time (current-seconds)) (mt-mod-time (file-modification-time mtpath)) - (recently-synced (< (- start-time mt-mod-time) 4)) + (recently-synced (> (- start-time mt-mod-time) 4)) (will-sync (and (or need-sync should-sync) (not sync-in-progress) (not recently-synced)))) - (debug:print-info 13 *default-log-port* "WD writable-watchdog top of loop. need-sync="need-sync" sync-in-progress="sync-in-progress" should-sync="should-sync" start-time="start-time" mt-mod-time="mt-mod-time" recently-synced="recently-synced" will-sync="will-sync) ;; (if recently-synced (debug:print-info 0 *default-log-port* "Skipping sync due to recently-synced flag=" recently-synced)) ;; (debug:print-info 0 *default-log-port* "need-sync: " need-sync " sync-in-progress: " sync-in-progress " should-sync: " should-sync " will-sync: " will-sync) (if will-sync (set! *db-sync-in-progress* #t)) (mutex-unlock! *db-multi-sync-mutex*) (if will-sync @@ -686,42 +639,24 @@ ;; keep going unless time to exit ;; (if (not *time-to-exit*) (let delay-loop ((count 0)) - ;;(debug:print-info 13 *default-log-port* "delay-loop top; count="count" pid="(current-process-id)" this-wd-num="this-wd-num" *time-to-exit*="*time-to-exit*) + ;;(BB> "delay-loop top; count="count" pid="(current-process-id)" this-wd-num="this-wd-num" *time-to-exit*="*time-to-exit*) (if (and (not *time-to-exit*) (< count 4)) ;; was 11, changing to 4. (begin (thread-sleep! 1) (delay-loop (+ count 1)))) (if (not *time-to-exit*) (loop)))) (if (common:low-noise-print 30) (debug:print-info 0 *default-log-port* "Exiting watchdog timer, *time-to-exit* = " *time-to-exit*" pid="(current-process-id)" this-wd-num="this-wd-num))))))) - -;; TODO: for multiple areas, we will have multiple watchdogs; and multiple threads to manage -(define (common:watchdog) - ;;#t) - (debug:print-info 13 *default-log-port* "common:watchdog entered.") - - (let ((dbstruct (db:setup))) - (debug:print-info 13 *default-log-port* "after db:setup with dbstruct="dbstruct) - (cond - ((dbr:dbstruct-read-only dbstruct) - (debug:print-info 13 *default-log-port* "loading read-only watchdog") - (common:readonly-watchdog dbstruct)) - (else - (debug:print-info 13 *default-log-port* "loading writable-watchdog.") - (common:writable-watchdog dbstruct)))) - (debug:print-info 13 *default-log-port* "watchdog done.");;) - ) - (define (std-exit-procedure) (on-exit (lambda () 0)) - ;;(debug:print-info 13 *default-log-port* "std-exit-procedure called; *time-to-exit*="*time-to-exit*) + ;;(BB> "std-exit-procedure called; *time-to-exit*="*time-to-exit*) (let ((no-hurry (if *time-to-exit* ;; hurry up #f (begin (set! *time-to-exit* #t) #t)))) @@ -764,11 +699,11 @@ 0) (define (std-signal-handler signum) ;; (signal-mask! signum) (set! *time-to-exit* #t) - ;;(debug:print-info 13 *default-log-port* "got signal "signum) + ;;(BB> "got signal "signum) (debug:print-error 0 *default-log-port* "Received signal " signum " exiting promptly") ;; (std-exit-procedure) ;; shouldn't need this since we are exiting and it will be called anyway (exit)) (set-signal-handler! signal/int std-signal-handler) ;; ^C Index: common_records.scm ================================================================== --- common_records.scm +++ common_records.scm @@ -124,24 +124,19 @@ ;; Brandon's debug printer shortcut (indulge me :) (define *BB-process-starttime* (current-milliseconds)) (define (BB> . in-args) (let* ((stack (get-call-chain)) - (location "??")) + (location #f)) (for-each (lambda (frame) (let* ((this-loc (vector-ref frame 0)) - (temp (string-split (->string this-loc) " ")) - (this-func (if (and (list? temp) (> (length temp) 1)) (cadr temp) "???"))) + (this-func (cadr (string-split this-loc " ")))) (if (equal? this-func "BB>") (set! location this-loc)))) stack) - (let ((dp-args - (append - (list 0 *default-log-port* - (conc location "@"(/ (- (current-milliseconds) *BB-process-starttime*) 1000)" ") ) - in-args))) + (let ((dp-args (append (list 0 *default-log-port* (conc location "@"(/ (- (current-milliseconds) *BB-process-starttime*) 1000)" ") ) in-args))) (apply debug:print dp-args)))) (define *BBpp_custom_expanders_list* (make-hash-table)) Index: dashboard-tests.scm ================================================================== --- dashboard-tests.scm +++ dashboard-tests.scm @@ -45,11 +45,11 @@ (let ((cfg-ovrd (configf:lookup *configdat* "dashboard" "pre-command"))) (or cfg-ovrd default-override "viewscreen "))) ;; "xterm -geometry 180x20 -e \""))) (define (dtests:get-post-command #!key (default-override #f)) (let ((cfg-ovrd (configf:lookup *configdat* "dashboard" "post-command"))) - (or cfg-ovrd default-override " &"))) ;; ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &"))) + (or cfg-ovrd default-override ""))) ;; ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &"))) (define (test-info-panel testdat store-label widgets) (iup:frame #:title "Test Info" ; #:expand "YES" @@ -404,11 +404,11 @@ (test-id (db:test-get-id testdat))) (if (or (not wpatt) (string-match wregx comment)) (begin ;; (rmt:test-set-state-status-by-id run-id test-id #f "WAIVED" comment) - (rmt:test-set-state-status run-id test-id #f "WAIVED" comment) + (rmt:test-set-state-status-by run-id test-id #f "WAIVED" comment) (db:test-set-status! testdat "WAIVED") (cmtcmd comment) (iup:destroy! dlog)))))) (iup:button "Cancel" #:expand "HORIZONTAL" Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -101,11 +101,11 @@ (print help) (exit))) (if (not (common:on-homehost?)) (begin - (debug:print 0 *default-log-port* "WARNING: Current policy requires running dashboard on homehost: " (common:get-homehost)))) + (debug:print 0 *default-log-port* "ERROR: Current policy requires running dashboard on homehost: " (common:get-homehost)))) ;; TODO: Move this inside (main) ;; (if (not (launch:setup)) (begin @@ -112,18 +112,16 @@ (print "Failed to find megatest.config, exiting") (exit 1))) ;; create a watch dog to move changes from lt/.db/*.db to megatest.db ;; -;;;(if (file-write-access? (conc *toppath* "/megatest.db")) -;;(debug:print-info 13 *default-log-port* "Before common:watchdog spawn") -(thread-start! (make-thread common:watchdog "Watchdog thread")) -;;(debug:print-info 13 *default-log-port* "After common:watchdog spawn") -(if (not (args:get-arg "-use-db-cache")) - (begin - (debug:print-info 0 *default-log-port* "Forcing db-cache mode due to read-only access to megatest.db") - (hash-table-set! args:arg-hash "-use-db-cache" #t)));;;) +(if (file-write-access? (conc *toppath* "/megatest.db")) + (thread-start! (make-thread common:watchdog "Watchdog thread")) + (if (not (args:get-arg "-use-db-cache")) + (begin + (debug:print-info 0 *default-log-port* "Forcing db-cache mode due to read-only access to megatest.db") + (hash-table-set! args:arg-hash "-use-db-cache" #t)))) ;; data common to all tabs goes here ;; (defstruct dboard:commondat ((curr-tab-num 0) : number) @@ -1505,11 +1503,11 @@ (let* ((cnv-obj (iup:canvas ;; #:size "500x400" #:expand "YES" #:scrollbar "YES" #:posx "0.5" - #:posy "0.5" + ;;#:posy "0.5" #:action (make-canvas-action (lambda (c xadj yadj) (debug:catch-and-dump (lambda () (if (not (dboard:tabdat-cnv tabdat)) @@ -1700,12 +1698,12 @@ (tests-mindat (dcommon:minimize-test-data tests-dat))) ;; reduces data for display (dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2)) (hash-table-set! (dboard:tabdat-last-test-dat tabdat) run-id tests-dat) (hash-table-set! (dboard:tabdat-run-update-times tabdat) run-id (- (current-seconds) 10)) (when (not run) - (debug:print-info 13 *default-log-port* "ERROR: NO RUN FOR RUN-ID run-id="run-id) - (debug:print-info 13 *default-log-port* "runs-hash-> " (hash-table->alist runs-hash)) + (BB> "ERROR: NO RUN FOR RUN-ID run-id="run-id) + (BB> "runs-hash-> " (hash-table->alist runs-hash)) ) tests-mindat)) (define (dashboard:runs-summary-xor-matrix-content tabdat runs-hash #!key (hide-clean #f)) (let* ((src-run-id (dboard:tabdat-prev-run-id tabdat)) @@ -2077,11 +2075,11 @@ ;; Bummer - we dont have the global get/set api mapped in chicken ;; (let* ((modkeys (iup:global "MODKEYSTATE"))) ;; (BB> "modkeys="modkeys)) - (debug:print-info 13 *default-log-port* "click-cb: obj="obj" lin="lin" col="col" status="status) + (BB> "click-cb: obj="obj" lin="lin" col="col" status="status) ;; status is corrupted on Brandon's home machine. will have to wait until after shutdown to see if it is still broken in PDX SLES (let* ((toolpath (car (argv))) (key (conc lin ":" col)) (test-id (hash-table-ref/default cell-lookup key -1)) (run-id (dboard:tabdat-curr-run-id tabdat)) @@ -2101,25 +2099,25 @@ (item-test-path (conc test-name "/" (if (equal? item-path "") "%" item-path))) (status-chars (char-set->list (string->char-set status))) (testpanel-cmd (conc toolpath " -test " (dboard:tabdat-curr-run-id tabdat) "," test-id " &"))) - (debug:print-info 13 *default-log-port* "status-chars=["status-chars"] status=["status"]") + (BB> "status-chars=["status-chars"] status=["status"]") (cond ((member #\1 status-chars) ;; 1 is left mouse button (system testpanel-cmd)) ((member #\2 status-chars) ;; 2 is middle mouse button - (debug:print-info 13 *default-log-port* "mmb- test-name="test-name" testpatt="testpatt) + (BB> "mmb- test-name="test-name" testpatt="testpatt) (iup:show (dashboard:popup-menu run-id test-id target runname test-name testpatt item-test-path) ;; popup-menu #:x 'mouse #:y 'mouse #:modal? "NO") ) (else - (debug:print-info 13 *default-log-port* "unhandled status in run-summary-click-cb. Doing right click action. (status is corrupted on Brandon's ubuntu host - bad/buggy iup install??" ) + (BB> "unhandled status in run-summary-click-cb. Doing right click action. (status is corrupted on Brandon's ubuntu host - bad/buggy iup install??" ) (iup:show (dashboard:popup-menu run-id test-id target runname test-name testpatt item-test-path) ;; popup-menu #:x 'mouse #:y 'mouse #:modal? "NO") ) @@ -3427,11 +3425,11 @@ ;;(print "RA => calling runs-tab-updater with commondat " commondat " tab-num " tab-num) ;;(tabdat-values tabdat) ;;RA added ;; (pp (dboard:tabdat->alist tabdat)) ;; (if (dashboard:database-changed? commondat tabdat context-key: 'runs-rundat) (dashboard:do-update-rundat tabdat) - ;;(debug:print-info 13 *default-log-port* "dashboard:runs-tab-updater") + ;;(BB> "dashboard:runs-tab-updater") ;;(inspect tabdat) (let ((uidat (dboard:commondat-uidat commondat))) ;;(print "RA => Calling update-buttons with tabdat : " tabdat " uidat " uidat) (update-buttons tabdat uidat (dboard:tabdat-numruns tabdat) (dboard:tabdat-num-tests tabdat))) Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -42,17 +42,16 @@ ;; each db entry is a pair ( db . dbfilepath ) ;; I propose this record evolves into the area record ;; (defstruct dbr:dbstruct - (tmpdb #f) + ;; (tmpdb #f) (dbstack #f) ;; stack for tmp db handles, do not initialize with a stack (mtdb #f) (refndb #f) (homehost #f) ;; not used yet (on-homehost #f) ;; not used yet - (read-only #f) ) ;; goal is to converge on one struct for an area but for now it is too confusing ;; record for keeping state,status and count for doing roll-ups in ;; iterated tests @@ -270,68 +269,51 @@ ;; (db:sync-tables db:sync-tests-only *megatest-db* db) ;; db)) ;; This routine creates the db if not already present. It is only called if the db is not already opened ;; -(define (db:open-db dbstruct #!key (areapath #f)) ;; TODO: actually use areapath +(define (db:open-db dbstruct #!key (areapath #f)) (let ((tmpdb-stack (dbr:dbstruct-dbstack dbstruct))) ;; RA => Returns the first reference in dbstruct (if (stack? tmpdb-stack) (db:get-db tmpdb-stack) ;; get previously opened db (will create new db handle if all in the stack are already used - (let* ((dbpath (db:dbfile-path )) ;; 0)) + (let* ((dbpath (db:dbfile-path)) ;; 0)) (dbexists (file-exists? dbpath)) (dbfexists (file-exists? (conc dbpath "/megatest.db"))) (tmpdb (db:open-megatest-db path: dbpath)) ;; lock-create-open dbpath db:initialize-main-db)) (mtdb (db:open-megatest-db)) - (mtdbpath (db:dbdat-get-path mtdb)) - (mtdbexists (file-exists? mtdbpath)) (refndb (db:open-megatest-db path: dbpath name: "megatest_ref.db")) - (write-access (file-write-access? mtdbpath))) - ;;(debug:print-info 13 *default-log-port* "db:open-db>> mtdbpath="mtdbpath" mtdbexists="mtdbexists" and write-access="write-access) + (write-access (file-write-access? dbpath))) (if (and dbexists (not write-access)) - (begin - (set! *db-write-access* #f) - (dbr:dbstruct-read-only-set! dbstruct #t))) + (set! *db-write-access* #f)) (dbr:dbstruct-mtdb-set! dbstruct mtdb) - (dbr:dbstruct-tmpdb-set! dbstruct tmpdb) - (dbr:dbstruct-dbstack-set! dbstruct (make-stack)) ;; BB: why a stack? Why would the number of db's be indeterminate? Is this a legacy of 1.db 2.db .. ? + (dbr:dbstruct-dbstack-set! dbstruct (make-stack)) (stack-push! (dbr:dbstruct-dbstack dbstruct) tmpdb) ;; olddb is already a (cons db path) (dbr:dbstruct-refndb-set! dbstruct refndb) ;; (mutex-unlock! *rundb-mutex*) - (if #t ;;(not dbfexists) + (if (and (not dbfexists) + write-access) ;; *db-write-access*) ;; did not have a prior db and do have write access (begin (debug:print 0 *default-log-port* "filling db " (db:dbdat-get-path tmpdb) " with data from " (db:dbdat-get-path mtdb)) - (db:sync-tables (db:sync-all-tables-list dbstruct) #f mtdb refndb tmpdb) - (debug:print-info 13 *default-log-port* "db:sync-all-tables-list done.") - ) + (db:sync-tables (db:sync-all-tables-list dbstruct) #f mtdb refndb tmpdb)) (debug:print 0 *default-log-port* " db, " (db:dbdat-get-path tmpdb) " already exists, not propogating data from " (db:dbdat-get-path mtdb))) ;; (db:multi-db-sync dbstruct 'old2new)) ;; migrate data from megatest.db automatically tmpdb)))) ;; Make the dbstruct, setup up auxillary db's and call for main db at least once ;; ;; called in http-transport and replicated in rmt.scm for *local* access. ;; (define (db:setup #!key (areapath #f)) - ;; - - (cond - (*dbstruct-db* *dbstruct-db*);; TODO: when multiple areas are supported, this optimization will be a hazard - (else ;;(common:on-homehost?) - (debug:print-info 13 *default-log-port* "db:setup entered (first time, not cached.)") - (let* ((dbstruct (make-dbr:dbstruct))) - (when (not *toppath*) - (debug:print-info 13 *default-log-port* "in db:setup, *toppath* not set; calling launch:setup") - (launch:setup areapath: areapath)) - (debug:print-info 13 *default-log-port* "Begin db:open-db") - (db:open-db dbstruct areapath: areapath) - (debug:print-info 13 *default-log-port* "Done db:open-db") - (set! *dbstruct-db* dbstruct) - ;;(debug:print-info 13 *default-log-port* "new dbstruct = "(dbr:dbstruct->alist dbstruct)) - dbstruct)))) - ;; (else - ;; (debug:print 0 *default-log-port* "ERROR: attempt to open database when not on homehost. Exiting. Homehost: " (common:get-homehost)) - ;; (exit 1)))) + (or *dbstruct-db* + (if (common:on-homehost?) + (let* ((dbstruct (make-dbr:dbstruct))) + (db:open-db dbstruct areapath: areapath) + (set! *dbstruct-db* dbstruct) + dbstruct) + (begin + (debug:print 0 *default-log-port* "ERROR: attempt to open database when not on homehost. Exiting. Homehost: " (common:get-homehost)) + (exit 1))))) ;; Open the classic megatest.db file (defaults to open in toppath) ;; ;; NOTE: returns a dbdat not a dbstruct! ;; @@ -341,11 +323,10 @@ (db (db:lock-create-open dbpath (lambda (db) (db:initialize-main-db db) (db:initialize-run-id-db db)))) (write-access (file-write-access? dbpath))) - (debug:print-info 13 *default-log-port* "db:open-megatest-db "dbpath) (if (and dbexists (not write-access)) (set! *db-write-access* #f)) (cons db dbpath))) ;; sync run to disk if touched @@ -574,35 +555,16 @@ (cons todb slave-dbs)) 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 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))) - (debug:print-error 0 *default-log-port* "db:sync-tables called with fromdb not a database " fromdb) - -3) + (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))) - (debug:print-error 0 *default-log-port* "db:sync-tables called with todb not a database " todb) - -4) - - ((not (file-write-access? (db:dbdat-get-path todb))) - (debug:print-error 0 *default-log-port* "db:sync-tables called with todb not a read-only database " todb) - -5) - ((not (null? (let ((readonly-slave-dbs - (filter - (lambda (dbdat) - (not (file-write-access? (db:dbdat-get-path todb)))) - slave-dbs))) - (for-each - (lambda (bad-dbdat) - (debug:print-error - 0 *default-log-port* "db:sync-tables called with todb not a read-only database " bad-dbdat)) - readonly-slave-dbs) - readonly-slave-dbs))) -6) + (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)) (start-time (current-milliseconds)) @@ -630,11 +592,11 @@ (full-ins (conc "INSERT OR REPLACE INTO " tablename " ( " (string-intersperse (map car fields) ",") " ) " " VALUES ( " (string-intersperse (make-list num-fields "?") ",") " );")) (fromdat '()) (fromdats '()) (totrecords 0) - (batch-len (string->number (or (configf:lookup *configdat* "sync" "batchsize") "100"))) + (batch-len (string->number (or (configf:lookup *configdat* "sync" "batchsize") "10"))) (todat (make-hash-table)) (count 0)) ;; set up the field->num table (for-each @@ -849,14 +811,15 @@ ;; options: ;; ;; 'killservers - kills all servers ;; 'dejunk - removes junk records ;; 'adj-testids - move test-ids into correct ranges -;; 'old2new - sync megatest.db to /tmp/.../megatest.db and /tmp/.../megatest_ref.db -;; 'new2old - sync /tmp/.../megatest.db to megatest.db and /tmp/.../megatest_ref.db (and update data_synced) +;; 'old2new - sync megatest.db records to .db/{main,1,2 ...}.db +;; 'new2old - sync .db/{main,1,2,3 ...}.db to megatest.db ;; 'closeall - close all opened dbs ;; 'schema - attempt to apply schema changes +;; ;; run-ids: '(1 2 3 ...) or #f (for all) ;; (define (db:multi-db-sync dbstruct . options) (if (not (launch:setup)) (debug:print 0 *default-log-port* "ERROR: not able to setup up for megatest.") @@ -895,13 +858,11 @@ ;; sync runs, test_meta etc. ;; (if (member 'old2new options) ;; (begin - (set! data-synced - (+ (db:sync-tables (db:sync-all-tables-list dbstruct) #f mtdb tmpdb refndb) - data-synced))) + (db:sync-tables (db:sync-all-tables-list dbstruct) #f mtdb tmpdb refndb)) ;; (db:sync-main-list mtdb) mtdb (db:get-db dbstruct #f)) ;; (for-each ;; (lambda (run-id) ;; (db:delay-if-busy mtdb) ;; (let ((testrecs (db:get-all-tests-info-by-run-id mtdb run-id))) @@ -916,11 +877,10 @@ ;; (if (member 'new2old options) (set! data-synced (+ (db:sync-tables (db:sync-all-tables-list dbstruct) #f tmpdb refndb mtdb) data-synced))) - (if (member 'fixschema options) (begin (db:patch-schema-maindb (db:dbdat-get-db mtdb)) @@ -2673,12 +2633,11 @@ run-id #f (lambda (db) (sqlite3:first-result db - "SELECT count(id) FROM tests WHERE state in ('LAUNCHED','NOT_STARTED','REMOTEHOSTSTART','RUNNING','KILLREQ') AND run_id=?;") - run-id))) + "SELECT count(id) FROM tests WHERE state in ('LAUNCHED','NOT_STARTED','REMOTEHOSTSTART','RUNNING','KILLREQ');")))) ;; map run-id, testname item-path to test-id (define (db:get-test-id dbstruct run-id testname item-path) (db:with-db dbstruct @@ -2755,20 +2714,20 @@ (define (db:replace-test-records dbstruct run-id testrecs) (db:with-db dbstruct run-id #t (lambda (db) (let* ((qmarks (string-intersperse (make-list (length db:test-record-fields) "?") ",")) - (qrystr (conc "INSERT OR REPLACE INTO tests (" db:test-record-qry-selector ") VALUES (" qmarks ") WHERE run_id=?;")) + (qrystr (conc "INSERT OR REPLACE INTO tests (" db:test-record-qry-selector ") VALUES (" qmarks ");")) (qry (sqlite3:prepare db qrystr))) (debug:print 0 *default-log-port* "INFO: migrating test records for run with id " run-id) (sqlite3:with-transaction db (lambda () (for-each (lambda (rec) ;; (debug:print 0 *default-log-port* "INFO: Inserting values: " (string-intersperse (map conc (vector->list rec)) ",") "\n") - (apply sqlite3:execute qry (append (vector->list rec)(list run-id)))) + (apply sqlite3:execute qry (vector->list rec))) testrecs))) (sqlite3:finalize! qry))))) ;; map a test-id into the proper range ;; @@ -3663,13 +3622,12 @@ (lambda (db) (sqlite3: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 != '' AND run_id=?;" ;; BUG! WHY NO run_id? - test-name - run-id) + "SELECT id,item_path,state,status,run_duration,final_logf,comment FROM tests WHERE testname=? AND item_path != '';" + test-name) res)))) ;;====================================================================== ;; Tests meta data ;;====================================================================== DELETED docs/api_access_methods_evolution.ods Index: docs/api_access_methods_evolution.ods ================================================================== --- docs/api_access_methods_evolution.ods +++ /dev/null cannot compute difference between binary files Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -71,11 +71,11 @@ (status (configf:lookup dat "final" "exit-status")) (msg (configf:lookup dat "final" "message"))) (if csvt ;; this if blocked stack dump caused by .dat file from logpro being 0-byte. fixed by upgrading logpro (rmt:csv->test-data run-id test-id csvt) (debug:print 0 *default-log-port* "ERROR: no csvdat exists for run-id: " run-id " test-id: " test-id " stepname: " stepname ", check that logpro version is 1.15 or newer")) - ;; (debug:print-info 13 *default-log-port* "Error: run-id/test-id/stepname="run-id"/"test-id"/"stepname" => bad csvr="csvr) + ;; (BB> "Error: run-id/test-id/stepname="run-id"/"test-id"/"stepname" => bad csvr="csvr) ;; ) (cond ((equal? status "PASS") "PASS") ;; skip the message part if status is pass (status (conc (configf:lookup dat "final" "exit-status") ": " (if msg msg "no message"))) (else #f))) @@ -721,24 +721,24 @@ ;; side effects: ;; sets; *configdat* (megatest.config info) ;; *runconfigdat* (runconfigs.config info) ;; *configstatus* (status of the read data) ;; -(define (launch:setup #!key (force #f) (areapath #f)) +(define (launch:setup #!key (force #f)) (mutex-lock! *launch-setup-mutex*) (if (and *toppath* (eq? *configstatus* 'fulldata)) ;; got it all (begin (debug:print 0 *default-log-port* "NOTE: skipping launch:setup-body call since we have fulldata") (mutex-unlock! *launch-setup-mutex*) *toppath*) - (let ((res (launch:setup-body force: force areapath: areapath))) + (let ((res (launch:setup-body force: force))) (mutex-unlock! *launch-setup-mutex*) res))) -(define (launch:setup-body #!key (force #f) (areapath #f)) - (let* ((toppath (or *toppath* areapath (getenv "MT_RUN_AREA_HOME"))) ;; preserve toppath +(define (launch:setup-body #!key (force #f)) + (let* ((toppath (or *toppath* (getenv "MT_RUN_AREA_HOME"))) ;; preserve toppath (runname (common:args-get-runname)) (target (common:args-get-target)) (linktree (common:get-linktree)) (sections (if target (list "default" target) #f)) ;; for runconfigs (mtconfig (or (args:get-arg "-config") "megatest.config")) ;; allow overriding megatest.config Index: megatest-version.scm ================================================================== --- megatest-version.scm +++ megatest-version.scm @@ -1,7 +1,7 @@ ;; Always use two or four digit decimal ;; 1.01, 1.02...1.10,1.11,1.1101 ... 1.99,2.00.. (declare (unit megatest-version)) -(define megatest-version 1.6308) +(define megatest-version 1.6307) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -364,12 +364,10 @@ (let ((targ (or (args:get-arg "-reqtarg")(args:get-arg "-target")))) (if targ (setenv "MT_TARGET" targ))) ;; The watchdog is to keep an eye on things like db sync etc. ;; - -;; TODO: for multiple areas, we will have multiple watchdogs; and multiple threads to manage (define *watchdog* (make-thread common:watchdog "Watchdog thread")) (if (not (args:get-arg "-server")) (thread-start! *watchdog*)) ;; if starting a server; wait till we get to running state before kicking off watchdog @@ -1081,10 +1079,11 @@ (hash-table-set! test-field-index hed idx) (if (not (null? tal))(loop (car tal)(cdr tal)(+ idx 1)))) (begin (debug:print-error 0 *default-log-port* "Invalid test fields specified: " (string-intersperse invalid-tests-spec ", ")) (exit))))) + ;; Each run (for-each (lambda (run) (let ((targetstr (string-intersperse (map (lambda (x) (db:get-value-by-header run header x)) @@ -1348,15 +1347,11 @@ (debug:print 0 *default-log-port* "WARNING: path given, " outputfile " is relative, prefixing with current directory") (conc (current-directory) "/" outputfile))))) (create-directory tempdir #t) (ods:list->ods tempdir ouf sheets)))) ;; (system (conc "rm -rf " tempdir)) - (set! *didsomething* #t) - (set! *time-to-exit* #t) - ) ;; end if true branch (end of a let) - ) ;; end if - ) ;; end if -list-runs + (set! *didsomething* #t)))) ;; Don't think I need this. Incorporated into -list-runs instead ;; ;; (if (and (args:get-arg "-since") ;; (launch:setup)) @@ -2020,15 +2015,14 @@ ;; Exit and clean up ;;====================================================================== (if (not *didsomething*) (debug:print 0 *default-log-port* help)) -;;(debug:print-info 13 *default-log-port* "thread-join! watchdog") +;;(BB> "thread-join! watchdog") ;; join the watchdog thread if it has been thread-start!ed (it may not have been started in the case of a server that never enters running state) ;; (symbols returned by thread-state: created ready running blocked suspended sleeping terminated dead) -;; TODO: for multiple areas, we will have multiple watchdogs; and multiple threads to manage (if (thread? *watchdog*) (case (thread-state *watchdog*) ((ready running blocked sleeping terminated dead) (thread-join! *watchdog*)))) Index: rmt.scm ================================================================== --- rmt.scm +++ rmt.scm @@ -55,37 +55,16 @@ ;; 1. check if server is started IFF cmd is a write OR if we are not on the homehost, store in runremote ;; 2. check the age of the connections. refresh the connection if it is older than timeout-20 seconds. ;; 3. do the query, if on homehost use local access ;; (let* ((start-time (current-seconds)) ;; snapshot time so all use cases get same value - (areapath *toppath*);; TODO - resolve from dbstruct to be compatible with multiple areas - (dbfile (conc *toppath* "/megatest.db")) - (readonly-mode (not (file-write-access? dbfile))) ;; TODO: use dbstruct or runremote to figure this out in future (runremote (or area-dat *runremote*))) - ;;(print "BB> readonly-mode is "readonly-mode" dbfile is "dbfile) (cond ;; give up if more than 15 attempts ((> attemptnum 15) (debug:print 0 *default-log-port* "ERROR: 15 tries to start/connect to server. Giving up.") (exit 1)) - - ;; readonly mode, read request- handle it - case 20 - ((and readonly-mode - (member cmd api:read-only-queries)) - (mutex-unlock! *rmt-mutex*) - (debug:print-info 12 *default-log-port* "rmt:send-receive, case 20") - (rmt:open-qry-close-locally cmd 0 params) - ) - - ;; readonly mode, write request. Do nothing, return #f - (readonly-mode - (mutex-unlock! *rmt-mutex*) - (debug:print-info 12 *default-log-port* "rmt:send-receive, case 21") - (debug:print 0 *default-log-port* "WARNING: write transaction requested on a readonly area. cmd="cmd" params="params) - #f - ) - ;; reset the connection if it has been unused too long ((and runremote (remote-conndat runremote) (let ((expire-time (+ (- start-time (remote-server-timeout runremote))(random 30)))) ;; add 30 seconds of noise so that not all running tests expire at the same time causing a storm of server starts (< (http-transport:server-dat-get-last-access (remote-conndat runremote)) expire-time))) Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -202,12 +202,10 @@ (let* ((keys (keys:config-get-fields *configdat*)) (keyvals (keys:target->keyval keys target)) (run-id (rmt:register-run keyvals runname "new" "n/a" user)) ;; test-name))) ;; (deferred '()) ;; delay running these since they have a waiton clause (runconfigf (conc *toppath* "/runconfigs.config")) - (dbfile (conc *toppath* "/megatest.db")) - (readonly-mode (not (file-write-access? dbfile))) (test-records (make-hash-table)) ;; need to process runconfigs before generating these lists (all-tests-registry #f) ;; (tests:get-all)) ;; (tests:get-valid-tests (make-hash-table) test-search-path)) ;; all valid tests to check waiton names (all-test-names #f) ;; (hash-table-keys all-tests-registry)) (test-names #f) ;; Generated by a call to (tests:filter-test-names all-test-names test-patts)) @@ -215,19 +213,14 @@ (task-key (conc (hash-table->alist flags) " " (get-host-name) " " (current-process-id))) (tdbdat (tasks:open-db)) (config-reruns (let ((x (configf:lookup *configdat* "setup" "reruns"))) (if x (string->number x) #f)))) - ;; check if readonly - (when readonly-mode - (debug:print-error 0 *default-log-port* "megatest.db is readonly. Cannot proceed.") - (exit 1)) - ;; per user request. If less than 100Meg space on dbdir partition, bail out with error ;; this will reduce issues in database corruption (common:check-db-dir-and-exit-if-insufficient) - + ;; override the number of reruns from the configs (if (and config-reruns (> run-count config-reruns)) (set! run-count config-reruns)) @@ -1331,11 +1324,11 @@ ;; now *if* -run-wait we wait for all tests to be done ;; Now wait for any RUNNING tests to complete (if in run-wait mode) (thread-sleep! 5) ;; I think there is a race condition here. Let states/statuses settle (let wait-loop ((num-running (rmt:get-count-tests-running-for-run-id run-id)) (prev-num-running 0)) - ;; (debug:print-info 13 *default-log-port* "num-running=" num-running ", prev-num-running=" prev-num-running) + ;; (BB> "num-running=" num-running ", prev-num-running=" prev-num-running) (if (and (or (args:get-arg "-run-wait") (equal? (configf:lookup *configdat* "setup" "run-wait") "yes")) (> num-running 0)) (begin ;; Here we mark any old defunct tests as incomplete. Do this every fifteen minutes @@ -1646,20 +1639,10 @@ (states (if state (string-split state ",") '())) (statuses (if status (string-split status ",") '())) (state-status (if (string? new-state-status) (string-split new-state-status ",") '(#f #f))) (rp-mutex (make-mutex)) (bup-mutex (make-mutex))) - - (let* ((write-access-actions '(remove-runs set-state-status archive run-wait)) - (dbfile (conc *toppath* "/megatest.db")) - (readonly-mode (not (file-write-access? dbfile)))) - (when (and readonly-mode - (member action write-access-actions)) - (debug:print-error 0 *default-log-port* "megatest.db is readonly. Cannot proceed with action ["action"] in which write-access isrequired .") - (exit 1))) - - (debug:print-info 4 *default-log-port* "runs:operate-on => Header: " header " action: " action " new-state-status: " new-state-status) (if (> 2 (length state-status)) (begin (debug:print-error 0 *default-log-port* "the parameter to -set-state-status is a comma delimited string. E.g. COMPLETED,FAIL") (exit))) @@ -1909,12 +1892,10 @@ (full-runconfigs-read) ;; cache the run config (launch:cache-config)) ;; do not cache here - need to be sure runconfigs is processed (begin (debug:print 0 *default-log-port* "Failed to setup, exiting") (exit 1))) - - (set! keys (keys:config-get-fields *configdat*)) ;; have enough to process -target or -reqtarg here (if (args:get-arg "-reqtarg") (let* ((runconfigf (conc *toppath* "/runconfigs.config")) ;; DO NOT EVALUATE ALL (runconfig (read-config runconfigf #f #t environ-patt: #f)))