Index: common.scm
==================================================================
--- common.scm
+++ common.scm
@@ -646,11 +646,13 @@
;; hash-table tree to html list tree
;;
;; tipfunc takes two parameters: y the tip value and path the path to that point
;;
(define (common:htree->html ht path tipfunc)
- (let ((datlist (hash-table->alist ht)))
+ (let ((datlist (sort (hash-table->alist ht)
+ (lambda (a b)
+ (string< (car a)(car b))))))
(if (null? datlist)
(tipfunc #f path) ;; really shouldn't get here
(s:ul
(map (lambda (x)
(let* ((levelname (car x))
Index: megatest.scm
==================================================================
--- megatest.scm
+++ megatest.scm
@@ -169,10 +169,11 @@
multiple sheets)
-o : output file for refdb2dat (defaults to stdout)
-archive cmd : archive runs specified by selectors to one of disks specified
in the [archive-disks] section.
cmd: keep-html, restore, save, save-remove
+ -generate-html : create a simple html tree for browsing your runs
Spreadsheet generation
-extract-ods fname.ods : extract an open document spreadsheet from the database
-pathmod path : insert path, i.e. path/runame/itempath/logfile.html
will clear the field if no rundir/testname/itempath/logfile
@@ -284,10 +285,11 @@
"-lock"
"-unlock"
"-list-servers"
"-run-wait" ;; wait on a run to complete (i.e. no RUNNING)
"-local" ;; run some commands using local db access
+ "-generate-html"
;; misc queries
"-list-disks"
"-list-targets"
"-list-db-targets"
@@ -2001,10 +2003,17 @@
(db:multi-db-sync
#f ;; do all run-ids
'new2old
)
(set! *didsomething* #t)))
+
+(if (args:get-arg "-generate-html")
+ (let* ((toppath (launch:setup)))
+ (if (tests:create-html-tree #f)
+ (debug:print-info 0 *default-log-port* "HTML output created in " toppath "/lt/runs-index.html")
+ (debug:print 0 *default-log-port* "Failed to create HTML output in " toppath "/lt/runs-index.html"))
+ (set! *didsomething* #t)))
;;======================================================================
;; Exit and clean up
;;======================================================================
Index: tests.scm
==================================================================
--- tests.scm
+++ tests.scm
@@ -649,11 +649,11 @@
(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))
+ (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))
@@ -674,77 +674,100 @@
(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)
+ (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"))
- (testdats (rmt:get-tests-for-run
- run-id "%" ;; testnamepatt
+ (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)))
- (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))))))))))
+ #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
;;