Megatest

Changes On Branch bd1e7c8fc9b9fc27
Login

Changes In Branch v1.81 Through [bd1e7c8fc9] Excluding Merge-Ins

This is equivalent to a diff from da872f4237 to bd1e7c8fc9

2024-08-16
11:45
Patched across adjutant code into v1.8031 Leaf check-in: d861259e2f user: matt tags: v1.8031-adjutant
2024-07-15
15:12
CI/CD: Automated commit after successful test, build, and deploy for v1.81-bump-server-load check-in: 1fff14fbea user: fdiskadm tags: v1.81
09:48
Added buttontest.scm check-in: bd1e7c8fc9 user: mrwellan tags: v1.81
2024-07-11
16:12
CI/CD: Automated commit after successful test, build, and deploy for v1.81-preq-fail-details check-in: b7cfdb3706 user: fdiskadm tags: v1.81
2024-06-13
14:35
Cherrypicked 583699e19c and created branch v1.8031-dev check-in: 08b69a24b9 user: mrwellan tags: v1.81
2024-04-05
22:18
Made -import-sexpr work if runs or tests already exist. Leaf check-in: da872f4237 user: mmgraham tags: v1.8031
18:08
minor adjustments to -import-sexpr check-in: dc61281d6c user: mmgraham tags: v1.8031

Modified Makefile from [ff04dd969e] to [d32576ac8f].

22
23
24
25
26
27
28

29
30
31
32
33
34
35
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36







+








recent-commits.csv : .fslckout
	fossil timeline -n 350 -t ci -F "%h,%a,%b,%t,\"%c\"" > recent-commits.csv


SHELL=/bin/bash
PREFIX=$(PWD)
# CSCOPTS=-lfa2 -specialize -inline-global
CSCOPTS=
INSTALL=install
SRCFILES = common.scm items.scm launch.scm ods.scm runconfig.scm	\
           server.scm configf.scm db.scm keys.scm		\
           process.scm runs.scm tasks.scm tests.scm genexample.scm	\
           tdb.scm mt.scm	\
           ezsteps.scm rmt.scm api.scm		\
337
338
339
340
341
342
343



344
345
346
347
348
349
350
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354







+
+
+







	$(INSTALL) $< $@
	chmod a+x $@

$(PREFIX)/bin/mt-new-to-old.sh : utils/mt-new-to-old.sh
	$(INSTALL) $< $@
	chmod a+x $@

$(PREFIX)/bin/convert-db.sh : utils/convert-db.sh
	$(INSTALL) $< $@
	chmod a+x $@

deploytarg/nbfake : utils/nbfake
	$(INSTALL) $< $@
	chmod a+x $@

deploytarg/viewscreen : utils/viewscreen
	$(INSTALL) $< $@
383
384
385
386
387
388
389

390
391
392
393
394
395
396
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401







+







	$(INSTALL) lib/libxcb-xlib.so.0 $(PREFIX)/bin/.$(ARCHSTR)/lib/libxcb-xlib.so.0; \
        fi

install : $(PREFIX)/bin/.$(ARCHSTR) $(PREFIX)/bin/.$(ARCHSTR)/mtest $(PREFIX)/bin/megatest \
          $(PREFIX)/bin/.$(ARCHSTR)/dboard $(PREFIX)/bin/dashboard $(HELPERS) $(PREFIX)/bin/nbfake \
	  $(PREFIX)/bin/nbfind $(PREFIX)/bin/mtrunner $(PREFIX)/bin/viewscreen $(PREFIX)/bin/mt_xterm \
          $(PREFIX)/bin/mt-old-to-new.sh $(PREFIX)/bin/mt-new-to-old.sh \
          $(PREFIX)/bin/convert-db.sh $(PREFIX)/bin/convert-db.sh \
	  $(PREFIX)/share/docs/megatest_manual.html $(PREFIX)/bin/remrun \
	  $(PREFIX)/share/docs/megatest_manual.html $(PREFIX)/bin/remrun $(PREFIX)/bin/mtutil \
	  $(PREFIX)/share/db/mt-pg.sql \
          $(PREFIX)/share/js/jquery-3.1.0.slim.min.js \
          $(PREFIX)/bin/.$(ARCHSTR)/lib/libpangox-1.0.so \
          $(PREFIX)/bin/.$(ARCHSTR)/lib/libpangox-1.0.so.0 \
          $(PREFIX)/bin/.$(ARCHSTR)/lib/libxcb-xlib.so.0 $(PREFIX)/bin/serialize-env

Modified api.scm from [b08fe263c7] to [0ec121fad4].

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
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
191
192
193
194
195
196







-
-
+
+
+
+
+
+
+
+













+
+
+
+
+
+
+
+
+







    tasks-set-state-given-param-key
    ))

