Megatest

Check-in [a2aeca7f4b]
Login
☰Home Timeline Files Branches Tags Tickets Wiki Login
Overview
Comment:tweaks
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | v1.6584-nanomsg
Files: files | file ages | folders
SHA1: a2aeca7f4b9760d4a834ba268fb55c3ddc388e6b
User & Date: matt on 2021-11-06 19:17:43
Other Links: branch diff | manifest | tags
Context
2021-11-06
20:09
wip check-in: 35654d794d user: matt tags: v1.6584-nanomsg
19:17
tweaks check-in: a2aeca7f4b user: matt tags: v1.6584-nanomsg
2021-11-05
19:18
wip check-in: 1e545a3411 user: matt tags: v1.6584-nanomsg
Changes
Hide Diffs Side-by-Side Diffs Ignore Whitespace Patch

Modified dashboard-context-menu.scm from [12ecddc7c4] to [2625bf1bcf].

︙
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

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








+
+
+






-
+
+
+
+
+

+
+
+
+





+















+









;;======================================================================

;;======================================================================
;; implementation of context menu that pops up on
;; right click on test cell in Runs & Runs Summary Tabs
;;======================================================================

(module dashboard-context-menu
	*

(import format fmt)
(import (prefix iup iup:))

(import canvas-draw)

(import srfi-1
(import scheme
	srfi-1
	chicken.base
	chicken.condition
	chicken.port
	chicken.file.posix
	chicken.pathname
	chicken.process
	chicken.process-context
	chicken.string
	regex regex-case srfi-69
	(prefix sqlite3 sqlite3:))

(declare (unit dashboard-context-menu))
(declare (uses commonmod))
(declare (uses configfmod))
(declare (uses dbmod))
(declare (uses gutils))
(declare (uses rmtmod))
(declare (uses ezstepsmod))
;; (declare (uses sdb))
;; (declare (uses filedb))
(declare (uses subrunmod))
(declare (uses debugprint))

(import commonmod
	dbmod
	rmtmod
	ezstepsmod
	subrunmod
	debugprint
	configfmod
	)

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

(define (dboard:launch-testpanel run-id test-id)
︙
267
268
269
270
271
272
273
274

275
276

277

278
279
280
281
282
283
284

280
281
282
283
284
285
286

287
288
289
290

291
292
293
294
295
296
297
298








-
+


+
-
+








;; item5  custom show test-patt (%test-patt%):echo "%test-patt%"
;; item6  custom show test-run-dir (%test-run-dir%):echo "%test-run-dir%"
;; item7  custom show run-area-home (%run-area-home%):echo "%run-area-home%"
;; item8  custom show megatest root (%mt-root%):echo "%mt-root%"
;; item9  custom ls :  ls -lrt
;; item10 custom see $MT_RUN_AREA_HOME (not yet implemented) :  echo $MT_RUN_AREA_HOME

(define (dashboard:custom-menu-items  run-id test-id target run-name test-name testpatt item-test-path test-info)
(define (dashboard:custom-menu-items  bdat run-id test-id target run-name test-name testpatt item-test-path test-info)
  (let* ((vars (configf:section-vars *configdat* "custom-context-menu-items"))
         (item-path (db:test-get-item-path test-info))
	 ;; (bdat-this-exe-dir-set! bdat (pathname-directory fullp))
         (mt-root (pathname-directory  (pathname-directory *common:this-exe-dir* ))))
         (mt-root (pathname-directory  (pathname-directory (bdat-this-exe-dir bdat)))))
    (filter-map
     (lambda (var)
       (let* ((val (configf:lookup *configdat* "custom-context-menu-items" var))
              (m   (string-match "^\\s*([^:]+?)\\s*:\\s*(.*?)\\s*$" val)))
         (if m
             (let* ((menu-item-text-raw (list-ref m 1))
                    (command-line-raw   (list-ref m 2))
︙
335
336
337
338
339
340
341
342

343
344
345
346
347
348

349
350
351
352
353
354
355
356
357
358
359
360



349
350
351
352
353
354
355

356
357
358
359
360
361

362
363
364
365
366
367
368
369
370
371
372
373
374
375
376








-
+





-
+












+
+

                              (begin
                                ;;(BB> "gonna eval it!")
                                (eval (with-input-from-string (cadr scheme-match) read)))))
                           (common:run-a-command command-line with-vars: #t))))))))
             #f)))
     vars)))

(define (dashboard:context-menu  run-id test-id target runname test-name testpatt item-test-path test-info)
(define (dashboard:context-menu bdat 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))
          (dashboard:custom-menu-items bdat 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))
             ,@custom-menu-items))))

)

Modified dashboard.scm from [441252a2cc] to [91cf4074c8].

︙
80
81
82
83
84
85
86
87

88
89
90
91
92
93
94

80
81
82
83
84
85
86

87
88
89
90
91
92
93
94








-
+








 (prefix mtargs args:)
 mtmod
 mtver
 processmod
 runsmod
 subrunmod
 vgmod
 )
 dashboard-context-menu)

(define help (conc 
	      "Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest
  version " megatest-version "
  license GPL, Copyright (C) Matt Welland 2012-2017

Usage: dashboard [options]
︙
130
131
132
133
134
135
136

137
138
139
140
141
142
143

130
131
132
133
134
135
136
137
138
139
140
141
142
143
144








+








			"-repl"
                        "-rh5.11" ;; fix to allow running on rh5.11
			"-:p"     ;; ignore the built in chicken profiling switch
			)
		 args:arg-hash
		 0))

(make-and-init-bigdata)
;; check for MT_* environment variables and exit if found
(if (not (args:get-arg "-test"))
    (begin
      (display "Checking for MT_ vars: ")
      (for-each (lambda (var)
		  (display " ")(display var)
		  (if (get-environment-variable var)
︙
177
178
179
180
181
182
183
184

185
186
187
188
189
190
191

178
179
180
181
182
183
184

185
186
187
188
189
190
191
192








-
+








;; first check for the switch
;;
(if (or (args:get-arg "-rh5.11")
	(configf:lookup *configdat* "dashboard" "no-detachbox")
        (not (file-exists? "/etc/os-release")))
    (set! iup:detachbox iup:vbox))

(if (not (common:on-homehost?))
#;(if (not (common:on-homehost?))
    (begin
      (debug:print 0 *default-log-port* "WARNING: Current policy requires running dashboard on homehost: " (common:get-homehost))))
    
;; RA => Might require revert for filters 
;; create a watch dog to move changes from lt/.db/*.db to megatest.db
;;
;;;(if (file-write-access? (conc *toppath* "/megatest.db"))
︙
2417
2418
2419
2420
2421
2422
2423
2424

2425
2426
2427
2428
2429
2430
2431

2432
2433
2434
2435
2436
2437
2438

2418
2419
2420
2421
2422
2423
2424

2425
2426
2427
2428
2429
2430
2431

2432
2433
2434
2435
2436
2437
2438
2439








-
+






-
+








                             (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
                               (iup:show (dashboard:context-menu *bdat* 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
                               (iup:show (dashboard:context-menu *bdat* 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"))))
︙
2975
2976
2977
2978
2979
2980
2981
2982

2983
2984
2985
2986
2987
2988
2989

2976
2977
2978
2979
2980
2981
2982

2983
2984
2985
2986
2987
2988
2989
2990








-
+








								     "%"
								     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
					 (iup:show (dashboard:context-menu *bdat* 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.109s by Fossil 2.24 [452f8e1ffc] 2024-03-26 15:36:00