Megatest

Check-in [962be10405]
Login
☰Home Timeline Files Branches Tags Tickets Wiki Login
Overview
Comment:Cleaned up html generation a little
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | html-tree
Files: files | file ages | folders
SHA1: 962be1040557ddc29220547c9f7c2593d43f55fd
User & Date: mrwellan on 2016-10-17 11:00:12
Other Links: branch diff | manifest | tags
Context
2016-10-17
11:04
Merged in html and bumped version to v1.6204 check-in: 831e40ab39 user: mrwellan tags: v1.62
11:00
Cleaned up html generation a little Closed-Leaf check-in: 962be10405 user: mrwellan tags: html-tree
01:32
Added data get for runs summary html page check-in: 6ae61495e7 user: matt tags: html-tree
Changes
Hide Diffs Side-by-Side Diffs Ignore Whitespace Patch

Modified common.scm from [69895b157d] to [8514527bdb].

︙
644
645
646
647
648
649
650
651



652
653
654
655
656
657
658

644
645
646
647
648
649
650

651
652
653
654
655
656
657
658
659
660








-
+
+
+








    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)
  (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))
		       (y         (cdr x))
		       (newpath   (append path (list levelname)))
︙

Modified megatest.scm from [abcb815542] to [f073a21a21].

︙
167
168
169
170
171
172
173

174
175
176
177
178
179
180

167
168
169
170
171
172
173
174
175
176
177
178
179
180
181








+








                            formats: perl, ruby, sqlite3, csv (for csv the -o param
                            will substitute %s for the sheet name in generating 
                            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
                            if it contains forward slashes the path will be converted
                            to windows style
︙
282
283
284
285
286
287
288

289
290
291
292
293
294
295

283
284
285
286
287
288
289
290
291
292
293
294
295
296
297








+








			;; misc
			"-repl"
			"-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"
			"-show-runconfig"
			"-show-config"
︙
1999
2000
2001
2002
2003
2004
2005







2006
2007
2008
2009
2010
2011
2012

2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021








+
+
+
+
+
+
+








(if (args:get-arg "-sync-to-megatest.db")
    (begin
      (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
;;======================================================================

(if *runremote* (close-all-connections!))
︙

Modified tests.scm from [34fb215fdd] to [8d5f3a1ead].

︙
647
648
649
650
651
652
653
654

655
656
657
658
659
660
661

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))
	       (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

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 ((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"))
                    (run-dir      (tests:run-record->test-path run numkeys))
		    (testdats     (rmt:get-tests-for-run
				   run-id "%" ;; testnamepatt
		    (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)))

				   #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)
;;   (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)
               (if oup
;; 	     (directory? path)) ;; can get #f here under some wierd conditions. why, unknown ...
;; 	(begin
                   (begin
;; 	  (debug:print 4 *default-log-port* "Found path: " path)
;; 	  (change-directory path))
;; 	;; (set! outputfilename (conc path "/" outputfilename)))
                     (s:output-new
;; 	(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)
                      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
;; 	(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 " & "))
                                      (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
;; 		      (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))
                                                                                         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)))
;; 		;; 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))
                                                                     (if (file-exists? full-targ)
;; 		    ;; 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
                                                                         (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)))

;; 		      (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))
(define (tests:process-steps-table steps);; db test-id #!key (work-area #f))
︙

This page was generated in about 0.12s by Fossil 2.24 [452f8e1ffc] 2024-03-26 15:36:00