Megatest

Check-in [40fcb78bd6]
Login
☰Home Timeline Files Branches Tags Tickets Wiki Login
Overview
Comment:Added auto-rolling up of item status into an html file
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk | v1.19
Files: files | file ages | folders
SHA1: 40fcb78bd61dae1915ae516dadac9589bac470eb
User & Date: matt on 2011-08-02 23:27:07
Other Links: manifest | tags
Context
2011-08-03
11:23
Couple tweaks to html output of the items rollup check-in: 6b05707512 user: mrwellan tags: trunk
2011-08-02
23:27
Added auto-rolling up of item status into an html file check-in: 40fcb78bd6 user: matt tags: trunk, v1.19
17:56
Partial implemenation of rolling up item results check-in: 42b834da20 user: mrwellan tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Modified common.scm from [a1016b8cd0] to [828a92199d].

︙︙
125
126
127
128
129
130
131






























(define (seconds->hr-min-sec secs)
  (let* ((hrs (quotient secs 3600))
	 (min (quotient (- secs (* hrs 3600)) 60))
	 (sec (- secs (* hrs 3600)(* min 60))))
    (conc (if (> hrs 0)(conc hrs "hr ") "")
	  (if (> min 0)(conc min "m ")  "")
	  sec "s")))





































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>

125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160

(define (seconds->hr-min-sec secs)
  (let* ((hrs (quotient secs 3600))
	 (min (quotient (- secs (* hrs 3600)) 60))
	 (sec (- secs (* hrs 3600)(* min 60))))
    (conc (if (> hrs 0)(conc hrs "hr ") "")
	  (if (> min 0)(conc min "m ")  "")
	  sec "s")))

;;======================================================================
;; Colors
;;======================================================================
      
(define (common:name->iup-color name)
  (case (string->symbol (string-downcase name))
    ((red)    "223 33 49")
    ((grey)   "192 192 192")
    ((orange) "255 172 13")
    ((purple) "This is unfinished ...")))

(define (common:get-color-for-state-status state status type)
  (case (string->symbol state)
    ((COMPLETED)
     (if (equal? status "PASS")
	 "70 249 73"
	 (if (or (equal? status "WARN")
		 (equal? status "WAIVED"))
	     "255 172 13"
	     "223 33 49"))) ;; greenish orangeish redish
    ((LAUNCHED)         "101 123 142")
    ((CHECK)            "255 100 50")
    ((REMOTEHOSTSTART)  "50 130 195")
    ((RUNNING)          "9 131 232")
    ((KILLREQ)          "39 82 206")
    ((KILLED)           "234 101 17")
    ((NOT_STARTED)      "240 240 240")
    (else               "192 192 192")))

Modified db.scm from [b552412187] to [7e7088ebc5].

