Megatest

Check-in [915e74bc33]
Login
☰Home Timeline Files Branches Tags Tickets Wiki Login
Overview
Comment:wip
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | v1.65-custom-menu
Files: files | file ages | folders
SHA1: 915e74bc332cca88f57964fe501c1d5c05b6e79a
User & Date: bb on 2018-02-13 23:10:27
Other Links: branch diff | manifest | tags
Context
2018-02-14
00:33
tested basic functionality - custom context menu items now available check-in: ae21e2aec1 user: bb tags: v1.65-custom-menu
2018-02-13
23:10
wip check-in: 915e74bc33 user: bb tags: v1.65-custom-menu
18:10
wip check-in: d05d52e750 user: bjbarcla tags: v1.65-custom-menu
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Modified Makefile from [6f749a00c0] to [7cd05c6ca0].

︙︙
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33


# Eggs to install (straightforward ones)
EGGS=matchable readline apropos base64 regex-literals format regex-case test coops trace csv \
dot-locking posix-utils posix-extras directory-utils hostinfo tcp-server rpc csv-xml fmt \
json md5 awful http-client spiffy uri-common intarweb spiffy-request-vars \
spiffy-directory-listing ssax sxml-serializer sxml-modifications iup canvas-draw sqlite3

GUISRCF  = dashboard-tests.scm dashboard-guimonitor.scm gutils.scm dcommon.scm tree.scm vg.scm

OFILES   = $(SRCFILES:%.scm=%.o)
GOFILES  = $(GUISRCF:%.scm=%.o)

MOFILES = $(addprefix mofiles/,$(MSRCFILES:%.scm=%.o))

mofiles/%.o : %.scm








|








19
20
21
22
23
24
25
26
27
28
29
30
31
32
33


# Eggs to install (straightforward ones)
EGGS=matchable readline apropos base64 regex-literals format regex-case test coops trace csv \
dot-locking posix-utils posix-extras directory-utils hostinfo tcp-server rpc csv-xml fmt \
json md5 awful http-client spiffy uri-common intarweb spiffy-request-vars \
spiffy-directory-listing ssax sxml-serializer sxml-modifications iup canvas-draw sqlite3

GUISRCF  = dashboard-context-menu.scm dashboard-tests.scm dashboard-guimonitor.scm gutils.scm dcommon.scm tree.scm vg.scm

OFILES   = $(SRCFILES:%.scm=%.o)
GOFILES  = $(GUISRCF:%.scm=%.o)

MOFILES = $(addprefix mofiles/,$(MSRCFILES:%.scm=%.o))

mofiles/%.o : %.scm
︙︙
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140

#	csc $(CSCOPTS) $(OFILES) $(GOFILES) multi-dboard.scm -o multi-dboard

# 
# $(PREFIX)/bin/revtagfsl : utils/revtagfsl.scm
#	csc utils/revtagfsl.scm -o $(PREFIX)/bin/revtagfsl

# Special dependencies for the includes
tests.o db.o launch.o runs.o dashboard-tests.o dashboard-guimonitor.o dashboard-main.o monitor.o dashboard.o  \
archive.o megatest.o : db_records.scm
tests.o runs.o dashboard.o dashboard-tests.o dashboard-main.o  : run_records.scm
db.o ezsteps.o keys.o launch.o megatest.o monitor.o runs-for-ref.o runs.o tests.o : key_records.scm
tests.o tasks.o dashboard-tasks.o : task_records.scm
runs.o : test_records.scm
megatest.o : megatest-fossil-hash.scm
rmt.scm client.scm common.scm configf.scm dashboard-guimonitor.scm dashboard-tests.scm dashboard.scm db.scm dcommon.scm ezsteps.scm fs-transport.scm http-transport.scm index-tree.scm items.scm keys.scm launch.scm megatest.scm monitor.scm mt.scm newdashboard.scm runconfig.scm runs.scm server.scm tdb.scm tests.scm tree.scm : common_records.scm rpc-transport.scm
common_records.scm : altdb.scm
vg.o dashboard.o : vg_records.scm
dcommon.o : run_records.scm
# Temporary while transitioning to new routine
# runs.o : run-tests-queue-classic.scm  run-tests-queue-new.scm

