@@ -50,12 +50,253 @@ (import stml2 ) (module commonmod - * + ( + ;; globals + *already-seen-runconfig-info* + *common:badly-ended-states* + *common:dont-roll-up-states* + *common:ended-states* + *common:not-started-ok-statuses* + *common:running-states* + *common:std-states* + *common:std-statuses* + *common:well-ended-states* + *configdat* + *configinfo* + *configstatus* + *db-access-allowed* + *db-api-call-time* + *db-cache-path* + *db-keys* + *default-area-tag* + *env-vars-by-run-id* + *globalexitstatus* + *host-loads* + *keyvals* + *last-launch* + *launch-setup-mutex* + *logged-in-clients* + *my-client-signature* + *on-exit-procs* + *passnum* + *pkts-info* + *pre-reqs-met-cache* + *runconfigdat* + *runremote* + *server-id* + *server-info* + *target* + *task-db* + *test-meta-updated* + *testconfigs* + *time-to-exit* + *toppath* + *toptest-paths* + *transport-type* + *common:this-exe-dir* + + common:list-is-sublist + seconds->year-week/day-time + common:find-start-mark-and-mark-delta + + common:with-orig-env + alist->env-vars + any->number + any->number-if-possible + assoc/default + client:get-signature + + common:alist-ref/default + common:clear-caches + common:dir-clean-up + common:directory-exists? + common:directory-writable? + common:fail-safe + common:file-exists? + common:find-local-megatest + common:generic-ssh + common:get-area-path-signature + common:get-color-from-status + common:get-cpu-load + common:get-create-writeable-dir + common:get-fields + common:get-intercept + common:get-megatest-exe + common:get-megatest-exe-dir + common:get-megatest-exe-path + common:get-mtexe + common:get-normalized-cpu-load + common:get-normalized-cpu-load + common:get-num-cpus + common:get-param-mapping + common:get-signature + common:get-toppath + common:hms-string->seconds + common:htree->html + common:human-time + common:in-running-test? + common:join-backgrounded-threads + common:lazy-sqlite-db-modification-time + common:list->htree + common:list-or-null + common:logpro-exit-code->status-sym + common:low-noise-print + common:make-tmpdir-name + common:max + common:min-max + common:nice-path + common:pkts-spec + common:raw-get-remote-host-load + common:read-encoded-string + common:real-path + common:send-thunk-to-background-thread + common:simple-file-lock + common:simple-file-lock-and-wait + common:simple-file-release-lock + common:sparse-list-generate-index + common:special-sort + common:steps-can-proceed-given-status-sym + common:sum + common:to-alist + common:unix-ping + common:val->alist + common:version-signature + common:which + common:with-env-vars + common:without-vars + common:worse-status-sym + commonmod:get-cpu-load + commonmod:is-test-alive + db:mintest-get-event_time + db:patt->like + + db:test-data-get-category + db:test-data-get-comment + db:test-data-get-expected + db:test-data-get-id + db:test-data-get-last_update + db:test-data-get-status + db:test-data-get-test_id + db:test-data-get-tol + db:test-data-get-type + db:test-data-get-units + db:test-data-get-value + db:test-data-get-variable + db:test-get-archived + db:test-get-comment + db:test-get-cpuload + db:test-get-diskfree + db:test-get-event_time + db:test-get-final_logf + db:test-get-fullname + db:test-get-host + db:test-get-id + db:test-get-is-toplevel + db:test-get-item-path + db:test-get-last_update + db:test-get-process_id + db:test-get-run_duration + db:test-get-run_id + db:test-get-rundir + db:test-get-state + db:test-get-status + db:test-get-testname + db:test-get-uname + db:test-make-full-name + db:test-set-state! + db:test-set-status! + db:test-set-testname! + + db:testmeta-get-author + db:testmeta-get-description + db:testmeta-get-owner + db:testmeta-get-reviewed + db:testmeta-get-tags + + get-area-path-signature + get-normalized-cpu-load + getenv + host-last-cpuload + host-last-cpuload-set! + host-last-update + host-last-update-set! + host-last-used + host-last-used-set! + host-reachable + host-reachable-set! + item-list->path + keys->keystr + keys->valslots + keys:config-get-fields + keys:target->keyval + keys:target-set-args + make-db:testmeta + make-host + make-sparse-array + make-tests:testqueue + megatest-fossil-hash + megatest-version + number-of-processes-running + patt-list-match + rmt:transport-mode + runs:get-std-run-fields + safe-setenv + save-environment-as-files + sdb:qry + seconds->hr-min-sec + seconds->quarter + seconds->time-string + seconds->work-week/day + seconds->work-week/day-time + seconds->year-work-week/day-time + setenv + sparse-array-ref + sparse-array-set! + status-sym->string + stop-the-train + tasks:wait-on-journal + + tdb:step-get-comment + tdb:step-get-event_time + tdb:step-get-id + tdb:step-get-last_update + tdb:step-get-logfile + tdb:step-get-state + tdb:step-get-status + tdb:step-get-stepname + tdb:step-get-test_id + tdb:steps-table-get-end + tdb:steps-table-get-log-file + tdb:steps-table-get-runtime + tdb:steps-table-get-start + tdb:steps-table-get-status + tdb:steps-table-get-stepname + + tests:glob-like-match + tests:lookup-itemmap + tests:match + tests:match->sqlqry + + tests:testqueue-get-item_path + tests:testqueue-get-itemdat + tests:testqueue-get-items + tests:testqueue-get-priority + tests:testqueue-get-testconfig + tests:testqueue-get-testname + tests:testqueue-get-waitons + tests:testqueue-set-item_path! + tests:testqueue-set-itemdat! + tests:testqueue-set-items! + tests:testqueue-set-priority! + + val->alist + ) + (import scheme) (cond-expand (chicken-4 (import chicken @@ -120,10 +361,12 @@ srfi-69 typed-records system-information debugprint + megatest-fossil-hash + ))) ;;====================================================================== ;; CONTENTS ;; @@ -136,11 +379,10 @@ (include "megatest-version.scm") (include "megatest-fossil-hash.scm") (include "db_records.scm") (include "key_records.scm") (include "common_records.scm") -(include "test_records.scm") ;; http - use the old http + in /tmp db ;; tcp - use tcp transport with cachedb db ;; nfs - use direct to disk access (read-only) ;; @@ -285,10 +527,11 @@ (caddr argv)) (else (car argv)))) (fullpath (realpath this-script))) fullpath)) +;; get rid of these, no need to slow down start up ;;====================================================================== (define *common:this-exe-fullpath* (common:get-this-exe-fullpath)) (define *common:this-exe-dir* (pathname-directory *common:this-exe-fullpath*)) (define *common:this-exe-name* (pathname-strip-directory *common:this-exe-fullpath*)) @@ -385,10 +628,11 @@ (define *last-launch* (current-seconds)) ;; use for throttling the launch rate. Would be better to use the db and last time of a test in LAUNCHED state. ;; environment vars handy stuff from common.scm ;; (define getenv get-environment-variable) + (define (safe-setenv key val) (if (or (substring-index "!" key) (substring-index ":" key) ;; variables containing : are for internal use and cannot be environment variables. (substring-index "." key)) ;; periods are not allowed in environment variables (debug:print-error 4 *default-log-port* "skip setting internal use only variables containing \":\" or starting with \"!\"") @@ -563,13 +807,10 @@ (if valstr (val->alist valstr) '()))) ;; should it return empty list or #f to indicate not set? -(define (get-section cfgdat section) - (hash-table-ref/default cfgdat section '())) - (define (common:make-tmpdir-name areapath tmpadj) (let* ((area (pathname-file areapath)) (dname (conc "/tmp/"(current-user-name)"/megatest_localdb/" area "/" (string-translate areapath "/" ".") tmpadj "/.mtdb"))) (unless (directory-exists? dname) (create-directory dname #t)) @@ -2735,7 +2976,229 @@ (define (common:get-fields cfgdat) (let ((fields (hash-table-ref/default cfgdat "fields" '()))) (map car fields))) (define keys:config-get-fields common:get-fields) + +;;====================================================================== +;; db_records.scm +;;====================================================================== + +;;====================================================================== +;; dbstruct +;;====================================================================== + +(define (make-db:test)(make-vector 20)) +(define (db:test-get-id vec) (vector-ref vec 0)) +(define (db:test-get-run_id vec) (vector-ref vec 1)) +(define (db:test-get-testname vec) (vector-ref vec 2)) +(define (db:test-get-state vec) (vector-ref vec 3)) +(define (db:test-get-status vec) (vector-ref vec 4)) +(define (db:test-get-event_time vec) (vector-ref vec 5)) +(define (db:test-get-host vec) (vector-ref vec 6)) +(define (db:test-get-cpuload vec) (vector-ref vec 7)) +(define (db:test-get-diskfree vec) (vector-ref vec 8)) +(define (db:test-get-uname vec) (vector-ref vec 9)) +;; (define (db:test-get-rundir vec) (sdb:qry 'getstr (vector-ref vec 10))) +(define (db:test-get-rundir vec) (vector-ref vec 10)) +(define (db:test-get-item-path vec) (vector-ref vec 11)) +(define (db:test-get-run_duration vec) (vector-ref vec 12)) +(define (db:test-get-final_logf vec) (vector-ref vec 13)) +(define (db:test-get-comment vec) (vector-ref vec 14)) +(define (db:test-get-process_id vec) (vector-ref vec 16)) +(define (db:test-get-archived vec) (vector-ref vec 17)) +(define (db:test-get-last_update vec) (vector-ref vec 18)) + +;; (define (db:test-get-pass_count vec) (vector-ref vec 15)) +;; (define (db:test-get-fail_count vec) (vector-ref vec 16)) +(define (db:test-get-fullname vec) + (conc (db:test-get-testname vec) "/" (db:test-get-item-path vec))) + +;; replace runs:make-full-test-name with this routine +(define (db:test-make-full-name testname itempath) + (if (equal? itempath "") testname (conc testname "/" itempath))) + +;; (define (db:test-get-first_err vec) (printable (vector-ref vec 15))) +;; (define (db:test-get-first_warn vec) (printable (vector-ref vec 16))) ;; RADT => reference 16 is repeated + +(define (db:test-set-cpuload! vec val)(vector-set! vec 7 val)) +(define (db:test-set-diskfree! vec val)(vector-set! vec 8 val)) +(define (db:test-set-testname! vec val)(vector-set! vec 2 val)) +(define (db:test-set-state! vec val)(vector-set! vec 3 val)) +(define (db:test-set-status! vec val)(vector-set! vec 4 val)) +(define (db:test-set-run_duration! vec val)(vector-set! vec 12 val)) +(define (db:test-set-final_logf! vec val)(vector-set! vec 13 val)) + +;; Test record utility functions + +;; Is a test a toplevel? +;; +(define (db:test-get-is-toplevel vec) + (and (equal? (db:test-get-item-path vec) "") ;; test is not an item + (equal? (db:test-get-uname vec) "n/a"))) ;; test has never been run + +;; make-vector-record "" db mintest id run_id testname state status event_time item_path +;; RADT => purpose of mintest?? +;; +(define (make-db:mintest)(make-vector 7)) +(define (db:mintest-get-id vec) (vector-ref vec 0)) +(define (db:mintest-get-run_id vec) (vector-ref vec 1)) +(define (db:mintest-get-testname vec) (vector-ref vec 2)) +(define (db:mintest-get-state vec) (vector-ref vec 3)) +(define (db:mintest-get-status vec) (vector-ref vec 4)) +(define (db:mintest-get-event_time vec) (vector-ref vec 5)) +(define (db:mintest-get-item_path vec) (vector-ref vec 6)) + +;; make-vector-record db testmeta id testname author owner description reviewed iterated avg_runtime avg_disk +(define (make-db:testmeta)(make-vector 10 "")) +(define (db:testmeta-get-id vec) (vector-ref vec 0)) +(define (db:testmeta-get-testname vec) (vector-ref vec 1)) +(define (db:testmeta-get-author vec) (vector-ref vec 2)) +(define (db:testmeta-get-owner vec) (vector-ref vec 3)) +(define (db:testmeta-get-description vec) (vector-ref vec 4)) +(define (db:testmeta-get-reviewed vec) (vector-ref vec 5)) +(define (db:testmeta-get-iterated vec) (vector-ref vec 6)) +(define (db:testmeta-get-avg_runtime vec) (vector-ref vec 7)) +(define (db:testmeta-get-avg_disk vec) (vector-ref vec 8)) +(define (db:testmeta-get-tags vec) (vector-ref vec 9)) +(define (db:testmeta-set-id! vec val)(vector-set! vec 0 val)) +(define (db:testmeta-set-testname! vec val)(vector-set! vec 1 val)) +(define (db:testmeta-set-author! vec val)(vector-set! vec 2 val)) +(define (db:testmeta-set-owner! vec val)(vector-set! vec 3 val)) +(define (db:testmeta-set-description! vec val)(vector-set! vec 4 val)) +(define (db:testmeta-set-reviewed! vec val)(vector-set! vec 5 val)) +(define (db:testmeta-set-iterated! vec val)(vector-set! vec 6 val)) +(define (db:testmeta-set-avg_runtime! vec val)(vector-set! vec 7 val)) +(define (db:testmeta-set-avg_disk! vec val)(vector-set! vec 8 val)) + +;;====================================================================== +;; S I M P L E R U N +;;====================================================================== + +;; (defstruct id "runname" "state" "status" "owner" "event_time" + +;;====================================================================== +;; T E S T D A T A +;;====================================================================== +(define (make-db:test-data)(make-vector 10)) +(define (db:test-data-get-id vec) (vector-ref vec 0)) +(define (db:test-data-get-test_id vec) (vector-ref vec 1)) +(define (db:test-data-get-category vec) (vector-ref vec 2)) +(define (db:test-data-get-variable vec) (vector-ref vec 3)) +(define (db:test-data-get-value vec) (vector-ref vec 4)) +(define (db:test-data-get-expected vec) (vector-ref vec 5)) +(define (db:test-data-get-tol vec) (vector-ref vec 6)) +(define (db:test-data-get-units vec) (vector-ref vec 7)) +(define (db:test-data-get-comment vec) (vector-ref vec 8)) +(define (db:test-data-get-status vec) (vector-ref vec 9)) +(define (db:test-data-get-type vec) (vector-ref vec 10)) +(define (db:test-data-get-last_update vec) (vector-ref vec 11)) + +(define (db:test-data-set-id! vec val)(vector-set! vec 0 val)) +(define (db:test-data-set-test_id! vec val)(vector-set! vec 1 val)) +(define (db:test-data-set-category! vec val)(vector-set! vec 2 val)) +(define (db:test-data-set-variable! vec val)(vector-set! vec 3 val)) +(define (db:test-data-set-value! vec val)(vector-set! vec 4 val)) +(define (db:test-data-set-expected! vec val)(vector-set! vec 5 val)) +(define (db:test-data-set-tol! vec val)(vector-set! vec 6 val)) +(define (db:test-data-set-units! vec val)(vector-set! vec 7 val)) +(define (db:test-data-set-comment! vec val)(vector-set! vec 8 val)) +(define (db:test-data-set-status! vec val)(vector-set! vec 9 val)) +(define (db:test-data-set-type! vec val)(vector-set! vec 10 val)) + +;;====================================================================== +;; S T E P S +;;====================================================================== +;; Run steps +;; make-vector-record "Run steps" db step id test_id stepname step_complete step_pass event_time +(define (make-db:step)(make-vector 9)) +(define (tdb:step-get-id vec) (vector-ref vec 0)) +(define (tdb:step-get-test_id vec) (vector-ref vec 1)) +(define (tdb:step-get-stepname vec) (vector-ref vec 2)) +(define (tdb:step-get-state vec) (vector-ref vec 3)) +(define (tdb:step-get-status vec) (vector-ref vec 4)) +(define (tdb:step-get-event_time vec) (vector-ref vec 5)) +(define (tdb:step-get-logfile vec) (vector-ref vec 6)) +(define (tdb:step-get-comment vec) (vector-ref vec 7)) +(define (tdb:step-get-last_update vec) (vector-ref vec 8)) +(define (tdb:step-set-id! vec val)(vector-set! vec 0 val)) +(define (tdb:step-set-test_id! vec val)(vector-set! vec 1 val)) +(define (tdb:step-set-stepname! vec val)(vector-set! vec 2 val)) +(define (tdb:step-set-state! vec val)(vector-set! vec 3 val)) +(define (tdb:step-set-status! vec val)(vector-set! vec 4 val)) +(define (tdb:step-set-event_time! vec val)(vector-set! vec 5 val)) +(define (tdb:step-set-logfile! vec val)(vector-set! vec 6 val)) +(define (tdb:step-set-comment! vec val)(vector-set! vec 7 val)) + + +;; The steps table +(define (make-db:steps-table)(make-vector 5)) +(define (tdb:steps-table-get-stepname vec) (vector-ref vec 0)) +(define (tdb:steps-table-get-start vec) (vector-ref vec 1)) +(define (tdb:steps-table-get-end vec) (vector-ref vec 2)) +(define (tdb:steps-table-get-status vec) (vector-ref vec 3)) +(define (tdb:steps-table-get-runtime vec) (vector-ref vec 4)) +(define (tdb:steps-table-get-log-file vec) (vector-ref vec 5)) + +(define (tdb:step-stable-set-stepname! vec val)(vector-set! vec 0 val)) +(define (tdb:step-stable-set-start! vec val)(vector-set! vec 1 val)) +(define (tdb:step-stable-set-end! vec val)(vector-set! vec 2 val)) +(define (tdb:step-stable-set-status! vec val)(vector-set! vec 3 val)) +(define (tdb:step-stable-set-runtime! vec val)(vector-set! vec 4 val)) + +;; ;; The data structure for handing off requests via wire +;; (define (make-cdb:packet)(make-vector 6)) +;; (define (cdb:packet-get-client-sig vec) (vector-ref vec 0)) +;; (define (cdb:packet-get-qtype vec) (vector-ref vec 1)) +;; (define (cdb:packet-get-immediate vec) (vector-ref vec 2)) +;; (define (cdb:packet-get-query-sig vec) (vector-ref vec 3)) +;; (define (cdb:packet-get-params vec) (vector-ref vec 4)) +;; (define (cdb:packet-get-qtime vec) (vector-ref vec 5)) +;; (define (cdb:packet-set-client-sig! vec val)(vector-set! vec 0 val)) +;; (define (cdb:packet-set-qtype! vec val)(vector-set! vec 1 val)) +;; (define (cdb:packet-set-immediate! vec val)(vector-set! vec 2 val)) +;; (define (cdb:packet-set-query-sig! vec val)(vector-set! vec 3 val)) +;; (define (cdb:packet-set-params! vec val)(vector-set! vec 4 val)) +;; (define (cdb:packet-set-qtime! vec val)(vector-set! vec 5 val)) + +;;====================================================================== +;; key_records +;;====================================================================== + +(define (keys->valslots keys) ;; => ?,?,? .... + (string-intersperse (map (lambda (x) "?") keys) ",")) + +;; (define (keys->key/field keys . additional) +;; (string-join (map (lambda (k)(conc k " TEXT")) +;; (append keys additional)) ",")) + +(define (item-list->path itemdat) + (if (list? itemdat) + (string-intersperse (map cadr itemdat) "/") + "")) + + +;;====================================================================== +;; test_records +;;====================================================================== + +;; make-vector-record tests testqueue testname testconfig waitons priority items +(define (make-tests:testqueue)(make-vector 7 #f)) +(define (tests:testqueue-get-testname vec) (vector-ref vec 0)) +(define (tests:testqueue-get-testconfig vec) (vector-ref vec 1)) +(define (tests:testqueue-get-waitons vec) (vector-ref vec 2)) +(define (tests:testqueue-get-priority vec) (vector-ref vec 3)) +;; items: #f=no items, list=list of items remaining, proc=need to call to get items +(define (tests:testqueue-get-items vec) (vector-ref vec 4)) +(define (tests:testqueue-get-itemdat vec) (vector-ref vec 5)) +(define (tests:testqueue-get-item_path vec) (vector-ref vec 6)) + +(define (tests:testqueue-set-testname! vec val)(vector-set! vec 0 val)) +(define (tests:testqueue-set-testconfig! vec val)(vector-set! vec 1 val)) +(define (tests:testqueue-set-waitons! vec val)(vector-set! vec 2 val)) +(define (tests:testqueue-set-priority! vec val)(vector-set! vec 3 val)) +(define (tests:testqueue-set-items! vec val)(vector-set! vec 4 val)) +(define (tests:testqueue-set-itemdat! vec val)(vector-set! vec 5 val)) +(define (tests:testqueue-set-item_path! vec val)(vector-set! vec 6 val)) + )