647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
|
;; (tests:create-html-tree "test-index.html")
;;
(define (tests:create-html-tree outf)
(let* ((lockfile (conc outf ".lock"))
(runs-to-process '()))
(if (common:simple-file-lock lockfile)
(let* ((linktree (common:get-linktree))
(oup (open-output-file outf))
(area-name (common:get-testsuite-name))
(keys (rmt:get-keys))
(numkeys (length keys))
(runsdat (rmt:get-runs "%" #f #f (map (lambda (x)(list x "%")) keys)))
(header (vector-ref runsdat 0))
(runs (vector-ref runsdat 1))
(runtreedat (map (lambda (x)
|
|
|
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
|
;; (tests:create-html-tree "test-index.html")
;;
(define (tests:create-html-tree outf)
(let* ((lockfile (conc outf ".lock"))
(runs-to-process '()))
(if (common:simple-file-lock lockfile)
(let* ((linktree (common:get-linktree))
(oup (open-output-file (or outf (conc linktree "/runs-index.html"))))
(area-name (common:get-testsuite-name))
(keys (rmt:get-keys))
(numkeys (length keys))
(runsdat (rmt:get-runs "%" #f #f (map (lambda (x)(list x "%")) keys)))
(header (vector-ref runsdat 0))
(runs (vector-ref runsdat 1))
(runtreedat (map (lambda (x)
|
672
673
674
675
676
677
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
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
|
;; top list
(s:ul 'id "LinkedList1" 'class "LinkedList"
(s:li
"Runs"
(common:htree->html runs-htree
'()
(lambda (x p)
(let ((targpath (string-intersperse p "/"))
(runname (car (reverse p))))
(s:a runname 'href (conc targpath "/runsummary.html"))))
))))))
(close-output-port oup)
(testdats (rmt:get-tests-for-run
run-id "%" ;; testnamepatt
#f)))
(print "testdats: " testdats)))
runs)
#t)
#f)))
;; (let* ((outputfilename (conc "megatest-rollup-" test-name ".html"))
;; (orig-dir (current-directory))
;; (logf-info (rmt:test-get-logfile-info run-id test-name))
;; (logf (if logf-info (cadr logf-info) #f))
;; (path (if logf-info (car logf-info) #f)))
;; ;; This query finds the path and changes the directory to it for the test
;; (if (and (string? path)
;; (directory? path)) ;; can get #f here under some wierd conditions. why, unknown ...
;; (begin
;; (debug:print 4 *default-log-port* "Found path: " path)
;; (change-directory path))
;; ;; (set! outputfilename (conc path "/" outputfilename)))
;; (debug:print-error 0 *default-log-port* "summarize-items for run-id=" run-id ", test-name=" test-name ", no such path: " path))
;; (debug:print 4 *default-log-port* "summarize-items with logf " logf ", outputfilename " outputfilename " and force " force)
;; (if (or (equal? logf "logs/final.log")
;; (equal? logf outputfilename)
;; force)
;; (let ((my-start-time (current-seconds))
;; (lockf (conc outputfilename ".lock")))
;; (let loop ((have-lock (common:simple-file-lock lockf)))
;; (if have-lock
;; (let ((script (configf:lookup *configdat* "testrollup" test-name)))
;; (print "Obtained lock for " outputfilename)
;; ;; (rmt:top-test-set-per-pf-counts run-id test-name)
;; (rmt:roll-up-pass-fail-counts run-id test-name "" #f #f)
;; (rmt:top-test-set-per-pf-counts run-id test-name)
;; (if script
;; (system (conc script " > " outputfilename " & "))
;; (tests:generate-html-summary-for-iterated-test run-id test-id test-name outputfilename))
;; (change-directory orig-dir)
;; ;; NB// tests:test-set-toplog! is remote internal...
;; (tests:test-set-toplog! run-id test-name outputfilename))
;; ;; didn't get the lock, check to see if current update started later than this
;; ;; update, if so we can exit without doing any work
;; (if (> my-start-time (file-modification-time lockf))
;; ;; we started since current re-gen in flight, delay a little and try again
;; (begin
;; (debug:print-info 1 *default-log-port* "Waiting to update " outputfilename ", another test currently updating it")
;; (thread-sleep! (+ 5 (random 5))) ;; delay between 5 and 10 seconds
;; (loop (common:simple-file-lock lockf))))))))))
|
|
>
|
>
>
>
|
>
>
|
|
>
|
>
|
|
|
>
>
>
>
>
|
|
>
>
>
>
>
>
>
|
|
<
<
<
<
<
<
|
<
|
<
<
|
<
<
<
>
>
|
>
>
|
<
<
>
>
>
|
|
|
|
|
|
>
>
>
|
|
|
<
>
>
>
|
>
|
>
|
<
<
|
<
>
|
|
>
>
>
>
>
>
|
<
|
672
673
674
675
676
677
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
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
|
;; top list
(s:ul 'id "LinkedList1" 'class "LinkedList"
(s:li
"Runs"
(common:htree->html runs-htree
'()
(lambda (x p)
(let* ((targ-path (string-intersperse p "/"))
(full-path (conc linktree "/" targ-path))
(run-name (car (reverse p))))
(if (and (file-exists? full-path)
(directory? full-path)
(file-write-access? full-path))
(s:a run-name 'href (conc targ-path "/run-summary.html"))
(begin
(debug:print 0 *default-log-port* "INFO: Can't create " targ-path "/run-summary.html")
(conc run-name " (Not able to create summary at " targ-path ")")))))))))))
(close-output-port oup)
(common:simple-file-release-lock lockfile)
(for-each
(lambda (run)
(let* ((test-subpath (tests:run-record->test-path run numkeys))
(run-id (db:get-value-by-header run header "id"))
(run-dir (tests:run-record->test-path run numkeys))
(test-dats (rmt:get-tests-for-run
run-id
"%/" ;; testnamepatt
'() ;; states
'() ;; statuses
#f ;; offset
#f ;; num-to-get
#f ;; hide/not-hide
#f ;; sort-by
#f ;; sort-order
#f ;; 'shortlist ;; qrytype
0 ;; last update
#f))
(tests-tree-dat (map (lambda (test-dat)
;; (tests:run-record->test-path x numkeys))
(let* ((test-name (db:test-get-testname test-dat))
(item-path (db:test-get-item-path test-dat))
(full-name (db:test-make-full-name test-name item-path))
(path-parts (string-split full-name)))
path-parts))
test-dats))
(tests-htree (common:list->htree tests-tree-dat))
(html-dir (conc linktree "/" (string-intersperse run-dir "/")))
(html-path (conc html-dir "/run-summary.html"))
(oup (if (and (file-exists? html-dir)
(directory? html-dir)
(file-write-access? html-dir))
(open-output-file html-path)
#f)))
;; (print "run-dir: " run-dir ", tests-tree-dat: " tests-tree-dat)
(if oup
(begin
(s:output-new
oup
(s:html tests:css-jscript-block
(s:title "Summary for " area-name)
(s:body 'onload "addEvents();"
(s:h1 "Summary for " (string-intersperse run-dir "/"))
;; top list
(s:ul 'id "LinkedList1" 'class "LinkedList"
(s:li
"Tests"
(common:htree->html tests-htree
'()
(lambda (x p)
(let* ((targ-path (string-intersperse p "/"))
(test-name (car p))
(item-path ;; (if (> (length p) 2) ;; test-name + run-name
(string-intersperse p "/"))
(full-targ (conc html-dir "/" targ-path))
(std-file (conc full-targ "/test-summary.html"))
(alt-file (conc full-targ "/megatest-rollup-" test-name ".html"))
(html-file (if (file-exists? alt-file)
alt-file
std-file))
(run-name (car (reverse p))))
(if (and (not (file-exists? full-targ))
(directory? full-targ)
(file-write-access? full-targ))
(tests:summarize-test
run-id
(rmt:get-test-id run-id test-name item-path)))
(if (file-exists? full-targ)
(s:a run-name 'href html-file)
(begin
(debug:print 0 *default-log-port* "ERROR: can't access " full-targ)
(conc "No summary for " run-name)))))
))))))
(close-output-port oup)))))
runs)
#t)
#f)))
;; CHECK - WAS THIS ADDED OR REMOVED? MANUAL MERGE WITH API STUFF!!!
;;
;; get a pretty table to summarize steps
;;
;; (define (dcommon:process-steps-table steps);; db test-id #!key (work-area #f))
(define (tests:process-steps-table steps);; db test-id #!key (work-area #f))
|