Megatest

Diff
Login

Differences From Artifact [9c3a853d3a]:

To Artifact [ad835aa81d]:


349
350
351
352
353
354
355
356

357
358
359
360
361
362
363
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)))
       (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
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)))
       (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
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*)
    ;; (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
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 *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
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*)))
  (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
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* '()))
	 (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
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)
  (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)))
(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: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
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)
  (let* ((nkeys   (length keynames))
(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
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*)
      #: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
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-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*)))