Megatest

Check-in [dec6d535be]
Login
Overview
Comment:Fixed running dependent tests problem
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | v1.54
Files: files | file ages | folders
SHA1: dec6d535be7eb389afb61de185370fc39ba8b8e4
User & Date: mrwellan on 2013-05-06 14:28:02
Other Links: branch diff | manifest | tags
Context
2013-05-06
15:37
Bumped version to v1.5422 check-in: 1037acdf73 user: mrwellan tags: v1.54, v1.5422
14:28
Fixed running dependent tests problem check-in: dec6d535be user: mrwellan tags: v1.54
2013-05-05
00:43
Added MT_RUN_AREA_HOME for -show-runconfigs check-in: 2d38067787 user: matt tags: v1.54, v1.5421
Changes

Modified megatest.scm from [e8e5a17f3e] to [4db82708a1].

30
31
32
33
34
35
36
37

38
39

40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58

59
60
61
62
63
64
65
66
67

68
69
70
71
72
73
74
30
31
32
33
34
35
36

37


38



















39









40
41
42
43
44
45
46
47







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







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

(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "megatest-fossil-hash.scm")

;; (use trace dot-locking)
(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.megatestrc")))
;;  (trace
;;   tests:match
  (if (file-exists? debugcontrolf)
;;   runs:run-tests)
;;  db:teststep-set-status!
;;  db:open-test-db-by-test-id
;;  db:test-get-rundir-from-test-id
;;  cdb:tests-register-test
;;  cdb:tests-update-uname-host
;;  cdb:tests-update-run-duration
;;  ;;  cdb:client-call
;;  ;; cdb:remote-run
;; )
;;  cdb:test-set-status-state
;;  change-directory
;;  db:process-queue-item
;;  db:test-get-logfile-info
;;  db:teststep-set-status!
;;  nice-path
;;  obtain-dot-lock
;;  open-run-close
;;  read-config
      (load debugcontrolf)))
;;  runs:can-run-more-tests
;;  sqlite3:execute
;;  sqlite3:for-each-row
;;  tests:check-waiver-eligibility
;;  tests:summarize-items
;;  tests:test-set-status!
;;  thread-sleep!
;;)
       


