Megatest

Check-in [c4edfbcd13]
Login
Overview
Comment:Added pattern selectors for use with -list-runs
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: c4edfbcd138fdc64a1b442baeb373527a2daff42
User & Date: mrwellan on 2011-05-04 23:48:00
Other Links: manifest | tags
Context
2011-05-05
01:37
Fixed -m missing from args check-in: e0413b29e1 user: matt tags: trunk
2011-05-04
23:48
Added pattern selectors for use with -list-runs check-in: c4edfbcd13 user: mrwellan tags: trunk
08:22
Placeholder for remove-runs check-in: cf78fcded0 user: matt tags: trunk
Changes

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].

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
;; Copyright 2006-2011, 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.

(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













|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
;; Copyright 2006-2011, 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.

(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
35
36
37
38
39
40
41


42
43
44
45
46
47
48
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







>
>







35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
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
65
66
67
68
69
70
71


72
73
74
75
76
77
78
			"-step"
			":runname"   
			":item"
			":runname"   
			":state"  
			":status"
			"-list-runs"


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







>
>







67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
			"-step"
			":runname"   
			":item"
			":runname"   
			":state"  
			":status"
			"-list-runs"
			"-testpatt" 
			"-itempatt"
			"-setlog"
			"-runstep"
			"-logpro"
			"-remove-run"
			) 
		 (list  "-h"
		        "-force"
107
108
109
110
111
112
113


114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
;;======================================================================

(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 
       (lambda (run)
	 (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) "")







>
>















|







111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
;;======================================================================

(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 
       (lambda (run)
	 (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) "")