1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
|
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
|
-
-
+
+
|
;;======================================================================
;; Copyright 2006-2012, Matthew Welland.
;;
;; This program is made available under the GNU GPL version 2.0 or
;; greater. See the accompanying file COPYING for details.
;;
;; This program is distributed WITHOUT ANY WARRANTY; without even the
;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;; PURPOSE.
;;======================================================================
(use srfi-1 data-structures posix regex-case base64 format dot-locking csv-xml z3 sql-de-lite hostinfo md5 message-digest typed-records directory-utils stack
matchable regex posix srfi-18 extras
pkts (prefix dbi dbi:))
matchable pkts (prefix dbi dbi:)
regex)
(import (prefix sqlite3 sqlite3:))
(import (prefix base64 base64:))
(declare (unit common))
(include "common_records.scm")
|
︙ | | |
98
99
100
101
102
103
104
105
106
107
108
109
110
111
|
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
|
+
|
;; A hash table that can be accessed by #{scheme ...} calls in
;; config files. Allows communicating between confgs
;;
(define *user-hash-data* (make-hash-table))
(define *db-keys* #f)
(define *pkts-info* (make-hash-table)) ;; store stuff like the last parent here
(define *configinfo* #f) ;; raw results from setup, includes toppath and table from megatest.config
(define *runconfigdat* #f) ;; run configs data
(define *configdat* #f) ;; megatest.config data
(define *configstatus* #f) ;; status of data; 'fulldata : all processing done, #f : no data yet, 'partialdata : partial read done
(define *toppath* #f)
(define *already-seen-runconfig-info* #f)
|
︙ | | |
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
|
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
|
+
-
+
|
;;======================================================================
;; S T A T E S A N D S T A T U S E S
;;======================================================================
;; BBnote: *common:std-states* - dashboard filter control and test control state buttons defined here; used in set-fields-panel and dboard:make-controls
(define *common:std-states* ;; for toggle buttons in dashboard
'(
'((0 "ARCHIVED")
(0 "ARCHIVED")
(1 "STUCK")
(2 "KILLREQ")
(3 "KILLED")
(4 "NOT_STARTED")
(5 "COMPLETED")
(6 "LAUNCHED")
(7 "REMOTEHOSTSTART")
|
︙ | | |
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
|
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
|
+
-
+
-
+
+
+
+
|
(4 "WARN")
(5 "WAIVED")
(6 "CHECK")
(7 "STUCK/DEAD")
(8 "DEAD")
(9 "FAIL")
(10 "PREQ_FAIL")
(11 "PREQ_DISCARDED")
(11 "ABORT")))
(12 "ABORT")))
(define *common:ended-states* ;; states which indicate the test is stopped and will not proceed
'("COMPLETED" "ARCHIVED" "KILLED" "KILLREQ" "STUCK" "INCOMPLETE"))
'("COMPLETED" "ARCHIVED" "KILLED" "KILLREQ" "STUCK" "INCOMPLETE" ))
(define *common:badly-ended-states* ;; these roll up as CHECK, i.e. results need to be checked
'("KILLED" "KILLREQ" "STUCK" "INCOMPLETE" "DEAD"))
(define *common:well-ended-states* ;; an item's prereq in this state allows item to proceed
'("PASS" "WARN" "CHECK" "WAIVED" "SKIP"))
;; BBnote: *common:running-states* used from db:set-state-status-and-roll-up-items
(define *common:running-states* ;; test is either running or can be run
'("RUNNING" "REMOTEHOSTSTART" "LAUNCHED" "STARTED"))
(define *common:cant-run-states* ;; These are stopping conditions that prevent a test from being run
'("COMPLETED" "KILLED" "UNKNOWN" "INCOMPLETE" "ARCHIVED"))
|
︙ | | |
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
|
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
|
+
+
|
"# export "
"export ")
key "=" delim (mungeval val) delim)))
envvars)))))
;; set some env vars from an alist, return an alist with original values
;; (("VAR" "value") ...)
;; a value of #f means "unset this var"
;;
(define (alist->env-vars lst)
(if (list? lst)
(let ((res '()))
(for-each (lambda (p)
(let* ((var (car p))
(val (cadr p))
(prv (get-environment-variable var)))
|
︙ | | |
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356
2357
2358
2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
|
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356
2357
2358
2359
2360
2361
2362
2363
2364
2365
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
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
2410
2411
|
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
|
view-cfgdat))
;;======================================================================
;; Manage pkts, used in servers, tests and likely other contexts so put
;; in common
;;======================================================================
(define common:pkt-spec
'((server . ((action . a)
(pid . d)
(ipaddr . i)
(port . p)))
(define common:pkts-spec
'((default . ((parent . P)
(action . a)
(filename . f)))
(configf . ((parent . P)
(action . a)
(filename . f)))
(server . ((action . a)
(pid . d)
(ipaddr . i)
(port . p)
(parent . P)))
(test . ((cpuuse . c)
(diskuse . d)
(item-path . i)
(runname . r)
(state . s)
(target . t)
(status . u)))))
(test . ((cpuuse . c)
(diskuse . d)
(item-path . i)
(runname . r)
(state . s)
(target . t)
(status . u)
(parent . P)))))
(define (common:get-pkts-dirs mtconf use-lt)
(let* ((pktsdirs-str (or (configf:lookup mtconf "setup" "pktsdirs")
(and use-lt
(conc (or *toppath*
(current-directory))
(conc *toppath* "/lt/.pkts"))))
"/lt/.pkts"))))
(pktsdirs (if pktsdirs-str
(string-split pktsdirs-str " ")
#f)))
pktsdirs))
;; use-lt is use linktree "lt" link to find pkts dir
(define (common:save-pkt pktalist-in mtconf use-lt #!key (add-only #f)) ;; add-only saves the pkt only if there is a parent already
(if (or add-only
(hash-table-exists? *pkts-info* 'last-parent))
(let* ((parent (hash-table-ref/default *pkts-info* 'last-parent #f))
(pktalist (if parent
(cons `(parent . ,parent)
pktalist-in)
pktalist-in)))
(let-values (((uuid pkt)
(alist->pkt pktalist common:pkts-spec)))
(hash-table-set! *pkts-info* 'last-parent uuid)
(let ((pktsdir (or (hash-table-ref/default *pkts-info* 'pkts-dir #f)
(let* ((pktsdirs (common:get-pkts-dirs mtconf use-lt))
(pktsdir (car pktsdirs))) ;; assume it is there
(hash-table-set! *pkts-info* 'pkts-dir pktsdir)
pktsdir))))
(if (not (file-exists? pktsdir))
(create-directory pktsdir #t))
(with-output-to-file
(conc pktsdir "/" uuid ".pkt")
(lambda ()
(print pkt))))))))
(define (common:with-queue-db mtconf proc #!key (use-lt #f)(toppath-in #f))
(let* ((pktsdirs (common:get-pkts-dirs mtconf use-lt))
(pktsdir (if pktsdirs (car pktsdirs) #f))
(toppath (or (configf:lookup mtconf "scratchdat" "toppath")
toppath-in))
(pdbpath (or (configf:lookup mtconf "setup" "pdbpath") pktsdir)))
(cond
((not (and pktsdir toppath pdbpath))
(debug:print 0 *default-log-port* "ERROR: settings are missing in your megatest.config for area management.")
(debug:print 0 *default-log-port* " you need to have pktsdir in the [setup] section."))
((not (common:file-exists? pktsdir))
(debug:print 0 *default-log-port* "ERROR: pkts directory not found " pktsdir))
((not (equal? (file-owner pktsdir)(current-effective-user-id)))
(debug:print 0 *default-log-port* "ERROR: directory " pktsdir " is not owned by " (current-effective-user-name)))
(else
(let* ((pdb (open-queue-db pdbpath "pkts.db"
schema: '("CREATE TABLE groups (id INTEGER PRIMARY KEY,groupname TEXT, CONSTRAINT group_constraint UNIQUE (groupname));"))))
(proc pktsdirs pktsdir pdb)
(dbi:close pdb))))))
(define (common:load-pkts-to-db mtconf)
(define (common:load-pkts-to-db mtconf #!key (use-lt #f))
(common:with-queue-db
mtconf
(lambda (pktsdirs pktsdir pdb)
(for-each
(lambda (pktsdir) ;; look at all
(cond
((not (common:file-exists? pktsdir))
|
︙ | | |
2387
2388
2389
2390
2391
2392
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
2410
2411
2412
2413
2414
|
2428
2429
2430
2431
2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
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
2487
2488
2489
2490
2491
2492
2493
2494
|
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
(apkt (pkt->alist pktdat))
(ptype (alist-ref 'T apkt)))
(add-to-queue pdb pktdat uuid (or ptype 'cmd) #f 0)
(debug:print 4 *default-log-port* "Added " uuid " of type " ptype " to queue"))
(debug:print 4 *default-log-port* "pkt: " uuid " exists, skipping...")
)))
pkts)))))
pktsdirs))))
pktsdirs))
use-lt: use-lt))
(define (common:get-pkt-alists pkts)
(map (lambda (x)
(alist-ref 'apkt x)) ;; 'pkta pulls out the alist from the read pkt
pkts))
;; given list of pkts (alist mode) return list of D cards as Unix epoch, sorted descending
;; also delete duplicates by target i.e. (car pkt)
;;
(define (common:get-pkt-times pkts)
(delete-duplicates
(sort
(map (lambda (x)
`(,(alist-ref 't x) . ,(string->number (alist-ref 'D x))))
pkts)
(lambda (a b)(> (cdr a)(cdr b)))) ;; sort descending
(lambda (a b)(equal? (car a)(car b))))) ;; remove duplicates by target
;; accept an alist or hash table containing envvar/env value pairs (value of #f causes unset)
;; execute thunk in context of environment modified as per this list
;; restore env to prior state then return value of eval'd thunk.
;; ** this is not thread safe **
(define (common:with-env-vars delta-env-alist-or-hash-table thunk)
(let* ((delta-env-alist (if (hash-table? delta-env-alist-or-hash-table)
(hash-table->alist delta-env-alist-or-hash-table)
delta-env-alist-or-hash-table))
(restore-thunks
(filter
identity
(map (lambda (env-pair)
(let* ((env-var (car env-pair))
(new-val (cadr env-pair))
(current-val (get-environment-variable env-var))
(restore-thunk
(cond
((not current-val) (lambda () (unsetenv env-var)))
((not (string? new-val)) #f)
((eq? current-val new-val) #f)
(else
(lambda () (setenv env-var current-val))))))
;;(when (not (string? new-val))
;; (debug:print 0 *default-log-port* " PROBLEM: not a string: "new-val"\n from env-alist:\n"delta-env-alist)
;; (pp delta-env-alist)
;; (exit 1))
(cond
((not new-val) ;; modify env here
(unsetenv env-var))
((string? new-val)
(setenv env-var new-val)))
restore-thunk))
delta-env-alist))))
(let ((rv (thunk)))
(for-each (lambda (x) (x)) restore-thunks) ;; restore env to original state
rv)))
|
︙ | | |
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
|
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
|
+
+
+
+
-
+
|
(define configf:comment-rx (regexp "^\\s*#.*"))
(define configf:cont-ln-rx (regexp "^(\\s+)(\\S+.*)$"))
(define configf:settings (regexp "^\\[configf:settings\\s+(\\S+)\\s+(\\S+)]\\s*$"))
;; read a line and process any #{ ... } constructs
(define configf:var-expand-regex (regexp "^(.*)#\\{(scheme|system|shell|getenv|get|runconfigs-get|rget|scm|sh|rp|gv|g|mtrah)\\s+([^\\}\\{]*)\\}(.*)"))
(define (configf:system ht cmd)
(system cmd)
)
(define (configf:process-line l ht allow-system #!key (linenum #f))
(let loop ((res l))
(if (string? res)
(let ((matchdat (string-search configf:var-expand-regex res)))
(if matchdat
(let* ((prestr (list-ref matchdat 1))
(cmdtype (list-ref matchdat 2)) ;; eval, system, shell, getenv
(cmd (list-ref matchdat 3))
(poststr (list-ref matchdat 4))
(result #f)
(start-time (current-seconds))
(cmdsym (string->symbol cmdtype))
(fullcmd (case cmdsym
((scheme scm) (conc "(lambda (ht)" cmd ")"))
((system) (conc "(lambda (ht)(system \"" cmd "\"))"))
((system) (conc "(lambda (ht)(configf:system ht \"" cmd "\"))"))
((shell sh) (conc "(lambda (ht)(string-translate (shell \"" cmd "\") \"\n\" \" \"))"))
((realpath rp)(conc "(lambda (ht)(common:nice-path \"" cmd "\"))"))
((getenv gv) (conc "(lambda (ht)(get-environment-variable \"" cmd "\"))"))
((mtrah) (conc "(lambda (ht)"
" (let ((extra \"" cmd "\"))"
" (conc (or *toppath* (get-environment-variable \"MT_RUN_AREA_HOME\"))"
" (if (string-null? extra) \"\" \"/\")"
|
︙ | | |
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
|
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
|
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
inl)
(else
(configf:process-line inl ht allow-processing)))))
(if (and (string? res)
(not (equal? (hash-table-ref/default settings "trim-trailing-spaces" "no") "no")))
(string-substitute "\\s+$" "" res)
res))))))
(define (configf:cfgdat->env-alist section cfgdat-ht allow-system)
(filter
(lambda (pair)
(let* ((var (car pair))
(val (cdr pair)))
(cons var
(cond
((and allow-system (procedure? val)) ;; if we decided to use something other than #t or #f for allow-system ('return-procs or 'return-string) , this may become problematic
(val))
((procedure? val) #f)
((string? val) val)
(else "#f")))))
(append
(hash-table-ref/default cfgdat-ht "default" '())
(if (equal? section "default") '() (hash-table-ref/default cfgdat-ht section '())))))
(define (calc-allow-system allow-system section sections)
(if sections
(and (or (equal? "default" section)
(member section sections))
allow-system) ;; account for sections and return allow-system as it might be a symbol such as return-strings
allow-system))
|
︙ | | |
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
|
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
|
+
+
+
+
+
-
+
-
+
+
+
+
+
+
+
+
|
(hash-table-keys ht))))
ht)
;; read a config file, returns hash table of alists
;; read a config file, returns hash table of alists
;; adds to ht if given (must be #f otherwise)
;; allow-system:
;; #f - do not evaluate [system
;; #t - immediately evaluate [system and store result as string
;; 'return-procs -- return a proc taking ht as an argument that may be evaulated at some future time
;; 'return-string -- return a string representing a proc taking ht as an argument that may be evaulated at some future time
;; envion-patt is a regex spec that identifies sections that will be eval'd
;; in the environment on the fly
;; sections: #f => get all, else list of sections to gather
;; post-section-procs alist of section-pattern => proc, where: (proc section-name next-section-name ht curr-path)
;; apply-wildcards: #t/#f - apply vars from targets with % wildcards to all matching sections
;;
(define (read-config path ht allow-system #!key (environ-patt #f) (curr-section #f)
(define (read-config path ht allow-system #!key (environ-patt #f) (curr-section #f)
(sections #f) (settings (make-hash-table)) (keep-filenames #f)
(post-section-procs '()) (apply-wildcards #t))
(post-section-procs '()) (apply-wildcards #t) )
(debug:print 9 *default-log-port* "START: " path)
(if *configdat*
(common:save-pkt `((action . read-config)
(f . ,(cond ((string? path) path)
((port? path) "port")
(else (conc path))))
(T . configf))
*configdat* #t add-only: #t))
(if (and (not (port? path))
(not (common:file-exists? path))) ;; for case where we are handed a port
(begin
(debug:print-info 1 *default-log-port* "read-config - file not found " path " current path: " (current-directory))
;; WARNING: This is a risky change but really, we should not return an empty hash table if no file read?
#f) ;; (if (not ht)(make-hash-table) ht))
(let ((inp (if (string? path)
|
︙ | | |
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
|
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
|
-
+
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
+
+
|
(if (list? sections) ;; delete all sections except given when sections is provided
(for-each
(lambda (section)
(if (not (member section sections))
(hash-table-delete! res section))) ;; we are using "" as a dumping ground and must remove it before returning the ht
(hash-table-keys res)))
(debug:print 9 *default-log-port* "END: " path)
res)
res
) ;; retval
(regex-case
inl
(configf:comment-rx _ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))
(configf:blank-l-rx _ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))
(configf:settings ( x setting val ) (begin
(hash-table-set! settings setting val)
(loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)))
(configf:include-rx ( x include-file ) (let* ((curr-conf-dir (pathname-directory path))
(full-conf (if (absolute-pathname? include-file)
include-file
(common:nice-path
(conc (if curr-conf-dir
curr-conf-dir
".")
"/" include-file)))))
(if (common:file-exists? full-conf)
(begin
;; (push-directory conf-dir)
(debug:print 9 *default-log-port* "Including: " full-conf)
(read-config full-conf res allow-system environ-patt: environ-patt curr-section: curr-section-name sections: sections settings: settings keep-filenames: keep-filenames)
;; (pop-directory)
(loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))
(begin
(debug:print '(2 9) #f "INFO: include file " include-file " not found (called from " path ")")
(debug:print 2 *default-log-port* " " full-conf)
(loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)))))
(configf:comment-rx _ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings)
curr-section-name #f #f))
(configf:blank-l-rx _ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings)
curr-section-name #f #f))
(configf:settings ( x setting val )
(begin
(hash-table-set! settings setting val)
(loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings)
curr-section-name #f #f)))
(configf:include-rx ( x include-file )
(let* ((curr-conf-dir (pathname-directory path))
(full-conf (if (absolute-pathname? include-file)
include-file
(common:nice-path
(conc (if curr-conf-dir
curr-conf-dir
".")
"/" include-file)))))
(if (common:file-exists? full-conf)
(begin
;; (push-directory conf-dir)
(debug:print 9 *default-log-port* "Including: " full-conf)
(read-config full-conf res allow-system environ-patt: environ-patt
curr-section: curr-section-name sections: sections settings: settings
keep-filenames: keep-filenames)
;; (pop-directory)
(loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))
(begin
(debug:print '(2 9) #f "INFO: include file " include-file " not found (called from " path ")")
(debug:print 2 *default-log-port* " " full-conf)
(loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings)
curr-section-name #f #f)))))
(configf:script-rx ( x include-script params);; handle-exceptions
;; exn
;; (begin
;; (debug:print '(0 2 9) #f "INFO: include from script " include-script " failed.")
;; (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))
(if (and (common:file-exists? include-script)(file-execute-access? include-script))
(let* ((new-inp-port (open-input-pipe (conc include-script " " params))))
(debug:print '(2 9) *default-log-port* "Including from script output: " include-script)
;; (print "We got here, calling read-config next. Port is: " new-inp-port)
(read-config new-inp-port res allow-system environ-patt: environ-patt curr-section: curr-section-name sections: sections settings: settings keep-filenames: keep-filenames)
(close-input-port new-inp-port)
(loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))
(begin
(debug:print 0 *default-log-port* "Script not found or not exectutable: " include-script)
(loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)))
) ;; )
(configf:section-rx ( x section-name ) (begin
;; call post-section-procs
(for-each
(lambda (dat)
(let ((patt (car dat))
(proc (cdr dat)))
(if (string-match patt curr-section-name)
(proc curr-section-name section-name res path))))
post-section-procs)
;; after gathering the vars for a section and if apply-wildcards is true and if there is a wildcard in the section name process wildcards
;; NOTE: we are processing the curr-section-name, NOT section-name.
(process-wildcards res curr-section-name)
(if (not (hash-table-ref/default res section-name #f))(hash-table-set! res section-name '())) ;; ensure that mere mention of a section is not lost
(loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings)
;; if we have the sections list then force all settings into "" and delete it later?
;; (if (or (not sections)
;; (member section-name sections))
;; section-name "") ;; stick everything into "". NOPE: We need new strategy. Put stuff in correct sections and then delete all sections later.
section-name
#f #f)))
(configf:key-sys-pr ( x key cmd ) (if (calc-allow-system allow-system curr-section-name sections)
(let ((alist (hash-table-ref/default res curr-section-name '()))
(val-proc (lambda ()
(let* ((start-time (current-seconds))
(cmdres (process:cmd-run->list cmd))
(delta (- (current-seconds) start-time))
(status (cadr cmdres))
(res (car cmdres)))
(debug:print-info 4 *default-log-port* "" inl "\n => " (string-intersperse res "\n"))
(if (not (eq? status 0))
(begin
(debug:print-error 0 *default-log-port* "problem with " inl ", return code " status
" output: " cmdres)))
(if (> delta 2)
(debug:print-info 0 *default-log-port* "for line \"" inl "\"\n command: " cmd " took " delta " seconds to run with output:\n " res)
(debug:print-info 9 *default-log-port* "for line \"" inl "\"\n command: " cmd " took " delta " seconds to run with output:\n " res))
(if (null? res)
""
(string-intersperse res " "))))))
(hash-table-set! res curr-section-name
(config:assoc-safe-add alist
key
(case (calc-allow-system allow-system curr-section-name sections)
((return-procs) val-proc)
((return-string) cmd)
(else (val-proc)))
metadata: metapath))
(loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))
(loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)))
(configf:key-no-val ( x key val) (let* ((alist (hash-table-ref/default res curr-section-name '()))
(fval (or (if (string? val) val #f) ""))) ;; fval should be either "" or " " (one or more spaces)
(debug:print 10 *default-log-port* " setting: [" curr-section-name "] " key " = #t")
(safe-setenv key fval)
(hash-table-set! res curr-section-name
(config:assoc-safe-add alist key fval metadata: metapath))
(loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name key #f)))
(configf:key-val-pr ( x key unk1 val unk2 ) (let* ((alist (hash-table-ref/default res curr-section-name '()))
(envar (and environ-patt (string-search (regexp environ-patt) curr-section-name)))
(realval (if envar
(config:eval-string-in-environment val)
val)))
(debug:print-info 6 *default-log-port* "read-config env setting, envar: " envar " realval: " realval " val: " val " key: " key " curr-section-name: " curr-section-name)
(if envar (safe-setenv key realval))
(debug:print 10 *default-log-port* " setting: [" curr-section-name "] " key " = " val)
(hash-table-set! res curr-section-name
(config:assoc-safe-add alist key realval metadata: metapath))
(loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name key #f)))
(if (and (common:file-exists? include-script)(file-execute-access? include-script))
(let* ((local-allow-system (calc-allow-system allow-system curr-section-name sections))
(env-delta (configf:cfgdat->env-alist curr-section-name res local-allow-system))
(new-inp-port
(common:with-env-vars
env-delta
(lambda ()
(open-input-pipe (conc include-script " " params))))))
(debug:print '(2 9) *default-log-port* "Including from script output: " include-script)
;; (print "We got here, calling read-config next. Port is: " new-inp-port)
(read-config new-inp-port res allow-system environ-patt: environ-patt curr-section: curr-section-name sections: sections settings: settings keep-filenames: keep-filenames)
(close-input-port new-inp-port)
(loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))
(begin
(debug:print 0 *default-log-port* "Script not found or not exectutable: " include-script)
(loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)))
) ;; )
(configf:section-rx ( x section-name )
(begin
;; call post-section-procs
(for-each
(lambda (dat)
(let ((patt (car dat))
(proc (cdr dat)))
(if (string-match patt curr-section-name)
(proc curr-section-name section-name res path))))
post-section-procs)
;; after gathering the vars for a section and if apply-wildcards is true and if there is a wildcard in the section name process wildcards
;; NOTE: we are processing the curr-section-name, NOT section-name.
(process-wildcards res curr-section-name)
(if (not (hash-table-ref/default res section-name #f))(hash-table-set! res section-name '())) ;; ensure that mere mention of a section is not lost
(loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings)
;; if we have the sections list then force all settings into "" and delete it later?
;; (if (or (not sections)
;; (member section-name sections))
;; section-name "") ;; stick everything into "". NOPE: We need new strategy. Put stuff in correct sections and then delete all sections later.
section-name
#f #f)))
(configf:key-sys-pr ( x key cmd )
(if (calc-allow-system allow-system curr-section-name sections)
(let ((alist (hash-table-ref/default res curr-section-name '()))
(val-proc (lambda ()
(let* ((start-time (current-seconds))
(local-allow-system (calc-allow-system allow-system curr-section-name sections))
(env-delta (configf:cfgdat->env-alist curr-section-name res local-allow-system))
(cmdres (process:cmd-run->list cmd delta-env-alist-or-hash-table: env-delta)) ;; BB: here is where [system is exec'd. needs to have env from other vars!
(delta (- (current-seconds) start-time))
(status (cadr cmdres))
(res (car cmdres)))
(debug:print-info 4 *default-log-port* "" inl "\n => " (string-intersperse res "\n"))
(if (not (eq? status 0))
(begin
(debug:print-error 0 *default-log-port* "problem with " inl ", return code " status
" output: " cmdres)))
(if (> delta 2)
(debug:print-info 0 *default-log-port* "for line \"" inl "\"\n command: " cmd " took " delta " seconds to run with output:\n " res)
(debug:print-info 9 *default-log-port* "for line \"" inl "\"\n command: " cmd " took " delta " seconds to run with output:\n " res))
(if (null? res)
""
(string-intersperse res " "))))))
(hash-table-set! res curr-section-name
(config:assoc-safe-add alist
key
(case (calc-allow-system allow-system curr-section-name sections)
((return-procs) val-proc)
((return-string) cmd)
(else (val-proc)))
metadata: metapath))
(loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))
(loop (configf:read-line inp res
(calc-allow-system allow-system curr-section-name sections)
settings)
curr-section-name #f #f)))
(configf:key-no-val ( x key val)
(let* ((alist (hash-table-ref/default res curr-section-name '()))
(fval (or (if (string? val) val #f) ""))) ;; fval should be either "" or " " (one or more spaces)
(debug:print 10 *default-log-port* " setting: [" curr-section-name "] " key " = #t")
(safe-setenv key fval)
(hash-table-set! res curr-section-name
(config:assoc-safe-add alist key fval metadata: metapath))
(loop (configf:read-line inp res
(calc-allow-system allow-system curr-section-name sections)
settings)
curr-section-name key #f)))
(configf:key-val-pr ( x key unk1 val unk2 )
(let* ((alist (hash-table-ref/default res curr-section-name '()))
(envar (and environ-patt (string-search (regexp environ-patt) curr-section-name)))
(realval (if envar
(config:eval-string-in-environment val)
val)))
(debug:print-info 6 *default-log-port* "read-config env setting, envar: " envar " realval: " realval " val: " val " key: " key " curr-section-name: " curr-section-name)
(if envar (safe-setenv key realval))
(debug:print 10 *default-log-port* " setting: [" curr-section-name "] " key " = " val)
(hash-table-set! res curr-section-name
(config:assoc-safe-add alist key realval metadata: metapath))
(loop (configf:read-line inp res
(calc-allow-system allow-system curr-section-name sections) settings)
curr-section-name key #f)))
;; if a continued line
(configf:cont-ln-rx ( x whsp val ) (let ((alist (hash-table-ref/default res curr-section-name '())))
(if var-flag ;; if set to a string then we have a continued var
(let ((newval (conc
(config-lookup res curr-section-name var-flag) "\n"
;; trim lead from the incoming whsp to support some indenting.
(if lead
(string-substitute (regexp lead) "" whsp)
"")
val)))
;; (print "val: " val "\nnewval: \"" newval "\"\nvarflag: " var-flag)
(hash-table-set! res curr-section-name
(config:assoc-safe-add alist var-flag newval metadata: metapath))
(loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name var-flag (if lead lead whsp)))
(loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))))
(configf:cont-ln-rx ( x whsp val )
(let ((alist (hash-table-ref/default res curr-section-name '())))
(if var-flag ;; if set to a string then we have a continued var
(let ((newval (conc
(config-lookup res curr-section-name var-flag) "\n"
;; trim lead from the incoming whsp to support some indenting.
(if lead
(string-substitute (regexp lead) "" whsp)
"")
val)))
;; (print "val: " val "\nnewval: \"" newval "\"\nvarflag: " var-flag)
(hash-table-set! res curr-section-name
(config:assoc-safe-add alist var-flag newval metadata: metapath))
(loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name var-flag (if lead lead whsp)))
(loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))))
(else (debug:print-error 0 *default-log-port* "problem parsing " path ",\n \"" inl "\"")
(set! var-flag #f)
(loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))))))))
(loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))))
) ;; end loop
)))
;; pathenvvar will set the named var to the path of the config
(define (find-and-read-config fname #!key (environ-patt #f)(given-toppath #f)(pathenvvar #f))
(let* ((curr-dir (current-directory))
(configinfo (find-config fname toppath: given-toppath))
(toppath (car configinfo))
(configfile (cadr configinfo))
|
︙ | | |
455
456
457
458
459
460
461
462
463
464
465
466
467
468
|
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
|
+
+
+
+
+
+
+
+
|
(let ((sectdat (hash-table-ref/default cfgdat section '())))
(if (null? sectdat)
'()
(map car sectdat))))
(define (configf:get-section cfgdat section)
(hash-table-ref/default cfgdat section '()))
(define (configf:set-section-var cfgdat section var val)
(let ((sectdat (configf:get-section cfgdat section)))
(hash-table-set! cfgdat section
(config:assoc-safe-add sectdat var val))))
;;(append (filter (lambda (x)(not (assoc var sectdat))) sectdat)
;; (list var val))))
(define (setup)
(let* ((configf (find-config "megatest.config"))
(config (if configf (read-config configf #f #t) #f)))
(if config
(setenv "RUN_AREA_HOME" (pathname-directory configf)))
config))
|
︙ | | |
︙ | | |
219
220
221
222
223
224
225
226
227
228
229
230
231
232
|
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
|
+
|
(if (not readyexists)
(common:simple-file-lock-and-wait lockfname))
(let ((db (sqlite3:open-database fname)))
(sqlite3:set-busy-handler! db (make-busy-timeout 136000))
(sqlite3:execute db "PRAGMA synchronous = 0;")
(if (not file-exists)
(begin
(if (and (configf:lookup *configdat* "setup" "use-wal")
(string-match "^/tmp/.*" fname)) ;; this is a file in /tmp
(sqlite3:execute db "PRAGMA journal_mode=WAL;")
(debug:print 2 *default-log-port* "Creating " fname " in NON-WAL mode."))
(initproc db)))
(if (not readyexists)
(begin
|
︙ | | |
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
|
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
|
-
+
|
(dbr:dbstruct-refndb-set! dbstruct refndb)
;; (mutex-unlock! *rundb-mutex*)
(if (and (or (not dbfexists)
(and modtimedelta
(> modtimedelta 10))) ;; if db in tmp is over ten seconds older than the file in MTRA then do a sync back
do-sync)
(begin
(debug:print 4 *default-log-port* "filling db " (db:dbdat-get-path tmpdb) " with data \n from " (db:dbdat-get-path mtdb) " mod time delta: " modtimedelta)
(debug:print 1 *default-log-port* "filling db " (db:dbdat-get-path tmpdb) " with data \n from " (db:dbdat-get-path mtdb) " mod time delta: " modtimedelta)
(db:sync-tables (db:sync-all-tables-list dbstruct) #f mtdb refndb tmpdb)
(debug:print-info 13 *default-log-port* "db:sync-all-tables-list done.")
)
(debug:print 4 *default-log-port* " db, " (db:dbdat-get-path tmpdb) " already exists or fresh enough, not propogating data from\n " (db:dbdat-get-path mtdb) " mod time delta: " modtimedelta) )
;; (db:multi-db-sync dbstruct 'old2new)) ;; migrate data from megatest.db automatically
tmpdb))))
|
︙ | | |
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
|
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
|
-
+
|
;;
;; (define (db:launch-delay-left dbstruct run-id launch-delay)
;; select end_time-now from
;; (select testname,item_path,event_time+run_duration as
;; end_time,strftime('%s','now') as now from tests where state in
;; ('RUNNING','REMOTEHOSTSTART','LAUNCED'));
;; ('RUNNING','REMOTEHOSTSTART','LAUNCHED'));
(define (db:find-and-mark-incomplete dbstruct run-id ovr-deadtime)
(let* ((incompleted '())
(oldlaunched '())
(toplevels '())
(deadtime-str (configf:lookup *configdat* "setup" "deadtime")) ;; FIXME suspect test run time & deadtime are not well matched; resulting in COMPLETED/DEAD status of an a-ok running test
(deadtime (if (and deadtime-str
|
︙ | | |
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
|
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
|
-
+
|
(define (db:get-run-times dbstruct run-patt target-patt)
(let ((res `())
(qry (conc "select runname, (max(end_time)-min(event_time))/60 as runtime, target from (select runname, run_id,tests.event_time,tests.event_time+run_duration AS end_time, " (string-join (db:get-keys dbstruct) " || '/' || ") " as target from tests inner join runs on tests.run_id = runs.id where runs.runname like ? and target like ?) group by run_id ;")))
(print qry)
;(print qry)
(db:with-db
dbstruct
#f ;; this is for the main runs db
#f ;; does not modify db
(lambda (db)
(sqlite3:for-each-row
(lambda (runname runtime target )
|
︙ | | |
2534
2535
2536
2537
2538
2539
2540
2541
2542
2543
2544
2545
2546
2547
2548
2549
2550
2551
2552
2553
2554
2555
2556
2557
2558
2559
2560
2561
2562
2563
2564
2565
2566
|
2535
2536
2537
2538
2539
2540
2541
2542
2543
2544
2545
2546
2547
2548
2549
2550
2551
2552
2553
2554
2555
2556
2557
2558
2559
2560
2561
2562
2563
2564
2565
2566
2567
|
-
+
-
+
|
dbstruct #f #f
(lambda (db)
(for-each
(lambda (key)
(let ((qry (conc "SELECT " key " FROM runs WHERE id=?;")))
(sqlite3:for-each-row
(lambda (key-val)
(set! res (cons (list key key-val) res)))
(set! res (cons (list key (if (string? key-val) key-val "")) res))) ;; replace non-string bad values with empty string to prevent crashes. This scenario can happen when Megatest is killed on updating the db
db qry run-id)))
keys)))
(reverse res)))
;; get key vals for a given run-id
(define (db:get-key-vals dbstruct run-id)
(let* ((keys (db:get-keys dbstruct))
(res '()))
(db:with-db
dbstruct #f #f
(lambda (db)
(for-each
(lambda (key)
(let ((qry (conc "SELECT " key " FROM runs WHERE id=?;")))
;; (db:delay-if-busy dbdat)
(sqlite3:for-each-row
(lambda (key-val)
(set! res (cons key-val res)))
(set! res (cons (if (string? key-val) key-val "") res))) ;; check that the key-val is a string for cases where a crash injected bad data in the megatest.db
db qry run-id)))
keys)))
(let ((final-res (reverse res)))
(hash-table-set! *keyvals* run-id final-res)
final-res)))
;; The target is keyval1/keyval2..., cached in *target* as it is used often
|
︙ | | |
3151
3152
3153
3154
3155
3156
3157
3158
3159
3160
3161
3162
3163
3164
|
3152
3153
3154
3155
3156
3157
3158
3159
3160
3161
3162
3163
3164
3165
3166
3167
3168
3169
3170
3171
3172
3173
3174
3175
3176
3177
3178
3179
3180
3181
3182
|
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
(sqlite3:for-each-row
(lambda (test-name item-path test-time target )
(set! res (cons (vector test-name item-path test-time) res)))
db
qry
run-name target)
res))))
(define (db:get-test-times dbstruct run-name target)
(let ((res `())
(qry (conc "select testname, item_path, run_duration, " (string-join (db:get-keys dbstruct) " || '/' || ") " as target from tests inner join runs on tests.run_id = runs.id where runs.runname = ? and target = ? ;")))
(db:with-db
dbstruct
#f ;; this is for the main runs db
#f ;; does not modify db
(lambda (db)
(sqlite3:for-each-row
(lambda (test-name item-path test-time target )
(set! res (cons (vector test-name item-path test-time) res)))
db
qry
run-name target)
res))))
;;======================================================================
;; S T E P S
;;======================================================================
(define (db:teststep-set-status! dbstruct run-id test-id teststep-name state-in status-in comment logfile)
(db:with-db
|
︙ | | |
3575
3576
3577
3578
3579
3580
3581
3582
3583
3584
3585
3586
3587
3588
3589
3590
3591
3592
3593
3594
3595
3596
3597
3598
3599
3600
3601
3602
3603
3604
3605
3606
3607
3608
3609
3610
3611
3612
3613
3614
|
3593
3594
3595
3596
3597
3598
3599
3600
3601
3602
3603
3604
3605
3606
3607
3608
3609
3610
3611
3612
3613
3614
3615
3616
3617
3618
3619
3620
3621
3622
3623
3624
3625
3626
3627
3628
3629
3630
3631
3632
|
-
+
-
-
-
-
-
+
+
+
+
+
-
+
|
(let ((tr-res
(sqlite3:with-transaction
db
(lambda ()
;; NB// Pass the db so it is part fo the transaction
(db:test-set-state-status db run-id test-id state status comment) ;; this call sets the item state/status
(if (not (equal? item-path "")) ;; only roll up IF incoming test is an item
(let* ((state-status-counts (db:get-all-state-status-counts-for-test dbstruct run-id test-name item-path)) ;; item-path is used to exclude current state/status of THIS test
(let* ((state-status-counts (db:get-all-state-status-counts-for-test dbstruct run-id test-name item-path state status)) ;; item-path is used to exclude current state/status of THIS test
(running (length (filter (lambda (x)
(member (dbr:counts-state x) *common:running-states*))
state-status-counts)))
(bad-not-started (length (filter (lambda (x)
(and (equal? (dbr:counts-state x) "NOT_STARTED")
(not (member (dbr:counts-status x)
*common:not-started-ok-statuses*))))
state-status-counts)))
;; (non-completes (filter (lambda (x)
;; (not (equal? (dbr:counts-state x) "COMPLETED")))
;; state-status-counts))
(all-curr-states (common:special-sort ;; worst -> best (sort of)
(delete-duplicates
(if (not (equal? state "DELETED"))
(cons state (map dbr:counts-state state-status-counts))
(map dbr:counts-state state-status-counts)))
*common:std-states* >))
(delete-duplicates
(if (not (equal? state "DELETED"))
(cons state (map dbr:counts-state state-status-counts))
(map dbr:counts-state state-status-counts)))
*common:std-states* >))
(all-curr-statuses (common:special-sort ;; worst -> best
(delete-duplicates
(if (not (equal? state "DELETED"))
(cons status (map dbr:counts-status state-status-counts))
(map dbr:counts-status state-status-counts)))
*common:std-statuses* >))
(non-completes (filter (lambda (x)
(not (equal? x "COMPLETED")))
(not (member x '("DELETED" "COMPLETED"))))
all-curr-states))
(preq-fails (filter (lambda (x)
(equal? x "PREQ_FAIL"))
all-curr-statuses))
(num-non-completes (length non-completes))
(newstate (cond
((> running 0) "RUNNING") ;; anything running, call the situation running
|
︙ | | |
3627
3628
3629
3630
3631
3632
3633
3634
3635
3636
3637
3638
3639
3640
3641
3642
3643
3644
3645
3646
3647
3648
3649
3650
3651
3652
3653
3654
3655
3656
3657
3658
3659
3660
3661
3662
3663
3664
3665
3666
3667
3668
3669
3670
|
3645
3646
3647
3648
3649
3650
3651
3652
3653
3654
3655
3656
3657
3658
3659
3660
3661
3662
3663
3664
3665
3666
3667
3668
3669
3670
3671
3672
3673
3674
3675
3676
3677
3678
3679
3680
3681
3682
3683
3684
3685
3686
3687
3688
3689
3690
3691
3692
3693
3694
3695
3696
3697
3698
3699
3700
3701
3702
3703
3704
3705
3706
3707
3708
3709
3710
3711
3712
3713
3714
3715
3716
3717
3718
3719
3720
3721
3722
3723
3724
3725
3726
3727
3728
3729
|
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
"PREQ_FAIL")
((or (> bad-not-started 0)
(and (equal? newstate "NOT_STARTED")
(> num-non-completes 0)))
"STARTED")
(else
(car all-curr-statuses)))))
(debug:print-info 2 *default-log-port*
"\n--> probe db:set-state-status-and-roll-up-items: "
"\n--> state-status-counts: "(map dbr:counts->alist state-status-counts)
"\n--> running: "running
"\n--> bad-not-started: "bad-not-started
"\n--> non-non-completes: "num-non-completes
"\n--> non-completes: "non-completes
"\n--> all-curr-states: "all-curr-states
"\n--> all-curr-statuses: "all-curr-statuses
"\n--> newstate "newstate
"\n--> newstatus "newstatus
"\n\n")
;; (print "bad-not-supported: " bad-not-support " all-curr-states: " all-curr-states " all-curr-statuses: " all-curr-states)
;; " newstate: " newstate " newstatus: " newstatus)
;; NB// Pass the db so it is part of the transaction
(debug:print 4 *default-log-port* "BB> tl-test-id="tl-test-id" ; "test-name":"item-path"> bad-not-started="bad-not-started" newstate="newstate" newstatus="newstatus" num-non-completes="num-non-completes" non-completes="non-completes "len(sscs)="(length state-status-counts) " state-status-counts: "
(apply conc
(map (lambda (x)
(conc
(with-output-to-string (lambda () (pp (dbr:counts->alist x)))) " | "))
state-status-counts))
); end debug:print
(if tl-test-id
(db:test-set-state-status db run-id tl-test-id newstate newstatus #f)) ;; we are still in the transaction - must access the db and not the dbstruct
))))))
(mutex-unlock! *db-transaction-mutex*)
(if (and test-id state status (equal? status "AUTO"))
(db:test-data-rollup dbstruct run-id test-id status))
tr-res)))))
;; BBnote: db:get-all-state-status-counts-for-test returns dbr:counts object aggregating state and status of items of a given test, *not including rollup state/status*
(define (db:get-all-state-status-counts-for-test dbstruct run-id test-name item-path)
(db:with-db
dbstruct #f #f
(lambda (db)
(sqlite3:map-row
(lambda (state status count)
(make-dbr:counts state: state status: status count: count))
db
"SELECT state,status,count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND item_path !=? GROUP BY state,status;"
run-id test-name item-path))))
(define (db:get-all-state-status-counts-for-test dbstruct run-id test-name item-path item-state-in item-status-in)
(let* ((test-info (db:get-test-info dbstruct run-id test-name item-path))
(item-state (or item-state-in (db:test-get-state test-info)))
(item-status (or item-status-in (db:test-get-status test-info)))
(other-items-count-recs (db:with-db
dbstruct #f #f
(lambda (db)
(sqlite3:map-row
(lambda (state status count)
(make-dbr:counts state: state status: status count: count))
db
;; ignore current item because we have changed its value in the current transation so this select will see the old value.
"SELECT state,status,count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND item_path !=? GROUP BY state,status;"
run-id test-name item-path))))
;; add current item to tally outside of sql query
(match-countrec-lambda (lambda (countrec)
(and (equal? (dbr:counts-state countrec) item-state)
(equal? (dbr:counts-status countrec) item-status))))
(already-have-count-rec-list
(filter match-countrec-lambda other-items-count-recs)) ;; will have either 0 or 1 count recs depending if another item shares this item's state/status
(updated-count-rec (if (null? already-have-count-rec-list)
(make-dbr:counts state: item-state status: item-status count: 1)
(let* ((our-count-rec (car already-have-count-rec-list))
(new-count (add1 (dbr:counts-count our-count-rec))))
(make-dbr:counts state: item-state status: item-status count: new-count))))
(nonmatch-countrec-lambda (lambda (countrec) (not (match-countrec-lambda countrec))))
(unrelated-rec-list
(filter nonmatch-countrec-lambda other-items-count-recs)))
(cons updated-count-rec unrelated-rec-list)))
;; (define (db:get-all-item-states db run-id test-name)
;; (sqlite3:map-row
;; (lambda (a) a)
;; db
;; "SELECT DISTINCT state FROM tests WHERE item_path != '' AND state != 'DELETED' AND run_id=? AND testname=?"
;; run-id test-name))
|
︙ | | |
4198
4199
4200
4201
4202
4203
4204
4205
4206
4207
4208
4209
4210
4211
4212
4213
4214
4215
4216
4217
4218
4219
4220
4221
4222
4223
4224
4225
4226
4227
4228
4229
4230
4231
4232
4233
4234
4235
4236
4237
4238
4239
4240
4241
4242
4243
4244
4245
4246
4247
4248
4249
4250
4251
4252
4253
4254
4255
4256
4257
4258
4259
4260
4261
4262
4263
4264
4265
4266
4267
4268
4269
4270
4271
4272
4273
|
4257
4258
4259
4260
4261
4262
4263
4264
4265
4266
4267
4268
4269
4270
4271
4272
4273
4274
4275
4276
4277
4278
4279
4280
4281
4282
4283
4284
4285
4286
4287
4288
4289
4290
4291
4292
4293
4294
4295
4296
4297
4298
4299
4300
4301
4302
4303
4304
4305
4306
4307
4308
4309
4310
4311
4312
4313
4314
4315
4316
4317
4318
4319
4320
4321
4322
4323
4324
4325
4326
4327
4328
4329
4330
4331
4332
4333
4334
4335
4336
4337
4338
4339
4340
4341
4342
4343
4344
4345
4346
4347
4348
4349
4350
4351
4352
4353
4354
4355
4356
4357
4358
4359
4360
4361
4362
4363
4364
4365
4366
4367
4368
4369
4370
4371
4372
4373
4374
4375
4376
4377
4378
4379
4380
4381
4382
4383
4384
4385
|
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
-
+
+
+
+
+
+
+
+
-
+
-
-
-
+
+
+
+
+
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
-
+
+
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
-
-
+
+
+
-
-
-
-
-
-
-
+
+
+
+
+
+
+
-
-
+
+
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
+
+
-
-
+
+
|
;; (if (equal? (db:test-get-item-path testdat) "")
;; (db:test-get-testname testdat)
;; (conc (db:test-get-testname testdat)
;; "/"
;; (db:test-get-item-path testdat))))
running-tests) ;; calling functions want the entire data
'())
;; collection of: for each waiton -
;; if this ref-test-name is an item in an itemized test and mode is itemwait/itemmatch:
;; if waiton is not itemized - if waiton is not both completed and in ok status, add as unmet prerequisite
;; if waiton is itemized:
;; and waiton's items are not expanded, add as unmet prerequisite
;; else if matching waiton item is not both completed and in an ok status, add as unmet prerequisite
;; else
;; if waiton toplevel is not in both completed and ok status, add as unmet prerequisite
(if (or (not waitons)
(null? waitons))
'()
(let* ((ref-test-itemized-mode (not (null? (lset-intersection eq? mode '(itemmatch itemwait)))))
(ref-test-toplevel-mode (not (null? (lset-intersection eq? mode '(toplevel)))))
(ref-test-is-toplevel (equal? ref-item-path ""))
(ref-test-is-item (not ref-test-is-toplevel))
(let* ((unmet-pre-reqs '())
(result '()))
(for-each
(unmet-pre-reqs '())
(result '())
(unmet-prereq-items '())
)
(for-each ; waitons
(lambda (waitontest-name)
;; by getting the tests with matching name we are looking only at the matching test
;; and related sub items
;; next should be using mt:get-tests-for-run?
(let (;(waiton-is-itemized ...)
;(waiton-items-are-expanded ...)
(let ((tests (db:get-tests-for-run-state-status dbstruct run-id waitontest-name))
(waiton-tests (db:get-tests-for-run-state-status dbstruct run-id waitontest-name))
(ever-seen #f)
(parent-waiton-met #f)
(item-waiton-met #f))
(for-each
(lambda (test) ;; BB- this is the upstream test
(item-waiton-met #f)
)
(for-each ; test expanded from waiton
(lambda (waiton-test)
;; (if (equal? waitontest-name (db:test-get-testname test)) ;; by defintion this had better be true ...
(let* ((state (db:test-get-state test))
(status (db:test-get-status test))
(item-path (db:test-get-item-path test)) ;; BB- this is the upstream itempath
(is-completed (equal? state "COMPLETED"))
(is-running (equal? state "RUNNING"))
(is-killed (equal? state "KILLED"))
(is-ok (member status '("PASS" "WARN" "CHECK" "WAIVED" "SKIP")))
(let* ((waiton-state (db:test-get-state waiton-test))
(waiton-status (db:test-get-status waiton-test))
(waiton-item-path (db:test-get-item-path waiton-test)) ;; BB- this is the upstream itempath
(waiton-is-toplevel (equal? waiton-item-path ""))
(waiton-is-item (not waiton-is-toplevel))
(waiton-is-completed (member waiton-state *common:ended-states*))
(waiton-is-running (member waiton-state *common:running-states*))
(waiton-is-killed (member waiton-state *common:badly-ended-states*))
(waiton-is-ok (member waiton-status *common:well-ended-states*))
;; testname-b path-a path-b
(same-itempath (db:compare-itempaths ref-test-name item-path ref-item-path itemmaps))) ;; (equal? ref-item-path item-path)))
(same-itempath (db:compare-itempaths ref-test-name waiton-item-path ref-item-path itemmaps))) ;; (equal? ref-item-path waiton-item-path)))
(set! ever-seen #t)
;;(BB> "***consider waiton "waiton-test"/"waiton-item-path"***")
(cond
;; case 1, non-item (parent test) is
((and (equal? item-path "") ;; this is the parent test of the waiton being examined
is-completed
(or is-ok (not (null? (lset-intersection eq? mode '(toplevel)))))) ;; itemmatch itemwait))))))
(cond
;; case 0 - toplevel of an itemized test, at least one item in prereq has completed
((and waiton-is-item ref-test-is-toplevel ref-test-itemized-mode waiton-is-completed)
(set! parent-waiton-met #t))
;; case 1, non-item (parent test) is
((and waiton-is-toplevel ;; this is the parent test of the waiton being examined
waiton-is-completed
;;(BB> "cond1")
(or waiton-is-ok ref-test-toplevel-mode)) ;; itemmatch itemwait))))))
(set! parent-waiton-met #t))
;; Special case for toplevel and KILLED
((and (equal? item-path "") ;; this is the parent test
is-killed
((and waiton-is-toplevel ;; this is the parent test
waiton-is-killed
(member 'toplevel mode))
;;(BB> "cond2")
(set! parent-waiton-met #t))
;; For itemwait mode IFF the previous matching item is good the set parent-waiton-met
((and (not (null? (lset-intersection eq? mode '(itemmatch itemwait)))) ;; how is that different from (member mode '(itemmatch itemwait)) ?????
;; (not (equal? item-path "")) ;; this applies to both top level (to allow launching of next batch) and items
same-itempath)
(if (and is-completed is-ok)
(set! item-waiton-met #t))
(if (and (equal? item-path "") ;; if upstream rollup test is completed, parent-waiton-met is set
(or is-completed is-running));; this is the parent, set it to run if completed or running ;; BB1
((and ref-test-itemized-mode ref-test-is-item same-itempath)
;;(BB> "cond3")
(if (and waiton-is-completed (or waiton-is-ok ref-test-toplevel-mode))
(set! item-waiton-met #t)
(set! unmet-prereq-items (cons waiton-test unmet-prereq-items)))
(if (and waiton-is-toplevel ;; if upstream rollup test is completed, parent-waiton-met is set
(or waiton-is-completed waiton-is-running))
(set! parent-waiton-met #t)))
;; normal checking of parent items, any parent or parent item not ok blocks running
((and is-completed
(or is-ok
((and waiton-is-completed
(or waiton-is-ok
(member 'toplevel mode)) ;; toplevel does not block on FAIL
(and is-ok (member 'itemmatch mode))) ;; itemmatch blocks on not ok
(set! item-waiton-met #t)))))
tests)
(and waiton-is-ok (member 'itemmatch mode) ;; itemmatch blocks on not ok
))
;;(BB> "cond4")
(set! item-waiton-met #t))
((and waiton-is-completed waiton-is-ok same-itempath)
;;(BB> "cond5")
(set! item-waiton-met #t))
(else
#t
;;(BB> "condelse")
))))
waiton-tests)
;; both requirements, parent and item-waiton must be met to NOT add item to
;; prereq's not met list
;; (BB>
;; "\n* waiton-tests "waiton-tests
;; "\n* parent-waiton-met "parent-waiton-met
;; "\n* item-waiton-met "item-waiton-met
;; "\n* ever-seen "ever-seen
;; "\n* ref-test-itemized-mode "ref-test-itemized-mode
;; "\n* unmet-prereq-items "unmet-prereq-items
;; "\n* result (pre) "result
;; "\n* ever-seen "ever-seen
;; "\n")
(cond
((and ref-test-itemized-mode ref-test-is-item (not (null? unmet-prereq-items)))
(set! result (append unmet-prereq-items result)))
(if (not (or parent-waiton-met item-waiton-met))
(set! result (append (if (null? tests) (list waitontest-name) tests) result))) ;; appends the string if the full record is not available
((not (or parent-waiton-met item-waiton-met))
(set! result (append (if (null? waiton-tests) (list waitontest-name) waiton-tests) result))) ;; appends the string if the full record is not available
;; if the test is not found then clearly the waiton is not met...
;; (if (not ever-seen)(set! result (cons waitontest-name result)))))
(if (not ever-seen)
(set! result (append (if (null? tests)(list waitontest-name) tests) result)))))
((not ever-seen)
(set! result (append (if (null? waiton-tests)(list waitontest-name) waiton-tests) result))))))
waitons)
(delete-duplicates result)))))
;;======================================================================
;; Just for sync, procedures to make sync easy
;;======================================================================
|
︙ | | |
1
2
3
4
5
6
7
8
9
10
11
12
|
1
2
3
4
5
6
7
8
9
10
11
12
|
-
+
|
<!DOCTYPE html>
<html lang="en">
<head>
<meta http-equiv="Content-Type" content="text/html; charset=UTF-8">
<meta name="generator" content="AsciiDoc 8.6.9">
<meta name="generator" content="AsciiDoc 8.6.7">
<title>The Megatest Users Manual</title>
<style type="text/css">
/* Shared CSS for AsciiDoc xhtml11 and html5 backends */
/* Default font. */
body {
font-family: Georgia,serif;
|
︙ | | |
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
|
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
|
-
+
-
-
-
-
-
-
|
ul, ol, li > p {
margin-top: 0;
}
ul > li { color: #aaa; }
ul > li > * { color: black; }
.monospaced, code, pre {
pre {
font-family: "Courier New", Courier, monospace;
font-size: inherit;
color: navy;
padding: 0;
margin: 0;
}
pre {
white-space: pre-wrap;
}
#author {
color: #527bbd;
font-weight: bold;
font-size: 1.1em;
}
#email {
|
︙ | | |
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
|
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
|
-
+
|
div.exampleblock > div.content {
border-left: 3px solid #dddddd;
padding-left: 0.5em;
}
div.imageblock div.content { padding-left: 0; }
span.image img { border-style: none; vertical-align: text-bottom; }
span.image img { border-style: none; }
a.image:visited { color: white; }
dl {
margin-top: 0.8em;
margin-bottom: 0.8em;
}
dt {
|
︙ | | |
415
416
417
418
419
420
421
422
423
424
425
426
427
428
|
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
|
+
+
+
+
+
+
|
div.unbreakable { page-break-inside: avoid; }
/*
* xhtml11 specific
*
* */
tt {
font-family: "Courier New", Courier, monospace;
font-size: inherit;
color: navy;
}
div.tableblock {
margin-top: 1.0em;
margin-bottom: 1.5em;
}
div.tableblock > table {
border: 3px solid #527bbd;
|
︙ | | |
448
449
450
451
452
453
454
455
456
457
458
459
460
461
|
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
|
+
+
+
+
+
+
|
}
/*
* html5 specific
*
* */
.monospaced {
font-family: "Courier New", Courier, monospace;
font-size: inherit;
color: navy;
}
table.tableblock {
margin-top: 1.0em;
margin-bottom: 1.5em;
}
thead, p.tableblock.header {
font-weight: bold;
|
︙ | | |
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
|
534
535
536
537
538
539
540
541
542
543
544
545
546
547
|
-
-
|
body.manpage div.sectionbody {
margin-left: 3em;
}
@media print {
body.manpage div#toc { display: none; }
}
@media screen {
body {
max-width: 50em; /* approximately 80 characters wide */
margin-left: 16em;
}
#toc {
|
︙ | | |
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
|
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
|
-
+
|
<div class="content monospaced">
<pre>[triggers]
COMPLETED/ xterm -e bash -s --</pre>
</div></div>
<div class="admonitionblock">
<table><tr>
<td class="icon">
<img src="/usr/images/icons/note.png" alt="Note">
<img src="/nfs/pdx/disks/ice.disk.002/icfadm/pkgs/asciidoc/8.6.7/images/icons/note.png" alt="Note">
</td>
<td class="content">There is a trailing space after the --</td>
</tr></table>
</div>
<div class="paragraph"><p>There are a number of environment variables available to the trigger script
but since triggers can be called in various contexts not all variables are
available at all times. The trigger script should check for the variable and
|
︙ | | |
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
|
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
|
-
|
megatest -envdelta original-munged -dumpmode ini -o modified.config</pre>
</div></div>
<div class="paragraph"><p>Then in runconfigs.config</p></div>
<div class="listingblock">
<div class="title">Example of using modified.config in a testconfig</div>
<div class="content monospaced">
<pre>cat testconfig
[pre-launch-env-vars]
[include modified.config]</pre>
</div></div>
</div>
</div>
</div>
<div class="sect1">
|
︙ | | |
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
|
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
|
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
<div class="listingblock">
<div class="title">For each target, remove all runs but the most recent 3 if they are over 1 week old</div>
<div class="content monospaced">
<pre># use -precmd 'sleep 5;nbfake' to limit overloading the host computer but to allow the removes to run in parallel.
megatest -actions print,remove-runs -remove-keep 3 -target %/%/%/% -runname % -age 1w -precmd 'sleep 5;nbfake'"</pre>
</div></div>
</div>
</div>
<div class="sect1">
<h2 id="_nested_runs">Nested Runs</h2>
<div class="sectionbody">
<div class="paragraph"><p>A Megatest test can run a full Megatest run in either the same
Megatest area or in another area. This is a powerful way of chaining
complex suites of tests and or actions.</p></div>
<div class="paragraph"><p>If you are not using the current area you can use ezsteps to retrieve
and setup the sub-Megatest run area.</p></div>
<div class="paragraph"><p>In the testconfig:</p></div>
<div class="listingblock">
<div class="content monospaced">
<pre>[subrun]
# Required: wait for the run or just launch it
# if no then the run will be an automatic PASS irrespective of the actual result
runwait yes|no
# Optional: where to execute the run. Default is the current runarea
runarea /some/path/to/megatest/area
# Optional: method to use to determine pass/fail status of the run
# auto (default) - roll up the net state/status of the sub-run
# logpro - use the provided logpro rules, happens automatically if there is a logpro section
# passfail auto|logpro
# Example of logpro:
passfail logpro
# Optional:
logpro ;; if this section exists then logpro is used to determine pass/fail
(expect:required in "LogFileBody" >= 1 "At least one pass" #/PASS/)
# Optional: target translator, default is to use the parent target
target #{shell somescript.sh}
# Optional: runname translator/generator, default is to use the parent runname
runname #{somescript.sh}
# Optional: testpatt spec, default is to first look for TESTPATT spec from runconfigs unless there is a contour spec
testpatt %/item1,test2
# Optional: contour spec, use the named contour from the megatest.config contour spec
contour contourname ### NOTE: Not implemented yet! Let us know if you need this feature.
# Optional: mode-patt, use this spec for testpatt from runconfigs
mode-patt TESTPATT
# Optional: tag-expr, use this tag-expr to select tests
tag-expr quick
# Optional: (not yet implemented), propagate these actions from the parent
# test
# Note// default is % for all
propagate remove-runs archive ...</pre>
</div></div>
</div>
</div>
<div class="sect1">
<h2 id="_programming_api">Programming API</h2>
<div class="sectionbody">
<div class="paragraph"><p>These routines can be called from the megatest repl.</p></div>
<table class="tableblock frame-topbot grid-all"
style="
|
︙ | | |
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
|
2242
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
|
-
+
-
|
</div>
</div>
</div>
<div id="footnotes"><hr></div>
<div id="footer">
<div id="footer-text">
Version 1.0<br>
Last updated
Last updated 2017-08-30 10:42:37 PDT
2017-06-25 21:04:36 MST
</div>
</div>
</body>
</html>
|
︙ | | |
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
|
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
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
|
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
------------------------------
Then in runconfigs.config
.Example of using modified.config in a testconfig
------------------------------
cat testconfig
[pre-launch-env-vars]
[include modified.config]
------------------------------
Managing Old Runs
-----------------
It is often desired to keep some older runs around but this must be balanced with the costs of disk space.
. Use -remove-keep
. Use -archive (can also be done from the -remove-keep interface)
. use -remove-runs with -keep-records
.For each target, remove all runs but the most recent 3 if they are over 1 week old
---------------------
# use -precmd 'sleep 5;nbfake' to limit overloading the host computer but to allow the removes to run in parallel.
megatest -actions print,remove-runs -remove-keep 3 -target %/%/%/% -runname % -age 1w -precmd 'sleep 5;nbfake'"
---------------------
Nested Runs
-----------
A Megatest test can run a full Megatest run in either the same
Megatest area or in another area. This is a powerful way of chaining
complex suites of tests and or actions.
If you are not using the current area you can use ezsteps to retrieve
and setup the sub-Megatest run area.
In the testconfig:
---------------
[subrun]
# Required: wait for the run or just launch it
# if no then the run will be an automatic PASS irrespective of the actual result
runwait yes|no
# Optional: where to execute the run. Default is the current runarea
runarea /some/path/to/megatest/area
# Optional: method to use to determine pass/fail status of the run
# auto (default) - roll up the net state/status of the sub-run
# logpro - use the provided logpro rules, happens automatically if there is a logpro section
# passfail auto|logpro
# Example of logpro:
passfail logpro
# Optional:
logpro ;; if this section exists then logpro is used to determine pass/fail
(expect:required in "LogFileBody" >= 1 "At least one pass" #/PASS/)
(expect:fail in "LogFileBody" = 0 "No FAILs allowed" #/FAIL/)
# Optional: target translator, default is to use the parent target
target #{shell somescript.sh}
# Optional: runname translator/generator, default is to use the parent runname
runname #{somescript.sh}
# Optional: testpatt spec, default is to first look for TESTPATT spec from runconfigs unless there is a contour spec
testpatt %/item1,test2
# Optional: contour spec, use the named contour from the megatest.config contour spec
contour contourname ### NOTE: Not implemented yet! Let us know if you need this feature.
# Optional: mode-patt, use this spec for testpatt from runconfigs
mode-patt TESTPATT
# Optional: tag-expr, use this tag-expr to select tests
tag-expr quick
# Optional: (not yet implemented), propagate these actions from the parent
# test
# Note// default is % for all
propagate remove-runs archive ...
---------------
Programming API
---------------
These routines can be called from the megatest repl.
.API Keys Related Calls
[width="70%",cols="^,2m,2m,2m",frame="topbot",options="header,footer"]
|
︙ | | |