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 Unified 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

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


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








|
>
>








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

                            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


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








>








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

			;; 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


			;; misc queries
			"-list-disks"
			"-list-targets"
			"-list-db-targets"
			"-show-runconfig"
			"-show-config"








>








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

(if (args:get-arg "-sync-to-megatest.db")
    (begin
      (db:multi-db-sync 
       #f ;; do all run-ids
       'new2old
       )
      (set! *didsomething* #t)))








;;======================================================================
;; Exit and clean up
;;======================================================================

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









>
>
>
>
>
>
>








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

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

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








|
>
|
>
>
>
|
>
>
|
|





>
|
>
|









|
|
>
>
>
>
>
|
|
>
>
>
>
>
>
>
|
|
<
<
<
<
<
<
|
<
|
<
<
|
<
<
<
>
>
|
>
>
|
<
<
>
>
>
|
|
|
|
|
|
>
>
>
|
|
|
<
>
>
>
|
>
|
>
|
<
<
|
<
>
|
|
>
>
>
>
>
>
|
<








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

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