| ︙ | | | ︙ | |
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
|
;; runs:get-runs-by-patt
;; get runs by list of criteria
;; register a test run with the db
;;
;; Use: (db-get-value-by-header (db:get-header runinfo)(db:get-row runinfo))
;; to extract info from the structure returned
;;
(define (runs:get-runs-by-patt db keys runnamepatt) ;; test-name)
(let* ((keyvallst (keys->vallist keys))
(tmp (runs:get-std-run-fields keys '("id" "runname" "state" "status" "owner" "event_time")))
(keystr (car tmp))
(header (cadr tmp))
(res '())
(key-patt "")
(runwildtype (if (substring-index "%" runnamepatt) "like" "glob"))
(qry-str #f))
(for-each (lambda (keyval)
(let* ((key (vector-ref keyval 0))
(fulkey (conc ":" key))
(patt (args:get-arg fulkey))
keys)
(set! qry-str (conc "SELECT " keystr " FROM runs WHERE runname " runwildtype " ? " key-patt ";"))
(debug:print-info 4 "runs:get-runs-by-patt qry=" qry-str " " runnamepatt)
(sqlite3:for-each-row
(lambda (a . r)
(set! res (cons (list->vector (cons a r)) res)))
db
qry-str
runnamepatt)
(vector header res)))
(define (runs:test-get-full-path test)
(let* ((testname (db:test-get-testname test))
(itempath (db:test-get-item-path test)))
(conc testname (if (equal? itempath "") "" (conc "(" itempath ")")))))
(define (set-megatest-env-vars run-id #!key (inkeys #f)(inrunname #f))
(let ((keys (if inkeys inkeys (cdb:remote-run db:get-keys #f)))
(vals (hash-table-ref/default *env-vars-by-run-id* run-id #f)))
;; get the info from the db and put it in the cache
(if (not vals)
(let ((ht (make-hash-table)))
(hash-table-set! *env-vars-by-run-id* run-id ht)
(set! vals ht)
(for-each
(lambda (key)
(hash-table-set! vals key (cdb:remote-run db:get-run-key-val #f run-id key)))
keys)))
;; from the cached data set the vars
(hash-table-for-each
vals
(lambda (key val)
(debug:print 2 "setenv " (key:get-fieldname key) " " val)
(setenv (key:get-fieldname key) val)))
(alist->env-vars (hash-table-ref/default *configdat* "env-override" '()))
;; Lets use this as an opportunity to put MT_RUNNAME in the environment
(setenv "MT_RUNNAME" (if inrunname inrunname (cdb:remote-run db:get-run-name-from-id #f run-id)))
(setenv "MT_RUN_AREA_HOME" *toppath*)
))
(define (set-item-env-vars itemdat)
(for-each (lambda (item)
(debug:print 2 "setenv " (car item) " " (cadr item))
(setenv (car item) (cadr item)))
itemdat))
|
|
<
|
|
>
|
>
<
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
|
|
<
|
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
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
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
|
;; runs:get-runs-by-patt
;; get runs by list of criteria
;; register a test run with the db
;;
;; Use: (db-get-value-by-header (db:get-header runinfo)(db:get-row runinfo))
;; to extract info from the structure returned
;;
(define (runs:get-runs-by-patt db keys runnamepatt targpatt) ;; test-name)
(let* ((tmp (runs:get-std-run-fields keys '("id" "runname" "state" "status" "owner" "event_time")))
(keystr (car tmp))
(header (cadr tmp))
(res '())
(key-patt "")
(runwildtype (if (substring-index "%" runnamepatt) "like" "glob"))
(qry-str #f)
(keyvals (keys:target->keyval keys targpatt)))
(for-each (lambda (keyval)
(let* ((key (car keyval))
(patt (cadr keyval))
(fulkey (conc ":" key))
(wildtype (if (substring-index "%" patt) "like" "glob")))
(if patt
(set! key-patt (conc key-patt " AND " key " " wildtype " '" patt "'"))
(begin
(debug:print 0 "ERROR: searching for runs with no pattern set for " fulkey)
(exit 6)))))
keyvals)
(set! qry-str (conc "SELECT " keystr " FROM runs WHERE runname " runwildtype " ? " key-patt ";"))
(debug:print-info 4 "runs:get-runs-by-patt qry=" qry-str " " runnamepatt)
(sqlite3:for-each-row
(lambda (a . r)
(set! res (cons (list->vector (cons a r)) res)))
db
qry-str
runnamepatt)
(vector header res)))
(define (runs:test-get-full-path test)
(let* ((testname (db:test-get-testname test))
(itempath (db:test-get-item-path test)))
(conc testname (if (equal? itempath "") "" (conc "(" itempath ")")))))
;; This is the *new* methodology. One record to inform them and in the chaos, organise them.
;;
(define (runs:create-run-record)
(let* ((mconfig (if *configdat*
*configdat*
(if (setup-for-run)
*configdat*
(begin
(debug:print 0 "ERROR: Called setup in a non-megatest area, exiting")
(exit 1)))))
(runrec (runs:runrec-make-record))
(target (or (args:get-arg "-reqtarg")
(args:get-arg "-target")))
(runname (or (args:get-arg ":runname")
(args:get-arg "-runname")))
(testpatt (or (args:get-arg "-testpatt")
(args:get-arg "-runtests")))
(keys (keys:config-get-fields mconfig))
(keyvals (keys:target->keyval keys target))
(toppath *toppath*)
(envdat keyvals) ;; initial values start with keyvals
(runconfig #f)
(serverdat (if (args:get-arg "-server")
*runremote*
#f)) ;; to be used later
(transport (or (args:get-arg "-transport") 'http))
(db (if (and mconfig
(or (args:get-arg "-server")
(eq? transport 'fs)))
(open-db)
#f))
(run-id #f))
;; Set all the environment vars we know so far, start with keys
(for-each (lambda (keyval)
(setenv (car keyval)(cadr keyval)))
keyvals)
;; Set up various and sundry known vars here
(setenv "MT_RUN_AREA_HOME" toppath)
(setenv "MT_RUNNAME" runname)
(setenv "MT_TARGET" target)
(set! envdat (append
envdat
(list (list "MT_RUN_AREA_HOME" toppath)
(list "MT_RUNNAME" runname)
(list "MT_TARGET" target))))
;; Now can read the runconfigs file
;;
(set! runconfig (read-config (conc *toppath* "/runconfigs.config") #f #t sections: (list "default" target)))
(if (not (hash-table-ref/default runconfig (args:get-arg "-reqtarg") #f))
(begin
(debug:print 0 "ERROR: [" (args:get-arg "-reqtarg") "] not found in " runconfigf)
(if db (sqlite3:finalize! db))
(exit 1)))
;; Now have runconfigs data loaded, set environment vars
(for-each (lambda (section)
(for-each (lambda (varval)
(set! envdat (append envdat (list varval)))
(setenv (car varval)(cadr varval)))
(configf:get-section runconfig section)))
(list "default" target))
(vector target runname testpatt keys keyvals envdat mconfig runconfig serverdat transport db toppath run-id)))
(define (set-megatest-env-vars run-id #!key (inkeys #f)(inrunname #f))
(let ((keys (if inkeys inkeys (cdb:remote-run db:get-keys #f)))
(vals (hash-table-ref/default *env-vars-by-run-id* run-id #f)))
;; get the info from the db and put it in the cache
(if (not vals)
(let ((ht (make-hash-table)))
(hash-table-set! *env-vars-by-run-id* run-id ht)
(set! vals ht)
(for-each
(lambda (key)
(hash-table-set! vals key (cdb:remote-run db:get-run-key-val #f run-id key)))
keys)))
;; from the cached data set the vars
(hash-table-for-each
vals
(lambda (key val)
(debug:print 2 "setenv " key " " val)
(setenv key val)))
(alist->env-vars (hash-table-ref/default *configdat* "env-override" '()))
;; Lets use this as an opportunity to put MT_RUNNAME in the environment
(setenv "MT_RUNNAME" (if inrunname inrunname (cdb:remote-run db:get-run-name-from-id #f run-id)))
(setenv "MT_RUN_AREA_HOME" *toppath*)))
(define (set-item-env-vars itemdat)
(for-each (lambda (item)
(debug:print 2 "setenv " (car item) " " (cadr item))
(setenv (car item) (cadr item)))
itemdat))
|
| ︙ | | | ︙ | |
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
|
;; This is a duplicate of run-tests (which has been deprecated). Use this one instead of run tests.
;; keyvals.
;;
;; test-names: Comma separated patterns same as test-patts but used in selection
;; of tests to run. The item portions are not respected.
;; FIXME: error out if /patt specified
;;
(define (runs:run-tests target runname test-names test-patts user flags)
(common:clear-caches) ;; clear all caches
(let* ((db #f)
(keys (cdb:remote-run db:get-keys #f))
(keyvallst (keys:target->keyval keys target))
(run-id (cdb:remote-run db:register-run #f keys keyvallst runname "new" "n/a" user)) ;; test-name)))
(keyvals (if run-id (cdb:remote-run db:get-key-vals #f run-id) #f))
(deferred '()) ;; delay running these since they have a waiton clause
;; keepgoing is the defacto modality now, will add hit-n-run a bit later
;; (keepgoing (hash-table-ref/default flags "-keepgoing" #f))
(runconfigf (conc *toppath* "/runconfigs.config"))
(required-tests '())
(test-records (make-hash-table)))
(set-megatest-env-vars run-id inkeys: keys) ;; these may be needed by the launching process
(if (file-exists? runconfigf)
(setup-env-defaults runconfigf run-id *already-seen-runconfig-info* keys keyvals "pre-launch-env-vars")
(debug:print 0 "WARNING: You do not have a run config file: " runconfigf))
;; look up all tests matching the comma separated list of globs in
;; test-patts (using % as wildcard)
(set! test-names (tests:get-valid-tests *toppath* test-names))
(set! test-names (delete-duplicates test-names))
(debug:print-info 0 "test names " test-names)
;; on the first pass or call to run-tests set FAILS to NOT_STARTED if
;; -keepgoing is specified
(if (eq? *passnum* 0)
|
|
|
|
|
<
|
>
|
|
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
|
;; This is a duplicate of run-tests (which has been deprecated). Use this one instead of run tests.
;; keyvals.
;;
;; test-names: Comma separated patterns same as test-patts but used in selection
;; of tests to run. The item portions are not respected.
;; FIXME: error out if /patt specified
;;
(define (runs:run-tests target runname test-patts user flags) ;; test-names
(common:clear-caches) ;; clear all caches
(let* ((db #f)
(keys (keys:config-get-fields *configdat*))
(keyvals (keys:target->keyval keys target))
(run-id (cdb:remote-run db:register-run #f keys keyvals runname "new" "n/a" user)) ;; test-name)))
(deferred '()) ;; delay running these since they have a waiton clause
;; keepgoing is the defacto modality now, will add hit-n-run a bit later
;; (keepgoing (hash-table-ref/default flags "-keepgoing" #f))
(runconfigf (conc *toppath* "/runconfigs.config"))
(required-tests '())
(test-records (make-hash-table))
(test-names '()))
(set-megatest-env-vars run-id inkeys: keys) ;; these may be needed by the launching process
(if (file-exists? runconfigf)
(setup-env-defaults runconfigf run-id *already-seen-runconfig-info* keys keyvals "pre-launch-env-vars")
(debug:print 0 "WARNING: You do not have a run config file: " runconfigf))
;; look up all tests matching the comma separated list of globs in
;; test-patts (using % as wildcard)
(set! test-names (tests:get-valid-tests *toppath* test-patts))
(set! test-names (delete-duplicates test-names))
(debug:print-info 0 "test names " test-names)
;; on the first pass or call to run-tests set FAILS to NOT_STARTED if
;; -keepgoing is specified
(if (eq? *passnum* 0)
|
| ︙ | | | ︙ | |
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
|
(if (not (null? required-tests))
(debug:print-info 1 "Adding " required-tests " to the run queue"))
;; NOTE: these are all parent tests, items are not expanded yet.
(debug:print-info 4 "test-records=" (hash-table->alist test-records))
(let ((reglen (any->number (configf:lookup *configdat* "setup" "runqueue"))))
(if reglen
(runs:run-tests-queue-new run-id runname test-records keyvallst flags test-patts reglen)
(runs:run-tests-queue-classic run-id runname test-records keyvallst flags test-patts)))
(debug:print-info 4 "All done by here")))
(define (runs:calc-fails prereqs-not-met)
(filter (lambda (test)
(and (vector? test) ;; not (string? test))
(equal? (db:test-get-state test) "COMPLETED")
(not (member (db:test-get-status test)
|
|
|
|
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
|
(if (not (null? required-tests))
(debug:print-info 1 "Adding " required-tests " to the run queue"))
;; NOTE: these are all parent tests, items are not expanded yet.
(debug:print-info 4 "test-records=" (hash-table->alist test-records))
(let ((reglen (any->number (configf:lookup *configdat* "setup" "runqueue"))))
(if reglen
(runs:run-tests-queue-new run-id runname test-records flags test-patts reglen)
(runs:run-tests-queue-classic run-id runname test-records flags test-patts)))
(debug:print-info 4 "All done by here")))
(define (runs:calc-fails prereqs-not-met)
(filter (lambda (test)
(and (vector? test) ;; not (string? test))
(equal? (db:test-get-state test) "COMPLETED")
(not (member (db:test-get-status test)
|
| ︙ | | | ︙ | |
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
|
'()
reg)))
(include "run-tests-queue-classic.scm")
(include "run-tests-queue-new.scm")
;; parent-test is there as a placeholder for when parent-tests can be run as a setup step
(define (run:test run-id run-info key-vals runname keyvallst test-record flags parent-test)
;; All these vars might be referenced by the testconfig file reader
(let* ((test-name (tests:testqueue-get-testname test-record))
(test-waitons (tests:testqueue-get-waitons test-record))
(test-conf (tests:testqueue-get-testconfig test-record))
(itemdat (tests:testqueue-get-itemdat test-record))
(test-path (conc *toppath* "/tests/" test-name)) ;; could use tests:get-testconfig here ...
(force (hash-table-ref/default flags "-force" #f))
|
|
|
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
|
'()
reg)))
(include "run-tests-queue-classic.scm")
(include "run-tests-queue-new.scm")
;; parent-test is there as a placeholder for when parent-tests can be run as a setup step
(define (run:test run-id run-info key-vals runname test-record flags parent-test)
;; All these vars might be referenced by the testconfig file reader
(let* ((test-name (tests:testqueue-get-testname test-record))
(test-waitons (tests:testqueue-get-waitons test-record))
(test-conf (tests:testqueue-get-testconfig test-record))
(itemdat (tests:testqueue-get-itemdat test-record))
(test-path (conc *toppath* "/tests/" test-name)) ;; could use tests:get-testconfig here ...
(force (hash-table-ref/default flags "-force" #f))
|
| ︙ | | | ︙ | |
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
|
(if (not parent-test)
(debug:print 1 "NOTE: Not starting test " new-test-name " as it is state \"" (test:get-state testdat)
"\" and status \"" (test:get-status testdat) "\", use -rerun \"" (test:get-status testdat)
"\" or -force to override"))
;; NOTE: No longer be checking prerequisites here! Will never get here unless prereqs are
;; already met.
;; This would be a great place to do the process-fork
(if (not (launch-test test-id run-id run-info key-vals runname test-conf keyvallst test-name test-path itemdat flags))
(begin
(print "ERROR: Failed to launch the test. Exiting as soon as possible")
(set! *globalexitstatus* 1) ;;
(process-signal (current-process-id) signal/kill))))))
((KILLED)
(debug:print 1 "NOTE: " new-test-name " is already running or was explictly killed, use -force to launch it."))
((LAUNCHED REMOTEHOSTSTART RUNNING)
|
|
|
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
|
(if (not parent-test)
(debug:print 1 "NOTE: Not starting test " new-test-name " as it is state \"" (test:get-state testdat)
"\" and status \"" (test:get-status testdat) "\", use -rerun \"" (test:get-status testdat)
"\" or -force to override"))
;; NOTE: No longer be checking prerequisites here! Will never get here unless prereqs are
;; already met.
;; This would be a great place to do the process-fork
(if (not (launch-test test-id run-id run-info key-vals runname test-conf test-name test-path itemdat flags))
(begin
(print "ERROR: Failed to launch the test. Exiting as soon as possible")
(set! *globalexitstatus* 1) ;;
(process-signal (current-process-id) signal/kill))))))
((KILLED)
(debug:print 1 "NOTE: " new-test-name " is already running or was explictly killed, use -force to launch it."))
((LAUNCHED REMOTEHOSTSTART RUNNING)
|
| ︙ | | | ︙ | |
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
|
;; fields are passing in through
;; action:
;; 'remove-runs
;; 'set-state-status
;;
;; NB// should pass in keys?
;;
(define (runs:operate-on action runnamepatt testpatt #!key (state #f)(status #f)(new-state-status #f))
(common:clear-caches) ;; clear all caches
(let* ((db #f)
(keys (open-run-close db:get-keys db))
(rundat (open-run-close runs:get-runs-by-patt db keys runnamepatt))
(header (vector-ref rundat 0))
(runs (vector-ref rundat 1))
(states (if state (string-split state ",") '()))
(statuses (if status (string-split status ",") '()))
(state-status (if (string? new-state-status) (string-split new-state-status ",") '(#f #f))))
(debug:print-info 4 "runs:operate-on => Header: " header " action: " action " new-state-status: " new-state-status)
(if (> 2 (length state-status))
(begin
(debug:print 0 "ERROR: the parameter to -set-state-status is a comma delimited string. E.g. COMPLETED,FAIL")
(exit)))
(for-each
(lambda (run)
(let ((runkey (string-intersperse (map (lambda (k)
(db:get-value-by-header run header (vector-ref k 0))) keys) "/"))
(dirs-to-remove (make-hash-table)))
(let* ((run-id (db:get-value-by-header run header "id"))
(run-state (db:get-value-by-header run header "state"))
(tests (if (not (equal? run-state "locked"))
(open-run-close db:get-tests-for-run db run-id
testpatt states statuses
not-in: #f
|
|
|
|
|
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
|
;; fields are passing in through
;; action:
;; 'remove-runs
;; 'set-state-status
;;
;; NB// should pass in keys?
;;
(define (runs:operate-on action target runnamepatt testpatt #!key (state #f)(status #f)(new-state-status #f))
(common:clear-caches) ;; clear all caches
(let* ((db #f)
(keys (open-run-close db:get-keys db))
(rundat (open-run-close runs:get-runs-by-patt db keys runnamepatt target))
(header (vector-ref rundat 0))
(runs (vector-ref rundat 1))
(states (if state (string-split state ",") '()))
(statuses (if status (string-split status ",") '()))
(state-status (if (string? new-state-status) (string-split new-state-status ",") '(#f #f))))
(debug:print-info 4 "runs:operate-on => Header: " header " action: " action " new-state-status: " new-state-status)
(if (> 2 (length state-status))
(begin
(debug:print 0 "ERROR: the parameter to -set-state-status is a comma delimited string. E.g. COMPLETED,FAIL")
(exit)))
(for-each
(lambda (run)
(let ((runkey (string-intersperse (map (lambda (k)
(db:get-value-by-header run header k)) keys) "/"))
(dirs-to-remove (make-hash-table)))
(let* ((run-id (db:get-value-by-header run header "id"))
(run-state (db:get-value-by-header run header "state"))
(tests (if (not (equal? run-state "locked"))
(open-run-close db:get-tests-for-run db run-id
testpatt states statuses
not-in: #f
|
| ︙ | | | ︙ | |
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
|
;; Since many calls to a run require pretty much the same setup
;; this wrapper is used to reduce the replication of code
(define (general-run-call switchname action-desc proc)
(let ((runname (args:get-arg ":runname"))
(target (if (args:get-arg "-target")
(args:get-arg "-target")
(args:get-arg "-reqtarg")))
(th1 #f))
(cond
((not target)
(debug:print 0 "ERROR: Missing required parameter for " switchname ", you must specify the target with -target")
(exit 3))
((not runname)
(debug:print 0 "ERROR: Missing required parameter for " switchname ", you must specify the run name with :runname runname")
(exit 3))
(else
(let ((db #f)
(keys #f))
(if (not (setup-for-run))
(begin
(debug:print 0 "Failed to setup, exiting")
(exit 1)))
(if (args:get-arg "-server")
(open-run-close server:start db (args:get-arg "-server")))
;; (if (not (or (args:get-arg "-runall") ;; runall and runtests are allowed to be servers
;; (args:get-arg "-runtests")))
;; (client:setup) ;; This is a duplicate startup!!!??? BUG?
;; ))
(set! keys (open-run-close db:get-keys db))
(let* ((keynames (map key:get-fieldname keys))
(keyvallst (keys->vallist keys #t)))
(proc target runname keys keynames keyvallst)))
(if th1 (thread-join! th1))
(if db (sqlite3:finalize! db))
(set! *didsomething* #t))))))
;;======================================================================
;; Lock/unlock runs
;;======================================================================
(define (runs:handle-locking target keys runname lock unlock user)
(let* ((db #f)
(rundat (open-run-close runs:get-runs-by-patt db keys runname))
(header (vector-ref rundat 0))
(runs (vector-ref rundat 1)))
(for-each (lambda (run)
(let ((run-id (db:get-value-by-header run header "id")))
(if (or lock
(and unlock
(begin
|
|
|
|
>
>
<
<
<
<
|
>
|
<
|
<
|
|
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
|
;; Since many calls to a run require pretty much the same setup
;; this wrapper is used to reduce the replication of code
(define (general-run-call switchname action-desc proc)
(let ((runname (args:get-arg ":runname"))
(target (if (args:get-arg "-target")
(args:get-arg "-target")
(args:get-arg "-reqtarg"))))
;; (th1 #f))
(cond
((not target)
(debug:print 0 "ERROR: Missing required parameter for " switchname ", you must specify the target with -target")
(exit 3))
((not runname)
(debug:print 0 "ERROR: Missing required parameter for " switchname ", you must specify the run name with :runname runname")
(exit 3))
(else
(let ((db #f)
(keys #f)
(target (or (args:get-arg "-reqtarg")
(args:get-arg "-target"))))
(if (not (setup-for-run))
(begin
(debug:print 0 "Failed to setup, exiting")
(exit 1)))
(if (args:get-arg "-server")
(open-run-close server:start db (args:get-arg "-server")))
(set! keys (keys:config-get-fields *configdat*))
;; have enough to process -target or -reqtarg here
(if (args:get-arg "-reqtarg")
(let* ((runconfigf (conc *toppath* "/runconfigs.config")) ;; DO NOT EVALUATE ALL
(runconfig (read-config runconfigf #f #t environ-patt: #f)))
(if (hash-table-ref/default runconfig (args:get-arg "-reqtarg") #f)
(keys:target-set-args keys (args:get-arg "-reqtarg") args:arg-hash)
(begin
(debug:print 0 "ERROR: [" (args:get-arg "-reqtarg") "] not found in " runconfigf)
(if db (sqlite3:finalize! db))
(exit 1))))
(if (args:get-arg "-target")
(keys:target-set-args keys (args:get-arg "-target" args:arg-hash) args:arg-hash)))
(if (not (car *configinfo*))
(begin
(debug:print 0 "ERROR: Attempted to " action-desc " but run area config file not found")
(exit 1))
;; Extract out stuff needed in most or many calls
;; here then call proc
(let* ((keyvals (keys:target->keyval keys target)))
(proc target runname keys keyvals)))
(if db (sqlite3:finalize! db))
(set! *didsomething* #t))))))
;;======================================================================
;; Lock/unlock runs
;;======================================================================
(define (runs:handle-locking target keys runname lock unlock user)
(let* ((db #f)
(rundat (open-run-close runs:get-runs-by-patt db keys runname target))
(header (vector-ref rundat 0))
(runs (vector-ref rundat 1)))
(for-each (lambda (run)
(let ((run-id (db:get-value-by-header run header "id")))
(if (or lock
(and unlock
(begin
|
| ︙ | | | ︙ | |
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
|
;; read configs with tricks turned off (i.e. no system)
(test-conf (if testexists (read-config test-configf #f #f)(make-hash-table))))
;; use the open-run-close instead of passing in db
(runs:update-test_meta test-name test-conf)))
test-names)))
;; This could probably be refactored into one complex query ...
(define (runs:rollup-run keys keyvallst runname user) ;; was target, now keyvallst
(debug:print 4 "runs:rollup-run, keys: " keys " keyvallst: " keyvallst " :runname " runname " user: " user)
(let* ((db #f) ;; (keyvalllst (keys:target->keyval keys target))
(new-run-id (cdb:remote-run db:register-run #f keys keyvallst runname "new" "n/a" user))
(prev-tests (open-run-close test:get-matching-previous-test-run-records db new-run-id "%" "%"))
(curr-tests (open-run-close db:get-tests-for-run db new-run-id "%/%" '() '()))
(curr-tests-hash (make-hash-table)))
(open-run-close db:update-run-event_time db new-run-id)
;; index the already saved tests by testname and itemdat in curr-tests-hash
(for-each
(lambda (testdat)
|
|
|
|
|
|
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
|
;; read configs with tricks turned off (i.e. no system)
(test-conf (if testexists (read-config test-configf #f #f)(make-hash-table))))
;; use the open-run-close instead of passing in db
(runs:update-test_meta test-name test-conf)))
test-names)))
;; This could probably be refactored into one complex query ...
(define (runs:rollup-run keys runname user keyvals)
(debug:print 4 "runs:rollup-run, keys: " keys " :runname " runname " user: " user)
(let* ((db #f)
(new-run-id (cdb:remote-run db:register-run #f keys keyvals runname "new" "n/a" user))
(prev-tests (open-run-close test:get-matching-previous-test-run-records db new-run-id "%" "%"))
(curr-tests (open-run-close db:get-tests-for-run db new-run-id "%/%" '() '()))
(curr-tests-hash (make-hash-table)))
(open-run-close db:update-run-event_time db new-run-id)
;; index the already saved tests by testname and itemdat in curr-tests-hash
(for-each
(lambda (testdat)
|
| ︙ | | | ︙ | |
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
|
;; 2. replace the rollup test with the new *always*
(for-each
(lambda (testdat)
(let* ((testname (db:test-get-testname testdat))
(item-path (db:test-get-item-path testdat))
(full-name (conc testname "/" item-path))
(prev-test-dat (hash-table-ref/default curr-tests-hash full-name #f))
(test-steps (open-run-close db:get-steps-for-test db (db:test-get-id testdat)))
(new-test-record #f))
;; replace these with insert ... select
(apply sqlite3:execute
db
(conc "INSERT OR REPLACE INTO tests (run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment) "
"VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?);")
new-run-id (cddr (vector->list testdat)))
|
|
|
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
|
;; 2. replace the rollup test with the new *always*
(for-each
(lambda (testdat)
(let* ((testname (db:test-get-testname testdat))
(item-path (db:test-get-item-path testdat))
(full-name (conc testname "/" item-path))
(prev-test-dat (hash-table-ref/default curr-tests-hash full-name #f))
(test-steps (open-run-close db:get-steps-for-test db (db:test-get-id testdat)))
(new-test-record #f))
;; replace these with insert ... select
(apply sqlite3:execute
db
(conc "INSERT OR REPLACE INTO tests (run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment) "
"VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?);")
new-run-id (cddr (vector->list testdat)))
|
| ︙ | | | ︙ | |