Megatest

Changes On Branch 3e4d4b90274334b3
Login
☰Home Timeline Files Branches Tags Tickets Wiki Login
Hide Diff Patch Unified Diff

Changes In Branch rollup-runs Through [3e4d4b9027] Excluding Merge-Ins

This is equivalent to a diff from 6b1fa57fcf to 3e4d4b9027

2011-08-11
01:45
Merged in rollup runs to trunk. Actual rollup of runs not completed yet check-in: d7ffcddcac user: matt tags: trunk, v1.20
00:53
Added test_meta data populating check-in: 5cecd7e1d4 user: matt tags: rollup-runs
2011-08-10
21:57
Rollup runs, clean up tests check-in: 3e4d4b9027 user: mrwellan tags: rollup-runs
2011-08-08
23:24
Minor refactoring of run code. check-in: f8f7968767 user: mrwellan tags: rollup-runs
14:45
Rollup runs from past N days to new runname, started implementation check-in: 8757213827 user: mrwellan tags: rollup-runs
2011-08-06
23:42
Added debugging statements, regenerated docs check-in: 6b1fa57fcf user: matt tags: trunk
2011-08-04
09:56
Added support for using the shell when launching a command (vs. directly kicking off the process) check-in: dc5aae878a user: mrwellan tags: trunk

Modified Makefile from [6bee1e6a16] to [6c62140a06].

︙︙
12
13
14
15
16
17
18
19
20
21

	cp megatest $(PREFIX)/bin/megatest

$(PREFIX)/bin/dashboard : dashboard
	cp dashboard $(PREFIX)/bin/dashboard

install : $(PREFIX)/bin/megatest $(PREFIX)/bin/dashboard

test: megatest tests/tests.scm
	cd tests;csi -I .. -b -n tests.scm









|



12
13
14
15
16
17
18
19
20
21

	cp megatest $(PREFIX)/bin/megatest

$(PREFIX)/bin/dashboard : dashboard
	cp dashboard $(PREFIX)/bin/dashboard

install : $(PREFIX)/bin/megatest $(PREFIX)/bin/dashboard

test: tests/tests.scm
	cd tests;csi -I .. -b -n tests.scm

Modified configf.scm from [50f8f33c26] to [9fba368c47].

︙︙
23
24
25
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
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

	    (list path fullpath configname)
	    (let ((remcwd (take dir (- (length dir) 1))))
	      (if (null? remcwd)
		  (list #f #f #f) ;;  #f #f) 
		  (loop remcwd))))))))

(define (config:assoc-safe-add alist key val)
  (let ((newalist (filter (lambda (x)(not (equal? key x))) alist)))
    (append alist (list (list key val)))))

