Megatest

Check-in [cff44e26a5]
Login
☰Home Timeline Files Branches Tags Tickets Wiki Login
Overview
Comment:wip, compiles
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | v1.6584-ck5
Files: files | file ages | folders
SHA1: cff44e26a59a995ae29913dfa416fdaaf32d5514
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
Hide Diffs Side-by-Side Diffs Ignore Whitespace Patch

Modified apimod.scm from [499827ca49] to [ef19086eeb].

︙
252
253
254
255
256
257
258
259
260
261
262
263





264
265
266
267
268
269
270

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)) 
;;                    ((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

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
470
471





472
473
474
475
476
477
478

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)
      (db:multi-db-sync 
   (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



28

29
30
31
32
33
34
35

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)
#;(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

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

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
924
925




926
927
928
929
930
931
932

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
     ;;======================================================================
     
     (if (and (args:get-arg "-cache-db")

;; 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



1311


1312
1313
1314
1315
1316
1317
1318

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)
	    ;; (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
2152
2153




2154
2155
2156
2157
2158
2159
2160

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
     ;;======================================================================
     
     (if (args:get-arg "-extract-ods")

;; 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
2373
2374




2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385
2386

2387
2388
2389
2390
2391
2392
2393

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
     ;;======================================================================
     
     (if (args:get-arg "-rebuild-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")
     #;(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
2556
2557




2558
2559
2560
2561
2562
2563
2564
2565
2566
2567
2568
2569
2570
2571
2572
2573

2574
2575
2576
2577
2578
2579
2580

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)))
     
     (if (args:get-arg "-import-megatest.db")

;; 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")
     #;(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
1641

1642
1643
1644
1645
1646
1647
1648

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))
#;(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
1725

1726
1727
1728
1729
1730
1731
1732

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)
#;(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*




︙












This page was generated in about
0.112s by
Fossil 2.24 [452f8e1ffc] 2024-03-26 15:36:00