1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
|
;; Copyright 2006-2012, 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")
;; (include "megatest-version.scm")
;; fake out readline usage of toplevel-command
(define (toplevel-command . a) #f)
(use sqlite3 srfi-1 posix regex regex-case srfi-69 base64 readline apropos json http-client directory-utils rpc ;; (srfi 18) extras)
http-client srfi-18 extras format) ;; zmq extras)
|
>
>
>
>
|
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
|
;; Copyright 2006-2012, 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")
;; (include "megatest-version.scm")
(define (toplevel-command . a) #f)
(define (toplevel-command . a) #f)
;; fake out readline usage of toplevel-command
(define (toplevel-command . a) #f)
(use sqlite3 srfi-1 posix regex regex-case srfi-69 base64 readline apropos json http-client directory-utils rpc ;; (srfi 18) extras)
http-client srfi-18 extras format) ;; zmq extras)
|
︙ | | | ︙ | |
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
|
license GPL, Copyright Matt Welland 2006-2015
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)
-lock : lock run specified by target and runname
-unlock : unlock run specified by target and runname
-set-run-status status : sets status for run to status, requires -target and -runname
|
|
<
<
|
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
|
license GPL, Copyright Matt Welland 2006-2015
Usage: megatest [options]
-h : this help
-version : print megatest version (currently " megatest-version ")
Launching and managing runs
-runall : run all tests or as specified by -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)
-lock : lock run specified by target and runname
-unlock : unlock run specified by target and runname
-set-run-status status : sets status for run to status, requires -target and -runname
|
︙ | | | ︙ | |
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
|
"-show-config"
"-show-cmdinfo"
"-get-run-status"
;; queries
"-test-paths" ;; get path(s) to a test, ordered by youngest first
"-runall" ;; run all tests
"-remove-runs"
"-rebuild-db"
"-cleanup-db"
"-rollup"
"-update-meta"
"-gen-megatest-area"
"-mark-incompletes"
|
|
>
|
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
|
"-show-config"
"-show-cmdinfo"
"-get-run-status"
;; queries
"-test-paths" ;; get path(s) to a test, ordered by youngest first
"-runall" ;; run all tests, respects -testpatt
"-run" ;; alias for -runall
"-remove-runs"
"-rebuild-db"
"-cleanup-db"
"-rollup"
"-update-meta"
"-gen-megatest-area"
"-mark-incompletes"
|
︙ | | | ︙ | |
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
|
(args:get-arg "-get-run-status"))
(general-run-call
"-set-run-status"
"set run status"
(lambda (target runname keys keyvals)
(let* ((runsdat (rmt:get-runs-by-patt keys runname
(common:args-get-target)
#f #f))
(header (vector-ref runsdat 0))
(rows (vector-ref runsdat 1)))
(if (null? rows)
(begin
(debug:print-info 0 "No matching run found.")
(exit 1))
(let* ((row (car (vector-ref runsdat 1)))
|
|
|
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
|
(args:get-arg "-get-run-status"))
(general-run-call
"-set-run-status"
"set run status"
(lambda (target runname keys keyvals)
(let* ((runsdat (rmt:get-runs-by-patt keys runname
(common:args-get-target)
#f #f #f))
(header (vector-ref runsdat 0))
(rows (vector-ref runsdat 1)))
(if (null? rows)
(begin
(debug:print-info 0 "No matching run found.")
(exit 1))
(let* ((row (car (vector-ref runsdat 1)))
|
︙ | | | ︙ | |
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
|
(let* ((dbstruct (make-dbr:dbstruct path: (megatest:area-path *area-dat*) local: #t))
(runpatt (args:get-arg "-list-runs"))
(testpatt (if (args:get-arg "-testpatt")
(args:get-arg "-testpatt")
"%"))
(keys (db:get-keys dbstruct))
;; (runsda t (db:get-runs dbstruct runpatt #f #f '()))
(runsdat (rmt:get-runs-by-patt keys (or runpatt "%") (common:args-get-target)
#f #f '("id" "runname" "state" "status" "owner" "event_time" "comment")))
(runstmp (db:get-rows runsdat))
(header (db:get-header runsdat))
(runs (if (and (not (null? runstmp))
(args:get-arg "-since"))
(let ((changed-ids (db:get-changed-run-ids (string->number (args:get-arg "-since")))))
(let loop ((hed (car runstmp))
|
|
|
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
|
(let* ((dbstruct (make-dbr:dbstruct path: (megatest:area-path *area-dat*) local: #t))
(runpatt (args:get-arg "-list-runs"))
(testpatt (if (args:get-arg "-testpatt")
(args:get-arg "-testpatt")
"%"))
(keys (db:get-keys dbstruct))
;; (runsda t (db:get-runs dbstruct runpatt #f #f '()))
(runsdat (db:get-runs-by-patt dbstruct keys (or runpatt "%") (common:args-get-target)
#f #f '("id" "runname" "state" "status" "owner" "event_time" "comment")))
(runstmp (db:get-rows runsdat))
(header (db:get-header runsdat))
(runs (if (and (not (null? runstmp))
(args:get-arg "-since"))
(let ((changed-ids (db:get-changed-run-ids (string->number (args:get-arg "-since")))))
(let loop ((hed (car runstmp))
|
︙ | | | ︙ | |
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
|
(db-targets (args:get-arg "-list-db-targets"))
(seen (make-hash-table))
(dmode (let ((d (args:get-arg "-dumpmode")))
(if d (string->symbol d) #f)))
(data (make-hash-table))
(fields-spec (if (args:get-arg "-fields")
(extract-fields-constraints (args:get-arg "-fields"))
(list (list "runs" "id" "target" "runname")
(cons "tests" db:test-record-fields) ;; "id" "testname" "test_path")
(list "steps" "id" "stepname"))))
(runs-spec (let ((r (alist-ref "runs" fields-spec equal?)))
(if (and r (not (null? r))) r (list "id"))))
(tests-spec (let ((t (alist-ref "tests" fields-spec equal?)))
(if (and t (null? t)) ;; all fields
db:test-record-fields
t)))
(adj-tests-spec (delete-duplicates (if tests-spec (cons "id" tests-spec) db:test-record-fields))) ;; '("id"))))
(steps-spec (alist-ref "steps" fields-spec equal?))
(test-field-index (make-hash-table)))
|
|
|
|
|
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
|
(db-targets (args:get-arg "-list-db-targets"))
(seen (make-hash-table))
(dmode (let ((d (args:get-arg "-dumpmode")))
(if d (string->symbol d) #f)))
(data (make-hash-table))
(fields-spec (if (args:get-arg "-fields")
(extract-fields-constraints (args:get-arg "-fields"))
(list (cons "runs" (append keys (list "id" "runname" "state" "status" "owner" "event_time" "comment" "fail_count" "pass_count")))
(cons "tests" db:test-record-fields) ;; "id" "testname" "test_path")
(list "steps" "id" "stepname"))))
(runs-spec (let ((r (alist-ref "runs" fields-spec equal?))) ;; the check is now unnecessary
(if (and r (not (null? r))) r (list "id" ))))
(tests-spec (let ((t (alist-ref "tests" fields-spec equal?)))
(if (and t (null? t)) ;; all fields
db:test-record-fields
t)))
(adj-tests-spec (delete-duplicates (if tests-spec (cons "id" tests-spec) db:test-record-fields))) ;; '("id"))))
(steps-spec (alist-ref "steps" fields-spec equal?))
(test-field-index (make-hash-table)))
|
︙ | | | ︙ | |
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
|
(db:get-value-by-header run header x))
keys) "/")))
(if db-targets
(if (not (hash-table-ref/default seen targetstr #f))
(begin
(hash-table-set! seen targetstr #t)
;; (print "[" targetstr "]"))))
(if (not dmode)(print targetstr))))
(let* ((run-id (db:get-value-by-header run header "id"))
(runname (db:get-value-by-header run header "runname"))
(tests (if tests-spec
(rmt:get-tests-for-run run-id testpatt '() '() #f #f #f 'testname 'asc
;; use qryvals if test-spec provided
(if tests-spec
(string-intersperse adj-tests-spec ",")
;; db:test-record-fields
#f))
'())))
(case dmode
|
|
>
>
>
|
|
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
|
(db:get-value-by-header run header x))
keys) "/")))
(if db-targets
(if (not (hash-table-ref/default seen targetstr #f))
(begin
(hash-table-set! seen targetstr #t)
;; (print "[" targetstr "]"))))
(if (not dmode)
(print targetstr)
(hash-table-set! data "targets" (cons targetstr (hash-table-ref/default data "targets" '())))
)))
(let* ((run-id (db:get-value-by-header run header "id"))
(runname (db:get-value-by-header run header "runname"))
(tests (if tests-spec
(db:get-tests-for-run dbstruct run-id testpatt '() '() #f #f #f 'testname 'asc
;; use qryvals if test-spec provided
(if tests-spec
(string-intersperse adj-tests-spec ",")
;; db:test-record-fields
#f))
'())))
(case dmode
|
︙ | | | ︙ | |
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
|
;; 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 keyvals)
(runs:run-tests target
runname
(args:get-arg "-testpatt")
|
|
|
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
|
;; 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")(args:get-arg "-run"))
(general-run-call
"-runall"
"run all tests"
(lambda (target runname keys keyvals)
(runs:run-tests target
runname
(args:get-arg "-testpatt")
|
︙ | | | ︙ | |