megatest-fossil-hash.scm : $(SRCFILES) megatest.scm *_records.scm








|

|




|








119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140

#	csc $(CSCOPTS) $(OFILES) $(GOFILES) multi-dboard.scm -o multi-dboard

# 
# $(PREFIX)/bin/revtagfsl : utils/revtagfsl.scm
#	csc utils/revtagfsl.scm -o $(PREFIX)/bin/revtagfsl

# Special dependencies for the includes
tests.o db.o launch.o runs.o dashboard-tests.o dashboard-context-menu.o dashboard-guimonitor.o dashboard-main.o monitor.o dashboard.o  \
archive.o megatest.o : db_records.scm
tests.o runs.o dashboard.o dashboard-tests.o dashboard-context-menu.o dashboard-main.o  : run_records.scm
db.o ezsteps.o keys.o launch.o megatest.o monitor.o runs-for-ref.o runs.o tests.o : key_records.scm
tests.o tasks.o dashboard-tasks.o : task_records.scm
runs.o : test_records.scm
megatest.o : megatest-fossil-hash.scm
rmt.scm client.scm common.scm configf.scm dashboard-guimonitor.scm dashboard-tests.scm dashboard-context-menu.scm dashboard.scm db.scm dcommon.scm ezsteps.scm fs-transport.scm http-transport.scm index-tree.scm items.scm keys.scm launch.scm megatest.scm monitor.scm mt.scm newdashboard.scm runconfig.scm runs.scm server.scm tdb.scm tests.scm tree.scm : common_records.scm rpc-transport.scm
common_records.scm : altdb.scm
vg.o dashboard.o : vg_records.scm
dcommon.o : run_records.scm
# Temporary while transitioning to new routine
# runs.o : run-tests-queue-classic.scm  run-tests-queue-new.scm

megatest-fossil-hash.scm : $(SRCFILES) megatest.scm *_records.scm
︙︙
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386

	if  csi -ne '(use mysql-client)';then \
           echo "(use mysql-client)(hash-table-set! *available-db* 'mysql #t)" >> altdb.scm; \
	fi
	if csi -ne '(use postgresql)';then \
	   echo "(use postgresql)(hash-table-set! *available-db* 'postgresql #t)" >> altdb.scm;\
	fi

portlogger-example : portlogger-example.scm api.o archive.o client.o common.o configf.o daemon.o dashboard-tests.o db.o dcommon.o ezsteps.o filedb.o genexample.o gutils.o http-transport.o items.o keys.o launch.o lock-queue.o margs.o megatest-version.o mt.o ods.o portlogger.o process.o rmt.o rpc-transport.o runconfig.o runs.o sdb.o server.o synchash.o tasks.o tdb.o tests.o tree.o
	csc $(CSCOPTS) portlogger-example.scm api.o archive.o client.o common.o configf.o daemon.o dashboard-tests.o db.o dcommon.o ezsteps.o filedb.o genexample.o gutils.o http-transport.o items.o keys.o launch.o lock-queue.o margs.o megatest-version.o mt.o ods.o portlogger.o process.o rmt.o rpc-transport.o runconfig.o runs.o sdb.o server.o synchash.o tasks.o tdb.o tests.o tree.o

# create a pdf dot graphviz diagram from notations in rmt.scm
rmt.pdf : rmt.scm
	grep ';;DOT' rmt.scm | sed -e 's/.*;;DOT //' > rmt.dot;dot -Tpdf rmt.dot -o rmt.pdf

buildmanual:
	cd docs/manual && make








|
|








371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386

	if  csi -ne '(use mysql-client)';then \
           echo "(use mysql-client)(hash-table-set! *available-db* 'mysql #t)" >> altdb.scm; \
	fi
	if csi -ne '(use postgresql)';then \
	   echo "(use postgresql)(hash-table-set! *available-db* 'postgresql #t)" >> altdb.scm;\
	fi

