Megatest

Diff
Login

Differences From Artifact [c44fb62fd2]:

To Artifact [f5c119fd95]:


808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
		   (elapsed-time (- (current-seconds) start-time)))
	      (if (null? all-test-ids)
		  (hash-table-delete! (dboard:tabdat-allruns-by-id tabdat) run-id)
		  (hash-table-set!    (dboard:tabdat-allruns-by-id tabdat) run-id run-struct))
	      (if (or (null? tal)
		      (> elapsed-time 2)) ;; stop loading data after 5 seconds, on the next call more data *should* be loaded since get-tests-for-run uses last update
		  (begin
		    (if (> elapsed-time 2)(print "WARNING: timed out in update-testdat " elapsed-time "s"))
		    (dboard:tabdat-allruns-set! tabdat new-res)
		    maxtests)
		  (if (> (dboard:rundat-run-data-offset run-struct) 0)
		      (loop run tal new-res newmaxtests) ;; not done getting data for this run
		      (loop (car tal)(cdr tal) new-res newmaxtests)))))))
    (dboard:tabdat-filters-changed-set! tabdat #f)
    (dboard:update-tree tabdat runs-hash header tb)))







|







808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
		   (elapsed-time (- (current-seconds) start-time)))
	      (if (null? all-test-ids)
		  (hash-table-delete! (dboard:tabdat-allruns-by-id tabdat) run-id)
		  (hash-table-set!    (dboard:tabdat-allruns-by-id tabdat) run-id run-struct))
	      (if (or (null? tal)
		      (> elapsed-time 2)) ;; stop loading data after 5 seconds, on the next call more data *should* be loaded since get-tests-for-run uses last update
		  (begin
		    (if (> elapsed-time 2)(debug:print 0 *default-log-port*  "WARNING: timed out in update-testdat " elapsed-time "s"))
		    (dboard:tabdat-allruns-set! tabdat new-res)
		    maxtests)
		  (if (> (dboard:rundat-run-data-offset run-struct) 0)
		      (loop run tal new-res newmaxtests) ;; not done getting data for this run
		      (loop (car tal)(cdr tal) new-res newmaxtests)))))))
    (dboard:tabdat-filters-changed-set! tabdat #f)
    (dboard:update-tree tabdat runs-hash header tb)))
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
	"Compact layout"
	#:fontsize 8
	#:expand "HORIZONTAL"
	#:value 1
	#:action (lambda (obj tstate)
		   (debug:catch-and-dump 
		    (lambda ()
		      (print "tstate: " tstate)
		      (if (eq? tstate 0)
			  (dboard:tabdat-compact-layout-set! tabdat #f)
			  (dboard:tabdat-compact-layout-set! tabdat #t))
		      (dboard:tabdat-last-filter-str-set! tabdat "")
		      )
		    "text-list-toggle-box"))))
      (dcommon:command-runname-selector commondat tabdat tab-num: tab-num)







|







