Megatest

Diff
Login

Differences From Artifact [d249feea17]:

To Artifact [85c9231672]:


8
9
10
11
12
13
14
15
16
17

18



19
































20
21
22
23
24










25



26


27

28
29

30
31
32
33
34

35
36
37


38
39



40
41
42

43
44
45


46
47
48
49
50
51












52
53
54
55
56
57
58
59
;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;;  PURPOSE.
;;======================================================================

;;======================================================================
;;
;;======================================================================
(define (examine-test db test-id) ;; run-id run-key origtest)
  (let* ((testdat   (db:get-test-data-by-id db test-id))
	 (run-id    (if testdat (db:test-get-run_id testdat) #f))

	 (rundat    (if testdat (db:get-run-info db run-id)))



	 (teststeps (if testdat (db:get-steps-for-test db test-id))))
































    (cond
     ((not testdat)(begin (print "ERROR: bad test info for " test-id)(exit 1)))
     ((not rundat)(begin (print "ERROR: found test info but there is a problem with the run info for " run-id)(exit 1)))
     (else
      (let* ((widgets      (make-hash-table)) ;; put the widgets to update in this hashtable










	     (logfile      (conc (db:test-get-rundir testdat) "/" (db:test-get-final_logf testdat)))



	     (viewlog      (lambda (x)


			     (if (file-exists? logfile)

				 (system (conc "firefox " logfile "&"))
				 (message-window (conc "File " logfile " not found")))))

	     (xterm        (lambda (x)
			     (if (directory-exists? rundir)
				 (let ((shell (if (get-environment-variable "SHELL") 
						  (conc "-e " (get-environment-variable "SHELL"))
						  "")))

				   (system (conc "cd " rundir 
						 ";xterm -T \"" (string-translate testfullname "()" "  ") "\" " shell "&")))
				 (message-window  (conc "Directory " rundir " not found")))))


	     (self         #f))
	



	  (hash-table-set! widgets "testdat" testdat)
	  (hash-table-set! widgets "rundat"  rundat)
	  

	  ;;  (test-set-status! db run-id test-name state status itemdat)
	  (set! self 
		(iup:dialog


		 #:title "testfullname"
		 (iup:hbox ;; Need a full height box for all the test steps
		  (iup:vbox
		   (iup:hbox 
		    (iup:frame (iup:label "BLAH (was run-key)")))))))
	  (iup:show self)












	  )))))

;;
;;		    (iup:frame (iup:label (conc "TESTNAME:\n" testfullname) #:expand "YES")))
;;		   (iup:frame #:title "Actions" #:expand "YES"
;;			      (iup:hbox ;; the actions box
;;			       (iup:button "View Log"    #:action viewlog  #:expand "YES")
;;			       (iup:button "Start Xterm" #:action xterm  #:expand "YES")))







|
|
|
>
|
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>




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







8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
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
75
76
77
78
79
80

81
82



83
84
85


86
87
88
89
90
91
92
93

94
95
96
97
98
99
100
101

102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;;  PURPOSE.
;;======================================================================

;;======================================================================
;;
;;======================================================================
(define (examine-test db test-id other-thread) ;; run-id run-key origtest)
  (let* ((testdat       (db:get-test-data-by-id db test-id))
	 (run-id        (if testdat (db:test-get-run_id testdat) #f))
	 (keydat        (if testdat (keys:get-key-val-pairs db run-id) #f))
	 (rundat        (if testdat (db:get-run-info db run-id) #f))
	 (runname       (if testdat (db:get-value-by-header (db:get-row rundat)
							    (db:get-header rundat)
							    "runname") #f))
	 (teststeps     (if testdat (db:get-steps-for-test db test-id) #f))
	 (logfile       "/this/dir/better/not/exist")
	 (rundir        logfile)
	 (testfullname  (if testdat (db:test-get-fullname testdat) "Gathering data ..."))
	 (viewlog    (lambda (x)
		       (if (file-exists? logfile)
			   (system (conc "firefox " logfile "&"))
			   (message-window (conc "File " logfile " not found")))))
	 (xterm      (lambda (x)
		       (if (directory-exists? rundir)
			   (let ((shell (if (get-environment-variable "SHELL") 
					    (conc "-e " (get-environment-variable "SHELL"))
					    "")))
			     (system (conc "cd " rundir 
					   ";xterm -T \"" (string-translate testfullname "()" "  ") "\" " shell "&")))
			   (message-window  (conc "Directory " rundir " not found")))))
	 (refreshdat (lambda ()
		       (set! testdat      (db:get-test-data-by-id db test-id))
		       (set! teststeps    (db:get-steps-for-test db test-id))
		       (set! logfile      (conc (db:test-get-rundir testdat) "/" (db:test-get-final_logf testdat)))
		       (set! rundir       (db:test-get-rundir testdat))
		       (set! testfullname (db:test-get-fullname testdat))))
	 (widgets      (make-hash-table))
	 (self         #f)
	 (store-label  (lambda (name lbl cmd)
			 (hash-table-set! widgets name (lambda ()
							 (iup:attribute-set! lbl "TITLE" (cmd))))
			 lbl))
	 (store-button (lambda (name btn cmd)
			 (hash-table-set! widgets name (lambda (cmd)
							 (iup:attribute-set! btn "TITLE" (cmd))))
			 btn))
	 )
    (cond
     ((not testdat)(begin (print "ERROR: bad test info for " test-id)(exit 1)))
     ((not rundat)(begin (print "ERROR: found test info but there is a problem with the run info for " run-id)(exit 1)))
     (else
      ;;  (test-set-status! db run-id test-name state status itemdat)
      (set! self 
	    (iup:dialog
	     #:title testfullname
	     (iup:hbox  #:expand "BOTH" ;; Need a full height box for all the test steps
	      (iup:vbox #:expand "BOTH"
	       (iup:hbox  #:expand "BOTH"
		(iup:frame #:title "Run Info" #:expand "VERTICAL"
			   (iup:hbox #:expand "BOTH"
			    (apply iup:vbox #:expand "BOTH"
				   (append (map (lambda (keyval)
						  (iup:label (conc (car keyval) " ") #:expand "HORIZONTAL"))
						keydat)
					   (list (iup:label "runname "))))
			    (apply iup:vbox
				   (append (map (lambda (keyval)
						  (iup:label (cadr keyval) #:expand "HORIZONTAL"))
						keydat)
					   (list (iup:label runname))))))
		(iup:frame #:title "Test Info" #:expand "VERTICAL"
			   (iup:hbox #:expand "BOTH"

			    (apply iup:vbox #:expand "BOTH"
				   (map (lambda (val)



					  (iup:label val #:expand "HORIZONTAL"))
					(list "Testname: "
					      "Item path: "


					      "Current state: "
					      "Current status: "
					      "Test comment: ")))
			    (apply iup:vbox  #:expand "BOTH"
				   (list 
				    (iup:label (db:test-get-testname  testdat) #:expand "BOTH")
				    (iup:label (db:test-get-item-path testdat) #:expand "BOTH")
				    (store-label "teststate" 

						 (iup:label "TestState" #:expand "BOTH")
						 (lambda ()
						   (db:test-get-state testdat)))
				    (store-label "teststatus"
						 (iup:label "TestStatus" #:expand "BOTH")
						 (lambda ()
						   (db:test-get-status    testdat)))
				    (store-label "testcomment"

						 (iup:label "TestComment" #:expand "BOTH")
						 (lambda ()
						   (db:test-get-comment   testdat))))))))))))
      (iup:show self)
      ;; Now start keeping the gui updated from the db
      (let loop ((i 0))
	(thread-sleep! 0.1)
	(refreshdat) ;; update from the db here
	(thread-suspend! other-thread)
	;; update the gui elements here
	(for-each 
	 (lambda (key)
	   (print "Updating " key)
	   ((hash-table-ref widgets key)))
	 (hash-table-keys widgets))
	(thread-resume! other-thread)
	(loop i))))))

;;
;;		    (iup:frame (iup:label (conc "TESTNAME:\n" testfullname) #:expand "YES")))
;;		   (iup:frame #:title "Actions" #:expand "YES"
;;			      (iup:hbox ;; the actions box
;;			       (iup:button "View Log"    #:action viewlog  #:expand "YES")
;;			       (iup:button "Start Xterm" #:action xterm  #:expand "YES")))