| ︙ | | |
100
101
102
103
104
105
106
107
108
109
110
111
112
113
|
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
|
+
|
(define *state-ignore-hash* (make-hash-table))
(define *last-db-update-time* 0)
(define *please-update-buttons* #t)
(define *db-file-path* (conc *toppath* "/megatest.db"))
(define *tests-sort-reverse* #f)
(define *hide-empty-runs* #f)
(define *verbosity* (cond
((args:get-arg "-debug")(string->number (args:get-arg "-debug")))
((args:get-arg "-v") 2)
((args:get-arg "-q") 0)
(else 1)))
|
| ︙ | | |
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
|
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
|
+
-
-
+
+
|
(for-each (lambda (run)
(let* ((run-id (db:get-value-by-header run header "id"))
(tests (let ((tsts (db-get-tests-for-run *db* run-id testnamepatt itemnamepatt states statuses)))
(if *tests-sort-reverse* (reverse tsts) tsts)))
(key-vals (get-key-vals *db* run-id)))
(if (> (length tests) maxtests)
(set! maxtests (length tests)))
(if (or (not *hide-empty-runs*) ;; this reduces the data burden when set
;(if (not (null? tests))
(set! result (cons (vector run tests key-vals) result)))); )
(not (null? tests)))
(set! result (cons (vector run tests key-vals) result)))))
runs)
(set! *header* header)
(set! *allruns* result)
(debug:print 6 "*allruns* has " (length *allruns*) " runs")
;; (set! *tot-run-count* (+ 1 (length *allruns*)))
maxtests))
*num-tests*))) ;; FIXME, naughty coding eh?
|
| ︙ | | |
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
|
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
|
+
+
-
-
-
-
-
+
+
+
+
+
|
(set! *alltestnamelst* '())
;; create a concise list of test names
(for-each
(lambda (rundat)
(if (vector? rundat)
(let* ((testdat (vector-ref rundat 1))
(testnames (map test:test-get-fullname testdat)))
(if (not (and *hide-empty-runs*
(null? testnames)))
(for-each (lambda (testname)
(if (not (member testname *alltestnamelst*))
(begin
(set! *alltestnamelst* (append *alltestnamelst* (list testname))))))
testnames))))
(for-each (lambda (testname)
(if (not (member testname *alltestnamelst*))
(begin
(set! *alltestnamelst* (append *alltestnamelst* (list testname))))))
testnames)))))
runs)
(set! *alltestnamelst* (collapse-rows *alltestnamelst*)) ;;; argh. please clean up this sillyness
(set! *alltestnamelst* (let ((xl (if (> (length *alltestnamelst*) *start-test-offset*)
(drop *alltestnamelst* *start-test-offset*)
'())))
(append xl (make-list (- *num-tests* (length xl)) ""))))
|
| ︙ | | |
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
|
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
|
+
+
+
+
-
+
|
(set! *last-db-update-time* 0)
(update-search "item-name" val)))))
(iup:vbox
(iup:hbox
(iup:button "Sort" #:action (lambda (obj)
(set! *tests-sort-reverse* (not *tests-sort-reverse*))
(iup:attribute-set! obj "TITLE" (if *tests-sort-reverse* "+Sort" "-Sort"))
(set! *last-db-update-time* 0)))
(iup:button "HideEmpty" #:action (lambda (obj)
(set! *hide-empty-runs* (not *hide-empty-runs*))
(iup:attribute-set! obj "TITLE" (if *hide-empty-runs* "+Hide" "-Hide"))
(set! *last-db-update-time* 0))))
(set! *last-db-update-time* 0))))
(iup:hbox
(iup:button "Quit" #:action (lambda (obj)(sqlite3:finalize! *db*)(exit)))
(iup:button "Monitor" #:action (lambda (obj)(system (conc (car (argv))" -guimonitor &")))))
))
;; (iup:button "<- Left" #:action (lambda (obj)(set! *start-run-offset* (+ *start-run-offset* 1))))
;; (iup:button "Up ^" #:action (lambda (obj)(set! *start-test-offset* (if (> *start-test-offset* 0)(- *start-test-offset* 1) 0))))
;; (iup:button "Down v" #:action (lambda (obj)(set! *start-test-offset* (if (>= *start-test-offset* (length *alltestnamelst*))(length *alltestnamelst*)(+ *start-test-offset* 1)))))
|
| ︙ | | |