portlogger-example : portlogger-example.scm api.o archive.o client.o common.o configf.o daemon.o dashboard-tests.o dashboard-context-menu.o db.o dcommon.o ezsteps.o filedb.o genexample.o gutils.o http-transport.o items.o keys.o launch.o lock-queue.o margs.o megatest-version.o mt.o ods.o portlogger.o process.o rmt.o rpc-transport.o runconfig.o runs.o sdb.o server.o synchash.o tasks.o tdb.o tests.o tree.o
	csc $(CSCOPTS) portlogger-example.scm api.o archive.o client.o common.o configf.o daemon.o dashboard-tests.o dashboard-context-menu.o db.o dcommon.o ezsteps.o filedb.o genexample.o gutils.o http-transport.o items.o keys.o launch.o lock-queue.o margs.o megatest-version.o mt.o ods.o portlogger.o process.o rmt.o rpc-transport.o runconfig.o runs.o sdb.o server.o synchash.o tasks.o tdb.o tests.o tree.o

# create a pdf dot graphviz diagram from notations in rmt.scm
rmt.pdf : rmt.scm
	grep ';;DOT' rmt.scm | sed -e 's/.*;;DOT //' > rmt.dot;dot -Tpdf rmt.dot -o rmt.pdf

buildmanual:
	cd docs/manual && make
︙︙

Added dashboard-context-menu.scm version [01bb33e0f6]. 





















































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>

1
2
3
4
5
6
7
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
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249

;;======================================================================
;; Copyright 2006-2012, Matthew Welland.
;; 
;;  This program is made available under the GNU GPL version 2.0 or
;;  greater. See the accompanying file COPYING for details.
;; 
;;  This program is distributed WITHOUT ANY WARRANTY; without even the
;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;;  PURPOSE.
;;======================================================================

;;======================================================================
;; Test info panel
;;======================================================================

(use format fmt)
(require-library iup)
(import (prefix iup iup:))

(use canvas-draw)

(use srfi-1 posix regex regex-case srfi-69)
(use (prefix sqlite3 sqlite3:))

(declare (unit dashboard-context-menu))
(declare (uses common))
(declare (uses db))
(declare (uses gutils))
(declare (uses rmt))
(declare (uses ezsteps))
;; (declare (uses sdb))
;; (declare (uses filedb))
(declare (uses subrun))

(include "common_records.scm")
(include "db_records.scm")
(include "run_records.scm")


(define (dashboard:run-menu-items  run-id test-id target runname test-name testpatt item-test-path test-info)
  (list
   (iup:menu-item
    (conc "Rerun " testpatt)
    #:action
    (lambda (obj)
      ;; (print  " run-id: " run-id " test-id: " test-id " target: " target " runname: " runname " test-name: " test-name " testpatt: " testpatt "item-path : " item-path)
      (common:run-a-command
       (conc "megatest -run -target " target
             " -runname " runname
             " -testpatt " testpatt
             " -preclean -clean-cache")
       )))
   (iup:menu-item
    "Rerun Complete Run"
    #:action
    (lambda (obj)
      (common:run-a-command
       (conc "megatest -set-state-status NOT_STARTED,n/a -run -target " target
             " -runname " runname
             " -testpatt % "
             " -preclean -clean-cache"))))
   (iup:menu-item
    "Clean Complete Run"
    #:action
    (lambda (obj)
      (common:run-a-command
       (conc "megatest -remove-runs -target " target
             " -runname " runname
             " -testpatt % "))))
   (iup:menu-item 
    "Kill Complete Run"
    #:action
    (lambda (obj)
      (common:run-a-command
       (conc "megatest -set-state-status KILLREQ,n/a -target " target
             " -runname " runname
             " -testpatt % "
             "  -state RUNNING,REMOTEHOSTSTART,LAUNCHED,NOT_STARTED"))))
   (iup:menu-item 
    "Delete Run Data"
    #:action
    (lambda (obj)
      (common:run-a-command
       (conc "megatest -remove-runs -target " target
             " -runname " runname
             " -testpatt % "
             "  -keep-records"))))))

