Megatest

Check-in [aaf7a45583]
Login
Overview
Comment:Start of dot generation and alt simplified -run vs. -runtests/-runall/-itempatt
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | revamped-run-spec
Files: files | file ages | folders
SHA1: aaf7a45583f2ca8148a5bd424fbf76386256a73b
User & Date: mrwellan on 2012-12-04 15:55:37
Other Links: branch diff | manifest | tags
Context
2012-12-04
15:55
Start of dot generation and alt simplified -run vs. -runtests/-runall/-itempatt Closed-Leaf check-in: aaf7a45583 user: mrwellan tags: revamped-run-spec
2012-12-03
17:21
Added -list-targets, -list-disks and -list-db-targets check-in: 970f20a4ba user: mrwellan tags: trunk
Changes

Modified megatest.scm from [302c3da708] to [9bf54c5489].

38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
  license GPL, Copyright Matt Welland 2006-2012

Usage: megatest [options]
  -h                      : this help
  -version                : print megatest version (currently " megatest-version ")

Launching and managing runs
  -runall                 : run all tests that are not state COMPLETED and status PASS, 
                            CHECK or KILLED
  -runtests tst1,tst2 ... : run tests
  -remove-runs            : remove the data for a run, requires :runname and -testpatt
                            Optionally use :state and :status
  -set-state-status X,Y   : set state to X and status to Y, requires controls per -remove-runs
  -rerun FAIL,WARN...     : force re-run for tests with specificed status(s)
  -rollup                 : (currently disabled) fill run (set by :runname)  with latest test(s)
                            from prior runs with same keys
  -lock                   : lock run specified by target and runname







|
|
<







38
39
40
41
42
43
44
45
46

47
48
49
50
51
52
53
  license GPL, Copyright Matt Welland 2006-2012

Usage: megatest [options]
  -h                      : this help
  -version                : print megatest version (currently " megatest-version ")

Launching and managing runs
  -run testpatt[/itempatt] : run all tests that are not state COMPLETED and status PASS, 
                            CHECK or KILLED, matching pattern testpatt...

  -remove-runs            : remove the data for a run, requires :runname and -testpatt
                            Optionally use :state and :status
  -set-state-status X,Y   : set state to X and status to Y, requires controls per -remove-runs
  -rerun FAIL,WARN...     : force re-run for tests with specificed status(s)
  -rollup                 : (currently disabled) fill run (set by :runname)  with latest test(s)
                            from prior runs with same keys
  -lock                   : lock run specified by target and runname
166
167
168
169
170
171
172

