Megatest
Check-in [c4edfbcd13]
Not logged in
Overview
SHA1:c4edfbcd138fdc64a1b442baeb373527a2daff42
Date: 2011-05-04 23:48:00
User: mrwellan
Comment:Added pattern selectors for use with -list-runs
Timelines: family | ancestors | descendants | both | trunk
Downloads: Tarball | ZIP archive
Other Links: files | file ages | folders | manifest
Tags And Properties
Context
2011-05-05
01:37
[e0413b29e1] Fixed -m missing from args (user: matt, tags: trunk)
2011-05-04
23:48
[c4edfbcd13] Added pattern selectors for use with -list-runs (user: mrwellan, tags: trunk)
08:22
[cf78fcded0] Placeholder for remove-runs (user: matt, tags: trunk)
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Modified db.scm from [8e4eb733da] to [514fa0af1c].

169
170
171
172
173
174
175
176
177


178
179
180
181
182
183
184
185
186
187
188
189
190
(define-inline (db:test-get-uname        vec) (vector-ref vec 9))
(define-inline (db:test-get-rundir       vec) (vector-ref vec 10))
(define-inline (db:test-get-item-path    vec) (vector-ref vec 11))
(define-inline (db:test-get-run_duration vec) (vector-ref vec 12))
(define-inline (db:test-get-final_logf   vec) (vector-ref vec 13))
(define-inline (db:test-get-comment      vec) (vector-ref vec 14))