(define (dashboard:test-menu-items  run-id test-id target runname test-name testpatt item-test-path test-info)
  (list
   (iup:menu-item
    (conc "Rerun " item-test-path)
    #:action
    (lambda (obj)
      (common:run-a-command
       (conc "megatest -set-state-status NOT_STARTED,n/a -run -target " target
             " -runname " runname
             " -testpatt " item-test-path
             " -preclean -clean-cache"))))
   (iup:menu-item
    (conc "Kill " item-test-path)
    #:action
    (lambda (obj)
      ;; (rmt:test-set-state-status-by-id run-id test-id "KILLREQ" #f #f)
      (common:run-a-command
       (conc "megatest -set-state-status KILLREQ,n/a -target " target
             " -runname " runname
             " -testpatt " item-test-path 
             " -state RUNNING,REMOTEHOSTSTART,LAUNCHED"))))
   (iup:menu-item
    (conc "Delete data : " item-test-path)
    #:action
    (lambda (obj)
      (common:run-a-command
       (conc "megatest -remove-runs -target " target
             " -runname " runname
             " -testpatt " item-test-path 
             " -keep-records"))))
   (iup:menu-item
    (conc "Clean "item-test-path)
    #:action
    (lambda (obj)
      (common:run-a-command
       (conc "megatest -remove-runs -target " target
             " -runname " runname
             " -testpatt " item-test-path))))
   (iup:menu-item
    "Start xterm"
    #:action
    (lambda (obj)
      (dcommon:examine-xterm run-id test-id)))
   ;;(let* ((cmd (conc (car (argv)) " -xterm " run-id "," test-id "&")))
   ;; (system cmd))))
   (iup:menu-item
    "Edit testconfig"
    #:action
    (lambda (obj)
      (let* ((all-tests (tests:get-all))
             (editor-rx (or (configf:lookup *configdat* "setup" "editor-regex") 
                            "\\b(vim?|nano|pico)\\b"))
             (editor (or (configf:lookup *configdat* "setup" "editor")
                         (get-environment-variable "VISUAL")
                         (get-environment-variable "EDITOR") "vi"))
             (tconfig (conc (hash-table-ref all-tests test-name) "/testconfig"))
             (cmd (conc (if (string-search editor-rx editor)
                            (conc "xterm -e " editor)
                            editor)
                        " " tconfig " &")))
        (system cmd))))))

(define (dashboard:toplevel-menu-items  run-id test-id target runname test-name testpatt item-test-path test-info)
  (list
   (iup:menu-item
    (conc "Rerun " item-test-path)
    #:action
    (lambda (obj)
      (common:run-a-command
       (conc "megatest -set-state-status NOT_STARTED,n/a -run -target " target
             " -runname " runname
             " -testpatt " item-test-path
             " -preclean -clean-cache"))))
   
   (iup:menu-item
    "Start xterm"
    #:action
    (lambda (obj)
      (dcommon:examine-xterm run-id test-id)))
   
   (iup:menu-item
    (conc "Kill " item-test-path)
    #:action
    (lambda (obj)
      ;; (rmt:test-set-state-status-by-id run-id test-id "KILLREQ" #f #f)
      (common:run-a-command
       (conc "megatest -set-state-status KILLREQ,n/a -target " target
             " -runname " runname
             " -testpatt " item-test-path 
             " -state RUNNING,REMOTEHOSTSTART,LAUNCHED,NOT_STARTED"))))
   
   (let* ((rundir    (db:test-get-rundir      test-info))
          (has-subrun (subrun:subrun-test-initialized? rundir)))
     (if has-subrun
         (iup:menu-item
          "Launch subrun dashboard"
          #:action
          (lambda (obj)
            (subrun:launch-dashboard rundir)))
         (iup:vbox)))
   (iup:menu 
    (iup:menu-item
     "Test Control Panel"
     #:action
     (lambda (obj)
       (launch-testpanel run-id test-id)))
    
    (iup:menu-item
     (conc "View Log " item-test-path)
     #:action
     (lambda (obj)
       (let* ((rundir    (db:test-get-rundir      test-info))
              (logf      (db:test-get-final_logf  test-info))
              (fullfile  (conc rundir "/" logf)))
         (if (common:file-exists? fullfile)
             (dcommon:run-html-viewer fullfile)
             (message-window (conc "file " fullfile " not found.")))))
     )
    (let* ((steps (tests:get-compressed-steps run-id test-id))   ;; #<stepname start end status Duration Logfile Comment id>
           (rundir (db:test-get-rundir test-info)))
      (iup:menu-item
       "Step logs"
       (apply iup:menu
              (map (lambda (step)
                     (let ((stepname (vector-ref step 0))
                           (logfile  (vector-ref step 5))
                           (status   (vector-ref step 3)))
                       (iup:menu-item
                        (conc stepname "/" (if (string=? logfile "") "no log!" logfile) " (" status ")")
                        #:action (lambda (obj)
                                   (let ((fullfile (conc rundir "/" logfile)))
                                     (if (common:file-exists? fullfile)
                                         (dcommon:run-html-viewer fullfile)
                                         (message-window (conc "file " fullfile " not found"))))))))
                   steps)))))))

