Overview
| Comment: | updated -import-sexpr to remove existing dbs and correctly recreate runs, also added switch -remove-dbs and insist that it is used if dbs already exist. |
|---|---|
| Downloads: | Tarball | ZIP archive | SQL archive |
| Timelines: | family | ancestors | descendants | both | v1.80-revolution |
| Files: | files | file ages | folders |
| SHA1: |
5e997071bea47f533abf7ca2a130cd91 |
| User & Date: | mmgraham on 2024-01-01 17:48:41 |
| Original Comment: | updated -import-sexpr to remove existing dbs and correctly recreate runs |
| Other Links: | branch diff | manifest | tags |
Context
|
2024-01-02
| ||
| 10:00 | Changed version to 1.8027 check-in: 841ecebad5 user: mmgraham tags: v1.80-revolution, v1.8027 | |
|
2024-01-01
| ||
| 17:48 | updated -import-sexpr to remove existing dbs and correctly recreate runs, also added switch -remove-dbs and insist that it is used if dbs already exist. check-in: 5e997071be user: mmgraham tags: v1.80-revolution | |
|
2023-12-24
| ||
| 18:28 | Changed version to 1.8026 check-in: 3a124c1ad8 user: mmgraham tags: v1.80-revolution, v1.8026 | |
Changes
Modified db.scm from [678efe323e] to [346b188c56].
| ︙ | ︙ | |||
1461 1462 1463 1464 1465 1466 1467 |
(let ((runs (db:simple-get-runs dbstruct runname #f #f target #f))) ;; runpatt count offset target last-update
(if (null? runs)
#f
(simple-run-id (car runs)))))
;; called with run-id=#f so will operate on main.db
;;
| | | | > | > > | > > | > > > > > > | > > > > > > > > | | | > > > | > | | | 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 |
(let ((runs (db:simple-get-runs dbstruct runname #f #f target #f))) ;; runpatt count offset target last-update
(if (null? runs)
#f
(simple-run-id (car runs)))))
;; 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)
)
)
(let* ()
;;(debug:print 0 *default-log-port* "db:insert-run: Calling db:with-db to update the run record")
(debug:print 0 *default-log-port* "db:insert-run: runid = " run-id)
#; (db:with-db
dbstruct
#f #t
(lambda (dbdat db)
(debug:print 0 *default-log-port* "In the lambda proc for " dbdat " " db)
(for-each
(lambda (keyval)
(debug:print 0 *default-log-port* "In the lambda proc for " keyval)
(let* ((fieldname (car keyval))
(getqry (conc "SELECT "fieldname" FROM runs WHERE id=?;"))
(setqry (conc "UPDATE runs SET "fieldname"=? WHERE id=?;"))
(val (cdr keyval))
(valnum (if (number? val)
val
(if (string? val)
(string->number val)
#f))))
(debug:print 0 *default-log-port* "fieldname " fieldname " val " val " valnum " valnum)
(if (not (member fieldname (cons "runname" keys))) ;; don't attempt to tweak these
(let* ((curr-val (get-var db getqry))
(have-it (or (equal? curr-val val)
(equal? curr-val valnum))))
(debug:print 0 *default-log-port* "have-it = " have-it)
(if (not have-it)
(begin
(debug:print 0 *default-log-port* "Do sqlite3:execute")
;; (sqlite3:execute db setqry (or valnum val) run-id)
)
)
)
)
(debug:print 0 *default-log-port* "Done with update")
)
(debug:print 0 *default-log-port* "next keyval")
)
run-meta)))
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")")))
(debug:print 0 *default-log-port* "db:create-initial-run-record")
(debug:print 0 *default-log-port* "qrystr = " qrystr)
(db:with-db
dbstruct #f #t ;; run-id writable
(lambda (dbdat db)
(debug:print 0 *default-log-port* "lambda proc: dbdat: " dbdat " db: " 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)))))))
|
| ︙ | ︙ |
Modified dbmod.scm from [cb31c71f30] to [404c8ee706].
| ︙ | ︙ | |||
134 135 136 137 138 139 140 | (debug:print-info 0 *default-log-port* "dbmod:with-db, database is busy, will try "count" more times.") (thread-sleep! 1) (loop (- count 1))) (begin (debug:print-info 0 *default-log-port* "dbmod:with-db, database is busy, giving up.") (exit 1)))) (exn () | | | 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 |
(debug:print-info 0 *default-log-port* "dbmod:with-db, database is busy, will try "count" more times.")
(thread-sleep! 1)
(loop (- count 1)))
(begin
(debug:print-info 0 *default-log-port* "dbmod:with-db, database is busy, giving up.")
(exit 1))))
(exn ()
(dbfile:print-err exn "ERROR: dbmod:with-db: Unknown error with database for run-id "run-id", message: "
((condition-property-accessor 'exn 'message) exn))
(exit 2))))))
(if use-mutex (mutex-unlock! *db-with-db-mutex*))
res)))
(define (db:with-db dbstruct run-id w/r proc . params)
(dbmod:with-db dbstruct run-id w/r proc params))
|
| ︙ | ︙ |
Modified megatest.scm from [7048d9a8e4] to [02fbabd339].
| ︙ | ︙ | |||
255 256 257 258 259 260 261 262 263 264 265 266 267 268 |
-mark-incompletes : find and mark incomplete tests
-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)
-regen-testfiles : regenerate scripts and logpro files from testconfig, run in test context
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
| > | 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 |
-mark-incompletes : find and mark incomplete tests
-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)
-remove-dbs all : remove Megatest DBs before importing sexpr. (Use only with -import-sexpr)
-regen-testfiles : regenerate scripts and logpro files from testconfig, run in test context
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
|
| ︙ | ︙ | |||
377 378 379 380 381 382 383 384 385 386 387 388 389 390 |
"-pathmod"
"-env2file"
"-envcap"
"-envdelta"
"-setvars"
"-set-state-status"
"-import-sexpr"
"-period" ;; sync period in seconds
"-timeout" ;; exit sync if timeout in seconds exceeded since last change
;; move runs stuff here
"-remove-keep"
"-set-run-status"
"-age"
| > | 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 |
"-pathmod"
"-env2file"
"-envcap"
"-envdelta"
"-setvars"
"-set-state-status"
"-import-sexpr"
"-remove-dbs" ;; to be used only with -import-sexpr to remove megatest dbs first.
"-period" ;; sync period in seconds
"-timeout" ;; exit sync if timeout in seconds exceeded since last change
;; move runs stuff here
"-remove-keep"
"-set-run-status"
"-age"
|
| ︙ | ︙ | |||
1045 1046 1047 1048 1049 1050 1051 | ) ) (if (args:get-arg "-kill-servers") | | | | 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 |
)
)
(if (args:get-arg "-kill-servers")
(let* ((tl (launch:setup)) ;; need this to initialize *toppath*
(servdir (tt:get-servinfo-dir *toppath*))
(servfiles (glob (conc servdir "/*:*.db")))
(fmtstr "~10a~22a~10a~25a~25a~8a\n")
(dbfiles (if (file-exists? (conc *toppath* "/.mtdb/main.db")) (append (glob (conc *toppath* "/.mtdb/main.db")) (glob (conc *toppath* "/.mtdb/?.db"))(glob (conc *toppath* "/.mtdb/??.db"))) '()))
(ttdat (make-tt areapath: *toppath*))
)
(format #t fmtstr "DB" "host:port" "PID" "age" "last mod" "state")
(for-each
(lambda (dbfile)
(let* (
(dbfname (conc (pathname-file dbfile) ".db"))
|
| ︙ | ︙ | |||
2626 2627 2628 2629 2630 2631 2632 |
'dejunk
'adj-testids
'old2new
)
(set! *didsomething* #t)))
(if (args:get-arg "-import-sexpr")
| > > > > > > > > > | > > > > > > > > | | | | 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 |
'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)
)
)
(debug:print 0 *default-log-port* "Did not find " (conc toppath "/.mtdb"))
)
(db:setup)
(rmt:import-sexpr (args:get-arg "-import-sexpr"))
(set! *didsomething* #t)))
(if (args:get-arg "-sync-to-megatest.db")
(let* ((duh (launch:setup))
(dbstruct (db:setup))
(tmpdbpth (dbr:dbstruct-tmppath dbstruct))
(lockfile (conc tmpdbpth ".lock"))
(locked (common:simple-file-lock lockfile))
|
| ︙ | ︙ |
Modified rmt.scm from [070a664ad0] to [77312b7fa0].
| ︙ | ︙ | |||
77 78 79 80 81 82 83 84 85 86 87 88 89 90 |
(let* ((newremote (make-and-init-remote areapath)))
(set! *ttdat* newremote)
newremote)))
;; NB// area-dat replaced by ttdat
;;
(define (rmt:send-receive cmd run-id params #!key (attemptnum 1)(ttdat #f))
(assert *toppath* "FATAL: rmt:send-receive called with *toppath* not set.")
(let* ((areapath *toppath*) ;; TODO - resolve from dbstruct to be compatible with multiple areas
(readonly-mode (rmtmod:calc-ro-mode ttdat *toppath*))
(testsuite (common:get-testsuite-name)))
(case (rmt:transport-mode)
((tcp)
(let* ((start-time (current-seconds)) ;; snapshot time so all use cases get same value
| > | 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 |
(let* ((newremote (make-and-init-remote areapath)))
(set! *ttdat* newremote)
newremote)))
;; NB// area-dat replaced by ttdat
;;
(define (rmt:send-receive cmd run-id params #!key (attemptnum 1)(ttdat #f))
(assert (or (not run-id) (number? run-id)) "FATAL: run-id is required to be a number or #f")
(assert *toppath* "FATAL: rmt:send-receive called with *toppath* not set.")
(let* ((areapath *toppath*) ;; TODO - resolve from dbstruct to be compatible with multiple areas
(readonly-mode (rmtmod:calc-ro-mode ttdat *toppath*))
(testsuite (common:get-testsuite-name)))
(case (rmt:transport-mode)
((tcp)
(let* ((start-time (current-seconds)) ;; snapshot time so all use cases get same value
|
| ︙ | ︙ |
Modified rmtmod.scm from [c4f748fe17] to [052d2f8699].
| ︙ | ︙ | |||
84 85 86 87 88 89 90 |
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?))
| > > | | > > | > > > | > > < | 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 |
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)
(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)))
;; 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
(debug:print 0 *default-log-port* "Insert run: "target"/"runname)
(let* ((runs (rmtmod: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)
(rmtmod:send-receive 'insert-run #f (list run-id target runname run-meta))
)
(begin
(debug:print 0 *default-log-port* "Found run-id " (simple-run-id (car runs)) " for runname " runname " target " target)
(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?)))
(rmtmod:send-receive 'insert-test run-id test-rec)))
;;======================================================================
;; T E S T S
;;======================================================================
;; Just some syntatic sugar
|
| ︙ | ︙ |