| ︙ | | |
13
14
15
16
17
18
19
20
21
22
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
|
13
14
15
16
17
18
19
20
21
22
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
|
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
;; strftime('%m/%d/%Y %H:%M:%S','now','localtime')
(use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 (srfi 18)
posix-extras directory-utils pathname-expand typed-records format sxml-serializer
sxml-modifications matchable)
(declare (unit runs))
(declare (uses db))
(declare (uses common))
(declare (uses items))
(declare (uses runconfig))
(declare (uses tests))
(declare (uses server))
(declare (uses mt))
(declare (uses archive))
;; (declare (uses filedb))
(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(include "test_records.scm")
;; (use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 (srfi 18)
;; posix-extras directory-utils pathname-expand typed-records format sxml-serializer
;; sxml-modifications matchable)
;;
;; (declare (unit runs))
;; (declare (uses db))
;; (declare (uses common))
;; (declare (uses items))
;; (declare (uses runconfig))
;; (declare (uses tests))
;; (declare (uses server))
;; (declare (uses mt))
;; (declare (uses archive))
;; ;; (declare (uses filedb))
;;
;; (include "common_records.scm")
;; (include "key_records.scm")
;; (include "db_records.scm")
;; (include "run_records.scm")
;; (include "test_records.scm")
;;
;; (include "debugger.scm")
;; use this struct to facilitate refactoring
;;
(defstruct runs:dat
reglen regfull
|
| ︙ | | |
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
|
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
|
-
+
|
(rtime 0)
(startt (current-seconds))
(endt (+ startt duration)))
((or proc runs:parallel-runners-mgmt) rdat)
(let loop ()
(let* ((wstart (current-seconds)))
(if (< wstart endt)
(let* ((work-time (random 10)))
(let* ((work-time (pseudo-random-integer 10)))
#;(debug:print-info 0 *default-log-port* "working for " work-time
" seconds. Total work: " rtime ", elapsed time: " (- wstart startt))
(thread-sleep! work-time)
(set! rtime (+ rtime work-time))
((or proc runs:parallel-runners-mgmt) rdat)
(loop)))))
(let* ((done-time (current-seconds)))
|
| ︙ | | |
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
|
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
|
-
+
|
(define (runs:run-tests target runname test-patts user flags #!key (run-count 1)) ;; test-names
(let* ((keys (keys:config-get-fields *configdat*))
(keyvals (keys:target->keyval keys target))
(run-id (rmt:register-run keyvals runname "new" "n/a" user (args:get-arg "-contour"))) ;; test-name)))
;; (deferred '()) ;; delay running these since they have a waiton clause
(runconfigf (conc *toppath* "/runconfigs.config"))
(dbfile (conc *toppath* "/megatest.db"))
(readonly-mode (not (file-write-access? dbfile)))
(readonly-mode (not (file-writable? dbfile)))
(test-records (make-hash-table))
;; need to process runconfigs before generating these lists
(all-tests-registry #f) ;; (tests:get-all)) ;; (tests:get-valid-tests (make-hash-table) test-search-path)) ;; all valid tests to check waiton names
(all-test-names #f) ;; (hash-table-keys all-tests-registry))
(test-names #f) ;; Generated by a call to (tests:filter-test-names all-test-names test-patts))
(required-tests #f) ;; Put fully qualified test/testpath names in this list to be done
(waitors-upon (make-hash-table)) ;; given a test, return list of tests waiting upon this test.
|
| ︙ | | |
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
|
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
|
-
+
|
;; If no resources are available just kill time and loop again
;;
((not have-resources) ;; simply try again after waiting a second
(if (runs:lownoise "no resources" 60)
(debug:print-info 1 *default-log-port* "no resources to run new tests, waiting ..."))
;; Have gone back and forth on this but db starvation is an issue.
;; wait one second before looking again to run jobs.
(thread-sleep! 0.25)
(thread-sleep! 0.253)
;; could have done hed tal here but doing car/cdr of newtal to rotate tests
(list (car newtal)(cdr newtal) reg reruns))
;; This is the final stage, everything is in place so launch the test
;;
((and have-resources
(or (null? prereqs-not-met)
|
| ︙ | | |
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
|
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
|
-
+
|
(rp-mutex (make-mutex))
(bup-mutex (make-mutex))
(keep-records (args:get-arg "-keep-records")) ;; used in conjunction with -remove-runs to keep the records, TODO: consolidate this with "mode".
(test-records '())) ;; for tasks that we wish to operate on all tests in one fell swoop
(let* ((write-access-actions '(remove-runs set-state-status archive run-wait kill-runs))
(dbfile (conc *toppath* "/megatest.db"))
(readonly-mode (not (file-write-access? dbfile))))
(readonly-mode (not (file-writable? dbfile))))
(when (and readonly-mode
(member action write-access-actions))
(debug:print-error 0 *default-log-port* "megatest.db is readonly. Cannot proceed with action ["action"] in which write-access isrequired .")
(exit 1)))
(debug:print-info 4 *default-log-port* "runs:operate-on => Header: " header " action: " action " new-state-status: " new-state-status)
(if (> 2 (length state-status))
|
| ︙ | | |
2563
2564
2565
2566
2567
2568
2569
2570
2571
2572
2573
2574
2575
2576
2577
|
2563
2564
2565
2566
2567
2568
2569
2570
2571
2572
2573
2574
2575
2576
2577
|
-
+
|
(if (and (not (string= rundir "/tmp/badname"))
(file-exists? rundir)
(substring-index run-name rundir)
(tests:glob-like-match (conc "%/" target "/%") rundir)
)
(begin
(set! lasttpath (db:test-get-rundir new-test-dat)) ;; remember this path for run removal
(set! lastrealpath (remove-last-path-directory (resolve-pathname lasttpath)))
(set! lastrealpath (remove-last-path-directory (realpath lasttpath)))
(hash-table-set! run-paths-hash lastrealpath 1)
(runs:remove-test-directory new-test-dat mode) ;; 'remove-all)
)
(begin
(debug:print 2 *default-log-port* "Not removing directory " rundir " because either it doesn't exist or has a bad name")
(debug:print 2 *default-log-port* "Is /tmp/badname: " (string= rundir "/tmp/badname"))
(debug:print 2 *default-log-port* "Exists: " (file-exists? rundir))
|
| ︙ | | |
2731
2732
2733
2734
2735
2736
2737
2738
2739
2740
2741
2742
2743
2744
2745
|
2731
2732
2733
2734
2735
2736
2737
2738
2739
2740
2741
2742
2743
2744
2745
|
-
+
|
((remove-data-only)(mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "CLEANING" "LOCKED" #f))
((remove-all) (mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "REMOVING" "LOCKED" #f))
((archive-remove) (mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "ARCHIVE_REMOVING" #f #f)))
(debug:print-info 1 *default-log-port* "Attempting to remove " (if real-dir (conc " dir " real-dir " and ") "") " link " run-dir)
(if (and real-dir
(> (string-length real-dir) 5)
(common:file-exists? real-dir)) ;; bad heuristic but should prevent /tmp /home etc.
(let* ((realpath (resolve-pathname run-dir)))
(let* ((realpath (realpath run-dir)))
(debug:print-info 1 *default-log-port* "Recursively removing " realpath)
(if (common:file-exists? realpath)
(runs:safe-delete-test-dir realpath)
(debug:print 0 *default-log-port* "WARNING: test dir " realpath " appears to not exist or is not readable")))
(if real-dir
(debug:print 0 *default-log-port* "WARNING: directory " real-dir " does not exist")
(debug:print 0 *default-log-port* "WARNING: no real directory corrosponding to link " run-dir ", nothing done")))
|
| ︙ | | |
2957
2958
2959
2960
2961
2962
2963
2964
2965
2966
2967
2968
2969
2970
2971
2972
|
2957
2958
2959
2960
2961
2962
2963
2964
2965
2966
2967
2968
2969
2970
2971
|
-
-
+
|
(define doc-template
'(*TOP*
(*PI* xml "version='1.0'")
(testsuite)))
(define (runs:update-junit-test-reporter-xml run-id)
(let* (
(junit-test-reporter (configf:lookup *configdat* "runs" "junit-test-reporter-xml"))
|
| ︙ | | |
3001
3002
3003
3004
3005
3006
3007
3008
3009
3010
3011
3012
3013
3014
3015
3016
3017
3018
3019
3020
3021
3022
3023
3024
3025
3026
3027
3028
3029
3030
3031
3032
3033
3034
3035
3036
3037
|
3000
3001
3002
3003
3004
3005
3006
3007
3008
3009
3010
3011
3012
3013
3014
3015
3016
3017
3018
3019
3020
3021
3022
3023
3024
3025
3026
3027
3028
3029
3030
3031
3032
3033
3034
3035
3036
|
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
|
(test-itempath (vector-ref test 11))
(tc-name (conc test-name (if (and test-itempath (not (equal? test-itempath ""))) (conc "." (string-translate test-itempath "/" "." )) "")))
(test-state (vector-ref test 3))
(comment (vector-ref test 14))
(test-status (vector-ref test 4))
(exc-msg (conc "No bucket for State " test-state " Status " test-status))
(new-doc (cond
((member test-state (list "RUNNING" ))
((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (inProgress)))) doc))
((member test-state (list "LAUNCHED" "REMOTEHOSTSTART" "NOT_STARTED"))
((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (inQueue)))) doc))
((member test-status (list "PASS" "WARN" "WAIVED"))
((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name))))) doc))
((member test-status (list "FAIL" "CHECK"))
((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (failure (@ (message ,comment) (type "failure")))))) doc))
((member test-status (list "DEAD" "KILLED" "ABORT" "PREQ_FAIL" "PREQ_DISCARDED"))
((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (failure (@ (message ,comment) (type "error")))))) doc))
((member test-status (list "SKIP"))
((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (skipped (@ (type "skipped")))))) doc))
(else
(debug:print 0 *default-log-port* (conc "What do I do with State " test-state " Status " test-status))
((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (failure (@ (message ,exc-msg) (type "error")))))) doc))))
(new-error-cnt (if (member test-status (list "DEAD" "KILLED" "ABORT" "PREQ_FAIL" "PREQ_DISCARDED"))
(+ error-cnt 1)
error-cnt))
(new-fail-cnt (if (member test-status (list "FAIL" "CHECK"))
(+ fail-cnt 1)
fail-cnt)))
((member test-state (list "RUNNING" ))
((modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (inProgress)))) doc))
((member test-state (list "LAUNCHED" "REMOTEHOSTSTART" "NOT_STARTED"))
((modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (inQueue)))) doc))
((member test-status (list "PASS" "WARN" "WAIVED"))
((modify `("testsuite" insert-into (testcase (@ (name ,tc-name))))) doc))
((member test-status (list "FAIL" "CHECK"))
((modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (failure (@ (message ,comment) (type "failure")))))) doc))
((member test-status (list "DEAD" "KILLED" "ABORT" "PREQ_FAIL" "PREQ_DISCARDED"))
((modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (failure (@ (message ,comment) (type "error")))))) doc))
((member test-status (list "SKIP"))
((modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (skipped (@ (type "skipped")))))) doc))
(else
(debug:print 0 *default-log-port* (conc "What do I do with State " test-state " Status " test-status))
((modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (failure (@ (message ,exc-msg) (type "error")))))) doc))))
(new-error-cnt (if (member test-status (list "DEAD" "KILLED" "ABORT" "PREQ_FAIL" "PREQ_DISCARDED"))
(+ error-cnt 1)
error-cnt))
(new-fail-cnt (if (member test-status (list "FAIL" "CHECK"))
(+ fail-cnt 1)
fail-cnt)))
(if (null? tail)
(let* ((final-doc ((sxml-modify `("testsuite" insert-into (@ (name ,xml-ts-name) (tests ,tests-count) (errors ,error-cnt) (failures ,fail-cnt)))) new-doc)))
(let* ((final-doc ((modify `("testsuite" insert-into (@ (name ,xml-ts-name) (tests ,tests-count) (errors ,error-cnt) (failures ,fail-cnt)))) new-doc)))
(debug:print 0 *default-log-port* "modify attrib error=" error-cnt " fail= " fail-cnt)
(handle-exceptions
exn
(let* ((msg ((condition-property-accessor 'exn 'message) exn)))
(debug:print 0 *default-log-port* (conc "WARNING: Failed to update file" xml-path". Message:" msg ", exn=" exn)))
(if (not (file-exists? xml-dir))
|
| ︙ | | |