1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
	"Compact layout"
	#:fontsize 8
	#:expand "HORIZONTAL"
	#:value 1
	#:action (lambda (obj tstate)
		   (debug:catch-and-dump 
		    (lambda ()
		      ;; (print "tstate: " tstate)
		      (if (eq? tstate 0)
			  (dboard:tabdat-compact-layout-set! tabdat #f)
			  (dboard:tabdat-compact-layout-set! tabdat #t))
		      (dboard:tabdat-last-filter-str-set! tabdat "")
		      )
		    "text-list-toggle-box"))))
      (dcommon:command-runname-selector commondat tabdat tab-num: tab-num)
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
	 (begin
	   (print-call-chain)
	   (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn)
	   (debug:print 0 *default-log-port* "ERROR: failed call procedure " viewgen
			", with; tab-num=" tab-num ", view-name=" view-name
			", and views-cfgdat and megatest configdat as parameters. To debug try loading in the repl: megatest -repl")
	   (set! success #f))
	 (print "Adding tab " view-name " with proc " viewgen)
	 ;; (iup:child-add! tabs
	 (set! result-child 
	       ((eval (string->symbol viewgen)) commondat tabs tab-num view-name views-cfgdat *configdat*))))
    ;; and finally set the updater
    (if success
	(dboard:commondat-add-updater commondat
				      (lambda ()







|







2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
	 (begin
	   (print-call-chain)
	   (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn)
	   (debug:print 0 *default-log-port* "ERROR: failed call procedure " viewgen
			", with; tab-num=" tab-num ", view-name=" view-name
			", and views-cfgdat and megatest configdat as parameters. To debug try loading in the repl: megatest -repl")
	   (set! success #f))
	 (debug:print 0 *default-log-port* "Adding tab " view-name " with proc " viewgen)
	 ;; (iup:child-add! tabs
	 (set! result-child 
	       ((eval (string->symbol viewgen)) commondat tabs tab-num view-name views-cfgdat *configdat*))))
    ;; and finally set the updater
    (if success
	(dboard:commondat-add-updater commondat
				      (lambda ()
3502
3503
3504
3505
3506
3507
3508
3509
3510
3511
3512
3513
3514
3515
3516
                                              (vg:make-line-obj last-tval last-yval curr-tval last-yval
                                                                line-color: graph-color))
                                             (vg:add-obj-to-comp
                                              cmp 
                                              ;;(vg:make-rect-obj last-tval lly curr-tval last-yval ;; (- stval 2) lly (+ stval 2)(+ lly (* yval yscale))
                                              (vg:make-line-obj curr-tval last-yval curr-tval next-yval
                                                                line-color: graph-color)))         
                                           (print "ERROR: curr-tval is not > last-tval; curr-tval " curr-tval ", last-tval " last-tval))))
                                 next)
                               #f ;; (vector tstart minval minval)
                               dat)
                              )))))) ;; for each data point in the series
	      (hash-table-keys alldat)))))
     cfg)
    (if changed (iup:attribute-set! graph-matrix "REDRAW" "ALL"))))







|







3502
3503
3504
3505
3506
3507
3508
3509
3510
3511
3512
3513
3514
3515
3516
                                              (vg:make-line-obj last-tval last-yval curr-tval last-yval
                                                                line-color: graph-color))
                                             (vg:add-obj-to-comp
                                              cmp 
                                              ;;(vg:make-rect-obj last-tval lly curr-tval last-yval ;; (- stval 2) lly (+ stval 2)(+ lly (* yval yscale))
                                              (vg:make-line-obj curr-tval last-yval curr-tval next-yval
                                                                line-color: graph-color)))         
                                           (debug:print 0 *default-log-port* "ERROR: curr-tval is not > last-tval; curr-tval " curr-tval ", last-tval " last-tval))))
                                 next)
                               #f ;; (vector tstart minval minval)
                               dat)
                              )))))) ;; for each data point in the series
	      (hash-table-keys alldat)))))
     cfg)
    (if changed (iup:attribute-set! graph-matrix "REDRAW" "ALL"))))
