Megatest

Check-in [5e997071be]
Login
☰Home Timeline Files Branches Tags Tickets Wiki Login
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: 5e997071bea47f533abf7ca2a130cd919c946ccc
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
Hide Diffs Side-by-Side Diffs Ignore Whitespace Patch

Modified db.scm from [678efe323e] to [346b188c56].

︙
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

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 target runname run-meta)
(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 (runname,"keystr") VALUES (?,"key?str")"))
	   (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 runname)
			  db qrystr run-id runname)
			 res))))
      (if (null? runs)
        (begin
	  (db:create-initial-run-record dbstruct runname target))
      (let* ((run-id (db:get-run-id dbstruct runname target)))
	(db:with-db
	  (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))))))
			  ;; (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 runname target)	  
(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) "?") ","))
	 (qrystr   (conc "INSERT INTO runs (runname,"keystr") VALUES (?,"key?str")")))
	 (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
     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 runname targvals)))))
       (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)
    ;; (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
141

142
143
144
145
146
147
148

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: Unknown error with database for run-id "run-id", message: "
			(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

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

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
1052

1053
1054
1055
1056
1057

1058
1059
1060
1061
1062
1063
1064

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 (append (glob (conc *toppath* "/.mtdb/main.db")) (glob (conc *toppath* "/.mtdb/?.db"))(glob (conc *toppath* "/.mtdb/??.db"))))
        (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









2633
2634
2635
2636












2637
2638
2639
2640
2641
2642
2643

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
      (launch:setup)
      (rmt:import-sexpr (args:get-arg "-import-sexpr"))
      (set! *didsomething* #t)))
       (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

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


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

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?))))

	 (run-id     (rmt:insert-run target runname run-meta)))
    (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 target runname run-meta)
(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 target runname run-meta))
	(simple-run-id (car runs)))))
	(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?)))
    (debug:print 0 *default-log-port* "   Insert test in run "run-id": "testname"/"item-path)
    (rmtmod:send-receive 'insert-test run-id test-rec)))

;;======================================================================
;;  T E S T S
;;======================================================================

;; Just some syntatic sugar
︙

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