Overview
Context
Changes
Modified dashboard-tests.scm
from [102e50a90f]
to [87f3e4eff2].
︙ | | |
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
|
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
|
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
(iup:attribute-set! btn "BGCOLOR" newcolor))))
btns)))
btns))))))
(define (dashboard-tests:run-a-step info)
#t)
(define (dashboard-tests:step-run-control testdat stepname testconfig)
(iup:dialog ;; #:close_cb (lambda (a)(exit)) ; #:expand "YES"
#:title stepname
(iup:vbox ; #:expand "YES"
(iup:label (conc "Step: " stepname "\nNB// These buttons only run the test step\nfor the purpose of debugging.\nNot all database updates are done."))
(iup:button "Re-run"
#:expand "HORIZONTAL"
#:action (lambda (obj)
(debug:catch-and-dump
;; (define (dashboard-tests:step-run-control testdat stepname testconfig)
;; (let* ((mutex (make-mutex)))
;; (letrec ((dlg
;; (iup:dialog ;; #:close_cb (lambda (a)(exit)) ; #:expand "YES"
;; #:title stepname
;; (iup:vbox ; #:expand "YES"
;; (iup:label (conc "Step: " stepname "\nNB// These buttons only run the test step\nfor the purpose of debugging.\nNot all database updates are done."))
;; (iup:button "Re-run"
;; #:expand "HORIZONTAL"
;; #:action (lambda (obj)
;; (debug:catch-and-dump (lambda ()
(lambda ()
(thread-start!
(make-thread
(lambda ()
(ezsteps:run-from testdat stepname #t) 'foo)
"ezstep:run-from")))
(conc "ezstep run single step " stepname))))
(iup:button "Re-run and continue"
#:expand "HORIZONTAL"
#:action (lambda (obj)
(thread-start!
(make-thread (lambda ()
(ezsteps:run-from testdat stepname #f))
(conc "ezstep run from step " stepname)))))
;; (iup:button "Refresh test data"
;; #:expand "HORIZONTAL"
;; #:action (lambda (obj)
;; (print "Refresh test data " stepname))
)))
;; (thread-start!
;; (make-thread
;; (lambda ()
;; (print "BB> started ezsteps:run-from")
;; (debug:catch-and-dump
;; (lambda ()
;; (ezsteps:run-from testdat stepname #t))
;; "dashboard-tests:step-run-control -> ezstep:run-from (1)")
;; (print "BB> done ezsteps:run-from")
;; 'foo)
;; (conc "ezstep run single step " stepname)))
;; )
;; "step-run-control action")))
;; (iup:button "Re-run and continue"
;; #:expand "HORIZONTAL"
;; #:action (lambda (obj)
;; (debug:catch-and-dump
;; (lambda ()
;; (thread-start!
;; (make-thread (lambda ()
;; (ezsteps:run-from testdat stepname #f))
;; (conc "ezstep run from step " stepname))))
;; "dashboard-tests:step-run-control -> ezstep:run-from (2)")))
;; (iup:button "Close"
;; #:action (lambda (obj)
;; (iup:destroy! dlg)))
;; ;; (iup:button "Refresh test data"
;; ;; #:expand "HORIZONTAL"
;; ;; #:action (lambda (obj)
;; ;; (print "Refresh test data " stepname))
;; ))))
;; dlg)))
(define (dashboard-tests:waiver run-id testdat ovrdval cmtcmd)
(let* ((wpatt (configf:lookup *configdat* "setup" "waivercommentpatt"))
(wregx (if (string? wpatt)(regexp wpatt) #f))
(wmesg (iup:label (if wpatt (conc "Comment must match pattern " wpatt) "")))
(comnt (iup:textbox #:action (lambda (val a b)
(if wpatt
|
︙ | | |
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
|
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
|
+
+
+
+
+
+
+
+
-
+
|
;; These next two are intentional bad values to ensure errors if they should not
;; get filled in properly.
(logfile "/this/dir/better/not/exist")
(rundir (if testdat
(db:test-get-rundir testdat)
logfile))
;; (testdat-path (conc rundir "/testdat.db")) ;; this gets recalculated until found
(augment-teststeps (lambda (inlov)
(map
(lambda (invec)
(list->vector
`(
,@(reverse (cdr (reverse (vector->list invec))))
"rerun this step" "restart from here" )))
inlov)))
(teststeps (if testdat (tests:get-compressed-steps run-id test-id) '()))
(teststeps (if testdat (augment-teststeps (tests:get-compressed-steps run-id test-id)) '()))
(testfullname (if testdat (db:test-get-fullname testdat) "Gathering data ..."))
(testname (if testdat (db:test-get-testname testdat) "n/a"))
;; (tests:get-testconfig testdat testname 'return-procs))
(testmeta (if testdat
(let ((tm (rmt:testmeta-get-record testname)))
(if tm tm (make-db:testmeta)))
(make-db:testmeta)))
|
︙ | | |
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
|
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
|
-
+
|
exn
(debug:print-info 0 *default-log-port* "test db access issue in examine test for run-id " run-id ", test-id " test-id ": " ((condition-property-accessor 'exn 'message) exn))
(rmt:get-test-info-by-id run-id test-id )))))
;; (print "INFO: need-update= " need-update " curr-mod-time = " curr-mod-time)
(cond
((and need-update newtestdat)
(set! testdat newtestdat)
(set! teststeps (tests:get-compressed-steps run-id test-id))
(set! teststeps (augment-teststeps (tests:get-compressed-steps run-id test-id)))
(set! logfile (conc (db:test-get-rundir testdat) "/" (db:test-get-final_logf testdat)))
(set! rundir ;; (filedb:get-path *fdb*
(db:test-get-rundir testdat)) ;; )
(set! testfullname (db:test-get-fullname testdat))
;; (debug:print 0 *default-log-port* "INFO: teststeps=" (intersperse teststeps "\n "))
;; I don't see why this was implemented this way. Please comment it ...
|
︙ | | |
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
|
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
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
|
-
+
-
+
-
-
-
-
+
+
+
+
+
-
-
-
-
-
+
+
+
+
+
+
|
(let ((tabs
(iup:tabs
;; Replace here with matrix
(let ((steps-matrix (iup:matrix
#:font "Courier New, -8"
#:expand "YES"
#:scrollbar "YES"
#:numcol 7
#:numcol 9
#:numlin 100
#:numcol-visible 7
#:numcol-visible 9
#:numlin-visible 5
#:click-cb (lambda (obj lin col status)
;; (if (equal? col 6)
(let* ((mtrx-rc (conc lin ":" 6))
(fname (iup:attribute obj mtrx-rc))) ;; col))))
(if (eq? col 6)
(view-a-log fname)
(let* ((mtrx-rc (conc lin ":" 6))
(fname (iup:attribute obj mtrx-rc))
(stepname (iup:attribute obj (conc lin ":" 1))) (comment (iup:attribute obj (conc lin ":" 7))))
(case col
((6) (view-a-log fname))
(iup:show
(dashboard-tests:step-run-control
testdat
(iup:attribute obj (conc lin ":" 1))
teststeps))))))))
((7) (print "Comment from step "stepname": "comment))
((8) (ezsteps:spawn-run-from testdat stepname #t))
((9) (ezsteps:spawn-run-from testdat stepname #f))
(else (print "No action for col="col))))))))
;; (let loop ((count 0))
;; (iup:attribute-set! steps-matrix "FITTOTEXT" (conc "L" count))
;; (if (< count 30)
;; (loop (+ count 1))))
(iup:attribute-set! steps-matrix "0:1" "Step Name")
(iup:attribute-set! steps-matrix "0:2" "Start")
(iup:attribute-set! steps-matrix "0:3" "End")
(iup:attribute-set! steps-matrix "WIDTH3" "50")
(iup:attribute-set! steps-matrix "0:4" "Status")
(iup:attribute-set! steps-matrix "WIDTH4" "50")
(iup:attribute-set! steps-matrix "0:5" "Duration")
(iup:attribute-set! steps-matrix "0:6" "Log File")
(iup:attribute-set! steps-matrix "0:7" "Comment")
(iup:attribute-set! steps-matrix "0:8" "rerun only")
(iup:attribute-set! steps-matrix "0:9" "rerun & continue")
(iup:attribute-set! steps-matrix "ALIGNMENT1" "ALEFT")
;; (iup:attribute-set! steps-matrix "FIXTOTEXT" "C1")
(iup:attribute-set! steps-matrix "RESIZEMATRIX" "YES")
(let ((proc
(lambda (testdat)
(dcommon:populate-steps teststeps steps-matrix))))
(hash-table-set! widgets "StepsMatrix" proc)
|
︙ | | |
Modified dcommon.scm
from [2d492dcb7c]
to [11f59293fe].
︙ | | |
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
|
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
|
-
+
|
;;======================================================================
;; S T E P S
;;======================================================================
(define (dcommon:populate-steps teststeps steps-matrix)
(let ((max-row 0)
(max-col 7))
(max-col 9))
(if (null? teststeps)
(iup:attribute-set! steps-matrix "CLEARVALUE" "CONTENTS")
(let loop ((hed (car teststeps))
(tal (cdr teststeps))
(rownum 1)
(colnum 1))
(if (> rownum max-row)(set! max-row rownum))
|
︙ | | |
Modified ezsteps.scm
from [081cb24570]
to [f44a45955c].
︙ | | |
29
30
31
32
33
34
35
36
37
38
39
40
41
42
|
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
|
+
+
+
+
+
|
;; (declare (uses sdb))
;; (declare (uses filedb))
(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
;;(rmt:get-test-info-by-id run-id test-id) -> testdat
(define (ezsteps:run-from testdat start-step-name run-one)
(let* ((test-run-dir ;; (filedb:get-path *fdb*
(db:test-get-rundir testdat)) ;; )
(testconfig (read-config (conc test-run-dir "/testconfig") #f #t environ-patt: "pre-launch-env-vars"))
(ezstepslst (hash-table-ref/default testconfig "ezsteps" '()))
(run-mutex (make-mutex))
|
︙ | | |
178
179
180
181
182
183
184
185
|
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
|
+
+
+
+
+
+
+
+
|
(rmt:set-state-status-and-roll-up-items run-id test-name item-path new-state new-status #f))))
;; for automated creation of the rollup html file this is a good place...
(if (not (equal? item-path ""))
(tests:summarize-items run-id test-id test-name #f)) ;; don't force - just update if no
)))
(pop-directory)
rollup-status))
(define (ezsteps:spawn-run-from testdat start-step-name run-one)
(thread-start!
(make-thread
(lambda ()
(ezsteps:run-from testdat start-step-name run-one))
(conc "ezstep run single step " start-step-name " run-one="run-one)))
)
|