Overview
Comment: | wip, compiles |
---|---|
Downloads: | Tarball | ZIP archive | SQL archive |
Timelines: | family | ancestors | descendants | both | v1.6584-ck5 |
Files: | files | file ages | folders |
SHA1: |
cff44e26a59a995ae29913dfa416fdaa |
User & Date: | matt on 2021-04-23 05:36:22 |
Other Links: | branch diff | manifest | tags |
Context
2021-04-23
| ||
23:57 | Basic initialization of dbstruct works. check-in: 1b388397ae user: matt tags: v1.6584-ck5 | |
05:36 | wip, compiles check-in: cff44e26a5 user: matt tags: v1.6584-ck5 | |
00:23 | wip check-in: 0538039b08 user: matt tags: v1.6584-ck5 | |
Changes
Modified apimod.scm from [499827ca49] to [ef19086eeb].
︙ | ︙ | |||
252 253 254 255 256 257 258 | ((delete-steps-for-test!) (apply db:delete-steps-for-test! 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 | | | | | | | 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 | ((delete-steps-for-test!) (apply db:delete-steps-for-test! 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)) ;; ((create-all-triggers) (db:create-all-triggers dbstruct)) ;; ((drop-all-triggers) (db:drop-all-triggers dbstruct)) ;; 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 |
︙ | ︙ |
Modified archivemod.scm from [46d9ed9faa] to [a7eb8f34d2].
1 2 3 4 5 6 7 | ;;====================================================================== ;; Copyright 2017, Matthew Welland. ;; ;; This file is part of Megatest. ;; ;; Megatest is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by | > | 1 2 3 4 5 6 7 8 | ;;====================================================================== ;; Copyright 2017, Matthew Welland. ;; ;; This file is part of Megatest. ;; ;; Megatest is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by |
︙ | ︙ | |||
463 464 465 466 467 468 469 | (define (archive:restore-db archive-path ts) (let* ((bup-exe (or (configf:lookup *configdat* "archive" "bup") "bup")) (archive-internal-path (conc (common:get-area-name) "-megatest-db/" ts "/megatest.db" )) (bup-restore-params (list "-d" archive-path "restore" "-C" *toppath* archive-internal-path))) (debug:print-info 2 *default-log-port* "Restoring archived data to " *toppath* " from archive in " archive-path " ... " archive-internal-path) (run-n-wait bup-exe params: bup-restore-params print-cmd: "Running:")) | | > > > | | 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 | (define (archive:restore-db archive-path ts) (let* ((bup-exe (or (configf:lookup *configdat* "archive" "bup") "bup")) (archive-internal-path (conc (common:get-area-name) "-megatest-db/" ts "/megatest.db" )) (bup-restore-params (list "-d" archive-path "restore" "-C" *toppath* archive-internal-path))) (debug:print-info 2 *default-log-port* "Restoring archived data to " *toppath* " from archive in " archive-path " ... " archive-internal-path) (run-n-wait bup-exe params: bup-restore-params print-cmd: "Running:")) (sleep 2) ;; TODO: restore this functionality #;(db:multi-db-sync (db:setup #f) 'killservers ;'dejunk ;'adj-testids 'old2new ) (debug:print-info 1 *default-log-port* "dropping triggers to update linktree") |
︙ | ︙ |
Modified db.scm from [82696a1002] to [f0d5613294].
︙ | ︙ | |||
21 22 23 24 25 26 27 | ;; Extract ods file from the db ;;====================================================================== ;; NOT REWRITTEN YET!!!!! ;; runspatt is a comma delimited list of run patterns ;; keypatt-alist must contain *all* keys with an associated pattern: '( ("KEY1" "%") .. ) | > > > | | 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 | ;; Extract ods file from the db ;;====================================================================== ;; NOT REWRITTEN YET!!!!! ;; runspatt is a comma delimited list of run patterns ;; keypatt-alist must contain *all* keys with an associated pattern: '( ("KEY1" "%") .. ) ;; TODO: Re-enable this functionality #;(define (db:extract-ods-file dbstruct outputfile keypatt-alist runspatt pathmod) (let* ((keysstr (string-intersperse (map car keypatt-alist) ",")) (keyqry (string-intersperse (map (lambda (p)(conc (car p) " LIKE ? ")) keypatt-alist) " AND ")) (numkeys (length keypatt-alist)) (test-ids '()) (dbdat (db:get-db dbstruct)) (db (db:dbdat-get-db dbdat)) (windows (and pathmod (substring-index "\\" pathmod))) |
︙ | ︙ |
Modified launchmod.scm from [2eee1b3817] to [032f2a94bb].
︙ | ︙ | |||
2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 | (debug:print-info 13 *default-log-port* "no need for watchdog on non-homehost")))) ;;====================================================================== ;; 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) (let ((just-testing 0.0501)) (thread-sleep! just-testing)) ;; (/ 1 20)) ;; 0.051) ;; 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)) | > > > | 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 | (debug:print-info 13 *default-log-port* "no need for watchdog on non-homehost")))) ;;====================================================================== ;; 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) #f) #;(define (common:readonly-watchdog dbstruct) (let ((just-testing 0.0501)) (thread-sleep! just-testing)) ;; (/ 1 20)) ;; 0.051) ;; 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)) |
︙ | ︙ | |||
2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 | (map args:get-arg no-watchdog-args))) (start-watchdog (and (null? no-watchdog-args-vals) start-watchdog-special-arg-val))) ;; (print "no-watchdog-args="no-watchdog-args "no-watchdog-args-vals="no-watchdog-args-vals " start-watchdog-special-arg-val:" start-watchdog-special-arg-val " start-watchdog:" start-watchdog) (if start-watchdog (thread-start! (bdat-watchdog *bdat*))))) (define (server:writable-watchdog-deltasync dbstruct) (thread-sleep! 0.054) ;; delay for startup (let ((legacy-sync (common:run-sync?)) (sync-stale-seconds (configf:lookup-number *configdat* "server" "sync-stale-seconds" default: 300)) (debug-mode (debug:debug-mode 1)) (last-time (current-seconds)) (no-sync-db (db:open-no-sync-db)) (stmt-cache (dbr:dbstruct-stmt-cache dbstruct)) | > > | 2389 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 | (map args:get-arg no-watchdog-args))) (start-watchdog (and (null? no-watchdog-args-vals) start-watchdog-special-arg-val))) ;; (print "no-watchdog-args="no-watchdog-args "no-watchdog-args-vals="no-watchdog-args-vals " start-watchdog-special-arg-val:" start-watchdog-special-arg-val " start-watchdog:" start-watchdog) (if start-watchdog (thread-start! (bdat-watchdog *bdat*))))) (define (server:writable-watchdog-deltasync dbstruct) #f) #;(define (server:writable-watchdog-deltasync dbstruct) (thread-sleep! 0.054) ;; delay for startup (let ((legacy-sync (common:run-sync?)) (sync-stale-seconds (configf:lookup-number *configdat* "server" "sync-stale-seconds" default: 300)) (debug-mode (debug:debug-mode 1)) (last-time (current-seconds)) (no-sync-db (db:open-no-sync-db)) (stmt-cache (dbr:dbstruct-stmt-cache dbstruct)) |
︙ | ︙ |
Modified megatest.scm from [9e5e8b387a] to [b5b98a6d56].
︙ | ︙ | |||
917 918 919 920 921 922 923 | (debug:print 0 *default-log-port* "WARNING: \"-runtests\" is deprecated. Use \"-run\" with \"-testpatt\" instead")) (on-exit std-exit-procedure) ;;====================================================================== ;; Misc general calls ;;====================================================================== | | > > | | 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 | (debug:print 0 *default-log-port* "WARNING: \"-runtests\" is deprecated. Use \"-run\" with \"-testpatt\" instead")) (on-exit std-exit-procedure) ;;====================================================================== ;; Misc general calls ;;====================================================================== ;; TODO: Restore this functionality #; (if (and (args:get-arg "-cache-db") (args:get-arg "-source-db")) (let* ((temp-dir (or (args:get-arg "-target-db") (create-directory (conc "/tmp/" (getenv "USER") "/" (string-translate (current-directory) "/" "_"))))) (target-db (conc temp-dir "/cached.db")) (source-db (args:get-arg "-source-db"))) (db:cache-for-read-only source-db target-db) (set! *didsomething* #t))) |
︙ | ︙ | |||
1304 1305 1306 1307 1308 1309 1310 | (if (not (car *configinfo*)) (begin (debug:print-error 0 *default-log-port* "Attempted " action "on test(s) but run area config file not found") (exit 1)) ;; put test parameters into convenient variables (begin ;; check for correct version, exit with message if not correct | > > > | > | 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 | (if (not (car *configinfo*)) (begin (debug:print-error 0 *default-log-port* "Attempted " action "on test(s) but run area config file not found") (exit 1)) ;; put test parameters into convenient variables (begin ;; check for correct version, exit with message if not correct ;; TODO: restore this functionality ;; (common:exit-on-version-changed) (runs:operate-on action target runname testpatt state: (common:args-get-state) status: (common:args-get-status) new-state-status: (args:get-arg "-set-state-status") |
︙ | ︙ | |||
2145 2146 2147 2148 2149 2150 2151 | "Archive" (lambda (target runname keys keyvals) (operate-on 'archive target-in: target runname-in: runname ))))) ;;====================================================================== ;; Extract a spreadsheet from the runs database ;;====================================================================== | | > > | | 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 | "Archive" (lambda (target runname keys keyvals) (operate-on 'archive target-in: target runname-in: runname ))))) ;;====================================================================== ;; Extract a spreadsheet from the runs database ;;====================================================================== ;; TODO: Reenable this functionality #;(if (args:get-arg "-extract-ods") (general-run-call "-extract-ods" "Make ods spreadsheet" (lambda (target runname keys keyvals) (let ((dbstruct (make-dbr:dbstruct path: *toppath* local: #t)) (outputfile (args:get-arg "-extract-ods")) (runspatt (or (args:get-arg "-runname")(args:get-arg ":runname"))) |
︙ | ︙ | |||
2366 2367 2368 2369 2370 2371 2372 | (let ((testname (args:get-arg "-create-test"))) (genexample:mk-megatest-test testname) (set! *didsomething* #t))) ;;====================================================================== ;; Update the database schema, clean up the db ;;====================================================================== | | > > | | | 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 | (let ((testname (args:get-arg "-create-test"))) (genexample:mk-megatest-test testname) (set! *didsomething* #t))) ;;====================================================================== ;; Update the database schema, clean up the db ;;====================================================================== ;; TODO: Restore this functionality #;(if (args:get-arg "-rebuild-db") (begin (if (not (launch:setup)) (begin (debug:print 0 *default-log-port* "Failed to setup, exiting") (exit 1))) ;; keep this one local ;; (open-run-close patch-db #f) (let ((dbstruct (db:setup #f areapath: *toppath*))) (common:cleanup-db dbstruct full: #t)) (set! *didsomething* #t))) #;(if (args:get-arg "-cleanup-db") (begin (if (not (launch:setup)) (begin (debug:print 0 *default-log-port* "Failed to setup, exiting") (exit 1))) (let ((dbstruct (db:setup #f areapath: *toppath*))) (common:cleanup-db dbstruct)) |
︙ | ︙ | |||
2549 2550 2551 2552 2553 2554 2555 | ;; ;; ;; redo me (debug:print-info 0 *default-log-port* "Converting " (cadr item) " to " newval " for test #" (car item))) ;; ;; ;; redo me (sqlite3:execute qry newval (car item)))) ;; ;; ;; redo me dat) ;; ;; ;; redo me (sqlite3:finalize! qry)))) ;; ;; ;; redo me (db:close-all dbstruct) ;; ;; ;; redo me (list "uname" "rundir" "final_logf" "comment")) ;; ;; ;; redo me (set! *didsomething* #t))) | | > > | | | 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 | ;; ;; ;; redo me (debug:print-info 0 *default-log-port* "Converting " (cadr item) " to " newval " for test #" (car item))) ;; ;; ;; redo me (sqlite3:execute qry newval (car item)))) ;; ;; ;; redo me dat) ;; ;; ;; redo me (sqlite3:finalize! qry)))) ;; ;; ;; redo me (db:close-all dbstruct) ;; ;; ;; redo me (list "uname" "rundir" "final_logf" "comment")) ;; ;; ;; redo me (set! *didsomething* #t))) ;; TODO: restore this functionality #;(if (args:get-arg "-import-megatest.db") (begin (db:multi-db-sync (db:setup #f) 'killservers 'dejunk 'adj-testids 'old2new ;; 'new2old ) (set! *didsomething* #t))) (when (args:get-arg "-sync-brute-force") ((server:get-bruteforce-syncer (db:setup #t) persist-until-sync: #t)) (set! *didsomething* #t)) #;(if (args:get-arg "-sync-to-megatest.db") (let* ((dbstruct (db:setup #f)) (tmpdbpth (cdr (dbr:dbstruct-tmpdb dbstruct))) (lockfile (conc tmpdbpth ".lock")) (locked (common:simple-file-lock lockfile)) (res (if locked (db:multi-db-sync dbstruct |
︙ | ︙ |
Modified rmtmod.scm from [729f28cf76] to [06da62af7d].
︙ | ︙ | |||
1634 1635 1636 1637 1638 1639 1640 | (not (equal? (substring (->string megatest-version) 0 4) (substring (conc (common:get-last-run-version)) 0 4)))) ;;====================================================================== ;; Move me elsewhere ... ;; RADT => Why do we meed the version check here, this is called only if version misma ;; | | | 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 | (not (equal? (substring (->string megatest-version) 0 4) (substring (conc (common:get-last-run-version)) 0 4)))) ;;====================================================================== ;; Move me elsewhere ... ;; RADT => Why do we meed the version check here, this is called only if version misma ;; #;(define (common:cleanup-db dbstruct #!key (full #f)) (apply db:multi-db-sync dbstruct 'schema ;; 'new2old 'killservers 'adj-target ;; 'old2new |
︙ | ︙ | |||
1718 1719 1720 1721 1722 1723 1724 | 0) ;;====================================================================== ;; Force a megatest cleanup-db if version is changed and skip-version-check not specified ;; Do NOT check if not on homehost! ;; | | | 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 | 0) ;;====================================================================== ;; Force a megatest cleanup-db if version is changed and skip-version-check not specified ;; Do NOT check if not on homehost! ;; #;(define (common:exit-on-version-changed) (if (common:on-homehost?) (if (common:api-changed?) (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-writable? dbfile))) (dbstruct (db:setup #t))) (debug:print 0 *default-log-port* |
︙ | ︙ |