(define *db-write-mutexes* (make-hash-table))
(define *server-signature* #f)

(define *api-threads* '())
(define (api:register-thread th-in)
  (set! *api-threads* (cons (cons th-in (current-seconds)) *api-threads*)))
(define (api:register-thread th-in command)
  (set! *api-threads* (cons (list th-in (current-seconds) command) *api-threads*)))

(define (api:get-thread-command th-in)
  (let ((thread-data (assoc th-in *api-threads*)))
    (if thread-data
        (third thread-data) ; Assuming the command is the third element in the list
        #f))) ; Return #f if the thread is not found

(define (api:unregister-thread th-in)
  (set! *api-threads* (filter (lambda (thdat)
				(not (eq? th-in (car thdat))))
			      *api-threads*)))

(define (api:remove-dead-or-terminated)
  (set! *api-threads* (filter (lambda (thdat)
				(not (member (thread-state (car thdat)) '(terminated dead))))
			      *api-threads*)))

(define (api:get-count-threads-alive)
  (length *api-threads*))

(define (api:get-threads)
  (map (lambda (thdat)
         (let ((thread (first thdat))
               (timestamp (second thdat))
               (command (third thdat)))
           (format "\nThread: ~a, age: ~a, Command: ~a" thread (- (current-seconds) timestamp) command)))
       *api-threads*))


(define *api:last-stats-print* 0)
(define *api-print-db-stats-mutex* (make-mutex))
(define (api:print-db-stats)
  (debug:print-info 0 *default-log-port* "Started periodic db stats printer")
  (let loop ()
    (mutex-lock! *api-print-db-stats-mutex*)
194
195
196
197
198
199
200
201

202
203
204
205
206
207
208
209
210
211
212
213
214
215

216
217
218
219
220
221
222
223







-
+







;;          reads/writes to current in/out port
;;
(define (api:tcp-dispatch-request-make-handler dbstruct) ;; cmd run-id params)
  (assert *toppath* "FATAL: api:tcp-dispatch-request-make-handler called but *toppath* not set.")
  (if (not *server-signature*)
      (set! *server-signature* (tt:mk-signature *toppath*)))
  (lambda (indat)
    (api:register-thread (current-thread))
    (api:register-thread (current-thread) (car indat))
    (let* ((result 
	    (let* ((numthreads (api:get-count-threads-alive))
		   (delay-wait (if (> numthreads 10)
				   (- numthreads 10)
				   0))
		   (normal-proc (lambda (cmd run-id params)
				  (case cmd
226
227
228
229
230
231
232
233
234
235
236











237
238
239

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

257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
241
242
243
244
245
246
247




248
249
250
251
252
253
254
255
256
257
258
259
260

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

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


291
292
293
294
295
296
297







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


-
+
















-
+












-
-







					 ((ping) #t) ;; we are fine
					 (else
					  (assert ok "FATAL: database file and run-id not aligned.")))))
			     (ttdat   *server-info*)
			     (server-state (tt-state ttdat))
			     (maxthreads   20) ;; make this a parameter?
			     (status  (cond
				       ((and (> numthreads maxthreads)
					     (> (random 100) 70)) ;; allow a 30% probability to go through so we can figure out what is going wrong in main.db server.
					'busy)
				       ;; ((> numthreads 5) 'loaded) ;; this gets transmitted to the client which calls tt:backoff-incr to slow stuff down.
                                       ((> numthreads maxthreads)
					(let* ((testsuite (common:get-testsuite-name))
					       (mtexe     (common:find-local-megatest))
					       (proc      (lambda ()
							    ;; we are overloaded, try to start another server
							    (debug:print 0 *default-log-port* "Too many threads running, starting another server")
							    (tt:server-process-run *toppath* testsuite mtexe run-id))))
					  (set! *server-start-requests* (cons proc *server-start-requests*)))
					;; 'busy
					'loaded ;; not ideal since the client will not backoff
					)
				       (else 'ok)))
			     (errmsg  (case status
					((busy)   (conc "Server overloaded, "numthreads" threads in flight"))
					((busy)   (conc "Server overloaded, "numthreads" threads in flight, current cmd: " cmd "\n current threads: " (api:get-threads)))
					((loaded) (conc "Server loaded, "numthreads" threads in flight"))
					(else     #f)))
			     (result  (case status
					((busy)
					 (if (eq? cmd 'ping)
					     (normal-proc cmd run-id params)
					     ;; numthreads must be greater than 5 for busy
					     (* 0.1 (- numthreads maxthreads)) ;; was 15
					     )) ;; (- numthreads 29)) ;; call back in as many seconds
					((loaded)
					 ;; 			    (if (eq? (rmt:transport-mode) 'tcp)
					 ;; 				(thread-sleep! 0.5))
					 (normal-proc cmd run-id params))
					(else
					 (normal-proc cmd run-id params))))
			     (meta   (case cmd
				       ((ping) `((sstate . ,server-state)))
				       ((ping) `((sstate . ,server-state)(sload . ,numthreads)))
				       (else   `((wait . ,delay-wait)))))
			     (payload (list status errmsg result meta)))
			;; (cmd run-id params meta)
			(db:add-stats cmd run-id params (- (current-milliseconds) start-t))
			payload))
		     (else
		      (assert #f "FATAL: failed to deserialize indat "indat))))))
      ;; (set! *api-process-request-count* (- *api-process-request-count* 1))
      ;; (serialize payload)
     
      (api:unregister-thread (current-thread))
      result)))



(define *api-halt-writes* #f)

(define (api:dispatch-request dbstruct cmd run-id params)
  (if (not *no-sync-db*)
      (db:open-no-sync-db))
  (let* ((start-time (current-milliseconds)))

Modified common.scm from [5744dec10a] to [dd0c23fb98].

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







-
+
+
+
+

-












+







(use posix-extras pathname-expand files)


(import commonmod
	debugprint
	rmtmod
	(prefix mtargs args:))

	
(define (remove-server-files directory-path)
  (let ((files (glob (string-append directory-path "/server*"))))
    (for-each delete-file* files)))
(include "common_records.scm")

(define (remove-files filespec)
  (let ((files (glob filespec)))
    (for-each delete-file* files)))

(define (stop-the-train)
  (thread-start! (make-thread (lambda ()
				(let loop ()
				  (if (and *toppath*
					   (file-exists? (conc *toppath*"/stop-the-train")))
				      (let* ((msg (conc "ERROR: found file "*toppath*"/stop-the-train, exiting immediately")))
					;; yes, print to current-output-port AND *default-log-port*, annoying but necessary I think
					(print msg)
                                        (remove-server-files (conc *toppath* "/logs"))
					(debug:print 0 *default-log-port* msg)
                                        (remove-files (conc *toppath* "/logs/server*"))
                                        (remove-files (conc *toppath* "/.servinfo/*"))
                                        (remove-files (conc *toppath* "/.mtdb/*lock"))
					(exit 1)))
				  (thread-sleep! 5)
				  (loop))))))
395
396
397
398
399
400
401
402
403




404
405
406
407


408
409
410


411
412
413
414
415
416
417
418
419
398
399
400
401
402
403
404


405
406
407
408
409



410
411



412
413


414
415
416
417
418
419
420







-
-
+
+
+
+

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







  (- megatest-version (common:get-last-run-version-number)))

(define (common:version-changed?)
  (not (equal? (common:get-last-run-version)
               (common:version-signature))))


;; From 1.70 to 1.80, db's are compatible.

;; From 1.70 to 1.81, db's are compatible.
;;
;; BUG: This logic is almost certainly not quite correct.
;;
(define (common:api-changed?)
  (let* (
    (megatest-major-version (substring (->string megatest-version) 0 4))
    (run-major-version (substring (conc (common:get-last-run-version)) 0 4))
  (let* ((megatest-major-version (substring (->string megatest-version) 0 4))
	 (run-major-version (substring (conc (common:get-last-run-version)) 0 4)))
   )
   (and (not (equal? megatest-major-version "1.80"))
     (not (equal? megatest-major-version megatest-run-version)))
    (and (not (member megatest-major-version '("1.81" "1.80")))
	 (not (equal? megatest-major-version run-major-version)))))
  )
)

;;======================================================================
;; Move me elsewhere ...
;; RADT => Why do we meed the version check here, this is called only if version misma
;;
(define (common:cleanup-db dbstruct #!key (full #f))
  (case (rmt:transport-mode)

Modified dashboard-tests.scm from [ceec46e3cb] to [9ace3eb7d8].

93
94
95
96
97
98
99
100


101
102
103
104
105
106
107
93
94
95
96
97
98
99

100
101
102
103
104
105
106
107
108







-
+
+







			(list "Testname: "
			      "Item path: "
			      "Current state: "
			      "Current status: "
			      "Test comment: "
			      "Test id: "
			      "Test date: "))
		   (list (iup:label "" #:expand "VERTICAL"))))
		   (list (iup:label "" #:expand "VERTICAL"
				    ))))
    (apply iup:vbox  ; #:expand "YES"
	   (list 
	    (store-label "testname"
			 (iup:label (db:test-get-testname  testdat) #:expand "HORIZONTAL")
			 (lambda (testdat)(db:test-get-testname testdat)))
	    (store-label "item-path"
			 (iup:label (db:test-get-item-path testdat) #:expand "HORIZONTAL")
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
191
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
191
192
193
194







-
+
+















-
+
+







			  (iup:label val ; #:expand "HORIZONTAL"
				     ))
			(list "Author: "
			      "Owner: "
			      "Reviewed: "
			      "Tags: "
			      "Description: "))
		   (list (iup:label "" #:expand "VERTICAL"))))
		   (list (iup:label "" #:expand "VERTICAL"
				    ))))
    (apply iup:vbox  ; #:expand "YES"
	   (list 
	    (store-meta "author"
			 (iup:label (db:testmeta-get-author testmeta) #:expand "HORIZONTAL")
			 (lambda (testmeta)(db:testmeta-get-author testmeta)))
	    (store-meta "owner"
			 (iup:label (db:testmeta-get-owner testmeta) #:expand "HORIZONTAL")
			 (lambda (testmeta)(db:testmeta-get-owner testmeta)))
	    (store-meta "reviewed" 
			 (iup:label (db:testmeta-get-reviewed testmeta) #:expand "HORIZONTAL")
			 (lambda (testmeta)(db:testmeta-get-reviewed testmeta)))
	    (store-meta "tags" 
			 (iup:label (db:testmeta-get-tags testmeta) #:expand "HORIZONTAL")
			 (lambda (testmeta)(db:testmeta-get-tags testmeta)))
	    (store-meta "description" 
			 (iup:label (test-meta-panel-get-description testmeta) #:size "x50"); #:expand "HORIZONTAL")
			(iup:label (test-meta-panel-get-description testmeta) ;; #:wordwrap "YES" ;; #:size "x50"
				   ) ;; #:expand "HORIZONTAL")
			 (lambda (testmeta)
			   (test-meta-panel-get-description testmeta)))
	    )))))


;;======================================================================
;; Run info panel
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
242
243
244
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
242
243
244

245
246
247
248
249
250
251
252
253







+
-
+
+
+
+




-
+
+



















-
+
+







			    (iup:label (conc (car keyval) " ")))
			  keydat)
		     (list (iup:label "runname ")
			   (iup:label "run-id")
			   (iup:label "run-date"))))
      (apply iup:vbox
	     (append (map (lambda (keyval)
			    (iup:vbox
			    (iup:label (cadr keyval) #:expand "HORIZONTAL"))
			     (iup:label (cadr keyval) #:expand "HORIZONTAL")
			     ;; (iup:label "" #:expand "BOTH")
			     )
			    )
			  keydat)
		     (list (iup:label runname)
			   (iup:label (conc run-id))
			   (iup:label (seconds->year-work-week/day-time event_time))
			   (iup:label "" #:expand "VERTICAL"))))))))
			   (iup:label "" ;;#:expand "VERTICAL"
				      ))))))))
  
;;======================================================================
;; Host info panel
;;======================================================================
(define (host-info-panel testdat store-label)
  (iup:frame
   #:title "Remote host and Test Run Info" ; #:expand "YES"
   (iup:hbox ; #:expand "YES"
    (apply iup:vbox ; #:expand "YES" ;; The heading labels
	   (append (map (lambda (val)
			  (iup:label val ; #:expand "HORIZONTAL"
				     ))
			(list "Hostname: "
			      "Disk free: "
			      "CPU Load: "
			      "Run duration: "
			      "Logfile: "
			      "Top process id: "
			      "Uname -a: "))
		   (iup:label "" #:expand "VERTICAL")))
		   (iup:label "" ;; #:expand "VERTICAL"
			      )))
    (apply iup:vbox ; #:expand "YES"
	   (list
	    ;; NOTE: Yes, the host can change!
	    (store-label "HostName"
			 (iup:label ;; (sdb:qry 'getstr 
			  (db:test-get-host testdat) ;; )
			  #:expand "HORIZONTAL")
266
267
268
269
270
271
272
273
274
275



276
277
278
279
280




281
282
283
284
285
286
287
275
276
277
278
279
280
281



282
283
284
285
286
287


288
289
290
291
292
293
294
295
296
297
298







-
-
-
+
+
+



-
-
+
+
+
+








;; if there is a submegatest create a button to launch dashboard in that area
;;
(define (submegatest-panel dbstruct keydat testdat runname testconfig)
  (let* ((test-run-dir      (db:test-get-rundir testdat))
	 (subarea           (subrun:get-runarea test-run-dir))
	 (area-exists       (and subarea (common:file-exists? subarea silent: #t))))
    (if subarea
	(iup:frame 
	 #:title "Megatest Run Info" ; #:expand "YES"
    (iup:frame 
     #:title "Megatest Run Info" ;; #:expand "HORIZONTAL"
     (if subarea
	 (iup:button
	  "Launch Dashboard"
	  #:action (lambda (obj)
                     (subrun:launch-dashboard test-run-dir))))
	(iup:vbox))))
                     (subrun:launch-dashboard test-run-dir)))
	 (iup:vbox
	  (iup:label "Not a subrun..." #:expand "HORIZONTAL")
	  )))))

;; use a global for setting the buttons colors
;;                           state status teststeps
(define *state-status* (vector #f #f #f))
(define (update-state-status-buttons testdat)
  (let* ((state  (db:test-get-state  testdat))
	 (status (db:test-get-status testdat))
669
670
671
672
673
674
675









676
677
678
679
680
681
682
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702







+
+
+
+
+
+
+
+
+







			    (iup:attribute-set! 
			     command-text-box "VALUE"
			     (conc "megatest -target " keystring " -runname " runname 
				   " -run -testpatt " (conc testname "/" (if (equal? item-path "")
									"%" 
									item-path))
				   " -clean-cache"
				   ))))
	       (rerun-clean  (lambda (x)
			    (iup:attribute-set! 
			     command-text-box "VALUE"
			     (conc "megatest -target " keystring " -runname " runname 
				   " -rerun-clean -testpatt " (conc testname "/" (if (equal? item-path "")
									"%" 
									item-path))
				   " -clean-cache"
				   ))))
	       (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 "")
									  "%"
717
718
719
720
721
722
723


724
725
726
727
728
729
730
731
732









733
734

735
736
737
738
739
740













741
742
743
744








745
746
747
748
749
750
751
737
738
739
740
741
742
743
744
745









746
747
748
749
750
751
752
753
754
755

756
757





758
759
760
761
762
763
764
765
766
767
768
769
770




771
772
773
774
775
776
777
778
779
780
781
782
783
784
785







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

-
+

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







	   ((not testdat)(begin (debug:print 0 *default-log-port* "ERROR: bad test info for " test-id)(exit 1)))
	   ((not rundat)(begin (debug:print 0 *default-log-port* "ERROR: found test info but there is a problem with the run info for " run-id)(exit 1)))
	   (else
	    ;;  (test-set-status! db run-id test-name state status itemdat)
	    (set! self ; 
		  (iup:dialog #:close_cb (lambda (a)(exit)) ; #:expand "YES"
			      #:title testfullname
			      (iup:vbox
			       (iup:hbox
			      (iup:vbox ; #:expand "YES"
			       ;; The run and test info
			       (iup:hbox  ; #:expand "YES"
				(run-info-panel dbstruct keydat testdat runname)
				(test-info-panel testdat store-label widgets)
				(test-meta-panel testmeta store-meta))
			       (iup:hbox
				(host-info-panel testdat store-label)
				(submegatest-panel dbstruct keydat testdat runname testconfig))
				(iup:vbox ; #:expand "YES"
				 ;; The run and test info
				 (iup:hbox  ; #:expand "YES"
				  (run-info-panel dbstruct keydat testdat runname)
				  (test-info-panel testdat store-label widgets))
				 (host-info-panel testdat store-label))
				(iup:vbox
				 (test-meta-panel testmeta store-meta)
				 (submegatest-panel dbstruct keydat testdat runname testconfig)))
			       ;; The controls
			       (iup:frame #:title "Actions" 
			       (iup:hbox ;; frame #:title "Actions" 
					  (iup:vbox
					   (iup:hbox 
					    (iup:button "View Log"      #:action viewlog      #:size "80x")
					    (iup:button "Start Xterm"   #:action xterm        #:size "80x")
					    (iup:button "Run Test"      #:action run-test     #:size "80x")
					    (iup:button "Clean Test"    #:action remove-test  #:size "80x")
					   (iup:hbox
					    (iup:frame
					     #:title "Immediate"
					     (iup:hbox
					      (iup:button "Start Xterm"   #:action xterm        #:size "80x")
					      (iup:button "CleanRunExecute!"    #:action clean-run-execute #:size "80x")
					      (iup:button "View Log"      #:action viewlog      #:size "80x")))
					    (iup:frame
					     #:title "Command line"
					     (iup:hbox
					      (iup:button "Run Test"      #:action run-test     #:size "80x")
					      (iup:button "Rerun-clean"   #:action rerun-clean  #:size "80x")
					      (iup:button "Clean Test"    #:action remove-test  #:size "80x")
					    (iup:button "CleanRunExecute!"    #:action clean-run-execute #:size "80x")
					    (iup:button "Kill All Jobs" #:action kill-jobs    #:size "80x")
					    (iup:button "Archive Test"  #:action archive-test #:size "80x")
					    (iup:button "Close"         #:action (lambda (x)(exit)) #:size "80x"))
					      (iup:button "Kill All Jobs" #:action kill-jobs    #:size "80x")))
					    (iup:label "" #:expand "HORIZONTAL")
					    (iup:frame
					     #:title "Other"
					     (iup:hbox
					      ;; (iup:button "Archive Test"  #:action archive-test #:size "80x")
					      (iup:button "Close"         #:action (lambda (x)(exit)) #:size "80x")
					      )))
					   (apply 
					    iup:hbox
					    (list command-text-box command-launch-button))))
			       (set-fields-panel dbstruct run-id test-id testdat)
			       (let ((tabs 
				      (iup:tabs
				       ;; Replace here with matrix

Modified dashboard.scm from [e5b27b795a] to [89bc431aeb].

166
167
168
169
170
171
172


173
174
175
176
177
178
179
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181







+
+







;;    please-update:        #t
;;    update-mutex:         (make-mutex)
;;    updaters:             (make-hash-table)
;;    updating:             #f
;;    hide-not-hide-tabs:   #f
;;    target:               ""
;;    ))

(set! *journal-stats-enable* #f)

;;======================================================================
;; buttons color using image
;;======================================================================

(define *images* (make-hash-table))

Modified docs/Makefile from [c01320f2b0] to [fc2e46e5a1].

31
32
33
34
35
36
37



31
32
33
34
35
36
37
38
39
40







+
+
+
	fossil add html/*

megatest.pdf : megatest.lyx
	lyx -e pdf2 megatest.lyx

pkts.pdf : pkts.dot
	dot -Tpdf pkts.dot -o pkts.pdf

stepwise.pdf : stepwise-rpc-via-direct-and-tcp-or-http.dot
	dot stepwise-rpc-via-direct-and-tcp-or-http.dot -Tpdf -o stepwise.pdf

Added docs/csirc version [ab27eade5c].


































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
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
(cond-expand
 (chicken-4
  ;; chicken 4 stuff here
  (use readline)
  (current-input-port (make-readline-port))
  (install-history-file #f "/.csi.history")
  )
 (chicken-5
  (import (chicken load))
  (import (chicken format))
  (import (chicken process-context))
  (import (chicken process signal))
  (load-verbose #f)
  (let ()
    (unless (get-environment-variable "INSIDE_EMACS")
      (import breadline)
      (import breadline-scheme-completion)
      (history-file (format "~a/.csi_history" (get-environment-variable "HOME")))
      (stifle-history! 10000)
      (completer-word-break-characters-set! "\"\'`;|(")
      (completer-set! scheme-completer)
      (basic-quote-characters-set! "\"|")
      (variable-bind! "blink-matching-paren" "on")
      (paren-blink-timeout-set! 200000)
      (let ((handler (signal-handler signal/int)))
	(set-signal-handler! signal/int
			     (lambda (s)
			       (cleanup-after-signal!)
			       (reset-after-signal!)
			       (handler s))))
      (on-exit reset-terminal!)
      (current-input-port (make-readline-port))))
  ))

Added docs/stepwise-rpc-via-direct-and-tcp-or-http.dot version [a96a45b2ca].



































































































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
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
//  Copyright 2006-2017, Matthew Welland.
// 
// This file is part of Megatest.
// 
//     Megatest is free software: you can redistribute it and/or modify
//     it under the terms of the GNU General Public License as published by
//     the Free Software Foundation, either version 3 of the License, or
//     (at your option) any later version.
// 
//     Megatest is distributed in the hope that it will be useful,
//     but WITHOUT ANY WARRANTY; without even the implied warranty of
//     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
//     GNU General Public License for more details.
// 
//     You should have received a copy of the GNU General Public License
//     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.
//

digraph megatest_state_status {
  ranksep=0.05;
  // rankdir=LR
    
  node [shape=box,style=filled];
  
  "START" -> "have_server";
  "DONE" [label="ALL DONE"];
  "send_request" -> "receive_response";
  "receive_response" -> "DONE";
  "have_server" -> "start_http_server" [label="no"];
  
  subgraph cluster_start_server {
    label="Start Server";
    "start_http_server" -> "create_servinfo_file";
    "start_http_server" -> "enable_direct_mode";
    "create_servinfo_file" -> "delay_60_sec";
    "delay_60_sec" -> "set_up_tmp_cache";
    "set_up_tmp_cache" -> "switch_mode_to_tmp";
  }
  
  subgraph cluster_direct_access {
    label="Direct Access";
   
    "direct_access" -> "touch_access_file";
    "touch_access_file" -> "touch_host_pid_file";
    "touch_host_pid_file" -> "count_host_pid_files";
    "count_host_pid_files" -> "call_query_proc" [label="count < 5"];
    "wait_for_low_count_host_pid_files" [label="sleep 1"];
    "count_host_pid_files" -> "wait_for_low_count_host_pid_files"[label="count >= 5"];
    "wait_for_low_count_host_pid_files" -> "count_host_pid_files";
    "call_query_proc" -> "DONE";
  }

  "have_server" -> "ping_server" [label="yes"];
  "have_server" -> "direct_access" [label="no" ];
  "ping_server" -> "send_request" [label="server alive"];
  "ping_server" -> "remove_server_file" [label="server not alive"];
  "remove_server_file" -> "START";


}
// subgraph cluster_notstarted {
//   label="Not started";

//   "NOT_STARTED FAILS" [
//   label = "{ NOT_STARTED/FAILS |{ NO_ITEMS |<here> FAIL_PREREQ |<here> FAIL_TIMEOUT }}";
//   shape= "record";
//   ]
// 
// "NOT_STARTED n/a" -> "LAUNCHED n/a" [label=" launch"];
// "NOT_STARTED WAIT" -> "LAUNCHED n/a"
// 
//   "NOT_STARTED n/a";
//   "NOT_STARTED WAIT" [
//   label = "{NOT_STARTED WAIT|{ NO_SLOTS | <here> WAIT_PREREQ}}";
//   shape = "record";
// ]
// 
// // struct3 [shape=record,label="hello\nworld |{ b |{c|<here> d|e}| f}| g | h"];
// 
//   "NOT_STARTED n/a" -> "NOT_STARTED FAILS";
//   "NOT_STARTED n/a" -> "NOT_STARTED WAIT";
// 
//   "RUNNING" [
//      shape="record";
//      label="{RUNNING|{n/a|<here> PASS |<here> FAIL}}";
//   ]
// 
//   "COMPLETED" [
//       shape="record";
//       label = "{COMPLETED|{PASS | SKIP | WAIVED | FAIL | CHECK| ABORT}}";
//   ]
// 
// 
// "RUNNING" -> "COMPLETED";
// "RUNNING" -> "INCOMPLETE" [label="test dead for > 24hrs"];
// 
// 
// "LAUNCHED n/a" -> "REMOTEHOSTSTART n/a" -> "RUNNING";

Modified launch.scm from [98ad71ee6e] to [053403603a].

378
379
380
381
382
383
384













































385
386
387
388
389
390
391
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436







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







		 (lambda ()
		   (print content)
		   ;; (change-file-mode name (bitwise-ior perm/irwxg perm/irwxu))
		   )))
	      (else
	       (debug:print-info 0 "Invalid logpro definiton found in [logpro] section of testconfig. \"" logprodat "\""))))
     logpros)))

;; read testconfig and create .logpro and script files
;;    - use #f for tconfigreg to re-read the testconfigs from disk
;;
(define (launch:extract-scripts-logpro  test-dir test-name item-path tconfigreg-in)
  (let* ((tconfigreg      (or tconfigreg-in
			      (tests:get-all)))
	 (tconfig-fname   (conc test-dir "/.testconfig"))
	 (tconfig-tmpfile (conc tconfig-fname ".tmp"))
	 (tconfig         (tests:get-testconfig test-name item-path tconfigreg #t force-create: #t)) ;; 'return-procs)))
	 (scripts         (configf:get-section tconfig "scripts"))
	 (logpros         (configf:get-section tconfig "logpro")))
    ;; create .testconfig file
    (configf:write-alist tconfig tconfig-tmpfile)
    (file-move tconfig-tmpfile tconfig-fname #t)
    (delete-file* ".final-status")
    
    ;; extract scripts from testconfig and write them to files in test run dir
    (for-each
     (lambda (scriptdat)
       (match scriptdat
	      ((name content)
	       (debug:print-info 2 *default-log-port* "Creating script "(current-directory)"/"name)
	       (with-output-to-file name
		 (lambda ()
		   (print content)))
	       (change-file-mode name (bitwise-ior perm/irwxg perm/irwxu)))
	      (else
	       (debug:print-info 0 "Invalid script definiton found in [scripts] section of testconfig. \"" scriptdat "\""))))
     scripts)

    ;; extract logpro from testconfig and write them to files in test run dir
    (for-each
     (lambda (logprodat)
       (match logprodat
	      ((name content)
	       (debug:print-info 2 *default-log-port* "Creating logpro file "(current-directory)"/"name)
	       (with-output-to-file name
		 (lambda ()
		   (print content)
		   ;; (change-file-mode name (bitwise-ior perm/irwxg perm/irwxu))
		   )))
	      (else
	       (debug:print-info 0 "Invalid logpro definiton found in [logpro] section of testconfig. \"" logprodat "\""))))
     logpros)))

(define (launch:execute encoded-cmd)
  (let* ((cmdinfo    (common:read-encoded-string encoded-cmd))
	 (tconfigreg #f))
    (setenv "MT_CMDINFO" encoded-cmd)
    ;;(bb-check-path msg: "launch:execute incoming")
    (if (list? cmdinfo) ;; ((testpath /tmp/mrwellan/jazzmind/src/example_run/tests/sqlitespeed)
731
732
733
734
735
736
737
738


739
740
741
742


743

744
745
746
747
748
749
750
776
777
778
779
780
781
782

783
784
785
786
787
788
789
790

791
792
793
794
795
796
797
798







-
+
+




+
+
-
+







		 (monitorjob   (lambda ()
				 (launch:monitor-job  run-id test-id item-path fullrunscript ezsteps test-name tconfigreg exit-info m work-area runtlim misc-flags)))
		 (th1          (make-thread monitorjob "monitor job"))
		 (th2          (make-thread runit "run job"))
                 (tconfig         (tests:get-testconfig test-name item-path tconfigreg #t))
                 (propagate-exit-code (configf:lookup *configdat* "setup" "propagate-exit-code"))
                 (propagate-status-list '("FAIL" "KILLED" "ABORT" "DEAD" "CHECK" "SKIP" "WAIVED"))
                 (test-status "not set")
                 (test-status     "not set")
		 (test-state      "not set")
		 (precmd          (configf:lookup tconfig "setup" "precmd"))
		 (postcmd         (configf:lookup tconfig "setup" "postcmd")))
	    ;; first, if set, run the precmd
	    (if precmd ;; (file-exists? precmd)(file-execute-access? precmd))
		(begin
		  ;; (save-environment-as-files "precmd-envt")
		(system precmd)) ;; up to test author to put nbfake if desired.
		  (system precmd))) ;; up to test author to put nbfake if desired.
	    (set! job-thread th2)
	    (thread-start! th1)
	    (thread-start! th2)
	    (thread-join! th2)
	    (debug:print-info 0 *default-log-port* "Megatest execute of test " test-name ", item path " item-path " complete. Notifying the db ...")
            (debug:print-info 2 *default-log-port* "exit-info = " exit-info)
	    (hash-table-set! misc-flags 'keep-going #f)
799
800
801
802
803
804
805
806
807



808
809
810
811
812
813
814
815
816
817
818
819
820






821
822
823
824
825
826
827
847
848
849
850
851
852
853


854
855
856
857
858
859


860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880







-
-
+
+
+



-
-








+
+
+
+
+
+







	      (rmt:update-run-stats run-id (rmt:get-raw-run-stats run-id))) ;; end of let*

	    (mutex-unlock! m)
            (launch:end-of-run-check run-id )
	    (debug:print 2 *default-log-port* "Output from running " fullrunscript ", pid " (launch:einf-pid exit-info) " in work area " 
			 work-area ":\n====\n exit code " (launch:einf-exit-code exit-info) "\n" "====\n")


            (set! test-status (db:test-get-status (rmt:get-testinfo-state-status run-id test-id)))
	    (let* ((testrec  (rmt:get-testinfo-state-status run-id test-id)))
              (set! test-status (db:test-get-status testrec))
	      (set! test-state  (db:test-get-state  testrec)))

            ;; If the propagate-exit-code option has been set in the megatest config, and the test status matches the list, set the exit code to 1.

	    (if postcmd
		(system postcmd))

            (if (and propagate-exit-code (string=? propagate-exit-code "yes") (member test-status propagate-status-list))
               (begin
                (debug:print 1 *default-log-port* "Setting exit status to 1 because of test status of " test-status) 
                (set! *globalexitstatus* 1)
               )
            )

	    (if postcmd
		(begin
		  (setenv "MT_TEST_STATE" test-state)
		  (setenv "MT_TEST_STATUS" test-status)
		  ;; (save-environment-as-files "postcmd-envt")
		  (system postcmd)))
	    (if (not (launch:einf-exit-status exit-info))
		(exit 4))))
        )))

;; Spec for End of test
;; At end of each test call, after marking self as COMPLETED do run-state-status-rollup
;; At transition to run COMPLETED/X do hooks

Added matt/buttontest.scm version [4c1acbf3a4].






















































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
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
(use iup srfi-4)

(module buttontest
	*

(import iup)

(import scheme
	srfi-4
	(prefix iup iup:))

(define (make-image name tcolor bgcolor)
  (let* ((img-bits1 (u8vector->blob (u8vector
				     1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 
				     1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
				     1 1 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 1 1
				     1 1 2 3 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 1 1
				     1 1 2 2 3 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 1 1
				     1 1 2 2 2 3 2 2 2 2 2 2 2 2 2 2 2 2 2 2 1 1
				     1 1 2 2 2 3 3 2 2 2 2 2 2 2 2 2 2 2 2 2 1 1
				     1 1 2 2 2 3 2 2 2 2 2 2 2 2 2 2 2 2 2 2 1 1
				     1 1 2 2 3 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 1 1
				     1 1 2 3 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 1 1
				     1 1 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 1 1
				     1 1 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 1 1
				     1 1 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 1 1
				     1 1 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 1 1
				     1 1 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 1 1
				     1 1 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 1 1
				     1 1 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 1 1
				     1 1 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 1 1
				     1 1 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 1 1
				     1 1 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 1 1
				     1 1 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 1 1
				     1 1 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 1 1
				     1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
				     1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
				     )))
	 ;;                        w  h
	 (img1 (iup:image/palette 22 24 img-bits1)))
    (iup:handle-name-set! img1 name)
    (iup:attribute-set! img1 "1" "10 10 10")
    (iup:attribute-set! img1 "2" bgcolor) ;; "BGCOLOR")
    (iup:attribute-set! img1 "3" tcolor)
    name))

(iup:show
 (iup:dialog
  (iup:vbox
   (iup:button " " image: (make-image "GreenBlack" "0 255 0" "0 0 0")))))

(iup:main-loop)
)

Modified megatest-version.scm from [1bbcf7f9b0] to [29093264c9].

16
17
18
19
20
21
22
23

16
17
18
19
20
21
22

23







-
+
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.

;; Always use two or four digit decimal
;; 1.01, 1.02...1.10,1.11,1.1101 ... 1.99,2.00..

;; (declare (unit megatest-version))

(define megatest-version 1.8031)
(define megatest-version 1.8101)

Modified megatest.scm from [8ff2c8d3e0] to [458fe118db].

111
112
113
114
115
116
117


118

119
120
121
122
123
124
125
111
112
113
114
115
116
117
118
119

120
121
122
123
124
125
126
127







+
+
-
+








;; load the ~/.megatestrc file, put (use trace)(trace-call-sites #t)(trace function-you-want-to-trace) in this file
;;
(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.megatestrc")))
  (if (common:file-exists? debugcontrolf)
    (begin
      ;; for some reason, debug:print does not work here. Had to use print.
      (with-output-to-port (current-error-port)
	(lambda ()
      (print (conc "WARNING: loading " debugcontrolf))
	  (print (conc "WARNING: loading " debugcontrolf))))
      (load debugcontrolf)
    )
  )
)

;; usage logging, careful with this, it is not designed to deal with all real world challenges!
;;
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
263
264
265
266
267
268
269

270
271
272
273
274
275
276







-







  -mark-incompletes       : find and mark incomplete tests
  -ping run-id|host:port  : ping server, exit with 0 if found
  -debug N|N,M,O...       : enable debug 0-N or N and M and O ...
  -debug-noprop N|M,M,O...: enable debug but do not propagate to subprocesses via MT_DEBUG
  -config fname           : override the megatest.config file with fname
  -append-config fname    : append fname to the megatest.config file
  -import-sexpr fname     : import a sexpr file (use -list-runs % -dumpmode sexpr to create)
  -remove-dbs all         : remove Megatest DBs before importing sexpr. (Use only with -import-sexpr)
  -regen-testfiles        : regenerate scripts and logpro files from testconfig, run in test context
  
Utilities
  -env2file fname         : write the environment to fname.csh and fname.sh
  -envcap a               : save current variables labeled as context 'a' in file envdat.db
  -envdelta a-b           : output enviroment delta from context a to context b to -o fname
                            set the output mode with -dumpmode csh, bash or ini
2128
2129
2130
2131
2132
2133
2134















2135
2136
2137
2138
2139
2140
2141
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157







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







	   (let* ((db       #f)
		  ;; DO NOT run remote
		  (paths    (tests:test-get-paths-matching keys target (args:get-arg "-test-files"))))
	     (for-each (lambda (path)
			 (print path))
		       paths))))))

;;======================================================================
;; Utils for test areas
;;======================================================================

(if (args:get-arg "-regen-testfiles")
    (if (getenv "MT_TEST_RUN_DIR")
	(begin
	  (launch:setup)
	  (change-directory (getenv "MT_TEST_RUN_DIR"))
	  (let* ((testname (getenv "MT_TEST_NAME"))
		 (itempath (getenv "MT_ITEMPATH")))
	    (launch:extract-scripts-logpro (getenv "MT_TEST_RUN_DIR") testname itempath #f))
	  (set! *didsomething* #t))
	(debug:print 0 *default-log-port* "ERROR: Must run -regen-testfiles in a test environment (i.e. test xterm from dashboard)")))
		 	  
;;======================================================================
;; Utils for test areas
;;======================================================================

(if (args:get-arg "-regen-testfiles")
    (if (getenv "MT_TEST_RUN_DIR")
	(begin

Modified portlogger.scm from [f5c418f411] to [36890e0c14].

13
14
15
16
17
18
19

20
21
22
23
24
25
26
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27







+







;;     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;     GNU General Public License for more details.
;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.
;;

(require-extension (srfi 18) extras tcp s11n)

(declare (unit portlogger))
(declare (uses debugprint))
(declare (uses dbmod))

(module portlogger
*

Modified rmt.scm from [1cc680357a] to [0cdd3c737a].

90
91
92
93
94
95
96
97















98
99
100
101
102
103
104
105
106
107
108
109
110
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







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





-







;; NB// area-dat replaced by ttdat
;; 
(define (rmt:send-receive cmd run-id params #!key (attemptnum 1)(ttdat #f))
  (assert (or (not run-id) (number? run-id)) "FATAL: run-id is required to be a number or #f")
  (assert *toppath* "FATAL: rmt:send-receive called with *toppath* not set.")
  (let* ((areapath      *toppath*) ;; TODO - resolve from dbstruct to be compatible with multiple areas
	 (readonly-mode (rmtmod:calc-ro-mode ttdat *toppath*))
	 (testsuite     (common:get-testsuite-name)))
	 (testsuite     (common:get-testsuite-name))
	 (dbfname       (conc (dbfile:run-id->dbnum run-id)".db"))
	 (dbdir         (conc areapath "/.mtdb")))
    (if (and (not *journal-stats*)
	     (file-exists? dbdir))
	(tt:start-stats dbdir)) ;; fixme - find the right call to get the db directory
    
    ;; check the load on dbfname and add some delay using a droop curve of sorts
    (if *journal-stats*
	(let* ((load  (tt:get-journal-stats dbfname)))
	  (if (> load 0.1) ;; start activating delay at 10% journal load time
	      (let ((dely (* 50 (* load load)))) ;; 100% journal time=50sec delay
		(debug:print 0 *default-log-port* "Journal load "load" on "dbfname" delaying queries "dely"s.")
		(thread-sleep! dely)))))
	
    (case (rmt:transport-mode)
      ((tcp)
       (let* ((start-time    (current-seconds)) ;; snapshot time so all use cases get same value
	      (attemptnum    (+ 1 attemptnum))
	      (mtexe         (common:find-local-megatest))
	      (dbfname       (conc (dbfile:run-id->dbnum run-id)".db"))
	      (ttdat         (rmt:set-ttdat areapath ttdat))
	      (conn          (tt:get-conn ttdat dbfname))
	      (is-main       (equal? dbfname "main.db")) ;; why not (not run-id) ?
	      (server-start-proc (if is-main
				     #f
				     (lambda ()
				       ;; (debug:print-info 0 *default-log-port* "starting server for dbfname: "dbfname)
788
789
790
791
792
793
794



801
802
803
804
805
806
807
808
809
810







+
+
+

(define (rmt:find-and-mark-incomplete run-id ovr-deadtime)
  (let* ((cfg-deadtime             (configf:lookup-number *configdat* "setup" "deadtime"))
	 (test-stats-update-period (configf:lookup-number *configdat* "setup" "test-stats-update-period")))
   (rmt:find-and-mark-incomplete-engine run-id ovr-deadtime cfg-deadtime test-stats-update-period)
   ;;call end of eud of run detection for posthook
   (launch:end-of-run-check run-id)))

;; orphaned from cherrypick merge
;;         (debug:print 0 *default-log-port* "Inserting " (length tests-data) " tests in run " runname)

Modified rmtmod.scm from [bb5d679cbc] to [1cfe9c07c7].

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







+

+

+
+
+













+
+
+
+







;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.

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

(declare (unit rmtmod))
(declare (uses debugprint))
;; (declare (uses debugprint.import))
(declare (uses commonmod))
;; (declare (uses commonmod.import))
(declare (uses dbfile))    ;; needed for records
(declare (uses dbmod))
;; (declare (uses tcp-transportmod))
;; (declare (uses tcp-transportmod.import))

;; (declare (uses apimod))
;; (declare (uses apimod.import))
;; (declare (uses ulex))

;; (include "ulex/ulex.scm")

(module rmtmod
	*
	
(import scheme chicken data-structures extras matchable srfi-69)
(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18)
(import commonmod dbfile debugprint) ;; (prefix commonmod cmod:))
(import dbmod
	;; tcp-transportmod
	)

;; (import apimod)
;; (import (prefix ulex ulex:))

(include "db_records.scm")

(defstruct alldat
  (areapath #f)
303
304
305
306
307
308
309



310














311


312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336

337
338







+
+
+

+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
+
			      run-id test-id 'foo "COMPLETED" "DEAD"
			      "Test stopped responding while in RUNNING or REMOTEHOSTSTART; presumed dead.")))))))
	     ;; call end of eud of run detection for posthook - from merge, is it needed?
	     ;; (launch:end-of-run-check run-id)
	     all-ids)
	    )))))

;;======================================================================
;; Misc
;;======================================================================

;; (define (rmtmod:wait-on-server-load run-id ttdat)
;;   (let* ((dbfname                 (dbmod:run-id->dbfname run-id))
;; 	 (get-lowest-thread-load
;; 	  (lambda ()
;; 	    (let* ((sdats (tt:get-server-info-sorted ttdat dbfname)))
;; 	      (car (map tt:get-server-threads sdats))))))
;;     (if ttdat
;; 	(let loop ()
;; 	  (if (> (get-lowest-thread-load) 5) ;; load is pretty high
;; 	      (begin
;; 		(debug:print 0 *default-log-port* "Servers appear overloaded, waiting...")
;; 		(thread-sleep! 1)
;; 		(loop))))
;; 	(debug:print 0 *default-log-port* "Can't wait on server load, *ttdat* not set"))))
)

)

Modified runs.scm from [dbe1379c23] to [2d4118afd2].

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







+



















+







(declare (uses tests))
(declare (uses server))
(declare (uses mt))
(declare (uses archive))
(declare (uses mtargs))
(declare (uses rmtmod))
(declare (uses dbfile))
(declare (uses tcp-transportmod))

(use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 (srfi 18) 
     posix-extras directory-utils pathname-expand typed-records format  sxml-serializer
     sxml-modifications matchable)



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

;; (include "debugger.scm")

(import commonmod
	debugprint
	rmtmod
	dbfile
	tcp-transportmod
	(prefix mtargs args:))

;; use this struct to facilitate refactoring
;;

(defstruct runs:dat
  reglen regfull
809
810
811
812
813
814
815
816

817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836


837
838
839
840
841
842
843
811
812
813
814
815
816
817

818









819
820

821
822
823
824
825
826


827
828
829
830
831
832
833
834
835







-
+
-
-
-
-
-
-
-
-
-


-






-
-
+
+








    (if (not (null? required-tests))
	(debug:print-info 1 *default-log-port* "Adding \"" (string-intersperse required-tests " ") "\" to the run queue"))
    ;; NOTE: these are all parent tests, items are not expanded yet.
    (debug:print-info 4 *default-log-port* "test-records=" (hash-table->alist test-records))
    (let ((reglen (configf:lookup *configdat* "setup" "runqueue")))
      (if (> (length (hash-table-keys test-records)) 0)
	  (let* ((keep-going        #t)
	  (let* ()
		 (run-queue-retries 5)
		 (run-ids (rmt:get-all-run-ids)))
	    #;(for-each (lambda (run-id)
			(if keep-going
			    (handle-exceptions
				exn
			      (debug:print 0 *default-log-port* "error in calling find-and-mark-incomplete for run-id " run-id ", exn=" exn)
			      (rmt:find-and-mark-incomplete run-id #f)))) ;; ovr-deadtime))) ;; could be root of https://hsdes.intel.com/appstore/article/#/220546828/main -- Title: Megatest jobs show DEAD even though they are still running (1.64/27)
		      run-ids)
	    (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests
				  (any->number reglen) all-tests-registry)
	    (set! keep-going #f)
	    (if (> run-count 0) ;; handle reruns
		(begin
		  (if (not (hash-table-ref/default flags "-preclean" #f))
		      (hash-table-set! flags "-preclean" #t))
		  (if (not (hash-table-ref/default flags "-rerun" #f))
		      (hash-table-set! flags "-rerun" "ABORT,STUCK/DEAD,n/a,ZERO_ITEMS"))
      (runs:run-tests target runname test-patts user flags run-count: (- run-count 1)))
                (launch:end-of-run-check run-id)))
                  (runs:run-tests target runname test-patts user flags run-count: (- run-count 1)))
                 (launch:end-of-run-check run-id)))
	  (debug:print-info 0 *default-log-port* "No tests to run")))
    (debug:print-info 4 *default-log-port* "All done by here")
    ;; TODO: try putting post hook call here
      
    ;  (debug:print-info 2 *default-log-port* " run-count " run-count)
    ;  (runs:run-post-hook run-id))
    ;  (debug:print-info 2 *default-log-port* "Not calling post hook runcount = " run-count ))   
992
993
994
995
996
997
998
999

1000
1001
1002
1003
1004
1005
1006
984
985
986
987
988
989
990

991
992
993
994
995
996
997
998







-
+







	  (if (list? items-list)
	      (begin
		(if (null? items-list)
		    (let ((test-id   (rmt:get-test-id run-id test-name ""))
			  (num-items (rmt:test-toplevel-num-items run-id test-name)))
		      (if (and test-id
			       (not (> num-items 0)))
			  (mt:test-set-state-status-by-id run-id test-id "NOT_STARTED" "ZERO_ITEMS" "Failed to run due to failed prerequisites"))))
			  (mt:test-set-state-status-by-id run-id test-id "NOT_STARTED" "ZERO_ITEMS" (conc "Failed to run due to failed prerequisites: " (runs:pretty-string fails))))))
		(tests:testqueue-set-items! test-record items-list)
		(list hed tal reg reruns))
	      (begin
		(debug:print-error 0 *default-log-port* "The proc from reading the items table did not yield a list - please report this")
		(exit 1))))))

    ((and (null? fails)
1028
1029
1030
1031
1032
1033
1034
1035

1036
1037
1038

1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054

1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065

1066
1067

1068
1069
1070
1071
1072
1073
1074
1075
1076

1077
1078
1079
1080
1081
1082
1083


1084
1085
1086
1087
1088
1089
1090
1020
1021
1022
1023
1024
1025
1026

1027
1028
1029

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

1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056

1057
1058

1059
1060
1061
1062
1063
1064
1065
1066
1067

1068
1069
1070
1071
1072
1073


1074
1075
1076
1077
1078
1079
1080
1081
1082







-
+


-
+















-
+










-
+

-
+








-
+





-
-
+
+







			    (set! give-up #t)))
		      prereqstrs))

	(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 *default-log-port* "WARNING: test " hed " has discarded prerequisites, removing it from the queue")
	      (debug:print 1 *default-log-port* "WARNING: test " hed " has discarded prerequisites: " prereqstrs ", removing it from the queue")

	      (let ((test-id (rmt:get-test-id run-id hed "")))
		(if test-id (mt:test-set-state-status-by-id run-id test-id "COMPLETED" "PREQ_DISCARDED" "Failed to run due to discarded prerequisites")))
		(if test-id (mt:test-set-state-status-by-id run-id test-id "COMPLETED" "PREQ_DISCARDED" (conc "Failed to run due to discarded prerequisites: " prereqstrs))))
	      
	      (if (and (null? trimmed-tal)
		       (null? trimmed-reg))
		  #f
                  (runs:loop-values trimmed-tal trimmed-reg reglen regfull reruns)
                  ))
	      (list (car newtal)(append (cdr newtal) reg) '() reruns))))

    ((and (null? fails) ;; have not-started tests, but unable to run them.  everything looks completed with no prospect of unsticking something that is stuck.  we should mark hed as moribund and exit or continue if there are more tests to consider
	   (null? prereq-fails)
	   (null? non-completed))
     (debug:print-info 4 *default-log-port* "cond branch - "  "ei-4")
      (if  (runs:can-keep-running? hed 20)
	  (begin
	    (runs:inc-cant-run-tests hed)
	    (debug:print-info 0 *default-log-port* "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) ", going to wait 60 sec.") ;; 
	    (debug:print-info 0 *default-log-port* "no fails in prerequisites (" (runs:pretty-string prereqs-not-met) ") for " hed " but also none running, keeping " hed " for now. Try count: " (hash-table-ref/default *seen-cant-run-tests* hed 0) ", going to wait 60 sec.") ;; 
	    ;; getting here likely means the system is way overloaded, kill a full minute before continuing
	    ;; (thread-sleep! 60) ;; TODO: gate by normalized server load > 1.0 (maxload config thing) CHECKTHIS!!!
	    ;; No runsdat, can't do this yet
	    ;; (if (runs:dat-load-mgmt-function runsdat)((runs:dat-load-mgmt-function runsdat)))
	    ;;
	    (thread-sleep! 5) ;; TODO: gate by normalized server load > 1.0 (maxload config thing)
	    ;; 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 *default-log-port* "no fails in prerequisites for " hed " but nothing seen running in a while, dropping test " hed " from the run queue")
	    (debug:print-info 1 *default-log-port* "no fails in prerequisites (" (runs:pretty-string prereqs-not-met) ") 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 "")))
	      (if test-id (mt:test-set-state-status-by-id run-id test-id "NOT_STARTED" "TIMED_OUT" "Nothing seen running in a while.")))
	      (if test-id (mt:test-set-state-status-by-id run-id test-id "NOT_STARTED" "TIMED_OUT" (conc "Prerequisites (" (runs:pretty-string prereqs-not-met) ") not seen running in a while."))))
            (runs:loop-values tal reg reglen regfull reruns)
            )))

    ((and 
       (or (not (null? fails))
	   (not (null? prereq-fails)))
       (member 'normal testmode))
      (debug:print-info 4 *default-log-port* "cond branch - "  "ei-5")
      (debug:print-info 1 *default-log-port* "test "  hed " (mode=" testmode ") has failed prerequisite(s); "
      (debug:print-info 1 *default-log-port* "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 "")))
	(if test-id
	    (if (not (null? prereq-fails))
		(mt:test-set-state-status-by-id-unless-completed run-id test-id "COMPLETED" "PREQ_DISCARDED" "Failed to run due to prior failed prerequisites")
		(mt:test-set-state-status-by-id-unless-completed run-id test-id "COMPLETED" "PREQ_FAIL"      "Failed to run due to failed prerequisites"))))
		(mt:test-set-state-status-by-id-unless-completed run-id test-id "COMPLETED" "PREQ_DISCARDED" (conc "Failed to run due to prior failed prerequisites: "(runs:pretty-string prereq-fails)))
		(mt:test-set-state-status-by-id-unless-completed run-id test-id "COMPLETED" "PREQ_FAIL"      (conc "Failed to run due to failed prerequisites: " (runs:pretty-string fails ))))))
      ;; (debug:print 4 *default-log-port*"BB> set PREQ_FAIL on "hed)
      ;; (mt:test-set-state-status-by-id run-id test-id "NOT_STARTED" "PREQ_FAIL"      "Failed to run due to failed prerequisites")))) ;; BB: this works, btu equivalent for itemwait mode does not work.
      (if (or (not (null? reg))(not (null? tal)))
	  (begin
	    (hash-table-set! test-registry hed 'CANNOTRUN)
            (runs:loop-values tal reg reglen regfull (cons hed reruns))
            )
1153
1154
1155
1156
1157
1158
1159
1160














1161
1162
1163
1164
1165
1166

1167
1168
1169
1170
1171
1172
1173
1145
1146
1147
1148
1149
1150
1151

1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179







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






+







	 (registry-mutex         (runs:dat-registry-mutex runsdat))
	 (flags                  (runs:dat-flags runsdat))
	 (keyvals                (runs:dat-keyvals runsdat))
	 (run-info               (runs:dat-run-info runsdat))
	 (all-tests-registry     (runs:dat-all-tests-registry runsdat))
	 (run-limits-info        (runs:dat-can-run-more-tests runsdat))
	 ;; (runs:can-run-more-tests run-id jobgroup max-concurrent-jobs)) ;; look at the test jobgroup and tot jobs running
	 (have-resources         (car run-limits-info))
	 (have-resources         (and (if *journal-stats*
					  (let* ((dbfname (conc
							   (dbfile:run-id->dbnum run-id)
							   ".db"))
						 (load (tt:get-journal-stats dbfname)))
					    (if (> load 0.1) ;; dbs too busy to start more tests
						(begin
						  (debug:print-info 0 *default-log-port* "Gating launch due to db load "load" based on journal file observations for "dbfname)
						 #f)
						#t))
					  (begin
					    (debug:print-info 0 *default-log-port* "Journal gating not started for "run-id)
					    #t)) ;; if journal monitoring not started do not gate
				      (car run-limits-info)))
	 (num-running            (list-ref run-limits-info 1))
	 (num-running-in-jobgroup(list-ref run-limits-info 2)) 
	 (max-concurrent-jobs    (list-ref run-limits-info 3))
	 (job-group-limit        (list-ref run-limits-info 4))
	 ;; (prereqs-not-met        (rmt:get-prereqs-not-met run-id waitons hed item-path mode: testmode itemmaps: itemmaps))
	 ;; (prereqs-not-met         (mt:lazy-get-prereqs-not-met run-id waitons item-path mode: testmode itemmap: itemmap))
         (prereqs-running        (runs:calc-prereqs-running prereqs-not-met))
	 (fails                  (if (list? prereqs-not-met) ;; TODO: rename fails to failed-prereqs
				      (runs:calc-fails prereqs-not-met)
				      (begin
					(debug:print-error 0 *default-log-port* "prereqs-not-met is not a list! " prereqs-not-met)
					'())))
	 (non-completed           (filter (lambda (x)             ;; remove hed from not completed list, duh, of course it is not completed!
					    (not (equal? x hed)))
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208







1209
1210
1211
1212
1213
1214
1215
1205
1206
1207
1208
1209
1210
1211



1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225







-
-
-
+
+
+
+
+
+
+







	   (if (and (not (common:on-homehost?))
		    maxload) ;; only gate if maxload is specified, NOTE: maxload is normalized, i.e. load=1 means all cpus fully utilized
	       (common:wait-for-normalized-load maxload "Waiting for load to drop before starting more tests" #f))
	   
	   ;; jobtools maxhomehostload is intended to prevent overloading on the homehost which can cause database corruption issues
	   (if maxhomehostload
	       (common:wait-for-homehost-load maxhomehostload
					      (conc "Waiting for homehost load to drop below normalized value of " maxhomehostload))))))
    
 
					      (conc "Waiting for homehost load to drop below normalized value of " maxhomehostload)))

	   ;; lastly lets check the servers are not overloaded by looking at threads
	   (tt:wait-on-server-load run-id *ttdat*)
	   
	   )))
    
    
    (if (and (not (null? prereqs-not-met))
	     (runs:lownoise (conc "waiting on tests " prereqs-not-met hed) 60))
	(debug:print-info 2 *default-log-port* "waiting on tests; " (string-intersperse (runs:mixed-list-testname-and-testrec->list-of-strings prereqs-not-met) ", ")))

    ;; Don't know at this time if the test have been launched at some time in the past
    ;; i.e. is this a re-launch?
1333
1334
1335
1336
1337
1338
1339
1340

1341
1342
1343
1344
1345

1346
1347

1348
1349
1350
1351
1352
1353
1354

1355
1356
1357
1358
1359
1360
1361
1362
1363
1364




1365
1366
1367
1368
1369
1370
1371
1372
1373
1374

1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387







1388
1389
1390
1391
1392
1393
1394

1395
1396
1397
1398
1399
1400
1401
1343
1344
1345
1346
1347
1348
1349

1350
1351
1352
1353
1354

1355
1356

1357
1358
1359
1360
1361
1362


1363

1364
1365
1366
1367
1368
1369



1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382

1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393



1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406

1407
1408
1409
1410
1411
1412
1413
1414







-
+




-
+

-
+





-
-
+
-






-
-
-
+
+
+
+









-
+










-
-
-
+
+
+
+
+
+
+






-
+







	    
	    ;; (if (runs:dat-load-mgmt-function runsdat)((runs:dat-load-mgmt-function runsdat)))
	    (thread-sleep! 5)
	    (list (car newtal)(cdr newtal) reg reruns))
	  ;; the waiton is FAIL so no point in trying to run hed ever again
	  (begin
            (let ((my-test-id (rmt:get-test-id run-id test-name item-path)))
              (mt:test-set-state-status-by-id-unless-completed run-id my-test-id "COMPLETED" "PREQ_FAIL" "Failed to run due to failed prerequisites2"))            
              (mt:test-set-state-status-by-id-unless-completed run-id my-test-id "COMPLETED" "PREQ_FAIL" (conc "Failed to run due to failed prerequisites: " (runs:pretty-string fails))))            
            (if (or (not (null? reg))(not (null? tal)))
                (if (vector? hed)
		  (begin
		    (debug:print 1 *default-log-port* "WARNING: Dropping test " test-name "/" item-path
				 " from the launch list as it has prerequistes that are FAIL")
				 " from the launch list as it has prerequistes that are FAIL: " (runs:pretty-string fails))
		    (let ((test-id (rmt:get-test-id run-id hed "")))
		      (if test-id (mt:test-set-state-status-by-id-unless-completed run-id test-id "COMPLETED" "PREQ_FAIL" "Failed to run due to failed prerequisites")))
		      (if test-id (mt:test-set-state-status-by-id-unless-completed run-id test-id "COMPLETED" "PREQ_FAIL" (conc "Failed to run due to failed prerequisites: " (runs:pretty-string fails)) )))
		    (runs:shrink-can-run-more-tests-count runsdat) ;; DELAY TWEAKER (still needed?)
		    ;; (thread-sleep! *global-delta*)
		    ;; This next is for the items

                    (if (not (null? fails))
                        ;;(mt:test-set-state-status-by-testname run-id test-name item-path "NOT_STARTED" "PREQ_FAIL" #f)
                        (rmt:set-state-status-and-roll-up-items run-id test-name item-path "NOT_STARTED" "PREQ_FAIL" #f) 
                        (rmt:set-state-status-and-roll-up-items run-id test-name item-path "NOT_STARTED" "PREQ_FAIL" (runs:pretty-string fails)) 
                        ;;(mt:test-set-state-status-by-testname run-id test-name item-path "NOT_STARTED" "BLOCKED" #f)
                        (rmt:set-state-status-and-roll-up-items run-id test-name item-path "NOT_STARTED" "BLOCKED" #f) )
		    (hash-table-set! test-registry (db:test-make-full-name test-name item-path) 'removed)
		    (runs:loop-values tal reg reglen regfull reruns))
		  (let ((nth-try (hash-table-ref/default test-registry hed 0))) ;; hed not a vector...
                    (debug:print 2 *default-log-port* "nth-try("hed")="nth-try)
		    (cond
		     ((member "RUNNING" (map db:test-get-state prereqs-not-met))
		      (if (runs:lownoise (conc "possible RUNNING prerequistes " hed) 60)
			  (debug:print 0 *default-log-port* "WARNING: test " hed " has possible RUNNING prerequisites, don't give up on it yet."))
		     ;;((member "RUNNING" (map db:test-get-state prereqs-not-met))
                      ((> 0 (length prereqs-running))
		      (if (runs:lownoise (conc "possible RUNNING prerequisites " hed) 60)
			  (debug:print 0 *default-log-port* "WARNING: test " hed " has possible RUNNING prerequisites: " prereqs-running ", don't give up on it yet."))
		      (thread-sleep! 0.1)
		      (runs:loop-values tal reg reglen regfull reruns))
		     ((or (not nth-try) ;; BB: condition on subsequent tries, condition below fires on first try 
			  (and (number? nth-try)
			       (< nth-try 2)))
		      (hash-table-set! test-registry hed (if (number? nth-try)
							     (+ nth-try 1)
							     0))
		      (if (runs:lownoise (conc "not removing test " hed) 60)
			  (debug:print 1 *default-log-port* "WARNING: not removing test " hed " from queue although it may not be runnable due to FAILED prerequisites"))
			  (debug:print 1 *default-log-port* "WARNING: not removing test " hed " from queue although it may not be runnable due to FAILED prerequisites: "(runs:pretty-string fails)))
		      ;; may not have processed correctly. Could be a race condition in your test implementation? Dropping test " hed) ;;  " as it has prerequistes that are FAIL. (NOTE: hed is not a vector)")
		      (runs:shrink-can-run-more-tests-count runsdat) ;; DELAY TWEAKER (still needed?)
		      (runs:loop-values newtal reg reglen regfull reruns))
		     ((symbol? nth-try) ;; BB: 'done matches here in one case where prereq itemwait failed.  This is first "try"
		      (if (eq? nth-try 'removed) ;; removed is removed - drop it NOW
			  (if (null? tal)
			      #f ;; yes, really
			      (list (car tal)(cdr tal) reg reruns))
			  (begin
			    (if (runs:lownoise (conc "FAILED prerequisites or other issue" hed) 60)
				(debug:print 0 *default-log-port* "WARNING: test " hed " has FAILED prerequisites or other issue. Internal state >" nth-try "< will be overridden and we'll retry."))
			    ;; was: (mt:test-set-state-status-by-testname run-id test-name item-path "NOT_STARTED" "KEEP_TRYING" #f)
                            (mt:test-set-state-status-by-testname-unless-completed run-id test-name item-path "COMPLETED" "PREQ_FAIL" #f)
				(debug:print 0 *default-log-port* "WARNING: test " hed " has FAILED prerequisites (" (runs:pretty-string fails)") or other issue. Internal state >" nth-try "< will be overridden and we'll retry."))
			    (let* ((test-id      (rmt:get-test-id run-id hed item-path))
				   (test-info    (rmt:get-testinfo-state-status run-id test-id)) ;; we need *current* info
				   (status       (db:test-status test-info)))
			      (if (equal? status "KEEP_TRYING")
				  (mt:test-set-state-status-by-testname-unless-completed run-id test-name item-path "COMPLETED" "PREQ_FAIL" #f)
				  (mt:test-set-state-status-by-testname run-id test-name item-path "NOT_STARTED" "KEEP_TRYING" #f)))
			    (hash-table-set! test-registry hed 'removed) ;; was 0
                            (if (not (and (null? reg) (null? tal)))
                                (runs:loop-values tal reg reglen regfull reruns)
                                #f))))
		     (else
		      (if (runs:lownoise (conc "FAILED prerequitests and we tried" hed) 60)
			  (debug:print 0 *default-log-port* "WARNING: test " hed " has FAILED prerequitests and we've tried at least 10 times to run it. Giving up now."))
			  (debug:print 0 *default-log-port* "WARNING: test " hed " has FAILED prerequitests: " (runs:pretty-string fails) "  and we've tried at least 10 times to run it. Giving up now."))
		      ;; (debug:print 0 *default-log-port* "         prereqs: " prereqs-not-met)
		      (hash-table-set! test-registry hed 'removed)
		      (mt:test-set-state-status-by-testname run-id test-name item-path "NOT_STARTED" "TEN_STRIKES" #f)
		      ;; I'm unclear on if this roll up is needed - it may be the root cause of the "all set to FAIL" bug.
		      (rmt:set-state-status-and-roll-up-items run-id test-name item-path #f "FAIL" #f) ;; treat as FAIL
		      (list (if (null? tal)(car newtal)(car tal))
			    tal
2001
2002
2003
2004
2005
2006
2007












2008
2009
2010
2011
2012
2013
2014
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039







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







   (lambda (t)
     (or (not (vector? t))
	 (and (equal? "NOT_STARTED" (db:test-get-state t))
	      (member (db:test-get-status t)
		      '("n/a" "KEEP_TRYING")))
	 (and (equal? "RUNNING" (db:test-get-state t))))) ;; account for a test that is running
   prereqs-not-met))

(define (runs:calc-prereqs-running prereqs-not-met)
  (if (list? prereqs-not-met)
    (filter 
     (lambda (t)
       (or (not (vector? t))
         (member (db:test-get-state t) '("RUNNING" "LAUNCHED" "REMOTE_HOST_START"))
       ))
     prereqs-not-met)
    '()
  )
)

(define (runs:pretty-string lst)
  (map (lambda (t)
	 (if (not (vector? t))
	     (conc t)
	     (conc (db:test-get-testname t) ":" (db:test-get-state t) "/" (db:test-get-status t))))
       lst))

Modified server.scm from [8ac9dab770] to [c559be1916].

391
392
393
394
395
396
397
398

399
400
401
402
403
404
405
391
392
393
394
395
396
397

398
399
400
401
402
403
404
405







-
+







		      (with-output-to-file start-flag (lambda () (print server-key)))
		      (thread-sleep! 0.25)
		      (set! new-server-key (with-input-from-file start-flag (lambda () (read-line))))
		      (equal? server-key new-server-key)))
	       #t
               ;; If either of the above conditions is not true, print a "Gating server start" message, wait <idle-time> + 1, then call this function recursively. 
	       (begin
		 (debug:print-info 0 *default-log-port* "Gating server start, last start: "
		 (debug:print-info 2 *default-log-port* "Gating server start, last start: "
				   (seconds->time-string fmodtime) ", time since last start: " delta ", required idletime: " idletime ", gating reason:" (if old-enough "another job started a server" "too soon to start another server"))
		 
		 (thread-sleep! ( + 1 idletime))
		 (server:wait-for-server-start-last-flag areapath)))))))

;; oldest server alive determines host then choose random of youngest
;; five servers on that host

Modified tcp-transportmod.scm from [5ace6e2c23] to [d0258d10eb].

39
40
41
42
43
44
45

46
47
48
49
50
51
52
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53







+







	  extras
	  hostinfo

	  ports
	  posix
	  files
	  data-structures
	  directory-utils
	  tcp
	  ))
 (chicken-5
  (import chicken.base
	  chicken.condition
	  chicken.file
	  chicken.pathname
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
191
192
193
194
195
196
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
191
192
193

194
195
196
197
198
199
200
201
202
203
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







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


-
+












-
+



+
+
+



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







;; (max-connections 4096)

(define (tt:get-conn ttdat dbfname)
  (hash-table-ref/default (tt-conns ttdat) dbfname #f))

;; do all the busy work of finding and setting up conn for
;; connecting to a server
;; This function, `tt:client-connect-to-server`, is designed to manage connections between a client and a server within a testing framework.
;; The function takes four arguments:
;; 1. `ttdat`: a data structure that holds information about the testing environment or connections.
;; 2. `dbfname`: The name of the database file that the client wants to connect to.
;; 3. `run-id`: An identifier for the current run of the test suite.
;; 4. `testsuite`: The test suite that is being run.
;; 
;;
;; Here's a step-by-step explanation of what the function does:
;;
;; 1. It first asserts that the `run-id` is valid for the given `dbfname` using the `tt:valid-run-id` function. If the `run-id` is not valid, it raises a fatal error.
;; 2. It prints debug information indicating that the function `tt:client-connect-to-server` has been called with the given `dbfname`.
;; 3. It attempts to retrieve an existing connection to the server from a hash table (`tt-conns`) using the `dbfname` as the key. If a connection already exists, it prints debug information and returns the existing connection.
;; 4. If no existing connection is found, it retrieves the current server information from the servinfo file, using the `tt:get-current-server-info` function.
;; 5. It uses pattern matching to destructure the server information into variables (`host`, `port`, `start-time`, `server-id`, `pid`, `dbfname2`, `servinffile`). It then asserts that the `dbfname` from the server info matches the one provided to the function.
;; 6. It constructs a connection object (`conn`) with the server information.
;; 7. It attempts to ping the server using `tt:timed-ping` to verify that the server is running and can be communicated with.
;; 8. Depending on the result of the ping:
;;    - If the server is running (`running`), it prints debug information, saves the connection in the hash table, and returns the connection.
;;    - If the server is starting (`starting`), it sleeps for 2 seconds and then recursively calls itself to retry the connection.
;;    - If the server is neither running nor starting, it checks if it's been more than 10 seconds since the last server start attempt. If so, it attempts to start the server using `server-start-proc` and then sleeps for 1 second before retrying the connection.
;; 9. If no server information is found (`else` case), it checks if it's been more than 3 seconds since the last server start attempt. If so, it starts a new server using `server-start-proc`, updates the last server start time, and sleeps for 4 seconds.
;; 10. It then sleeps for 1 second and prints debug information before recursively calling itself to retry the connection.
;;
;; The function uses recursion to keep trying to connect to the server, with various sleep intervals to prevent overwhelming the system with connection attempts or server starts.
;; It also uses a hash table to cache connections and avoid reconnecting to a server if a connection already exists.
;; The function is designed to handle different server states and ensure that a server is running and available before returning a valid connection to the caller.
;; 
(define (tt:client-connect-to-server ttdat dbfname run-id testsuite server-start-proc)
  (assert (tt:valid-run-id run-id dbfname) "FATAL: invalid run-id "run-id)
  (debug:print-info 2 *default-log-port* "tt:client-connect-to-server " dbfname " " run-id)
  (debug:print-info 2 *default-log-port* "tt:client-connect-to-server " dbfname)
  (let* ((conn              (tt:get-conn ttdat dbfname))
	 (server-start-proc (or server-start-proc
				(lambda ()
				  (assert (equal? dbfname "main.db") ;; only main.db is started here
					  "FATAL: called server-start-proc for db other than main.db")
				  (tt:server-process-run
				   (tt-areapath ttdat)
				   testsuite ;; (dbfile:testsuite-name)
				   (common:find-local-megatest)
				   run-id)))))
    (if conn
	(begin 
          (debug:print-info 2 *default-log-port* "already connected to a server")
          (debug:print-info 2 *default-log-port* "already connected to a server for " dbfname)
           conn) ;; we are already connected to the server

	;; no conn

	;; find server with lowest number of threads running (i.e. lowest load)
	;;
        (let* ((sdats (tt:get-server-info-sorted ttdat dbfname))
	       (sdat  (if (null? sdats)
			  #f
			  ;; choose server with lowest threads count
			  (car sdats))))
	   (debug:print-info 2 *default-log-port* "found sdat " sdat)
           (match sdat
			  (car (sort sdats
				     (lambda (a b)
				       (let* ((load-a (tt:get-server-threads a))
					      (load-b (tt:get-server-threads b)))
					 (< load-a load-b))))))))
				     
	  ;; (let ((indx (max (random (- (length sdats) 1)) 0)))
	  ;;    (list-ref sdats indx)))))
	  ;; (debug:print-info 1 *default-log-port* "found sdat " sdat" from sdats: "sdats)
          (match sdat
	    ((host port start-time server-id pid dbfname2 servinffile)
	     (assert (equal? dbfname dbfname2) "FATAL: read server info from wrong file.")
             (debug:print-info 2 *default-log-port* "no conn - in match servinffile:" servinffile)
	     (let* ((host-port (conc host":"port))
		    (conn (make-tt-conn
			   host: host
			   port: port
246
247
248
249
250
251
252
253















































254
255
256
257
258
259
260
261
262
263
264
265
266
267

268
269
270
271
272

273

274
275
276
277
278
279
280
281
282

283
284
285
286
287
288
289
284
285
286
287
288
289
290

291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358

359
360
361
362
363
364
365
366
367

368
369
370
371
372
373
374
375







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














+





+
-
+








-
+







	     (tt:client-connect-to-server ttdat dbfname run-id testsuite server-start-proc)))))))

;; returns ( result . ping_time )
(define (tt:timed-ping host port server-id)
  (let* ((start-time (current-milliseconds))
	 (result     (tt:ping host port server-id)))
    (cons result (- (current-milliseconds) start-time))))
    

;; host:port => ( meta . when-updated)
(define *server-load* (make-hash-table))

(define (tt:save-server-meta host port meta)
  (hash-table-set! *server-load* (conc host":"port) (cons meta (current-seconds))))

(define (tt:get-server-threads dat)
  (let* ((host (car  dat))
	 (port (cadr dat))
	 (dat  (tt:get-server-meta host port #t)))
    ;; (debug:print 0 *default-log-port* "host: "host" port: "port" dat: "dat)
    (if (list? dat)
	(or (alist-ref 'sload dat) 99998)
	99999))) ;; absurd number means don't use this one

;; lazy get, does not auto-refresh meta, this might be a problem
;;
(define (tt:get-server-meta host port #!optional (do-ping #f))
  (let* ((get-meta (lambda ()
		     (let* ((dat  (hash-table-ref/default *server-load* (conc host":"port) #f)))
		       (if dat (car dat) #f))))
	 (meta     (get-meta)))
    (if (and (not meta)
	     do-ping)
	(begin
	  (tt:timed-ping host port #f)
	  (get-meta))
	meta)))

(define (tt:wait-on-server-load run-id ttdat)
  (if ttdat ;; if no server yet just pass on through
      (let* ((dbfname                 (dbmod:run-id->dbfname run-id))
	     (get-lowest-thread-load
	      (lambda ()
		(let* ((sdats (tt:get-server-info-sorted ttdat dbfname)))
		  (car (map tt:get-server-threads sdats))))))
	(if ttdat
	    (let loop ((count 0))
	      (let* ((lowestload (get-lowest-thread-load)))
		(if (> lowestload 5) ;; load is pretty high
		    (begin
		      (debug:print 0 *default-log-port* "Servers appear overloaded with "lowestload" threads, waiting...")
		      (thread-sleep! 1)
		      (if (< count 10)
			  (loop (+ count 1)))))))
	    (debug:print 0 *default-log-port* "Can't wait on server load, *ttdat* not set")))))

(define (tt:ping host port server-id #!optional (tries-left 5))
  (let*  ((res      (tt:send-receive-direct host port `(ping #f #f #f) ping-mode: #t)) ;; please send me your server-id
	  (try-again (lambda ()
		       (if (> tries-left 0)
			   (begin
			     (thread-sleep! 1)
			     (tt:ping host port server-id (- tries-left 1)))
			   #f))))
    ;;
    ;; need two threads, one a 5 second timer
    ;;
    (match res
      ((status errmsg result meta)
       (tt:save-server-meta host port meta)
       (if (equal? result server-id)
	   (let* ((server-state (alist-ref 'sstate meta)))
	     ;; (debug:print 0 *default-log-port* "Ping to "host":"port" successful.")
	     (or server-state 'unk)) ;; then we are good
	   (begin
	     (if server-id
	     (debug:print 0 *default-log-port* "WARNING: server-id does not match, expected: "server-id", got: "result)
		 (debug:print 0 *default-log-port* "WARNING: server-id does not match, expected: "server-id", got: "result))
	     #f)))
      (else
       ;; (debug:print 0 *default-log-port* "res not in form (status errmsg result meta), got: "res)
       (try-again)))))

;; client side handler
;;
;;(tt:handler #<tt> get-keys #f () 2 #f "/home/matt/data/megatest/ext-tests" #f "main.db" "ext-tests" "/home/matt/data/megatest/bin/.22.04/../megatest")
;;
;;g
(define (tt:handler ttdat cmd run-id params attemptnum readonly-mode dbfname testsuite mtexe server-start-proc)
  ;; connect-to-server will start a server if needed.
  (let* ((areapath (tt-areapath ttdat))
	 (conn     (tt:client-connect-to-server ttdat dbfname run-id testsuite server-start-proc))) ;; looks up conn keyed by dbfname
    (if conn
	;; have connection, call the server
	(let* ((res (tt:send-receive ttdat conn cmd run-id params)))
298
299
300
301
302
303
304

305
306
307
308
309



310
311
312
313
314
315
316
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406







+





+
+
+







			 (debug:print 0 *default-log-port* "Server is loaded, delaying "delay-wait" seconds")
			 (thread-sleep! delay-wait)))))
	     (case status
	       ((busy) ;; result will be how long the server wants you to delay
		(let* ((raw-dly  (if (number? result) result 0.1))
		       (dly      (+ raw-dly (/ attemptnum 10)))) ;; (* raw-dly (/ attemptnum 2))))
		  (debug:print 0 *default-log-port* "WARNING: server for "dbfname" is busy, cmd is "cmd", will try again in "dly" seconds. This is attempt "(- attemptnum 1))
                  (debug:print 0 *default-log-port* errmsg)
		  (thread-sleep! dly)
		  (tt:handler  ttdat cmd run-id params (+ attemptnum 1) readonly-mode dbfname testsuite mtexe server-start-proc)))
	       ((loaded)
		(debug:print 0 *default-log-port* "WARNING: server for "dbfname" is loaded, slowing queries.")
		(tt:backoff-incr (tt-conn-host conn)(tt-conn-port conn))

		;; this would be a good place to force reconnection and connect to a different server
		
		result) ;; (tt:handler  ttdat cmd run-id params (+ attemptnum 1) readonly-mode dbfname testsuite mtexe))
	       (else
		result)))
	    (else ;; did not receive properly formated result
	     (if (not res) ;; tt:send-receive telling us that communication failed
		 (let* ((host    (tt-conn-host conn))
			(port    (tt-conn-port conn))
353
354
355
356
357
358
359
360



361
362
363
364
365
366
367
368
369
370
371
372
373

374
375
376
377
378
379
380
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







-
+
+
+












-
+







		   ;; (tt:handler ttdat cmd run-id params (+ attemptnum 1) readonly-mode dbfname testsuite mtexe)
		   )))))
	(begin
	  (thread-sleep! 1) ;; no conn yet set up, give it a rest and try again
	  (tt:handler ttdat cmd run-id params attemptnum readonly-mode dbfname testsuite mtexe server-start-proc)))))

;; gets server info and appends path to server file
;; sorts by age, oldest first
;; sorts by age, --oldest-- now newest first
;;
;; move the ping here?
;;
;; returns list of (host port startseconds server-id servinfofile)
;;
(define (tt:get-server-info-sorted ttdat dbfname)
  (let* ((areapath (tt-areapath ttdat))
	 (sfiles   (tt:find-server areapath dbfname))
	 (sdats    (filter car (map tt:server-get-info sfiles))) ;; first element is #f if the file disappeared while being read
	 (sorted   (sort sdats (lambda (a b)
				 (let* ((starta (list-ref a 2))
					(startb (list-ref b 2)))
				   (if (eq? starta startb)
				       (string>? (list-ref a 3)(list-ref b 3)) ;; if servers started at same time look at server-id
				       (< starta startb))))))
				       (> starta startb))))))
	 (count    0))
    (for-each
     (lambda (rec)
       (if (or (> (length sorted) 1)
	       (common:low-noise-print 120 "server info sorted"))
	   (debug:print 2 *default-log-port* "SERVER #"count": "(string-intersperse (map conc sorted) ", ")))
       (set! count (+ count 1)))
489
490
491
492
493
494
495


496
497
498
499
500
501
502
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596







+
+








;;======================================================================
;; server
;;======================================================================

(define (tt:sync-dbs ttdat)
  #f)

(define *server-start-requests* '())

;; start the listener and start responding to requests
;;
;; NOTE: organise by dbfname, not run-id so we don't need
;;       to pull in more modules
;;
;; This is the routine called in megatest.scm to start a server. NOTE: sequence is different for main.db vs. X.db
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
638
639
640
641
642
643
644








645
646
647
648
649
650
651
652
653
654
655
656

657
658
659
660
661
662
663
664
665
666
667
668
669

670
671
672
673
674
675
676
677







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

-
+








+



-
+







				     (same-host (or (not prime-host) ;; i.e. this is the first host
						    (equal? prime-host host)))
				     (keep-srv  (and good-ping same-host)))
				(if keep-srv	
				    (loop (cdr servrs)
					  host
					  (cons servdat result))
				    (begin
                                      ;; (debug:print-info 0 *default-log-port* "good-ping: " good-ping " same-host: " same-host "keep-srv: " keep-srv)
				      (handle-exceptions
				       exn
				       (debug:print-info 0 *default-log-port* "Error removing server info file: "servinfofile", "
							 (condition->list exn))
				       (delete-file* servinfofile))
				      (loop (cdr servrs) prime-host result)))))
				    (let* ((modtime (file-modification-time servinfofile)))
				      ;; if the .servinfo hasn't been touched in five min
				      ;; we can be pretty sure the server is truly dead
				      (if (> (- (current-seconds) modtime) 360)
					  (handle-exceptions
					   exn
					   (debug:print-info 0 *default-log-port*
							     "Error removing server info file: "servinfofile", "
							     (condition->list exn))
					   (delete-file* servinfofile))
					  (loop (cdr servrs) prime-host result))))))
			     (else
			      ;; can't delete it as we don't have a filename. NOTE: Should really never get here.
			      ;; can't delete it as we don't have a filename. NOTE: Should never get here.
			      (debug:print-info 0 *default-log-port* "ERROR: bad servinfo record \""servdat"\"")
			      (loop (cdr servrs) prime-host result)) ;; drop 
			     )))))
	       (home-host (if (null? good-srvrs)
			      #f
			      (caar good-srvrs))))
	  ;; by here we have a trustworthy list of servers and we have removed the .servinfo file for any unresponsive servers
	  ;; and the list is in good-srvrs
	  ;;
	  (cond
	   ((not home-host) ;; no servers yet, go ahead and start
	    (debug:print-info 0 *default-log-port* "No servers yet, starting on "(get-host-name)))
	   ((> (length good-srvrs) 2) ;; don't need more, just exit
	   ((> (length good-srvrs) 3) ;; don't need more, just exit
	    (debug:print-info 0 *default-log-port* "Have "(length good-srvrs)", no need for more, exiting.")
	    (exit))
	   ((not (equal? home-host (get-host-name))) ;; there is a home-host and we are not on it
	    (debug:print-info 0 *default-log-port* "Prime main server is on host "home-host", but we are on host "(get-host-name)", exiting.")
	    (exit))
	   (else
	    (debug:print-info 0 *default-log-port* "Starting on host "(get-host-name)", along with "(length good-srvrs)" other servers.")))
593
594
595
596
597
598
599


600
601
602
603
604
605
606
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706







+
+







		      (thread-sleep! 0.25)
		      (loop (+ count 1)))
		    (begin
		      (debug:print 0 *default-log-port* "ERROR: (tt-port ttdat) no port set! Exiting.")
		      (exit)))))
	  
	  ;; create a servinfo file start keep-running
	  ;; On WSL there seems to be a race condition where the .servinfo file
	  ;; is not created fast enough
          (debug:print 0 *default-log-port* "Creating servinfo file for " dbfname)
	  (tt:create-server-registration-file ttdat dbfname)
	  (procinf-status-set! *procinf* "running")
	  (tt-state-set! ttdat 'running)
	  (dbfile:with-no-sync-db
	   nosyncdbpath
	   (lambda (nsdb)
619
620
621
622
623
624
625


626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641



642
643
644
645
646
647
648
649


650
651
652
653
654
655
656
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752


753
754
755
756
757
758
759
760
761







+
+
















+
+
+






-
-
+
+







	   nosyncdbpath
	   (lambda (nsdb)
	     (dbfile:insert-or-update-process nsdb *procinf*)))
	  (debug:print 0 *default-log-port* "Exiting now.")
	  (exit))))))

(define (tt:keep-running ttdat dbfname dbstruct)

  (thread-sleep! 1)
  
  ;; at this point the server is running and responding to calls, we just monitor
  ;; for db calls and exit if there are none.

  ;; if I am not in the first 3 servers, exit
  (let* ((start-time (current-seconds)))
    (let loop ()
      (let* ((servers   (tt:get-server-info-sorted ttdat dbfname))
	     (home-host (if (null? servers)
			    #f
			    (caar servers)))
	     (my-index  (list-index (lambda (x)
				      (equal? (list-ref x 6)
					      (tt-servinf-file ttdat)))
				    servers))
	     (ok         (cond
			  ((not my-index)
			   (debug:print 0 *default-log-port* "WARNING: Apparently I don't exist.")
			   #f) ;; keep trying or give up?
			  ((not *server-run*)
			   (debug:print 0 *default-log-port* "WARNING: received a stop server from client by remote request.")
			   #f)
			  ((null? servers)
			   (debug:print 0 *default-log-port* "WARNING: no servinfo files found, this cannot be.")
			   #f) ;; not ok
			  ((> my-index 2)
			   (debug:print 0 *default-log-port* "WARNING: there are more than two servers ahead of me, I'm not needed, exiting.")
			  ((> my-index 3)
			   (debug:print 0 *default-log-port* "WARNING: there are more than three servers ahead of me, I'm not needed, exiting.")
			   #f) ;; not ok to not be in first three
			  ((eq? (tt-state ttdat) 'running) #t) ;; we are good to keep going
			  ((> (- (current-seconds) start-time) 30)
			   (debug:print 0 *default-log-port* "WARNING: over 30 seconds and not yet in runnning mode. Exiting.")
			   #f)
			  (else #t))))
	(if ok
667
668
669
670
671
672
673






674



675
676
677
678
679
680
681
772
773
774
775
776
777
778
779
780
781
782
783
784

785
786
787
788
789
790
791
792
793
794







+
+
+
+
+
+
-
+
+
+







	      (let* ((sinfo-file (tt-servinf-file ttdat)))
		;; (debug:print 0 *default-log-port* "INFO: touching "sinfo-file)
		(set! (file-modification-time sinfo-file) (current-seconds))
		((dbr:dbstruct-sync-proc dbstruct) last-update)
		(dbr:dbstruct-last-update-set! dbstruct curr-secs))))
	
	(if (< (- (current-seconds) (tt-last-access ttdat)) (tt-server-timeout-param))
	    ;; process any requests to start a new server due to load on this one
	    (let* ((requests *server-start-requests*))
	      (set! *server-start-requests* '())
	      (if (> (length requests) 0)
		  (debug:print-info 0 *default-log-port* "Processing "(length requests)" server start requests"))
	      (for-each (lambda (proc)
	    (begin
			  (proc)
			  (thread-sleep! 1))
			requests)
	      (thread-sleep! 5)
	      (loop)))))
    (tt:shutdown-server ttdat)
    (debug:print 0 *default-log-port* "INFO: Server timed out, exiting from tt:keep-running.")))


(define (tt:shutdown-server ttdat)
699
700
701
702
703
704
705








706

707
708
709
710


711

712
713
714
715
716
717
718
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826

827
828
829
830
831
832
833

834
835
836
837
838
839
840
841







+
+
+
+
+
+
+
+
-
+




+
+
-
+







	 (servinf (conc servdir"/"host":"port"-"(current-process-id)":"dbfname))
	 (serv-id (tt:mk-signature areapath)))
    (assert (and host port) "FATAL: tt:create-server-registration-file called with no conn, dbfname="dbfname)
    (tt-servinf-file-set! ttdat servinf)
    (with-output-to-file servinf
      (lambda ()
	(print "SERVER STARTED: "host":"port" AT "(current-seconds)" server-id: "serv-id" pid: "(current-process-id)" dbfname: "dbfname)))
    (let loop ((count 0))
      (if (not (file-exists? servinf))
	  (begin
	    (debug:print 0 *default-log-port* "WARNING: file "servinf" was created but it doesn't show up on disk! We'll try again.")
	    (thread-sleep! 1)
	    (if (> count 10)
		(debug:print 0 *default-log-port* "WARNING: file "servinf" was not created.")
		(loop (+ count 1))))))
      serv-id))
    serv-id))

;; find valid server
;; get servers listed, last part of name must match :<dbfname>
;; if more than one, wait one second and look again
;; 
;; NOTE: this only gets the servinfo data, no network activity here
;; future: ping oldest, if alive remove other :<dbfname> files
;;       i.e. no ping etc.
;;
(define (tt:find-server areapath dbfname)
  (let* ((servdir  (tt:get-servinfo-dir areapath))
	 (sfiles   (glob (conc servdir"/*:"dbfname)))
	 (goodfiles '()))

    ;; filter the files here by looking in processes table (if we are not main.db)
773
774
775
776
777
778
779


780
781
782
783
784
785
786
787
788
789
790
791

792

793
794
795
796
797

798
799
800
801



802
803
804
805
806
807

808
809
810
811
812
813
814
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







+
+












+
-
+





+

-
-
-
+
+
+





-
+








(define *last-server-start* (make-hash-table))

(define (tt:too-recent-server-start dbfname)
  (let* ((last-run-time (hash-table-ref/default *last-server-start* dbfname #f)))
    (and last-run-time
	 (< (- (current-seconds) last-run-time) 5))))

(define *last-server-start-request-time* 0)
    
;; Given an area path,  start a server process    ### NOTE ### > file 2>&1 
;; if the target-host is set 
;; try running on that host
;;   incidental: rotate logs in logs/ dir.
;;
(define  (tt:server-process-run areapath testsuite mtexe run-id #!key (profile-mode "")) ;; areapath is *toppath* for a given testsuite area
  (assert areapath  "FATAL: tt:server-process-run called without areapath defined.")
  (assert testsuite "FATAL: tt:server-process-run called without testsuite defined.")
  (assert mtexe     "FATAL: tt:server-process-run called without mtexe defined.")
  ;; mtest -server - -m testsuite:ext-tests -db 6.db
  (let* ((dbfname  (dbmod:run-id->dbfname run-id)))
    (if (or (< (- (current-seconds) *last-server-start-request-time*) 5) ;; attempted start less than 5 sec ago
    (if (tt:too-recent-server-start dbfname)
	    (tt:too-recent-server-start dbfname))
	#f
	(let* ((load     (get-normalized-cpu-load))
	       (srvrs    (tt:find-server areapath dbfname))
	       (trying   (length srvrs))
	       (nrun     (number-of-processes-running (conc "mtest.*server.*"testsuite".*"dbfname))))
	  (set! *last-server-start-request-time* (current-seconds))
	  (cond
	   ((> load 2.0)
	    (debug:print 0 *default-log-port* "Normalized load "load" on " (get-host-name) " is over the limit of 2.0. Not starting a server. Please reduce the load on "(get-host-name)" by killing some processes")
	    (thread-sleep! 1)
	   ((> load 4.0)
	    (debug:print 0 *default-log-port* "Normalized load " load " over 4, (load: " (commonmod:get-cpu-load) " cores: " (get-current-host-cores) " exiting...")
	    (thread-sleep! 1) ;; I'm not convinced that a delay here is helpful. -mrw-
	    #f)
	   ((> nrun 100)
	    (debug:print 0 *default-log-port* nrun" servers running on " (get-host-name) ", not starting another.")
	    (thread-sleep! 1)
	    #f)
	   ((> trying 2)
	   ((> trying 3)
	    (debug:print 0 *default-log-port* trying" servers registered in .servinfo dir. not starting another.")
	    (thread-sleep! 1)
	    #f)
	   (else
	    (if (not (file-exists? (conc areapath"/logs")))
		(create-directory (conc areapath"/logs") #t))
	    (let* ((logfile   (conc areapath "/logs/server-"dbfname"-"(current-process-id)".log")) ;; -" curr-pid "-" target-host ".log"))
1000
1001
1002
1003
1004
1005
1006
1007



1008




















































































































1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137

1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
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
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253








+
+
+
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
  (sort (get-all-ips) ip-pref-less?))

(define (get-all-ips)
  (map address-info-host
       (filter (lambda (x)
		 (equal? (address-info-type x) "tcp"))
	       (address-infos (get-host-name)))))

;;======================================================================
;; Other Utils
;;======================================================================
)

(defstruct jstats
  (count 0)
  (jcount (make-hash-table)) ;; 1.db => journal_count
  )

;; timeblk => jstats
(define *journal-stats* #f) ;; (make-hash-table))
(define *journal-stats-enable* #t) ;; change to #f to turn off

;; monte-carlo-esque random sampling of journal files
;; for all the files:
;;   if .journal
;;      update stats +1 +1
;;      update stats +1  0
;;
(define (tt:write-load-tracking dbdir)
  (if *journal-stats-enable*
      (let* ((cs    (current-seconds))
	     (key   (inexact->exact (quotient cs 10)))
	     (old   (- key 5)) ;; 4 x 10 seconds ago
	     (jstat (if (hash-table-exists? *journal-stats* key)
			(hash-table-ref *journal-stats* key )
			(let ((new (make-jstats)))
			  (hash-table-set! *journal-stats* key new)
			  new))))
	;; clear out old records
	(for-each
	 (lambda (key)
	   (if (< key old)
	       (hash-table-delete! *journal-stats* key)))
	 (hash-table-keys *journal-stats*))

	;; increment our count of observations
	(jstats-count-set! jstat (+ (jstats-count jstat) 1))
	
	;; now find and increment journal file counts
	(directory-fold
	 (lambda (fname res)
	   ;; is it a journal file?
	   (let ((parts (string-match "^(.*\\.db)-journal.*" fname)))
	     (match parts
		    ((_ dbfname)
		     (hash-table-set! (jstats-jcount jstat) dbfname
				      (+ (hash-table-ref/default (jstats-jcount jstat) dbfname 0) 1.0)
				      ))
		    (else #f)
		    )))
	 '()
	 dbdir 
     ))))

(define *journal-stats-mutex* (make-mutex))

(define (tt:journal-stats-run dbdir)
  (if (not *journal-stats*)(set! *journal-stats* (make-hash-table)))
  (let loop ()
    (mutex-lock! *journal-stats-mutex*)
    (tt:write-load-tracking dbdir)
    (mutex-unlock! *journal-stats-mutex*)
    (thread-sleep! (/ (random 1000) 100.0))
    (loop)))

;; call this to start a thread that is keeping the journal-stats up to date.
(define (tt:start-stats dbdir)
  
  (thread-start!
   (make-thread
    (lambda ()(tt:journal-stats-run dbdir)) "Journal stats collection thread")))

(define (tt:get-journal-stats #!optional (dbfname #f))
  (let* ((result    (make-jstats))
	 (hitcounts (jstats-jcount result)))
    (if (and *journal-stats*
	     *journal-stats-enable*)
	(begin
	  (mutex-lock! *journal-stats-mutex*)
	  (hash-table-for-each
	   *journal-stats*
	   (lambda (k v) ;; key jstats
	     (let* ((count  (jstats-count v))
		    (jcount (jstats-jcount v))) ;; dbfname => hit count
	       (jstats-count-set! result
				  (+ (jstats-count result)
				     (jstats-count v)))
	       (hash-table-for-each
		jcount
		(lambda (dbfname hit-count)
		  (hash-table-set! hitcounts dbfname
				   (+ hit-count
				      (hash-table-ref/default hitcounts dbfname 0))))))))
	  (mutex-unlock! *journal-stats-mutex*))
	(debug:print 0 *default-log-port* "INFO: *journal-stats* not set."))
    ;; convert to normalized alist
    (let* ((tot  (max (jstats-count result) 1)) ;; avoid divide by zero
	   (hits (jstats-jcount result)) ;; 1.db => count
	   (res  (hash-table-map
		  hits
		  (lambda (fname hitcount)
		    (cons fname (/ hitcount tot))))))
      (if dbfname
	  (or (alist-ref dbfname res equal?) 0)
	  res))))

;; megatest> (import tcp-transportmod)
;; megatest> (tt:write-load-tracking ".mtdb")
;; megatest> (hash-table-keys *journal-stats*)
;; (172060297)
;; megatest> (jstats->alist (hash-table-ref *journal-stats* 172060297))
;; ((count . 1) (jcount . #<hash-table (1)>))
;; megatest> (jstats-jcount (hash-table-ref *journal-stats* 172060297))
;; #<hash-table (1)>
;; megatest> (hash-table->alist (jstats-jcount (hash-table-ref *journal-stats* 172060297)))
;; (("1.db" . 4))

)

Added utils/convert-db.sh version [8205e222a7].


























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
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
#!/bin/bash

if [ -z "megatest.config" ]; then
    echo "The file 'megatest.config' does not exist. This must be run in a megatest area."
    exit 1
fi
if [ -d ".mtdb" ]; then
    echo "The .mtdb directory already exists. Will not do the conversion"
    exit 1
fi
if [ -d ".megatest" ]; then
    echo "Found a .megatest directory. Will convert from megatest 1.70 to 1.71/1.80 format"
    /p/foundry/env/pkgs/megatest/1.70/16/bin/megatest -list-runs % -dumpmode sexpr > data.sexpr
else 
    if [ -f "megatest.db" ]; then
        echo "Found megatest.db. Will convert from megatest 1.65 to 1.71/1.80 format"
        /p/foundry/env/pkgs/megatest/1.65/92/bin/megatest -list-runs % -dumpmode sexpr > data.sexpr
    else
        echo "Did not find .megatest or megatest.db. Cannot do the conversion"
        exit 1
    fi
fi
which megatest
megatest -import-sexpr data.sexpr

Added utils/setcicd version [bb9f0e8cef].











1
2
3
4
5
6
7
8
9
10
+
+
+
+
+
+
+
+
+
+
#!/bin/bash

branch=$(fossil branch current)
wikiname=${branch}_cicd
echo "ready to merge" > $wikiname
if fossil wiki export $wikiname;then
    fossil wiki commit $wikiname $wikiname
else
    fossil wiki create $wikiname $wikiname
fi