Megatest

Changes On Branch 19769d349d39b3d3
Login
☰Home Timeline Files Branches Tags Tickets Wiki Login
Hide Diff Patch Side-by-Side Diff

Changes In Branch normalize-db Through [19769d349d] Excluding Merge-Ins

This is equivalent to a diff from 76e1588a7c to 19769d349d

2013-10-30
07:41
Added placeholder for script runner mtrunscript check-in: 9890845462 user: matt tags: v1.55
2013-10-29
15:53
Added migration to new format but -test-path not ported check-in: 541aae0765 user: mrwellan tags: normalize-db
09:20
Normalized rundir, uname and others check-in: 19769d349d user: mrwellan tags: normalize-db
00:02
Normalize db experiments check-in: 1d81882ece user: matt tags: normalize-db
00:01
Fixed couple typos check-in: 76e1588a7c user: matt tags: v1.55, v1.5513-1
2013-10-28
23:22
Completed sdb code check-in: f20d481bb0 user: matt tags: v1.55

Modified dashboard-tests.scm from [7817a2c78f] to [6bf2b48df2].

︙
23
24
25
26
27
28
29

30
31
32
33
34
35
36

23
24
25
26
27
28
29
30
31
32
33
34
35
36
37








+








(import (prefix sqlite3 sqlite3:))

(declare (unit dashboard-tests))
(declare (uses common))
(declare (uses db))
(declare (uses gutils))
(declare (uses ezsteps))
(declare (uses sdb))

(include "common_records.scm")
(include "db_records.scm")
(include "run_records.scm")