(define (db-get-tests-for-run db run-id)
  (let ((res '()))


    (sqlite3:for-each-row 
     (lambda (id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment)
       (set! res (cons (vector id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment) res)))
     db 
     "SELECT id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment FROM tests WHERE run_id=? ORDER BY id DESC;"
     run-id)
    res))

(define (db:delete-test-step-records db run-id test-name)
  (sqlite3:execute db "DELETE FROM test_steps WHERE test_id in (SELECT id FROM tests WHERE run_id=? AND testname=?);" run-id test-name))

(define (db:get-count-tests-running db)
  (let ((res 0))







|
|
>
>




|
|







169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
(define-inline (db:test-get-uname        vec) (vector-ref vec 9))
(define-inline (db:test-get-rundir       vec) (vector-ref vec 10))
(define-inline (db:test-get-item-path    vec) (vector-ref vec 11))
(define-inline (db:test-get-run_duration vec) (vector-ref vec 12))
(define-inline (db:test-get-final_logf   vec) (vector-ref vec 13))
(define-inline (db:test-get-comment      vec) (vector-ref vec 14))

(define (db-get-tests-for-run db run-id . params)
  (let ((res '())
	(testpatt (if (or (null? params)(not (car params))) "%" (car params)))
	(itempatt (if (> (length params) 1)(cadr params) "%")))
    (sqlite3:for-each-row 
     (lambda (id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment)
       (set! res (cons (vector id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment) res)))
     db 
     "SELECT id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment FROM tests WHERE run_id=? AND testname like ? AND item_path LIKE ? ORDER BY id DESC;"
     run-id testpatt (if itempatt itempatt "%"))
    res))

(define (db:delete-test-step-records db run-id test-name)
  (sqlite3:execute db "DELETE FROM test_steps WHERE test_id in (SELECT id FROM tests WHERE run_id=? AND testname=?);" run-id test-name))

(define (db:get-count-tests-running db)
  (let ((res 0))

Modified megatest.scm from [af51a420cc] to [864689325a].

7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
..
35
36
37
38
39
40
41


42
43
44
45
46
47
48
..
65
66
67
68
69
70
71


72
73
74
75
76
77
78
...
107
108
109
110
111
112
113


114
115
116
117
118
119
120
...
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;;  PURPOSE.

(include "common.scm")
(define megatest-version 1.01)

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

Usage: megatest [options]
  -h                      : this help

Process and test running
................................................................................
Run data
  :runname                : required, name for this particular test run
  :state                  : required if updating step state; e.g. start, end, completed
  :status                 : required if updating step status; e.g. pass, fail, n/a

Queries
  -list-runs patt         : list runs matching pattern \"patt\", % is the wildcard


  -showkeys               : show the keys used in this megatest setup

Misc 
  -force                  : override some checks
  -xterm                  : start an xterm instead of launching the test

Helpers
................................................................................
			"-step"
			":runname"   
			":item"
			":runname"   
			":state"  
			":status"
			"-list-runs"


			"-setlog"
			"-runstep"
			"-logpro"
			"-remove-run"
			) 
		 (list  "-h"
		        "-force"
................................................................................
;;======================================================================

(if (args:get-arg "-list-runs")
    (let* ((db       (begin
		       (setup-for-run)
		       (open-db)))
	   (runpatt  (args:get-arg "-list-runs"))


	   (runsdat  (db-get-runs db runpatt))
	   (runs     (db:get-rows runsdat))
	   (header   (db:get-header runsdat))
	   (keys     (db-get-keys db))
	   (keynames (map key:get-fieldname keys)))
      ;; Each run
      (for-each 
................................................................................
	 (print "Run: "
		(string-intersperse (map (lambda (x)
					   (db-get-value-by-header run header x))
					 keynames) "/")
		"/"
		(db-get-value-by-header run header "runname"))
	 (let ((run-id (db-get-value-by-header run header "id")))
	   (let ((tests (db-get-tests-for-run db run-id)))
	     ;; Each test
	     (for-each 
	      (lambda (test)
		(format #t
			"  Test: ~25a State: ~15a Status: ~15a Runtime: ~5@as Time: ~22a Host: ~10a\n"
			(conc (db:test-get-testname test)
			      (if (equal? (db:test-get-item-path test) "")







|







 







>
>







 







>
>







 







>
>







 







|







7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
..
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
..
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
...
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
...
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;;  PURPOSE.

(include "common.scm")
(define megatest-version 1.01)

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

Usage: megatest [options]
  -h                      : this help

Process and test running
................................................................................
Run data
  :runname                : required, name for this particular test run
  :state                  : required if updating step state; e.g. start, end, completed
  :status                 : required if updating step status; e.g. pass, fail, n/a

Queries
  -list-runs patt         : list runs matching pattern \"patt\", % is the wildcard
  -testpatt patt          : in list-runs show only these tests, % is the wildcard
  -itempatt patt          : in list-runs show only tests with items that match patt
  -showkeys               : show the keys used in this megatest setup

Misc 
  -force                  : override some checks
  -xterm                  : start an xterm instead of launching the test

Helpers
................................................................................
			"-step"
			":runname"   
			":item"
			":runname"   
			":state"  
			":status"
			"-list-runs"
			"-testpatt" 
			"-itempatt"
			"-setlog"
			"-runstep"
			"-logpro"
			"-remove-run"
			) 
		 (list  "-h"
		        "-force"
................................................................................
;;======================================================================

(if (args:get-arg "-list-runs")
    (let* ((db       (begin
		       (setup-for-run)
		       (open-db)))
	   (runpatt  (args:get-arg "-list-runs"))
	   (testpatt (args:get-arg "-testpatt"))
	   (itempatt (args:get-arg "-itempatt"))
	   (runsdat  (db-get-runs db runpatt))
	   (runs     (db:get-rows runsdat))
	   (header   (db:get-header runsdat))
	   (keys     (db-get-keys db))
	   (keynames (map key:get-fieldname keys)))
      ;; Each run
      (for-each 
................................................................................
	 (print "Run: "
		(string-intersperse (map (lambda (x)
					   (db-get-value-by-header run header x))
					 keynames) "/")
		"/"
		(db-get-value-by-header run header "runname"))
	 (let ((run-id (db-get-value-by-header run header "id")))
	   (let ((tests (db-get-tests-for-run db run-id testpatt itempatt)))
	     ;; Each test
	     (for-each 
	      (lambda (test)
		(format #t
			"  Test: ~25a State: ~15a Status: ~15a Runtime: ~5@as Time: ~22a Host: ~10a\n"
			(conc (db:test-get-testname test)
			      (if (equal? (db:test-get-item-path test) "")