Megatest

Check-in [400675ea9b]
Login
☰Home Timeline Files Branches Tags Tickets Wiki Login
Overview
Comment:rmt:get-keys now working
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | v1.7001-multi-db-02
Files: files | file ages | folders
SHA1: 400675ea9b74fd1b6c31c5a2778bcabc46b7deaa
User & Date: matt on 2022-03-27 19:45:31
Other Links: branch diff | manifest | tags
Context
2022-03-27
19:45
rmt:get-keys now working Closed-Leaf check-in: 400675ea9b user: matt tags: v1.7001-multi-db-02
2022-03-25
19:52
Removed nearly all the defenses built into Megatest v1.65 database handling. v1.70 has the beginnings of a raw start check-in: e4ffe733d9 user: matt tags: v1.7001-multi-db-02
Changes
Hide Diffs Side-by-Side Diffs Ignore Whitespace Patch

Modified archive.scm from [91a1f5c7df] to [9231707c41].

︙
395
396
397
398
399
400
401
402

403
404
405
406
407
408
409

395
396
397
398
399
400
401

402
403
404
405
406
407
408
409








-
+








   (let* ((bup-exe               (or (configf:lookup *configdat* "archive" "bup") "bup"))
         (archive-internal-path (conc (common:get-testsuite-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 
       (db:setup #t *toppath*) ;; (db:setup-db *dbstruct-dbs* *toppath* #f)
       (db:setup #t) ;; (db:setup-db *dbstruct-dbs* *toppath* #f)
       'killservers
       ;'dejunk
       ;'adj-testids
       'old2new
       )
      (debug:print-info 1 *default-log-port* "dropping triggers to update linktree") 
      (rmt:drop-all-triggers)
︙

Modified common.scm from [84646d3764] to [32dded1e96].

︙
591
592
593
594
595
596
597
598

599
600
601
602
603
604
605

591
592
593
594
595
596
597

598
599
600
601
602
603
604
605








-
+








;;
(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-write-access? dbfile)))
                 (dbstruct (db:setup #t *toppath*))) ;; (db:setup-db *dbstruct-dbs* *toppath* #f))) ;;  #t)))
                 (dbstruct (db:setup #t))) ;; (db:setup-db *dbstruct-dbs* *toppath* #f))) ;;  #t)))
	    (debug:print 0 *default-log-port*
			 "WARNING: Version mismatch!\n"
			 "   expected: " (common:version-signature) "\n"
			 "   got:      " (common:get-last-run-version))
            (cond
             ((get-environment-variable "MT_SKIP_DB_MIGRATE") #t)
             ((and (common:file-exists? mtconf) (common:file-exists? dbfile) (not read-only)
︙

Modified db.scm from [4f44b2e67a] to [384fb25c83].

︙
133
134
135
136
137
138
139

140

141
142
143
144
145
146
147

133
134
135
136
137
138
139
140

141
142
143
144
145
146
147
148








+
-
+








		     ", error: "     ((condition-property-accessor 'exn 'message)   exn)
		     ", arguments: " ((condition-property-accessor 'exn 'arguments) exn)
		     ", location: "  ((condition-property-accessor 'exn 'location)  exn)
		     ))

(define (db:setup do-sync)
  (assert *toppath* "FATAL: db:setup called before launch:setup has been run.")
  (let* ((tmpdir (common:get-db-tmp-area)))
  (dbfile:setup do-sync *toppath*))
    (dbfile:setup do-sync *toppath* tmpdir)))

;; looks up subdb and returns it, if not found then set up
;; and then return it.
;;
#;(define (db:get-db dbstruct run-id)
  (let* ((res (dbfile:get-subdb dbstruct run-id)))
    (if res
︙
179
180
181
182
183
184
185



186
187
188
189
190
191
192

193
194
195
196
197
198
199

180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195

196
197
198
199
200
201
202
203








+
+
+






-
+








  (apply debug:print-error 0 *default-log-port* message)
  (debug:print-error 0 *default-log-port* "   params: " params
		     ", error: "     ((condition-property-accessor 'exn 'message)   exn)
		     ", arguments: " ((condition-property-accessor 'exn 'arguments) exn)
		     ", location: "  ((condition-property-accessor 'exn 'location)  exn)
		     ))

(define (db:open-db dbstruct run-id)
  (dbfile:open-db dbstruct run-id db:initialize-main-db))

;; (db:with-db dbstruct run-id sqlite3:exec "select blah fgrom blaz;")
;; r/w is a flag to indicate if the db is modified by this query #t = yes, #f = no
;;
(define (db:with-db dbstruct run-id r/w proc . params)
  (let* ((have-struct (dbr:dbstruct? dbstruct))
         (dbdat     (if have-struct                ;; this stuff just allows us to call with a db handle directly
			(db:get-subdb dbstruct run-id)
			(db:open-db dbstruct run-id) ;; (dbfile:get-subdb dbstruct run-id)
			#f))
	 (db        (if have-struct                ;; this stuff just allows us to call with a db handle directly
			(dbr:dbdat-dbh dbdat)
			dbstruct))
	 (fname     (if dbdat
			(dbr:dbdat-dbfile dbdat)
			"nofilenameavailable"))
︙
1268
1269
1270
1271
1272
1273
1274
1275

1276
1277
1278
1279
1280
1281
1282
1283

1284
1285
1286
1287
1288
1289
1290

1272
1273
1274
1275
1276
1277
1278

1279
1280
1281
1282
1283
1284
1285
1286

1287
1288
1289
1290
1291
1292
1293
1294








-
+







-
+








                              (conc "update_" tbl-name "_trigger"))))
       (for-each (lambda (key) 
             (if (equal? (car key) trigger-name)
             (sqlite3:execute db (cadr key))))
      db:trigger-list))) 


(define (db:initialize-main-db dbdat)
(define (db:initialize-main-db db)
  (when (not *configinfo*)
           (launch:setup)) ;; added because Elena was getting stack dump because *configinfo* below was #f.
  (let* ((configdat (car *configinfo*))  ;; tut tut, global warning...
	 (keys     (keys:config-get-fields configdat))
	 (havekeys (> (length keys) 0))
	 (keystr   (keys->keystr keys))
	 (fieldstr (keys:make-key/field-string configdat))
	 (db       (dbr:dbdat-dbh dbdat)))
	 #;(db       (dbr:dbdat-dbh dbdat)))
    (for-each (lambda (key)
		(let ((keyn key))
		  (if (member (string-downcase keyn)
			      (list "runname" "state" "status" "owner" "event_time" "comment" "fail_count"
				    "pass_count" "contour"))
		      (begin
			(print "ERROR: your key cannot be named " keyn " as this conflicts with the same named field in the runs table, you must remove your megatest.db and <linktree>/.db before trying again.")
︙

Modified dbfile.scm from [c3b47573e8] to [be245468de].

︙
225
226
227
228
229
230
231
232
233

234
235
236
237
238
239
240

225
226
227
228
229
230
231

232
233
234
235
236
237
238
239
240








-

+








	 (tmpdbpath (dbfile:run-id->path tmppath run-id))
	 (mtdbdat   (dbfile:open-sqlite3-db mtdbpath init-proc))
	 (tmpdbdat  (dbfile:open-sqlite3-db tmpdbpath init-proc)) ;; push this on the stack
	 (newsubdb  (make-dbr:subdb dbname:    dbname
				    mtdbfile:  mtdbpath
				    tmpdbfile: tmpdbpath
				    mtdbdat:   mtdbdat)))
    (dbfile:add-dbdat dbstruct run-id tmpdbdat)
    (dbfile:set-subdb dbstruct run-id newsubdb)
    (dbfile:add-dbdat dbstruct run-id tmpdbdat)
    newsubdb)) ;; return the new subdb - but shouldn't really use it

;; returns dbdat with dbh and dbfilepath
;;  1. if needed setup the subdb for the given run-id
;;  2. if there is no existing db handle in the stack
;;     create a new handle and return it (do NOT add
;;     it to the stack).
︙

Modified http-transport.scm from [ffeae77768] to [3300e19a72].

︙
459
460
461
462
463
464
465
466

467
468
469
470
471
472
473

459
460
461
462
463
464
465

466
467
468
469
470
471
472
473








-
+








	       (server-state 'available)
	       (bad-sync-count 0)
	       (start-time     (current-milliseconds)))
      ;; Use this opportunity to sync the tmp db to megatest.db
      (if (not server-going) ;; *dbstruct-dbs* 
	  (begin
	    (debug:print 0 *default-log-port* "SERVER: dbprep")
	    (set! *dbstruct-dbs*  (db:setup #t *toppath*)) ;;  run-id)) FIXME!!!
	    (set! *dbstruct-dbs*  (db:setup #t)) ;;  run-id)) FIXME!!!
	    (set! server-going #t)
	    (debug:print 0 *default-log-port* "SERVER: running, megatest version: " (common:get-full-version)) ;; NOTE: the server is NOT yet marked as running in the log. We do that in the keep-running routine.
	    (thread-start! *watchdog*)))
      
      ;; when things go wrong we don't want to be doing the various queries too often
      ;; so we strive to run this stuff only every four seconds or so.
      (let* ((sync-time (- (current-milliseconds) start-time))
︙

Modified megatest.scm from [e1bdb1ecbd] to [718f8c5f41].

︙
2301
2302
2303
2304
2305
2306
2307
2308

2309
2310
2311
2312
2313
2314
2315
2316
2317
2318

2319
2320
2321
2322
2323
2324
2325

2301
2302
2303
2304
2305
2306
2307

2308
2309
2310
2311
2312
2313
2314
2315
2316
2317

2318
2319
2320
2321
2322
2323
2324
2325








-
+









-
+








    (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 ((dbstructs (db:setup #f *toppath*)))
      (let ((dbstructs (db:setup #f)))
        (common:cleanup-db dbstructs 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 ((dbstructs (db:setup #f *toppath*)))
      (let ((dbstructs (db:setup #f)))
        (common:cleanup-db dbstructs))
      (set! *didsomething* #t)))

(if (args:get-arg "-mark-incompletes")
    (begin
      (if (not (launch:setup))
	  (begin
︙
2370
2371
2372
2373
2374
2375
2376
2377

2378
2379
2380
2381
2382
2383
2384

2370
2371
2372
2373
2374
2375
2376

2377
2378
2379
2380
2381
2382
2383
2384








-
+









(if (or (getenv "MT_RUNSCRIPT")
	(args:get-arg "-repl")
	(args:get-arg "-load"))
    (let* ((toppath (launch:setup))
	   (dbstructs (if (and toppath
                               (common:on-homehost?))
                          (dbfile:setup #t toppath)
                          (db:setup #t)
                          #f))) ;; make-dbr:dbstruct path: toppath local: (args:get-arg "-local")) #f)))
      (if *toppath*
	  (cond
	   ((getenv "MT_RUNSCRIPT")
	    ;; How to run megatest scripts
	    ;;
	    ;; #!/bin/bash
︙
2461
2462
2463
2464
2465
2466
2467
2468

2469
2470
2471
2472
2473
2474
2475
2476
2477
2478
2479

2480
2481
2482
2483
2484
2485
2486

2461
2462
2463
2464
2465
2466
2467

2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
2478

2479
2480
2481
2482
2483
2484
2485
2486








-
+










-
+








;; ;; ;; redo me        (list "uname" "rundir" "final_logf" "comment"))
;; ;; ;; redo me       (set! *didsomething* #t)))

(if (args:get-arg "-import-megatest.db")
    (begin
      (launch:setup)
      (db:multi-db-sync 
       (db:setup #f *toppath*)
       (db:setup #f)
       'killservers
       'dejunk
       'adj-testids
       'old2new
       ;; 'new2old
       )
      (set! *didsomething* #t)))

(when (args:get-arg "-sync-brute-force")
  (launch:setup)
  ((server:get-bruteforce-syncer (db:setup #t *toppath*) persist-until-sync: #t))
  ((server:get-bruteforce-syncer (db:setup #t) persist-until-sync: #t))
  (set! *didsomething* #t))

(if (args:get-arg "-sync-to-megatest.db")
    (let* ((duh      (launch:setup))
	   (dbstruct (db:setup #f))
	   (tmpdbpth (cdr (dbr:dbstruct-tmpdb dbstruct)))
	   (lockfile (conc tmpdbpth ".lock"))
︙

Modified rmt.scm from [f95a70f6c9] to [842b52e01e].

︙
368
369
370
371
372
373
374
375

376
377
378
379
380
381
382

368
369
370
371
372
373
374

375
376
377
378
379
380
381
382








-
+








			     (loop (car tal)(cdr tal) newmax-cmd currmax)))))))
    (mutex-unlock! *db-stats-mutex*)
    res))

(define (rmt:open-qry-close-locally cmd run-id params #!key (remretries 5))
  (let* ((qry-is-write    (not (member cmd api:read-only-queries)))
	 (db-file-path    (db:dbfile-path)) ;;  0))
	 (dbstructs-local (db:setup #t *toppath*))  ;; make-dbr:dbstruct path:  dbdir local: #t)))
	 (dbstructs-local (db:setup #t))  ;; make-dbr:dbstruct path:  dbdir local: #t)))
	 (read-only       (not (file-write-access? db-file-path)))
	 (start           (current-milliseconds))
	 (resdat          (if (not (and read-only qry-is-write))
			      (let ((v (api:execute-requests dbstructs-local (vector (symbol->string cmd) params))))
				(handle-exceptions ;; there has been a long history of receiving strange errors from values returned by the client when things go wrong..
				 exn               ;;  This is an attempt to detect that situation and recover gracefully
				 (begin
︙

Modified tests/simplerun/thebeginning.scm from [bad078aed6] to [5b513666c4]. 

1
2
3
4
5






6
7
8

9

10
11
12
13
14
15
16


17
18
19
20
21
22
23

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15

16
17
18
19
20
21


22
23
24
25
26
27
28
29
30






+
+
+
+
+
+



+
-
+





-
-
+
+








(use trace test (prefix sqlite3 sqlite3:))
(import dbfile)
(trace-call-sites #t)

(trace
 ;; dbfile:setup
 ;; dbfile:open-sqlite3-db
 ;; dbfile:init-subdb
 ;; dbfile:add-dbdat
 ;; dbfile:set-subdb
 ;; db:with-db
 ;; dbfile:get-subdb
 )

(define tmpdir (common:get-db-tmp-area))
(test #f #t (dbr:dbstruct? (dbfile:setup #t *toppath*)))
(test #f #t (dbr:dbstruct? (dbfile:setup #t *toppath* tmpdir)))
(test #f #t (dbr:dbstruct? (db:setup #t)))
(define dbstruct *dbstruct-dbs*)
(test #f #f (dbfile:get-subdb dbstruct #f)) ;; get main.db (never opened yet)
(test #f #f (dbfile:get-subdb dbstruct 1))  ;; get 1.db
(test #f #t (hash-table? (dbr:dbstruct-subdbs dbstruct)))

(test #f #t (dbr:dbdat? (dbfile:get-dbdat *dbstruct-dbs* #f)))
(test #f #t (dbr:dbdat? (dbfile:open-db *dbstruct-dbs* #f db:initialize-main-db)))
(test #f '("SYSTEM" "RELEASE") (db:get-keys *dbstruct-dbs*))

;; test #f #t (sqlite3:database? (db:open-db dbstruct #f)))
;; test #f #t (sqlite3:database? (db:open-db dbstruct 1)))
;; 
;; test #f #t (stack? (dbr:subdb-dbstack subdb
;; test #f #f (db:get-subdb dbstruct 1))
;;
︙

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