3663
3664
3665
3666
3667
3668
3669
3670
3671
3672
3673
3674
3675
3676
3677
						;; (vg:instance-move drawing run-full-name 0 (calc-y (dboard:tabdat-max-row tabdat)))
						(dboard:tabdat-view-changed-set! tabdat #t)
						(cons obj test-objs))))))
				  ;; (print "event_time: " (db:test-get-event_time   testdat) " mapped event_time: " event-time)
				  ;; (print "run-duration: "  (db:test-get-run_duration testdat) " mapped run_duration: " run-duration)
				  (if (> item-num 50)
				      (if (eq? 0 (modulo item-num 50))
					  (print "processing " run-num " of " num-runs " runs " item-num " of " num-items " of test " test-name ", " test-num " of " num-tests " tests")))
				  ;; (print "test-name: " test-name " event-time: " event-time " run-duration: " run-duration)
				  (let ((newdoneruns (cons rundat doneruns)))
				    (if (null? tidstal)
					(if iterated
					    (let* ((xtents (vg:get-extents-for-objs drawing new-test-objs))
						   (llx (- (car xtents)  10))
						   (lly (- (cadr xtents) 10))







|







3663
3664
3665
3666
3667
3668
3669
3670
3671
3672
3673
3674
3675
3676
3677
						;; (vg:instance-move drawing run-full-name 0 (calc-y (dboard:tabdat-max-row tabdat)))
						(dboard:tabdat-view-changed-set! tabdat #t)
						(cons obj test-objs))))))
				  ;; (print "event_time: " (db:test-get-event_time   testdat) " mapped event_time: " event-time)
				  ;; (print "run-duration: "  (db:test-get-run_duration testdat) " mapped run_duration: " run-duration)
				  (if (> item-num 50)
				      (if (eq? 0 (modulo item-num 50))
					  (debug:print 0 *default-log-port* "processing " run-num " of " num-runs " runs " item-num " of " num-items " of test " test-name ", " test-num " of " num-tests " tests")))
				  ;; (print "test-name: " test-name " event-time: " event-time " run-duration: " run-duration)
				  (let ((newdoneruns (cons rundat doneruns)))
				    (if (null? tidstal)
					(if iterated
					    (let* ((xtents (vg:get-extents-for-objs drawing new-test-objs))
						   (llx (- (car xtents)  10))
						   (lly (- (cadr xtents) 10))
3688
3689
3690
3691
3692
3693
3694
3695
3696
3697
3698
3699
3700
3701
3702
					(if (dboard:tabdat-layout-update-ok tabdat)
					    (testitemloop (car tidstal)(cdr tidstal)(+ item-num 1) new-test-objs)
					    (escapeloop #t) ;; (dboard:tabdat-layout-update-ok tabdat)
					    )))))
			      ;; If it is an iterated test put box around it now.
			      (if (not (null? tests-tal))
				  (if #f ;; (> (- (current-seconds) update-start-time) 5)
				      (print "drawing runs taking too long")
				      (if (dboard:tabdat-layout-update-ok tabdat)
					  (testsloop  (car tests-tal)(cdr tests-tal)(+ test-num 1))
					  (escapeloop #t) ;; (dboard:tabdat-layout-update-ok tabdat)
					  )))))
			  ;; placeholder box
			  (dboard:tabdat-max-row-set! tabdat (+ (dboard:tabdat-max-row tabdat) 1))
			  ;; (let ((y  (calc-y (dboard:tabdat-max-row tabdat)))) ;;  (- sizey (* (dboard:tabdat-max-row tabdat) row-height))))







|







3688
3689
3690
3691
3692
3693
3694
3695
3696
3697
3698
3699
3700
3701
3702
					(if (dboard:tabdat-layout-update-ok tabdat)
					    (testitemloop (car tidstal)(cdr tidstal)(+ item-num 1) new-test-objs)
					    (escapeloop #t) ;; (dboard:tabdat-layout-update-ok tabdat)
					    )))))
			      ;; If it is an iterated test put box around it now.
			      (if (not (null? tests-tal))
				  (if #f ;; (> (- (current-seconds) update-start-time) 5)
				      (debug:print 0 *default-log-port* "drawing runs taking too long")
				      (if (dboard:tabdat-layout-update-ok tabdat)
					  (testsloop  (car tests-tal)(cdr tests-tal)(+ test-num 1))
					  (escapeloop #t) ;; (dboard:tabdat-layout-update-ok tabdat)
					  )))))
			  ;; placeholder box
			  (dboard:tabdat-max-row-set! tabdat (+ (dboard:tabdat-max-row tabdat) 1))
			  ;; (let ((y  (calc-y (dboard:tabdat-max-row tabdat)))) ;;  (- sizey (* (dboard:tabdat-max-row tabdat) row-height))))