︙︙
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62

                    (id INTEGER PRIMARY KEY,
                     run_id     INTEGER,
                     testname   TEXT,
                     host       TEXT DEFAULT 'n/a',
                     cpuload    REAL DEFAULT -1,
                     diskfree   INTEGER DEFAULT -1,
                     uname      TEXT DEFAULT 'n/a', 
                    rundir     TEXT DEFAULT 'n/a',
                     item_path  TEXT DEFAULT '',
                     state      TEXT DEFAULT 'NOT_STARTED',
                     status     TEXT DEFAULT 'FAIL',
                     attemptnum INTEGER DEFAULT 0,
                     final_logf TEXT DEFAULT 'logs/final.log',
                     logdat     BLOB, 
                     run_duration INTEGER DEFAULT 0,








|








48
49
50
51
52
53
54
55
56
57
58
59
60
61
62

                    (id INTEGER PRIMARY KEY,
                     run_id     INTEGER,
                     testname   TEXT,
                     host       TEXT DEFAULT 'n/a',
                     cpuload    REAL DEFAULT -1,
                     diskfree   INTEGER DEFAULT -1,
                     uname      TEXT DEFAULT 'n/a', 
                     rundir     TEXT DEFAULT 'n/a',
                     item_path  TEXT DEFAULT '',
                     state      TEXT DEFAULT 'NOT_STARTED',
                     status     TEXT DEFAULT 'FAIL',
                     attemptnum INTEGER DEFAULT 0,
                     final_logf TEXT DEFAULT 'logs/final.log',
                     logdat     BLOB, 
                     run_duration INTEGER DEFAULT 0,
︙︙

Modified megatest-version.scm from [d7a309cb03] to [c09e9a5825]. 

1

(define megatest-version 1.18)

|

1

(define megatest-version 1.19)

Modified megatest.scm from [cc849a95d3] to [fdec59eebf].

︙︙
489
490
491
492
493
494
495

496
497
498
499
500
501
502
503
504
505
506
507



508
509
510
511
512
513
514

		   (th2          (make-thread runit)))
	      (set! job-thread th2)
	      (thread-start! th1)
	      (thread-start! th2)
	      (thread-join! th2)
	      (mutex-lock! m)
	      (set! db (open-db))

	      (let* ((testinfo (db:get-test-info db run-id test-name (item-list->path itemdat))))
		(if (not (equal? (db:test-get-state testinfo) "COMPLETED"))
		    (begin
		      (debug:print 2 "Test NOT logged as COMPLETED, (state=" (db:test-get-state testinfo) "), updating result")
		      (test-set-status! db run-id test-name
					(if kill-job? "KILLED" "COMPLETED")
					(if (vector-ref exit-info 1) ;; look at the exit-status
					    (if (and (not kill-job?) 
						     (eq? (vector-ref exit-info 2) 0))
						"PASS"
						"FAIL")
					    "FAIL") itemdat (args:get-arg "-m")))))



	      (mutex-unlock! m)
	      ;; (exec-results (cmd-run->list fullrunscript)) ;;  (list ">" (conc test-name "-run.log"))))
	      ;; (success      exec-results)) ;; (eq? (cadr exec-results) 0)))
	      (debug:print 2 "Output from running " fullrunscript ", pid " (vector-ref exit-info 0) " in work area " 
		     work-area ":\n====\n exit code " (vector-ref exit-info 2) "\n" "====\n")
	      (sqlite3:finalize! db)
	      (if (not (vector-ref exit-info 1))








>
|










|
>
>
>








489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518

		   (th2          (make-thread runit)))
	      (set! job-thread th2)
	      (thread-start! th1)
	      (thread-start! th2)
	      (thread-join! th2)
	      (mutex-lock! m)
	      (set! db (open-db))
	      (let* ((item-path (item-list->path itemdat))
		     (testinfo  (db:get-test-info db run-id test-name item-path)))
		(if (not (equal? (db:test-get-state testinfo) "COMPLETED"))
		    (begin
		      (debug:print 2 "Test NOT logged as COMPLETED, (state=" (db:test-get-state testinfo) "), updating result")
		      (test-set-status! db run-id test-name
					(if kill-job? "KILLED" "COMPLETED")
					(if (vector-ref exit-info 1) ;; look at the exit-status
					    (if (and (not kill-job?) 
						     (eq? (vector-ref exit-info 2) 0))
						"PASS"
						"FAIL")
					    "FAIL") itemdat (args:get-arg "-m"))))
		;; for automated creation of the rollup html file this is a good place...
		(tests:summarize-items db run-id test-name #f) ;; don't force - just update if no
		)
	      (mutex-unlock! m)
	      ;; (exec-results (cmd-run->list fullrunscript)) ;;  (list ">" (conc test-name "-run.log"))))
	      ;; (success      exec-results)) ;; (eq? (cadr exec-results) 0)))
	      (debug:print 2 "Output from running " fullrunscript ", pid " (vector-ref exit-info 0) " in work area " 
		     work-area ":\n====\n exit code " (vector-ref exit-info 2) "\n" "====\n")
	      (sqlite3:finalize! db)
	      (if (not (vector-ref exit-info 1))
︙︙
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586

		(exit 1)))
	  (set! db (open-db))
	  (if (args:get-arg "-setlog")
	      (test-set-log! db run-id test-name itemdat (args:get-arg "-setlog")))
	  (if (args:get-arg "-set-toplog")
	      (test-set-toplog! db run-id test-name (args:get-arg "-set-toplog")))
	  (if (args:get-arg "-summarize-items")
	      (tests:summarize-items db run-id test-name))
	  (if (args:get-arg "-runstep")
	      (if (null? remargs)
		  (begin
		    (debug:print 0 "ERROR: nothing specified to run!")
		    (sqlite3:finalize! db)
		    (exit 6))
		  (let* ((stepname   (args:get-arg "-runstep"))








|








576
577
578
579
580
581
582
583
584
585
586
587
588
589
590

		(exit 1)))
	  (set! db (open-db))
	  (if (args:get-arg "-setlog")
	      (test-set-log! db run-id test-name itemdat (args:get-arg "-setlog")))
	  (if (args:get-arg "-set-toplog")
	      (test-set-toplog! db run-id test-name (args:get-arg "-set-toplog")))
	  (if (args:get-arg "-summarize-items")
	      (tests:summarize-items db run-id test-name #t)) ;; do force here
	  (if (args:get-arg "-runstep")
	      (if (null? remargs)
		  (begin
		    (debug:print 0 "ERROR: nothing specified to run!")
		    (sqlite3:finalize! db)
		    (exit 6))
		  (let* ((stepname   (args:get-arg "-runstep"))
︙︙

Modified runs.scm from [07e183ee46] to [2ce4434f2f].

︙︙
126
127
128
129
130
131
132
133
134
135
136
137
138

139
140

























141
142
143



144
145
146

147

148

149
150
151
152
153
154
155
156
157
158
159
160
161
162
163

    (sqlite3:execute db "UPDATE tests SET final_logf=? WHERE run_id=? AND testname=? AND item_path=?;" 
		     logf run-id test-name item-path)))

(define (test-set-toplog! db run-id test-name logf) 
  (sqlite3:execute db "UPDATE tests SET final_logf=? WHERE run_id=? AND testname=? AND item_path='';" 
		   logf run-id test-name))

(define (tests:summarize-items db run-id test-name)
  (obtain-dot-lock "final-results.html" 1 20 30) ;; retry every second for 20 seconds, call it dead after 30 seconds and steal the lock
  (let ((oup   (open-output-file "final-results.html")))
    (with-output-to-port
	oup
      (print "<html><title>Summary: " test-name "</title><body><table>")

      (sqlite3:for-each-row 
       (lambda (id itempath state status run_duration logf comment)

























	 (print "<tr>"
		"<td><href=\"" itempath "/" logf "\"</a>" itempath "</td>" 
		"<td>" state    "</td>" 



		"<td>" status   "</td>"
		"<td>" comment  "</td>"
		"</tr>")

	 "SELECT id,item_path,state,status,run_duration,final_logf,comment FROM tests WHERE run_id=? AND testname=? AND item_path != '';"))

      (print "</body></html>")

      (close-output-port oup)
      (release-dot-lock "final-results.html"))

    ;; ADD UPDATE TO FINAL LOG HERE

))
			   


;; ;; TODO: Converge this with db:get-test-info
;; (define (runs:get-test-info db run-id test-name item-path)
;;   (let ((res #f)) ;; (vector #f #f #f #f #f #f)))
;;     (sqlite3:for-each-row 
;;      (lambda (id run-id test-name state status)
;;        (set! res (vector id run-id test-name state status item-path)))








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








126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181

182

183
184


185
186
187
188
189
190
191

    (sqlite3:execute db "UPDATE tests SET final_logf=? WHERE run_id=? AND testname=? AND item_path=?;" 
		     logf run-id test-name item-path)))

(define (test-set-toplog! db run-id test-name logf) 
  (sqlite3:execute db "UPDATE tests SET final_logf=? WHERE run_id=? AND testname=? AND item_path='';" 
		   logf run-id test-name))

(define (tests:summarize-items db run-id test-name force)
  ;; if not force then only update the record if one of these is true:
  ;;   1. logf is "log/final.log
  ;;   2. logf is same as outputfilename
  (let ((outputfilename (conc "megatest-rollup-" test-name ".html"))
	(orig-dir       (current-directory))
	(logf           #f))
    (sqlite3:for-each-row 
     (lambda (path final_logf)
       (set! logf final_logf)
       (if (directory? path)
	   (begin
	     (print "Found path: " path)
	     (change-directory path))
	     ;; (set! outputfilename (conc path "/" outputfilename)))
	   (print "No such path: " path)))
     db 
     "SELECT rundir,final_logf FROM tests WHERE run_id=? AND testname=? AND item_path='';"
     run-id test-name)
    (print "summarize-items with logf " logf)
    (if (or (equal? logf "logs/final.log")
	    (equal? logf outputfilename)
	    force)
	(begin
	  (if (obtain-dot-lock outputfilename 1 20 30) ;; retry every second for 20 seconds, call it dead after 30 seconds and steal the lock
	      (print "Obtained lock for " outputfilename)
	      (print "Failed to obtain lock for " outputfilename))
	  (let ((oup   (open-output-file outputfilename)))
	    (with-output-to-port
		oup
	      (lambda ()
		(print "<html><title>Summary: " test-name "</title><body><h1>Summary for " test-name "<table>")
		(sqlite3:for-each-row 
		 (lambda (id itempath state status run_duration logf comment)
		   (print "<tr>"
			  "<td><a href=\"" itempath "/" logf "\"</a>" itempath "</td>" 
			  "<td>" state    "</td>" 
			  "<td><font color=" (cond
					      ((equal? status "PASS") "green")
					      ((equal? status "FAIL") "red")
					      (else "blue")) ">"   status   "</font></td>"
					      "<td>" comment  "</td>"
					      "</tr>"))
		 db
		 "SELECT id,item_path,state,status,run_duration,final_logf,comment FROM tests WHERE run_id=? AND testname=? AND item_path != '';"
		 run-id test-name)
		(print "</body></html>")
		(release-dot-lock outputfilename)))
	    (close-output-port oup)

	    (change-directory orig-dir)

	    (test-set-toplog! db run-id test-name outputfilename)
	    )))))



;; ;; TODO: Converge this with db:get-test-info
;; (define (runs:get-test-info db run-id test-name item-path)
;;   (let ((res #f)) ;; (vector #f #f #f #f #f #f)))
;;     (sqlite3:for-each-row 
;;      (lambda (id run-id test-name state status)
;;        (set! res (vector id run-id test-name state status item-path)))
︙︙

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