Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -620,10 +620,59 @@ (loop (max hed max-val) (car tal) (cdr tal)) (max hed max-val)))) +;; path list to hash-table tree +;; ((a b c)(a b d)(e b c)) => ((a (b (d) (c))) (e (b (c)))) +;; +(define (common:list->htree lst) + (let ((resh (make-hash-table))) + (for-each + (lambda (inlst) + (let loop ((ht resh) + (hed (car inlst)) + (tal (cdr inlst))) + (if (hash-table-ref/default ht hed #f) + (if (not (null? tal)) + (loop (hash-table-ref ht hed) + (car tal) + (cdr tal))) + (begin + (hash-table-set! ht hed (make-hash-table)) + (loop ht hed tal))))) + lst) + resh)) + +;; 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) + (s:ul + (map (lambda (x) + (let ((levelname (car x))) + (s:li + levelname + (let ((y (cdr x)) + (newpath (append path (list levelname)))) + ;; (print "levelname=" levelname " newpath=" newpath) + (if (hash-table? y) + (common:htree->html y newpath tipfunc) + (tipfunc y newpath)))))) + (hash-table->alist ht)))) + +;; hash-table tree to alist tree +;; +(define (common:htree->atree ht) + (map (lambda (x) + (cons (car x) + (let ((y (cdr x))) + (if (hash-table? y) + (common:htree->atree y) + y)))) + (hash-table->alist ht))) ;;====================================================================== ;; M U N G E D A T A I N T O N I C E F O R M S ;;====================================================================== Index: tests.scm ================================================================== --- tests.scm +++ tests.scm @@ -568,10 +568,155 @@ ;; state-status-counts ;; (lambda (key val) ;; (append key (list val))))) )))) +(define tests:css-jscript-block +#< +ul.LinkedList { display: block; } +/* ul.LinkedList ul { display: none; } */ +.HandCursorStyle { cursor: pointer; cursor: hand; } /* For IE */ + + + +EOF +) + +;; (tests:create-html-tree "test-index.html") +;; +(define (tests:create-html-tree outf) + (if (common:simple-file-lock (conc outf ".lock")) + (let* ((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) + (append (take (vector->list x) numkeys) + (list (vector-ref x (+ 1 numkeys))))) ;; gets the runname + runs)) + (runs-htree (common:list->htree runtreedat))) + (s:output-new + oup + (s:html tests:css-jscript-block + (s:title "Summary for " area-name) + (s:body 'onload "addEvents();" + ;; top list + (s:ul 'id "LinkedList1" 'class "LinkedList" + (s:li + "Runs" + (common:htree->html runs-htree + '() + (lambda (x p) + (apply s:a x p)))))))) + (close-output-port oup) + (common:simple-file-release-lock (conc outf ".lock")) + #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)))))))))) + ;; 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)) @@ -666,11 +811,12 @@ (conc (vector-ref b 2))) #f)) (string