;; read a config file, returns two level hierarchial hash-table,
;; adds to ht if given (must be #f otherwise)
(define (read-config path . ht)
  (if (not (file-exists? path))
      (if (null? ht)(make-hash-table) (car ht))
      (let ((inp        (open-input-file path))
	    (res        (if (null? ht)(make-hash-table)(car ht)))
	    (include-rx (regexp "^\\[include\\s+(.*)\\]\\s*$"))
	    (section-rx (regexp "^\\[(.*)\\]\\s*$"))
	    (blank-l-rx (regexp "^\\s*$"))
	    (key-sys-pr (regexp "^(\\S+)\\s+\\[system\\s+(\\S+.*)\\]\\s*$"))
	    (key-val-pr (regexp "^(\\S+)\\s+(.*)$"))
	    (comment-rx (regexp "^\\s*#.*")))

	(let loop ((inl               (read-line inp))
		   (curr-section-name "default"))


	  (if (eof-object? inl) 
	      (begin
		(close-input-port inp)
		res)
	      (regex-case 
	       inl 
	       (comment-rx _                  (loop (read-line inp) curr-section-name))
	       (blank-l-rx _                  (loop (read-line inp) curr-section-name))
	       (include-rx ( x include-file ) (begin
						(read-config include-file res)
						(loop (read-line inp) curr-section-name)))
	       (section-rx ( x section-name ) (loop (read-line inp) section-name))
	       (key-sys-pr ( x key cmd      ) (let ((alist (hash-table-ref/default res curr-section-name '()))
						    (val   (let* ((cmdres  (cmd-run->list cmd))
								  (status  (cadr cmdres))
								  (res     (car  cmdres)))
							     (if (not (eq? status 0))
								 (begin
								   (debug:print 0 "ERROR: problem with " inl ", return code " status)
								   (exit 1)))
							     (if (null? res)
								 ""
								 (string-intersperse res " ")))))
						(hash-table-set! res curr-section-name 
								 (config:assoc-safe-add alist key val))
								 ;; (append alist (list (list key val))))
						(loop (read-line inp) curr-section-name)))
	       (key-val-pr ( x key val      ) (let ((alist (hash-table-ref/default res curr-section-name '())))
						(hash-table-set! res curr-section-name 
								 (config:assoc-safe-add alist key val))










								 ;; (append alist (list (list key val))))



						(loop (read-line inp) curr-section-name)))

	       (else (debug:print 0 "ERROR: problem parsing " path ",\n   \"" inl "\"")

		     (loop (read-line inp) curr-section-name))))))))
  
(define (find-and-read-config fname)
  (let* ((curr-dir   (current-directory))
         (configinfo (find-config fname))
	 (toppath    (car configinfo))
	 (configfile (cadr configinfo)))








|
|













|
>

|
>
>






|
|


|
|














|



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

>








23
24
25
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
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105

	    (list path fullpath configname)
	    (let ((remcwd (take dir (- (length dir) 1))))
	      (if (null? remcwd)
		  (list #f #f #f) ;;  #f #f) 
		  (loop remcwd))))))))

(define (config:assoc-safe-add alist key val)
  (let ((newalist (filter (lambda (x)(not (equal? key (car x)))) alist)))
    (append newalist (list (list key val)))))

;; read a config file, returns two level hierarchial hash-table,
;; adds to ht if given (must be #f otherwise)
(define (read-config path . ht)
  (if (not (file-exists? path))
      (if (null? ht)(make-hash-table) (car ht))
      (let ((inp        (open-input-file path))
	    (res        (if (null? ht)(make-hash-table)(car ht)))
	    (include-rx (regexp "^\\[include\\s+(.*)\\]\\s*$"))
	    (section-rx (regexp "^\\[(.*)\\]\\s*$"))
	    (blank-l-rx (regexp "^\\s*$"))
	    (key-sys-pr (regexp "^(\\S+)\\s+\\[system\\s+(\\S+.*)\\]\\s*$"))
	    (key-val-pr (regexp "^(\\S+)\\s+(.*)$"))
	    (comment-rx (regexp "^\\s*#.*"))
	    (cont-ln-rx (regexp "^(\\s+)(\\S+.*)$")))
	(let loop ((inl               (read-line inp))
		   (curr-section-name "default")
		   (var-flag #f);; turn on for key-var-pr and cont-ln-rx, turn off elsewhere
		   (lead     #f))
	  (if (eof-object? inl) 
	      (begin
		(close-input-port inp)
		res)
	      (regex-case 
	       inl 
	       (comment-rx _                  (loop (read-line inp) curr-section-name #f #f))
	       (blank-l-rx _                  (loop (read-line inp) curr-section-name #f #f))
	       (include-rx ( x include-file ) (begin
						(read-config include-file res)
						(loop (read-line inp) curr-section-name #f #f)))
	       (section-rx ( x section-name ) (loop (read-line inp) section-name #f #f))
	       (key-sys-pr ( x key cmd      ) (let ((alist (hash-table-ref/default res curr-section-name '()))
						    (val   (let* ((cmdres  (cmd-run->list cmd))
								  (status  (cadr cmdres))
								  (res     (car  cmdres)))
							     (if (not (eq? status 0))
								 (begin
								   (debug:print 0 "ERROR: problem with " inl ", return code " status)
								   (exit 1)))
							     (if (null? res)
								 ""
								 (string-intersperse res " ")))))
						(hash-table-set! res curr-section-name 
								 (config:assoc-safe-add alist key val))
								 ;; (append alist (list (list key val))))
						(loop (read-line inp) curr-section-name #f #f)))
	       (key-val-pr ( x key val      ) (let ((alist (hash-table-ref/default res curr-section-name '())))
						(hash-table-set! res curr-section-name 
								 (config:assoc-safe-add alist key val))
						(loop (read-line inp) curr-section-name key #f)))
	       ;; if a continued line
	       (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))
						      (loop (read-line inp) curr-section-name var-flag (if lead lead whsp)))
						    (loop (read-line inp) curr-section-name #f #f))))
	       (else (debug:print 0 "ERROR: problem parsing " path ",\n   \"" inl "\"")
		     (set! var-flag #f)
		     (loop (read-line inp) curr-section-name))))))))
  
(define (find-and-read-config fname)
  (let* ((curr-dir   (current-directory))
         (configinfo (find-config fname))
	 (toppath    (car configinfo))
	 (configfile (cadr configinfo)))
︙︙

Modified db.scm from [603c4ba3d8] to [b3bfe37375].

︙︙
77
78
79
80
81
82
83
84












85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111

                               status TEXT DEFAULT 'n/a',event_time TIMESTAMP,
                               comment TEXT DEFAULT '',
                               CONSTRAINT test_steps_constraint UNIQUE (test_id,stepname,state));")
	  (sqlite3:execute db "CREATE TABLE extradat (id INTEGER PRIMARY KEY, run_id INTEGER, key TEXT, val TEXT);")
	  (sqlite3:execute db "CREATE TABLE metadat (id INTEGER PRIMARY KEY, var TEXT, val TEXT,
                                  CONSTRAINT metadat_constraint UNIQUE (id,var));")
	  (db:set-var db "MEGATEST_VERSION" megatest-version)
	  (sqlite3:execute db "CREATE TABLE access_log (id INTEGER PRIMARY KEY, user TEXT, accessed TIMESTAMP, args TEXT);")))












    db))

;;======================================================================
;; TODO:
;;   put deltas into an assoc list with version numbers
;;   apply all from last to current
;;======================================================================
(define (patch-db db)
  (handle-exceptions
   exn
   (begin
     (print "Exception: " exn)
     (print "ERROR: Possible out of date schema, attempting to add table metadata...")
     (sqlite3:execute db "CREATE TABLE metadat (id INTEGER PRIMARY KEY, var TEXT, val TEXT,
                                  CONSTRAINT metadat_constraint UNIQUE (id,var));")
     (sqlite3:execute db "ALTER TABLE tests ADD COLUMN tags TEXT DEFAULT '';")
     (db:set-var db "MEGATEST_VERSION" 1.17)
     )
   (let ((mver (db:get-var db "MEGATEST_VERSION")))
     (if(not mver)
	(begin
	  (print "Adding megatest-version to metadata")
	  (sqlite3:execute db (db:set-var db "MEGATEST_VERSION" megatest-version))))
     (if (< mver 1.18)
	 (begin
	   (print "Adding tags column to tests table")
	   (sqlite3:execute db "ALTER TABLE tests ADD COLUMN tags TEXT DEFAULT '';")))








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



















|








77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123

                               status TEXT DEFAULT 'n/a',event_time TIMESTAMP,
                               comment TEXT DEFAULT '',
                               CONSTRAINT test_steps_constraint UNIQUE (test_id,stepname,state));")
	  (sqlite3:execute db "CREATE TABLE extradat (id INTEGER PRIMARY KEY, run_id INTEGER, key TEXT, val TEXT);")
	  (sqlite3:execute db "CREATE TABLE metadat (id INTEGER PRIMARY KEY, var TEXT, val TEXT,
                                  CONSTRAINT metadat_constraint UNIQUE (id,var));")
	  (db:set-var db "MEGATEST_VERSION" megatest-version)
	  (sqlite3:execute db "CREATE TABLE access_log (id INTEGER PRIMARY KEY, user TEXT, accessed TIMESTAMP, args TEXT);")
	  (sqlite3:execute db "CREATE TABLE test_meta (id INTEGER PRIMARY KEY,
                                     testname    TEXT DEFAULT '',
                                     author      TEXT DEFAULT '',
                                     owner       TEXT DEFAULT '',
                                     description TEXT DEFAULT '',
                                     reviewed    TIMESTAMP,
                                     iterated    TEXT DEFAULT '',
                                     avg_runtime REAL,
                                     avg_disk    REAL,
                                CONSTRAINT test_meta_contstraint UNIQUE (id,testname));")

	  ))
    db))

;;======================================================================
;; TODO:
;;   put deltas into an assoc list with version numbers
;;   apply all from last to current
;;======================================================================
(define (patch-db db)
  (handle-exceptions
   exn
   (begin
     (print "Exception: " exn)
     (print "ERROR: Possible out of date schema, attempting to add table metadata...")
     (sqlite3:execute db "CREATE TABLE metadat (id INTEGER PRIMARY KEY, var TEXT, val TEXT,
                                  CONSTRAINT metadat_constraint UNIQUE (id,var));")
     (sqlite3:execute db "ALTER TABLE tests ADD COLUMN tags TEXT DEFAULT '';")
     (db:set-var db "MEGATEST_VERSION" 1.17)
     )
   (let ((mver (db:get-var db "MEGATEST_VERSION")))
     (if (not mver)
	(begin
	  (print "Adding megatest-version to metadata")
	  (sqlite3:execute db (db:set-var db "MEGATEST_VERSION" megatest-version))))
     (if (< mver 1.18)
	 (begin
	   (print "Adding tags column to tests table")
	   (sqlite3:execute db "ALTER TABLE tests ADD COLUMN tags TEXT DEFAULT '';")))
︙︙
427
428
429
430
431
432
433


;;  					  tests)
;;  				(filter (lambda (x)
;;  					  (not (hash-table-ref/default non-completed (db:test-get-testname x) #f)))
;;  					tests)))
;;  	     (pre-dep-names   (map db:test-get-testname completed-tests))
;;  	     (result          (lset-difference string=? waiton pre-dep-names)))
;;  	(print "pre-dep-names: " pre-dep-names " waiton: " waiton " result: " result)









>

439
440
441
442
443
444
445
446

;;  					  tests)
;;  				(filter (lambda (x)
;;  					  (not (hash-table-ref/default non-completed (db:test-get-testname x) #f)))
;;  					tests)))
;;  	     (pre-dep-names   (map db:test-get-testname completed-tests))
;;  	     (result          (lset-difference string=? waiton pre-dep-names)))
;;  	(print "pre-dep-names: " pre-dep-names " waiton: " waiton " result: " result)

Modified megatest.scm from [fdec59eebf] to [8f3220a6de].

︙︙
52
53
54
55
56
57
58



59
60
61
62
63
64
65

                            and :runname ,-testpatt and -itempatt
                            and -testpatt
  -keepgoing              : continue running until no jobs are \"LAUNCHED\" or
                            \"NOT_STARTED\"
  -rerun FAIL,WARN...     : re-run if called on a test that previously ran (nullified
                            if -keepgoing is also specified)
  -rebuild-db             : bring the database schema up to date




Helpers
  -runstep stepname  ...  : take remaining params as comand and execute as stepname
                            log will be in stepname.log. Best to put command in quotes
  -logpro file            : with -exec apply logpro file to stepname.log, creates
                            stepname.html and sets log to same
                            If using make use stepname_logpro.log as your target








>
>
>








52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68

                            and :runname ,-testpatt and -itempatt
                            and -testpatt
  -keepgoing              : continue running until no jobs are \"LAUNCHED\" or
                            \"NOT_STARTED\"
  -rerun FAIL,WARN...     : re-run if called on a test that previously ran (nullified
                            if -keepgoing is also specified)
  -rebuild-db             : bring the database schema up to date
  -rollup N               : fill run (set by :runname)  with latest test(s) from
                            past N days, requires keys
  -rename-run <runb>      : rename run (set by :runname) to <runb>, requires keys

Helpers
  -runstep stepname  ...  : take remaining params as comand and execute as stepname
                            log will be in stepname.log. Best to put command in quotes
  -logpro file            : with -exec apply logpro file to stepname.log, creates
                            stepname.html and sets log to same
                            If using make use stepname_logpro.log as your target
︙︙
86
87
88
89
90
91
92



93
94
95
96
97
98
99
100
101
102
103
104
105
106

107
108
109
110
111
112
113

			"-itempatt"
			"-setlog"
			"-set-toplog"
			"-runstep"
			"-logpro"
			"-m"
			"-rerun"



			"-debug" ;; for *verbosity* > 2
			) 
		 (list  "-h"
		        "-force"
		        "-xterm"
		        "-showkeys"
		        "-test-status"
			"-summarize-items"
		        "-gui"
			"-runall"    ;; run all tests
			"-remove-runs"
			"-keepgoing"
			"-usequeue"
			"-rebuild-db"

			"-v" ;; verbose 2, more than normal (normal is 1)
			"-q" ;; quiet 0, errors/warnings only
		       )
		 args:arg-hash
		 0))

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








>
>
>














>








89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120

			"-itempatt"
			"-setlog"
			"-set-toplog"
			"-runstep"
			"-logpro"
			"-m"
			"-rerun"
			"-days"
			"-rename-run"
			"-to"
			"-debug" ;; for *verbosity* > 2
			) 
		 (list  "-h"
		        "-force"
		        "-xterm"
		        "-showkeys"
		        "-test-status"
			"-summarize-items"
		        "-gui"
			"-runall"    ;; run all tests
			"-remove-runs"
			"-keepgoing"
			"-usequeue"
			"-rebuild-db"
			"-rollup"
			"-v" ;; verbose 2, more than normal (normal is 1)
			"-q" ;; quiet 0, errors/warnings only
		       )
		 args:arg-hash
		 0))

(if (args:get-arg "-h")
︙︙
256
257
258
259
260
261
262
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

;;   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")
    (if (not (args:get-arg ":runname"))
	(begin
	  (debug:print 0 "ERROR: Missing required parameter for -runtests, you must specify the run name with :runname runname")
	  (exit 2))
	(let* ((db      (if (setup-for-run)
			    (open-db)
			    (begin
			      (debug:print 0 "Failed to setup, exiting")
			      (exit 1)))))
	  (if (not (car *configinfo*))
	      (begin
		(debug:print 0 "ERROR: Attempted to run a test but run area config file not found")
		(exit 1))
	      ;; put test parameters into convenient variables

	      (let* ((test-names (get-all-legal-tests))) ;; "PROD" is ignored for now
		(debug:print 1 "INFO: Attempting to start the following tests...")
		(debug:print 1 "     " (string-intersperse test-names ","))
		(run-tests db test-names)))
	  ;; (run-waiting-tests db)






	  (sqlite3:finalize! db)


	  (set! *didsomething* #t))))

;;======================================================================
;; 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

(define (runtests)
  (if (not (args:get-arg ":runname"))
      (begin
	(debug:print 0 "ERROR: Missing required parameter for -runtests, you must specify the run name with :runname runname")
	(exit 2))
      (let ((db #f))
	(if (not (setup-for-run))
	    (begin 
	      (debug:print 0 "Failed to setup, exiting")
	      (exit 1)))
	(set! db (open-db))
	(if (not (car *configinfo*))
	    (begin
	      (debug:print 0 "ERROR: Attempted to run a test but run area config file not found")
	      (exit 1))
	    ;; put test parameters into convenient variables

	    (let* ((test-names   (string-split (args:get-arg "-runtests") ",")))
	      (run-tests db test-names)))
	;; run-waiting-tests db)
	(sqlite3:finalize! db)
	;; (run-waiting-tests #f)
	(set! *didsomething* #t))))
	  
(if (args:get-arg "-runtests")
    (runtests))

;;======================================================================
;; execute the test
;;    - gets called on remote host
;;    - receives info from the -execute param
;;    - passes info to steps via MT_CMDINFO env var (future is to use a dot file)
;;    - gathers host info and 








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


















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








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

;;   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 (db keys keynames keyvallst)
       (let* ((test-names (get-all-legal-tests))) ;; "PROD" is ignored for now
	 (debug:print 1 "INFO: Attempting to start the following tests...")
	 (debug:print 1 "     " (string-intersperse test-names ","))
	 (run-tests db test-names)))))

;;======================================================================
;; Rollup into a run
;;======================================================================
(if (args:get-arg "-rollup")
    (general-run-call 
     "-rollup" 
     "rollup tests" 
     (lambda (db keys keynames keyvallst)
       (let ((n (args:get-arg "-rollup")))
	 (runs:rollup db keys keynames keyvallst n)))))

;;======================================================================
;; 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 (db keys keynames keyvallst)
     (let ((test-names (string-split (args:get-arg "-runtests") ",")))
       (run-tests db test-names)))))








;;======================================================================
;; execute the test
;;    - gets called on remote host
;;    - receives info from the -execute param
;;    - passes info to steps via MT_CMDINFO env var (future is to use a dot file)
;;    - gathers host info and
︙︙
503
504
505
506
507
508
509

510
511
512
513
514
515
516
517

					(if (vector-ref exit-info 1) ;; look at the exit-status
					    (if (and (not kill-job?) 
						     (eq? (vector-ref exit-info 2) 0))
						"PASS"
						"FAIL")
					    "FAIL") itemdat (args:get-arg "-m"))))
		;; for automated creation of the rollup html file this is a good place...

		(tests:summarize-items db run-id test-name #f) ;; don't force - just update if no
		)
	      (mutex-unlock! m)
	      ;; (exec-results (cmd-run->list fullrunscript)) ;;  (list ">" (conc test-name "-run.log"))))
	      ;; (success      exec-results)) ;; (eq? (cadr exec-results) 0)))
	      (debug:print 2 "Output from running " fullrunscript ", pid " (vector-ref exit-info 0) " in work area " 
		     work-area ":\n====\n exit code " (vector-ref exit-info 2) "\n" "====\n")
	      (sqlite3:finalize! db)








>
|








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

					(if (vector-ref exit-info 1) ;; look at the exit-status
					    (if (and (not kill-job?) 
						     (eq? (vector-ref exit-info 2) 0))
						"PASS"
						"FAIL")
					    "FAIL") itemdat (args:get-arg "-m"))))
		;; for automated creation of the rollup html file this is a good place...
		(if (not (equal? item-path ""))
		   (tests:summarize-items db run-id test-name #f)) ;; don't force - just update if no
		)
	      (mutex-unlock! m)
	      ;; (exec-results (cmd-run->list fullrunscript)) ;;  (list ">" (conc test-name "-run.log"))))
	      ;; (success      exec-results)) ;; (eq? (cadr exec-results) 0)))
	      (debug:print 2 "Output from running " fullrunscript ", pid " (vector-ref exit-info 0) " in work area " 
		     work-area ":\n====\n exit code " (vector-ref exit-info 2) "\n" "====\n")
	      (sqlite3:finalize! db)
︙︙

Modified runs.scm from [80fea350e5] to [4f776d58bd].

︙︙
424
425
426
427
428
429
430






431
432
433
434
435
436
437

	  (if (>= *verbosity* 1)(pp allitems))
	  (if (>= *verbosity* 5)
	      (begin
		(print "items: ")(pp (item-assoc->item-list items))
		(print "itestable: ")(pp (item-table->item-list itemstable))))
	  (if (args:get-arg "-m")
	      (db:set-comment-for-run db run-id (args:get-arg "-m")))






	  ;; braindead work-around for poorly specified allitems list BUG!!! FIXME
	  (if (null? allitems)(set! allitems '(())))
	  (let loop ((itemdat (car allitems))
		     (tal     (cdr allitems)))
	    ;; (lambda (itemdat) ;;; ((ripeness "overripe") (temperature "cool") (season "summer"))
	    ;; Handle lists of items
	    (let* ((item-path     (item-list->path itemdat)) ;; (string-intersperse (map cadr itemdat) "/"))








>
>
>
>
>
>








424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443

	  (if (>= *verbosity* 1)(pp allitems))
	  (if (>= *verbosity* 5)
	      (begin
		(print "items: ")(pp (item-assoc->item-list items))
		(print "itestable: ")(pp (item-table->item-list itemstable))))
	  (if (args:get-arg "-m")
	      (db:set-comment-for-run db run-id (args:get-arg "-m")))
	  ;; Here is where the test_meta table is best updated
	  (for-each 
	   (lambda (key)
	     (let ((val (config-lookup *configdat* "test_meta" key)))
			

	  ;; braindead work-around for poorly specified allitems list BUG!!! FIXME
	  (if (null? allitems)(set! allitems '(())))
	  (let loop ((itemdat (car allitems))
		     (tal     (cdr allitems)))
	    ;; (lambda (itemdat) ;;; ((ripeness "overripe") (temperature "cool") (season "summer"))
	    ;; Handle lists of items
	    (let* ((item-path     (item-list->path itemdat)) ;; (string-intersperse (map cadr itemdat) "/"))
︙︙
631
632
633
634
635
636
637








































		   ;;    (if (null? (glob (conc runpath "/*")))
		   ;;        (begin
		   ;; 	 (debug:print 1 "Removing run dir " runpath)
		   ;; 	 (system (conc "rmdir -p " runpath))))
		   ))))
	 ))
     runs)))















































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>

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

		   ;;    (if (null? (glob (conc runpath "/*")))
		   ;;        (begin
		   ;; 	 (debug:print 1 "Removing run dir " runpath)
		   ;; 	 (system (conc "rmdir -p " runpath))))
		   ))))
	 ))
     runs)))

