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) "")
|