Index: api.scm ================================================================== --- api.scm +++ api.scm @@ -229,10 +229,13 @@ ((set-state-status-and-roll-up-items) (apply db:set-state-status-and-roll-up-items dbstruct params)) ((set-state-status-and-roll-up-run) (apply db:set-state-status-and-roll-up-run 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)) + ((insert-test) (let ((run-id (alist-ref "run_id" params equal? #f))) + (db:insert-test dbstruct run-id 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)) @@ -241,10 +244,12 @@ ((set-var) (apply db:set-var dbstruct params)) ((inc-var) (apply db:inc-var dbstruct params)) ((dec-var) (apply db:dec-var dbstruct params)) ((del-var) (apply db:del-var dbstruct params)) ((add-var) (apply db:add-var dbstruct params)) + + ((insert-run) (apply db:insert-run dbstruct params)) ;; STEPS ((teststep-set-status!) (apply db:teststep-set-status! dbstruct params)) ((delete-steps-for-test!) (apply db:delete-steps-for-test! dbstruct params)) Index: commonmod.scm ================================================================== --- commonmod.scm +++ commonmod.scm @@ -86,10 +86,17 @@ '()))) ;; 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)) + dname)) ;; dot-locking egg seems not to work, using this for now ;; if lock is older than expire-time then remove it and try again ;; to get the lock ;; Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -1581,10 +1581,68 @@ (sqlite3:execute db "UPDATE runs SET state=?,status=?,event_time=strftime('%s','now') WHERE id=? AND state='deleted';" state status res) res))) (begin (debug:print-error 0 *default-log-port* "Called without all necessary keys") #f)))) + +;; called with run-id=#f so will operate on main.db +;; +(define (db:insert-run dbstruct run-id target runname run-meta) + (let* ((keys (db:get-keys dbstruct)) + (runs (db:simple-get-runs dbstruct runname #f #f target #f))) ;; runpatt count offset target last-update + ;; need to insert run based on target and runname + (let* ((targvals (string-split target "/")) + (keystr (string-intersperse keys ",")) + (key?str (string-intersperse (make-list (length targvals) "?") ",")) + (qrystr (conc "INSERT INTO runs (id,runname,"keystr") VALUES (?,?,"key?str")")) + (get-var (lambda (db qrystr) + (let* ((res #f)) + (sqlite3:for-each-row + (lambda row + (set res (car row))) + db qrystr run-id runname) + res)))) + (if (null? runs) + (begin + (db:create-initial-run-record dbstruct run-id runname target) + ) + ) + run-id))) + +(define (db:create-initial-run-record dbstruct run-id runname target) + (let* ((keys (db:get-keys dbstruct)) + (targvals (string-split target "/")) + (keystr (string-intersperse keys ",")) + (key?str (string-intersperse (make-list (length targvals) "?") ",")) ;; a string with the same length as targvals, where each element is "?" and interspersed with commas. + (qrystr (conc "INSERT INTO runs (id,runname,"keystr") VALUES (?,?,"key?str")"))) + + (db:with-db + dbstruct #f #t ;; run-id writable + (lambda (dbdat db) + (apply sqlite3:execute db qrystr run-id runname targvals))))) + +(define (db:insert-test dbstruct run-id test-rec) + (let* ((testname (alist-ref "testname" test-rec equal?)) + (item-path (alist-ref "item_path" test-rec equal?)) + (id (db:get-test-id dbstruct run-id testname item-path)) + (fieldvals (filter (lambda (x)(not (member (car x) '("id" "last_update")))) test-rec)) + (setqry (conc "UPDATE tests SET "(string-intersperse + (map (lambda (dat) + (conc (car dat)"=?")) + fieldvals) + ",")" WHERE id=?;")) + (insqry (conc "INSERT INTO tests ("(string-intersperse (map (lambda (x) (car x)) fieldvals) ",") + ") VALUES ("(string-intersperse (make-list (length fieldvals) "?") ",")");"))) + ;; (debug:print 0 *default-log-port* "id: "id"\nset: "setqry"\ninsqry: "insqry) + (db:with-db + dbstruct + run-id #t + (lambda (dbdat db) + ;; (if id + ;; (apply sqlite3:execute db setqry (append (map cdr fieldvals) (list id))) + (apply sqlite3:execute db insqry (map cdr fieldvals)) + )))) ;; replace header and keystr with a call to runs:get-std-run-fields ;; ;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") ) ;; runpatts: patt1,patt2 ... @@ -1656,20 +1714,21 @@ "") (if (number? offset) (conc " OFFSET " offset) ""))) ) - (debug:print-info 11 *default-log-port* "db:get-runs START qrystr: " qrystr " target: " target " offset: " offset " limit: " count) + (debug:print-info 11 *default-log-port* "db:simple-get-runs START qrystr: " qrystr " target: " target " offset: " offset " limit: " count) (db:with-db dbstruct #f #f (lambda (dbdat db) (sqlite3:for-each-row (lambda (target id runname state status owner event_time) - (set! res (cons (make-simple-run target id runname state status owner event_time) res))) + (set! res (cons (make-simple-run target id runname state status owner event_time) res)) + (debug:print-info 0 *default-log-port* "db:simple-get-runs: res = " res)) db qrystr ))) - (debug:print-info 11 *default-log-port* "db:get-runs END qrystr: " qrystr " target: " target " offset: " offset " limit: " count) + (debug:print-info 11 *default-log-port* "db:simple-get-runs END qrystr: " qrystr " target: " target " offset: " offset " limit: " count) res)) ;; TODO: Switch this to use max(update_time) from each run db? Then if using a server there is no disk traffic (using inmem db) ;; ;; NOTE: This DOESN'T (necessarily) get the real run ids, but the number of the .db!! Index: dbfile.scm ================================================================== --- dbfile.scm +++ dbfile.scm @@ -49,10 +49,12 @@ (define num-run-dbs (make-parameter 10)) ;;====================================================================== ;; R E C O R D S ;;====================================================================== + +;; (define-record simple-run target id runname state status owner event_time) ;; a single Megatest area with it's multiple dbs is ;; managed in a dbstruct ;; (defstruct dbr:dbstruct Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -193,11 +193,11 @@ -list-disks : list the disks available for storing runs -list-targets : list the targets in runconfigs.config -list-db-targets : list the target combinations used in the db -show-config : dump the internal representation of the megatest.config file -show-runconfig : dump the internal representation of the runconfigs.config file - -dumpmode MODE : dump in MODE format instead of sexpr, MODE=json,ini,sexp etc. (add -debug 0,9 to see which file contributes each line) + -dumpmode MODE : dump in MODE format instead of sexpr, MODE=json,ini,sexpr etc. (add -debug 0,9 to see which file contributes each line) -show-cmdinfo : dump the command info for a test (run in test environment) -section sectionName -var varName : for config and runconfig lookup value for sectionName varName -since N : get list of runs changed since time N (Unix seconds) -fields fieldspec : fields to include in json dump; runs:id,runame+tests:testname+steps @@ -231,18 +231,19 @@ -ping run-id|host:port : ping server, exit with 0 if found -debug N|N,M,O... : enable debug 0-N or N and M and O ... -debug-noprop N|M,M,O...: enable debug but do not propagate to subprocesses via MT_DEBUG -config fname : override the megatest.config file with fname -append-config fname : append fname to the megatest.config file + -import-sexpr fname : import a sexpr file (use -list-runs % -dumpmode sexpr to create) Utilities -env2file fname : write the environment to fname.csh and fname.sh -envcap a : save current variables labeled as context 'a' in file envdat.db -envdelta a-b : output enviroment delta from context a to context b to -o fname set the output mode with -dumpmode csh, bash or ini note: ini format will use calls to use curr and minimize path - -refdb2dat refdb : convert refdb to sexp or to format specified by s-dumpmode + -refdb2dat refdb : convert refdb to sexpr or to format specified by -dumpmode formats: perl, ruby, sqlite3, csv (for csv the -o param will substitute %s for the sheet name in generating multiple sheets) -o : output file for refdb2dat (defaults to stdout) -archive cmd : archive runs specified by selectors to one of disks specified @@ -349,10 +350,11 @@ "-env2file" "-envcap" "-envdelta" "-setvars" "-set-state-status" + "-import-sexpr" ;; move runs stuff here "-remove-keep" "-set-run-status" "-age" @@ -1062,11 +1064,11 @@ (configf:lookup data "default" (args:get-arg "-var"))))) (if val (print val)))) ((or (not (args:get-arg "-dumpmode")) (string=? (args:get-arg "-dumpmode") "ini")) (configf:config->ini data)) - ((string=? (args:get-arg "-dumpmode") "sexp") + ((string=? (args:get-arg "-dumpmode") "sexpr") (pp (hash-table->alist data))) ((string=? (args:get-arg "-dumpmode") "json") (json-write data)) (else (debug:print-error 0 *default-log-port* "-dumpmode of " (args:get-arg "-dumpmode") " not recognised"))) @@ -1084,11 +1086,11 @@ (let ((val (configf:lookup data (args:get-arg "-section")(args:get-arg "-var")))) (if val (print val)))) ;; print just a section if only -section - ((equal? (args:get-arg "-dumpmode") "sexp") + ((equal? (args:get-arg "-dumpmode") "sexpr") (pp (hash-table->alist data))) ((equal? (args:get-arg "-dumpmode") "json") (json-write data)) ((or (not (args:get-arg "-dumpmode")) (string=? (args:get-arg "-dumpmode") "ini")) @@ -1431,10 +1433,15 @@ db:test-record-fields t))) (adj-tests-spec (delete-duplicates (if tests-spec (cons "id" tests-spec) db:test-record-fields))) ;; '("id")))) (steps-spec (alist-ref "steps" fields-spec equal?)) (test-field-index (make-hash-table))) + (if (and (args:get-arg "-dumpmode") + (not (member (args:get-arg "-dumpmode") '("sexpr" "json" "ods" "list")))) + (begin + (debug:print 0 *default-log-port* "ERROR: dumpmode "(args:get-arg "-dumpmode")" not recognised. Use sexpr, json, ods or list") + (exit))) (if (and tests-spec (not (null? tests-spec))) ;; do some validation and processing of the test-spec (let ((invalid-tests-spec (filter (lambda (x)(not (member x db:test-record-fields))) tests-spec))) (if (null? invalid-tests-spec) ;; generate the lookup map test-field-name => index-number (let loop ((hed (car adj-tests-spec)) @@ -1486,12 +1493,12 @@ ;; (mutils:hierhash-set! data (conc (db:get-value-by-header run header "id")) targetstr runname "meta" "id" ) ;; (mutils:hierhash-set! data (db:get-value-by-header run header "event_time") targetstr runname "meta" "event_time" ) ;; (mutils:hierhash-set! data (db:get-value-by-header run header "comment") targetstr runname "meta" "comment" ) ;; ;; add last entry twice - seems to be a bug in hierhash? ;; (mutils:hierhash-set! data (db:get-value-by-header run header "comment") targetstr runname "meta" "comment" ) - (else - (if (null? runs-spec) + ((#f list) + (if (null? runs-spec) (print "Run: " targetstr "/" runname " status: " (db:get-value-by-header run header "state") " run-id: " run-id ", number tests: " (length tests) " event_time: " (db:get-value-by-header run header "event_time")) (begin @@ -1502,11 +1509,14 @@ (lambda (field-name) (if (equal? field-name "target") (display (conc "target: " targetstr " ")) (display (conc field-name ": " (db:get-value-by-header run header (conc field-name)) " ")))) runs-spec) - (newline))))) + (newline)))) + (else + (debug:print 0 *default-log-port* "ERROR: dumpmode "(args:get-arg "-dumpmode")" not recognised. Use sexpr, json, ods or list") + )) (for-each (lambda (test) (common:debug-handle-exceptions #f exn @@ -2476,10 +2486,32 @@ 'dejunk 'adj-testids 'old2new ) (set! *didsomething* #t))) + +(if (args:get-arg "-import-sexpr") + (let* ( + (toppath (launch:setup)) + (tmppath (common:make-tmpdir-name toppath ""))) + (if (file-exists? (conc toppath "/.mtdb")) + (if (args:get-arg "-remove-dbs") + (let* ((dbfiles (conc toppath "/.mtdb/* " tmppath "/*"))) + (debug:print 0 *default-log-port* "Removing db files: " dbfiles) + (system (conc "rm -rvf " dbfiles)) + ) + (begin + (debug:print 0 *default-log-port* "ERROR: Cannot import sexpr with an existing DB present.") + (debug:print 0 *default-log-port* "Add '-remove-dbs all' to remove the current Megatest DBs.") + (set! *didsomething* #t) + (exit) + ) + ) + ) + (db:setup #f) + (rmt:import-sexpr (args:get-arg "-import-sexpr")) + (set! *didsomething* #t))) (when (args:get-arg "-sync-brute-force") (launch:setup) ((server:get-bruteforce-syncer (db:setup #t) persist-until-sync: #t)) (set! *didsomething* #t)) Index: rmt.scm ================================================================== --- rmt.scm +++ rmt.scm @@ -1095,5 +1095,75 @@ #;(set-functions rmt:send-receive remote-server-url-set! http-transport:close-connections remote-conndat-set! debug:print debug:print-info remote-ro-mode remote-ro-mode-set! remote-ro-mode-checked-set! remote-ro-mode-checked) + + +;;====================================================================== +;; import an sexpr file into the db +;;====================================================================== + +(define (rmt:import-sexpr sexpr-file) + (if (file-exists? sexpr-file) + (let* ((data (with-input-from-file sexpr-file read))) + (for-each + (lambda (targ-dat) + (rmt:import-target targ-dat)) ;; ("target" ("run1" ("data" (1 ("field" . "value") ... + data)) + (let* ((msg (conc "ERROR: file "sexpr-file" not found"))) + (debug:print 0 *default-log-port* msg) + (cons #f msg)))) + +(define (rmt:import-target targ-dat) + (let* ((target (car targ-dat)) + (data (cdr targ-dat))) + (for-each + (lambda (run-dat) + (rmt:import-run target run-dat)) ;; ("runname" ("data" ("testid" ("field" . "value") ... + data))) + +(define (rmt:import-run target run-dat) + (let* ((runname (car run-dat)) + (all-dat (cdr run-dat)) + (tests-data (alist-ref "data" all-dat equal?)) + (run-meta (alist-ref "meta" all-dat equal?)) + (run-id (string->number (alist-ref "id" run-meta equal?)))) + (rmt:insert-run run-id target runname run-meta) + (if (list? tests-data) + (begin + (for-each + (lambda (test-dat) + (let* ((test-id (car test-dat)) + (test-rec (cdr test-dat))) + (rmt:insert-test run-id test-rec))) + tests-data) + ) + (debug:print 0 *default-log-port* "rmt:import-run: tests-data is empty") + ) + ) +) + +;; insert run if not there, return id either way +(define (rmt:insert-run run-id target runname run-meta) + ;; look for id, return if found + (let* ((runs (rmt:send-receive 'simple-get-runs #f + ;; runpatt count offset target last-update) + (list runname #f #f target #f)))) + (if (null? runs) + (begin + (debug:print 0 *default-log-port* "inserting run for runname " runname " target " target) + (rmt:send-receive 'insert-run #f (list run-id target runname run-meta)) + ) + (begin + (simple-run-id (car runs)) + )))) + + +(define (rmt:insert-test run-id test-rec) + (let* ((testname (alist-ref "testname" test-rec equal?)) + (item-path (alist-ref "item_path" test-rec equal?))) + (debug:print 0 *default-log-port* " Insert test in run "run-id": "testname"/"item-path) + (rmt:send-receive 'insert-test run-id test-rec))) + + +