(define (dashboard:custom-menu-items  run-id test-id target runname test-name testpatt item-test-path test-info)
  '())

(define (dashboard:context-menu  run-id test-id target runname test-name testpatt item-test-path test-info)
  (let* (
         (run-menu-items
          (dashboard:run-menu-items  run-id test-id target runname test-name testpatt item-test-path test-info))
         (test-menu-items
          (dashboard:test-menu-items  run-id test-id target runname test-name testpatt item-test-path test-info))
         (custom-menu-items
          (dashboard:custom-menu-items run-id test-id target runname test-name testpatt item-test-path test-info))
         (toplevel-menu-items
          (dashboard:toplevel-menu-items  run-id test-id target runname test-name testpatt item-test-path test-info))
         )
    (apply iup:menu
           `(,@toplevel-menu-items
             ,(iup:menu-item
              "Run"
              (apply iup:menu run-menu-items))
             ,(iup:menu-item
              "Test"
              (apply iup:menu test-menu-items))
             ,@(if (null? custom-menu-items)
                   '()
                   custom-menu-items)))))

Modified dashboard.scm from [d7ea6a4a7b] to [f416dfe09d].

︙︙
29
30
31
32
33
34
35

36
37
38
39
40
41
42

(declare (uses process))
(declare (uses launch))
(declare (uses runs))
(declare (uses dashboard-tests))
(declare (uses dashboard-guimonitor))
(declare (uses tree))
(declare (uses dcommon))

(declare (uses vg))
(declare (uses subrun))
;; (declare (uses dashboard-main))
(declare (uses megatest-version))
(declare (uses mt))

(include "common_records.scm")








>








29
30
31
32
33
34
35
36
37
38
39
40
41
42
43

(declare (uses process))
(declare (uses launch))
(declare (uses runs))
(declare (uses dashboard-tests))
(declare (uses dashboard-guimonitor))
(declare (uses tree))
(declare (uses dcommon))
(declare (uses dashboard-context-menu))
(declare (uses vg))
(declare (uses subrun))
;; (declare (uses dashboard-main))
(declare (uses megatest-version))
(declare (uses mt))

(include "common_records.scm")
︙︙
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178

                             (cond
                              ((member #\1 status-chars) ;; 1 is left mouse button
                               (dboard:launch-testpanel run-id test-id))
                              
                              ((member #\2 status-chars) ;; 2 is middle mouse button
                               
                               (debug:print-info 13 *default-log-port* "mmb- test-name="test-name" testpatt="testpatt)
                               (iup:show (dashboard:popup-menu run-id test-id target runname test-name testpatt item-test-path test-info) ;; popup-menu
                                         #:x 'mouse
                                         #:y 'mouse
                                         #:modal? "NO")
                               )
                              (else
                               (debug:print-info 13 *default-log-port* "unhandled status in run-summary-click-cb.  Doing right click action. (status is corrupted on Brandon's ubuntu host - bad/buggy  iup install??" )
                               (iup:show (dashboard:popup-menu run-id test-id target runname test-name testpatt item-test-path test-info) ;; popup-menu
                                         #:x 'mouse
                                         #:y 'mouse
                                         #:modal? "NO")
                               )
                              )
                            
                             )) "runs-summary-click-callback"))))








|






|








2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179

                             (cond
                              ((member #\1 status-chars) ;; 1 is left mouse button
                               (dboard:launch-testpanel run-id test-id))
                              
                              ((member #\2 status-chars) ;; 2 is middle mouse button
                               
                               (debug:print-info 13 *default-log-port* "mmb- test-name="test-name" testpatt="testpatt)
                               (iup:show (dashboard:context-menu run-id test-id target runname test-name testpatt item-test-path test-info) ;; popup-menu
                                         #:x 'mouse
                                         #:y 'mouse
                                         #:modal? "NO")
                               )
                              (else
                               (debug:print-info 13 *default-log-port* "unhandled status in run-summary-click-cb.  Doing right click action. (status is corrupted on Brandon's ubuntu host - bad/buggy  iup install??" )
                               (iup:show (dashboard:context-menu run-id test-id target runname test-name testpatt item-test-path test-info) ;; popup-menu
                                         #:x 'mouse
                                         #:y 'mouse
                                         #:modal? "NO")
                               )
                              )
                            
                             )) "runs-summary-click-callback"))))
︙︙
2402
2403
2404
2405
2406
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
2478
2479
2480
2481
2482
2483
2484
2485
2486
2487
2488
2489
2490
2491
2492
2493
2494
2495
2496
2497
2498
2499
2500
2501
2502
2503
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
2523
2524
2525
2526
2527
2528
2529
2530
2531
2532
2533
2534
2535
2536
2537
2538
2539
2540
2541
2542
2543
2544
2545
2546
2547
2548
2549
2550
2551
2552
2553
2554
2555
2556
2557
2558
2559
2560
2561
2562
2563
2564
2565
2566
2567
2568
2569
2570
2571
2572
2573
2574
2575
2576
2577
2578
2579
2580
2581
2582
2583
2584
2585
2586
2587
2588
2589
2590
2591
2592
2593
2594
2595
2596
2597
2598
2599
2600
2601
2602
2603
2604
2605
2606
2607
2608
2609
2610
2611
2612
2613
2614
2615

				      (iup:attribute-set! obj "MAX" (* maxruns 10))))
		#:expand "HORIZONTAL"
		#:max (* 10 (max (hash-table-size (dboard:tabdat-allruns-by-id tabdat)) 10))
		#:min 0
		#:step 0.01))


(define (dashboard:popup-menu  run-id test-id target runname test-name testpatt item-test-path test-info)
  (iup:menu 
   (iup:menu-item
    "Test Control Panel"
    #:action
    (lambda (obj)
      (launch-testpanel run-id test-id)))
   
   (iup:menu-item
    (conc "View Log " item-test-path)
    #:action
    (lambda (obj)
      (let* ((rundir    (db:test-get-rundir      test-info))
	     (logf      (db:test-get-final_logf  test-info))
	     (fullfile  (conc rundir "/" logf)))
	(if (common:file-exists? fullfile)
	    (dcommon:run-html-viewer fullfile)
	    (message-window (conc "file " fullfile " not found.")))))
    )
   (let* ((steps (tests:get-compressed-steps run-id test-id))   ;; #<stepname start end status Duration Logfile Comment id>
	  (rundir (db:test-get-rundir test-info)))
     (iup:menu-item
      "Step logs"
      (apply iup:menu
	     (map (lambda (step)
		    (let ((stepname (vector-ref step 0))
			  (logfile  (vector-ref step 5))
			  (status   (vector-ref step 3)))
		      (iup:menu-item
		       (conc stepname "/" (if (string=? logfile "") "no log!" logfile) " (" status ")")
		       #:action (lambda (obj)
				  (let ((fullfile (conc rundir "/" logfile)))
				    (if (common:file-exists? fullfile)
					(dcommon:run-html-viewer fullfile)
					(message-window (conc "file " fullfile " not found"))))))))
		  steps))))
   (iup:menu-item
    (conc "Rerun " item-test-path)
    #:action
    (lambda (obj)
      (common:run-a-command
       (conc "megatest -set-state-status NOT_STARTED,n/a -run -target " target
             " -runname " runname
             " -testpatt " item-test-path
             " -preclean -clean-cache"))))
   
   (iup:menu-item
    "Start xterm"
    #:action
    (lambda (obj)
      (dcommon:examine-xterm run-id test-id)))

   (iup:menu-item
    (conc "Kill " item-test-path)
    #:action
    (lambda (obj)
      ;; (rmt:test-set-state-status-by-id run-id test-id "KILLREQ" #f #f)
      (common:run-a-command
       (conc "megatest -set-state-status KILLREQ,n/a -target " target
             " -runname " runname
             " -testpatt " item-test-path 
             " -state RUNNING,REMOTEHOSTSTART,LAUNCHED,NOT_STARTED"))))

   (let* ((rundir    (db:test-get-rundir      test-info))
          (has-subrun (subrun:subrun-test-initialized? rundir)))
       (if has-subrun
           (iup:menu-item
            "Launch subrun dashboard"
            #:action
            (lambda (obj)
              (subrun:launch-dashboard rundir)))
           (iup:vbox)))

   (let* ((run-menu-items
           (list
            (iup:menu-item
             (conc "Rerun " testpatt)
             #:action
             (lambda (obj)
               ;; (print  " run-id: " run-id " test-id: " test-id " target: " target " runname: " runname " test-name: " test-name " testpatt: " testpatt "item-path : " item-path)
               (common:run-a-command
                (conc "megatest -run -target " target
                      " -runname " runname
                      " -testpatt " testpatt
                      " -preclean -clean-cache")
                )))
            (iup:menu-item
             "Rerun Complete Run"
             #:action
             (lambda (obj)
               (common:run-a-command
                (conc "megatest -set-state-status NOT_STARTED,n/a -run -target " target
                      " -runname " runname
                      " -testpatt % "
                      " -preclean -clean-cache"))))
            (iup:menu-item
             "Clean Complete Run"
             #:action
             (lambda (obj)
               (common:run-a-command
                (conc "megatest -remove-runs -target " target
                      " -runname " runname
                      " -testpatt % "))))
            (iup:menu-item 
             "Kill Complete Run"
             #:action
             (lambda (obj)
               (common:run-a-command
                (conc "megatest -set-state-status KILLREQ,n/a -target " target
                      " -runname " runname
                      " -testpatt % "
                      "  -state RUNNING,REMOTEHOSTSTART,LAUNCHED,NOT_STARTED"))))
            (iup:menu-item 
             "Delete Run Data"
             #:action
             (lambda (obj)
               (common:run-a-command
                (conc "megatest -remove-runs -target " target
                      " -runname " runname
                      " -testpatt % "
                      "  -keep-records"))))))
          (test-menu-items
           (iup:menu-item
            (conc "Rerun " item-test-path)
            #:action
            (lambda (obj)
              (common:run-a-command
               (conc "megatest -set-state-status NOT_STARTED,n/a -run -target " target
                     " -runname " runname
                     " -testpatt " item-test-path
                     " -preclean -clean-cache"))))
           (iup:menu-item
            (conc "Kill " item-test-path)
            #:action
            (lambda (obj)
              ;; (rmt:test-set-state-status-by-id run-id test-id "KILLREQ" #f #f)
              (common:run-a-command
               (conc "megatest -set-state-status KILLREQ,n/a -target " target
                     " -runname " runname
                     " -testpatt " item-test-path 
                     " -state RUNNING,REMOTEHOSTSTART,LAUNCHED"))))
           (iup:menu-item
            (conc "Delete data : " item-test-path)
            #:action
            (lambda (obj)
              (common:run-a-command
               (conc "megatest -remove-runs -target " target
                     " -runname " runname
                     " -testpatt " item-test-path 
                     " -keep-records"))))
           (iup:menu-item
            (conc "Clean "item-test-path)
            #:action
            (lambda (obj)
              (common:run-a-command
               (conc "megatest -remove-runs -target " target
                     " -runname " runname
                     " -testpatt " item-test-path))))
           (iup:menu-item
            "Start xterm"
            #:action
            (lambda (obj)
              (dcommon:examine-xterm run-id test-id)))
           ;;(let* ((cmd (conc (car (argv)) " -xterm " run-id "," test-id "&")))
           ;; (system cmd))))
           (iup:menu-item
            "Edit testconfig"
            #:action
            (lambda (obj)
              (let* ((all-tests (tests:get-all))
                     (editor-rx (or (configf:lookup *configdat* "setup" "editor-regex") 
                                    "\\b(vim?|nano|pico)\\b"))
                     (editor (or (configf:lookup *configdat* "setup" "editor")
                                 (get-environment-variable "VISUAL")
                                 (get-environment-variable "EDITOR") "vi"))
                     (tconfig (conc (hash-table-ref all-tests test-name) "/testconfig"))
                     (cmd (conc (if (string-search editor-rx editor)
                                    (conc "xterm -e " editor)
                                    editor)
                                " " tconfig " &")))
                (system cmd)))))
          (custom-menu-items (dashboard:get-custom-menu-items *configdat*))
          )
           
   
   (iup:menu-item
    "Run"
    (apply iup:menu run-menu-items))
   (iup:menu-item
    "Test"
    (apply iup:menu test-menu-items))
   )

     
     

     
     
     ))))

(define (make-dashboard-buttons commondat) ;;  runs-sum-dat new-view-dat)
  (let* ((stats-dat       (dboard:tabdat-make-data))
	 (runs-dat        (dboard:tabdat-make-data))
	 (onerun-dat      (dboard:tabdat-make-data)) ;; name for run-summary structure 
	 (runcontrols-dat (dboard:tabdat-make-data))
	 (runtimes-dat    (dboard:tabdat-make-data))
	 (nruns           (dboard:tabdat-numruns runs-dat))








<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<








2403
2404
2405
2406
2407
2408
2409








































































































































































































2410
2411
2412
2413
2414
2415
2416

				      (iup:attribute-set! obj "MAX" (* maxruns 10))))
		#:expand "HORIZONTAL"
		#:max (* 10 (max (hash-table-size (dboard:tabdat-allruns-by-id tabdat)) 10))
		#:min 0
		#:step 0.01))










































































































































































































(define (make-dashboard-buttons commondat) ;;  runs-sum-dat new-view-dat)
  (let* ((stats-dat       (dboard:tabdat-make-data))
	 (runs-dat        (dboard:tabdat-make-data))
	 (onerun-dat      (dboard:tabdat-make-data)) ;; name for run-summary structure 
	 (runcontrols-dat (dboard:tabdat-make-data))
	 (runtimes-dat    (dboard:tabdat-make-data))
	 (nruns           (dboard:tabdat-numruns runs-dat))
︙︙
2739
2740
2741
2742
2743
2744
2745
2746
2747
2748
2749
2750
2751
2752
2753

								     "%"
								     tpatt))
							       "%")))
                                              (item-path (db:test-get-item-path (rmt:get-test-info-by-id run-id test-id)))
                                              (item-test-path (conc test-name "/" (if (equal? item-path "")
									"%" 
									item-path))))
					 (iup:show (dashboard:popup-menu run-id test-id target runname test-name testpatt item-test-path test-info) ;; popup-menu
						   #:x 'mouse
						   #:y 'mouse
						   #:modal? "NO")
					 ;; (print "got here")
					 ))
				   (if (eq? pressed 0)
				       (let* ((toolpath (car (argv)))








|








2540
2541
2542
2543
2544
2545
2546
2547
2548
2549
2550
2551
2552
2553
2554

								     "%"
								     tpatt))
							       "%")))
                                              (item-path (db:test-get-item-path (rmt:get-test-info-by-id run-id test-id)))
                                              (item-test-path (conc test-name "/" (if (equal? item-path "")
									"%" 
									item-path))))
					 (iup:show (dashboard:context-menu run-id test-id target runname test-name testpatt item-test-path test-info) ;; popup-menu
						   #:x 'mouse
						   #:y 'mouse
						   #:modal? "NO")
					 ;; (print "got here")
					 ))
				   (if (eq? pressed 0)
				       (let* ((toolpath (car (argv)))
︙︙

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