(define help (conc "
Megatest, documentation at http://www.kiatoa.com/fossils/megatest
  version " megatest-version "
  license GPL, Copyright Matt Welland 2006-2012

Usage: megatest [options]
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
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








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

+
+
+







    (let ((targets (common:get-runconfig-targets)))
      (print "Found "(length targets) " targets")
      (for-each (lambda (x)
		  ;; (print "[" x "]"))
		  (print x))
		targets)
      (set! *didsomething* #t)))

(if (args:get-arg "-show-runconfig")
    (let* ((keys   (cdb:remote-run get-keys #f))
	   (target (if (args:get-arg "-reqtarg")
		       (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)))
				     key-vals))
		       (read-config "runconfigs.config" #f #t sections: sections))))
(define (full-runconfigs-read)
  (let* ((keys   (cdb:remote-run get-keys #f))
	 (target (if (args:get-arg "-reqtarg")
		     (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)))
				   key-vals))
		     (read-config "runconfigs.config" #f #t sections: sections))))
    data))


(if (args:get-arg "-show-runconfig")
    (let ((data (full-runconfigs-read)))
      ;; keep this one local
      (cond
       ((not (args:get-arg "-dumpmode"))
	(pp (hash-table->alist data)))
       ((string=? (args:get-arg "-dumpmode") "json")
	(json-write data))
       (else

Modified run-tests-queue-classic.scm from [7273016cde] to [5b3ba61f62].

1
2
3

4
5
6
7
8
9
10
1
2

3
4
5
6
7
8
9
10


-
+








;; test-records is a hash table testname:item_path => vector < testname testconfig waitons priority items-info ... >
(define (runs:run-tests-queue-classic run-id runname test-records keyvallst flags test-patts)
(define (runs:run-tests-queue-classic run-id runname test-records keyvallst flags test-patts required-tests)
    ;; At this point the list of parent tests is expanded 
    ;; NB// Should expand items here and then insert into the run queue.
  (debug:print 5 "test-records: " test-records ", keyvallst: " keyvallst " flags: " (hash-table->alist flags))
  (let ((run-info              (cdb:remote-run db:get-run-info #f run-id))
	(key-vals              (cdb:remote-run db:get-key-vals #f run-id))
	(sorted-test-names     (tests:sort-by-priority-and-waiton test-records))
	(test-registry         (make-hash-table))
50
51
52
53
54
55
56
57

58
59

60
61
62
63
64
65
66
50
51
52
53
54
55
56

57
58

59
60
61
62
63
64
65
66







-
+

-
+







	    (if (member test-name waitons)
		(begin
		  (debug:print 0 "ERROR: test " test-name " has listed itself as a waiton, please correct this!")
		  (set! waiton (filter (lambda (x)(not (equal? x hed))) waitons))))

	    (cond ;; OUTER COND
	     ((not items) ;; when false the test is ok to be handed off to launch (but not before)
	      (if (and (not (tests:match test-patts (tests:testqueue-get-testname test-record) item-path))
	      (if (and (not (tests:match test-patts (tests:testqueue-get-testname test-record) item-path required: required-tests))
	               (not (null? tal)))
	          (loop (car tal)(cdr tal) reruns))
	          (loop (car newtal)(cdr newtal) reruns))
	      (let* ((run-limits-info         (runs:can-run-more-tests test-record max-concurrent-jobs)) ;; look at the test jobgroup and tot jobs running
		     (have-resources          (car run-limits-info))
		     (num-running             (list-ref run-limits-info 1))
		     (num-running-in-jobgroup (list-ref run-limits-info 2))
		     (max-concurrent-jobs     (list-ref run-limits-info 3))
		     (job-group-limit         (list-ref run-limits-info 4))
		     (prereqs-not-met         (db:get-prereqs-not-met run-id waitons item-path mode: testmode))
76
77
78
79
80
81
82
83

84
85
86
87
88
89
90
76
77
78
79
80
81
82

83
84
85
86
87
88
89
90







-
+







		(debug:print-info 4 "hed=" hed "\n  test-record=" test-record "\n  test-name: " test-name "\n  item-path: " item-path "\n  test-patts: " test-patts)

		;; Don't know at this time if the test have been launched at some time in the past
		;; i.e. is this a re-launch?
		(debug:print-info 4 "run-limits-info = " run-limits-info)
		(cond ;; INNER COND #1 for a launchable test
		 ;; Check item path against item-patts
		 ((not (tests:match test-patts (tests:testqueue-get-testname test-record) item-path)) ;; This test/itempath is not to be run
		 ((not (tests:match test-patts (tests:testqueue-get-testname test-record) item-path required: required-tests)) ;; This test/itempath is not to be run
		  ;; else the run is stuck, temporarily or permanently
		  ;; but should check if it is due to lack of resources vs. prerequisites
		  (debug:print-info 1 "Skipping " (tests:testqueue-get-testname test-record) " " item-path " as it doesn't match " test-patts)
		  ;; (thread-sleep! *global-delta*)
		  (if (not (null? tal))
		      (loop (car tal)(cdr tal) reruns)))
		 ;; Registry has been started for this test but has not yet completed
176
177
178
179
180
181
182
183

184
185
186
187
188
189
190
176
177
178
179
180
181
182

183
184
185
186
187
188
189
190







-
+







		  (pp items))
	      (for-each
	       (lambda (my-itemdat)
		 (let* ((new-test-record (let ((newrec (make-tests:testqueue)))
					   (vector-copy! test-record newrec)
					   newrec))
			(my-item-path (item-list->path my-itemdat)))
		   (if (tests:match test-patts hed my-item-path) ;; (patt-list-match my-item-path item-patts)           ;; yes, we want to process this item, NOTE: Should not need this check here!
		   (if (tests:match test-patts hed my-item-path required: required-tests) ;; (patt-list-match my-item-path item-patts)           ;; yes, we want to process this item, NOTE: Should not need this check here!
		       (let ((newtestname (runs:make-full-test-name hed my-item-path)))    ;; test names are unique on testname/item-path
			 (tests:testqueue-set-items!     new-test-record #f)
			 (tests:testqueue-set-itemdat!   new-test-record my-itemdat)
			 (tests:testqueue-set-item_path! new-test-record my-item-path)
			 (hash-table-set! test-records newtestname new-test-record)
			 (set! tal (cons newtestname tal)))))) ;; since these are itemized create new test names testname/itempath
	       items)

Modified run-tests-queue-new.scm from [d3f73ecf45] to [1ba5251696].

1
2
3

4
5
6
7
8
9
10
1
2

3
4
5
6
7
8
9
10


-
+








;; test-records is a hash table testname:item_path => vector < testname testconfig waitons priority items-info ... >
(define (runs:run-tests-queue-new run-id runname test-records keyvallst flags test-patts reglen)
(define (runs:run-tests-queue-new run-id runname test-records keyvallst flags test-patts required-tests reglen)
  ;; At this point the list of parent tests is expanded 
  ;; NB// Should expand items here and then insert into the run queue.
  (debug:print 5 "test-records: " test-records ", keyvallst: " keyvallst " flags: " (hash-table->alist flags))
  (let ((run-info              (cdb:remote-run db:get-run-info #f run-id))
	(key-vals              (cdb:remote-run db:get-key-vals #f run-id))
	(sorted-test-names     (tests:sort-by-priority-and-waiton test-records))
	(test-registry         (make-hash-table))

Modified runs.scm from [67d716378c] to [b605c5e7c5].

163
164
165
166
167
168
169
170


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

170
171
172
173
174
175
176
177
178







-
+
+







	 (run-id      (cdb:remote-run db:register-run #f keys keyvallst runname "new" "n/a" user))  ;;  test-name)))
	 (keyvals     (if run-id (cdb:remote-run db:get-key-vals #f run-id) #f))
	 (deferred    '()) ;; delay running these since they have a waiton clause
	 ;; keepgoing is the defacto modality now, will add hit-n-run a bit later
	 ;; (keepgoing   (hash-table-ref/default flags "-keepgoing" #f))
	 (runconfigf   (conc  *toppath* "/runconfigs.config"))
	 (required-tests '())
	 (test-records (make-hash-table)))
	 (test-records (make-hash-table))
     (all-test-names (tests:get-valid-tests *toppath* "%"))) ;; we need a list of all valid tests to check waiton names)

    (set-megatest-env-vars run-id inkeys: keys) ;; these may be needed by the launching process

    (if (file-exists? runconfigf)
	(setup-env-defaults runconfigf run-id *already-seen-runconfig-info* keys keyvals "pre-launch-env-vars")
	(debug:print 0 "WARNING: You do not have a run config file: " runconfigf))
    
205
206
207
208
209
210
211

212
213
214
215
216
217
218
219
220
















221
222
223
224
225
226
227
206
207
208
209
210
211
212
213









214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236







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







		 (waitons (let ((instr (if config 
					   (config-lookup config "requirements" "waiton")
					   (begin ;; No config means this is a non-existant test
					     (debug:print 0 "ERROR: non-existent required test \"" hed "\"")
					     (if db (sqlite3:finalize! db))
					     (exit 1)))))
			    (debug:print-info 8 "waitons string is " instr)
			    (let ((newwaitons
			    (string-split (cond
					   ((procedure? instr)
					    (let ((res (instr)))
					      (debug:print-info 8 "waiton procedure results in string " res " for test " hed)
					      res))
					   ((string? instr)     instr)
					   (else 
					    ;; NOTE: This is actually the case of *no* waitons! ;; (debug:print 0 "ERROR: something went wrong in processing waitons for test " hed)
					    ""))))))
				   (string-split (cond
						  ((procedure? instr)
						   (let ((res (instr)))
						     (debug:print-info 8 "waiton procedure results in string " res " for test " hed)
						     res))
						  ((string? instr)     instr)
						  (else 
						   ;; NOTE: This is actually the case of *no* waitons! ;; (debug:print 0 "ERROR: something went wrong in processing waitons for test " hed)
						   "")))))
			      (filter (lambda (x)
					(if (member x all-test-names)
					    #t
					    (begin
					      (debug:print 0 "ERROR: test " hed " has unrecognised waiton testname " x)
					      #f)))
				      newwaitons)))))
	    (debug:print-info 8 "waitons: " waitons)
	    ;; check for hed in waitons => this would be circular, remove it and issue an
	    ;; error
	    (if (member hed waitons)
		(begin
		  (debug:print 0 "ERROR: test " hed " has listed itself as a waiton, please correct this!")
		  (set! waitons (filter (lambda (x)(not (equal? x hed))) waitons))))
273
274
275
276
277
278
279
280
281


282
283
284
285
286
287
288
282
283
284
285
286
287
288


289
290
291
292
293
294
295
296
297







-
-
+
+








    (if (not (null? required-tests))
	(debug:print-info 1 "Adding " required-tests " to the run queue"))
    ;; NOTE: these are all parent tests, items are not expanded yet.
    (debug:print-info 4 "test-records=" (hash-table->alist test-records))
    (let ((reglen (any->number  (configf:lookup *configdat* "setup" "runqueue"))))
      (if reglen
	  (runs:run-tests-queue-new run-id runname test-records keyvallst flags test-patts reglen)
	  (runs:run-tests-queue-classic run-id runname test-records keyvallst flags test-patts)))
	  (runs:run-tests-queue-new     run-id runname test-records keyvallst flags test-patts required-tests reglen)
	  (runs:run-tests-queue-classic run-id runname test-records keyvallst flags test-patts required-tests)))
    (debug:print-info 4 "All done by here")))

(define (runs:calc-fails prereqs-not-met)
  (filter (lambda (test)
	    (and (vector? test) ;; not (string? test))
		 (equal? (db:test-get-state test) "COMPLETED")
		 (not (member (db:test-get-status test)
625
626
627
628
629
630
631
632

633
634
635
636
637
638
639
634
635
636
637
638
639
640

641
642
643
644
645
646
647
648







-
+







 	    ;;     	 (args:get-arg "-runtests")))
	    ;;     (client:setup) ;; This is a duplicate startup!!!??? BUG?
	    ;;     ))
	(set! keys (open-run-close db:get-keys db))
	;; have enough to process -target or -reqtarg here
	(if (args:get-arg "-reqtarg")
	    (let* ((runconfigf (conc  *toppath* "/runconfigs.config")) ;; DO NOT EVALUATE ALL 
		   (runconfig  (read-config runconfigf #f #t environ-patt: #f))) 
		   (runconfig  (read-config runconfigf #f #t environ-patt: #f)))
	      (if (hash-table-ref/default runconfig (args:get-arg "-reqtarg") #f)
		  (keys:target-set-args keys (args:get-arg "-reqtarg") args:arg-hash)
		  (begin
		    (debug:print 0 "ERROR: [" (args:get-arg "-reqtarg") "] not found in " runconfigf)
		    (if db (sqlite3:finalize! db))
		    (exit 1))))
	    (if (args:get-arg "-target")

Modified tests.scm from [02eaa01dcc] to [c40619bb57].

49
50
51
52
53
54
55
56

57
58

59
60
61
62
63
64
65
49
50
51
52
53
54
55

56
57

58
59
60
61
62
63
64
65







-
+

-
+







	   (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
;;
(define (tests:match patterns testname itempath)
(define (tests:match patterns testname itempath #!key (required '()))
  (if (string? patterns)
      (let ((patts (string-split patterns ",")))
      (let ((patts (append (string-split patterns ",") required)))
	(if (null? patts) ;;; no pattern(s) means no match
	    #f
	    (let loop ((patt (car patts))
		       (tal  (cdr patts)))
	      ;; (print "loop: patt: " patt ", tal " tal)
	      (if (string=? patt "")
		  #f ;; nothing ever matches empty string - policy