Overview
Context
Changes
Modified megatest.scm
from [54431b021e]
to [bd2df667aa].
| ︙ | | |
9
10
11
12
13
14
15
16
17
18
19
20
21
22
|
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
|
+
|
;; (include "common.scm")
;; (include "megatest-version.scm")
(use sqlite3 srfi-1 posix regex regex-case srfi-69 base64 format readline apropos json http-client directory-utils) ;; (srfi 18) extras)
(import (prefix sqlite3 sqlite3:))
(import (prefix base64 base64:))
(require-library mutils)
;; (use zmq)
(declare (uses common))
(declare (uses megatest-version))
(declare (uses margs))
(declare (uses runs))
|
| ︙ | | |
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
|
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
|
-
+
+
+
+
-
-
-
+
+
+
+
+
+
+
+
+
-
+
-
+
-
-
-
+
+
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
(runsdat (cdb:remote-run db:get-runs-by-patt #f keys (if runpatt runpatt "%")
(if (args:get-arg "-list-runs")(common:args-get-target) #f)
#f #f))
;; (cdb:remote-run db:get-runs #f runpatt #f #f '()))
(runs (db:get-rows runsdat))
(header (db:get-header runsdat))
(db-targets (args:get-arg "-list-db-targets"))
(seen (make-hash-table)))
(seen (make-hash-table))
(dmode (let ((d (args:get-arg "-dumpmode")))
(if d (string->symbol d) #f)))
(data (make-hash-table)))
;; Each run
(for-each
(lambda (run)
(let ((targetstr (string-intersperse (map (lambda (x)
(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 "]"))))
(print targetstr))))
(if (not db-targets)
(let* ((run-id (db:get-value-by-header run header "id"))
(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 (mt:get-tests-for-run run-id testpatt '() '())))
(case dmode
((json)
(mutils:hierhash-set! data targetstr runname "meta" "status" (db:get-value-by-header run header "status"))
(mutils:hierhash-set! data targetstr runname "meta" "state" (db:get-value-by-header run header "state"))
(mutils:hierhash-set! data targetstr runname "meta" "id" (conc (db:get-value-by-header run header "id"))))
(else
(print "Run: " targetstr "/" (db:get-value-by-header run header "runname")
(print "Run: " targetstr "/" runname
" status: " (db:get-value-by-header run header "state")
" run-id: " run-id ", number tests: " (length tests))
" run-id: " run-id ", number tests: " (length tests))))
(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)
(conc "(" (db:test-get-item-path test) ")")))
(db:test-get-state test)
(db:test-get-status test)
(conc "(" (db:test-get-item-path test) ")"))))
(tstate (db:test-get-state test))
(tstatus (db:test-get-status test)))
(case dmode
((json)
(mutils:hierhash-set! data targetstr runname "data" (conc test-id) "tname" fullname)
(mutils:hierhash-set! data targetstr runname "data" (conc test-id) "state" tstate)
(mutils:hierhash-set! data targetstr runname "data" (conc test-id) "status" tstatus))
(else
(format #t
" Test: ~25a State: ~15a Status: ~15a Runtime: ~5@as Time: ~22a Host: ~10a\n"
fullname
tstate
tstatus
(db:test-get-run_duration test)
(db:test-get-event_time test)
(db:test-get-host test))
(if (not (or (equal? (db:test-get-status test) "PASS")
(equal? (db:test-get-status test) "WARN")
(equal? (db:test-get-state test) "NOT_STARTED")))
(begin
|
| ︙ | | |
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
|
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
|
-
+
+
|
(lambda (step)
(format #t
" Step: ~20a State: ~10a Status: ~10a Time ~22a\n"
(db:step-get-stepname step)
(db:step-get-state step)
(db:step-get-status step)
(db:step-get-event_time step)))
steps)))))
steps))))))))
tests)))))
runs)
(if (eq? dmode 'json)(json-write data))
(set! *didsomething* #t))))
;;======================================================================
;; full run
;;======================================================================
;; get lock in db for full run for this directory
|
| ︙ | | |