173
174
175
176
177
178
179
			"-env2file"
			"-setvars"
			"-set-state-status"
			"-debug" ;; for *verbosity* > 2
			"-gen-megatest-test"
			"-override-timeout"
			"-test-files"  ;; -test-paths is for listing all

			) 
		 (list  "-h"
			"-version"
		        "-force"
		        "-xterm"
		        "-showkeys"
		        "-test-status"







>







165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
			"-env2file"
			"-setvars"
			"-set-state-status"
			"-debug" ;; for *verbosity* > 2
			"-gen-megatest-test"
			"-override-timeout"
			"-test-files"  ;; -test-paths is for listing all
			"-run"
			) 
		 (list  "-h"
			"-version"
		        "-force"
		        "-xterm"
		        "-showkeys"
		        "-test-status"
509
510
511
512
513
514
515












516





517
518
519
520
521
522
523



524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
;;     launch task
;;   else
;;     put task in deferred queue
;; if still ok to run tasks
;;   process deferred tasks per above steps

;; run all tests are are Not COMPLETED and PASS or CHECK












(if (args:get-arg "-runall")





    (general-run-call 
     "-runall"
     "run all tests"
     (lambda (target runname keys keynames keyvallst)
       (runs:run-tests target
		       runname
		       "%"



		       (args:get-arg "-testpatt")
		       user
		       args:arg-hash))))

;;======================================================================
;; run one test
;;======================================================================

;; 1. find the config file
;; 2. change to the test directory
;; 3. update the db with "test started" status, set running host
;; 4. process launch the test
;;    - monitor the process, update stats in the db every 2^n minutes
;; 5. as the test proceeds internally it calls megatest as each step is
;;    started and completed
;;    - step started, timestamp
;;    - step completed, exit status, timestamp
;; 6. test phone home
;;    - if test run time > allowed run time then kill job
;;    - if cannot access db > allowed disconnect time then kill job

(if (args:get-arg "-runtests")
  (general-run-call 
   "-runtests" 
   "run a test" 
   (lambda (target runname keys keynames keyvallst)
     (runs:run-tests target
		     runname
		     (args:get-arg "-runtests")
		     (args:get-arg "-testpatt")
		     user
		     args:arg-hash))))

;;======================================================================
;; Rollup into a run
;;======================================================================

(if (args:get-arg "-rollup")
    (begin







>
>
>
>
>
>
>
>
>
>
>
>
|
>
>
>
>
>
|
|
|
|
|
|
<
>
>
>
|
|
|


















|
|
|
|
|
|
|
|
|
|
|







509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539

540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
;;     launch task
;;   else
;;     put task in deferred queue
;; if still ok to run tasks
;;   process deferred tasks per above steps

;; run all tests are are Not COMPLETED and PASS or CHECK
(if (or (args:get-arg "-runall") ;; deprecated
	(args:get-arg "-run")
	(args:get-arg "-runtests"))
    (begin
      (if (args:get-arg "-testpatt")
	  (begin
	    (debug:print 0 "ERROR:-testpatt is deprecated, use -run patt1,patt2... instead, your pattern " (args:get-arg "-testpatt") " will be ignored")
	    (sleep 3)))
      (if (args:get-arg "-itempatt")
	  (begin
	    (debug:print 0 "ERROR: -itempatt is not used with -run, your pattern " (args:get-arg "-itempatt") " will be ignored")
	    (sleep 3)))
      (if (args:get-arg "-runall")
	  (begin
	    (debug:print 0 "ERROR: -runall is deprecated, use -run patt1,patt2 ... instead")
	    (sleep 3)))
      (if (args:get-arg "-runtests")
	  (debug:print 0 "WARNING: -runtests is deprecated, use -run patt1,patt2 ... instead"))
      (general-run-call 
       "-run"
       "run tests"
       (lambda (target runname keys keynames keyvallst)
	 (runs:run-tests target
			 runname

			 '()
			 (or (args:get-arg "-run")
			     (args:get-arg "-runtests")
			     (args:get-arg "-testpatt"))
			 user
			 args:arg-hash)))))

;;======================================================================
;; run one test
;;======================================================================

;; 1. find the config file
;; 2. change to the test directory
;; 3. update the db with "test started" status, set running host
;; 4. process launch the test
;;    - monitor the process, update stats in the db every 2^n minutes
;; 5. as the test proceeds internally it calls megatest as each step is
;;    started and completed
;;    - step started, timestamp
;;    - step completed, exit status, timestamp
;; 6. test phone home
;;    - if test run time > allowed run time then kill job
;;    - if cannot access db > allowed disconnect time then kill job

;; (if (args:get-arg "-runtests")
;;   (general-run-call 
;;    "-runtests" 
;;    "run a test" 
;;    (lambda (target runname keys keynames keyvallst)
;;      (runs:run-tests target
;; 		     runname
;; 		     (args:get-arg "-runtests")
;; 		     (args:get-arg "-testpatt")
;; 		     user
;; 		     args:arg-hash))))

;;======================================================================
;; Rollup into a run
;;======================================================================

(if (args:get-arg "-rollup")
    (begin

Modified runs.scm from [ac5e3e62fc] to [a7759ddb27].

218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
    (if (file-exists? runconfigf)
	(open-run-close setup-env-defaults db runconfigf run-id *already-seen-runconfig-info* "pre-launch-env-vars")
	(debug:print 0 "WARNING: You do not have a run config file: " runconfigf))
    
    ;; look up all tests matching the comma separated list of globs in
    ;; test-patts (using % as wildcard)

    (set! test-names (tests:get-valid-tests *toppath* test-names))
    (set! test-names (delete-duplicates test-names))

    (debug:print-info 0 "test names " test-names)

    ;; on the first pass or call to run-tests set FAILS to NOT_STARTED if
    ;; -keepgoing is specified
    (if (eq? *passnum* 0)







|







218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
    (if (file-exists? runconfigf)
	(open-run-close setup-env-defaults db runconfigf run-id *already-seen-runconfig-info* "pre-launch-env-vars")
	(debug:print 0 "WARNING: You do not have a run config file: " runconfigf))
    
    ;; look up all tests matching the comma separated list of globs in
    ;; test-patts (using % as wildcard)

    (set! test-names (append (tests:get-valid-tests *toppath* test-patts) test-names))
    (set! test-names (delete-duplicates test-names))

    (debug:print-info 0 "test names " test-names)

    ;; on the first pass or call to run-tests set FAILS to NOT_STARTED if
    ;; -keepgoing is specified
    (if (eq? *passnum* 0)
340
341
342
343
344
345
346
347

348
349
350
351
352
353
354
(define (runs:run-tests-queue run-id runname test-records keyvallst flags test-patts)
    ;; 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 ((sorted-test-names (tests:sort-by-priority-and-waiton test-records))
	(test-registery    (make-hash-table))
	(num-retries        0)
	(max-retries       (config-lookup *configdat* "setup" "maxretries")))

    (set! max-retries (if (and max-retries (string->number max-retries))(string->number max-retries) 100))
    (if (not (null? sorted-test-names))
	(let loop ((hed         (car sorted-test-names))
		   (tal         (cdr sorted-test-names))
		   (reruns      '()))
	  (if (not (null? reruns))(debug:print-info 4 "reruns=" reruns))
	  ;; (print "Top of loop, hed=" hed ", tal=" tal " ,reruns=" reruns)







|
>







340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
(define (runs:run-tests-queue run-id runname test-records keyvallst flags test-patts)
    ;; 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 ((sorted-test-names (tests:sort-by-priority-and-waiton test-records))
	(test-registery    (make-hash-table))
	(num-retries        0)
	(max-retries       (config-lookup *configdat* "setup" "maxretries"))
	(dotfilep          (if (args:get-arg "-dotfile")(open-output-file (args:get-arg "-dotfile")) #f)))
    (set! max-retries (if (and max-retries (string->number max-retries))(string->number max-retries) 100))
    (if (not (null? sorted-test-names))
	(let loop ((hed         (car sorted-test-names))
		   (tal         (cdr sorted-test-names))
		   (reruns      '()))
	  (if (not (null? reruns))(debug:print-info 4 "reruns=" reruns))
	  ;; (print "Top of loop, hed=" hed ", tal=" tal " ,reruns=" reruns)
427
428
429
430
431
432
433






434
435
436
437
438
439
440
441
		  (thread-sleep! (+ 2 *global-delta*))
		  ;; could have done hed tal here but doing car/cdr of newtal to rotate tests
		  (loop (car newtal)(cdr newtal) reruns))
		 ((and have-resources
		       (or (null? prereqs-not-met)
			   (and (eq? testmode 'toplevel)
				(null? non-completed))))






		  (run:test run-id runname keyvallst test-record flags #f)
		  (thread-sleep! *global-delta*)
		  (if (not (null? tal))
		      (loop (car tal)(cdr tal) reruns)))
		 (else ;; must be we have unmet prerequisites
		    (debug:print 4 "FAILS: " fails)
		    ;; If one or more of the prereqs-not-met are FAIL then we can issue
		    ;; a message and drop hed from the items to be processed.







>
>
>
>
>
>
|







428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
		  (thread-sleep! (+ 2 *global-delta*))
		  ;; could have done hed tal here but doing car/cdr of newtal to rotate tests
		  (loop (car newtal)(cdr newtal) reruns))
		 ((and have-resources
		       (or (null? prereqs-not-met)
			   (and (eq? testmode 'toplevel)
				(null? non-completed))))
		  (if dotfilep
		      (with-output-to-port (lambda ()
					     (for-each (lambda (w)
							 (print " " w " -> " test-name ";"))
						       waitons)
					     (print " " test-name ";")))
		      (run:test run-id runname keyvallst test-record flags #f))
		  (thread-sleep! *global-delta*)
		  (if (not (null? tal))
		      (loop (car tal)(cdr tal) reruns)))
		 (else ;; must be we have unmet prerequisites
		    (debug:print 4 "FAILS: " fails)
		    ;; If one or more of the prereqs-not-met are FAIL then we can issue
		    ;; a message and drop hed from the items to be processed.

Modified tests.scm from [661a4dba80] to [f16c0dd062].

26
27
28
29
30
31
32
33





34
35
36
37
38
39
40
41
42
43
44
45
(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(include "test_records.scm")

(define (tests:get-valid-tests testsdir test-patts) ;;  #!key (test-names '()))
  (let ((tests (glob (conc testsdir "/tests/*")))) ;; " (string-translate patt "%" "*")))))





    (set! tests (filter (lambda (test)(file-exists? (conc test "/testconfig"))) tests))
    (delete-duplicates
     (filter (lambda (testname)
	       (tests:match test-patts testname #f))
	     (map (lambda (testp)
		    (last (string-split testp "/")))
		  tests)))))

;; tests:glob-like-match
(define (tests:glob-like-match patt str) 
  (let ((like (substring-index "%" patt)))
    (let* ((notpatt  (equal? (substring-index "~" patt) 0))







|
>
>
>
>
>



|
|







26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(include "test_records.scm")

(define (tests:get-valid-tests testsdir test-patts) ;;  #!key (test-names '()))
  (let ((tests  (glob (conc testsdir "/tests/*"))) ;; " (string-translate patt "%" "*")))))
	;; strip off all itempatt portions
	(modpat (string-intersperse
		 (map
		  (lambda (x)(first (string-split x "/")))
		  (string-split test-patts ",")) ",")))
    (set! tests (filter (lambda (test)(file-exists? (conc test "/testconfig"))) tests))
    (delete-duplicates
     (filter (lambda (testname)
	       (tests:match modpat testname #f))
	     (map (lambda (testp) ;; extract the testname from <test>/testconfig
		    (last (string-split testp "/")))
		  tests)))))

;; tests:glob-like-match
(define (tests:glob-like-match patt str) 
  (let ((like (substring-index "%" patt)))
    (let* ((notpatt  (equal? (substring-index "~" patt) 0))

Modified tests/tests.scm from [491ed287ed] to [6ed53e0842].

43
44
45
46
47
48
49
50
51

52
53
54
55
56




57
58
59






60
61


62
63


64
65
66
67
68
69
70
71
72
73
74


75
76
77
78
79
80
81
;; tests:glob-like-match
(test #f '("abc") (tests:glob-like-match "abc" "abc"))
(for-each 
 (lambda (patt str expected)
   (test (conc patt " " str "=>" expected) expected (tests:glob-like-match patt str)))
 (list "abc"    "~abc" "~abc" "a*c"  "a%c")
 (list "abc"    "abcd" "abc"  "ABC"  "ABC")
 (list '("abc")  #t      #f     #f '("ABC"))
 )


;; tests:match
(test #f #t (tests:match "abc/def" "abc" "def"))
(for-each 
 (lambda (patterns testname itempath expected)




   (test (conc patterns " " testname "/" itempath "=>" expected)
	 expected 
	 (tests:match patterns testname itempath)))






 (list "abc" "abc/%" "ab%/c%" "~abc/c%" "abc/~c%" "a,b/c,%/d" "%/,%/a" "%/,%/a" "%/,%/a" "%" "%" "%/" "%/")
 (list "abc" "abc"   "abcd"   "abc"     "abc"     "a"         "abc"     "def"    "ghi"   "a" "a"  "a"  "a")


 (list   ""  ""      "cde"    "cde"     "cde"     ""            ""      "a"       "b"    ""  "b"  ""   "b")
 (list   #t    #t       #t    #f           #f      #t           #t       #t       #f     #t  #t   #t    #f))



;; db:patt->like
(test #f "testname LIKE 't%'" (db:patt->like "testname" "t%" comparator: " AND "))
(test #f "testname LIKE 't%' AND testname LIKE '%t'" (db:patt->like "testname" "t%,%t" comparator: " AND "))
(test #f "item_path GLOB ''" (db:patt->like "item_path" ""))

;; test:match->sqlqry
(test #f "(testname GLOB 'a' AND item_path GLOB 'b') OR (testname LIKE 'a%' AND item_path LIKE '%') OR (testname GLOB '' AND item_path LIKE 'b%')"
      (tests:match->sqlqry "a/b,a%,/b%"))
(test #f "(testname GLOB 'a' AND item_path GLOB 'b') OR (testname LIKE 'a%' AND item_path LIKE '%') OR (testname LIKE '%' AND item_path LIKE 'b%')"
      (tests:match->sqlqry "a/b,a%,%/b%"))



;;======================================================================
;; S E R V E R
;;======================================================================

(test "setup for run" #t (begin (setup-for-run)
				(string? (getenv "MT_RUN_AREA_HOME"))))







|
|
>




|
>
>
>
>
|
|
|
>
>
>
>
>
>
|
|
>
>
|
|
>
>











>
>







43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
;; tests:glob-like-match
(test #f '("abc") (tests:glob-like-match "abc" "abc"))
(for-each 
 (lambda (patt str expected)
   (test (conc patt " " str "=>" expected) expected (tests:glob-like-match patt str)))
 (list "abc"    "~abc" "~abc" "a*c"  "a%c")
 (list "abc"    "abcd" "abc"  "ABC"  "ABC")
 (list '("abc")  #t      #f     #f '("ABC")))

(test #f '("sqlite3speed") (tests:get-valid-tests *toppath* "%sqlite%") )

;; tests:match
(test #f #t (tests:match "abc/def" "abc" "def"))
(for-each 
 (lambda (row) ;; erns testname itempath expected)
   (let ((patterns (list-ref row 0))
	 (testname (list-ref row 1))
	 (itempath (list-ref row 2))
	 (expected (list-ref row 3)))
     (test (conc patterns " " testname "/" itempath "=>" expected)
	   expected 
	   (tests:match patterns testname itempath))))
 '(("abc"        "abc"   ""      #t)
   ("abc/%"      "abc"   ""      #t)
   ("ab%/c%"     "abcd"  "cde"   #t)
   ("ab%/c%"     "def"   ""      #t)
   ("~abc/c%"    "abc"   "cde"   #f)
   ("abc/~c%"    "abc"   "cde"   #f)
   ("a,b/c,%/d"  "a"     ""      #t)
   ("%/,%/a"     "abc"   ""      #t)
   ("%/,%/a"     "def"   "a"     #t)
   ("%/,%/a"     "ghi"   "b"     #f)
   ("%"          "a"     ""      #t)
   ("%"          "a"     "b"     #t)
   ("%/"         "a"     ""      #t)
   ("%/"         "a"     "b"     #f)))

;; db:patt->like
(test #f "testname LIKE 't%'" (db:patt->like "testname" "t%" comparator: " AND "))
(test #f "testname LIKE 't%' AND testname LIKE '%t'" (db:patt->like "testname" "t%,%t" comparator: " AND "))
(test #f "item_path GLOB ''" (db:patt->like "item_path" ""))

;; test:match->sqlqry
(test #f "(testname GLOB 'a' AND item_path GLOB 'b') OR (testname LIKE 'a%' AND item_path LIKE '%') OR (testname GLOB '' AND item_path LIKE 'b%')"
      (tests:match->sqlqry "a/b,a%,/b%"))
(test #f "(testname GLOB 'a' AND item_path GLOB 'b') OR (testname LIKE 'a%' AND item_path LIKE '%') OR (testname LIKE '%' AND item_path LIKE 'b%')"
      (tests:match->sqlqry "a/b,a%,%/b%"))

(exit)

;;======================================================================
;; S E R V E R
;;======================================================================

(test "setup for run" #t (begin (setup-for-run)
				(string? (getenv "MT_RUN_AREA_HOME"))))