Megatest

Check-in [70e753f237]
Login
Overview
Comment:Merge of v1.55 into v1.60 but too many conflicts, saving on branch confict-merge-v1.60
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | confict-merge-v1.60
Files: files | file ages | folders
SHA1: 70e753f237721b21969a5a8012be0bc7340c6d27
User & Date: matt on 2014-03-30 01:07:57
Other Links: branch diff | manifest | tags
Context
2014-03-30
01:07
Merge of v1.55 into v1.60 but too many conflicts, saving on branch confict-merge-v1.60 Closed-Leaf check-in: 70e753f237 user: matt tags: confict-merge-v1.60
2014-03-29
19:11
Increased retries in client:start to 100, minor edits? check-in: 18d165c8c7 user: matt tags: v1.60
13:31
Improved an error message check-in: aa13991ded user: matt tags: v1.55
Changes

Modified Makefile from [ed1f2297ca] to [e9add66050].

25
26
27
28
29
30
31
32

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

32
33
34
35
36
37
38
39







-
+







CKPATH=$(shell dirname $(shell dirname $(CSIPATH)))
# ARCHSTR=$(shell uname -m)_$(shell uname -r)
# BASH_MACHTYPE=$(shell bash -c "echo \$$MACHTYPE")
# ARCHSTR=$(BASH_MACHTYPE)_$(shell lsb_release -sr)
ARCHSTR=$(shell lsb_release -sr)
# ARCHSTR=$(shell bash -c "echo \$$MACHTYPE")

all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard newdboard txtdb
all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard txtdb

refdb : txtdb/txtdb.scm
	csc -I txtdb txtdb/txtdb.scm -o refdb

mtest: $(OFILES) megatest.o
	csc $(CSCOPTS) $(OFILES) megatest.o -o mtest

Modified common.scm from [f2071ae50f] to [c74c09ea7d].

232
233
234
235
236
237
238

























239
240
241
242
243
244
245
232
233
234
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







+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+







			       #f #t))) string<?))