;;======================================================================
;; 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)
  (if (not (args:get-arg ":runname"))
      (begin
	(debug:print 0 "ERROR: Missing required parameter for " switchname ", you must specify the run name with :runname runname")
	(exit 2))
      (let ((db #f))
	(if (not (setup-for-run))
	    (begin 
	      (debug:print 0 "Failed to setup, exiting")
	      (exit 1)))
	(set! db (open-db))
	(if (not (car *configinfo*))
	    (begin
	      (debug:print 0 "ERROR: Attempted to " action-desc " but run area config file not found")
	      (exit 1))
	    ;; Extract out stuff needed in most or many calls
	    ;; here then call proc
	    (let* ((keys       (db-get-keys db))
		   (keynames   (map key:get-fieldname keys))
		   (keyvallst  (keys->vallist keys #t)))
	      (proc db keys keynames keyvallst)))
	(sqlite3:finalize! db)
	(set! *didsomething* #t))))

(define (runs:rollup-run db keys keynames keyvallst n)
  (let* ((new-run-id   (register-run db keys))
	 (similar-runs (db:get-similar-runs db keys))
	 (tests-n-days (db:get-tests-n-days db similar-runs)))
    (for-each 
     (lambda (test-id)
       (db:rollup-test db run-id test-id))
     tests-n-days)))

Modified tests/test.config from [50c4aca439] to [5ec648d029].

︙︙
15
16
17
18
19
20
21











[include a file that doesn't exist]


blah nada

# now inlcude a file tha tdoes exist
[include megatest.config]


















>
>
>
>
>
>
>
>
>
>

15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31

[include a file that doesn't exist]


blah nada

# now inlcude a file tha tdoes exist
[include megatest.config]

[metadata]
description This is a multiline 
  description. The leading whitespace is discarded
  irrespective of amount of indenting.
     This line is indented more.
 

author matt
lastreview never

Modified tests/tests.scm from [51a14a8524] to [8fcf733fb4].

︙︙
16
17
18
19
20
21
22

23
24
25
26
27
28
29

(test "Read a config that doesn't exist" #t (hash-table? (read-config "nada.config")))

(set! conffile (read-config "test.config"))
(test "Get available diskspace" #t (number? (get-df "./")))
(test "Get best dir" #t (let ((bestdir (get-best-disk conffile)))
			      (or (equal? "./"   bestdir)
				  (equal? "/tmp" bestdir))))


;; db
(define row    (vector "a" "b" "c" "blah"))
(define header (list "col1" "col2" "col3" "col4"))
(test "Get row by header" "blah" (db:get-value-by-header row header "col4"))

;; (define *toppath* "tests")








>








16
17
18
19
20
21
22
23
24
25
26
27
28
29
30

(test "Read a config that doesn't exist" #t (hash-table? (read-config "nada.config")))

(set! conffile (read-config "test.config"))
(test "Get available diskspace" #t (number? (get-df "./")))
(test "Get best dir" #t (let ((bestdir (get-best-disk conffile)))
			      (or (equal? "./"   bestdir)
				  (equal? "/tmp" bestdir))))
(test "Multiline variable" 4 (length (string-split (config-lookup conffile "metadata" "description") "\n")))

;; db
(define row    (vector "a" "b" "c" "blah"))
(define header (list "col1" "col2" "col3" "col4"))
(test "Get row by header" "blah" (db:get-value-by-header row header "col4"))

;; (define *toppath* "tests")
︙︙
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72

                                      (and (file-exists? "nada.sh")
    			                 (file-exists? "nada.csh"))))

(test "get all legal tests" (list "runfirst" "runwithfirst" "singletest" "singletest2" "sqlitespeed") (sort (get-all-legal-tests) string<=?))

(test "register-test, test info" "NOT_STARTED"
      (begin
	(register-test *db* 1 "nada" "")
	(test:get-state (db:get-test-info *db* 1 "nada" ""))))

(test "get-keys" "sysname" (key:get-fieldname (car (sort (db-get-keys *db*)(lambda (a b)(string>=? (vector-ref a 0)(vector-ref b 0)))))))

(define remargs (args:get-args
		 '("bar" "foo" ":runname" "bob" ":sysname" "ubuntu" ":fsname" "nfs" ":datapath" "blah/foo" "nada")
		 (list ":runname" ":state" ":status")








|








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

                                      (and (file-exists? "nada.sh")
    			                 (file-exists? "nada.csh"))))

(test "get all legal tests" (list "runfirst" "runwithfirst" "singletest" "singletest2" "sqlitespeed") (sort (get-all-legal-tests) string<=?))

(test "register-test, test info" "NOT_STARTED"
      (begin
	(register-test *db* 1 "nada" "" '("tag1" "tag2" "tag3"))
	(test:get-state (db:get-test-info *db* 1 "nada" ""))))

(test "get-keys" "sysname" (key:get-fieldname (car (sort (db-get-keys *db*)(lambda (a b)(string>=? (vector-ref a 0)(vector-ref b 0)))))))

(define remargs (args:get-args
		 '("bar" "foo" ":runname" "bob" ":sysname" "ubuntu" ":fsname" "nfs" ":datapath" "blah/foo" "nada")
		 (list ":runname" ":state" ":status")
︙︙

Modified tests/tests/runfirst/testconfig from [9a8e30b98e] to [f0b52bc3c6].

︙︙
10
11
12
13
14
15
16









[items]
SEASON summer winter fall spring

[itemstable]
BLOCK a  b
TOCK  1  2

















>
>
>
>
>
>
>
>

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

[items]
SEASON summer winter fall spring

[itemstable]
BLOCK a  b
TOCK  1  2

[test_meta]
author matt
owner  bob
description This test must
 be run before the other tests

tags first,single
reviewed 1/1/1965

This page was generated in about 0.159s by Fossil 2.24 [452f8e1ffc] 2024-03-26 15:36:00