︙ | | | ︙ | |
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
|
;; (iup:attribute-set! keys-matrix "WIDTH1" "100")
;; fill in keys
(for-each
(lambda (var)
;; (iup:attribute-set! keys-matrix "ADDLIN" (conc curr-row-num))
(iup:attribute-set! keys-matrix (conc curr-row-num ":0") curr-row-num)
(iup:attribute-set! keys-matrix (conc curr-row-num ":1") var)
(set! curr-row-num (+ 1 curr-row-num))) ;; (config-lookup *configdat* "fields" var)))
key-vals)
(iup:attribute-set! keys-matrix "WIDTHDEF" "40")
keys-matrix))
;; Section to table
(define (dcommon:section-matrix rawconfig sectionname varcolname valcolname #!key (title #f))
(let* ((curr-row-num 1)
|
|
|
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
|
;; (iup:attribute-set! keys-matrix "WIDTH1" "100")
;; fill in keys
(for-each
(lambda (var)
;; (iup:attribute-set! keys-matrix "ADDLIN" (conc curr-row-num))
(iup:attribute-set! keys-matrix (conc curr-row-num ":0") curr-row-num)
(iup:attribute-set! keys-matrix (conc curr-row-num ":1") var)
(set! curr-row-num (+ 1 curr-row-num))) ;; (config-lookup configdat "fields" var)))
key-vals)
(iup:attribute-set! keys-matrix "WIDTHDEF" "40")
keys-matrix))
;; Section to table
(define (dcommon:section-matrix rawconfig sectionname varcolname valcolname #!key (title #f))
(let* ((curr-row-num 1)
|
︙ | | | ︙ | |
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
|
(iup:attribute-set! section-matrix "WIDTH1" "200")
;; fill in keys
(for-each
(lambda (var)
;; (iup:attribute-set! keys-matrix "ADDLIN" (conc curr-row-num))
(iup:attribute-set! section-matrix (conc curr-row-num ":0") var)
(iup:attribute-set! section-matrix (conc curr-row-num ":1") (configf:lookup rawconfig sectionname var))
(set! curr-row-num (+ 1 curr-row-num))) ;; (config-lookup *configdat* "fields" var)))
key-vals)
(iup:vbox
(iup:label (if title title (conc "Settings from [" sectionname "]"))
;; #:size "5x"
#:expand "HORIZONTAL"
)
section-matrix)))
|
|
|
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
|
(iup:attribute-set! section-matrix "WIDTH1" "200")
;; fill in keys
(for-each
(lambda (var)
;; (iup:attribute-set! keys-matrix "ADDLIN" (conc curr-row-num))
(iup:attribute-set! section-matrix (conc curr-row-num ":0") var)
(iup:attribute-set! section-matrix (conc curr-row-num ":1") (configf:lookup rawconfig sectionname var))
(set! curr-row-num (+ 1 curr-row-num))) ;; (config-lookup configdat "fields" var)))
key-vals)
(iup:vbox
(iup:label (if title title (conc "Settings from [" sectionname "]"))
;; #:size "5x"
#:expand "HORIZONTAL"
)
section-matrix)))
|
︙ | | | ︙ | |
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
|
(iup:attribute-set! general-matrix "WIDTH1" "150")
(iup:attribute-set! general-matrix "0:1" "About this Megatest area")
;; User (this is not always obvious - it is common to run as a different user
(iup:attribute-set! general-matrix "1:0" "User")
(iup:attribute-set! general-matrix "1:1" (current-user-name))
;; Megatest area
;; (iup:attribute-set! general-matrix "2:0" "Area")
;; (iup:attribute-set! general-matrix "2:1" *toppath*)
;; Megatest version
(iup:attribute-set! general-matrix "2:0" "Version")
(iup:attribute-set! general-matrix "2:1" (conc megatest-version "-" (substring megatest-fossil-hash 0 4)))
general-matrix))
(define (dcommon:run-stats dbstruct)
|
|
|
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
|
(iup:attribute-set! general-matrix "WIDTH1" "150")
(iup:attribute-set! general-matrix "0:1" "About this Megatest area")
;; User (this is not always obvious - it is common to run as a different user
(iup:attribute-set! general-matrix "1:0" "User")
(iup:attribute-set! general-matrix "1:1" (current-user-name))
;; Megatest area
;; (iup:attribute-set! general-matrix "2:0" "Area")
;; (iup:attribute-set! general-matrix "2:1" toppath)
;; Megatest version
(iup:attribute-set! general-matrix "2:0" "Version")
(iup:attribute-set! general-matrix "2:1" (conc megatest-version "-" (substring megatest-fossil-hash 0 4)))
general-matrix))
(define (dcommon:run-stats dbstruct)
|
︙ | | | ︙ | |
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
|
(exit)))
(if (not (launch:setup-for-run))
(begin
(print "Failed to find megatest.config, exiting")
(exit 1)))
(define *dbdir* (db:dbfile-path #f)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db"))
(define *dbstruct-local* (make-dbr:dbstruct path: *dbdir*
local: #t))
(define *db-file-path* (db:dbfile-path 0))
;; HACK ALERT: this is a hack, please fix.
(define *read-only* (not (file-read-access? *db-file-path*)))
|
|
|
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
|
(exit)))
(if (not (launch:setup-for-run))
(begin
(print "Failed to find megatest.config, exiting")
(exit 1)))
(define *dbdir* (db:dbfile-path #f)) ;; (conc (configf:lookup configdat "setup" "linktree") "/.db"))
(define *dbstruct-local* (make-dbr:dbstruct path: *dbdir*
local: #t))
(define *db-file-path* (db:dbfile-path 0))
;; HACK ALERT: this is a hack, please fix.
(define *read-only* (not (file-read-access? *db-file-path*)))
|
︙ | | | ︙ | |
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
|
(define (next-sort-option)
(if (>= *tests-sort-reverse* 5)
(set! *tests-sort-reverse* 0)
(set! *tests-sort-reverse* (+ *tests-sort-reverse* 1)))
*tests-sort-reverse*)
(define *tests-sort-reverse*
(let ((t-sort (assoc (configf:lookup *configdat* "dashboard" "testsort") *tests-sort-type-index*)))
(if t-sort
(cadr t-sort)
3)))
(define (get-curr-sort)
(vector-ref *tests-sort-options* *tests-sort-reverse*))
|
|
|
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
|
(define (next-sort-option)
(if (>= *tests-sort-reverse* 5)
(set! *tests-sort-reverse* 0)
(set! *tests-sort-reverse* (+ *tests-sort-reverse* 1)))
*tests-sort-reverse*)
(define *tests-sort-reverse*
(let ((t-sort (assoc (configf:lookup (megatest:area-configdat *area-dat*) "dashboard" "testsort") *tests-sort-type-index*)))
(if t-sort
(cadr t-sort)
3)))
(define (get-curr-sort)
(vector-ref *tests-sort-options* *tests-sort-reverse*))
|
︙ | | | ︙ | |
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
|
;;======================================================================
;;
;; A gui for launching tests
;;
(define (dashboard:run-controls)
(let* ((targets (make-hash-table))
(test-records (make-hash-table))
(all-tests-registry (tests:get-all)) ;; (tests:get-valid-tests *toppath* '()))
(test-names (hash-table-keys all-tests-registry))
(sorted-testnames #f)
(action "-runtests")
(cmdln "")
(runlogs (make-hash-table))
(key-listboxes #f)
(updater-for-runs #f)
|
|
|
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
|
;;======================================================================
;;
;; A gui for launching tests
;;
(define (dashboard:run-controls)
(let* ((targets (make-hash-table))
(test-records (make-hash-table))
(all-tests-registry (tests:get-all)) ;; (tests:get-valid-tests toppath '()))
(test-names (hash-table-keys all-tests-registry))
(sorted-testnames #f)
(action "-runtests")
(cmdln "")
(runlogs (make-hash-table))
(key-listboxes #f)
(updater-for-runs #f)
|
︙ | | | ︙ | |
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
|
;; )))
;;======================================================================
;; S U M M A R Y
;;======================================================================
;;
;; General info about the run(s) and megatest area
(define (dashboard:summary db)
(let ((rawconfig (read-config (conc *toppath* "/megatest.config") #f #f))) ;; changed to #f since I want #{} to be expanded by [system ...] to NOT be expanded. WAS: 'return-string)))
(iup:vbox
(iup:split
#:value 500
(iup:frame
#:title "General Info"
(iup:vbox
(iup:hbox
(iup:label "Area Path")
(iup:textbox #:value *toppath* #:expand "HORIZONTAL"))
(iup:hbox
(dcommon:keys-matrix rawconfig)
(dcommon:general-info)
)))
(iup:frame
#:title "Server"
(dcommon:servers-table)))
|
|
>
|
|
|
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
|
;; )))
;;======================================================================
;; S U M M A R Y
;;======================================================================
;;
;; General info about the run(s) and megatest area
(define (dashboard:summary db area-dat)
(let* ((toppath (megatest:area-path area-dat))
(rawconfig (read-config (conc toppath "/megatest.config") #f #f))) ;; changed to #f since I want #{} to be expanded by [system ...] to NOT be expanded. WAS: 'return-string)))
(iup:vbox
(iup:split
#:value 500
(iup:frame
#:title "General Info"
(iup:vbox
(iup:hbox
(iup:label "Area Path")
(iup:textbox #:value toppath #:expand "HORIZONTAL"))
(iup:hbox
(dcommon:keys-matrix rawconfig)
(dcommon:general-info)
)))
(iup:frame
#:title "Server"
(dcommon:servers-table)))
|
︙ | | | ︙ | |
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
|
tb
run-matrix)))
;;======================================================================
;; R U N S
;;======================================================================
(define (make-dashboard-buttons db nruns ntests keynames)
(let* ((nkeys (length keynames))
(runsvec (make-vector nruns))
(header (make-vector nruns))
(lftcol (make-vector ntests))
(keycol (make-vector ntests))
(controls '())
(lftlst '())
(hdrlst '())
|
|
>
|
|
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
|
tb
run-matrix)))
;;======================================================================
;; R U N S
;;======================================================================
(define (make-dashboard-buttons db nruns ntests keynames area-dat)
(let* ((toppath (megatest:area-path area-dat))
(nkeys (length keynames))
(runsvec (make-vector nruns))
(header (make-vector nruns))
(lftcol (make-vector ntests))
(keycol (make-vector ntests))
(controls '())
(lftlst '())
(hdrlst '())
|
︙ | | | ︙ | |
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
|
(system cmd))))))
(hash-table-set! *buttondat* button-key (vector 0 "100 100 100" button-key #f #f))
(vector-set! testvec testnum butn)
(loop runnum (+ testnum 1) testvec (cons butn res))))))
;; now assemble the hdrlst and bdylst and kick off the dialog
(iup:show
(iup:dialog
#:title (conc "Megatest dashboard " (current-user-name) ":" *toppath*)
#:menu (dcommon:main-menu)
(let* ((runs-view (iup:vbox
(apply iup:hbox
(cons (apply iup:vbox lftlst)
(list
(iup:vbox
;; the header
|
|
|
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
|
(system cmd))))))
(hash-table-set! *buttondat* button-key (vector 0 "100 100 100" button-key #f #f))
(vector-set! testvec testnum butn)
(loop runnum (+ testnum 1) testvec (cons butn res))))))
;; now assemble the hdrlst and bdylst and kick off the dialog
(iup:show
(iup:dialog
#:title (conc "Megatest dashboard " (current-user-name) ":" toppath)
#:menu (dcommon:main-menu)
(let* ((runs-view (iup:vbox
(apply iup:hbox
(cons (apply iup:vbox lftlst)
(list
(iup:vbox
;; the header
|
︙ | | | ︙ | |
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
|
(define *tim* (iup:timer))
(define *ord* #f)
(iup:attribute-set! *tim* "TIME" 300)
(iup:attribute-set! *tim* "RUN" "YES")
;; Move this stuff to db.scm? I'm not sure that is the right thing to do...
;;
(define *last-db-update-time* (file-modification-time *db-file-path*)) ;; (conc *toppath* "/db/main.db")))
(define *last-recalc-ended-time* 0)
(define (dashboard:been-changed)
(> (file-modification-time *db-file-path*) *last-db-update-time*))
(define (dashboard:set-db-update-time)
(set! *last-db-update-time* (file-modification-time *db-file-path*)))
|
|
|
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
|
(define *tim* (iup:timer))
(define *ord* #f)
(iup:attribute-set! *tim* "TIME" 300)
(iup:attribute-set! *tim* "RUN" "YES")
;; Move this stuff to db.scm? I'm not sure that is the right thing to do...
;;
(define *last-db-update-time* (file-modification-time *db-file-path*)) ;; (conc toppath "/db/main.db")))
(define *last-recalc-ended-time* 0)
(define (dashboard:been-changed)
(> (file-modification-time *db-file-path*) *last-db-update-time*))
(define (dashboard:set-db-update-time)
(set! *last-db-update-time* (file-modification-time *db-file-path*)))
|
︙ | | | ︙ | |