Megatest

Check-in [c2c7cdb91e]
Login
Overview
Comment:Merged recent changes from v1.55
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | v1.60
Files: files | file ages | folders
SHA1: c2c7cdb91e7fcc9aee7cbb567f07af3792884671
User & Date: matt on 2014-07-15 00:06:15
Other Links: branch diff | manifest | tags
Context
2014-07-22
22:00
Merged recent changes from v1.55 and fixed few related bugs check-in: a7e3370085 user: matt tags: v1.60
2014-07-15
00:06
Merged recent changes from v1.55 check-in: c2c7cdb91e user: matt tags: v1.60
2014-07-14
23:05
Added more status variations for NOT_STARTED and bumped version. Also added visibility of statuses on dashboard check-in: 85a669be50 user: matt tags: v1.55
2014-06-26
15:27
Evaluate strings before storing in environment in launch:execute check-in: 761dba431d user: mrwellan tags: v1.60
Changes

Modified common.scm from [405f0df78e] to [e3f681efc8].

242
243
244
245
246
247
248
249

250
251
252
253
254
255
256
242
243
244
245
246
247
248

249
250
251
252
253
254
255
256







-
+







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

(define (common:args-get-target #!key (split #f))
  (let* ((target  (if (args:get-arg "-reqtarg")
		      (args:get-arg "-reqtarg")
		      (if (args:get-arg "-target")
			  (args:get-arg "-target")
			  #f)))
			  (getenv "MT_TARGET"))))
	 (tlist   (if target (string-split target "/" #t) '()))
	 (valid   (if target
		      (and (not (null? tlist))
			   (null? (filter string-null? tlist)))
		      #f)))
    (if valid
	(if split

Modified configf.scm from [5e1016adfd] to [81365b22b7].

109
110
111
112
113
114
115
116

117
118
119
120
121
122
123
109
110
111
112
113
114
115

116
117
118
119
120
121
122
123







-
+







	  (with-output-to-port (current-error-port)
	    (lambda ()
	      (print "ERROR: " cmd " returned bad exit code " status)))
	  ""))))

;; Lookup a value in runconfigs based on -reqtarg or -target
(define (runconfigs-get config var)
  (let ((targ (or (args:get-arg "-reqtarg")(args:get-arg "-target"))))
  (let ((targ (or (args:get-arg "-reqtarg")(args:get-arg "-target")(getenv "MT_TARGET"))))
    (if targ
	(or (configf:lookup config targ var)
	    (configf:lookup config "default" var))
	(configf:lookup config "default" var))))

(define-inline (configf:read-line p ht allow-processing)
  (let loop ((inl (read-line p)))

Modified dashboard-tests.scm from [b6cc0a25fc] to [ce4cdb7172].

658
659
660
661
662
663
664
665



666
667
668
669
670
671
672
658
659
660
661
662
663
664

665
666
667
668
669
670
671
672
673
674







-
+
+
+







											   "%"
											   item-path))
						      ";megatest -target " keystring " -runname " runname 
						      " -runtests " (conc testname "/" (if (equal? item-path "")
											   "%" 
											   item-path))
						      )))
				       (system (conc cmd " &")))))
				       (system (conc (dtests:get-pre-command)
						     cmd 
						     (dtests:get-post-command))))))
	       (remove-test (lambda (x)
			      (iup:attribute-set!
			       command-text-box "VALUE"
			       (conc "megatest -remove-runs -target " keystring " -runname " runname
				     " -testpatt " (conc testname "/" (if (equal? item-path "")
									  "%"
									  item-path))

Modified dashboard.scm from [741f8f5a94] to [d5cde3a2ed].

79
80
81
82
83
84
85
86

87
88
89
90
91
92
93
79
80
81
82
83
84
85

86
87
88
89
90
91
92
93







-
+







		 0))

(if (args:get-arg "-h")
    (begin
      (print help)
      (exit)))

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

(define *dbdir* (conc (configf:lookup *configdat* "setup" "linktree") "/.db"))
(define *dbstruct-local*  (make-dbr:dbstruct path:  *dbdir*
					     local: #t))
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
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







+
+
+
+
+
+
+







+
+
+
+
+
+




-








(define *tests-sort-options* (vector (vector "Sort +a" 'testname   "ASC")
				     (vector "Sort -a" 'testname   "DESC")
				     (vector "Sort +t" 'event_time "ASC")
				     (vector "Sort -t" 'event_time "DESC")
				     (vector "Sort +s" 'statestatus "ASC")
				     (vector "Sort -s" 'statestatus "DESC")))

(define *tests-sort-type-index* '(("+testname" 0)
				  ("-testname" 1)
				  ("+event_time" 2)
				  ("-event_time" 3)
				  ("+statestatus" 4)
				  ("-statestatus" 5)))

;; Don't forget to adjust the >= below if you add to the sort-options above
(define (next-sort-option)
  (if (>= *tests-sort-reverse* 5)
      (set! *tests-sort-reverse* 0)
      (set! *tests-sort-reverse* (+ *tests-sort-reverse* 1)))
  *tests-sort-reverse*)

(define *tests-sort-reverse* 
  (let ((t-sort (assoc (configf:lookup *configdat* "dashboard" "testsort") *tests-sort-type-index*)))
    (if t-sort
	(cadr t-sort)
	3)))

(define (get-curr-sort)
  (vector-ref *tests-sort-options* *tests-sort-reverse*))

(define *tests-sort-reverse* 3)
(define *hide-empty-runs* #f)
(define *hide-not-hide* #t) ;; toggle for hide/not hide
(define *hide-not-hide-button* #f)
(define *hide-not-hide-tabs* #f)

(define *current-tab-number* 0)
(define *updaters* (make-hash-table))
460
461
462
463
464
465
466

467






468
469
470
471
472
473
474
472
473
474
475
476
477
478
479

480
481
482
483
484
485
486
487
488
489
490
491
492







+
-
+
+
+
+
+
+







			   (testname   (db:test-get-testname  test))
			   (itempath   (db:test-get-item-path test))
			   (testfullname (test:test-get-fullname test))
			   (teststatus (db:test-get-status   test))
			   (teststate  (db:test-get-state    test))
			   ;;(teststart  (db:test-get-event_time test))
			   (runtime    (db:test-get-run_duration test))
			   (buttontxt  (cond
			   (buttontxt  (if (equal? teststate "COMPLETED") teststatus teststate))
					((equal? teststate "COMPLETED") teststatus)
					((and (equal? teststate "NOT_STARTED")
					      (member teststatus '("ZERO_ITEMS" "BLOCKED" "PREQ_FAIL" "PREQ_DISCARDED" "KEEP_TRYING" "TEN_STRIKES")))
					 teststatus)
					(else
					 teststate)))
			   (button     (vector-ref columndat rown))
			   (color      (car (gutils:get-color-for-state-status teststate teststatus)))
			   (curr-color (vector-ref buttondat 1)) ;; (iup:attribute button "BGCOLOR"))
			   (curr-title (vector-ref buttondat 2))) ;; (iup:attribute button "TITLE")))
		      (if (not (equal? curr-color color))
			  (iup:attribute-set! button "BGCOLOR" color))
		      (if (not (equal? curr-title buttontxt))
679
680
681
682
683
684
685
686
687
688



689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718

719
720
721
722
723
724
725
726
727
728
729
697
698
699
700
701
702
703



704
705
706






























707




708
709
710
711
712
713
714







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







	  (begin
	    (hash-table-set! tests-draw-state 'first-time #f)
	    (hash-table-set! tests-draw-state 'scalef 8)
	    (hash-table-set! tests-draw-state 'tests-info (make-hash-table))
	    (hash-table-set! tests-draw-state 'selected-tests (make-hash-table))
	    ;; set these 
	    (hash-table-set! tests-draw-state 'test-browse-xoffset 20) ;; (- 0 (* (/ sizex 2) (* 8 xadj))))
	    (hash-table-set! tests-draw-state 'test-browse-yoffset 20))) ;; (- 0 (* (/ sizey 2) (* 8 (- 1 yadj)))))))
      (let* ((scalef (hash-table-ref/default tests-draw-state 'scalef 8))
	     (test-browse-xoffset (hash-table-ref tests-draw-state 'test-browse-xoffset))
	    (hash-table-set! tests-draw-state 'test-browse-yoffset 20) ;; (- 0 (* (/ sizey 2) (* 8 (- 1 yadj)))))))
	    (dcommon:initial-draw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames))
	  (dcommon:redraw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames))
	     (test-browse-yoffset (hash-table-ref tests-draw-state 'test-browse-yoffset))
	     (xtorig (+ test-browse-xoffset (* (/ sizex 2) scalef (- 0.5 xadj)))) ;;  (- xadj 1))))
	     (ytorig (+ test-browse-yoffset (* (/ sizey 2) scalef (- yadj 0.5))))
	     (boxw   90)
	     (boxh   25)
	     (gapx   20)
	     (gapy   30)
	     (tests-hash     (hash-table-ref tests-draw-state 'tests-info))
	     (selected-tests (hash-table-ref tests-draw-state 'selected-tests )))
	;; (print "sizex: " sizex " sizey: " sizey " font: " (canvas-font cnv) " originx: " originx " originy: " originy " xtorig: " xtorig " ytorig: " ytorig " xadj: " xadj " yadj: " yadj)
	(let loop ((hed (car (reverse sorted-testnames)))
		   (tal (cdr (reverse sorted-testnames)))
		   (llx xtorig)
		   (lly ytorig)
		   (urx (+ xtorig boxw))
		   (ury (+ ytorig boxh)))
	  ; (print "hed " hed " llx " llx " lly " lly " urx " urx " ury " ury)
	  (canvas-text! cnv (+ llx 5)(+ lly 5) hed) ;; (conc testname " (" xtorig "," ytorig ")"))
	  (canvas-rectangle! cnv llx urx lly ury)
	  (if (hash-table-ref/default selected-tests hed #f)
	      (canvas-box! cnv llx (+ llx 5) lly (+ lly 5)))
	  (hash-table-set! tests-hash hed (list llx urx (- sizey ury)(- sizey lly))) ;; NB// Swap ury and lly
	  (if (not (null? tal))
	      ;; leave a column of space to the right to list items
	      (let ((have-room 
		     (if #t ;; put "auto" here where some form of auto rearanging can be done
			 (> (* 3 (+ boxw gapx)) (- urx xtorig))
			 (< urx (- sizex boxw gapx boxw)))))  ;; is there room for another column?
		(loop (car tal)
		      (cdr tal)
      ))
		      (if have-room (+ llx boxw gapx) xtorig) ;; have room, 
		      (if have-room lly (+ lly boxh gapy))
		      (if have-room (+ urx boxw gapx) (+ xtorig boxw))
		      (if have-room ury (+ ury boxh gapy)))))))))

;;======================================================================
;; R U N   C O N T R O L S
;;======================================================================
;;
;; A gui for launching tests
;;
802
803
804
805
806
807
808
809

810
811
812
813
814
815
816
787
788
789
790
791
792
793

794
795
796
797
798
799
800
801







-
+







		 (default-cmd (car cmds-list)))
	    (iuplistbox-fill-list lb cmds-list selected-item: default-cmd)
	    (dboard:data-set-command! *data* default-cmd)
	    lb)))

	(iup:frame
	 #:title "Runname"
	 (let* ((default-run-name (conc "ww" (seconds->work-week/day (current-seconds))))
	 (let* ((default-run-name (seconds->work-week/day (current-seconds)))
		(tb (iup:textbox #:expand "HORIZONTAL"
				 #:action (lambda (obj val txt)
					    ;; (print "obj: " obj " val: " val " unk: " unk)
					    (dboard:data-set-run-name! *data* txt) ;; (iup:attribute obj "VALUE"))
					    (dashboard:update-run-command))
				 #:value default-run-name))
		(lb (iup:listbox #:expand "HORIZONTAL"
884
885
886
887
888
889
890

891
892
893
894
895
896
897







898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942























































943
944
945

946
947
948
949
950
951
952
869
870
871
872
873
874
875
876







877
878
879
880
881
882
883













































884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940

941
942
943
944
945
946
947
948







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


-
+







	       (dashboard:update-run-command))))))))
      
       (iup:frame
	#:title "Tests and Tasks"
	(let* ((updater #f)
	       (last-xadj 0)
	       (last-yadj 0)
	       (the-cnv   #f)
	       (canvas-obj   
	(iup:canvas #:action (make-canvas-action
			      (lambda (cnv xadj yadj)
				(if (not updater)
				    (set! updater (lambda (xadj yadj)
						    ;; (print "cnv: " cnv " x: " x " y: " y)
						    (dashboard:draw-tests cnv xadj yadj tests-draw-state sorted-testnames))))
	       (canvas-obj 
                (iup:canvas #:action (make-canvas-action
				      (lambda (cnv xadj yadj)
					(if (not updater)
					    (set! updater (lambda (xadj yadj)
							    ;; (print "cnv: " cnv " xadj: " xadj " yadj: " yadj)
							    (dashboard:draw-tests cnv xadj yadj tests-draw-state sorted-testnames)
				(updater xadj yadj)
				(set! last-xadj xadj)
				(set! last-yadj yadj)))
		    ;; Following doesn't work 
		    ;; #:wheel-cb (make-canvas-action
		    ;;           (lambda (cnv xadj yadj)
		    ;;    	 ;; (print "cnv: " cnv " x: " x " y: " y)
		    ;;    	 (dashboard:draw-tests cnv xadj yadj tests-draw-state sorted-testnames)))
		    ;; #:size "50x50"
		    #:expand "YES"
		    #:scrollbar "YES"
		    #:posx "0.5"
		    #:posy "0.5"
		    #:button-cb (lambda (obj btn pressed x y status)
				  ;; (print "obj: " obj)
				  (let ((tests-info     (hash-table-ref tests-draw-state  'tests-info))
					(selected-tests (hash-table-ref tests-draw-state  'selected-tests)))
				    ;; (print "x\ty\tllx\tlly\turx\tury")
				    (for-each (lambda (test-name)
						(let* ((rec-coords (hash-table-ref tests-info test-name))
						       (llx        (list-ref rec-coords 0))
						       (urx        (list-ref rec-coords 1))
						       (lly        (list-ref rec-coords 2))
						       (ury        (list-ref rec-coords 3)))
						  ;; (print x "\t" y "\t" llx "\t" lly "\t" urx "\t" ury "\t" test-name " "
						  (if (and (eq? pressed 1)
							   (> x llx)
							   (> y lly)
							   (< x urx)
							   (< y ury))
						      (let ((patterns (string-split (iup:attribute test-patterns-textbox "VALUE"))))
							(let* ((selected     (not (member test-name patterns)))
							       (newpatt-list (if selected
										 (cons test-name patterns)
										 (delete test-name patterns)))
							       (newpatt      (string-intersperse newpatt-list "\n")))
							  ;; (if cnv-obj
							  ;;    (dashboard:draw-tests cnv-obj 0 0 tests-draw-state sorted-testnames))
							  (iup:attribute-set! obj "REDRAW" "ALL")
							  (hash-table-set! selected-tests test-name selected)
							  (iup:attribute-set! test-patterns-textbox "VALUE" newpatt)
							  (dboard:data-set-test-patts! *data* (dboard:lines->test-patt newpatt))
							  (dashboard:update-run-command)
							  (if updater (updater last-xadj last-yadj)))))))
					      (hash-table-keys tests-info)))))))
							    (set! last-xadj xadj)
							    (set! last-yadj yadj))))
					(updater xadj yadj)
					(set! the-cnv cnv)
					))
			    ;; Following doesn't work 
			    #:wheel-cb (lambda (obj step x y dir) ;; dir is 4 for up and 5 for down. I think.
					 (let ((xadj last-xadj)
					       (yadj (+ last-yadj (if (> step 0)
								      -0.01
								      0.01))))
					   ;; (print "step: " step " x: " x " y: " y " dir: \"" dir "\"")
					   ;; (print "the-cnv: " the-cnv " obj: " obj " xadj: " xadj " yadj: " yadj " dir: " dir)
					   (if the-cnv
					       (dashboard:draw-tests the-cnv xadj yadj tests-draw-state sorted-testnames))
					   (set! last-xadj xadj)
					   (set! last-yadj yadj)
					   ))
			    ;; #:size "50x50"
			    #:expand "YES"
			    #:scrollbar "YES"
			    #:posx "0.5"
			    #:posy "0.5"
			    #:button-cb (lambda (obj btn pressed x y status)
					  ;; (print "obj: " obj)
					  (let ((tests-info     (hash-table-ref tests-draw-state  'tests-info))
						(selected-tests (hash-table-ref tests-draw-state  'selected-tests)))
					    ;; (print "x\ty\tllx\tlly\turx\tury")
					    (for-each (lambda (test-name)
							(let* ((rec-coords (hash-table-ref tests-info test-name))
							       (llx        (list-ref rec-coords 0))
							       (urx        (list-ref rec-coords 1))
							       (lly        (list-ref rec-coords 2))
							       (ury        (list-ref rec-coords 3)))
							  ;; (print x "\t" y "\t" llx "\t" lly "\t" urx "\t" ury "\t" test-name " "
							  (if (and (eq? pressed 1)
								   (> x llx)
								   (> y lly)
								   (< x urx)
								   (< y ury))
							      (let ((patterns (string-split (iup:attribute test-patterns-textbox "VALUE"))))
								(let* ((selected     (not (member test-name patterns)))
								       (newpatt-list (if selected
											 (cons test-name patterns)
											 (delete test-name patterns)))
								       (newpatt      (string-intersperse newpatt-list "\n")))
								  ;; (if cnv-obj
								  ;;    (dashboard:draw-tests cnv-obj 0 0 tests-draw-state sorted-testnames))
								  (iup:attribute-set! obj "REDRAW" "ALL")
								  (hash-table-set! selected-tests test-name selected)
								  (iup:attribute-set! test-patterns-textbox "VALUE" newpatt)
								  (dboard:data-set-test-patts! *data* (dboard:lines->test-patt newpatt))
								  (dashboard:update-run-command)
								  (if updater (updater last-xadj last-yadj)))))))
						      (hash-table-keys tests-info)))))))
	  canvas-obj)))
      ;; (print "obj: " obj " btn: " btn " pressed: " pressed " x: " x " y: " y " status: " status))
      
       
      (iup:frame
       #:title "Logs" ;; To be replaced with tabs
       (let ((logs-tb (iup:textbox #:expand "YES"
				   #:multiline "YES")))
	 (dboard:data-set-logs-textbox! *data* logs-tb)
	 logs-tb))))))

1211
1212
1213
1214
1215
1216
1217











1218
1219
1220
1221




1222
1223
1224
1225
1226
1227
1228
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224




1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235







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







	      ;;(iup:textbox #:size "60x15" #:fontsize "10" #:value "%"
	      ;;  	   #:action (lambda (obj unk val)
	      ;;  		      (mark-for-update)
	      ;;  		      (update-search "item-name" val))
	      ))
	    (iup:vbox
	     (iup:hbox
	      (let* ((cmds-list '("+testname" "-testname" "+event_time" "-event_time" "+statestatus" "-statestatus"))
		     (lb         (iup:listbox #:expand "HORIZONTAL"
					      #:dropdown "YES"
					      #:action (lambda (obj val index lbstate)
							 (set! *tests-sort-reverse* index)
							 (mark-for-update))))
		     (default-cmd (car (list-ref *tests-sort-type-index* *tests-sort-reverse*))))
		(iuplistbox-fill-list lb cmds-list selected-item: default-cmd)
		(mark-for-update)
		;; (set! *tests-sort-reverse* *tests-sort-reverse*0)
		lb)
	      (iup:button "Sort -t"   #:action (lambda (obj)
						 (next-sort-option)
						 (iup:attribute-set! obj "TITLE" (vector-ref (vector-ref *tests-sort-options* *tests-sort-reverse*) 0))
						 (mark-for-update)))
	      ;; (iup:button "Sort -t"   #:action (lambda (obj)
	      ;;   				 (next-sort-option)
	      ;;   				 (iup:attribute-set! obj "TITLE" (vector-ref (vector-ref *tests-sort-options* *tests-sort-reverse*) 0))
	      ;;   				 (mark-for-update)))
	      (iup:button "HideEmpty" #:action (lambda (obj)
						 (set! *hide-empty-runs* (not *hide-empty-runs*))
						 (iup:attribute-set! obj "TITLE" (if *hide-empty-runs* "+HideE" "-HideE"))
						 (mark-for-update)))
	      (let ((hideit (iup:button "HideTests" #:action (lambda (obj)
							       (set! *hide-not-hide* (not *hide-not-hide*))
							       (iup:attribute-set! obj "TITLE" (if *hide-not-hide* "HideTests" "NotHide"))
1427
1428
1429
1430
1431
1432
1433
1434

1435
1436
1437
1438
1439
1440
1441
1434
1435
1436
1437
1438
1439
1440

1441
1442
1443
1444
1445
1446
1447
1448







-
+








;; Move this stuff to db.scm? I'm not sure that is the right thing to do...
;;
(define *last-db-update-time* (file-modification-time *db-file-path*)) ;; (conc *toppath* "/db/main.db")))
(define *last-recalc-ended-time* 0)

(define (dashboard:been-changed)
  (> (file-modification-time *db-file-path* *last-db-update-time*)))
  (> (file-modification-time *db-file-path*) *last-db-update-time*))

(define (dashboard:set-db-update-time)
  (set! *last-db-update-time* (file-modification-time *db-file-path*)))

(define (dashboard:recalc modtime please-update-buttons last-db-update-time)
  (or please-update-buttons
      (and (> (current-milliseconds)(+ *last-recalc-ended-time* 150))
1542
1543
1544
1545
1546
1547
1548
















1549
1550






1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571


1572
1573
1574
1575
1576
1577







+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
+
+
+
+
+
+
			   (begin
			     (dashboard:run-update x)
			     (mutex-lock! *update-mutex*)
			     (set! *update-is-running* #f)
			     (mutex-unlock! *update-mutex*))))
		       1))))

(let ((th1 (make-thread (lambda ()
			  (thread-sleep! 1)
			  (set! *please-update-buttons* #t)
			  (dashboard:run-update 1)) "update buttons once"))
			  ;; need to wait for first *update-is-running* #t
			  ;; (let loop ()
			  ;;   (mutex-lock! *update-mutex*)
			  ;;   (if *update-is-running*
			  ;;       (begin
			  ;;         (set! *please-update-buttons* #t)
			  ;;         (mark-for-update)
			  ;;         (print "Did redraw trigger")) "First update after startup")
			  ;;   (mutex-unlock! *update-mutex*)
			  ;;   (thread-sleep! 1)
			  ;;   (if (not *please-update-buttons*)
			  ;;       (loop))))))
(iup:main-loop)
(db:close-all *dbstruct-local*)
      (th2 (make-thread iup:main-loop "Main loop")))
  (thread-start! th1)
  (thread-start! th2)
  (thread-join! th2))

;; (iup:main-loop)(db:close-all *dbstruct-local*)

Modified dcommon.scm from [6ced1731f9] to [233e3f255c].

543
544
545
546
547
548
549



















































































550
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633







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

		       ;;  					   (show message-window
		       ;;  					     #:modal? #t
		       ;;  					     ;; set positon using coordinates or center, start, top, left, end, bottom, right, parent-center, current
		       ;;  					     ;; #:x 'mouse
		       ;;  					     ;; #:y 'mouse
		       ;;  )					     
		       ))))

;;======================================================================
;; CANVAS STUFF FOR TESTS
;;======================================================================

(define (dcommon:draw-test cnv x y w h name selected)
  (let* ((llx x)
	 (lly y)
	 (urx (+ x w))
	 (ury (+ y h)))
    (canvas-text! cnv (+ llx 5)(+ lly 5) name) ;; (conc testname " (" xtorig "," ytorig ")"))
    (canvas-rectangle! cnv llx urx lly ury)
    (if selected (canvas-box! cnv llx (+ llx 5) lly (+ lly 5)))))

(define (dcommon:initial-draw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames)
      (let* ((scalef (hash-table-ref/default tests-draw-state 'scalef 8))
	     (test-browse-xoffset (hash-table-ref tests-draw-state 'test-browse-xoffset))
	     (test-browse-yoffset (hash-table-ref tests-draw-state 'test-browse-yoffset))
	     (xtorig (+ test-browse-xoffset (* (/ sizex 2) scalef (- 0.5 xadj)))) ;;  (- xadj 1))))
	     (ytorig (+ test-browse-yoffset (* (/ sizey 2) scalef (- yadj 0.5))))
	     (boxw   90) ;; default, overriden by length estimate below
	     (boxh   25)
	     (gapx   20)
	     (gapy   30)
	     (tests-hash     (hash-table-ref tests-draw-state 'tests-info))
	     (selected-tests (hash-table-ref tests-draw-state 'selected-tests )))
	(hash-table-set! tests-draw-state 'xtorig xtorig)
	(hash-table-set! tests-draw-state 'ytorig ytorig)
	(let ((longest-str   (car (sort sorted-testnames (lambda (a b)(>= (string-length a)(string-length b)))))))
	  (let-values (((x-max y-max) (canvas-text-size cnv longest-str)))
             (if (> x-max boxw)(set! boxw (+ 10 x-max)))))
	;; (print "sizex: " sizex " sizey: " sizey " font: " (canvas-font cnv) " originx: " originx " originy: " originy " xtorig: " xtorig " ytorig: " ytorig " xadj: " xadj " yadj: " yadj)
	(let loop ((hed (car (reverse sorted-testnames)))
		   (tal (cdr (reverse sorted-testnames)))
		   (llx xtorig)
		   (lly ytorig)
		   (urx (+ xtorig boxw))
		   (ury (+ ytorig boxh)))
	  ; (print "hed " hed " llx " llx " lly " lly " urx " urx " ury " ury)
	  (dcommon:draw-test cnv llx lly boxw boxh hed (hash-table-ref/default selected-tests hed #f))
	  ;; data used by mouse click calc. keep the wacky order for now.
	  (hash-table-set! tests-hash hed  (list llx urx (- sizey ury)(- sizey lly) lly boxw boxh)) 
	  ;; (list llx lly boxw boxh)) ;; NB// Swap ury and lly
	  (if (not (null? tal))
	      ;; leave a column of space to the right to list items
	      (let ((have-room 
		     (if #t ;; put "auto" here where some form of auto rearanging can be done
			 (> (* 3 (+ boxw gapx)) (- urx xtorig))
			 (< urx (- sizex boxw gapx boxw)))))  ;; is there room for another column?
		(loop (car tal)
		      (cdr tal)
		      (if have-room (+ llx boxw gapx) xtorig) ;; have room, 
		      (if have-room lly (+ lly boxh gapy))
		      (if have-room (+ urx boxw gapx) (+ xtorig boxw))
		      (if have-room ury (+ ury boxh gapy))))))))

(define (dcommon:redraw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames)
  (let* ((scalef (hash-table-ref/default tests-draw-state 'scalef 8))
	 (test-browse-xoffset (hash-table-ref tests-draw-state 'test-browse-xoffset))
	 (test-browse-yoffset (hash-table-ref tests-draw-state 'test-browse-yoffset))
	 (xtorig (+ test-browse-xoffset (* (/ sizex 2) scalef (- 0.5 xadj)))) ;;  (- xadj 1))))
	 (ytorig (+ test-browse-yoffset (* (/ sizey 2) scalef (- yadj 0.5))))
	 (xdelta (- (hash-table-ref tests-draw-state 'xtorig) xtorig))
	 (ydelta (- (hash-table-ref tests-draw-state 'ytorig) ytorig))
	 (tests-hash     (hash-table-ref tests-draw-state 'tests-info))
	 (selected-tests (hash-table-ref tests-draw-state 'selected-tests )))
    (hash-table-set! tests-draw-state 'xtorig xtorig)
    (hash-table-set! tests-draw-state 'ytorig ytorig)
    (let loop ((hed (car (reverse sorted-testnames)))
	       (tal (cdr (reverse sorted-testnames))))
      (let* ((tvals (hash-table-ref tests-hash hed))
	     (llx   (+ xdelta (list-ref tvals 0)))
	     (lly   (+ ydelta (list-ref tvals 4)))
	     (boxw  (list-ref tvals 5))
	     (boxh  (list-ref tvals 6))
	     (urx   (+ llx boxw))
	     (ury   (+ lly boxh)))
	(dcommon:draw-test cnv llx lly boxw boxh hed (hash-table-ref/default selected-tests hed #f))
	(hash-table-set! tests-hash hed (list llx urx (- sizey ury)(- sizey lly) lly boxw boxh))
	(if (not (null? tal))
	    ;; leave a column of space to the right to list items
	    (loop (car tal)
		  (cdr tal)))))))

Modified launch.scm from [f158af2890] to [45d25922cf].

89
90
91
92
93
94
95
























96
97
98
99
100
101
102
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







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







                                                   (file-execute-access? fulln))
                                              fulln
                                              runscript))))) ;; assume it is on the path
	       (rollup-status 0))
	  (change-directory top-path)
	  (debug:print 2 "Exectuing " test-name " (id: " test-id ") on " (get-host-name))
	  (set! keys       (rmt:get-keys))
	  ;; (runs:set-megatest-env-vars run-id inkeys: keys inkeyvals: keyvals) ;; these may be needed by the launching process
	  ;; one of these is defunct/redundant ...
	  (if (not (launch:setup-for-run force: #t))
	      (begin
		(debug:print 0 "Failed to setup, exiting") 
		;; (sqlite3:finalize! db)
		;; (sqlite3:finalize! tdb)
		(exit 1)))
	  (change-directory *toppath*) 
	  (let ((rconfig (full-runconfigs-read))) ;; (read-config (conc  *toppath* "/runconfigs.config") #f #t sections: (list "default" target))))
	    ;; (setup-env-defaults (conc *toppath* "/runconfigs.config") run-id (make-hash-table) keyvals target)
	    ;; (set-run-config-vars run-id keyvals target) ;; (db:get-target db run-id))
	    ;; Now have runconfigs data loaded, set environment vars
	    (for-each (lambda (section)
			(for-each (lambda (varval)
				    (let ((var (car varval))
					  (val (cadr varval)))
				      (if (and (string? var)(string? val))
					  (begin
					    (setenv var (config:eval-string-in-environment val))) ;; val)
					  (debug:print 0 "ERROR: bad variable spec, " var "=" val))))
				  (configf:get-section rconfig section)))
		      (list "default" target)))
	  (change-directory work-area) 
	  (set! keyvals    (keys:target->keyval keys target))
	  ;; apply pre-overrides before other variables. The pre-override vars must not
	  ;; clobbers things from the official sources such as megatest.config and runconfigs.config
	  (if (string? set-vars)
	      (let ((varpairs (string-split set-vars ",")))
		(debug:print 4 "varpairs: " varpairs)
		(map (lambda (varpair)
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
146
147
148
149
150
151
152






153
154
155




156

157
158

159
160
161
162
163
164
165
166







-
-
-
-
-
-



-
-
-
-
+
-


-
+







	      (list  "MT_ITEM_INFO" (conc itemdat))
	      (list  "MT_RUNNAME"   runname)
	      (list  "MT_MEGATEST"  megatest)
	      (list  "MT_TARGET"    target)
	      (list  "MT_LINKTREE"  (configf:lookup *configdat* "setup" "linktree"))))
	  (if mt-bindir-path (setenv "PATH" (conc (getenv "PATH") ":" mt-bindir-path)))
	  ;; (change-directory top-path)
	  (if (not (setup-for-run))
	      (begin
		(debug:print 0 "Failed to setup, exiting") 
		;; (sqlite3:finalize! db)
		;; (sqlite3:finalize! tdb)
		(exit 1)))
	  ;; Can setup as client for server mode now
	  ;; (client:setup)

	  (change-directory *toppath*) 
	  (set-megatest-env-vars run-id inkeys: keys inkeyvals: keyvals) ;; these may be needed by the launching process
	  (change-directory work-area) 

	  
	  (set-run-config-vars run-id keyvals target) ;; (db:get-target db run-id))
	  ;; environment overrides are done *before* the remaining critical envars.
	  (alist->env-vars env-ovrd)
	  (set-megatest-env-vars run-id inkeys: keys inkeyvals: keyvals)
	  (runs:set-megatest-env-vars run-id inkeys: keys inkeyvals: keyvals)
	  (set-item-env-vars itemdat)
	  (save-environment-as-files "megatest")
	  ;; open-run-close not needed for test-set-meta-info
	  ;; (tests:set-full-meta-info #f test-id run-id 0 work-area)
	  ;; (tests:set-full-meta-info test-id run-id 0 work-area)
	  (tests:set-full-meta-info #f test-id run-id 0 work-area 10)

411
412
413
414
415
416
417
418

419
420
421
422
423

424
425
426
427
428
429
430
425
426
427
428
429
430
431

432
433
434
435
436

437
438
439
440
441
442
443
444







-
+




-
+







	    (mutex-unlock! m)
	    (debug:print 2 "Output from running " fullrunscript ", pid " (vector-ref exit-info 0) " in work area " 
			 work-area ":\n====\n exit code " (vector-ref exit-info 2) "\n" "====\n")
	    (if (not (vector-ref exit-info 1))
		(exit 4)))))))

;; set up the very basics needed for doing anything here.
(define (setup-for-run)
(define (launch:setup-for-run #!key (force #f))
  ;; would set values for KEYS in the environment here for better support of env-override but 
  ;; have chicken/egg scenario. need to read megatest.config then read it again. Going to 
  ;; pass on that idea for now
  ;; special case
  (if (not (hash-table? *configdat*))  ;; no need to re-open on every call
  (if (or force (not (hash-table? *configdat*)))  ;; no need to re-open on every call
      (begin
	(set! *configinfo* (find-and-read-config 
			    (if (args:get-arg "-config")(args:get-arg "-config") "megatest.config")
			    environ-patt: "env-override"
			    given-toppath: (get-environment-variable "MT_RUN_AREA_HOME")
			    pathenvvar: "MT_RUN_AREA_HOME"))
	(set! *configdat*  (if (car *configinfo*)(car *configinfo*) #f))
707
708
709
710
711
712
713
714


715
716
717
718
719
720
721
721
722
723
724
725
726
727

728
729
730
731
732
733
734
735
736







-
+
+







    (setenv "MT_ITEMPATH" item-path)
    (if hosts (set! hosts (string-split hosts)))
    ;; set the megatest to be called on the remote host
    (if (not remote-megatest)(set! remote-megatest local-megatest)) ;; "megatest"))
    (set! mt-bindir-path (pathname-directory remote-megatest))
    (if launcher (set! launcher (string-split launcher)))
    ;; set up the run work area for this test
    (if (args:get-arg "-preclean") ;; user has requested to preclean for this run
    (if (and (args:get-arg "-preclean") ;; user has requested to preclean for this run
	     (not (equal? (db:test-get-rundir testinfo) "n/a"))) ;; n/a is a placeholder and thus not a read dir
	(begin 
	  (debug:print-info 0 "attempting to preclean directory " (db:test-get-rundir testinfo) " for test " test-name "/" item-path)
	  (runs:remove-test-directory #f testinfo #t))) ;; remove data only, do not perturb the record
    (set! diskpath (get-best-disk *configdat*))
    (if diskpath
	(let ((dat  (create-work-area run-id run-info keyvals test-id test-path diskpath test-name itemdat)))
	  (set! work-area (car dat))

Modified megatest.scm from [545aadfca9] to [1c83282f36].

426
427
428
429
430
431
432
433

434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452

453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471

472
473
474
475
476
477
478
426
427
428
429
430
431
432

433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451

452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470

471
472
473
474
475
476
477
478







-
+


















-
+


















-
+







;;   we start the server if not running else start the client thread
;;======================================================================

(if (args:get-arg "-server")

    ;; Server? Start up here.
    ;;
    (let ((tl        (setup-for-run))
    (let ((tl        (launch:setup-for-run))
	  (run-id    (and (args:get-arg "-run-id")
			  (string->number (args:get-arg "-run-id")))))
      (if run-id
	  (begin
	    (server:launch run-id)
	    (set! *didsomething* #t))
	  (debug:print 0 "ERROR: server requires run-id be specified with -run-id")))

    ;; Not a server? This section will decide how to communicate
    ;;
    ;;  Setup client for all expect listed here
    (if (null? (lset-intersection 
		     equal?
		     (hash-table-keys args:arg-hash)
		     '("-list-servers"
		       "-stop-server"
		       "-show-cmdinfo"
		       "-list-runs")))
	(if (setup-for-run)
	(if (launch:setup-for-run)
	    (let ((run-id    (and (args:get-arg "-run-id")
				  (string->number (args:get-arg "-run-id")))))
	      ;; (set! *fdb*   (filedb:open-db (conc *toppath* "/db/paths.db")))
	      ;; if not list or kill then start a client (if appropriate)
	      (if (or (args-defined? "-h" "-version" "-gen-megatest-area" "-gen-megatest-test")
		      (eq? (length (hash-table-keys args:arg-hash)) 0))
		  (debug:print-info 1 "Server connection not needed")
		  (begin
		    (if run-id 
			(client:launch run-id) 
			(client:launch 0)      ;; without run-id we'll start a server for "0"
			)))))))

;; MAY STILL NEED THIS
;;		       (set! *megatest-db* (make-dbr:dbstruct path: *toppath* local: #t))))))))))

(if (or (args:get-arg "-list-servers")
	(args:get-arg "-stop-server"))
    (let ((tl (setup-for-run)))
    (let ((tl (launch:setup-for-run)))
      (if tl 
	  (let* ((servers (open-run-close tasks:get-all-servers tasks:open-db))
		 (fmtstr  "~5a~12a~8a~20a~24a~10a~10a~10a~10a\n")
		 (servers-to-kill '())
		 (killinfo   (args:get-arg "-stop-server"))
		 (khost-port (if killinfo (if (substring-index ":" killinfo)(string-split ":") #f) #f))
		 (sid        (if killinfo (if (substring-index ":" killinfo) #f (string->number killinfo)) #f)))
535
536
537
538
539
540
541
542

543
544
545
546
547

548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566

567
568
569
570
571
572
573
535
536
537
538
539
540
541

542
543
544
545
546

547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565

566
567
568
569
570
571
572
573







-
+




-
+


















-
+







	 (sections (if target (list "default" target) #f))
	 (data     (begin
		     (setenv "MT_RUN_AREA_HOME" *toppath*)
		     (if key-vals
			 (for-each (lambda (kt)
				     (setenv (car kt) (cadr kt)))
				   key-vals))
		     (read-config "runconfigs.config" #f #t sections: sections))))
		     (read-config (conc *toppath* "/runconfigs.config") #f #t sections: sections))))
    data))


(if (args:get-arg "-show-runconfig")
    (let ((tl (setup-for-run)))
    (let ((tl (launch:setup-for-run)))
      (push-directory *toppath*)
      (let ((data (full-runconfigs-read)))
	;; keep this one local
	(cond
	 ((and (args:get-arg "-section")
	       (args:get-arg "-var"))
	  (let ((val (configf:lookup data (args:get-arg "-section")(args:get-arg "-var"))))
	    (if val (print val))))
	 ((not (args:get-arg "-dumpmode"))
	  (pp (hash-table->alist data)))
	 ((string=? (args:get-arg "-dumpmode") "json")
	(json-write data))
	 (else
	  (debug:print 0 "ERROR: -dumpmode of " (args:get-arg "-dumpmode") " not recognised")))
	(set! *didsomething* #t))
      (pop-directory)))

(if (args:get-arg "-show-config")
    (let ((tl   (setup-for-run))
    (let ((tl   (launch:setup-for-run))
	  (data *configdat*)) ;; (read-config "megatest.config" #f #t)))
      (push-directory *toppath*)
      ;; keep this one local
      (cond 
       ((and (args:get-arg "-section")
	     (args:get-arg "-var"))
	(let ((val (configf:lookup data (args:get-arg "-section")(args:get-arg "-var"))))
665
666
667
668
669
670
671
672

673
674
675
676
677
678
679
665
666
667
668
669
670
671

672
673
674
675
676
677
678
679







-
+







;; Query runs
;;======================================================================

;; NOTE: list-runs and list-db-targets operate on local db!!!
;;
(if (or (args:get-arg "-list-runs")
	(args:get-arg "-list-db-targets"))
    (if (setup-for-run)
    (if (launch:setup-for-run)
	(let* ((dbstruct (make-dbr:dbstruct path: *toppath* local: #t))
	       (runpatt  (args:get-arg "-list-runs"))
	       (testpatt (if (args:get-arg "-testpatt") 
			     (args:get-arg "-testpatt") 
			     "%"))
	       (keys     (db:get-keys dbstruct))
	       ;; (runsdat  (db:get-runs dbstruct runpatt #f #f '()))
863
864
865
866
867
868
869
870

871
872
873
874
875
876
877
863
864
865
866
867
868
869

870
871
872
873
874
875
876
877







-
+







	       (target    (args:get-arg "-target"))
	       (toppath   (assoc/default 'toppath   cmdinfo)))
	  (change-directory toppath)
	  (if (not target)
	      (begin
		(debug:print 0 "ERROR: -target is required.")
		(exit 1)))
	  (if (not (setup-for-run))
	  (if (not (launch:setup-for-run))
	      (begin
		(debug:print 0 "Failed to setup, giving up on -test-paths or -test-files, exiting")
		(exit 1)))
	  (let* ((keys     (rmt:get-keys))
		 ;; db:test-get-paths must not be run remote
		 (paths    (tests:test-get-paths-matching keys target (args:get-arg "-test-files"))))
	    (set! *didsomething* #t)
909
910
911
912
913
914
915
916

917
918
919
920
921
922
923
909
910
911
912
913
914
915

916
917
918
919
920
921
922
923







-
+







	       (status    (args:get-arg ":status"))
	       (target    (args:get-arg "-target")))
	  (change-directory testpath)
	  (if (not target)
	      (begin
		(debug:print 0 "ERROR: -target is required.")
		(exit 1)))
	  (if (not (setup-for-run))
	  (if (not (launch:setup-for-run))
	      (begin
		(debug:print 0 "Failed to setup, giving up on -archive, exiting")
		(exit 1)))
	  (let* ((keys     (rmt:get-keys))
		 (paths    (tests:test-get-paths-matching keys target)))
	    (set! *didsomething* #t)
	    (for-each (lambda (path)
983
984
985
986
987
988
989
990

991
992
993
994
995
996
997
983
984
985
986
987
988
989

990
991
992
993
994
995
996
997







-
+







	     (db-host   (assoc/default 'db-host   cmdinfo))
	     (run-id    (assoc/default 'run-id    cmdinfo))
	     (test-id   (assoc/default 'test-id   cmdinfo))
	     (itemdat   (assoc/default 'itemdat   cmdinfo))
	     (work-area (assoc/default 'work-area cmdinfo))
	     (db        #f))
	(change-directory testpath)
	(if (not (setup-for-run))
	(if (not (launch:setup-for-run))
	    (begin
	      (debug:print 0 "Failed to setup, exiting")
	      (exit 1)))
	(if (and state status)
	    (rmt:teststep-set-status! run-id test-id step state status msg logfile)
	    (begin
	      (debug:print 0 "ERROR: You must specify :state and :status with every call to -step")
1030
1031
1032
1033
1034
1035
1036
1037

1038
1039
1040
1041
1042
1043
1044
1030
1031
1032
1033
1034
1035
1036

1037
1038
1039
1040
1041
1042
1043
1044







-
+







	       (run-id    (assoc/default 'run-id    cmdinfo))
	       (test-id   (assoc/default 'test-id   cmdinfo))
	       (itemdat   (assoc/default 'itemdat   cmdinfo))
	       (work-area (assoc/default 'work-area cmdinfo))
	       (db        #f) ;; (open-db))
	       (state     (args:get-arg ":state"))
	       (status    (args:get-arg ":status")))
	  (if (not (setup-for-run))
	  (if (not (launch:setup-for-run))
	      (begin
		(debug:print 0 "Failed to setup, exiting")
		(exit 1)))

	  (if (args:get-arg "-runstep")(debug:print-info 1 "Running -runstep, first change to directory " work-area))
	  (change-directory work-area)
	  ;; can setup as client for server mode now
1135
1136
1137
1138
1139
1140
1141
1142

1143
1144
1145
1146
1147
1148
1149
1135
1136
1137
1138
1139
1140
1141

1142
1143
1144
1145
1146
1147
1148
1149







-
+







;; Various helper commands can go below here
;;======================================================================

(if (or (args:get-arg "-showkeys")
        (args:get-arg "-show-keys"))
    (let ((db #f)
	  (keys #f))
      (if (not (setup-for-run))
      (if (not (launch:setup-for-run))
	  (begin
	    (debug:print 0 "Failed to setup, exiting")
	    (exit 1)))
      (set! keys (cdb:remote-run db:get-keys db))
      (debug:print 1 "Keys: " (string-intersperse keys ", "))
      (if (sqlite3:database? db)(sqlite3:finalize! db))
      (set! *didsomething* #t)))
1166
1167
1168
1169
1170
1171
1172
1173

1174
1175
1176
1177
1178
1179
1180
1181
1182
1183

1184
1185
1186
1187
1188
1189
1190
1191
1192
1193

1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206

1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221

1222
1223
1224
1225
1226
1227
1228
1166
1167
1168
1169
1170
1171
1172

1173
1174
1175
1176
1177
1178
1179
1180
1181
1182

1183
1184
1185
1186
1187
1188
1189
1190
1191
1192

1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205

1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220

1221
1222
1223
1224
1225
1226
1227
1228







-
+









-
+









-
+












-
+














-
+








;;======================================================================
;; Update the database schema, clean up the db
;;======================================================================

(if (args:get-arg "-rebuild-db")
    (begin
      (if (not (setup-for-run))
      (if (not (launch:setup-for-run))
	  (begin
	    (debug:print 0 "Failed to setup, exiting") 
	    (exit 1)))
      ;; keep this one local
      (open-run-close patch-db #f)
      (set! *didsomething* #t)))

(if (args:get-arg "-cleanup-db")
    (begin
      (if (not (setup-for-run))
      (if (not (launch:setup-for-run))
	  (begin
	    (debug:print 0 "Failed to setup, exiting") 
	    (exit 1)))
      ;; keep this one local
      (open-run-close db:clean-up #f)
      (set! *didsomething* #t)))

(if (args:get-arg "-mark-incompletes")
    (begin
      (if (not (setup-for-run))
      (if (not (launch:setup-for-run))
	  (begin
	    (debug:print 0 "Failed to setup, exiting") 
	    (exit 1)))
      (open-run-close db:find-and-mark-incomplete #f)
      (set! *didsomething* #t)))

;;======================================================================
;; Update the tests meta data from the testconfig files
;;======================================================================

(if (args:get-arg "-update-meta")
    (begin
      (if (not (setup-for-run))
      (if (not (launch:setup-for-run))
	  (begin
	    (debug:print 0 "Failed to setup, exiting") 
	    (exit 1)))
      ;; now can find our db
      ;; keep this one local
      (open-run-close runs:update-all-test_meta #f)
      (set! *didsomething* #t)))

;;======================================================================
;; Start a repl
;;======================================================================

(if (or (args:get-arg "-repl")
	(args:get-arg "-load"))
    (let* ((toppath (setup-for-run))
    (let* ((toppath (launch:setup-for-run))
	   (dbstruct (if toppath (make-dbr:dbstruct path: toppath local: #t) #f)))
      (if dbstruct
	  (begin
	    (set! *db* dbstruct)
	    (set! *client-non-blocking-mode* #t)
	    (import readline)
	    (import apropos)
1240
1241
1242
1243
1244
1245
1246
1247

1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281




























1282
1283
1284
1285
1286
1287
1288
1240
1241
1242
1243
1244
1245
1246

1247
1248
1249
1250
1251
1252
1253




























1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288







-
+






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








;;======================================================================
;; Wait on a run to complete
;;======================================================================

(if (args:get-arg "-run-wait")
    (begin
      (if (not (setup-for-run))
      (if (not (launch:setup-for-run))
	  (begin
	    (debug:print 0 "Failed to setup, exiting") 
	    (exit 1)))
      (operate-on 'run-wait)
      (set! *didsomething* #t)))

;; Not converted to use dbstruct yet
;;
(if (args:get-arg "-convert-to-norm")
    (let* ((toppath (setup-for-run))
	   (dbstruct (if toppath (make-dbr:dbstruct path: toppath local: #t))))
      (for-each 
       (lambda (field)
	 (let ((dat '()))
	   (debug:print-info 0 "Getting data for field " field)
	   (sqlite3:for-each-row
	    (lambda (id val)
	      (set! dat (cons (list id val) dat)))
	    (get-db db run-id)
	    (conc "SELECT id," field " FROM tests;"))
	   (debug:print-info 0 "found " (length dat) " items for field " field)
	   (let ((qry (sqlite3:prepare db (conc "UPDATE tests SET " field "=? WHERE id=?;"))))
	     (for-each
	      (lambda (item)
		(let ((newval ;; (sdb:qry 'getid 
		       (cadr item))) ;; )
		  (if (not (equal? newval (cadr item)))
		      (debug:print-info 0 "Converting " (cadr item) " to " newval " for test #" (car item)))
		  (sqlite3:execute qry newval (car item))))
	      dat)
	     (sqlite3:finalize! qry))))
       (db:close-all dbstruct)
       (list "uname" "rundir" "final_logf" "comment"))
      (set! *didsomething* #t)))
;; ;; ;; redo me ;; Not converted to use dbstruct yet
;; ;; ;; redo me ;;
;; ;; ;; redo me (if (args:get-arg "-convert-to-norm")
;; ;; ;; redo me     (let* ((toppath (setup-for-run))
;; ;; ;; redo me 	   (dbstruct (if toppath (make-dbr:dbstruct path: toppath local: #t))))
;; ;; ;; redo me       (for-each 
;; ;; ;; redo me        (lambda (field)
;; ;; ;; redo me 	 (let ((dat '()))
;; ;; ;; redo me 	   (debug:print-info 0 "Getting data for field " field)
;; ;; ;; redo me 	   (sqlite3:for-each-row
;; ;; ;; redo me 	    (lambda (id val)
;; ;; ;; redo me 	      (set! dat (cons (list id val) dat)))
;; ;; ;; redo me 	    (db:get-db db run-id)
;; ;; ;; redo me 	    (conc "SELECT id," field " FROM tests;"))
;; ;; ;; redo me 	   (debug:print-info 0 "found " (length dat) " items for field " field)
;; ;; ;; redo me 	   (let ((qry (sqlite3:prepare db (conc "UPDATE tests SET " field "=? WHERE id=?;"))))
;; ;; ;; redo me 	     (for-each
;; ;; ;; redo me 	      (lambda (item)
;; ;; ;; redo me 		(let ((newval ;; (sdb:qry 'getid 
;; ;; ;; redo me 		       (cadr item))) ;; )
;; ;; ;; redo me 		  (if (not (equal? newval (cadr item)))
;; ;; ;; redo me 		      (debug:print-info 0 "Converting " (cadr item) " to " newval " for test #" (car item)))
;; ;; ;; redo me 		  (sqlite3:execute qry newval (car item))))
;; ;; ;; redo me 	      dat)
;; ;; ;; redo me 	     (sqlite3:finalize! qry))))
;; ;; ;; redo me        (db:close-all dbstruct)
;; ;; ;; redo me        (list "uname" "rundir" "final_logf" "comment"))
;; ;; ;; redo me       (set! *didsomething* #t)))

(if (args:get-arg "-import-megatest.db")
    (let* ((toppath  (setup-for-run))
	   (dbstruct (if toppath (make-dbr:dbstruct path: toppath) #f))
	   (mtdb     (if toppath (db:open-megatest-db)))
	   (run-ids  (if toppath (db:get-all-run-ids mtdb))))
      ;; sync runs, test_meta etc.

Modified newdashboard.scm from [4e9877b3af] to [d94e7d2519].

65
66
67
68
69
70
71
72

73
74
75
76
77
78
79
65
66
67
68
69
70
71

72
73
74
75
76
77
78
79







-
+







		 0))

(if (args:get-arg "-h")
    (begin
      (print help)
      (exit)))

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

(if (args:get-arg "-host")
    (begin
      (set! *runremote* (string-split (args:get-arg "-host" ":")))

Modified runs.scm from [45abf9e2f5] to [d806e46083].

35
36
37
38
39
40
41
42

43
44
45
46
47
48
49
35
36
37
38
39
40
41

42
43
44
45
46
47
48
49







-
+







    (conc testname (if (equal? itempath "") "" (conc "(" itempath ")")))))

;; This is the *new* methodology. One record to inform them and in the chaos, organise them.
;;
(define (runs:create-run-record)
  (let* ((mconfig      (if *configdat*
		           *configdat*
		           (if (setup-for-run)
		           (if (launch:setup-for-run)
		               *configdat*
		               (begin
		                 (debug:print 0 "ERROR: Called setup in a non-megatest area, exiting")
		                 (exit 1)))))
	  (runrec      (runs:runrec-make-record))
	  (target      (common:args-get-target))
	  (runname     (or (args:get-arg "-runname")
86
87
88
89
90
91
92
93

94
95
96
97
98
99
100
86
87
88
89
90
91
92

93
94
95
96
97
98
99
100







-
+







		(for-each (lambda (varval)
			    (set! envdat (append envdat (list varval)))
			    (safe-setenv (car varval)(cadr varval)))
			  (configf:get-section runconfig section)))
	      (list "default" target))
    (vector target runname testpatt keys keyvals envdat mconfig runconfig serverdat transport db toppath run-id)))

(define (set-megatest-env-vars run-id #!key (inkeys #f)(inrunname #f)(inkeyvals #f))
(define (runs:set-megatest-env-vars run-id #!key (inkeys #f)(inrunname #f)(inkeyvals #f))
  (let* ((target    (or (common:args-get-target)
			(get-environment-variable "MT_TARGET")))
	 (keys    (if inkeys    inkeys    (rmt:get-keys)))
	 (keyvals   (if inkeyvals inkeyvals (keys:target->keyval keys target)))
	 (vals      (hash-table-ref/default *env-vars-by-run-id* run-id #f))
	 (link-tree (configf:lookup *configdat* "setup" "linktree")))
    ;; get the info from the db and put it in the cache
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
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







+
-
-
-
-
+
+
+
+

-
+

-
+

+
+
+
+
+
+





+
+
-
+







(define (runs:run-tests target runname test-patts user flags) ;; test-names
  (let* ((keys               (keys:config-get-fields *configdat*))
	 (keyvals            (keys:target->keyval keys target))
	 (run-id             (rmt:register-run keyvals runname "new" "n/a" user))  ;;  test-name)))
	 (deferred          '()) ;; delay running these since they have a waiton clause
	 (runconfigf         (conc  *toppath* "/runconfigs.config"))
	 (test-records       (make-hash-table))
	 ;; need to process runconfigs before generating these lists
	 (all-tests-registry (tests:get-all)) ;; (tests:get-valid-tests (make-hash-table) test-search-path)) ;; all valid tests to check waiton names
	 (all-test-names     (hash-table-keys all-tests-registry))
	 (test-names         (tests:filter-test-names all-test-names test-patts))
	 (required-tests     (lset-intersection equal? (string-split test-patts ",") test-names))) ;; test-names)) ;; Added test-names as initial for required-tests but that failed to work
	 (all-tests-registry #f)  ;; (tests:get-all)) ;; (tests:get-valid-tests (make-hash-table) test-search-path)) ;; all valid tests to check waiton names
	 (all-test-names     #f)  ;; (hash-table-keys all-tests-registry))
	 (test-names         #f)  ;; (tests:filter-test-names all-test-names test-patts))
	 (required-tests     #f)) ;;(lset-intersection equal? (string-split test-patts ",") test-names))) ;; test-names)) ;; Added test-names as initial for required-tests but that failed to work

    (set-megatest-env-vars run-id inkeys: keys inrunname: runname) ;; these may be needed by the launching process
    (runs:set-megatest-env-vars run-id inkeys: keys inrunname: runname) ;; these may be needed by the launching process
    (if (file-exists? runconfigf)
	(setup-env-defaults runconfigf run-id *already-seen-runconfig-info* keyvals "pre-launch-env-vars")
	(setup-env-defaults runconfigf run-id *already-seen-runconfig-info* keyvals target)
	(debug:print 0 "WARNING: You do not have a run config file: " runconfigf))

    ;; Now generate all the tests lists
    (set! all-tests-registry (tests:get-all))
    (set! all-test-names     (hash-table-keys all-tests-registry))
    (set! test-names         (tests:filter-test-names all-test-names test-patts))
    (set! required-tests     (lset-intersection equal? (string-split test-patts ",") test-names))
    
    ;; look up all tests matching the comma separated list of globs in
    ;; test-patts (using % as wildcard)

    ;; (set! test-names (delete-duplicates (tests:get-valid-tests *toppath* test-patts)))
    (debug:print-info 0 "tests search path: " (tests:get-tests-search-path *configdat*))
    (debug:print-info 0 "all tests:  " (string-intersperse (sort all-test-names string<) " "))
    (debug:print-info 0 "test names " test-names)
    (debug:print-info 0 "test names: " (string-intersperse (sort test-names string<) " "))

    ;; on the first pass or call to run-tests set FAILS to NOT_STARTED if
    ;; -keepgoing is specified
    (if (eq? *passnum* 0)
	(begin
	  ;; have to delete test records where NOT_STARTED since they can cause -keepgoing to 
	  ;; get stuck due to becoming inaccessible from a failed test. I.e. if test B depends 
428
429
430
431
432
433
434
435

436
437
438



439
440
441
442
443
444
445
437
438
439
440
441
442
443

444
445
446
447
448
449
450
451
452
453
454
455
456
457







-
+



+
+
+







     ((or (null? prereqs-not-met)
	  (and (member 'toplevel testmode)
	       (null? non-completed)))
      (debug:print-info 4 "runs:expand-items: (or (null? prereqs-not-met) (and (member 'toplevel testmode)(null? non-completed)))")
      (let ((test-name (tests:testqueue-get-testname test-record)))
	(setenv "MT_TEST_NAME" test-name) ;; 
	(setenv "MT_RUNNAME"   runname)
	(set-megatest-env-vars run-id inrunname: runname) ;; these may be needed by the launching process
	(runs:set-megatest-env-vars run-id inrunname: runname) ;; these may be needed by the launching process
	(let ((items-list (items:get-items-from-config tconfig)))
	  (if (list? items-list)
	      (begin
		(if (null? items-list)
		    (let ((test-id (rmt:get-test-id run-id test-name "")))
		      (mt:test-set-state-status-by-id run-id test-id "NOT_STARTED" "ZERO_ITEMS" "Failed to run due to failed prerequisites")))
		(tests:testqueue-set-items! test-record items-list)
		(list hed tal reg reruns))
	      (begin
		(debug:print 0 "ERROR: The proc from reading the items table did not yield a list - please report this")
		(exit 1))))))

     ((and (null? fails)
468
469
470
471
472
473
474
475

476
477
478
479
480
481
482
480
481
482
483
484
485
486

487
488
489
490
491
492
493
494







-
+







	(if (and give-up
		 (not (and (null? tal)(null? reg))))
	    (let ((trimmed-tal (mt:discard-blocked-tests run-id hed tal test-records))
		  (trimmed-reg (mt:discard-blocked-tests run-id hed reg test-records)))
	      (debug:print 1 "WARNING: test " hed " has discarded prerequisites, removing it from the queue")

	      (let ((test-id (rmt:get-test-id run-id hed "")))
		(mt:test-set-state-status-by-id test-id "DEQUEUED" "PREQ_FAIL" "Failed to run due to failed prerequisites"))
		(mt:test-set-state-status-by-id run-id test-id "NOT_STARTED" "PREQ_DISCARDED" "Failed to run due to discarded prerequisites"))
	      
	      (if (and (null? trimmed-tal)
		       (null? trimmed-reg))
		  #f
		  (list (runs:queue-next-hed trimmed-tal trimmed-reg reglen regfull)
			(runs:queue-next-tal trimmed-tal trimmed-reg reglen regfull)
			(runs:queue-next-reg trimmed-tal trimmed-reg reglen regfull)
544
545
546
547
548
549
550


551
552
553
554
555
556
557
558
559


560
561
562
563
564
565
566
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582







+
+









+
+







	    (runs:inc-cant-run-tests hed)
	    (debug:print-info 1 "no fails in prerequisites for " hed " but also none running, keeping " hed " for now. Try count: " (hash-table-ref/default *seen-cant-run-tests* hed 0))
	    ;; num-retries code was here
	    ;; we use this opportunity to move contents of reg to tal
	    (list (car newtal)(append (cdr newtal) reg) '() reruns)) ;; an issue with prereqs not yet met?
	  (begin
	    (debug:print-info 1 "no fails in prerequisites for " hed " but nothing seen running in a while, dropping test " hed " from the run queue")
	    (let ((test-id (rmt:get-test-id run-id hed "")))
	      (mt:test-set-state-status-by-id run-id test-id "DEQUEDED" "TIMED_OUT" "Nothing seen running in a while."))
	    (list (runs:queue-next-hed tal reg reglen regfull)
		  (runs:queue-next-tal tal reg reglen regfull)
		  (runs:queue-next-reg tal reg reglen regfull)
		  reruns))))

     ((and (not (null? fails))(member 'normal testmode))
      (debug:print-info 1 "test "  hed " (mode=" testmode ") has failed prerequisite(s); "
			(string-intersperse (map (lambda (t)(conc (db:test-get-testname t) ":" (db:test-get-state t)"/"(db:test-get-status t))) fails) ", ")
			", removing it from to-do list")
      (let ((test-id (rmt:get-test-id run-id hed "")))
	(mt:test-set-state-status-by-id run-id test-id "NOT_STARTED" "PREQ_FAIL" "Failed to run due to failed prerequisites"))
      (if (or (not (null? reg))(not (null? tal)))
	  (begin
	    (hash-table-set! test-registry hed 'CANNOTRUN)
	    (list (runs:queue-next-hed tal reg reglen regfull)
		  (runs:queue-next-tal tal reg reglen regfull)
		  (runs:queue-next-reg tal reg reglen regfull)
		  (cons hed reruns)))
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







+
+


+







	    (list (car newtal)(cdr newtal) reg reruns))
	  ;; the waiton is FAIL so no point in trying to run hed ever again
	  (if (or (not (null? reg))(not (null? tal)))
	      (if (vector? hed)
		  (begin
		    (debug:print 1 "WARNING: Dropping test " test-name "/" item-path
				 " from the launch list as it has prerequistes that are FAIL")
		    (let ((test-id (rmt:get-test-id run-id hed "")))
		      (mt:test-set-state-status-by-id run-id test-id "NOT_STARTED" "PREQ_FAIL" "Failed to run due to failed prerequisites"))
		    (runs:shrink-can-run-more-tests-count) ;; DELAY TWEAKER (still needed?)
		    ;; (thread-sleep! *global-delta*)
		    ;; This next is for the items
		    (mt:test-set-state-status-by-testname run-id test-name item-path "NOT_STARTED" "BLOCKED" #f)
		    (hash-table-set! test-registry (runs:make-full-test-name test-name item-path) 'removed)
		    (list (runs:queue-next-hed tal reg reglen regfull)
			  (runs:queue-next-tal tal reg reglen regfull)
			  (runs:queue-next-reg tal reg reglen regfull)
			  reruns ;; WAS: (cons hed reruns) ;; but that makes no sense?
			  ))
900
901
902
903
904
905
906
907

908
909
910
911
912
913
914
919
920
921
922
923
924
925

926
927
928
929
930
931
932
933







-
+







	     (newtal      (append tal (list hed)))
	     (regfull     (>= (length reg) reglen))
	     (num-running (rmt:get-count-tests-running-for-run-id run-id)))

      (if (> num-running 0)
	  (set! last-time-some-running (current-seconds)))

      (if (> (current-seconds)(+ last-time-some-running 60))
      (if (> (current-seconds)(+ last-time-some-running 240))
	  (hash-table-set! *max-tries-hash* tfullname (+ (hash-table-ref/default *max-tries-hash* tfullname 0) 1)))
	;; (debug:print 0 "max-tries-hash: " (hash-table->alist *max-tries-hash*))

	;; Ensure all top level tests get registered. This way they show up as "NOT_STARTED" on the dashboard
	;; and it is clear they *should* have run but did not.
	(if (not (hash-table-ref/default test-registry (runs:make-full-test-name test-name "") #f))
	    (begin
1114
1115
1116
1117
1118
1119
1120
1121

1122
1123
1124
1125
1126
1127
1128
1133
1134
1135
1136
1137
1138
1139

1140
1141
1142
1143
1144
1145
1146
1147







-
+







		      "\n   test-config: " (hash-table->alist test-conf)
		      "\n   itemdat: " itemdat
		      )
    (debug:print 2 "Attempting to launch test " full-test-name)
    (setenv "MT_TEST_NAME" test-name) ;; 
    (setenv "MT_ITEMPATH"  item-path)
    (setenv "MT_RUNNAME"   runname)
    (set-megatest-env-vars run-id inrunname: runname) ;; these may be needed by the launching process
    (runs:set-megatest-env-vars run-id inrunname: runname) ;; these may be needed by the launching process
    (change-directory *toppath*)

    ;; Here is where the test_meta table is best updated
    ;; Yes, another use of a global for caching. Need a better way?
    ;;
    ;; There is now a single call to runs:update-all-test_meta and this 
    ;; per-test call is not needed. Given the delicacy of the move to 
1358
1359
1360
1361
1362
1363
1364

1365
1366
1367
1368
1369
1370
1371
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391







+







		 (let ((sorted-tests     (sort tests (lambda (a b)(let ((dira ;; (rmt:sdb-qry 'getstr 
									 (db:test-get-rundir a)) ;; )  ;; (filedb:get-path *fdb* (db:test-get-rundir a)))
									(dirb ;; (rmt:sdb-qry 'getstr 
									 (db:test-get-rundir b))) ;; ) ;; ((filedb:get-path *fdb* (db:test-get-rundir b))))
								    (if (and (string? dira)(string? dirb))
									(> (string-length dira)(string-length dirb))
									#f)))))
		       (toplevel-retries (make-hash-table)) ;; try three times to loop through and remove top level tests
		       (test-retry-time  (make-hash-table))
		       (allow-run-time   10)) ;; seconds to allow for killing tests before just brutally killing 'em
		   (let loop ((test (car sorted-tests))
			      (tal  (cdr sorted-tests)))
		     (let* ((test-id       (db:test-get-id test))
			    (new-test-dat  (rmt:get-test-info-by-id run-id test-id)))
		       (if (not new-test-dat)
1383
1384
1385
1386
1387
1388
1389

1390







1391
1392
1393
1394
1395
1396
1397
1403
1404
1405
1406
1407
1408
1409
1410

1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424







+
-
+
+
+
+
+
+
+







				  (uname         (db:test-get-uname    new-test-dat))
				  (toplevel-with-children (and (db:test-get-is-toplevel test)
							       (> (cdb:remote-run db:test-toplevel-num-items db run-id test-name) 0))))
			     (case action
			       ((remove-runs)
				;; if the test is a toplevel-with-children issue an error and do not remove
				(if toplevel-with-children
				    (begin
				    (debug:print 0 "WARNING: skipping removal of " test-fulln " with run-id " run-id " as it has sub tests")
				      (debug:print 0 "WARNING: skipping removal of " test-fulln " with run-id " run-id " as it has sub tests")
				      (hash-table-set! toplevel-retries test-fulln (+ (hash-table-ref/default toplevel-retries test-fulln 0) 1))
				      (if (> (hash-table-ref toplevel-retries test-fulln) 3)
					  (if (not (null? tal))
					      (loop (car tal)(cdr tal))) ;; no else clause - drop it if no more in queue and > 3 tries
					  (let ((newtal (append tal (list test))))
					    (loop (car newtal)(cdr newtal))))) ;; loop with test still in queue
				    (begin
				      (debug:print-info 0 "test: " test-name " itest-state: " test-state)
				      (if (member test-state (list "RUNNING" "LAUNCHED" "REMOTEHOSTSTART" "KILLREQ"))
					  (begin
					    (if (not (hash-table-ref/default test-retry-time test-fulln #f))
						(begin
						  ;; want to set to REMOVING BUT CANNOT do it here?
1452
1453
1454
1455
1456
1457
1458
1459

1460
1461
1462
1463
1464
1465
1466
1479
1480
1481
1482
1483
1484
1485

1486
1487
1488
1489
1490
1491
1492
1493







-
+








(define (runs:remove-test-directory db test remove-data-only)
  (let* ((run-dir       (db:test-get-rundir test))    ;; run dir is from the link tree
	 (real-dir      (if (file-exists? run-dir)
			    (resolve-pathname run-dir)
			    #f)))
    (if (not remove-data-only)
	(mt:test-set-state-status-by-id (db:test-get-id test) "REMOVING" "LOCKED" #f))
	(mt:test-set-state-status-by-id (db:test-get-run-id test)(db:test-get-id test) "REMOVING" "LOCKED" #f))
    (debug:print-info 1 "Attempting to remove " (if real-dir (conc " dir " real-dir " and ") "") " link " run-dir)
    (if (and real-dir 
	     (> (string-length real-dir) 5)
	     (file-exists? real-dir)) ;; bad heuristic but should prevent /tmp /home etc.
	(begin ;; let* ((realpath (resolve-pathname run-dir)))
	  (debug:print-info 1 "Recursively removing " real-dir)
	  (if (file-exists? real-dir)
1506
1507
1508
1509
1510
1511
1512
1513

1514
1515
1516
1517
1518
1519
1520
1533
1534
1535
1536
1537
1538
1539

1540
1541
1542
1543
1544
1545
1546
1547







-
+







      (exit 3))
     ((not runname)
      (debug:print 0 "ERROR: Missing required parameter for " switchname ", you must specify the run name with -runname runname")
      (exit 3))
     (else
      (let ((db   #f)
	    (keys #f))
	(if (not (setup-for-run))
	(if (not (launch:setup-for-run))
	    (begin 
	      (debug:print 0 "Failed to setup, exiting")
	      (exit 1)))
	;; (if (args:get-arg "-server")
	;;     (cdb:remote-run server:start db (args:get-arg "-server")))
	(set! keys (keys:config-get-fields *configdat*))
	;; have enough to process -target or -reqtarg here

Modified tasks.scm from [a24fc80b64] to [0cb7ba898b].

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
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







+
+
+
+
+
+
+
+
+





-
-
-
+
+
+
+






-
+
+
+








(include "task_records.scm")

;;======================================================================
;; Tasks db
;;======================================================================

;; If file exists AND
;;    file readable
;;         ==> open it
;; If file exists AND
;;    file NOT readable
;;         ==> open in-mem version
;; If file NOT exists
;;    ==> open in-mem version
;;
(define (tasks:open-db)
  (let* ((linktree     (configf:lookup *configdat* "setup" "linktree"))
	 (dbpath       (conc linktree "/.db/monitor.db"))
	 (exists       (file-exists? dbpath))
	 (write-access (file-write-access? dbpath))
	 (mdb          (if (file-write-access? *toppath*)
			   (sqlite3:open-database dbpath)
			   (sqlite3:open-database ":memory:"))) ;; (never-give-up-open-db dbpath))
	 (mdb          (cond
			((file-write-access? *toppath*)(sqlite3:open-database dbpath))
			((file-read-access? dbpath)    (sqlite3:open-database dbpath))
			(else (sqlite3:open-database ":memory:")))) ;; (never-give-up-open-db dbpath))
	 (handler      (make-busy-timeout 36000)))
    (if (and exists
	     (not write-access))
	(set! *db-write-access* write-access)) ;; only unset so other db's also can use this control
    (sqlite3:set-busy-handler! mdb handler)
    (sqlite3:execute mdb (conc "PRAGMA synchronous = 0;"))
    (if (not exists)
    (if (or (and (not exists)
		 (file-write-access? *toppath*))
	    (not (file-read-access? dbpath)))
	(begin
	  (sqlite3:execute mdb "CREATE TABLE IF NOT EXISTS tasks_queue (id INTEGER PRIMARY KEY,
                                action TEXT DEFAULT '',
                                owner TEXT,
                                state TEXT DEFAULT 'new',
                                target TEXT DEFAULT '',
                                name TEXT DEFAULT '',

Modified tests.scm from [1442dbb947] to [4ca513a697].

29
30
31
32
33
34
35
36
37

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


36
37
38
39
40
41
42
43







-
-
+







(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(include "test_records.scm")

;; Call this one to do all the work and get a standardized list of tests
(define (tests:get-all)
  (let* ((test-search-path   (cons (conc *toppath* "/tests") ;; the default
				   (tests:get-tests-search-path *configdat*))))
  (let* ((test-search-path   (tests:get-tests-search-path *configdat*)))
    (tests:get-valid-tests (make-hash-table) test-search-path)))

(define (tests:get-tests-search-path cfgdat)
  (let ((paths (map cadr (configf:get-section cfgdat "tests-paths"))))
    (cons (conc *toppath* "/tests") paths)))

(define (tests:get-valid-tests test-registry tests-paths)
472
473
474
475
476
477
478
479

480
481
482
483
484
485
486
471
472
473
474
475
476
477

478
479
480
481
482
483
484
485







-
+







	 (tests:testqueue-set-priority! b-record b-priority)
	 (if (and a-waitons (member (tests:testqueue-get-testname b-record) a-waitons))
	     #f ;; cannot have a which is waiting on b happening before b
	     (if (and b-waitons (member (tests:testqueue-get-testname a-record) b-waitons))
		 #t ;; this is the correct order, b is waiting on a and b is before a
		 (if (> a-priority b-priority)
		     #t ;; if a is a higher priority than b then we are good to go
		     #f))))))))
		     (string-compare3 a b)))))))))

;; for each test:
;;   
(define (tests:filter-non-runnable run-id testkeynames testrecordshash)
  (let ((runnables '()))
    (for-each
     (lambda (testkeyname)

Modified tests/fullrun/megatest.config from [2791752641] to [9e6357a013].

9
10
11
12
13
14
15

16
17
18
19
20
21
22
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23







+







area1 /tmp/oldarea/megatest

[include config/mt_include_1.config]

[dashboard]
pre-command  xterm -geometry 180x20 -e "
post-command |& tee results.log ;echo Press any key to continue;bash -c 'read -n 1 -s'" &
testsort -event_time

[misc]
home #{shell readlink -f $MT_RUN_AREA_HOME}
parent #{shell readlink -f $MT_RUN_AREA_HOME/..}

[tests-paths]
1 #{get misc parent}/simplerun/tests

tests/installall/config/megatest.config.dat became a regular file with contents [736a5da885].

tests/installall/config/runconfigs.config.dat became a regular file with contents [3b8f260acb].

Modified utils/Makefile_latest.installall from [acded49260] to [89573a2276].

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
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







+

-
-
+
+
+
+












-
-
+
+
+
+
+
+





-
-
+
+







# make PREFIX=/mfs/pkgs/chicken/chicken-core all

help :
	@echo You may need to do the following first:
	@echo sudo apt-get install libreadline-dev
	@echo sudo apt-get install libwebkitgtk-dev 
	@echo sudo apt-get install libmotif3
	@echo For IUP set IUPBRANCH, currently $(IUPBRANCH)
	@echo You are using PREFIX=$(PREFIX)
	@echo You are using proxy="$(proxy)"
	@echo If needed set proxy to host.dom:port
	@echo You are using PROXY="$(PROXY)"
	@echo If needed set PROXY to host.dom:port
	@echo   http_proxy=$(http_proxy)
	@echo   PROX=$(PROX)
	@echo 
	@echo To make all do: make all

# Put the installation here
ifeq ($(PREFIX),)
PREFIX=$(PWD)/target
endif

# Set this on the command line of your make call if needed: make PROXY=host.com:1234
PROXY=

# Select version of chicken, sqlite3 etc
CHICKEN_VERSION=4.8.0
SQLITE3_VERSION=3071401
CHICKEN_VERSION=4.9.0.1
SQLITE3_VERSION=3080500
# http://www.sqlite.org/2014/sqlite-autoconf-3080500.tar.gz

# Override IUPBRANCH to use other than trunk
IUPBRANCH=iup-3.10.1

# 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 sqlite3 sql-de-lite \
     srfi-19
     spiffy-directory-listing ssax sxml-serializer sxml-modifications sql-de-lite \
     srfi-19 refdb

#
# Derived variables
#

ifeq ($(PROXY),)
PROX=
71
72
73
74
75
76
77

78
79
80

81
82
83
84
85
86
87
78
79
80
81
82
83
84
85
86
87

88
89
90
91
92
93
94
95







+


-
+







ifeq ($(ISARCHX86_64),)
ARCHSIZE=
else
ARCHSIZE=64_
endif

CSCLIBS=$(shell echo $(LD_LIBRARY_PATH) | sed 's/:/ -L/g')
CSC_OPTIONS="-I$(PREFIX)/include -L$(CSCLIBS)"
# CSC_OPTIONS=-I$(PREFIX)/include -L$(CSCLIBS)

all : chkn eggs libiup logprobin
all : chkn eggs libiup logprobin $(PREFIX)/lib/sqlite3.so

chkn : $(CHICKEN_INSTALL)

eggs : $(EGGSOFILES)

libiup : $(PREFIX)/lib/libavcall.a $(CHICKEN_EGG_DIR)/iup.so $(CHICKEN_EGG_DIR)/canvas-draw.so

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
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







-
-
-
+
+
+
-





+
+
+

+





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


















-
+

-
+


+
+
+
-
-
+
+


-
+


-
+
+



# some setup stuff
#
setup-chicken4x.sh : $(EGGFLAGS)
	(echo "export PATH=$(PATH)" > setup-chicken4x.sh)
	(echo "export LD_LIBRARY_PATH=$(LD_LIBRARY_PATH)" >> setup-chicken4x.sh)
	mkdir -p $(PREFIX)

chicken-core/chicken.scm : chicken-4.9.0rc1.tar.gz
	tar xfz chicken-4.9.0rc1.tar.gz
	ln -sf chicken-4.9.0rc1 chicken-core
chicken-core/chicken.scm : chicken-$(CHICKEN_VERSION).tar.gz
	tar xfz chicken-$(CHICKEN_VERSION).tar.gz
	ln -sf chicken-$(CHICKEN_VERSION) chicken-core
	# git clone http://code.call-cc.org/git/chicken-core.git


chicken-4.9.0rc1.tar.gz : 
	wget http://code.call-cc.org/dev-snapshots/2014/04/17/chicken-4.9.0rc1.tar.gz

chicken-4.9.0.1.tar.gz :
	wget http://code.call-cc.org/releases/4.9.0/chicken-4.9.0.1.tar.gz

# git clone git://code.call-cc.org/chicken-core
# git clone http://code.call-cc.org/git/chicken-core.git

$(CHICKEN_INSTALL) : chicken-core/chicken.scm setup-chicken4x.sh
	cd chicken-core;make PLATFORM=linux PREFIX=$(PREFIX)
	cd chicken-core;make PLATFORM=linux PREFIX=$(PREFIX) install

#======================================================================
# S Q L I T E 3
#======================================================================
# 
# IUP
#

sqlite-autoconf-$(SQLITE3_VERSION).tar.gz :
	wget  http://www.sqlite.org/2014/sqlite-autoconf-$(SQLITE3_VERSION).tar.gz

sqlite-autoconf-$(SQLITE3_VERSION)/config.log : sqlite-autoconf-$(SQLITE3_VERSION).tar.gz
	tar xfz  sqlite-autoconf-$(SQLITE3_VERSION).tar.gz

$(PREFIX)/bin/sqlite3 : sqlite-autoconf-$(SQLITE3_VERSION)/config.log
	cd sqlite-autoconf-$(SQLITE3_VERSION);./configure --prefix=$(PREFIX);make;make install

$(PREFIX)/lib/sqlite3.so : $(PREFIX)/bin/sqlite3
	CSC_OPTIONS="-I$(PREFIX)/include -L$(PREFIX)/lib" $(CHICKEN_INSTALL) $(PROX) sqlite3

#======================================================================
# I U P 
#======================================================================

ffcall.fossil :
	fossil clone http://www.kiatoa.com/fossils/ffcall ffcall.fossil

ffcall/README : ffcall.fossil
	mkdir -p ffcall
	cd ffcall && if [ -e README ];then fossil update; else fossil open ../ffcall.fossil; fi

# NOTE: This worked fine *without* the enable-shared
#
$(PREFIX)/lib/libavcall.a : ffcall/README
	cd ffcall;./configure --prefix=$(PREFIX) --enable-shared && make && make install

iuplib.fossil :
	fossil clone http://www.kiatoa.com/fossils/iuplib iuplib.fossil

iup/installall.sh : iuplib.fossil
	mkdir -p iup
	cd iup && if [ -e installall.sh ];then fossil update; else fossil open ../iuplib.fossil; fi
	cd iup && if [ -e installall.sh ];then fossil update $(IUPBRANCH); else fossil open ../iuplib.fossil;fossil update $(IUPBRANCH); fi

iup/iup/alldone : iup/installall.sh
iup/alldone : iup/installall.sh $(PREFIX)/include/iup.h $(PREFIX)/lib/libiup.so
	cd iup && ./makeall.sh

$(PREFIX)/lib/libiup.so $(PREFIX)/include/iup.h : iup/installall.sh iup/alldone
	cd iup && ./installall.sh

$(PREFIX)/lib/libiup.so : iup/iup/alldone
	touch -c $(PREFIX)/lib/libiup.so
# $(PREFIX)/lib/libiup.so : iup/iup/alldone
#	touch -c $(PREFIX)/lib/libiup.so

$(CHICKEN_EGG_DIR)/iup.so : $(PREFIX)/lib/libiup.so
	$(CHICKEN_INSTALL) $(PROX) -D no-library-checks -feature disable-iup-web iup
	LD_LIBRARY_PATH=$(LD_LIBRARY_PATH) CSC_OPTIONS=$(CSC_OPTIONS) $(CHICKEN_INSTALL) $(PROX) -D no-library-checks -feature disable-iup-web iup

$(CHICKEN_EGG_DIR)/canvas-draw.so :  $(PREFIX)/lib/libiup.so
	$(CHICKEN_INSTALL) $(PROX) -D no-library-checks canvas-draw
	CSC_OPTIONS=$(CSC_OPTIONS) $(CHICKEN_INSTALL) $(PROX) -D no-library-checks canvas-draw


clean :
	rm -rf chicken-4.8.0 eggflags ffcall sqlite-autoconf-$(SQLITE3_VERSION)

Added utils/installck.sh version [7eb094e9b0].























1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
#!/bin/bash

myhome=$(dirname $0)

if [[ $proxy == "" ]]; then 
  echo 'Please set the environment variable "proxy" to host.com:port (e.g. foo.com:1234) to use a proxy'
  echo PROX=""
else
  export http_proxy=http://$proxy
  export PROX="-proxy $proxy"
fi

if [[ -z $PREFIX ]];then
  echo "\$PREFIX variable is required"
  exit
fi

export LD_LIBRARY_NAME=$PREFIX/lib

logname=$(basename $PREFIX)

script -c "make -f $myhome/Makefile_latest.installall all" $logname.log

Modified utils/loadrunner from [3fad28f85d] to [9ef382563c].

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



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


+
+

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










-
+
+






+
+
+

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

-
+

+
+
+
#!/bin/bash 

LOADRUNNER=$0

# load=`uptime|awk '{print $10}'|cut -d, -f1`
load=`uptime|perl -pe 's/.*: (\d+.\d+),.*/$1/'`
load=$(uptime|perl -pe 's/.*: (\d+.\d+),.*/$1/')
load2=$(uptime|perl -pe 's/.*: (\d+.\d+), (\d+.\d+),.*/$2/')
# echo "load2=$load2, load=$load"

# Run a job detached from stdin/stdout (i.e. daemonized)
# Launch on remotehost if specified by TARGETHOST
#
function launchjob () {
  # Can't always trust $PWD
  CURRWD=`pwd`
  if [[ $TARGETHOST_LOGF == "" ]]; then
      TARGETHOST_LOGF=NBFAKE-`date +%GWW%V.%u_%T`
  fi
  echo "#======================================================================"
  echo "# NBFAKE Running command:"
  echo "#     \"$*\""
  echo "#======================================================================"
  
  if [[ $TARGETHOST == ""  ]]; then
    sh -c "cd $CURRWD;export DISPLAY=$DISPLAY; export PATH=$PATH; nohup $* > $TARGETHOST_LOGF 2>&1 &"
  else
    ssh -n -f $TARGETHOST "sh -c \"cd $CURRWD;export DISPLAY=$DISPLAY; export PATH=$PATH; nohup $* > $TARGETHOST_LOGF 2>&1 &\""
  fi
}

function get_delay_time () {
  RANGE=$1
  number=$RANDOM
  let "number %= $RANGE"
  echo $number
}

if which cpucheck > /dev/null;then
    numcpu=`cpucheck|tail -1|awk '{print $6}'`
elif which lscpu > /dev/null;then
    numcpu=`lscpu|grep "CPU.s.:"|awk '{print $2}'`
else
    numcpu=2
fi

# NB// max_load is in units of percent.
#
lperc=`echo "100 * $load / $numcpu"|bc`
lperc=$(echo "100 * $load / $numcpu"|bc)
lperc2=$(echo "100 * $load2 / $numcpu"|bc)
if [[ "x$MAX_ALLOWED_LOAD" == "x" ]]; then
  max_load=100
else
  max_load=$MAX_ALLOWED_LOAD
fi

lfile=/tmp/loadrunner-$USER.lockfile
lockfile -r 5 -l 60 $lfile

if [[  $lperc -lt $max_load ]];then
  if [[ $lperc -le $lperc2 ]];then
  echo "Load acceptable: lperc=$lperc %, max_load=$max_load %, load=$load, numcpu=$numcpu, MAX_ALLOWED_LOAD=$MAX_ALLOWED_LOAD %"
  echo "Starting command: \"$@\""
  nbfake "$@"
else
    echo "Load acceptable: lperc=$lperc %, max_load=$max_load %, load=$load, numcpu=$numcpu, MAX_ALLOWED_LOAD=$MAX_ALLOWED_LOAD % and $lperc2 < $lperc"
    echo "Starting command: \"$@\""
    launchjob "$@"
    # we sleep ten seconds here to keep the lock a little longer and give time for
    # the uptime to show a response
    sleep 10
  else
   echo "$LOADRUNNER $@" | at now + 2 minutes 2> /dev/null
  fi
else
  # echo "Load too high: lperc=$lperc, max_load=$max_load, waiting two minutes before trying to run command: \"$@\""
  echo "loadrunner $@" | at now + 2 minutes 2> /dev/null
  echo "$LOADRUNNER $@" | at now + 2 minutes 2> /dev/null
fi

sleep $(get_delay_time 10)
rm -f $lfile