Megatest

Check-in [3f0d1f8803]
Login
☰Home Timeline Files Branches Tags Tickets Wiki Login
Overview
Comment:added env vars to custom menu item context
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | v1.65
Files: files | file ages | folders
SHA1: 3f0d1f8803cb6a95353b635c2dfe9c9cc4ef3899
User & Date: bjbarcla on 2018-02-14 19:16:52
Other Links: branch diff | manifest | tags
Context
2018-02-15
16:45
Rebuilt manual check-in: d7e5356bca user: mrwellan tags: v1.65
2018-02-14
19:16
added env vars to custom menu item context check-in: 3f0d1f8803 user: bjbarcla tags: v1.65
17:58
fixed issues with context menu check-in: b5ed77d745 user: bjbarcla tags: v1.65
Changes
Hide Diffs Side-by-Side Diffs Ignore Whitespace Patch

Modified common.scm from [9d055a50b8] to [ded8fa3dd3].

︙
2767
2768
2769
2770
2771
2772
2773
2774


2775
2776
2777
2778
2779
2780
2781

2767
2768
2769
2770
2771
2772
2773

2774
2775
2776
2777
2778
2779
2780
2781
2782








-
+
+








                              (hash-table->alist delta-env-alist-or-hash-table)
                              delta-env-alist-or-hash-table))
         (restore-thunks
          (filter
           identity
           (map (lambda (env-pair)
                  (let* ((env-var     (car env-pair))
                         (new-val     (cadr env-pair))
                         (new-val     (let ((tmp (cdr env-pair)))
                                        (if (list? tmp) (car tmp) tmp)))
                         (current-val (get-environment-variable env-var))
                         (restore-thunk
                          (cond
                           ((not current-val) (lambda () (unsetenv env-var)))
                           ((not (string? new-val)) #f)
                           ((eq? current-val new-val) #f)
                           (else
︙

Modified dashboard-context-menu.scm from [10f8461975] to [6e0d3fe684].

︙
255
256
257
258
259
260
261
262

263

264
265
266
267
268
269
270
271
272
273
274
275
276
277
278

279

280

281
282
283
284
285
286
287

255
256
257
258
259
260
261

262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278

279
280
281
282
283
284
285
286
287
288
289
290








-
+

+














-
+

+

+








;; 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 runname test-name testpatt item-test-path test-info)
(define (dashboard:custom-menu-items  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))
         (mt-root (pathname-directory  (pathname-directory *common:this-exe-dir* ))))
    (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))
                    (subst-alist ;; template vars
                          `(( "%run-id%"    . ,run-id   )
                            ( "%test-id%"   . ,test-id  )
                            ( "%target%"    . ,target   )
                            ( "%test-name%" . ,test-name)
                            ( "%test-patt%" . ,testpatt)
                            ( "%test-run-dir%" . ,(db:test-get-rundir      test-info))
                            ( "%test-run-dir%" . ,(db:test-get-rundir test-info))
                            ( "%mt-root%" . ,mt-root)
                            ( "%run-name%" . ,run-name)
                            ( "%run-area-home%" . ,*toppath*)
                            ( "%item-path%" . ,item-path)
                            ( "%item-test-patt%" . ,item-test-path )))
                    (command-line ;; replace template vars
                          (foldr
                           (lambda (x i)
                             (string-substitute
                              (car x)
                              (->string (cdr x))
︙
299
300
301
302
303
304
305
306
307
308
309
310






311
312
313
314
315
316
317
318
319









320
321
322
323
324
325
326

302
303
304
305
306
307
308


309
310
311
312
313
314
315
316
317









318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333








-
-



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








                              #t))
                           menu-item-text-raw
                           subst-alist)))
               (iup:menu-item
                (conc "*"menu-item-text)
                #:action
                (lambda (obj)
                  ;; TODO: with-env-vars <runconfig target vars, env-override vars from mtest>
                  ;; TODO: with-env-vars MT_*

                  (let* ((scheme-match (string-match "^#(\\(.*)" command-line)))
                    ;;(BB> "cmdline is >"command-line"<")
                    (common:with-env-vars
                     ;; TODO: with-env-vars <runconfig target vars, env-override vars from mtest>
                     ;; TODO: with-env-vars MT_*
                     (runs:get-mt-env-alist run-id run-name target test-name item-path)
                     
                     (lambda ()
                    (if scheme-match
                        (begin
                          (handle-exceptions
                           exn
                           (print "error with custom menu scheme")
                           (begin
                             ;;(BB> "gonna eval it!")
                             (eval (with-input-from-string (cadr scheme-match) read)))))
                        (common:run-a-command command-line))))))
                       (if scheme-match
                           (begin
                             (handle-exceptions
                              exn
                              (print "error with custom menu scheme")
                              (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)
  (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
︙

Modified runs.scm from [977a378661] to [55626f9a0f].

︙
44
45
46
47
48
49
50








































51
52
53
54
55
56
57

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








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








  ((can-run-more-tests-count 0) : fixnum))

(defstruct runs:testdat
  hed tal reg reruns  test-record
  test-name item-path jobgroup
  waitons testmode  newtal itemmaps prereqs-not-met)


(define (runs:get-mt-env-alist run-id runname target testname itempath)
  ;;(bb-check-path msg: "runs:set-megatest-env-vars entry")
  `(("MT_TEST_NAME"     . ,testname)
    
    ("MT_ITEMPATH"      . ,itempath)

    ("MT_TARGET"        . ,target)
    
    ("MT_RUNNAME"       . ,runname)
    
    ("MT_RUN_AREA_HOME" . ,*toppath*)
    
    ,@(let* ((link-tree (common:get-linktree))) ;; (configf:lookup *configdat* "setup" "linktree")))
        (if link-tree
            (list (cons "MT_LINKTREE" link-tree)
                  
                  (cons "MT_TEST_RUN_DIR"
                        (conc link-tree  "/" target "/" runname "/" testname
                              (if (and (string? itempath) (not (equal? itempath "")))
                                  (conc "/" itempath)
                                  "")))
                  )
            '()))
    
    ,@(map
       (lambda (key)
         (cons  (car key) (cadr key)))
       (keys:target->keyval (rmt:get-keys) target))
    
    ,@(map (lambda (var)
             (let ((val (configf:lookup *configdat* "custom-context-menu-items" var)))
               (cons var val)))
           (configf:section-vars *configdat* "env-override"))))


    

    
    
;; set up needed environment variables given a run-id and optionally a target, itempath etc.
;;
(define (runs:set-megatest-env-vars run-id #!key (inkeys #f)(inrunname #f)(inkeyvals #f)(intarget #f)(testname #f)(itempath #f))
  ;;(bb-check-path msg: "runs:set-megatest-env-vars entry")
  (let* ((target    (or intarget 
			(common:args-get-target)
			(get-environment-variable "MT_TARGET")))
︙

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