;; '(print (string-intersperse (map cadr (hash-table-ref/default (read-config "megatest.config" \#f \#t) "disks" '"'"'("none" ""))) "\n"))'
(define (common:get-disks)
  (hash-table-ref/default 
   (read-config "megatest.config" #f #t)
   "disks" '("none" "")))

;;======================================================================
;; T A R G E T S
;;======================================================================

(define (common:args-get-target #!key (split #f))
  (let* ((target  (if (args:get-arg "-reqtarg")
		      (args:get-arg "-reqtarg")
		      (if (args:get-arg "-target")
			  (args:get-arg "-target")
			  #f)))
	 (tlist   (if target (string-split target "/" #t) '()))
	 (valid   (if target
		      (and (not (null? tlist))
			   (null? (filter string-null? tlist)))
		      #f)))
    (if valid
	(if split
	    tlist
	    target)
	(if target
	    (begin
	      (debug:print 0 "ERROR: Invalid target, spaces or blanks not allowed \"" target "\"")
	      #f)
	    #f))))

;;======================================================================
;; M I S C   L I S T S
;;======================================================================

;; items in lista are matched value and position in listb
;; return the remaining items in listb or #f
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
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







-
+





-
-
-
-
+
+
+
+
+
+




-
-
-
-
+
+
+
+
+
+







(define (get-uname . params)
  (let* ((uname-res (cmd-run->list (conc "uname " (if (null? params) "-a" (car params)))))
	 (uname #f))
    (if (null? (car uname-res))
	"unknown"
	(caar uname-res))))
	      
(define (save-environment-as-files fname #!key (ignorevars (list "DISPLAY" "LS_COLORS" "XKEYSYMDB" "EDITOR")))
(define (save-environment-as-files fname #!key (ignorevars (list "USER" "HOME" "DISPLAY" "LS_COLORS" "XKEYSYMDB" "EDITOR")))
  (let ((envvars (get-environment-variables))
        (whitesp (regexp "[^a-zA-Z0-9_\\-:;,.\\/%$]")))
     (with-output-to-file (conc fname ".csh")
       (lambda ()
          (for-each (lambda (key)
		      (if (not (member key ignorevars))
			  (let* ((val (cdr key))
				 (sval (if (string-search whitesp val)(conc "\"" val "\"") val)))
			    (print "setenv " (car key) " " sval))))
		      (let* ((val (cdr key))
			     (sval (if (string-search whitesp val)(conc "\"" val "\"") val)))
			(print (if (member key ignorevars)
				   "# setenv "
				   "setenv ")
			       (car key) " " sval)))
		      envvars)))
     (with-output-to-file (conc fname ".sh")
       (lambda ()
          (for-each (lambda (key)
		      (if (not (member key ignorevars))
			  (let* ((val (cdr key))
				 (sval (if (string-search whitesp val)(conc "\"" val "\"") val)))
			    (print "export " (car key) "=" sval))))
		      (let* ((val (cdr key))
			     (sval (if (string-search whitesp val)(conc "\"" val "\"") val)))
			(print (if (member key ignorevars)
				   "# export "
				   "export ")
			       (car key) "=" sval)))
                    envvars)))))

;; set some env vars from an alist, return an alist with original values
;; (("VAR" "value") ...)
(define (alist->env-vars lst)
  (if (list? lst)
      (let ((res '()))

Modified common_records.scm from [8d360e8ca7] to [785b03b237].

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

13
14
15
16
17
18
19
1
2
3
4
5
6
7
8
9
10
11

12
13
14
15
16
17
18
19











-
+







;;======================================================================
;; 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 trace)
;; (use trace)

(define (debug:calc-verbosity vstr)
  (cond
   ((number? vstr) vstr)
   ((not (string?  vstr))   1)
   ;; ((string-match  "^\\s*$" vstr) 1)
   (vstr           (let ((debugvals  (filter number? (map string->number (string-split vstr ",")))))

Modified dashboard.scm from [289eaba234] to [f68dd2fe09].

163
164
165
166
167
168
169


170
171
172
173
174
175
176
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178







+
+








(define uidat #f)

(define-inline (dboard:uidat-get-keycol  vec)(vector-ref vec 0))
(define-inline (dboard:uidat-get-lftcol  vec)(vector-ref vec 1))
(define-inline (dboard:uidat-get-header  vec)(vector-ref vec 2))
(define-inline (dboard:uidat-get-runsvec vec)(vector-ref vec 3))

(if (get-environment-variable "MT_RUN_AREA_HOME")(change-directory (get-environment-variable "MT_RUN_AREA_HOME")))

(define (message-window msg)
  (iup:show
   (iup:dialog
    (iup:vbox 
     (iup:label msg #:margin "40x40")))))

Modified db.scm from [82609fed05] to [0253d08df7].

137
138
139
140
141
142
143
144

145
146
147
148
149
150
151
137
138
139
140
141
142
143

144
145
146
147
148
149
150
151







-
+







	(let* ((dbpath       (db:dbfile-path run-id)) ;; (conc toppath "/db/" run-id ".db"))
	       (dbexists     (file-exists? dbpath))
	       (inmem        (if local #f (db:open-inmem-db)))
	       (refdb        (if local #f (db:open-inmem-db)))
	       (db           (sqlite3:open-database dbpath))
	       (olddb        (db:open-megatest-db))
	       (write-access (file-write-access? dbpath))
	       (handler      (make-busy-timeout 136000)))
	       (handler      (make-busy-timeout 1000)))
	  (if (and dbexists (not write-access))
	      (set! *db-write-access* #f)) ;; only unset so other db's also can use this control
	  (if write-access
	      (begin
		(if (not dbexists)
		    (begin
		      (db:initialize-run-id-db db)
478
479
480
481
482
483
484



485
486
487
488
489
490
491











492
493
494
495
496
497
498
478
479
480
481
482
483
484
485
486
487







488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505







+
+
+
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+







	(debug:print-info 11 "open-run-close-no-exception-handling END" )
	res)
      #f))

(define (open-run-close-exception-handling proc idb . params)
  (handle-exceptions
   exn
   (let ((sleep-time (random 30))
	 (err-status ((condition-property-accessor 'sqlite3 'status #f) exn)))
     (case err-status
   (begin
     (debug:print 0 "EXCEPTION: database probably overloaded or unreadable.")
     (debug:print 0 "  " ((condition-property-accessor 'exn 'message) exn))
     (print-call-chain)
     (thread-sleep! (random 120))
     (debug:print-info 0 "trying db call one more time....")
     (apply open-run-close-no-exception-handling proc idb params))
       ((busy)
	(thread-sleep! sleep-time))
       (else
	(debug:print 0 "EXCEPTION: database probably overloaded or unreadable.")
	(debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))
	(print "exn=" (condition->list exn))
	(debug:print 0 " status:  " ((condition-property-accessor 'sqlite3 'status) exn))
	(print-call-chain)
	(thread-sleep! sleep-time)
	(debug:print-info 0 "trying db call one more time....this may never recover, if necessary kill process " (current-process-id) " on host " (get-host-name) " to clean up")))
     (apply open-run-close-exception-handling proc idb params))
   (apply open-run-close-no-exception-handling proc idb params)))

;; (define open-run-close 
(define open-run-close ;; (if (debug:debug-mode 2)
		;;	   open-run-close-no-exception-handling
			   open-run-close-exception-handling)
;;)
609
610
611
612
613
614
615


616
617
618
619
620
621
622
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631







+
+







	                        tol REAL,
                                units TEXT,
                                comment TEXT DEFAULT '',
                                status TEXT DEFAULT 'n/a',
                                type TEXT DEFAULT '',
                              CONSTRAINT test_data_constraint UNIQUE (test_id,category,variable));")
  (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_rundat (
	      ;; Why use FULL here? This data is not that critical
	      ;; (sqlite3:execute db "PRAGMA synchronous = FULL;")
                              id           INTEGER PRIMARY KEY,
                              test_id      INTEGER,
                              update_time  TIMESTAMP,
                              cpuload      INTEGER DEFAULT -1,
                              diskfree     INTEGER DEFAULT -1,
                              diskusage    INTGER DEFAULT -1,
                              run_duration INTEGER DEFAULT 0);")
1805
1806
1807
1808
1809
1810
1811







1812
1813
1814
1815
1816
1817
1818
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834







+
+
+
+
+
+
+







	    (db:general-call db 'top-test-set-running (list test-name))
	    (db:general-call db 'top-test-set-per-pf-counts (list test-name test-name test-name)))
	#f)
      #f))

(define (db:tests-register-test dbstruct run-id test-name item-path)
  (sqlite3:execute (db:get-db dbstruct run-id) 'register-test run-id test-name item-path))
       (let ((sleep-time (random 20))
	     (err-status ((condition-property-accessor 'sqlite3 'status #f) exn)))
	 (case err-status
	   ((busy)(thread-sleep! 4))
	   (else
	    (debug:print 0 "WARNING: possible problem with call to cdb:remote-run, database may be read-only and locked, waiting and trying again ...")
	    (thread-sleep! sleep-time)))

(define (db:test-get-logfile-info dbstruct run-id test-name)
  (let ((res #f))
    (sqlite3:for-each-row 
     (lambda (path final_logf)
       ;; (let ((path       (sdb:qry 'getstr path-id))
       ;;       (final_logf (sdb:qry 'getstr final_logf-id)))
1974
1975
1976
1977
1978
1979
1980

























1981
1982
1983
1984
1985
1986
1987
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028







+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+







				    (> (db:test-get-event_time testdat)(db:test-get-event_time stored-test))))
			   ;; this test is younger, store it in the hash
			   (hash-table-set! tests-hash full-testname testdat))))
		   results)
		  (if (null? tal)
		      (map cdr (hash-table->alist tests-hash)) ;; return a list of the most recent tests
		      (loop (car tal)(cdr tal))))))))))
			   (let* ((remtries 10)
				  (proc     #f))
			     (set! proc (lambda (remtries)
					  (if (> remtries 0)
					      (handle-exceptions
					       exn
					       (let ((sleep-time (random 30))
						     (err-status ((condition-property-accessor 'sqlite3 'status #f) exn)))
						 (case err-status
						   ((busy)
						    (thread-sleep! sleep-time)
						    (proc 10)) ;; we never give up on busy
						   (else
						    (debug:print 0 "EXCEPTION: database probably overloaded or unreadable.")
						    (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))
						    (debug:print 0 " status:  " ((condition-property-accessor 'sqlite3 'status)  exn))
						    (print-call-chain)
						    (debug:print 0 "Sleeping for " sleep-time)
						    (thread-sleep! sleep-time)
						    (debug:print-info 0 "trying db call one more time....this may never recover, if necessary kill process " (current-process-id) " on host " (get-host-name) " to clean up")
						    (proc (- remtries 1)))))
					       (apply sqlite3:execute db query params))
					      (debug:print 0 "ERROR: too many attempts to access db were made and no sucess. query: "
							   query ", params: " params))))
			     (proc remtries))

(define (db:test-get-records-for-index-file dbstruct run-id test-name)
  (let ((res '()))
    (sqlite3:for-each-row 
     (lambda (id itempath state status run_duration logf-id comment-id)
       (let ((logf    (db:get-string dbstruct logf-id))
	     (comment (db:get-string dbstruct comment-id)))

Modified launch.scm from [59d0d6772c] to [108aa8951e].

142
143
144
145
146
147
148
149

150
151
152
153
154
155
156
142
143
144
145
146
147
148

149
150
151
152
153
154
155
156







-
+







	  (set-run-config-vars run-id keyvals target) ;; (db:get-target db run-id))
	  ;; environment overrides are done *before* the remaining critical envars.
	  (alist->env-vars env-ovrd)
	  (set-megatest-env-vars run-id inkeys: keys inkeyvals: keyvals)
	  (set-item-env-vars itemdat)
	  (save-environment-as-files "megatest")
	  ;; open-run-close not needed for test-set-meta-info
	  (tests:set-full-meta-info test-id run-id 0 work-area)
	  (tests:set-full-meta-info #f test-id run-id 0 work-area 10)

	  ;; (tests:test-set-status! test-id "REMOTEHOSTSTART" "n/a" (args:get-arg "-m") #f)
	  (tests:test-force-state-status! run-id test-id "REMOTEHOSTSTART" "n/a")
	  (thread-sleep! 0.3) ;; NFS slowness has caused grief here

	  (if (args:get-arg "-xterm")
	      (set! fullrunscript "xterm")
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
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







-
+











+
+
-
+
+









+
+
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+


-
-
+
+







					(calc-minutes  (lambda ()
							 (inexact->exact 
							  (round 
							   (- 
							    (current-seconds) 
							    start-seconds)))))
					(kill-tries 0))
				   (tests:set-full-meta-info test-id run-id (calc-minutes) work-area)
				   (tests:set-full-meta-info #f test-id run-id (calc-minutes) work-area 10)
				   (let loop ((minutes   (calc-minutes)))
				     (begin
				       (set! kill-job? (or (test-get-kill-request run-id test-id) ;; run-id test-name itemdat))
							   (and runtlim (let* ((run-seconds   (- (current-seconds) start-seconds))
									       (time-exceeded (> run-seconds runtlim)))
									  (if time-exceeded
									      (begin
										(debug:print-info 0 "KILLING TEST DUE TO TIME LIMIT EXCEEDED! Runtime=" run-seconds " seconds, limit=" runtlim)
										#t)
									      #f)))))
				       ;; open-run-close not needed for test-set-meta-info
				       (print "ERROR: EDIT ME")
				       (exit 1)
				       (tests:update-central-meta-info run-id test-id (get-cpu-load) (get-df (current-directory))(calc-minutes) #f #f)
				       ;;(tests:update-central-meta-info run-id test-id (get-cpu-load) (get-df (current-directory))(calc-minutes) #f #f)
				       ;;(tests:set-partial-meta-info #f test-id run-id minutes work-area 10)
				       ;; (tests:set-partial-meta-info test-id run-id minutes work-area)
				       (if kill-job? 
					   (begin
					     (mutex-lock! m)
					     ;; NOTE: The pid can change as different steps are run. Do we need handshaking between this
					     ;;       section and the runit section? Or add a loop that tries three times with a 1/4 second
					     ;;       between tries?
					     (let* ((pid (vector-ref exit-info 0)))
					       (if (number? pid)
						   (handle-exceptions
						    exn
						    (debug:print-info 0 "Unable to kill process with pid " pid ", possibly already killed.")
						   (process-signal pid signal/kill)
						   ;; (begin
						   ;;   (debug:print 0 "WARNING: Request received to kill job (attempt # " kill-tries ")")
						   ;;   (let ((processes (cmd-run->list (conc "pgrep -l -P " pid))))
						   ;;     (for-each 
						   ;;      (lambda (p)
						   ;;        (let* ((parts  (string-split p))
						   ;;      	 (p-id   (if (> (length parts) 0)
						   ;;      		     (string->number (car parts))
						   ;;      		     #f)))
						   ;;          (if p-id
						   ;;      	(begin
						   ;;      	  (debug:print 0 "Killing " (cadr parts) "; kill -9  " p-id)
						   ;;      	  (system (conc "kill -9 " p-id))))))
						   ;;      (car processes))
						   ;;     (system (conc "kill -9 -" pid))))
						    ;;(process-signal pid signal/kill))
						    (begin
						      (debug:print 0 "WARNING: Request received to kill job (attempt # " kill-tries ")")
						      (let ((processes (cmd-run->list (conc "pgrep -l -P " pid))))
							(for-each 
							 (lambda (p)
							   (let* ((parts  (string-split p))
								  (p-id   (if (> (length parts) 0)
									      (string->number (car parts))
									      #f)))
							     (if p-id
								 (begin
								   (debug:print 0 "Killing " (cadr parts) "; kill -9  " p-id)
								   ;; (process-signal pid signal/kill))))) ;; 
								   (system (conc "kill -9 " p-id))))))
							 (car processes)))
						      (system (conc "kill -9 -" pid))
						      (tests:test-set-status! test-id "KILLED"  "FAIL" (args:get-arg "-m") #f)))
						   (begin
						     (debug:print 0 "WARNING: Request received to kill job but problem with process, attempting to kill manager process")
						     (tests:test-set-status! run-id test-id "KILLED"  "FAIL"
								     (args:get-arg "-m") #f)
						     ;;(tests:test-set-status! run-id test-id "KILLED"  "FAIL"
						     (tests:test-set-status! trun-id est-id "KILLED"  "FAIL" (args:get-arg "-m") #f)
						     (exit 1) ;; IS THIS NECESSARY OR WISE???
						     )))
					     (set! kill-tries (+ 1 kill-tries))
					     (mutex-unlock! m)))
				       (if keep-going
					   (begin
					     (thread-sleep! 3) ;; (+ 3 (random 6))) ;; add some jitter to the call home time to spread out the db accesses

Modified megatest.scm from [f4ec5dd5d1] to [5f5a87a965].

455
456
457
458
459
460
461
462

463
464
465
466
467
468
469
470
471
472
473
455
456
457
458
459
460
461

462




463
464
465
466
467
468
469







-
+
-
-
-
-







		  ;; (print "[" x "]"))
		  (print x))
		targets)
      (set! *didsomething* #t)))

(define (full-runconfigs-read)
  (let* ((keys   (rmt:get-keys))
	 (target (if (args:get-arg "-reqtarg")
	 (target (common:args-get-target))
		     (args:get-arg "-reqtarg")
		     (if (args:get-arg "-target")
			 (args:get-arg "-target")
			 #f)))
	 (key-vals (if target (keys:target->keyval keys target) #f))
	 (sections (if target (list "default" target) #f))
	 (data     (begin
		     (setenv "MT_RUN_AREA_HOME" *toppath*)
		     (if key-vals
			 (for-each (lambda (kt)
				     (setenv (car kt) (cadr kt)))
519
520
521
522
523
524
525
526

527
528
529
530
531
532
533
534
515
516
517
518
519
520
521

522

523
524
525
526
527
528
529







-
+
-







;; Remove old run(s)
;;======================================================================

;; since several actions can be specified on the command line the removal
;; is done first
(define (operate-on action)
  (let* ((runrec (runs:runrec-make-record))
	 (target (or (args:get-arg "-reqtarg")
	 (target (common:args-get-target)))
		     (args:get-arg "-target"))))
    (cond
     ((not target)
      (debug:print 0 "ERROR: Missing required parameter for " action ", you must specify -target or -reqtarg")
      (exit 1))
     ((not (args:get-arg ":runname"))
      (debug:print 0 "ERROR: Missing required parameter for " action ", you must specify the run name pattern with :runname patt")
      (exit 2))
566
567
568
569
570
571
572
573
574



575
576
577
578
579
580
581
561
562
563
564
565
566
567


568
569
570
571
572
573
574
575
576
577







-
-
+
+
+








(if (or (args:get-arg "-set-run-status")
	(args:get-arg "-get-run-status"))
    (general-run-call
     "-set-run-status"
     "set run status"
     (lambda (target runname keys keyvals)
       (let* ((runsdat  (cdb:remote-run db:get-runs-by-patt #f keys runname (or (args:get-arg "-target")
									       (args:get-arg "-reqtarg")) #f #f))
       (let* ((runsdat  (cdb:remote-run db:get-runs-by-patt #f keys runname 
					(common:args-get-target)
					#f #f))
	      (header   (vector-ref runsdat 0))
	      (rows     (vector-ref runsdat 1)))
	 (if (null? rows)
	     (begin
	       (debug:print-info 0 "No matching run found.")
	       (exit 1))
	     (let* ((row      (car (vector-ref runsdat 1)))
597
598
599
600
601
602
603
604
605


606
607
608
609
610
611
612
593
594
595
596
597
598
599


600
601
602
603
604
605
606
607
608







-
-
+
+







	(let* ((dbstruct (make-dbr:dbstruct path: *toppath* local: #t))
	       (runpatt  (args:get-arg "-list-runs"))
	       (testpatt (if (args:get-arg "-testpatt") 
			     (args:get-arg "-testpatt") 
			     "%"))
	       (keys     (db:get-keys dbstruct))
	       ;; (runsdat  (db:get-runs dbstruct runpatt #f #f '()))
	       (runsdat  (db:get-runs-by-patt dbstruct keys runpatt (or (args:get-arg "-target")
									(args:get-arg "-reqtarg")) #f #f))
	       (runsdat  (db:get-runs-by-patt dbstruct keys runpatt (or (a(common:args:get-target)) ;;  rgs:get-arg "-target")
					 #f #f))
		;; (cdb:remote-run db:get-runs #f runpatt #f #f '()))
	       (runs     (db:get-rows runsdat))
	       (header   (db:get-header runsdat))
	       (db-targets (args:get-arg "-list-db-targets"))
	       (seen     (make-hash-table)))
	  ;; Each run
	  (for-each 
989
990
991
992
993
994
995
996




997
998
999
1000
1001
1002
1003
985
986
987
988
989
990
991

992
993
994
995
996
997
998
999
1000
1001
1002







-
+
+
+
+







		    (exit 6))
		  (let* ((stepname   (args:get-arg "-runstep"))
			 (logprofile (args:get-arg "-logpro"))
			 (logfile    (conc stepname ".log"))
			 (cmd        (if (null? remargs) #f (car remargs)))
			 (params     (if cmd (cdr remargs) '()))
			 (exitstat   #f)
			 (shell      (last (string-split (get-environment-variable "SHELL") "/")))
			 (shell      (let ((sh (get-environment-variable "SHELL") ))
				       (if sh 
					   (last (string-split sh "/"))
					   "bash")))
			 (redir      (case (string->symbol shell)
				       ((tcsh csh ksh)    ">&")
				       ((zsh bash sh ash) "2>&1 >")
				       (else ">&")))
			 (fullcmd    (conc "(" (string-intersperse 
						(cons cmd params) " ")
					   ") " redir " " logfile)))

Modified runconfig.scm from [4e3a96ccb1] to [d97360c67a].

9
10
11
12
13
14
15
16

17
18
19
20
21
22
23
24
9
10
11
12
13
14
15

16

17
18
19
20
21
22
23







-
+
-







(declare (uses common))

(include "common_records.scm")

(define (setup-env-defaults fname run-id already-seen keyvals #!key (environ-patt #f)(change-env #t))
  (let* ((keys    (map car keyvals))
	 (thekey  (if keyvals (string-intersperse (map (lambda (x)(if x x "-na-")) (map cadr keyvals)) "/")
		      (or (args:get-arg "-reqtarg") 
		      (or (common:args-get-target)
			  (args:get-arg "-target")
			  (get-environment-variable "MT_TARGET")
			  (begin
			    (debug:print 0 "ERROR: setup-env-defaults called with no run-id or -target or -reqtarg")
			    "nothing matches this I hope"))))
	 ;; Why was system disallowed in the reading of the runconfigs file?
	 ;; NOTE: Should be setting env vars based on (target|default)
	 (confdat (read-config fname #f #t environ-patt: environ-patt sections: (list "default" thekey)))
58
59
60
61
62
63
64
65

66
67
68
69
70
71
72
73
74
75
76
77
57
58
59
60
61
62
63

64

65
66
67
68
69
70
71
72
73
74
75







-
+
-











	  (debug:print 2 "---")
	  (set! *already-seen-runconfig-info* #t)))
    finaldat))

(define (set-run-config-vars run-id keyvals targ-from-db)
  (push-directory *toppath*) ;; the push/pop doesn't appear to do anything ...
  (let ((runconfigf (conc  *toppath* "/runconfigs.config"))
	(targ       (or (args:get-arg "-target")
	(targ       (or (common:args-get-target)
			(args:get-arg "-reqtarg")
			targ-from-db
			(get-environment-variable "MT_TARGET"))))
    (pop-directory)
    (if (file-exists? runconfigf)
	(setup-env-defaults runconfigf run-id #t keyvals
			    environ-patt: (conc "(default"
						(if targ
						    (conc "|" targ ")")
						    ")")))
	(debug:print 0 "WARNING: You do not have a run config file: " runconfigf))))
 

Modified runs.scm from [88c42814b9] to [c22e67eca1].

41
42
43
44
45
46
47
48

49
50
51
52
53
54
55
56
41
42
43
44
45
46
47

48

49
50
51
52
53
54
55







-
+
-







		           *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")
	  (target      (common:args-get-target))
		           (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*)
88
89
90
91
92
93
94
95

96
97
98
99
100
101
102
103
87
88
89
90
91
92
93

94

95
96
97
98
99
100
101







-
+
-







			    (set! envdat (append envdat (list varval)))
			    (safe-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)(inkeyvals #f))
  (let* ((target      (or (args:get-arg "-reqtarg")
  (let* ((target      (or (common:args-get-target)
			  (args:get-arg "-target")
			  (get-environment-variable "MT_TARGET")))
	 (keys    (if inkeys    inkeys    (rmt:get-keys)))
	 (keyvals (if inkeyvals inkeyvals (keys:target->keyval keys target)))
	 (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)))
201
202
203
204
205
206
207
208
209
210
211
212


213
214
215
216
217
218
219
199
200
201
202
203
204
205

206
207
208

209
210
211
212
213
214
215
216
217







-



-
+
+







;;            
(define (runs:run-tests target runname test-patts user flags) ;; test-names
  (let* ((keys               (keys:config-get-fields *configdat*))
	 (keyvals            (keys:target->keyval keys target))
	 (run-id             (rmt:register-run keyvals runname "new" "n/a" user))  ;;  test-name)))
	 (deferred          '()) ;; delay running these since they have a waiton clause
	 (runconfigf         (conc  *toppath* "/runconfigs.config"))
	 (required-tests    '())
	 (test-records       (make-hash-table))
	 (all-tests-registry (tests:get-all)) ;; (tests:get-valid-tests (make-hash-table) test-search-path)) ;; all valid tests to check waiton names
	 (all-test-names     (hash-table-keys all-tests-registry))
	 (test-names         (tests:filter-test-names all-test-names test-patts)))
	 (test-names         (tests:filter-test-names all-test-names test-patts))
	 (required-tests     test-names))

    (set-megatest-env-vars run-id inkeys: keys inrunname: runname) ;; these may be needed by the launching process
    (if (file-exists? runconfigf)
	(setup-env-defaults runconfigf run-id *already-seen-runconfig-info* 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
395
396
397
398
399
400
401

402
403


404
405
406
407
408
409
410
393
394
395
396
397
398
399
400


401
402
403
404
405
406
407
408
409







+
-
-
+
+







		      "\n items:           " items
		      "\n can-run-more:    " can-run-more)

    (cond
     ;; all prereqs met, fire off the test
     ;; or, if it is a 'toplevel test and all prereqs not met are COMPLETED then launch

     ((and (not (member 'toplevel testmode))
     ((member (hash-table-ref/default test-registry (runs:make-full-test-name hed item-path) 'n/a)
	      '(DONOTRUN removed)) ;; *common:cant-run-states-sym*) ;; '(COMPLETED KILLED WAIVED UNKNOWN INCOMPLETE)) ;; try to catch repeat processing of COMPLETED tests here
	   (member (hash-table-ref/default test-registry (runs:make-full-test-name hed item-path) 'n/a)
		   '(DONOTRUN removed CANNOTRUN))) ;; *common:cant-run-states-sym*) ;; '(COMPLETED KILLED WAIVED UNKNOWN INCOMPLETE)) ;; try to catch repeat processing of COMPLETED tests here
      (debug:print-info 1 "Test " hed " set to \"" (hash-table-ref test-registry (runs:make-full-test-name hed item-path)) "\". Removing it from the queue")
      (if (or (not (null? tal))
	      (not (null? reg)))
	  (list (runs:queue-next-hed tal reg reglen regfull)
		(runs:queue-next-tal tal reg reglen regfull)
		(runs:queue-next-reg tal reg reglen regfull)
		reruns)
450
451
452
453
454
455
456


457
458
459
460





461
462
463
464
465
466
467
468

469
470
471
472
473
474
475
449
450
451
452
453
454
455
456
457




458
459
460
461
462
463
464
465
466
467
468
469

470
471
472
473
474
475
476
477







+
+
-
-
-
-
+
+
+
+
+







-
+







             ;; (notinqueue (filter (lambda (x)
             ;;    		   (not (member x allinqueue)))
             ;;    		 prereqstrs))
	     (give-up    #f))

	;; We can get here when a prereq has not been run due to *it* having a prereq that failed.
	;; We need to use this to dequeue this item as CANNOTRUN
	;; 
	(if (member testmode '(toplevel))
	(for-each (lambda (prereq)
		    (if (eq? (hash-table-ref/default test-registry prereq 'justfine) 'CANNOTRUN)
			(set! give-up #t)))
		  prereqstrs)
	    (for-each (lambda (prereq)
			(if (eq? (hash-table-ref/default test-registry prereq 'justfine) 'CANNOTRUN)
			    (set! give-up #t)))
		      prereqstrs))

	(if (and give-up
		 (not (and (null? tal)(null? reg))))
	    (let ((trimmed-tal (mt:discard-blocked-tests run-id hed tal test-records))
		  (trimmed-reg (mt:discard-blocked-tests run-id hed reg test-records)))
	      (debug:print 1 "WARNING: test " hed " has discarded prerequisites, removing it from the queue")

	      (let ((test-id (rmt:get-test-id run-id hed "")))
		(mt:test-set-state-status-by-id test-id "DEQUED" "PREQ_FAIL" "Failed to run due to failed prerequisites"))
		(mt:test-set-state-status-by-id test-id "DEQUEUED" "PREQ_FAIL" "Failed to run due to failed prerequisites"))
	      
	      (if (and (null? trimmed-tal)
		       (null? trimmed-reg))
		  #f
		  (list (runs:queue-next-hed trimmed-tal trimmed-reg reglen regfull)
			(runs:queue-next-tal trimmed-tal trimmed-reg reglen regfull)
			(runs:queue-next-reg trimmed-tal trimmed-reg reglen regfull)
1384
1385
1386
1387
1388
1389
1390
1391

1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404

1405
1406
1407
1408
1409
1410
1411
1412
1413
1386
1387
1388
1389
1390
1391
1392

1393



1394
1395
1396
1397
1398
1399
1400
1401
1402

1403


1404
1405
1406
1407
1408
1409
1410







-
+
-
-
-









-
+
-
-







;; Routines for manipulating runs
;;======================================================================

;; 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")
	(target  (common:args-get-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)
	    (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")
	;;     (cdb:remote-run server:start db (args:get-arg "-server")))
	(set! keys (keys:config-get-fields *configdat*))

Modified tests.scm from [6b6e58b833] to [2b62908fb8].

66
67
68
69
70
71
72
73
74


75
76
77
78
79
80
81
66
67
68
69
70
71
72


73
74
75
76
77
78
79
80
81







-
-
+
+








;; tests:glob-like-match
(define (tests:glob-like-match patt str) 
  (let ((like (substring-index "%" patt)))
    (let* ((notpatt  (equal? (substring-index "~" patt) 0))
	   (newpatt  (if notpatt (substring patt 1) patt))
	   (finpatt  (if like
			(string-substitute (regexp "%") ".*" newpatt)
			(string-substitute (regexp "\\*") ".*" newpatt)))
			(string-substitute (regexp "%") ".*" newpatt #f)
			(string-substitute (regexp "\\*") ".*" newpatt #f)))
	   (res      #f))
      ;; (print "tests:glob-like-match => notpatt: " notpatt ", newpatt: " newpatt ", finpatt: " finpatt)
      (set! res (string-match (regexp finpatt (if like #t #f)) str))
      (if notpatt (not res) res))))

;; if itempath is #f then look only at the testname part
;;
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
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







+
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+











  (rmt:general-call 'update-cpuload-diskfree run-id cpuload diskfree test-id)
  (if minutes 
      (rmt:general-call 'update-run-duration run-id minutes test-id))
  (if (and uname hostname)
      (rmt:general-call 'update-uname-host run-id uname hostname test-id)))
  
;; This one is for running with no db access (i.e. via rmt: internally)
(define (tests:set-full-meta-info db test-id run-id minutes work-area remtries)
(define (tests:set-full-meta-info test-id run-id minutes work-area)
  (let* ((num-records 0)
	 (cpuload  (get-cpu-load))
	 (diskfree (get-df (current-directory)))
	 (uname    (get-uname "-srvpio"))
	 (hostname (get-host-name)))
    (tdb:remote-update-testdat-meta-info run-id test-id work-area cpuload diskfree minutes)
    (tests:update-central-meta-info run-id test-id cpuload diskfree minutes uname hostname)))
	  
(define (tests:set-partial-meta-info test-id run-id minutes work-area)
;; (define (tests:set-full-meta-info test-id run-id minutes work-area)
  (let ((remtries 10))
    (handle-exceptions
     exn
     (if (> remtries 0)
	 (begin
	   (set! remtries (- remtries 1))
	   (thread-sleep! 10)
	   (tests:set-full-meta-info db test-id run-id minutes work-area (- remtries 1)))
	 (let ((err-status ((condition-property-accessor 'sqlite3 'status #f) exn)))
	   (debug:print 0 "ERROR: tried for over a minute to update meta info and failed. Giving up")
	   (debug:print 0 "EXCEPTION: database probably overloaded or unreadable.")
	   (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))
	   (print "exn=" (condition->list exn))
	   (debug:print 0 " status:  " ((condition-property-accessor 'sqlite3 'status) exn))
	   (print-call-chain)))
     (let* ((num-records 0) ;; (test:tdb-get-rundat-count tdb))
	    (cpuload  (get-cpu-load))
	    (diskfree (get-df (current-directory)))
	    (uname    (get-uname "-srvpio"))
	    (hostname (get-host-name)))
       ;; (tests:update-testdat-meta-info drun-id test-id work-area cpuload diskfree minutes)
       (tests:update-central-meta-info trun-id test-id cpuload diskfree minutes uname hostname)))))
    
(define (tests:set-partial-meta-info dest-id run-id minutes work-area remtries)
;; (define (tests:set-partial-meta-info test-id run-id minutes work-area)
  (let* ((cpuload  (get-cpu-load))
	 (diskfree (get-df (current-directory))))
    (tdb:remote-update-testdat-meta-info run-id test-id work-area cpuload diskfree minutes)))
	 (diskfree (get-df (current-directory)))
	 (remtries 10))
    (handle-exceptions
     exn
     (if (> remtries 0)
	 (begin
	   (set! remtries (- remtries 1))
	   (thread-sleep! 10)
	   (tests:set-full-meta-info db test-id run-id minutes work-area (- remtries 1)))
	 (let ((err-status ((condition-property-accessor 'sqlite3 'status #f) exn)))
	   (debug:print 0 "ERROR: tried for over a minute to update meta info and failed. Giving up")
	   (debug:print 0 "EXCEPTION: database probably overloaded or unreadable.")
	   (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))
	   (print "exn=" (condition->list exn))
	   (debug:print 0 " status:  " ((condition-property-accessor 'sqlite3 'status) exn))
	   (print-call-chain)))
	 
;;======================================================================
;; A R C H I V I N G
;;======================================================================

(define (test:archive db test-id)
  #f)

(define (test:archive-tests db keynames target)
  #f)

Modified tests/Makefile from [6a1442238d] to [6898a8bdcb].

58
59
60
61
62
63
64



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







+
+
+







	@echo Run all_toplevel and all waitons
	cd fullrun;$(MEGATEST) -runtests all_toplevel -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_c

test4 : cleanprep
	@echo "WARNING: No longer running fullprep, test converage may be lessened"
	cd fullrun;time $(MEGATEST) -debug $(DEBUG) -runtests % -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_b -m "This is a comment specific to a run" -v $(LOGGING)

test4a : cleanprep
	cd fullrun;time $(MEGATEST) -debug $(DEBUG) -runtests all_toplevel -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_b -m "This is a comment specific to a run" -v $(LOGGING)

# NOTE: Only one instance can be a server
test5 : cleanprep
	@echo "WARNING: No longer running fullprep, test converage may be lessened"
	cd fullrun;sleep 0;$(MEGATEST) -runtests % -target $(TARGET) :runname $(RUNNAME)_aa -debug $(DEBUG) $(LOGGING) > aa.log 2> aa.log &
	cd fullrun;sleep 3;$(MEGATEST) -runtests % -target $(TARGET) :runname $(RUNNAME)_ab -debug $(DEBUG) $(LOGGING) > ab.log 2> ab.log &
	cd fullrun;sleep 6;$(MEGATEST) -runtests % -target $(TARGET) :runname $(RUNNAME)_ac -debug $(DEBUG) $(LOGGING) > ac.log 2> ac.log &
	cd fullrun;sleep 9;$(MEGATEST) -runtests % -target $(TARGET) :runname $(RUNNAME)_ad -debug $(DEBUG) $(LOGGING) > ad.log 2> ad.log &	

Modified tests/tests.scm from [a780d57ffe] to [ceeda9f906].

29
30
31
32
33
34
35




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







+
+
+
+

(define *runremote* #f)

(let* ((unit-test-name (list-ref (argv) 4))
       (fname          (conc "../unittests/" unit-test-name ".scm")))
  (if (file-exists? fname)
      (load fname)
      (print "ERROR: Unit test " unit-test-name " not found in unittests directory")))
 (list "abc" "abc/%" "ab%/c%" "~abc/c%" "abc/~c%" "a,b/c,%/d" "%/,%/a" "%/,%/a" "%/,%/a" "%" "%" "%/" "%/" "%abc%")
 (list "abc" "abc"   "abcd"   "abc"     "abc"     "a"         "abc"     "def"    "ghi"   "a" "a"  "a"  "a" "abc")
 (list   ""  ""      "cde"    "cde"     "cde"     ""            ""      "a"       "b"    ""  "b"  ""   "b" "abc")
 (list   #t    #t       #t    #f           #f      #t           #t       #t       #f     #t  #t   #t    #f #t))