Megatest

Changes On Branch a8b0f906a59b2af5
Login
☰Home Timeline Files Branches Tags Tickets Wiki Login
Hide Diff Patch Side-by-Side Diff

Changes In Branch mtdboard Excluding Merge-Ins

This is equivalent to a diff from 537ddaa4f1 to a8b0f906a5

2016-06-24
18:19
Fixed xterm implementation Closed-Leaf check-in: a8b0f906a5 user: ritikaag tags: mtdboard
2016-06-23
18:13
Added lt link at mtrah and spit out tests with a useful path check-in: d0d40af393 user: mrwellan tags: v1.61
14:42
Merged latest changes from v1.61 check-in: bb7e0b59c7 user: ritikaag tags: mtdboard
2016-06-22
10:43
Converted to using debug:print-error and added double printing of errors when output is sent to log file check-in: 537ddaa4f1 user: mrwellan tags: v1.61
10:15
Removed debugging print stmt check-in: dd032a6908 user: mrwellan tags: v1.61

Modified configf.scm from [cf3db9b475] to [71a6e1e172].

︙
38
39
40
41
42
43
44






45
46
47
48
49
50
51

38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57








+
+
+
+
+
+








		  (loop remcwd)))))))))

(define (config:assoc-safe-add alist key val #!key (metadata #f))
  (let ((newalist (filter (lambda (x)(not (equal? key (car x)))) alist)))
    (append newalist (list (if metadata
			       (list key val metadata)
			       (list key val))))))


(define (configf:set-section-var cfgdat section var value)
  (let ((sect (hash-table-ref/default cfgdat section '())))
    (hash-table-set! cfgdat section (config:assoc-safe-add sect var value))))


(define (config:eval-string-in-environment str)
  (handle-exceptions
   exn
   (begin
     (debug:print-error 0 *default-log-port* "problem evaluating \"" str "\" in the shell environment")
     #f)
︙
594
595
596
597
598
599
600



600
601
602
603
604
605
606
607
608








+
+

	      (let* ((var (car dat-pair))
		     (val (cadr dat-pair))
		     (fname (if (> (length dat-pair) 2)(caddr dat-pair) #f)))
		(if fname (print "# " var "=>" fname))
		(print var " " val)))
	    section-dat))) ;;       (print "section-dat: " section-dat))
   (hash-table->alist data)))

Modified dashboard.scm from [00e45e59ce] to [f1d9d3d3f8].

︙
47
48
49
50
51
52
53

54
55
56
57
58
59
60
61
62
63
64
65

66
67
68
69
70
71
72

47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74








+












+








  version " megatest-version "
  license GPL, Copyright (C) Matt Welland 2012-2016

Usage: dashboard [options]
  -h                   : this help
  -server host:port    : connect to host:port instead of db access
  -test run-id,test-id : control test identified by testid
  -xterm run-id,test-id : Start a new xterm with specified run-id and test-id
  -guimonitor          : control panel for runs

Misc
  -rows N         : set number of rows
"))

;; process args
(define remargs (args:get-args 
		 (argv)
		 (list  "-rows"
			"-run"
			"-test"
                        "-xterm"
			"-debug"
			"-host" 
			"-transport"
			) 
		 (list  "-h"
			"-use-server"
			"-guimonitor"
︙
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765































































1766
1767
1768
1769
1770
1771
1772

1751
1752
1753
1754
1755
1756
1757










1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827








-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+








	(set! bdylst (cons (apply iup:vbox (reverse res)) bdylst))
	(loop (+ runnum 1) 0 (make-vector ntests) '()))
       (else
	(let* ((button-key (mkstr runnum testnum))
	       (butn       (iup:button "" ;; button-key 
				       #:size "60x15" 
				       #:expand "HORIZONTAL"
				       #:fontsize "10" 
				       #:action (lambda (x)
						  (let* ((toolpath (car (argv)))
							 (buttndat (hash-table-ref (d:alldat-buttondat *alldat*) button-key))
							 (test-id  (db:test-get-id (vector-ref buttndat 3)))
							 (run-id   (db:test-get-run_id (vector-ref buttndat 3)))
							 (cmd  (conc toolpath " -test " run-id "," test-id "&")))
					;(print "Launching " cmd)
						    (system cmd))))))
	  (hash-table-set! (d:alldat-buttondat *alldat*) button-key (vector 0 "100 100 100" button-key #f #f)) 
				       #:fontsize "10"
				       ;; :action (lambda (x)
				       ;; 	  (let* ((toolpath (car (argv)))
				       ;; 		 (buttndat (hash-table-ref (d:alldat-buttondat *alldat*) button-key))
				       ;; 		 (test-id  (db:test-get-id (vector-ref buttndat 3)))
				       ;; 		 (run-id   (db:test-get-run_id (vector-ref buttndat 3)))
				       ;; 		 (cmd  (conc toolpath " -test " run-id "," test-id "&")))
				       ;; ;(print "Launching " cmd)
				       ;; 	    (system cmd)))
                                       #:button-cb (lambda (obj a pressed x y btn . rem)
                                                     (print "pressed= " pressed " x= " x " y= " y " rem=" rem " btn=" btn " string? " (string? btn))
                                                     (if  (substring-index "3" btn)
                                                          (if (eq? pressed 1)
                                                              (let* ((toolpath (car (argv)))
                                                                     (buttndat (hash-table-ref (d:alldat-buttondat *alldat*) button-key))
                                                                     (test-id  (db:test-get-id (vector-ref buttndat 3)))
                                                                     (run-id   (db:test-get-run_id (vector-ref buttndat 3)))
                                                                     (test-name (db:test-get-testname (rmt:get-test-info-by-id run-id test-id)))
                                                                     (popup-menu (iup:menu 
                                                                                  (iup:menu-item
                                                                                   "Run"
                                                                                   (iup:menu              
                                                                                    (iup:menu-item
                                                                                     "Rerun"
                                                                                     #:action
                                                                                     (lambda (obj)(print "Rerun")))))
                                                                                  (iup:menu-item
                                                                                   "Test"
                                                                                   (iup:menu 
                                                                                    (iup:menu-item
                                                                                     "Start xterm"
                                                                                     #:action
                                                                                     (lambda (obj)
                                                                                       (let* ((cmd (conc toolpath " -xterm " run-id "," test-id "&")))
                                                                                         (system cmd))))
                                                                                    (iup:menu-item
                                                                                     "Edit testconfig"
                                                                                     #:action
                                                                                     (lambda (obj)
                                                                                       (let* ((all-tests (tests:get-all))
                                                                                              (editor (or (get-environment-variable "VISUAL")
                                                                                                          (get-environment-variable "EDITOR") "gvim"))
                                                                                              (tconfig (conc (hash-table-ref all-tests test-name) "/testconfig"))
                                                                                              (cmd (conc (if (string-search "\\b(vim?|nano|pico)\\b")
                                                                                                             (conc "xterm -e " editor)
                                                                                                             editor)
                                                                                                         " " tconfig)))
                                                                                         (system cmd))))
                                                                                    )))))
                                                                (iup:show popup-menu
                                                                          #:x 'mouse
                                                                          #:y 'mouse
                                                                          #:modal? "NO")
                                                                (print "got here")))
                                                         (if (eq? pressed 0)
                                                             (let* ((toolpath (car (argv)))
                                                                    (buttndat (hash-table-ref (d:alldat-buttondat *alldat*) button-key))
                                                                    (test-id  (db:test-get-id (vector-ref buttndat 3)))
                                                                    (run-id   (db:test-get-run_id (vector-ref buttndat 3)))
                                                                    (cmd  (conc toolpath " -test " run-id "," test-id "&")))
                                                               (system cmd)))
                                                         )))))
          (hash-table-set! (d:alldat-buttondat *alldat*) 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)
︙
1929
1930
1931
1932
1933
1934
1935














1936
1937
1938
1939
1940
1941
1942

1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011








+
+
+
+
+
+
+
+
+
+
+
+
+
+








	(if (and (number? run-id)
		 (number? test-id)
		 (>= test-id 0))
	    (examine-test run-id test-id)
	    (begin
	      (debug:print 3 *default-log-port* "INFO: tried to open test with invalid run-id,test-id. " (args:get-arg "-test"))
	      (exit 1)))))
     ((args:get-arg "-xterm") ;; run-id,test-id
      (let* ((dat     (let ((d (map string->number (string-split (args:get-arg "-xterm") ","))))
			(if (> (length d) 1)
			    d
			    (list #f #f))))
	     (run-id  (car dat))
	     (test-id (cadr dat)))
	(if (and (number? run-id)
		 (number? test-id)
		 (>= test-id 0))
	    (dcommon:examine-xterm run-id test-id)
	    (begin
	      (debug:print 3 "INFO: tried to open xterm with invalid run-id,test-id. " (args:get-arg "-xterm"))
	      (exit 1)))))
     ((args:get-arg "-guimonitor")
      (gui-monitor (d:alldat-dblocal data)))
     (else
      (set! uidat (make-dashboard-buttons data ;; (d:alldat-dblocal data)
					  (d:alldat-numruns data)
					  (d:alldat-num-tests data)
					  (d:alldat-dbkeys data)
︙

Modified dcommon.scm from [02601e6d3a] to [ba01e4089c].

︙
316
317
318
319
320
321
322
323



























324
325
326
327
328
329
330

316
317
318
319
320
321
322

323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356








-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+








	       (item-path  (vector-ref hed 2))
	       (state      (vector-ref hed 3))
	       (status     (vector-ref hed 4))
	       (newitem    (list test-name item-path (list test-id state status))))
	  (if (null? tal)
	      (reverse (cons newitem res))
	      (loop (car tal)(cdr tal)(cons newitem res)))))))
	  

(define (dcommon:examine-xterm run-id test-id)
  (let*
      ((testdat (rmt:get-test-info-by-id run-id test-id)))
       (if (not testdat)
	(begin
	  (debug:print 2 "ERROR: No test data found for test " test-id ", exiting")
	  (exit 1))
        (let*
            ((rundir        (if testdat 
				  (db:test-get-rundir testdat)
				  logfile))
             (testfullname  (if testdat (db:test-get-fullname testdat) "Gathering data ..."))
             (xterm      (lambda ()
                           (if (directory-exists? rundir)
                               (let* ((shell (if (get-environment-variable "SHELL") 
                                                (conc "-e " (get-environment-variable "SHELL"))
                                                ""))
                                      (command (conc "cd " rundir 
                                                     ";mt_xterm -T \"" (string-translate testfullname "()" "  ") "\" " shell "&")))
                                 (print "Command =" command)
                                 (common:without-vars
                                  command
                                  "MT_.*"))
                               (message-window  (conc "Directory " rundir " not found"))))))
          (xterm)
          (print "Adding xterm code")))))

;;======================================================================
;; D A T A   T A B L E S
;;======================================================================

;; Table of keys
(define (dcommon:keys-matrix rawconfig)
︙

Modified megatest.scm from [3054ee349a] to [46dfab0f2e].

︙
34
35
36
37
38
39
40

41
42
43
44
45
46
47

34
35
36
37
38
39
40
41
42
43
44
45
46
47
48








+








(declare (uses launch))
(declare (uses server))
(declare (uses client))
(declare (uses tests))
(declare (uses genexample))
(declare (uses daemon))
(declare (uses db))
(declare (uses dcommon))

(declare (uses tdb))
(declare (uses mt))
(declare (uses api))
(declare (uses tasks)) ;; only used for debugging.
(declare (uses env))
︙

Modified multi-dboard.scm from [599895d711] to [ea319b7dd7].

︙
161
162
163
164
165
166
167

168
169
170
171
172
173
174

161
162
163
164
165
166
167
168
169
170
171
172
173
174
175








+








(define-record data
  cfgdat             ;; data from ~/.megatest/<group>.dat
  areas              ;; hash of areaname -> area-rec
  current-window-id  ;; 
  current-tab-id     ;; 
  update-needed      ;; flag to indicate that the tab pointed to by current tab id needs refreshing immediately
  tabs               ;; hash of tab-id -> areaname (??) should be of type "tab"
  groupn             ;; 
  )

;; all the components of an area display, all fits into a tab but
;; parts may be swapped in/out as needed
;;
(define-record tab
  tree
︙
410
411
412
413
414
415
416

417
418
419
420
421
422









423
424
425
426
427
428
429

411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440








+






+
+
+
+
+
+
+
+
+








(define (dashboard:main-matrix data adat window-id)
  (let* (;; (tab-dat         (areadat-
	 (view-matrix     (iup:matrix
			   ;; (runs-for-targ (db:get-runs-by-patt *dbstruct-local* *keys* "%" target #f #f #f))
			   #:expand "YES"
			   ;; #:fittosize "YES"
			   #:resizematrix "YES"
                           #:menucontext "YES"
			   #:scrollbar "YES"
			   #:numcol 100
			   #:numlin 100
			   #:numcol-visible 3
			   #:numlin-visible 20
			   #:click-cb (lambda (obj lin col status)
					(let ((popup-menu (iup:menu 
							   (iup:menu-item "Remove test"
									  #:action (lambda (obj)(print "Removing test"))))))
					  (iup:show popup-menu
						    #:x 'mouse
						    #:y 'mouse
						    #:modal? "NO")
						    
					  (print "got here"))
					(print "obj: " obj " lin: " lin " col: " col " status: " status " value: " (iup:attribute obj "VALUE"))))))
    
    ;; (iup:attribute-set! view-matrix "RESIZEMATRIX" "YES")
    (iup:attribute-set! view-matrix "WIDTH0" "100")
    ;; (dboard:data-set-runs-matrix! *data* runs-matrix)
    ;; (iup:hbox
    ;;  (iup:frame
︙
515
516
517
518
519
520
521






































522
523
524
525
526
527
528

526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577








+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+








   ;; (dboard:clear-matrix current-matrix used-cols used-rows touched) ;; clear all
    
	
  
;;======================================================================
;; D A S H B O A R D
;;======================================================================

;; The main menu
(define (dcommon:main-menu data)
  (iup:menu ;; a menu is a special attribute to a dialog (think Gnome putting the menu at screen top)
   (iup:menu-item "Files" (iup:menu   ;; Note that you can use either #:action or action: for options
			   (iup:menu-item "Open"  action: (lambda (obj)
							    (let* ((area-name (iup:textbox #:expand "HORIZONTAL"))
								   (fd        (iup:file-dialog #:dialogtype "DIR"))
								   (top       (iup:show fd #:modal? "YES")))
							      (iup:attribute-set! source-tb "VALUE"
										  (iup:attribute fd "VALUE"))
                                                              (iup:destroy! fd))))
                           (iup:menu-item "Open area"  action: (lambda (obj)
                                                            (let* ((area-name (iup:textbox #:expand "HORIZONTAL"))
                                                                   (fd        (iup:file-dialog #:dialogtype "DIR"))
                                                                   (top       (iup:show fd #:modal? "YES"))
                                                                   ;;(source-tb (iup:textbox #:expand "HORIZONTAL"))
                                                                   (cfgdat    (data-cfgdat data))
                                                                   (fname     (conc (getenv "HOME") "/.megatest/" (data-groupn data) ".dat"))
                                                                   )
                                                              ;;(iup:attribute-set! source-tb "VALUE"
                                                              ;;                    (iup:attribute fd "VALUE"))
                                                               (configf:set-section-var cfgdat "lvqa" "path" (iup:attribute fd "VALUE"))
                                                               (configf:write-alist cfgdat fname)
							      (iup:destroy! fd))))		      
                           (iup:menu-item "Save"  #:action (lambda (obj)(print "File->save " obj)))
                           (iup:menu-item "Exit"  #:action (lambda (obj)(exit)))))
   (iup:menu-item "Tools" (iup:menu
			   (iup:menu-item "Create new blah" #:action (lambda (obj)(print "Tools->new blah")))
			   ;; (iup:menu-item "Show dialog"     #:action (lambda (obj)
			   ;;  					   (show message-window
			   ;;  					     #:modal? #t
			   ;;  					     ;; set positon using coordinates or center, start, top, left, end, bottom, right, parent-center, current
			   ;;  					     ;; #:x 'mouse
			   ;;  					     ;; #:y 'mouse
			   ;;  )					     
			   ))))


(define (dashboard:area-panel aname data window-id)
  (let* ((apath      (configf:lookup (data-cfgdat data) aname "path")) ;;  (hash-table-ref (dboard:data-cfgdat data) area-name))
	 ;;          (hash-table-ref (dboard:data-cfgdat data) aname))
	 (area-dat   (dashboard:init-area data aname apath))
	 (tb         (dashboard:tree-browser data area-dat window-id)) ;; (dboard:areas-tree-browser data)
	 (ad         (dashboard:main-matrix  data area-dat window-id))
︙
552
553
554
555
556
557
558
559

560
561
562
563
564
565
566

601
602
603
604
605
606
607

608
609
610
611
612
613
614
615








-
+










;; Main Panel
;;
(define (dashboard:main-panel data window-id)
  (iup:dialog
   #:title "Megatest Control Panel"
;;   #:menu (dcommon:main-menu data)
   #:menu (dcommon:main-menu data)
   #:shrink "YES"
   (iup:vbox
    (let* ((area-names  (hash-table-keys (data-cfgdat data)))
	   (area-panels (map (lambda (aname)
			       (dashboard:area-panel aname data window-id))
			     area-names))
	   (tabtop      (apply iup:tabs
︙
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

776
777
778

779
780
781
782
783
784
785

796
797
798
799
800
801
802



803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840








-
-
-
+
+
+
+
+
+
+



















+



+








;; )

(define (dboard:read-mtconf apath)
  (let* ((mtconffile  (conc apath "/megatest.config")))
    (call-with-environment-variables
     (list (cons "MT_RUN_AREA_HOME" apath))
     (lambda ()
       (read-config mtconffile (make-hash-table) #f)) ;; megatest.config
     )))
	 
       (let ((res (read-config mtconffile (make-hash-table) #f))) ;; megatest.config
	 (if (hash-table? res)
	     res
	     (begin
	       (debug:print 0 "WARNING: failed to read " mtconffile)
	       (make-hash-table))))))))


;;======================================================================
;; G U I   S T U F F 
;;======================================================================

;;; main. Theoretically could have multiple windows (each with a group of tags, thus window-id
;;;
(define (dboard:make-window window-id)
  (let* (;; (window-id 0)
	 (groupn    (or (args:get-arg "-group") "default"))
	 (cfgdat    (dboard:get-config groupn))
	 ;; (cfgdat    (if (file-exists? cfname)(read-config cfname (make-hash-table) #t)(make-hash-table)))
	 (data      (make-data
		     cfgdat ;; this is the data from ~/.megatest for the selected group
		     (make-hash-table) ;; areaname -> area-rec
		     0                 ;; current window id
		     0                 ;; current tab id
		     #f                ;; redraw needed for current tab id
		     (make-hash-table) ;; tab-id -> areaname
                     groupn
		     )))
    (hash-table-set! *windows* window-id data)
    (iup:show (dashboard:main-panel data window-id))
    ;;(iup:show (layout-dialog (dashboard:main-panel data window-id)))
    (iup:main-loop)))

;; ease debugging by loading ~/.dashboardrc
(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.dashboardrc")))
  (if (file-exists? debugcontrolf)
      (load debugcontrolf)))
︙

Modified tests/fullrun/multi-dboard.sh from [b641343611] to [9629538735].

︙
12
13
14
15
16
17
18
19

20
21
22
23
24
25
26
27
28
29
30


12
13
14
15
16
17
18

19
20
21
22
23
24
25
26
27
28
29

30








-
+










-
+

# [local]
# localtest /home/matt/data/megatest/tests/fullrun
# EOF
# fi
if [[ ! -e "$HOME/.megatest/default.dat" ]];then
   cat > "$HOME/.megatest/default.dat" << EOF
[fullrun]
path /mfs/matt/data/megatest/tests/fullrun
path /home/USER/myMegatestArea
order 1
# [bigrun]
# path /mfs/matt/data/megatest/tests/fdktestqa/testqa
# order 2
# [local_fullrun]
# path /home/matt/data/megatest/tests/fullrun
# order 3
EOF
fi

csi -I ../.. multi-dboard-load-all.scm
/nfs/pdx/disks/icf_external/pkgs/chicken/4.10.0/bin/csi -I ../.. multi-dboard-load-all.scm

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