(define (test-info-panel testdat store-label widgets)
  (iup:frame
︙
71
72
73
74
75
76
77
78

79
80
81
82
83
84
85

72
73
74
75
76
77
78

79
80
81
82
83
84
85
86








-
+








														   (db:test-get-status testdat))))
					 (iup:attribute-set! lbl "TITLE" (db:test-get-status testdat)))))))
	      lbl)
	    (store-label "testcomment"
			 (iup:label "TestComment                             "
				    #:expand "HORIZONTAL")
			 (lambda (testdat)
			   (db:test-get-comment testdat)))
			   (sdb:qry 'getstr (db:test-get-comment testdat))))
	    (store-label "testid"
			 (iup:label "TestId                             "
				    #:expand "HORIZONTAL")
			 (lambda (testdat)
			   (db:test-get-id testdat)))
	    (store-label "testdate" 
			 (iup:label "TestDate                           "
︙
178
179
180
181
182
183
184
185

186
187
188
189

190
191
192
193
194
195
196

179
180
181
182
183
184
185

186
187
188
189

190
191
192
193
194
195
196
197








-
+



-
+








			      "Run duration: "
			      "Logfile: "))
		   (iup:label "" #:expand "VERTICAL")))
    (apply iup:vbox ; #:expand "YES"
	   (list
	    ;; NOTE: Yes, the host can change!
	    (store-label "HostName"
			 (iup:label (db:test-get-host testdat) #:expand "HORIZONTAL")
			 (iup:label (sdb:qry 'getstr (db:test-get-host testdat)) #:expand "HORIZONTAL")
			 (lambda (testdat)(db:test-get-host testdat)))
	    (store-label "Uname"
			 (iup:label "                                                   " #:expand "HORIZONTAL")
			 (lambda (testdat)(db:test-get-uname testdat)))
			 (lambda (testdat)(sdb:qry 'getstr (db:test-get-uname testdat))))
	    (store-label "DiskFree"
			 (iup:label (conc (db:test-get-diskfree testdat)) #:expand "HORIZONTAL")
			 (lambda (testdat)(conc (db:test-get-diskfree testdat))))
	    (store-label "CPULoad"
			 (iup:label (conc (db:test-get-cpuload testdat)) #:expand "HORIZONTAL")
			 (lambda (testdat)(conc (db:test-get-cpuload testdat))))
	    (store-label "RunDuration"
︙
381
382
383
384
385
386
387
388

389
390
391
392
393
394
395

382
383
384
385
386
387
388

389
390
391
392
393
394
395
396








-
+








						     (debug:print-info 2 "test db access issue: " ((condition-property-accessor 'exn 'message) exn))
						     (open-run-close db:get-test-info-by-id db test-id )))))
			       (cond
				((and need-update newtestdat)
				 (set! testdat newtestdat)
				 (set! teststeps    (db:get-compressed-steps test-id work-area: rundir))
				 (set! logfile      (conc (db:test-get-rundir testdat) "/" (db:test-get-final_logf testdat)))
				 (set! rundir       (db:test-get-rundir testdat))
				 (set! rundir       (sdb:qry 'getstr (db:test-get-rundir testdat)))
				 (set! testfullname (db:test-get-fullname testdat))
				 ;; (debug:print 0 "INFO: teststeps=" (intersperse teststeps "\n    "))
				 (if (eq? curr-mod-time db-mod-time) ;; do only once if same
				     (set! db-mod-time (+ curr-mod-time 1))
				     (set! db-mod-time curr-mod-time))
				 (set! last-update (current-milliseconds))
				 (set! request-update #f) ;; met the need ...
︙

Modified db.scm from [6da6156c30] to [b08cbf488a].

︙
26
27
28
29
30
31
32

33
34
35
36
37
38
39

26
27
28
29
30
31
32
33
34
35
36
37
38
39
40








+








(declare (unit db))
(declare (uses common))
(declare (uses keys))
(declare (uses ods))
(declare (uses fs-transport))
(declare (uses client))
(declare (uses mt))
(declare (uses sdb))

(include "common_records.scm")
(include "db_records.scm")
(include "key_records.scm")
(include "run_records.scm")

;; timestamp type (val1 val2 ...)
︙
58
59
60
61
62
63
64

65
66
67
68
69
70
71

59
60
61
62
63
64
65
66
67
68
69
70
71
72
73








+








		    (else 
		     (debug:print 0 "ERROR: synchronous must be 0,1,2,OFF,NORMAL or FULL, you provided: " syncval)
		     #f))))
    (if val
	(begin
	  (debug:print-info 9 "db:set-sync, setting pragma synchronous to " val)
	  (sqlite3:execute db (conc "PRAGMA synchronous = '" val "';"))))))
;;	(sqlite3:execute db "PRAGMA synchronous = normal;")))) ;; need a default?

(define (open-db) ;;  (conc *toppath* "/megatest.db") (car *configinfo*)))
  (if (not *toppath*)
      (if (not (setup-for-run))
	  (begin
	    (debug:print 0 "ERROR: Attempted to open db when not in megatest area. Exiting.")
	    (exit))))
︙
288
289
290
291
292
293
294
295

296
297
298
299
300
301
302

290
291
292
293
294
295
296

297
298
299
300
301
302
303
304








-
+








	(debug:print-info 11 "open-test-db END (unsucessful)" work-area)
	#f)))

;; find and open the testdat.db file for an existing test
(define (db:open-test-db-by-test-id db test-id #!key (work-area #f))
  (let* ((test-path (if work-area
			work-area
			(cdb:remote-run db:test-get-rundir-from-test-id db test-id))))
			(sdb:qry 'getstr (cdb:remote-run db:test-get-rundir-from-test-id db test-id)))))
    (debug:print 3 "TEST PATH: " test-path)
    (open-test-db test-path)))

(define (db:testdb-initialize db)
  (debug:print 11 "db:testdb-initialize START")
  (for-each
   (lambda (sqlcmd)
︙
861
862
863
864
865
866
867
868
869

870
871
872
873
874
875
876
877

863
864
865
866
867
868
869


870

871
872
873
874
875
876
877








-
-
+
-








     run-id)
    (debug:print-info 11 "db:get-run-info run-id: " run-id " header: " header " keystr: " keystr)
    (let ((finalres (vector header res)))
      ;; (hash-table-set! *run-info-cache* run-id finalres)
      finalres)))

(define (db:set-comment-for-run db run-id comment)
  (debug:print-info 11 "db:set-comment-for-run START run-id: " run-id " comment: " comment)
  (sqlite3:execute db "UPDATE runs SET comment=? WHERE id=?;" comment run-id)
  (sqlite3:execute db "UPDATE runs SET comment=? WHERE id=?;" (sdb:qry 'getid comment) run-id))
  (debug:print-info 11 "db:set-comment-for-run END run-id: " run-id " comment: " comment))

;; does not (obviously!) removed dependent data. But why not!!?
(define (db:delete-run db run-id)
  (common:clear-caches) ;; don't trust caches after doing any deletion
  ;; First set any related tests to DELETED
  (let ((stmt1 (sqlite3:prepare db "UPDATE tests SET state='DELETED',comment='' WHERE run_id=?;"))
	(stmt2 (sqlite3:prepare db "UPDATE runs SET state='deleted',comment='' WHERE id=?;")))
︙
1163
1164
1165
1166
1167
1168
1169
1170

1171
1172
1173
1174
1175
1176
1177
1178

1179
1180
1181
1182
1183
1184

1185
1186
1187
1188
1189
1190
1191

1163
1164
1165
1166
1167
1168
1169

1170
1171
1172
1173
1174
1175
1176
1177

1178
1179
1180
1181
1182
1183

1184
1185
1186
1187
1188
1189
1190
1191








-
+







-
+





-
+








(define (cdb:tests-update-cpuload-diskfree serverdat test-id cpuload diskfree)
  (cdb:client-call serverdat 'update-cpuload-diskfree #t *default-numtries* cpuload diskfree test-id))

(define (cdb:tests-update-run-duration serverdat test-id minutes)
  (cdb:client-call serverdat 'update-run-duration #t *default-numtries* minutes test-id))

(define (cdb:tests-update-uname-host serverdat test-id uname hostname)
  (cdb:client-call serverdat 'update-uname-host #t *default-numtries* uname hostname test-id))
  (cdb:client-call serverdat 'update-uname-host #t *default-numtries* (sdb:qry 'getid uname)(sdb:qry 'getid  hostname) test-id))

;; speed up for common cases with a little logic
;; NB// Ultimately this will be deprecated in deference to mt:test-set-state-status-by-id
;;
(define (db:test-set-state-status-by-id db test-id newstate newstatus newcomment)
  (cond
   ((and newstate newstatus newcomment)
    (sqlite3:execute db "UPDATE tests SET state=?,status=?,comment=? WHERE id=?;" newstate newstatus newcomment test-id))
    (sqlite3:execute db "UPDATE tests SET state=?,status=?,comment=? WHERE id=?;" newstate newstatus (sdb:qry 'getid newcomment) test-id))
   ((and newstate newstatus)
    (sqlite3:execute db "UPDATE tests SET state=?,status=? WHERE id=?;" newstate newstatus test-id))
   (else
    (if newstate   (sqlite3:execute db "UPDATE tests SET state=?   WHERE id=?;" newstate   test-id))
    (if newstatus  (sqlite3:execute db "UPDATE tests SET status=?  WHERE id=?;" newstatus  test-id))
    (if newcomment (sqlite3:execute db "UPDATE tests SET comment=? WHERE id=?;" newcomment test-id))))
    (if newcomment (sqlite3:execute db "UPDATE tests SET comment=? WHERE id=?;" (sdb:qry 'getid newcomment) test-id))))
  (mt:process-triggers test-id newstate newstatus))

;; Never used
;; (define (db:test-set-state-status-by-run-id-testname db run-id test-name item-path status state)
;;   (sqlite3:execute db "UPDATE tests SET state=?,status=?,event_time=strftime('%s','now') WHERE run_id=? AND testname=? AND item_path=?;" 
;; 		   state status run-id test-name item-path))
︙
1343
1344
1345
1346
1347
1348
1349
1350

1351
1352
1353


1354
1355
1356


1357
1358
1359
1360
1361
1362
1363

1343
1344
1345
1346
1347
1348
1349

1350
1351


1352
1353
1354


1355
1356
1357
1358
1359
1360
1361
1362
1363








-
+

-
-
+
+

-
-
+
+








(define (db:get-test-info db run-id testname item-path)
  (db:get-test-info-by-id db (db:get-test-id db run-id testname item-path)))

(define (db:test-set-comment db test-id comment)
  (sqlite3:execute 
   db
   "UPDATE tests SET comment=? WHERE id=?;"
   comment test-id))
   (sdb:qry 'getid comment) test-id))

(define (cdb:test-set-rundir! serverdat run-id test-name item-path rundir)
  (cdb:client-call serverdat 'test-set-rundir #t *default-numtries* rundir run-id test-name item-path))
(define (cdb:test-set-rundir! serverdat run-id test-name item-path rundir-id)
  (cdb:client-call serverdat 'test-set-rundir #t *default-numtries* rundir-id run-id test-name item-path))

(define (cdb:test-set-rundir-by-test-id serverdat test-id rundir)
  (cdb:client-call serverdat 'test-set-rundir-by-test-id #t *default-numtries* rundir test-id))
(define (cdb:test-set-rundir-by-test-id serverdat test-id rundir-id)
  (cdb:client-call serverdat 'test-set-rundir-by-test-id #t *default-numtries* rundir-id test-id))

(define (db:test-get-rundir-from-test-id db test-id)
  (let ((res #f)) ;; (hash-table-ref/default *test-paths* test-id #f)))
    ;; (if res
    ;;     res
    ;;     (begin
    (sqlite3:for-each-row
︙

Modified launch.scm from [ae5ddfc81a] to [b994a7eaec].

︙
17
18
19
20
21
22
23

24
25
26
27
28
29
30

17
18
19
20
21
22
23
24
25
26
27
28
29
30
31








+








(import (prefix base64 base64:))
(import (prefix sqlite3 sqlite3:))

(declare (unit launch))
(declare (uses common))
(declare (uses configf))
(declare (uses db))
(declare (uses sdb))

(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")

;;======================================================================
;; ezsteps
︙
492
493
494
495
496
497
498
499

500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520

521
522
523

524
525
526
527
528
529
530

493
494
495
496
497
498
499

500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520

521
522
523

524
525
526
527
528
529
530
531








-
+




















-
+


-
+








		      (if rd rd (conc *toppath* "/runs"))))

	 (lnkbase  (conc linktree "/" target "/" runname))
	 (lnkpath  (conc lnkbase "/" testname))
	 (lnkpathf (conc lnkpath (if not-iterated "" "/") item-path)))

    ;; Update the rundir path in the test record for all
    (cdb:test-set-rundir-by-test-id *runremote* test-id lnkpathf)
    (cdb:test-set-rundir-by-test-id *runremote* test-id (sdb:qry 'getid lnkpathf))

    (debug:print 2 "INFO:\n       lnkbase=" lnkbase "\n       lnkpath=" lnkpath "\n  toptest-path=" toptest-path "\n     test-path=" test-path)
    (if (not (file-exists? linktree))
	(begin
	  (debug:print 0 "WARNING: linktree did not exist! Creating it now at " linktree)
	  (create-directory linktree #t))) ;; (system (conc "mkdir -p " linktree))))
    ;; create the directory for the tests dir links, this is needed no matter what...
    (if (and (not (directory-exists? lnkbase))
	     (not (file-exists? lnkbase)))
	(create-directory lnkbase #t))
    
    ;; update the toptest record with its location rundir, cache the path
    ;; This wass highly inefficient, one db write for every subtest, potentially
    ;; thousands of unnecessary updates, cache the fact it was set and don't set it 
    ;; again. 

    ;; NB - This is not working right - some top tests are not getting the path set!!!

    (if (not (hash-table-ref/default *toptest-paths* testname #f))
	(let* ((testinfo       (cdb:get-test-info-by-id *runremote* test-id)) ;;  run-id testname item-path))
	       (curr-test-path (if testinfo (db:test-get-rundir testinfo) #f)))
	       (curr-test-path (if testinfo (sdb:qry 'getstr (db:test-get-rundir testinfo)) #f)))
	  (hash-table-set! *toptest-paths* testname curr-test-path)
	  ;; NB// Was this for the test or for the parent in an iterated test?
	  (cdb:test-set-rundir! *runremote* run-id testname "" lnkpath) ;; toptest-path)
	  (cdb:test-set-rundir! *runremote* run-id testname "" (sdb:qry 'getid lnkpath)) ;; toptest-path)
	  (if (or (not curr-test-path)
		  (not (directory-exists? toptest-path)))
	      (begin
		(debug:print-info 2 "Creating " toptest-path " and link " lnkpath)
		(create-directory toptest-path #t)
		(hash-table-set! *toptest-paths* testname toptest-path)))))
︙

Modified megatest.scm from [dc048f2b48] to [28774d006a].

︙
23
24
25
26
27
28
29

30
31
32
33
34
35
36

23
24
25
26
27
28
29
30
31
32
33
34
35
36
37








+








(declare (uses launch))
(declare (uses server))
(declare (uses client))
(declare (uses tests))
(declare (uses genexample))
(declare (uses daemon))
(declare (uses db))
(declare (uses sdb))

(define *db* #f) ;; this is only for the repl, do not use in general!!!!

(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
︙
288
289
290
291
292
293
294

295
296
297
298
299
300
301

289
290
291
292
293
294
295
296
297
298
299
300
301
302
303








+








;;  (hash-table-set! args:arg-hash "-transport" "fs"))

;;======================================================================
;; Misc setup stuff
;;======================================================================

(debug:setup)
(sdb:qry 'init #f)

(if (args:get-arg "-logging")(set! *logging* #t))

(if (debug:debug-mode 3) ;; we are obviously debugging
    (set! open-run-close open-run-close-no-exception-handling))

(if (args:get-arg "-itempatt")
︙
620
621
622
623
624
625
626
627
628


629
630
631
632
633
634
635

622
623
624
625
626
627
628


629
630
631
632
633
634
635
636
637








-
-
+
+








				(db:test-get-host test))
			(if (not (or (equal? (db:test-get-status test) "PASS")
				     (equal? (db:test-get-status test) "WARN")
				     (equal? (db:test-get-state test)  "NOT_STARTED")))
			    (begin
			      (print "         cpuload:  " (db:test-get-cpuload test)
				     "\n         diskfree: " (db:test-get-diskfree test)
				     "\n         uname:    " (db:test-get-uname test)
				     "\n         rundir:   " (db:test-get-rundir test)
				     "\n         uname:    " (sdb:qry 'getstr (db:test-get-uname test))
				     "\n         rundir:   " (sdb:qry 'getstr (db:test-get-rundir test))
				     )
			      ;; Each test
			      ;; DO NOT remote run
			      (let ((steps (db:get-steps-for-test #f (db:test-get-id test))))
				(for-each 
				 (lambda (step)
				   (format #t
︙
1162
1163
1164
1165
1166
1167
1168


1169
1170
1171
1172
1173
1174
1175

1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179








+
+









(if *runremote* (close-all-connections!))

;; this is the socket if we are a client
;; (if (and *runremote*
;; 	 (socket? *runremote*))
;;     (close-socket *runremote*))

(sdb:qry 'finalize! #f)

(if (not *didsomething*)
    (debug:print 0 help))

;; (if *runremote* (rpc:close-all-connections!))
    
(if (not (eq? *globalexitstatus* 0))
︙

Modified mt.scm from [4beb856e75] to [f901ea9aed].

︙
110
111
112
113
114
115
116
117

118
119
120
121
122
123
124

110
111
112
113
114
115
116

117
118
119
120
121
122
123
124








-
+









;;======================================================================
;;  T R I G G E R S
;;======================================================================

(define (mt:process-triggers test-id newstate newstatus)
  (let* ((test-dat      (mt:lazy-get-test-info-by-id test-id))
	 (test-rundir   (db:test-get-rundir test-dat))
	 (test-rundir   (sdb:qry 'getstr (db:test-get-rundir test-dat)))
	 (test-name     (db:test-get-testname test-dat))
	 (tconfig       #f)
	 (state         (if newstate  newstate  (db:test-get-state  test-dat)))
	 (status        (if newstatus newstatus (db:test-get-status test-dat))))
    (if (and (file-exists? test-rundir)
	     (directory? test-rundir))
	(begin
︙

Modified runs.scm from [954fc2f4a3] to [00b9e6b739].

︙
1209
1210
1211
1212
1213
1214
1215
1216
1217


1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234

1235
1236
1237
1238
1239
1240
1241

1209
1210
1211
1212
1213
1214
1215


1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233

1234
1235
1236
1237
1238
1239
1240
1241








-
-
+
+
















-
+








		   ((print-run)
		    (debug:print 1 "Printing info for run " runkey ", run=" run ", tests=" tests ", header=" header)
		    action)
		   ((run-wait)
		    (debug:print 1 "Waiting for run " runkey ", run=" runnamepatt " to complete"))
		   (else
		    (debug:print-info 0 "action not recognised " action)))
		 (let ((sorted-tests     (sort tests (lambda (a b)(let ((dira (db:test-get-rundir a))
									(dirb (db:test-get-rundir b)))
		 (let ((sorted-tests     (sort tests (lambda (a b)(let ((dira (sdb:qry 'getstr (db:test-get-rundir a)))
									(dirb (sdb:qry 'getstr (db:test-get-rundir b))))
								    (if (and (string? dira)(string? dirb))
									(> (string-length dira)(string-length dirb))
									#f)))))
		       (test-retry-time  (make-hash-table))
		       (allow-run-time   10)) ;; seconds to allow for killing tests before just brutally killing 'em
		   (let loop ((test (car sorted-tests))
			      (tal  (cdr sorted-tests)))
		     (let* ((test-id       (db:test-get-id test))
			    (new-test-dat  (cdb:get-test-info-by-id *runremote* test-id)))
		       (if (not new-test-dat)
			   (begin
			     (debug:print 0 "ERROR: We have a test-id of " test-id " but no record was found. NOTE: No locking of records is done between processes, do not simultaneously remove the same run from two processes!")
			     (if (not (null? tal))
				 (loop (car tal)(cdr tal))))
			   (let* ((item-path     (db:test-get-item-path new-test-dat))
				  (test-name     (db:test-get-testname new-test-dat))
				  (run-dir       (db:test-get-rundir new-test-dat))    ;; run dir is from the link tree
				  (run-dir       (sdb:qry 'getstr (db:test-get-rundir new-test-dat)))    ;; run dir is from the link tree
				  (real-dir      (if (file-exists? run-dir)
						     (resolve-pathname run-dir)
						     #f))
				  (test-state    (db:test-get-state new-test-dat))
				  (test-fulln    (db:test-get-fullname new-test-dat)))
			     (case action
			       ((remove-runs)
︙

Modified tests.scm from [ed985ac2fe] to [fe20e13a60].

︙
18
19
20
21
22
23
24

25
26
27
28
29
30
31

18
19
20
21
22
23
24
25
26
27
28
29
30
31
32








+









(declare (unit tests))
(declare (uses lock-queue))
(declare (uses db))
(declare (uses common))
(declare (uses items))
(declare (uses runconfig))
(declare (uses sdb))

(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(include "test_records.scm")
︙
219
220
221
222
223
224
225
226
227


228
229
230
231
232
233
234

220
221
222
223
224
225
226


227
228
229
230
231
232
233
234
235








-
-
+
+








		      (loop (car tal)(cdr tal))))))))))

;; Check for waiver eligibility
;;
(define (tests:check-waiver-eligibility testdat prev-testdat)
  (let* ((test-registry (make-hash-table))
	 (testconfig  (tests:get-testconfig (db:test-get-testname testdat) test-registry #f))
	 (test-rundir (db:test-get-rundir testdat))
	 (prev-rundir (db:test-get-rundir prev-testdat))
	 (test-rundir (sdb:qry 'getstr (db:test-get-rundir testdat)))
	 (prev-rundir (sdb:qry 'getstr (db:test-get-rundir prev-testdat)))
	 (waivers     (configf:section-vars testconfig "waivers"))
	 (waiver-rx   (regexp "^(\\S+)\\s+(.*)$"))
	 (diff-rule   "diff %file1% %file2%")
	 (logpro-rule "diff %file1% %file2% | logpro %waivername%.logpro %waivername%.html"))
    (if (not (file-exists? test-rundir))
	(begin
	  (debug:print 0 "ERROR: test run directory is gone, cannot propagate waiver")
︙

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