3728
3729
3730
3731
3732
3733
3734
3735
3736
3737
3738
3739
3740
3741
3742
			      (if (null? runtal)
				  (begin
				    (dboard:rundat-data-changed-set! rundat #f) 
				    (dboard:tabdat-not-done-runs-set! tabdat '())
				    (dboard:tabdat-done-runs-set! tabdat allruns))
				  (if #f ;; (> (- (current-seconds) update-start-time) 5)
				      (begin
					(print "drawing runs taking too long....  have " (length runtal) " remaining")
					;; (dboard:tabdat-done-runs-set! tabdat newdoneruns) ;; taking too long? stop here!
					;; (time (vg:draw (dboard:tabdat-drawing tabdat) #t))
					(dboard:tabdat-not-done-runs-set! tabdat runtal))
				      (begin
					(if (dboard:tabdat-layout-update-ok tabdat)
					    (runloop (car runtal)(cdr runtal) (+ run-num 1) newdoneruns)
					    (escapeloop #t) ;; (dboard:tabdat-layout-update-ok tabdat)







|







3728
3729
3730
3731
3732
3733
3734
3735
3736
3737
3738
3739
3740
3741
3742
			      (if (null? runtal)
				  (begin
				    (dboard:rundat-data-changed-set! rundat #f) 
				    (dboard:tabdat-not-done-runs-set! tabdat '())
				    (dboard:tabdat-done-runs-set! tabdat allruns))
				  (if #f ;; (> (- (current-seconds) update-start-time) 5)
				      (begin
					(debug:print 0 *default-log-port* "drawing runs taking too long....  have " (length runtal) " remaining")
					;; (dboard:tabdat-done-runs-set! tabdat newdoneruns) ;; taking too long? stop here!
					;; (time (vg:draw (dboard:tabdat-drawing tabdat) #t))
					(dboard:tabdat-not-done-runs-set! tabdat runtal))
				      (begin
					(if (dboard:tabdat-layout-update-ok tabdat)
					    (runloop (car runtal)(cdr runtal) (+ run-num 1) newdoneruns)
					    (escapeloop #t) ;; (dboard:tabdat-layout-update-ok tabdat)
3786
3787
3788
3789
3790
3791
3792
3793
3794
3795
3796
3797
3798
3799
3800
3801
3802
3803
3804
3805
3806
3807
3808
3809
3810
3811
3812
3813
3814
   "dashboard:runs-tab-updater"))

;;======================================================================
;; The heavy lifting starts here
;;======================================================================

(define (main)
  (print "Starting dashboard main")

  (let* ((mtdb-path (conc *toppath* "/.megatest/main.db"))
         (target (args:get-arg "-target"))
         (commondat       (dboard:commondat-make)))
    (if target
        (begin
          (args:remove-arg-from-ht "-target")
          (dboard:commondat-target-set! commondat target)
        )
    )

    (if (not (launch:setup))
        (begin
          (print "Failed to find megatest.config, exiting") 
          (exit 1)
        )
    )

    (if (not (common:on-homehost?))
    (begin
      (debug:print 0 *default-log-port* "WARNING: You are starting the dashboard on a machine that is not the homehost:" (common:get-homehost))







|













|







3786
3787
3788
3789
3790
3791
3792
3793
3794
3795
3796
3797
3798
3799
3800
3801
3802
3803
3804
3805
3806
3807
3808
3809
3810
3811
3812
3813
3814
   "dashboard:runs-tab-updater"))

;;======================================================================
;; The heavy lifting starts here
;;======================================================================

(define (main)
  ;; (print "Starting dashboard main")

  (let* ((mtdb-path (conc *toppath* "/.megatest/main.db"))
         (target (args:get-arg "-target"))
         (commondat       (dboard:commondat-make)))
    (if target
        (begin
          (args:remove-arg-from-ht "-target")
          (dboard:commondat-target-set! commondat target)
        )
    )

    (if (not (launch:setup))
        (begin
          (debug:print 0 *default-log-port* "Failed to find megatest.config, exiting") 
          (exit 1)
        )
    )

    (if (not (common:on-homehost?))
    (begin
      (debug:print 0 *default-log-port* "WARNING: You are starting the dashboard on a machine that is not the homehost:" (common:get-homehost))
3865
3866
3867
3868
3869
3870
3871
3872
3873
3874
3875
3876
3877
3878
3879
3880
3881
3882
3883
3884
3885
			     (begin
			     (dboard:common-run-curr-updaters commondat) ;; (dashboard:run-update commondat)
			     (mutex-lock! (dboard:commondat-update-mutex commondat))
			     (dboard:commondat-updating-set! commondat #f)
			     (mutex-unlock! (dboard:commondat-update-mutex commondat)))
				   ))
			     1))))
      (print "Starting updaters")
      (let ((th1 (make-thread (lambda ()
				(thread-sleep! 1)
				(dboard:common-run-curr-updaters commondat 0) ;; force update of summary tab 
				) "update buttons once"))
	    (th2 (make-thread iup:main-loop "Main loop")))
        (print "Starting main loop")
	(thread-start! th2)
	(thread-join! th2)
      )
    )
  )
)








|





|







3865
3866
3867
3868
3869
3870
3871
3872
3873
3874
3875
3876
3877
3878
3879
3880
3881
3882
3883
3884
3885
			     (begin
			     (dboard:common-run-curr-updaters commondat) ;; (dashboard:run-update commondat)
			     (mutex-lock! (dboard:commondat-update-mutex commondat))
			     (dboard:commondat-updating-set! commondat #f)
			     (mutex-unlock! (dboard:commondat-update-mutex commondat)))
				   ))
			     1))))
      ;; (debug:print 0 *default-log-port* "Starting updaters")
      (let ((th1 (make-thread (lambda ()
				(thread-sleep! 1)
				(dboard:common-run-curr-updaters commondat 0) ;; force update of summary tab 
				) "update buttons once"))
	    (th2 (make-thread iup:main-loop "Main loop")))
        ;; (print "Starting main loop")
	(thread-start! th2)
	(thread-join! th2)
      )
    )
  )
)

3903
3904
3905
3906
3907
3908
3909
3910
3911
3912
3913
3914
3915
3916
3917
3918
3919
3920
3921
3922
3923
3924
3925
3926
3927
3928
;; check for MT_* environment variables and exit if found
(if (not (args:get-arg "-test"))
    (begin
      (for-each (lambda (var)
		  ;; (display " ")(display var)
		  (if (get-environment-variable var)
		      (begin
			(print "ERROR: environment variable " var " is set in this terminal, this will cause you problems. Exiting now.")
			(exit 1))))
		'("MT_RUN_AREA_HOME" "MT_MEGATEST" "MT_CMDINFO" "MT_TEST_RUN_DIR" "MT_LINKTREE" "MT_TESTSUITENAME"))
    )
)

(setenv "MT_RUN_AREA_HOME" (get-environment-variable "PWD"))

(if (not (null? remargs))
  (if remargs
    (begin
      (print "Unrecognised arguments: " (string-intersperse remargs " "))
      (exit)
    )
    (begin
      (print help)
      (exit)
    )
  )







|










|







3903
3904
3905
3906
3907
3908
3909
3910
3911
3912
3913
3914
3915
3916
3917
3918
3919
3920
3921
3922
3923
3924
3925
3926
3927
3928
;; check for MT_* environment variables and exit if found
(if (not (args:get-arg "-test"))
    (begin
      (for-each (lambda (var)
		  ;; (display " ")(display var)
		  (if (get-environment-variable var)
		      (begin
			(debug:print 0 *default-log-port* "ERROR: environment variable " var " is set in this terminal, this will cause you problems. Exiting now.")
			(exit 1))))
		'("MT_RUN_AREA_HOME" "MT_MEGATEST" "MT_CMDINFO" "MT_TEST_RUN_DIR" "MT_LINKTREE" "MT_TESTSUITENAME"))
    )
)

(setenv "MT_RUN_AREA_HOME" (get-environment-variable "PWD"))

(if (not (null? remargs))
  (if remargs
    (begin
      (debug:print 0 *default-log-port* "Unrecognised arguments: " (string-intersperse remargs " "))
      (exit)
    )
    (begin
      (print help)
      (exit)
    )
  )