Megatest

Check-in [55aca0f74d]
Login
Overview
Comment:More edits
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | multi-area
Files: files | file ages | folders
SHA1: 55aca0f74d99fa66e2533842218f45bdb42766fc
User & Date: matt on 2015-04-05 18:58:59
Other Links: branch diff | manifest | tags
Context
2015-04-05
20:12
More conversion check-in: c42ba125bb user: matt tags: multi-area
18:58
More edits check-in: 55aca0f74d user: matt tags: multi-area
15:09
Sync up of partial edits check-in: bf62b354fe user: matt tags: multi-area
Changes

Modified dashboard-tests.scm from [877198e14c] to [8072d2165f].

41
42
43
44
45
46
47
48
49


50
51
52
53
54
55
56
41
42
43
44
45
46
47


48
49
50
51
52
53
54
55
56







-
-
+
+








(define *dashboard-comment-share-slot* #f)

(define (dtests:get-pre-command area-dat #!key (default-override #f))
  (let ((cfg-ovrd (configf:lookup (megatest:area-configdat area-dat) "dashboard" "pre-command")))
    (or cfg-ovrd default-override "xterm -geometry 180x20 -e \"")))

(define (dtests:get-post-command #!key (default-override #f))
  (let ((cfg-ovrd (configf:lookup *configdat* "dashboard" "post-command")))
(define (dtests:get-post-command area-dat  #!key (default-override #f))
  (let ((cfg-ovrd (configf:lookup (megatest:area-configdat area-dat) "dashboard" "post-command")))
    (or cfg-ovrd default-override ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &")))


(define (test-info-panel testdat store-label widgets)
  (iup:frame 
   #:title "Test Info" ; #:expand "YES"
   (iup:hbox ; #:expand "YES"
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
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







-
+
+
















-
-
+
+







													    (lambda (c)
													      (set! newcomment c)
													      (if wtxtbox 
														  (begin
														    (iup:attribute-set! wtxtbox "VALUE" c)
														    (if (not *dashboard-comment-share-slot*)
															(set! *dashboard-comment-share-slot* wtxtbox)))
														  ))))
														  ))
													    area-dat))
									  (begin
									    (rmt:test-set-state-status-by-id run-id test-id #f status #f)
									    (db:test-set-status! testdat status))))))))
				    btn))
				(map cadr *common:std-statuses*)))) ;; (list  "PASS" "WARN" "FAIL" "CHECK" "n/a" "WAIVED" "SKIP"))))
	       (vector-set! *state-status* 1
			    (lambda (status color)
			      (for-each 
			       (lambda (btn)
				 (let* ((name     (iup:attribute btn "TITLE"))
					(newcolor (if (equal? name status) color "192 192 192")))
				   (if (not (colors-similar? newcolor (iup:attribute btn "BGCOLOR")))
				       (iup:attribute-set! btn "BGCOLOR" newcolor))))
			       btns)))
	       btns))))))

(define (dashboard-tests:run-html-viewer lfilename)
  (let ((htmlviewercmd (configf:lookup *configdat* "setup" "htmlviewercmd")))
(define (dashboard-tests:run-html-viewer lfilename area-dat)
  (let ((htmlviewercmd (configf:lookup (megatest:area-configdat area-dat) "setup" "htmlviewercmd")))
    (if htmlviewercmd
	(system (conc "(" htmlviewercmd " " lfilename " ) &")) 
	(iup:send-url lfilename))))

(define (dashboard-tests:run-a-step info)
  #t)

351
352
353
354
355
356
357
358
359


360
361
362
363
364
365
366
352
353
354
355
356
357
358


359
360
361
362
363
364
365
366
367







-
-
+
+







					 (conc "ezstep run from step " stepname)))))
    ;; (iup:button "Refresh test data"
    ;;     	#:expand "HORIZONTAL"
    ;;     	#:action (lambda (obj)
    ;;     		   (print "Refresh test data " stepname))
    )))

(define (dashboard-tests:waiver run-id testdat ovrdval cmtcmd)
  (let* ((wpatt (configf:lookup *configdat* "setup" "waivercommentpatt"))
(define (dashboard-tests:waiver run-id testdat ovrdval cmtcmd area-dat)
  (let* ((wpatt (configf:lookup (megatest:area-configdat area-dat) "setup" "waivercommentpatt"))
	 (wregx (if (string? wpatt)(regexp wpatt) #f))
	 (wmesg (iup:label (if wpatt (conc "Comment must match pattern " wpatt) "")))
	 (comnt (iup:textbox #:action (lambda (val a b)
					(if wpatt
					    (if (string-match wregx b)
						(iup:attribute-set! wmesg "TITLE" (conc "Comment matches " wpatt))
						(iup:attribute-set! wmesg "TITLE" (conc "Comment does not match " wpatt))
397
398
399
400
401
402
403
404
405
406



407
408
409
410
411
412
413
398
399
400
401
402
403
404



405
406
407
408
409
410
411
412
413
414







-
-
-
+
+
+







					 (iup:destroy! dlog)))))))
    dlog))


;;======================================================================
;;
;;======================================================================
(define (examine-test run-id test-id) ;; run-id run-key origtest)
  (let* ((db-path       (db:dbfile-path run-id)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/db/" run-id ".db"))
	 (dbstruct      (make-dbr:dbstruct path:  (db:dbfile-path #f) ;; (configf:lookup *configdat* "setup" "linktree") 
(define (examine-test run-id test-id area-dat) ;; run-id run-key origtest)
  (let* ((db-path       (db:dbfile-path run-id))
	 (dbstruct      (make-dbr:dbstruct path:  (db:dbfile-path #f)
					   local: #t))
	 (testdat       (db:get-test-info-by-id dbstruct run-id test-id))
	 (db-mod-time   0) ;; (file-modification-time db-path))
	 (last-update   0) ;; (current-seconds))
	 (request-update #t))
    (if (not testdat)
	(begin
441
442
443
444
445
446
447
448

449
450
451
452
453
454
455

456
457
458
459
460
461
462
442
443
444
445
446
447
448

449
450
451
452
453
454
455

456
457
458
459
460
461
462
463







-
+






-
+







				   (cadr keyval))
				 keydat)
			    "/"))
	       (item-path  (db:test-get-item-path testdat))
	       (viewlog    (lambda (x)
			     (if (file-exists? logfile)
					;(system (conc "firefox " logfile "&"))
				 (dashboard-tests:run-html-viewer logfile)
				 (dashboard-tests:run-html-viewer logfile area-dat)
				 (message-window (conc "File " logfile " not found")))))
	       (view-a-log (lambda (lfile) 
			     (let ((lfilename (conc rundir "/" lfile)))
			       ;; (print "lfilename: " lfilename)
			       (if (file-exists? lfilename)
					;(system (conc "firefox " logfile "&"))
				   (dashboard-tests:run-html-viewer lfilename)
				   (dashboard-tests:run-html-viewer lfilename area-dat)
				   (message-window (conc "File " lfilename " not found"))))))
	       (xterm      (lambda (x)
			     (if (directory-exists? rundir)
				 (let ((shell (if (get-environment-variable "SHELL") 
						  (conc "-e " (get-environment-variable "SHELL"))
						  "")))
				   (system (conc "cd " rundir 
540
541
542
543
544
545
546
547

548
549

550
551
552
553
554
555
556
541
542
543
544
545
546
547

548
549

550
551
552
553
554
555
556
557







-
+

-
+







					;(mutex-unlock! mx1)
							 )))))
			      lbl))
	       (store-button store-label)
	       (command-text-box (iup:textbox #:expand "HORIZONTAL" #:font "Courier New, -10"))
	       (command-launch-button (iup:button "Execute!" #:action (lambda (x)
									(let* ((cmd     (iup:attribute command-text-box "VALUE"))
									       (fullcmd (conc (dtests:get-pre-command)
									       (fullcmd (conc (dtests:get-pre-command area-dat)
											      cmd 
											      (dtests:get-post-command))))
											      (dtests:get-post-command area-dat))))
									  (debug:print-info 02 "Running command: " fullcmd)
									  (system fullcmd)))))
	       (kill-jobs (lambda (x)
			    (iup:attribute-set! 
			     command-text-box "VALUE"
			     (conc "megatest -target " keystring " -runname "  runname 
				   " -set-state-status KILLREQ,n/a -testpatt %/% "
577
578
579
580
581
582
583
584

585
586

587
588
589
590
591
592
593
578
579
580
581
582
583
584

585
586

587
588
589
590
591
592
593
594







-
+

-
+







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

Modified dashboard.scm from [2ea14e20b7] to [c88733ec8c].

127
128
129
130
131
132
133
134
135
136




137
138
139
140
141
142
143
127
128
129
130
131
132
133



134
135
136
137
138
139
140
141
142
143
144







-
-
-
+
+
+
+







  (string-intersperse (map conc x) ","))

(define (update-search x val)
  (hash-table-set! *searchpatts* x val))

;; mtest is actually the megatest.config file
;;
(define (mtest window-id)
  (let* ((curr-row-num     0)
	 (rawconfig        (read-config (conc *toppath* "/megatest.config") #f 'return-string))
(define (mtest window-id area-dat)
  (let* ((toppath          (megatest:area-path area-dat))
	 (curr-row-num     0)
	 (rawconfig        (read-config (conc toppath "/megatest.config") #f 'return-string))
	 (keys-matrix      (dcommon:keys-matrix rawconfig))
	 (setup-matrix     (dcommon:section-matrix rawconfig "setup" "Varname" "Value"))
	 (jobtools-matrix  (iup:matrix
			    #:expand "YES"
			    #:numcol 1
			    #:numlin 5
			    #:numcol-visible 1

Modified db.scm from [356132297a] to [7e0be4c224].

119
120
121
122
123
124
125
126

127
128
129
130
131
132
133
119
120
121
122
123
124
125

126
127
128
129
130
131
132
133







-
+







;; K E E P   F I L E D B   I N   dbstruct
;;======================================================================

;; (define (db:get-filedb dbstruct run-id)
;;   (let ((db (vector-ref dbstruct 2)))
;;     (if db
;; 	db
;; 	(let ((fdb (filedb:open-db (conc *toplevel* "/db/files.db"))))
;; 	(let ((fdb (filedb:open-db (conc toppath "/db/files.db"))))
;; 	  (vector-set! dbstruct 2 fdb)
;; 	  fdb))))
;; 
;; ;; Can also be used to save arbitrary strings
;; ;;
;; (define (db:save-path dbstruct path)
;;   (let ((fdb (db:get-filedb dbstruct)))b
191
192
193
194
195
196
197
198

199
200
201
202
203
204
205
191
192
193
194
195
196
197

198
199
200
201
202
203
204
205







-
+







	      db)
	    (begin
	      (debug:print 0 "ERROR: no such db in non-writable dir " fname)
	      (sqlite3:open-database fname))))))

;; This routine creates the db. It is only called if the db is not already opened
;; 
(define (db:open-rundb dbstruct run-id #!key (attemptnum 0)(do-not-open #f)) ;;  (conc *toppath* "/megatest.db") (car *configinfo*)))
(define (db:open-rundb dbstruct run-id #!key (attemptnum 0)(do-not-open #f)) ;;  (conc toppath "/megatest.db") (car configinfo)))
  (let* ((local  (dbr:dbstruct-get-local dbstruct))
	 (rdb    (if local
		     (dbr:dbstruct-get-localdb dbstruct run-id)
		     (dbr:dbstruct-get-inmem dbstruct)))) ;; (dbr:dbstruct-get-runrec dbstruct run-id 'inmem)))
    (if (or rdb
	    do-not-open)
	rdb
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
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







-
+


















-
+





-
-
+
+
+







		;; sync once more to deal with delays?
		;; (db:sync-tables db:sync-tests-only db inmem)
		;; (db:sync-tables db:sync-tests-only inmem refdb)
		inmem))))))

;; This routine creates the db. It is only called if the db is not already ls opened
;;
(define (db:open-main dbstruct) ;;  (conc *toppath* "/megatest.db") (car *configinfo*)))
(define (db:open-main dbstruct) ;;  (conc toppath "/megatest.db") (car configinfo)))
  (let ((mdb (dbr:dbstruct-get-main dbstruct)))
    (if mdb
	mdb
	(let* ((dbpath       (db:dbfile-path 0))
	       (dbexists     (file-exists? dbpath))
	       (db           (db:lock-create-open dbpath db:initialize-main-db))
	       (olddb        (db:open-megatest-db))
	       (write-access (file-write-access? dbpath))
	       (dbdat        (cons db dbpath)))
	  (if (and dbexists (not write-access))
	      (set! *db-write-access* #f))
	  (dbr:dbstruct-set-main!   dbstruct dbdat)
	  (dbr:dbstruct-set-olddb!  dbstruct olddb) ;; olddb is already a (cons db path)
	  dbdat))))

;; Make the dbstruct, setup up auxillary db's and call for main db at least once
;;
(define (db:setup run-id #!key (local #f))
  (let* ((dbdir    (db:dbfile-path #f)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db"))
  (let* ((dbdir    (db:dbfile-path #f)) ;; (conc (configf:lookup configdat "setup" "linktree") "/.db"))
	 (dbstruct (make-dbr:dbstruct path: dbdir local: local)))
    dbstruct))

;; Open the classic megatest.db file in toppath
;;
(define (db:open-megatest-db)
  (let* ((dbpath       (conc *toppath* "/megatest.db"))
(define (db:open-megatest-db area-dat)
  (let* ((toppath      (megatest:area-path area-dat))
	 (dbpath       (conc toppath "/megatest.db"))
	 (dbexists     (file-exists? dbpath))
	 (db           (db:lock-create-open dbpath
					    (lambda (db)
					      (db:initialize-main-db db)
					      (db:initialize-run-id-db db))))
	 (write-access (file-write-access? dbpath)))
    (if (and dbexists (not write-access))
767
768
769
770
771
772
773
774

775
776
777
778
779
780
781
768
769
770
771
772
773
774

775
776
777
778
779
780
781
782







-
+







;; (define open-run-close 
(define open-run-close open-run-close-exception-handling)
		;;	   open-run-close-no-exception-handling
;;			   open-run-close-exception-handling)
;;)

(define (db:initialize-main-db dbdat area-dat)
  (let* ((configdat (megatest:area-configdat area-dat)) ;; (car *configinfo*))  ;; tut tut, global warning...
  (let* ((configdat (megatest:area-configdat area-dat)) ;; (car configinfo))  ;; tut tut, global warning...
	 (keys     (keys:config-get-fields configdat))
	 (havekeys (> (length keys) 0))
	 (keystr   (keys->keystr keys))
	 (fieldstr (keys->key/field keys))
	 (db       (db:dbdat-get-db dbdat)))
    (for-each (lambda (key)
		(let ((keyn key))
1077
1078
1079
1080
1081
1082
1083
1084
1085



1086
1087
1088
1089
1090
1091
1092
1078
1079
1080
1081
1082
1083
1084


1085
1086
1087
1088
1089
1090
1091
1092
1093
1094







-
-
+
+
+







;; 	 (blocks       '())) ;; a block is an archive chunck that can be added too if there is space
;;     (sqlite3:for-each-row  #f)

;;======================================================================
;; L O G G I N G    D B 
;;======================================================================

(define (open-logging-db) ;;  (conc *toppath* "/megatest.db") (car *configinfo*)))
  (let* ((dbpath    (conc (if *toppath* (conc *toppath* "/") "") "logging.db")) ;; fname)
(define (open-logging-db area-dat) ;;  (conc toppath "/megatest.db") (car configinfo)))
  (let* ((toppath   (megatest:area-path area-dat))
	 (dbpath    (conc (if toppath (conc toppath "/") "") "logging.db")) ;; fname)
	 (dbexists  (file-exists? dbpath))
	 (db        (sqlite3:open-database dbpath))
	 (handler   (make-busy-timeout (if (args:get-arg "-override-timeout")
					   (string->number (args:get-arg "-override-timeout"))
					   136000)))) ;; 136000)))
    (sqlite3:set-busy-handler! db handler)
    (if (not dbexists)
1441
1442
1443
1444
1445
1446
1447
1448

1449
1450
1451
1452
1453
1454
1455
1443
1444
1445
1446
1447
1448
1449

1450
1451
1452
1453
1454
1455
1456
1457







-
+







	      (lambda (db)
		(sqlite3:execute db "DELETE FROM metadat WHERE var=?;" var))))

;; use a global for some primitive caching, it is just silly to
;; re-read the db over and over again for the keys since they never
;; change

;; why get the keys from the db? why not get from the *configdat*
;; why get the keys from the db? why not get from the configdat
;; using keys:config-get-fields?

(define (db:get-keys dbstruct)
  (let ((res '()))
    (db:with-db dbstruct #f #f
		(lambda (db)
		  (sqlite3:for-each-row 
2828
2829
2830
2831
2832
2833
2834
2835

2836
2837
2838


2839
2840
2841
2842
2843
2844
2845
2830
2831
2832
2833
2834
2835
2836

2837
2838


2839
2840
2841
2842
2843
2844
2845
2846
2847







-
+

-
-
+
+







			       immediate
			       flush
			       sync
			       set-verbosity
			       killserver
			       ))

(define (db:login dbstruct calling-path calling-version run-id client-signature)
(define (db:login dbstruct area-dat calling-path calling-version run-id client-signature)
  (cond 
   ((not (equal? calling-path *toppath*))
    (list #f "Login failed due to mismatch paths: " calling-path ", " *toppath*))
   ((not (equal? calling-path (megatest:area-path area-dat)))
    (list #f "Login failed due to mismatch paths: " calling-path ", " (megatest:area-path area-dat)))
   ((not (equal? *run-id* run-id))
    (list #f "Login failed due to mismatch run-id: " run-id ", " *run-id*))
   ((not (equal? megatest-version calling-version))
    (list #f "Login failed due to mismatch megatest version: " calling-version ", " megatest-version))
   (else
    (hash-table-set! *logged-in-clients* client-signature (current-seconds))
    '(#t "successful login"))))

Modified dcommon.scm from [ae6e0ff941] to [203653f6f0].

387
388
389
390
391
392
393
394

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

394
395
396
397
398
399
400
401







-
+







    ;; (iup:attribute-set! keys-matrix "WIDTH1" "100")
    ;; fill in keys
    (for-each 
     (lambda (var)
       ;; (iup:attribute-set! keys-matrix "ADDLIN" (conc curr-row-num))
       (iup:attribute-set! keys-matrix (conc curr-row-num ":0") curr-row-num)
       (iup:attribute-set! keys-matrix (conc curr-row-num ":1") var)
       (set! curr-row-num (+ 1 curr-row-num))) ;; (config-lookup *configdat* "fields" var)))
       (set! curr-row-num (+ 1 curr-row-num))) ;; (config-lookup configdat "fields" var)))
     key-vals)
    (iup:attribute-set! keys-matrix "WIDTHDEF" "40")
    keys-matrix))

;; Section to table
(define (dcommon:section-matrix rawconfig sectionname varcolname valcolname #!key (title #f))
  (let* ((curr-row-num    1)
413
414
415
416
417
418
419
420

421
422
423
424
425
426
427
413
414
415
416
417
418
419

420
421
422
423
424
425
426
427







-
+







    (iup:attribute-set! section-matrix "WIDTH1" "200")
    ;; fill in keys
    (for-each 
     (lambda (var)
       ;; (iup:attribute-set! keys-matrix "ADDLIN" (conc curr-row-num))
       (iup:attribute-set! section-matrix (conc curr-row-num ":0") var)
       (iup:attribute-set! section-matrix (conc curr-row-num ":1") (configf:lookup rawconfig sectionname var))
       (set! curr-row-num (+ 1 curr-row-num))) ;; (config-lookup *configdat* "fields" var)))
       (set! curr-row-num (+ 1 curr-row-num))) ;; (config-lookup configdat "fields" var)))
     key-vals)
    (iup:vbox
     (iup:label (if title title (conc "Settings from [" sectionname "]"))  
         	;; #:size   "5x"
         	#:expand "HORIZONTAL"
         	)
     section-matrix)))
439
440
441
442
443
444
445
446

447
448
449
450
451
452
453
439
440
441
442
443
444
445

446
447
448
449
450
451
452
453







-
+







    (iup:attribute-set! general-matrix "WIDTH1" "150")
    (iup:attribute-set! general-matrix "0:1" "About this Megatest area") 
    ;; User (this is not always obvious - it is common to run as a different user
    (iup:attribute-set! general-matrix "1:0" "User")
    (iup:attribute-set! general-matrix "1:1" (current-user-name))
    ;; Megatest area
    ;; (iup:attribute-set! general-matrix "2:0" "Area")
    ;; (iup:attribute-set! general-matrix "2:1" *toppath*)
    ;; (iup:attribute-set! general-matrix "2:1" toppath)
    ;; Megatest version
    (iup:attribute-set! general-matrix "2:0" "Version")
    (iup:attribute-set! general-matrix "2:1" (conc megatest-version "-" (substring megatest-fossil-hash 0 4)))

    general-matrix))

(define (dcommon:run-stats dbstruct)

Modified http-transport.scm from [4b37e6ffd7] to [6df4b07013].

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







-
+

+
-
+







-
+







	   (set! res adr)))
     (vector->list (hostinfo-addresses (hostname->hostinfo hostname))))
    (string-intersperse 
     (map number->string
	  (u8vector->list
	   (if res res (hostname->ip hostname)))) ".")))

(define (http-transport:run hostn run-id server-id)
(define (http-transport:run hostn run-id server-id area-dat)
  (debug:print 2 "Attempting to start the server ...")
  (let* ((configdat       (megatest:area-configdat area-dat))
  (let* ((db              #f) ;;        (open-db)) ;; we don't want the server to be opening and closing the db unnecesarily
	 (db              #f) ;;        (open-db)) ;; we don't want the server to be opening and closing the db unnecesarily
	 (hostname        (get-host-name))
	 (ipaddrstr       (let ((ipstr (if (string=? "-" hostn)
					   ;; (string-intersperse (map number->string (u8vector->list (hostname->ip hostname))) ".")
					   (server:get-best-guess-address hostname)
					   #f)))
			    (if ipstr ipstr hostn))) ;; hostname))) 
	 (start-port      (portlogger:open-run-close portlogger:find-port))
	 (link-tree-path  (configf:lookup *configdat* "setup" "linktree")))
	 (link-tree-path  (configf:lookup configdat "setup" "linktree")))
    ;; (set! db *inmemdb*)
    (debug:print-info 0 "portlogger recommended port: " start-port)
    (root-path     (if link-tree-path 
		       link-tree-path
		       (current-directory))) ;; WARNING: SECURITY HOLE. FIX ASAP!
    (handle-directory spiffy-directory-listing)
    (handle-exception (lambda (exn chain)
92
93
94
95
96
97
98
99

100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119

120
121
122
123
124
125



126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144


145
146
147
148
149
150
151
93
94
95
96
97
98
99

100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119

120
121
122
123



124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144

145
146
147
148
149
150
151
152
153







-
+



















-
+



-
-
-
+
+
+


















-
+
+







				 ;; This is were we set up the database connections
			       (let* (($   (request-vars source: 'both))
				      (dat ($ 'dat))
				      (res #f))
				 (cond
				  ((equal? (uri-path (request-uri (current-request)))
					   '(/ "api"))
				   (send-response body:    (api:process-request *inmemdb* $) ;; the $ is the request vars proc
				   (send-response body:    (api:process-request *inmemdb* area-dat $) ;; the $ is the request vars proc
						  headers: '((content-type text/plain)))
				   (mutex-lock! *heartbeat-mutex*)
				   (set! *last-db-access* (current-seconds))
				   (mutex-unlock! *heartbeat-mutex*))
				  ((equal? (uri-path (request-uri (current-request))) 
					   '(/ ""))
				   (send-response body: (http-transport:main-page)))
				  ((equal? (uri-path (request-uri (current-request))) 
					   '(/ "runs"))
				   (send-response body: (http-transport:main-page)))
				  ((equal? (uri-path (request-uri (current-request))) 
					   '(/ any))
				   (send-response body: "hey there!\n"
						  headers: '((content-type text/plain))))
				  ((equal? (uri-path (request-uri (current-request))) 
					   '(/ "hey"))
				   (send-response body: "hey there!\n"
						  headers: '((content-type text/plain))))
				  (else (continue))))))))
    (http-transport:try-start-server run-id ipaddrstr start-port server-id)))
    (http-transport:try-start-server run-id ipaddrstr start-port server-id area-dat)))

;; This is recursively run by http-transport:run until sucessful
;;
(define (http-transport:try-start-server run-id ipaddrstr portnum server-id)
  (let ((config-hostname (configf:lookup *configdat* "server" "hostname"))
	(tdbdat          (tasks:open-db)))
(define (http-transport:try-start-server run-id ipaddrstr portnum server-id area-dat)
  (let ((config-hostname (configf:lookup (megatest:area-configdat area-dat) "server" "hostname"))
	(tdbdat          (tasks:open-db area-dat)))
    (debug:print-info 0 "http-transport:try-start-server run-id=" run-id " ipaddrsstr=" ipaddrstr " portnum=" portnum " server-id=" server-id " config-hostname=" config-hostname)
    (handle-exceptions
     exn
     (begin
       (print-error-message exn)
       (if (< portnum 64000)
	   (begin 
	     (debug:print 0 "WARNING: attempt to start server failed. Trying again ...")
	     (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))
	     (debug:print 0 "exn=" (condition->list exn))
	     (portlogger:open-run-close portlogger:set-failed portnum)
	     (debug:print 0 "WARNING: failed to start on portnum: " portnum ", trying next port")
	     (thread-sleep! 0.1)

	     ;; get_next_port goes here
	     (http-transport:try-start-server run-id
					      ipaddrstr
					      (portlogger:open-run-close portlogger:find-port)
					      server-id))
					      server-id
					      area-dat))
	   (begin
	     (tasks:server-force-clean-run-record (db:delay-if-busy tdbdat) run-id ipaddrstr portnum " http-transport:try-start-server")
	     (print "ERROR: Tried and tried but could not start the server"))))
     ;; any error in following steps will result in a retry
     (set! *server-info* (list ipaddrstr portnum))
     (tasks:server-set-interface-port 
		     (db:delay-if-busy tdbdat)
468
469
470
471
472
473
474
475

476
477
478
479
480
481
482
470
471
472
473
474
475
476

477
478
479
480
481
482
483
484







-
+







      (set! last-access *last-db-access*)
      (mutex-unlock! *heartbeat-mutex*)

      ;; (debug:print 11 "last-access=" last-access ", server-timeout=" server-timeout)
      ;;
      ;; no_traffic, no running tests, if server 0, no running servers
      ;;
      ;; (let ((wait-on-running (configf:lookup *configdat* "server" "wait-on-running"))) ;; wait on running tasks (if not true then exit on time out)
      ;; (let ((wait-on-running (configf:lookup configdat "server" "wait-on-running"))) ;; wait on running tasks (if not true then exit on time out)
      ;;
      (if (and *server-run*
	       (> (+ last-access server-timeout)
		  (current-seconds)))
	  (begin
	    (debug:print-info 0 "Server continuing, seconds since last db access: " (- (current-seconds) last-access))
	    ;;
520
521
522
523
524
525
526
527

528
529
530
531
532
533
534
522
523
524
525
526
527
528

529
530
531
532
533
534
535
536







-
+







    (tasks:server-delete-record (db:delay-if-busy tdbdat) server-id " http-transport:keep-running complete")
    (exit)))

;; all routes though here end in exit ...
;;
;; start_server? 
;;
(define (http-transport:launch run-id)
(define (http-transport:launch run-id area-dat)
  (let* ((tdbdat (tasks:open-db)))
    (set! *run-id*   run-id)
    (if (args:get-arg "-daemonize")
	(begin
	  (daemon:ize)
	  (if *alt-log-file* ;; we should re-connect to this port, I think daemon:ize disrupts it
	      (begin
554
555
556
557
558
559
560
561


562
563
564
565
566
567
568
556
557
558
559
560
561
562

563
564
565
566
567
568
569
570
571







-
+
+







	  (let* ((th2 (make-thread (lambda ()
				     (debug:print-info 0 "Server run thread started")
				     (http-transport:run 
				      (if (args:get-arg "-server")
					  (args:get-arg "-server")
					  "-")
				      run-id
				      server-id)) "Server run"))
				      server-id
				      area-dat)) "Server run"))
		 (th3 (make-thread (lambda ()
				     (debug:print-info 0 "Server monitor thread started")
				     (http-transport:keep-running server-id run-id))
				   "Keep running")))
	    (thread-start! th2)
	    (thread-sleep! 0.25) ;; give the server time to settle before starting the keep-running monitor.
	    (thread-start! th3)
600
601
602
603
604
605
606
607
608
609




610
611

612
613
614
615
616
617
618
603
604
605
606
607
608
609



610
611
612
613
614

615
616
617
618
619
620
621
622







-
-
-
+
+
+
+

-
+







     (thread-start! th1)
     (thread-join! th2))))

;;======================================================================
;; web pages
;;======================================================================

(define (http-transport:main-page)
  (let ((linkpath (root-path)))
    (conc "<head><h1>" (pathname-strip-directory *toppath*) "</h1></head>"
(define (http-transport:main-page area-dat)
  (let* ((toppath  (megatest:area-path area-dat))
	 (linkpath (root-path)))
    (conc "<head><h1>" (pathname-strip-directory toppath) "</h1></head>"
	  "<body>"
	  "Run area: " *toppath*
	  "Run area: " toppath
	  "<h2>Server Stats</h2>"
	  (http-transport:stats-table) 
	  "<hr>"
	  (http-transport:runs linkpath)
	  "<hr>"
	  (http-transport:run-stats)
	  "</body>"

Modified items.scm from [8234d9cd3a] to [afecb07c08].

125
126
127
128
129
130
131
132
133


134
135
136
137
138
139
140
125
126
127
128
129
130
131


132
133
134
135
136
137
138
139
140







-
-
+
+







	    (set! res (append res (list item)))
	    (loop (+ indx 1)
		  '()
		  #f)))
      res)))
            ;; Nope, not now, return null as of 6/6/2011
		
(define (items:check-valid-items class item)
  (let ((valid-values (let ((s (config-lookup *configdat* "validvalues" class)))
(define (items:check-valid-items class item area-dat)
  (let ((valid-values (let ((s (config-lookup (megatest:area-configdat area-dat) "validvalues" class)))
			(if s (string-split s) #f))))
    (if valid-values
	(if (member item valid-values)
	    item #f)
	item)))

(define (items:get-items-from-config tconfig)

Modified launch.scm from [18f0576fe7] to [c48e97b3ce].

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







-
+







-
+





-
-
+
+







		(tests:test-force-state-status! run-id test-id "REMOTEHOSTSTART" "n/a")
		(begin
		  (debug:print 0 "ERROR: test state is " (db:test-get-state test-info) ", cannot proceed")
		  (exit))))
	  
	  (debug:print 2 "Exectuing " test-name " (id: " test-id ") on " (get-host-name))
	  (set! keys       (rmt:get-keys area-dat))
	  ;; (runs:set-megatest-env-vars run-id inkeys: keys inkeyvals: keyvals) ;; these may be needed by the launching process
	  ;; (runs:set-megatest-env-vars run-id area-dat inkeys: keys inkeyvals: keyvals) ;; these may be needed by the launching process
	  ;; one of these is defunct/redundant ...
	  (if (not (launch:setup-for-run area-dat force: #t))
	      (begin
		(debug:print 0 "Failed to setup, exiting") 
		;; (sqlite3:finalize! db)
		;; (sqlite3:finalize! tdb)
		(exit 1)))
	  (change-directory *toppath*) 
	  (change-directory toppath) 

	  ;; NOTE: Current order is to process runconfigs *before* setting the MT_ vars. This 
	  ;;       seems non-ideal but could well break stuff
	  ;;    BUG? BUG? BUG?

	  (let ((rconfig (full-runconfigs-read))) ;; (read-config (conc  *toppath* "/runconfigs.config") #f #t sections: (list "default" target))))
	    ;; (setup-env-defaults (conc *toppath* "/runconfigs.config") run-id (make-hash-table) keyvals target)
	  (let ((rconfig (full-runconfigs-read))) ;; (read-config (conc  toppath "/runconfigs.config") #f #t sections: (list "default" target))))
	    ;; (setup-env-defaults (conc toppath "/runconfigs.config") run-id (make-hash-table) keyvals target)
	    ;; (set-run-config-vars run-id keyvals target) ;; (db:get-target db run-id))
	    ;; Now have runconfigs data loaded, set environment vars
	    (for-each (lambda (section)
			(for-each (lambda (varval)
				    (let ((var (car varval))
					  (val (cadr varval)))
				      (if (and (string? var)(string? val))
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
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







-
+










-
+







	      (list  "MT_TEST_RUN_DIR" work-area)
	      (list  "MT_TEST_NAME" test-name)
	      (list  "MT_ITEM_INFO" (conc itemdat))
	      (list  "MT_ITEMPATH"  item-path)
	      (list  "MT_RUNNAME"   runname)
	      (list  "MT_MEGATEST"  megatest)
	      (list  "MT_TARGET"    target)
	      (list  "MT_LINKTREE"  (configf:lookup *configdat* "setup" "linktree"))
	      (list  "MT_LINKTREE"  (configf:lookup (megatest:area-configdat area-dat) "setup" "linktree"))
	      (list  "MT_TESTSUITENAME" (common:get-testsuite-name))))

	  (if mt-bindir-path (setenv "PATH" (conc (getenv "PATH") ":" mt-bindir-path)))
	  ;; (change-directory top-path)
	  ;; Can setup as client for server mode now
	  ;; (client:setup)

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

Modified megatest.scm from [13327633c3] to [2c79680544].

430
431
432
433
434
435
436

437

438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456

457
458
459
460
461
462
463
430
431
432
433
434
435
436
437

438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456

457
458
459
460
461
462
463
464







+
-
+


















-
+








(if (args:get-arg "-itempatt")
    (let ((newval (conc (args:get-arg "-testpatt") "/" (args:get-arg "-itempatt"))))
      (debug:print 0 "WARNING: -itempatt has been deprecated, please use -testpatt testpatt/itempatt method, new testpatt is "newval)
      (hash-table-set! args:arg-hash "-testpatt" newval)
      (hash-table-delete! args:arg-hash "-itempatt")))

(on-exit (lambda ()
(on-exit std-exit-procedure)
	   (std-exit-procedure *area-dat*)))

;;======================================================================
;; Misc general calls
;;======================================================================

(if (args:get-arg "-env2file")
    (begin
      (save-environment-as-files (args:get-arg "-env2file"))
      (set! *didsomething* #t)))

(if (args:get-arg "-list-disks")
    (let ((toppath (launch:setup-for-run *area-dat*)))
      (print 
       (string-intersperse 
	(map (lambda (x)
	       (string-intersperse 
		x
		" => "))
	     (common:get-disks *configdat*))
	     (common:get-disks (megatest:area-configdat *area-dat*)))
	"\n"))
      (set! *didsomething* #t)))

(define (make-sparse-array)
  (let ((a (make-sparse-vector)))
    (sparse-vector-set! a 0 (make-sparse-vector))
    a))
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
635
636
637
638
639
640
641








642
643
644
645
646
647
648







-
-
-
-
-
-
-
-







      ))

(if (args:get-arg "-ping")
    (let* ((run-id        (string->number (args:get-arg "-run-id")))
	   (host:port     (args:get-arg "-ping")))
      (server:ping run-id host:port)))

;;       (set! *did-something* #t)
;; 	      (begin
;; 		(print ((rpc:procedure 'testing (car host-port)(cadr host-port))))
;; 		(case (server:get-transport)
;; 		  ((http)(http:ping run-id host-port))
;; 		  ((rpc) (rpc:procedure 'server:login (car host-port)(cadr host-port));;  *toppath*)) ;; (rpc-transport:ping  run-id (car host-port)(cadr host-port)))
;; 		  (else  (debug:print 0 "ERROR: No transport set")(exit)))))

;;======================================================================
;; Start the server - can be done in conjunction with -runall or -runtests (one day...)
;;   we start the server if not running else start the client thread
;;======================================================================

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

674
675
676
677
678
679
680
681

682
683
684
685
686
687
688
689
690
691
692
693
694

695
696
697
698
699
700
701
667
668
669
670
671
672
673

674
675
676
677
678
679
680
681
682
683
684
685
686

687
688
689
690
691
692
693
694







-
+












-
+







		       "-stop-server"
		       "-show-cmdinfo"
		       "-list-runs"
		       "-ping")))
	(if (launch:setup-for-run *area-dat*)
	    (let ((run-id    (and (args:get-arg "-run-id")
				  (string->number (args:get-arg "-run-id")))))
	      ;; (set! *fdb*   (filedb:open-db (conc *toppath* "/db/paths.db")))
	      ;; (set! *fdb*   (filedb:open-db (conc toppath "/db/paths.db")))
	      ;; if not list or kill then start a client (if appropriate)
	      (if (or (args-defined? "-h" "-version" "-gen-megatest-area" "-gen-megatest-test")
		      (eq? (length (hash-table-keys args:arg-hash)) 0))
		  (debug:print-info 1 "Server connection not needed")
		  (begin
		    ;; (if run-id 
		    ;;     (client:launch run-id) 
		    ;;     (client:launch 0)      ;; without run-id we'll start a server for "0"
		    #t
		    ))))))

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

(if (or (args:get-arg "-list-servers")
	(args:get-arg "-stop-server"))
    (let ((tl (launch:setup-for-run *area-dat*)))
      (if tl 
	  (let* ((tdbdat  (tasks:open-db))
		 (servers (tasks:get-all-servers (db:delay-if-busy tdbdat)))
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
786
787
788
789
790
791
792
793
794
795
796


797
798
799
800
801
802
803
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
786
787
788


789
790
791
792
793
794
795
796
797







-
-
-
+
+
+
+



-
+




-
+





-
+


















-
-
+
+







      (print "Found "(length targets) " targets")
      (for-each (lambda (x)
		  ;; (print "[" x "]"))
		  (print x))
		targets)
      (set! *didsomething* #t)))

(define (full-runconfigs-read)
  (let* ((keys   (rmt:get-keys))
	 (target (common:args-get-target))
(define (full-runconfigs-read area-dat)
  (let* ((toppath  (megatest:area-path area-dat))
	 (keys     (rmt:get-keys))
	 (target   (common:args-get-target))
	 (key-vals (if target (keys:target->keyval keys target) #f))
	 (sections (if target (list "default" target) #f))
	 (data     (begin
		     (setenv "MT_RUN_AREA_HOME" *toppath*)
		     (setenv "MT_RUN_AREA_HOME" toppath)
		     (if key-vals
			 (for-each (lambda (kt)
				     (setenv (car kt) (cadr kt)))
				   key-vals))
		     (read-config (conc *toppath* "/runconfigs.config") #f #t sections: sections))))
		     (read-config (conc toppath "/runconfigs.config") #f #t sections: sections))))
    data))


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

(if (args:get-arg "-show-config")
    (let ((tl   (launch:setup-for-run *area-dat*))
	  (data *configdat*)) ;; (read-config "megatest.config" #f #t)))
      (push-directory *toppath*)
	  (data (megatest:area-configdat *area-dat*)))
      (push-directory (megatest:area-path *area-dat*))
      ;; keep this one local
      (cond 
       ((and (args:get-arg "-section")
	     (args:get-arg "-var"))
	(let ((val (configf:lookup data (args:get-arg "-section")(args:get-arg "-var"))))
	  (if val (print val))))
       ((not (args:get-arg "-dumpmode"))
820
821
822
823
824
825
826
827
828
829




830
831
832
833
834
835
836
837
838
839
840
841
842

843
844
845
846
847
848
849
850

851
852
853
854
855
856
857
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
844
845
846
847
848
849
850
851
852
853







-
-
-
+
+
+
+












-
+








+








;;======================================================================
;; Remove old run(s)
;;======================================================================

;; since several actions can be specified on the command line the removal
;; is done first
(define (operate-on action)
  (let* ((runrec (runs:runrec-make-record))
	 (target (common:args-get-target)))
(define (operate-on action area-dat)
  (let* ((runrec     (runs:runrec-make-record))
	 (target     (common:args-get-target))
	 (configinfo (megatest:area-configinfo area-dat)))
    (cond
     ((not target)
      (debug:print 0 "ERROR: Missing required parameter for " action ", you must specify -target or -reqtarg")
      (exit 1))
     ((not (or (args:get-arg ":runname")
	       (args:get-arg "-runname")))
      (debug:print 0 "ERROR: Missing required parameter for " action ", you must specify the run name pattern with -runname patt")
      (exit 2))
     ((not (args:get-arg "-testpatt"))
      (debug:print 0 "ERROR: Missing required parameter for " action ", you must specify the test pattern with -testpatt")
      (exit 3))
     (else
      (if (not (car *configinfo*))
      (if (not (car configinfo))
	  (begin
	    (debug:print 0 "ERROR: Attempted " action "on test(s) but run area config file not found")
	    (exit 1))
	  ;; put test parameters into convenient variables
	  (runs:operate-on  action
			    target
			    (or (args:get-arg "-runname")(args:get-arg ":runname"))
			    (args:get-arg "-testpatt")
			    area-dat
			    state: (or (args:get-arg "-state")(args:get-arg ":state") )
			    status: (or (args:get-arg "-status")(args:get-arg ":status"))
			    new-state-status: (args:get-arg "-set-state-status")))
      (set! *didsomething* #t)))))
	  
(if (args:get-arg "-remove-runs")
    (general-run-call 
897
898
899
900
901
902
903
904

905
906
907
908
909
910
911
893
894
895
896
897
898
899

900
901
902
903
904
905
906
907







-
+







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

;; NOTE: list-runs and list-db-targets operate on local db!!!
;;
(if (or (args:get-arg "-list-runs")
	(args:get-arg "-list-db-targets"))
    (if (launch:setup-for-run *area-dat*)
	(let* ((dbstruct (make-dbr:dbstruct path: *toppath* local: #t))
	(let* ((dbstruct (make-dbr:dbstruct path: (megatest:area-path *area-dat*) local: #t))
	       (runpatt  (args:get-arg "-list-runs"))
	       (testpatt (if (args:get-arg "-testpatt") 
			     (args:get-arg "-testpatt") 
			     "%"))
	       (keys     (db:get-keys dbstruct))
	       ;; (runsdat  (db:get-runs dbstruct runpatt #f #f '()))
	       (runsdat  (db:get-runs-by-patt dbstruct keys (or runpatt "%") (common:args-get-target)
1172
1173
1174
1175
1176
1177
1178
1179

1180
1181
1182
1183
1184
1185
1186
1168
1169
1170
1171
1172
1173
1174

1175
1176
1177
1178
1179
1180
1181
1182







-
+







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

(if (args:get-arg "-extract-ods")
    (general-run-call
     "-extract-ods"
     "Make ods spreadsheet"
     (lambda (target runname keys keyvals)
       (let ((dbstruct   (make-dbr:dbstruct path: *toppath* local: #t))
       (let ((dbstruct   (make-dbr:dbstruct path: (megatest:area-path *area-dat*) local: #t))
	     (outputfile (args:get-arg "-extract-ods"))
	     (runspatt   (or (args:get-arg "-runname")(args:get-arg ":runname")))
	     (pathmod    (args:get-arg "-pathmod")))
	     ;; (keyvalalist (keys->alist keys "%")))
	 (debug:print 2 "Extract ods, outputfile: " outputfile " runspatt: " runspatt " keyvals: " keyvals)
	 (db:extract-ods-file dbstruct outputfile keyvals (if runspatt runspatt "%") pathmod)
	 (db:close-all dbstruct)

Modified mt.scm from [15956fcc00] to [040113cf66].

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







-
-
+
+
+


-
+






-
+










-
+



	(mt:process-triggers run-id test-id newstate newstatus)
	#t)))

(define (mt:test-set-state-status-by-testname run-id test-name item-path new-state new-status new-comment)
  (let ((test-id (cdb:remote-run db:get-test-id-cached #f run-id test-name item-path)))
    (mt:test-set-state-status-by-id test-id new-state new-status new-comment)))

(define (mt:lazy-read-test-config test-name)
  (let ((tconf (hash-table-ref/default *testconfigs* test-name #f)))
(define (mt:lazy-read-test-config test-name area-dat)
  (let ((tconf (hash-table-ref/default *testconfigs* test-name #f))
	(configdat (megatest:area-configdat area-dat)))
    (if tconf
	tconf
	(let ((test-dirs (tests:get-tests-search-path *configdat*)))
	(let ((test-dirs (tests:get-tests-search-path configdat area-dat)))
	  (let loop ((hed (car test-dirs))
		     (tal (cdr test-dirs)))
	    ;; Setting MT_LINKTREE here is almost certainly unnecessary. 
	    (let ((tconfig-file (conc hed "/" test-name "/testconfig")))
	      (if (and (file-exists? tconfig-file)
		       (file-read-access? tconfig-file))
		  (let ((link-tree-path (configf:lookup *configdat* "setup" "linktree"))
		  (let ((link-tree-path (configf:lookup configdat "setup" "linktree"))
			(old-link-tree  (get-environment-variable "MT_LINKTREE")))
		    (if link-tree-path (setenv "MT_LINKTREE" link-tree-path))
		    (let ((newtcfg (read-config tconfig-file #f #f))) ;; NOTE: Does NOT run [system ...]
		      (hash-table-set! *testconfigs* test-name newtcfg)
		      (if old-link-tree 
			  (setenv "MT_LINKTREE" old-link-tree)
			  (unsetenv "MT_LINKTREE"))
		      newtcfg))
		  (if (null? tal)
		      (begin
			(debug:print 0 "ERROR: No readable testconfig found for " test-name)
			(debug:print-info 0 "No readable testconfig found for " test-name)
			#f)
		      (loop (car tal)(cdr tal))))))))))

Modified newdashboard.scm from [9c6040697d] to [8553f36743].

81
82
83
84
85
86
87
88

89
90
91
92
93
94
95
81
82
83
84
85
86
87

88
89
90
91
92
93
94
95







-
+







;;     (client:launch))

;; ease debugging by loading ~/.dashboardrc
(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.dashboardrc")))
  (if (file-exists? debugcontrolf)
      (load debugcontrolf)))

(define *dbdir* (db:dbfile-path #f)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db"))
(define *dbdir* (db:dbfile-path #f)) ;; (conc (configf:lookup configdat "setup" "linktree") "/.db"))
(define *dbstruct-local*  (make-dbr:dbstruct path:  *dbdir*
					     local: #t))
(define *db-file-path* (db:dbfile-path 0))

;; HACK ALERT: this is a hack, please fix.
(define *read-only* (not (file-read-access? *db-file-path*)))

127
128
129
130
131
132
133
134

135
136

137
138
139
140
141
142
143
127
128
129
130
131
132
133

134
135

136
137
138
139
140
141
142
143







-
+

-
+







  (string-intersperse (map conc x) ","))

(define (update-search x val)
  (hash-table-set! *searchpatts* x val))

;; mtest is actually the megatest.config file
;;
(define (mtest window-id)
(define (mtest window-id area-dat)
  (let* ((curr-row-num     0)
	 (rawconfig        (read-config (conc *toppath* "/megatest.config") #f 'return-string))
	 (rawconfig        (read-config (conc (megatest:area-path area-dat) "/megatest.config") #f 'return-string))
	 (keys-matrix      (dcommon:keys-matrix rawconfig))
	 (setup-matrix     (dcommon:section-matrix rawconfig "setup" "Varname" "Value"))
	 (jobtools-matrix  (iup:matrix
			    #:expand "YES"
			    #:numcol 1
			    #:numlin 5
			    #:numcol-visible 1
577
578
579
580
581
582
583
584

585
586
587
588
589
590
591
592
593
594





595
596
597
598
599
600
601
577
578
579
580
581
582
583

584
585
586
587
588
589





590
591
592
593
594
595
596
597
598
599
600
601







-
+





-
-
-
-
-
+
+
+
+
+







  (iup:hbox))

;;======================================================================
;; D A S H B O A R D
;;======================================================================

;; Main Panel
(define (main-panel window-id)
(define (main-panel window-id area-dat)
  (iup:dialog
   #:title "Megatest Control Panel"
   #:menu (dcommon:main-menu)
   #:shrink "YES"
   (let ((tabtop (iup:tabs 
		  (runs window-id)
		  (tests window-id)
		  (runcontrol window-id)
		  (mtest window-id) 
		  (rconfig window-id)
		  (runs       window-id area-dat)
		  (tests      window-id area-dat)
		  (runcontrol window-id area-dat)
		  (mtest      window-id area-dat) 
		  (rconfig    window-id area-dat)
		  )))
     (iup:attribute-set! tabtop "TABTITLE0" "Runs")
     (iup:attribute-set! tabtop "TABTITLE1" "Tests")
     (iup:attribute-set! tabtop "TABTITLE2" "Run Control")
     (iup:attribute-set! tabtop "TABTITLE3" "megatest.config") 
     (iup:attribute-set! tabtop "TABTITLE4" "runconfigs.config")
     tabtop)))

Modified nmsg-transport.scm from [0e4df34ad1] to [43df6f5458].

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

111
112
113
114
115
116
117
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
99
100
101
102
103
104
105
106
107
108
109

110
111
112
113
114
115
116
117







-
+

















-
+







-
+

















-
+







(define *server-loop-heart-beat* (current-seconds))
(define *heartbeat-mutex* (make-mutex))

;;======================================================================
;; S E R V E R
;;======================================================================

(define (nmsg-transport:run dbstruct hostn run-id server-id #!key (retrynum 1000))
(define (nmsg-transport:run dbstruct area-dat hostn run-id server-id #!key (retrynum 1000))
  (debug:print 2 "Attempting to start the server ...")
  (let* ((start-port      (portlogger:open-run-close portlogger:find-port))
	 (server-thread   (make-thread (lambda ()
					 (nmsg-transport:try-start-server dbstruct run-id start-port server-id))
				       "server thread"))
	 (tdbdat          (tasks:open-db)))
    (thread-start! server-thread)
    (thread-sleep! 0.1)
    (if (nmsg-transport:ping hostn start-port timeout: 2 expected-key: (current-process-id))
	(let ((interface (if (equal? hostn "-")(get-host-name) hostn)))
	  (tasks:server-set-interface-port (db:delay-if-busy tdbdat) server-id interface start-port)
	  (tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "dbprep")
	  (set! *server-info* (list hostn start-port)) ;; probably not needed anymore? currently used by keep-running
	  (thread-sleep! 3) ;; give some margin for queries to complete before switching from file based access to server based access
	  ;; (set! *inmemdb*  dbstruct)
	  (tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "running")
	  (thread-start! (make-thread
			  (lambda ()(nmsg-transport:keep-running server-id run-id))
			  (lambda ()(nmsg-transport:keep-running server-id run-id area-dat))
			  "keep running"))
	  (thread-join! server-thread))
	(if (> retrynum 0)
	    (begin
	      (debug:print 0 "WARNING: Failed to connect to server (self) on host " hostn ":" start-port ", trying again.")
	      (tasks:server-delete-record (db:delay-if-busy tdbdat) server-id "failed to start, never received server alive signature")
	      (portlogger:open-run-close portlogger:set-failed start-port)
	      (nmsg-transport:run dbstruct hostn run-id server-id))
	      (nmsg-transport:run dbstruct area-dat hostn run-id server-id))
	    (begin
	      (debug:print 0 "ERROR: could not find an open port to start server on. Giving up")
	      (exit 1))))))

(define (nmsg-transport:try-start-server dbstruct run-id portnum server-id)
  (let ((repsoc (nn-socket 'rep)))
    (nn-bind repsoc (conc "tcp://*:" portnum))
    (let loop ((msg-in (nn-recv repsoc)))
      (let* ((dat    (db:string->obj msg-in transport: 'nmsg)))
	(debug:print 0 "server, received: " dat)
	(let ((result (api:execute-requests dbstruct dat)))
	  (debug:print 0 "server, sending: " result)
	  (nn-send repsoc (db:obj->string result  transport: 'nmsg)))
	(loop (nn-recv repsoc))))))

;; all routes though here end in exit ...
;;
(define (nmsg-transport:launch run-id)
(define (nmsg-transport:launch run-id area-dat)
  (let* ((tdbdat   (tasks:open-db))
	 (dbstruct (db:setup run-id))
	 (hostn    (or (args:get-arg "-server") "-")))
    (set! *run-id*   run-id)
    (set! *inmemdb* dbstruct)
    ;; with nbfake daemonize isn't really needed
    ;;
140
141
142
143
144
145
146
147

148
149
150
151
152
153
154
140
141
142
143
144
145
146

147
148
149
150
151
152
153
154







-
+







		      (exit 0))))
	      (begin
		;; since we didn't get the server lock we are going to clean up and bail out
		(debug:print-info 2 "INFO: server pid=" (current-process-id) ", hostname=" (get-host-name) " not starting due to other candidates ahead in start queue")
		(tasks:server-delete-records-for-this-pid (db:delay-if-busy tdbdat) " http-transport:launch")
		))
	  ;; locked in a server id, try to start up
	  (nmsg-transport:run dbstruct hostn run-id server-id))
	  (nmsg-transport:run dbstruct area-dat hostn run-id server-id))
      (set! *didsomething* #t)
      (exit))))

;;======================================================================
;; S E R V E R   U T I L I T I E S 
;;======================================================================

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







-
+



















-
+







	      (signal (vector-ref result 0))))
	(signal (make-composite-condition
		 (make-property-condition 'timeout 'message "nmsg-transport:client-api-send-receive-raw timed out talking to server"))))))

;; run nmsg-transport:keep-running in a parallel thread to monitor that the db is being 
;; used and to shutdown after sometime if it is not.
;;
(define (nmsg-transport:keep-running server-id run-id)
(define (nmsg-transport:keep-running server-id run-id area-dat)
  ;; if none running or if > 20 seconds since 
  ;; server last used then start shutdown
  ;; This thread waits for the server to come alive
  (let* ((server-info (let loop ()
                        (let ((sdat #f))
                          (mutex-lock! *heartbeat-mutex*)
                          (set! sdat *server-info*)
                          (mutex-unlock! *heartbeat-mutex*)
                          (if sdat 
			      (begin
				(debug:print-info 0 "keep-running got sdat=" sdat)
				sdat)
                              (begin
                                (thread-sleep! 0.5)
                                (loop))))))
         (iface       (car server-info))
         (port        (cadr server-info))
         (last-access 0)
	 (tdbdat      (tasks:open-db))
	 (server-timeout (let ((tmo (configf:lookup  *configdat* "server" "timeout")))
	 (server-timeout (let ((tmo (configf:lookup  (megatest:area-configdat area-dat) "server" "timeout")))
			   (if (and (string? tmo)
				    (string->number tmo))
			       (* 60 60 (string->number tmo))
			       ;; (* 3 24 60 60) ;; default to three days
			       (* 60 1)         ;; default to one minute
			       ;; (* 60 60 25)      ;; default to 25 hours
			       ))))

Modified olddashboard.scm from [9c3a853d3a] to [ad835aa81d].

349
350
351
352
353
354
355
356

357
358
359
360
361
362
363
349
350
351
352
353
354
355

356
357
358
359
360
361
362
363







-
+







    ;; (iup:attribute-set! keys-matrix "WIDTH1" "100")
    ;; fill in keys
    (for-each 
     (lambda (var)
       ;; (iup:attribute-set! keys-matrix "ADDLIN" (conc curr-row-num))
       (iup:attribute-set! keys-matrix (conc curr-row-num ":0") curr-row-num)
       (iup:attribute-set! keys-matrix (conc curr-row-num ":1") var)
       (set! curr-row-num (+ 1 curr-row-num))) ;; (config-lookup *configdat* "fields" var)))
       (set! curr-row-num (+ 1 curr-row-num))) ;; (config-lookup configdat "fields" var)))
     key-vals)
    (iup:attribute-set! keys-matrix "WIDTHDEF" "40")
    keys-matrix))

;; Section to table
(define (dcommon:section-matrix rawconfig sectionname varcolname valcolname #!key (title #f))
  (let* ((curr-row-num    1)
375
376
377
378
379
380
381
382

383
384
385
386
387
388
389
375
376
377
378
379
380
381

382
383
384
385
386
387
388
389







-
+







    (iup:attribute-set! section-matrix "WIDTH1" "200")
    ;; fill in keys
    (for-each 
     (lambda (var)
       ;; (iup:attribute-set! keys-matrix "ADDLIN" (conc curr-row-num))
       (iup:attribute-set! section-matrix (conc curr-row-num ":0") var)
       (iup:attribute-set! section-matrix (conc curr-row-num ":1") (configf:lookup rawconfig sectionname var))
       (set! curr-row-num (+ 1 curr-row-num))) ;; (config-lookup *configdat* "fields" var)))
       (set! curr-row-num (+ 1 curr-row-num))) ;; (config-lookup configdat "fields" var)))
     key-vals)
    (iup:vbox
     (iup:label (if title title (conc "Settings from [" sectionname "]"))  
         	;; #:size   "5x"
         	#:expand "HORIZONTAL"
         	)
     section-matrix)))
401
402
403
404
405
406
407
408

409
410
411
412
413
414
415
401
402
403
404
405
406
407

408
409
410
411
412
413
414
415







-
+







    (iup:attribute-set! general-matrix "WIDTH1" "150")
    (iup:attribute-set! general-matrix "0:1" "About this Megatest area") 
    ;; User (this is not always obvious - it is common to run as a different user
    (iup:attribute-set! general-matrix "1:0" "User")
    (iup:attribute-set! general-matrix "1:1" (current-user-name))
    ;; Megatest area
    ;; (iup:attribute-set! general-matrix "2:0" "Area")
    ;; (iup:attribute-set! general-matrix "2:1" *toppath*)
    ;; (iup:attribute-set! general-matrix "2:1" toppath)
    ;; Megatest version
    (iup:attribute-set! general-matrix "2:0" "Version")
    (iup:attribute-set! general-matrix "2:1" (conc megatest-version "-" (substring megatest-fossil-hash 0 4)))

    general-matrix))

(define (dcommon:run-stats dbstruct)
754
755
756
757
758
759
760
761

762
763
764
765
766
767
768
754
755
756
757
758
759
760

761
762
763
764
765
766
767
768







-
+







      (exit)))

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

(define *dbdir* (db:dbfile-path #f)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db"))
(define *dbdir* (db:dbfile-path #f)) ;; (conc (configf:lookup configdat "setup" "linktree") "/.db"))
(define *dbstruct-local*  (make-dbr:dbstruct path:  *dbdir*
					     local: #t))
(define *db-file-path* (db:dbfile-path 0))

;; HACK ALERT: this is a hack, please fix.
(define *read-only* (not (file-read-access? *db-file-path*)))

822
823
824
825
826
827
828
829

830
831
832
833
834
835
836
822
823
824
825
826
827
828

829
830
831
832
833
834
835
836







-
+







(define (next-sort-option)
  (if (>= *tests-sort-reverse* 5)
      (set! *tests-sort-reverse* 0)
      (set! *tests-sort-reverse* (+ *tests-sort-reverse* 1)))
  *tests-sort-reverse*)

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

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

1382
1383
1384
1385
1386
1387
1388
1389

1390
1391
1392
1393
1394
1395
1396
1382
1383
1384
1385
1386
1387
1388

1389
1390
1391
1392
1393
1394
1395
1396







-
+







;;======================================================================
;;
;; A gui for launching tests
;;
(define (dashboard:run-controls)
  (let* ((targets       (make-hash-table))
	 (test-records  (make-hash-table))
	 (all-tests-registry (tests:get-all)) ;; (tests:get-valid-tests *toppath* '()))
	 (all-tests-registry (tests:get-all)) ;; (tests:get-valid-tests toppath '()))
	 (test-names    (hash-table-keys all-tests-registry))
	 (sorted-testnames #f)
	 (action        "-runtests")
	 (cmdln         "")
	 (runlogs       (make-hash-table))
	 (key-listboxes #f)
	 (updater-for-runs #f)
1644
1645
1646
1647
1648
1649
1650
1651
1652



1653
1654
1655
1656
1657
1658
1659
1660
1661

1662
1663
1664
1665
1666
1667
1668
1644
1645
1646
1647
1648
1649
1650


1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661

1662
1663
1664
1665
1666
1667
1668
1669







-
-
+
+
+








-
+







;;      )))

;;======================================================================
;; S U M M A R Y 
;;======================================================================
;;
;; General info about the run(s) and megatest area
(define (dashboard:summary db)
  (let ((rawconfig        (read-config (conc *toppath* "/megatest.config") #f #f))) ;; changed to #f since I want #{} to be expanded by [system ...] to NOT be expanded. WAS: 'return-string)))
(define (dashboard:summary db area-dat)
  (let* ((toppath    (megatest:area-path area-dat))
	 (rawconfig  (read-config (conc toppath "/megatest.config") #f #f))) ;; changed to #f since I want #{} to be expanded by [system ...] to NOT be expanded. WAS: 'return-string)))
    (iup:vbox
     (iup:split
      #:value 500
      (iup:frame 
       #:title "General Info"
       (iup:vbox
	(iup:hbox
	 (iup:label "Area Path")
	 (iup:textbox #:value *toppath* #:expand "HORIZONTAL"))
	 (iup:textbox #:value toppath #:expand "HORIZONTAL"))
	(iup:hbox 
	 (dcommon:keys-matrix rawconfig)
	 (dcommon:general-info)
	 )))
      (iup:frame
       #:title "Server"
       (dcommon:servers-table)))
1848
1849
1850
1851
1852
1853
1854
1855
1856



1857
1858
1859
1860
1861
1862
1863
1849
1850
1851
1852
1853
1854
1855


1856
1857
1858
1859
1860
1861
1862
1863
1864
1865







-
-
+
+
+







     tb
     run-matrix)))

;;======================================================================
;; R U N S 
;;======================================================================

(define (make-dashboard-buttons db nruns ntests keynames)
  (let* ((nkeys   (length keynames))
(define (make-dashboard-buttons db nruns ntests keynames area-dat)
  (let* ((toppath (megatest:area-path area-dat))
	 (nkeys   (length keynames))
	 (runsvec (make-vector nruns))
	 (header  (make-vector nruns))
	 (lftcol  (make-vector ntests))
	 (keycol  (make-vector ntests))
	 (controls '())
	 (lftlst  '())
	 (hdrlst  '())
2058
2059
2060
2061
2062
2063
2064
2065

2066
2067
2068
2069
2070
2071
2072
2060
2061
2062
2063
2064
2065
2066

2067
2068
2069
2070
2071
2072
2073
2074







-
+







						    (system cmd))))))
	  (hash-table-set! *buttondat* button-key (vector 0 "100 100 100" button-key #f #f)) 
	  (vector-set! testvec testnum butn)
	  (loop runnum (+ testnum 1) testvec (cons butn res))))))
    ;; now assemble the hdrlst and bdylst and kick off the dialog
    (iup:show
     (iup:dialog 
      #:title (conc "Megatest dashboard " (current-user-name) ":" *toppath*)
      #:title (conc "Megatest dashboard " (current-user-name) ":" toppath)
      #:menu (dcommon:main-menu)
      (let* ((runs-view (iup:vbox
			 (apply iup:hbox 
				(cons (apply iup:vbox lftlst)
				      (list 
				       (iup:vbox
					;; the header
2103
2104
2105
2106
2107
2108
2109
2110

2111
2112
2113
2114
2115
2116
2117
2105
2106
2107
2108
2109
2110
2111

2112
2113
2114
2115
2116
2117
2118
2119







-
+







(define *tim* (iup:timer))
(define *ord* #f)
(iup:attribute-set! *tim* "TIME" 300)
(iup:attribute-set! *tim* "RUN" "YES")

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

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

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

Modified portlogger.scm from [c19f5a6299] to [bdca7fc363].

112
113
114
115
116
117
118
119
120


121
122
123
124
125
126
127
112
113
114
115
116
117
118


119
120
121
122
123
124
125
126
127







-
-
+
+







   (sqlite3:fold-row
    (lambda (var curr)
      (or curr var curr))
    #f
    db
    "SELECT (port) FROM ports WHERE state='released' LIMIT 1;")))

(define (portlogger:find-port db)
  (let* ((lowport (let ((val (configf:lookup *configdat* "server" "lowport")))
(define (portlogger:find-port db area-dat)
  (let* ((lowport (let ((val (configf:lookup (megatest:area-configdat area-dat) "server" "lowport")))
		    (if (and val 
			     (string->number val))
			(string->number val)
			32768)))
	 (portnum (or (portlogger:get-prev-used-port db)
		      (+ lowport ;; top of registered ports is 49152 but lets use ports in the registered range
			 (random (- 64000 lowport))))))

Modified rmt.scm from [a478090184] to [3e0b8a2905].

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







-
+












+







     (lambda (run-id)
       (let ((connection (common:get-remote remote run-id)))
         (if (and (vector? connection)
        	  (< (http-transport:server-dat-get-last-access connection) expire-time))
             (begin
               (debug:print-info 0 "Discarding connection to server for run-id " run-id ", too long between accesses")
               ;; SHOULD CLOSE THE CONNECTION HERE
	       (case *transport-type*
	       (case (megatest:area-transport area-dat)
		 ((nmsg)(nn-close (http-transport:server-dat-get-socket 
				   (common:get-remote remote run-id)))))
               (common:del-remote! remote run-id)))))
     (common:get-remote-all remote)))
  (mutex-unlock! *db-multi-sync-mutex*))

(define *send-receive-mutex* (make-mutex)) ;; should have separate mutex per run-id

(define (rmt:send-receive cmd rid params area-dat #!key (attemptnum 1)(remote #f)) ;; start attemptnum at 1 so the modulo below works as expected
  (rmt:discard-old-connections area-dat)
  ;; (mutex-lock! *send-receive-mutex*)
  (let* ((run-id          (if rid rid 0))
	 (configdat       (megatest:area-configdat area-dat))
	 (connection-info (rmt:get-connection-info run-id area-dat)))
    ;; the nmsg method does the encoding under the hood (the http method should be changed to do this also)
    (if connection-info
	;; use the server if have connection info
	(let* ((dat     (case *transport-type*
			  ((http)(condition-case
				  (http-transport:client-api-send-receive run-id connection-info cmd params)
151
152
153
154
155
156
157
158

159
160
161
162
163
164
165
152
153
154
155
156
157
158

159
160
161
162
163
164
165
166







-
+







	;; no connection info? try to start a server, or access locally if no
	;; server and the query is read-only
	;;
	;; Note: The tasks db was checked for a server in starting mode in the rmt:get-connection-info call
	;;
	(if (and (< attemptnum 15)
		 (member cmd api:write-queries))
	    (let ((faststart (configf:lookup *configdat* "server" "faststart")))
	    (let ((faststart (configf:lookup configdat "server" "faststart")))
	      (common:del-remote! remote run-id)
	      ;; (mutex-unlock! *send-receive-mutex*)
	      (if (and faststart (equal? faststart "no"))
		  (begin
		    (tasks:start-and-wait-for-server (db:delay-if-busy (tasks:open-db)) run-id 10)
		    (thread-sleep! (random 5)) ;; give some time to settle and minimize collison?
		    (rmt:send-receive cmd rid params area-dat attemptnum: (+ attemptnum 1)))
189
190
191
192
193
194
195
196

197
198
199
200
201
202
203
190
191
192
193
194
195
196

197
198
199
200
201
202
203
204







-
+







	   (hash-table-set! *db-stats* cmd newvec)
	   (set! stat-vec newvec)))
     (vector-set! stat-vec 0 (+ (vector-ref stat-vec 0) 1))
     (vector-set! stat-vec 1 (+ (vector-ref stat-vec 1) duration))))
  (mutex-unlock! *db-stats-mutex*))


(define (rmt:print-db-stats)
(define (rmt:print-db-stats area-dat)
  (let ((fmtstr "~40a~7-d~9-d~20,2-f")) ;; "~20,2-f"
    (debug:print 18 "DB Stats\n========")
    (debug:print 18 (format #f "~40a~8a~10a~10a" "Cmd" "Count" "TotTime" "Avg"))
    (for-each (lambda (cmd)
		(let ((cmd-dat (hash-table-ref *db-stats* cmd)))
		  (debug:print 18 (format #f fmtstr cmd (vector-ref cmd-dat 0) (vector-ref cmd-dat 1) (/ (vector-ref cmd-dat 1)(vector-ref cmd-dat 0))))))
	      (sort (hash-table-keys *db-stats*)
229
230
231
232
233
234
235
236

237
238
239
240
241
242
243
230
231
232
233
234
235
236

237
238
239
240
241
242
243
244







-
+







			     (loop (car tal)(cdr tal) newmax-cmd currmax)))))))
    (mutex-unlock! *db-stats-mutex*)
    res))
	  
(define (rmt:open-qry-close-locally cmd run-id params #!key (remretries 5))
  (let* ((dbstruct-local (if *dbstruct-db*
			     *dbstruct-db*
			     (let* ((dbdir (db:dbfile-path #f)) ;;  (conc    (configf:lookup *configdat* "setup" "linktree") "/.db"))
			     (let* ((dbdir (db:dbfile-path #f))
				    (db (make-dbr:dbstruct path:  dbdir local: #t)))
			       (set! *dbstruct-db* db)
			       db)))
	 (db-file-path   (db:dbfile-path 0))
	 ;; (read-only      (not (file-read-access? db-file-path)))
	 (start          (current-milliseconds))
	 (resdat         (api:execute-requests dbstruct-local (vector (symbol->string cmd) params)))
308
309
310
311
312
313
314
315
316


317
318
319
320
321
322
323
324






325
326
327
328
329
330
331
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







-
-
+
+




-
-
-
-
+
+
+
+
+
+







(define (rmt:start-server run-id)
  (rmt:send-receive 'start-server 0 (list run-id) area-dat))

;;======================================================================
;;  M I S C
;;======================================================================

(define (rmt:login run-id)
  (rmt:send-receive 'login run-id (list *toppath* megatest-version run-id *my-client-signature*) area-dat))
(define (rmt:login run-id area-dat)
  (rmt:send-receive 'login run-id (list (megatest:area-path area-dat) megatest-version run-id *my-client-signature*) area-dat))

;; This login does no retries under the hood - it acts a bit like a ping.
;; Deprecated for nmsg-transport.
;;
(define (rmt:login-no-auto-client-setup connection-info run-id)
  (case *transport-type*
    ((http)(rmt:send-receive-no-auto-client-setup connection-info 'login run-id (list *toppath* megatest-version run-id *my-client-signature*) area-dat))
    ((nmsg)(nmsg-transport:client-api-send-receive run-id connection-info 'login (list *toppath* megatest-version run-id *my-client-signature*) area-dat))))
(define (rmt:login-no-auto-client-setup connection-info run-id area-dat)
  (let ((transport (megatest:area-transport area-dat))
	(toppath   (megatest:area-path      area-dat)))
    (case transport
      ((http)(rmt:send-receive-no-auto-client-setup connection-info 'login run-id  (list toppath megatest-version run-id *my-client-signature*) area-dat))
      ((nmsg)(nmsg-transport:client-api-send-receive run-id connection-info 'login (list toppath megatest-version run-id *my-client-signature*) area-dat)))))

;; hand off a call to one of the db:queries statements
;; added run-id to make looking up the correct db possible 
;;
(define (rmt:general-call stmtname run-id area-dat . params)
  (rmt:send-receive 'general-call run-id (append (list stmtname run-id) params) area-dat))

Modified rpc-transport.scm from [a54662d800] to [9f0167ff5f].

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







-
+






+
-
+







-
+







	      ;; since we didn't get the server lock we are going to clean up and bail out
	      (debug:print-info 2 "INFO: server pid=" (current-process-id) ", hostname=" (get-host-name) " not starting due to other candidates ahead in start queue")
	      (open-run-close tasks:server-delete-records-for-this-pid tasks:open-db " rpc-transport:launch")))
	(begin
	  (rpc-transport:run (if (args:get-arg "-server")(args:get-arg "-server") "-") run-id server-id)
	  (exit)))))

(define (rpc-transport:run hostn run-id server-id)
(define (rpc-transport:run hostn run-id server-id area-dat)
  (debug:print 2 "Attempting to start the rpc server ...")
   ;; (trace rpc:publish-procedure!)

  (rpc:publish-procedure! 'server:login server:login)
  (rpc:publish-procedure! 'testing (lambda () "Just testing"))

  (let* ((configdat       (megatest:area-configdat area-dat))
  (let* ((db              #f)
	 (db              #f)
	 (hostname        (get-host-name))
	 (ipaddrstr       (let ((ipstr (if (string=? "-" hostn)
					   ;; (string-intersperse (map number->string (u8vector->list (hostname->ip hostname))) ".")
					   (server:get-best-guess-address hostname)
					   #f)))
			    (if ipstr ipstr hostn))) ;; hostname))) 
	 (start-port      (open-run-close tasks:server-get-next-port tasks:open-db))
	 (link-tree-path  (configf:lookup *configdat* "setup" "linktree"))
	 (link-tree-path  (configf:lookup configdat "setup" "linktree"))
	 (rpc:listener    (rpc-transport:find-free-port-and-open (rpc:default-server-port)))
	 (th1             (make-thread
			   (lambda ()
			     ((rpc:make-server rpc:listener) #t))
			   "rpc:server"))
			   ;; (cute (rpc:make-server rpc:listener) "rpc:server")
			   ;; 'rpc:server))
141
142
143
144
145
146
147
148

149
150
151
152
153
154

155
156
157
158
159
160
161
162
163
164

165
166
167
168

169

170
171
172
173

174
175
176
177
178
179
180
181

182
183
184
185
186
187
188

189
190
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
142
143
144
145
146
147
148

149
150
151
152
153
154

155
156
157
158
159
160
161
162
163
164

165
166
167
168
169
170

171
172
173
174

175
176
177
178
179
180
181
182

183
184
185
186
187
188
189

190
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







-
+





-
+









-
+




+
-
+



-
+







-
+






-
+







-
+



-
+

















-
+








	  (begin
     (print "Failed to bind to port " (rpc:default-server-port) ", trying next port")
     (rpc-transport:find-free-port-and-open (+ port 1)))
   (rpc:default-server-port port)
   (tcp-read-timeout 240000)
   (tcp-listen (rpc:default-server-port) 10000)))

(define (rpc-transport:ping run-id host port)
(define (rpc-transport:ping run-id host port area-dat)
  (handle-exceptions
   exn
   (begin
     (print "SERVER_NOT_FOUND")
     (exit 1))
   (let ((login-res ((rpc:procedure 'server:login host port) *toppath*)))
   (let ((login-res ((rpc:procedure 'server:login host port) (megatest:area-path area-dat))))
     (if (and (list? login-res)
	      (car login-res))
	 (begin
	   (print "LOGIN_OK")
	   (exit 0))
	 (begin
	   (print "LOGIN_FAILED")
	   (exit 1))))))

(define (rpc-transport:client-setup run-id #!key (remtries 10))
(define (rpc-transport:client-setup run-id area-dat #!key (remtries 10))
  (if (common:get-remote remote run-id)
      (begin
	(debug:print 0 "ERROR: Attempt to connect to server but already connected")
	#f)
      (let* ((toppath (megatest:area-path area-dat))
      (let* ((host-info (common:get-remote remote run-id))) ;; (open-run-close db:get-var #f "SERVER"))
	     (host-info (common:get-remote remote run-id))) ;; (open-run-close db:get-var #f "SERVER"))
	(if host-info
	    (let ((iface    (car host-info))
		  (port     (cadr host-info))
		  (ping-res ((rpc:procedure 'server:login host port) *toppath*)))
		  (ping-res ((rpc:procedure 'server:login host port) toppath)))
	      (if ping-res
		  (let ((server-dat (list iface port #f #f #f)))
		    (common:set-remote! remote run-id server-dat)
		    server-dat)
		  (begin
		    (server:try-running run-id)
		    (thread-sleep! 2)
		    (rpc-transport:client-setup run-id (- remtries 1)))))
		    (rpc-transport:client-setup run-id area-dat remtries: (- remtries 1)))))
 	    (let* ((server-db-info (open-run-close tasks:get-server tasks:open-db run-id)))
 	      (debug:print-info 0 "client:setup server-dat=" server-dat ", remaining-tries=" remaining-tries)
	      (if server-db-info
 		  (let* ((iface     (tasks:hostinfo-get-interface server-db-info))
 			 (port      (tasks:hostinfo-get-port      server-db-info))
			 (server-dat (list iface port #f #f #f))
 			 (ping-res  ((rpc:procedure 'server:login host port) *toppath*)))
 			 (ping-res  ((rpc:procedure 'server:login host port) toppath)))
 		    (if start-res
 			(begin
 			  (common:set-remote! remote run-id server-dat)
			  server-dat)
			(begin
			  (server:try-running run-id)
			  (thread-sleep! 2)
			  (rpc-transport:client-setup run-id (- remtries 1)))))
			  (rpc-transport:client-setup run-id area-dat remtries: (- remtries 1)))))
		  (begin
		    (server:try-running run-id)
		    (thread-sleep! 2)
		    (rpc-transport:client-setup run-id (- remtries 1)))))))))
		    (rpc-transport:client-setup run-id area-dat remtries: (- remtries 1)))))))))
;; 
;; 	     (port     (if (and hostinfo (> (length hostdat) 1))(cadr hostdat) #f)))
;; 	(if (and port
;; 		 (string->number port))
;; 	    (let ((portn (string->number port)))
;; 	      (debug:print-info 2 "Setting up to connect to host " host ":" port)
;; 	      (handle-exceptions
;; 	       exn
;; 	       (begin
;; 		 (debug:print 0 "ERROR: Failed to open a connection to the server at host: " host " port: " port)
;; 		 (debug:print 0 "   EXCEPTION: " ((condition-property-accessor 'exn 'message) exn))
;; 		 ;; (open-run-close 
;; 		 ;;  (lambda (db . param) 
;; 		 ;;    (sqlite3:execute db "DELETE FROM metadat WHERE var='SERVER'"))
;; 		 ;;  #f)
;; 		 (set! (common:get-remote remote) #f))
;; 	       (if (and (not (args:get-arg "-server")) ;; no point in the server using the server using the server
;; 			((rpc:procedure 'server:login host portn) *toppath*))
;; 			((rpc:procedure 'server:login host portn) toppath))
;; 		   (begin
;; 		     (debug:print-info 2 "Logged in and connected to " host ":" port)
;; 		     (set! (common:get-remote remote) (vector host portn)))
;; 		   (begin
;; 		     (debug:print-info 2 "Failed to login or connect to " host ":" port)
;; 		     (set! (common:get-remote remote) #f)))))
;; 	    (debug:print-info 2 "no server available")))))

Modified run_records.scm from [1580836de1] to [ee3ced0e70].

1
2

3
4
5
6
7
8
9
1

2
3
4
5
6
7
8
9

-
+







;;======================================================================
;; Copyright 2006-2012, Matthew Welland.
;; Copyright 2006-2015, Matthew Welland.
;; 
;;  This program is made available under the GNU GPL version 2.0 or
;;  greater. See the accompanying file COPYING for details.
;; 
;;  This program is distributed WITHOUT ANY WARRANTY; without even the
;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;;  PURPOSE.
17
18
19
20
21
22
23
24

25
26
27
28
29
30
31
17
18
19
20
21
22
23

24
25
26
27
28
29
30
31







-
+







(define-inline (runs:runrec-keyvals     vec)(vector-ref vec 4))  ;; ((key1 val1)(key2 val2) ...)
(define-inline (runs:runrec-environment vec)(vector-ref vec 5))  ;; environment, alist key val
(define-inline (runs:runrec-mconfig     vec)(vector-ref vec 6))  ;; megatest.config
(define-inline (runs:runrec-runconfig   vec)(vector-ref vec 7))  ;; runconfigs.config
(define-inline (runs:runrec-serverdat   vec)(vector-ref vec 8))  ;; (host port)
(define-inline (runs:runrec-transport   vec)(vector-ref vec 9))  ;; 'http
(define-inline (runs:runrec-db          vec)(vector-ref vec 10)) ;; <sqlite3db> (if 'fs)
(define-inline (runs:runrec-top-path    vec)(vector-ref vec 11)) ;; *toppath*
(define-inline (runs:runrec-top-path    vec)(vector-ref vec 11)) ;; toppath
(define-inline (runs:runrec-run_id      vec)(vector-ref vec 12)) ;; run-id

(define-inline (test:get-id vec)       (vector-ref vec 0))
(define-inline (test:get-run_id vec)   (vector-ref vec 1))
(define-inline (test:get-test-name vec)(vector-ref vec 2))
(define-inline (test:get-state vec)    (vector-ref vec 3))
(define-inline (test:get-status vec)   (vector-ref vec 4))

Modified runconfig.scm from [d97360c67a] to [294d3c472b].

54
55
56
57
58
59
60
61
62
63



64
65
66
67
68
69
70
54
55
56
57
58
59
60



61
62
63
64
65
66
67
68
69
70







-
-
-
+
+
+







	  (for-each (lambda (fullkey)
		      (debug:print 2 (format #f "~20a ~a\n" fullkey (hash-table-ref/default whatfound fullkey 0))))
		    sections)
	  (debug:print 2 "---")
	  (set! *already-seen-runconfig-info* #t)))
    finaldat))

(define (set-run-config-vars run-id keyvals targ-from-db)
  (push-directory *toppath*) ;; the push/pop doesn't appear to do anything ...
  (let ((runconfigf (conc  *toppath* "/runconfigs.config"))
(define (set-run-config-vars run-id keyvals targ-from-db area-dat)
  (push-directory (megatest:area-path area-dat)) ;; the push/pop doesn't appear to do anything ...
  (let ((runconfigf (conc (megatest:area-path area-dat) "/runconfigs.config"))
	(targ       (or (common:args-get-target)
			targ-from-db
			(get-environment-variable "MT_TARGET"))))
    (pop-directory)
    (if (file-exists? runconfigf)
	(setup-env-defaults runconfigf run-id #t keyvals
			    environ-patt: (conc "(default"

Modified runs.scm from [e8cbbfebdc] to [6f4d489558].

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
99
100
101
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
99
100
101
102
103







-
-
-
+
+
+
+
+

-
+











-




















-
+
















+







  (let* ((testname (db:test-get-testname   test))
	 (itempath (db:test-get-item-path test)))
    (conc testname (if (equal? itempath "") "" (conc "(" itempath ")")))))

;;;;;; ;; This is the *new* methodology. One record to inform them and in the chaos, organise them.
;;;;;; ;;
;;;;;; (define (runs:create-run-record area-dat) ;; #!key (remote #f))
;;;;;;   (let* ((remote       (megatest:area-remote area-dat))
;;;;;; 	 (mconfig      (if *configdat*
;;;;;; 		           *configdat*
;;;;;;   (let* ((remote       (megatest:area-remote    area-dat))
;;;;;;          (configdat    (megatest:area-configdat area-dat))
;;;;;;          (toppath      (megatest:area-path      area-dat)))
;;;;;; 	 (mconfig      (if configdat
;;;;;; 		           configdat
;;;;;; 		           (if (launch:setup-for-run)
;;;;;; 		               *configdat*
;;;;;; 		               configdat
;;;;;; 		               (begin
;;;;;; 		                 (debug:print 0 "ERROR: Called setup in a non-megatest area, exiting")
;;;;;; 		                 (exit 1)))))
;;;;;; 	  (runrec      (runs:runrec-make-record))
;;;;;; 	  (target      (common:args-get-target))
;;;;;; 	  (runname     (or (args:get-arg "-runname")
;;;;;; 		           (args:get-arg ":runname")))
;;;;;; 	  (testpatt    (or (args:get-arg "-testpatt")
;;;;;; 		           (args:get-arg "-runtests")))
;;;;;; 	  (keys        (keys:config-get-fields mconfig))
;;;;;; 	  (keyvals     (keys:target->keyval keys target))
;;;;;; 	  (toppath     *toppath*)
;;;;;; 	  (envdat      keyvals) ;; initial values start with keyvals
;;;;;; 	  (runconfig   #f)
;;;;;; 	  (transport   (or (args:get-arg "-transport") 'http))
;;;;;; 	  (run-id      #f))
;;;;;;     ;; Set all the environment vars we know so far, start with keys
;;;;;;     (for-each (lambda (keyval)
;;;;;; 		(setenv (car keyval)(cadr keyval)))
;;;;;; 	      keyvals)
;;;;;;     ;; Set up various and sundry known vars here
;;;;;;     (setenv "MT_RUN_AREA_HOME" toppath)
;;;;;;     (setenv "MT_RUNNAME" runname)
;;;;;;     (setenv "MT_TARGET"  target)
;;;;;;     (setenv "MT_TESTSUITENAME" (common:get-testsuite-name))
;;;;;;     (set! envdat (append 
;;;;;; 		  envdat
;;;;;; 		  (list (list "MT_RUN_AREA_HOME" toppath)
;;;;;; 			(list "MT_RUNNAME"       runname)
;;;;;; 			(list "MT_TARGET"        target))))
;;;;;;     ;; Now can read the runconfigs file
;;;;;;     ;; 
;;;;;;     (set! runconfig (read-config (conc  *toppath* "/runconfigs.config") #f #t sections: (list "default" target)))
;;;;;;     (set! runconfig (read-config (conc  toppath "/runconfigs.config") #f #t sections: (list "default" target)))
;;;;;;     (if (not (hash-table-ref/default runconfig (args:get-arg "-reqtarg") #f))
;;;;;; 	(begin
;;;;;; 	  (debug:print 0 "ERROR: [" (args:get-arg "-reqtarg") "] not found in " runconfigf)
;;;;;; 	  (if db (sqlite3:finalize! db))
;;;;;; 	  (exit 1)))
;;;;;;     ;; Now have runconfigs data loaded, set environment vars
;;;;;;     (for-each (lambda (section)
;;;;;; 		(for-each (lambda (varval)
;;;;;; 			    (set! envdat (append envdat (list varval)))
;;;;;; 			    (safe-setenv (car varval)(cadr varval)))
;;;;;; 			  (configf:get-section runconfig section)))
;;;;;; 	      (list "default" target))
;;;;;;     (vector target runname testpatt keys keyvals envdat mconfig runconfig (common:get-remote remote run-id) transport db toppath run-id)))

(define (runs:set-megatest-env-vars run-id area-dat #!key (inkeys #f)(inrunname #f)(inkeyvals #f))
  (let* ((configdat (megatest:area-configdat area-dat))
	 (toppath   (megatest:area-path      area-dat))
	 (target    (or (common:args-get-target)
			(get-environment-variable "MT_TARGET")))
	 (keys    (if inkeys    inkeys    (rmt:get-keys)))
	 (keyvals   (if inkeyvals inkeyvals (keys:target->keyval keys target)))
	 (vals      (hash-table-ref/default *env-vars-by-run-id* run-id #f))
	 (link-tree (configf:lookup configdat "setup" "linktree")))
    ;; get the info from the db and put it in the cache
119
120
121
122
123
124
125
126

127
128
129
130
131
132
133
121
122
123
124
125
126
127

128
129
130
131
132
133
134
135







-
+







    (if (not (get-environment-variable "MT_TARGET"))(setenv "MT_TARGET" target))
    (alist->env-vars (hash-table-ref/default configdat "env-override" '()))
    ;; Lets use this as an opportunity to put MT_RUNNAME in the environment
    (let ((runname  (if inrunname inrunname (rmt:get-run-name-from-id run-id))))
      (if runname
	  (setenv "MT_RUNNAME" runname)
	  (debug:print 0 "ERROR: no value for runname for id " run-id)))
    (setenv "MT_RUN_AREA_HOME" *toppath*)))
    (setenv "MT_RUN_AREA_HOME" toppath)))

(define (set-item-env-vars itemdat)
  (for-each (lambda (item)
	      (debug:print 2 "setenv " (car item) " " (cadr item))
	      (setenv (car item) (cadr item)))
	    itemdat))

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
254
255
256


257
258
259
260
261
262
263
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
254
255
256


257
258
259
260
261
262
263
264
265







-
+













-
+





-
+







-
-
+
+







	 (all-tests-registry #f)  ;; (tests:get-all)) ;; (tests:get-valid-tests (make-hash-table) test-search-path)) ;; all valid tests to check waiton names
	 (all-test-names     #f)  ;; (hash-table-keys all-tests-registry))
	 (test-names         #f)  ;; (tests:filter-test-names all-test-names test-patts))
	 (required-tests     #f)  ;;(lset-intersection equal? (string-split test-patts ",") test-names))) ;; test-names)) ;; Added test-names as initial for required-tests but that failed to work
	 (task-key           (conc (hash-table->alist flags) " " (get-host-name) " " (current-process-id)))
	 (tdbdat             (tasks:open-db)))

    (if (tasks:need-server run-id)(tasks:start-and-wait-for-server tdbdat run-id 10))
    (if (tasks:need-server run-id area-dat)(tasks:start-and-wait-for-server tdbdat run-id 10))

    (set-signal-handler! signal/int
			 (lambda (signum)
			   (signal-mask! signum)
			   (print "Received signal " signum ", cleaning up before exit. Please wait...")
			   (let ((tdbdat (tasks:open-db)))
			     (rmt:tasks-set-state-given-param-key task-key "killed"))
			   (print "Killed by signal " signum ". Exiting")
			   (exit)))

    ;; register this run in monitor.db
    (rmt:tasks-add "run-tests" user target runname test-patts task-key) ;; params)
    (rmt:tasks-set-state-given-param-key task-key "running")
    (runs:set-megatest-env-vars run-id inkeys: keys inrunname: runname) ;; these may be needed by the launching process
    (runs:set-megatest-env-vars run-id area-dat inkeys: keys inrunname: runname) ;; these may be needed by the launching process
    (if (file-exists? runconfigf)
	(setup-env-defaults runconfigf run-id *already-seen-runconfig-info* keyvals target)
	(debug:print 0 "WARNING: You do not have a run config file: " runconfigf))

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

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

    ;; on the first pass or call to run-tests set FAILS to NOT_STARTED if
    ;; -keepgoing is specified
    (if (eq? *passnum* 0)
	(begin
286
287
288
289
290
291
292
293

294
295
296
297
298
299
300
288
289
290
291
292
293
294

295
296
297
298
299
300
301
302







-
+







    ;;
    ;; What happended, this code is now duplicated in tests!?
    ;;
    ;;======================================================================
    (if (not (null? test-names))
	(let loop ((hed (car test-names))
		   (tal (cdr test-names)))         ;; 'return-procs tells the config reader to prep running system but return a proc
	  (change-directory *toppath*) ;; PLEASE OPTIMIZE ME!!! I think this should be a no-op but there are several places where change-directories could be happening.
	  (change-directory toppath) ;; PLEASE OPTIMIZE ME!!! I think this should be a no-op but there are several places where change-directories could be happening.
	  (setenv "MT_TEST_NAME" hed) ;; 
	  (let* ((config  (tests:get-testconfig hed all-tests-registry 'return-procs))
		 (waitons (let ((instr (if config 
					   (config-lookup config "requirements" "waiton")
					   (begin ;; No config means this is a non-existant test
					     (debug:print 0 "ERROR: non-existent required test \"" hed "\"")
					     (exit 1)))))
513
514
515
516
517
518
519
520

521
522
523
524
525
526
527
515
516
517
518
519
520
521

522
523
524
525
526
527
528
529







-
+







     ((or (null? prereqs-not-met)
	  (and (member 'toplevel testmode)
	       (null? non-completed)))
      (debug:print-info 4 "runs:expand-items: (or (null? prereqs-not-met) (and (member 'toplevel testmode)(null? non-completed)))")
      (let ((test-name (tests:testqueue-get-testname test-record)))
	(setenv "MT_TEST_NAME" test-name) ;; 
	(setenv "MT_RUNNAME"   runname)
	(runs:set-megatest-env-vars run-id inrunname: runname) ;; these may be needed by the launching process
	(runs:set-megatest-env-vars run-id area-dat inrunname: runname) ;; these may be needed by the launching process
	(let ((items-list (items:get-items-from-config tconfig)))
	  (if (list? items-list)
	      (begin
		(if (null? items-list)
		    (let ((test-id (rmt:get-test-id run-id test-name "")))
		      (if test-id (mt:test-set-state-status-by-id run-id test-id "NOT_STARTED" "ZERO_ITEMS" "Failed to run due to failed prerequisites"))))
		(tests:testqueue-set-items! test-record items-list)
758
759
760
761
762
763
764
765

766
767
768
769
770
771
772
760
761
762
763
764
765
766

767
768
769
770
771
772
773
774







-
+







      ;; we are going to reset all the counters for test retries by setting a new hash table
      ;; this means they will increment only when nothing can be run
      (set! *max-tries-hash* (make-hash-table))
      ;; well, first lets see if cpu load throttling is enabled. If so wait around until the
      ;; average cpu load is under the threshold before continuing
      (if (configf:lookup configdat "jobtools" "maxload") ;; only gate if maxload is specified
	  (common:wait-for-cpuload maxload numcpus waitdelay))
      (run:test run-id run-info keyvals runname test-record flags #f test-registry all-tests-registry)
      (run:test run-id run-info keyvals runname test-record flags #f test-registry all-tests-registry area-dat)
      (hash-table-set! test-registry (db:test-make-full-name test-name item-path) 'running)
      (runs:shrink-can-run-more-tests-count)  ;; DELAY TWEAKER (still needed?)
      ;; (thread-sleep! *global-delta*)
      (if (or (not (null? tal))(not (null? reg)))
	  (list (runs:queue-next-hed tal reg reglen regfull)
		(runs:queue-next-tal tal reg reglen regfull)
		(runs:queue-next-reg tal reg reglen regfull)
965
966
967
968
969
970
971
972

973
974
975
976
977
978
979
967
968
969
970
971
972
973

974
975
976
977
978
979
980
981







-
+







	     (tfullname   (db:test-make-full-name test-name item-path))
	     (newtal      (append tal (list hed)))
	     (regfull     (>= (length reg) reglen))
	     (num-running (rmt:get-count-tests-running-for-run-id run-id area-dat)))

	;; every couple minutes verify the server is there for this run
	(if (and (common:low-noise-print 60 "try start server"  run-id)
		 (tasks:need-server run-id))
		 (tasks:need-server run-id area-dat))
	    (tasks:start-and-wait-for-server tdbdat run-id 10)) ;; NOTE: delay and wait is done under the hood
	
	(if (> num-running 0)
	  (set! last-time-some-running (current-seconds)))

      (if (> (current-seconds)(+ last-time-some-running 240))
	  (hash-table-set! *max-tries-hash* tfullname (+ (hash-table-ref/default *max-tries-hash* tfullname 0) 1)))
1200
1201
1202
1203
1204
1205
1206
1207

1208

1209

1210
1211
1212
1213

1214
1215
1216
1217
1218
1219
1220
1202
1203
1204
1205
1206
1207
1208

1209
1210
1211

1212
1213
1214
1215

1216
1217
1218
1219
1220
1221
1222
1223







-
+

+
-
+



-
+







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

;; parent-test is there as a placeholder for when parent-tests can be run as a setup step
(define (run:test run-id run-info keyvals runname test-record flags parent-test test-registry all-tests-registry)
(define (run:test run-id run-info keyvals runname test-record flags parent-test test-registry all-tests-registry area-dat)
  ;; All these vars might be referenced by the testconfig file reader
  (let* ((toppath      (megatest:area-path area-dat))
  (let* ((test-name    (tests:testqueue-get-testname   test-record))
	 (test-name    (tests:testqueue-get-testname   test-record))
	 (test-waitons (tests:testqueue-get-waitons    test-record))
	 (test-conf    (tests:testqueue-get-testconfig test-record))
	 (itemdat      (tests:testqueue-get-itemdat    test-record))
	 (test-path    (hash-table-ref all-tests-registry test-name)) ;; (conc *toppath* "/tests/" test-name)) ;; could use tests:get-testconfig here ...
	 (test-path    (hash-table-ref all-tests-registry test-name))
	 (force        (hash-table-ref/default flags "-force" #f))
	 (rerun        (hash-table-ref/default flags "-rerun" #f))
	 (keepgoing    (hash-table-ref/default flags "-keepgoing" #f))
	 (incomplete-timeout (string->number (or (configf:lookup configdat "setup" "incomplete-timeout") "x")))
	 (item-path     "")
	 (db           #f)
	 (full-test-name #f))
1228
1229
1230
1231
1232
1233
1234
1235
1236


1237
1238
1239
1240
1241
1242
1243
1231
1232
1233
1234
1235
1236
1237


1238
1239
1240
1241
1242
1243
1244
1245
1246







-
-
+
+







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

    ;; Here is where the test_meta table is best updated
    ;; Yes, another use of a global for caching. Need a better way?
    ;;
    ;; There is now a single call to runs:update-all-test_meta and this 
    ;; per-test call is not needed. Given the delicacy of the move to 
    ;; v1.55 this code is being left in place for the time being.
1277
1278
1279
1280
1281
1282
1283
1284

1285
1286
1287
1288
1289
1290
1291
1280
1281
1282
1283
1284
1285
1286

1287
1288
1289
1290
1291
1292
1293
1294







-
+







      (if (not testdat) ;; should NOT happen
	  (debug:print 0 "ERROR: failed to get test record for test-id " test-id))
      (set! test-id (db:test-get-id testdat))
      (if (file-exists? test-path)
	  (change-directory test-path)
	  (begin
	    (debug:print "ERROR: test run path not created before attempting to run the test. Perhaps you are running -remove-runs at the same time?")
	    (change-directory *toppath*)))
	    (change-directory toppath)))
      (case (if force ;; (args:get-arg "-force")
		'NOT_STARTED
		(if testdat
		    (string->symbol (test:get-state testdat))
		    'failed-to-insert))
	((failed-to-insert)
	 (debug:print 0 "ERROR: Failed to insert the record into the db"))
1461
1462
1463
1464
1465
1466
1467
1468

1469
1470
1471
1472
1473
1474
1475

1476
1477
1478
1479
1480
1481
1482
1464
1465
1466
1467
1468
1469
1470

1471
1472
1473
1474
1475
1476
1477

1478
1479
1480
1481
1482
1483
1484
1485







-
+






-
+







		(lasttpath "/does/not/exist/I/hope")
		(worker-thread #f))
	   (debug:print-info 4 "runs:operate-on run=" run ", header=" header)
	   (if (not (null? tests))
	       (begin
		 (case action
		   ((remove-runs)
		    (if (tasks:need-server run-id)(tasks:start-and-wait-for-server tdbdat run-id 10))
		    (if (tasks:need-server run-id area-dat)(tasks:start-and-wait-for-server tdbdat run-id 10))
		    ;; seek and kill in flight -runtests with % as testpatt here
		    (if (equal? testpatt "%")
			(tasks:kill-runner target run-name)
			(debug:print 0 "not attempting to kill any run launcher processes as testpatt is " testpatt))
		    (debug:print 1 "Removing tests for run: " runkey " " (db:get-value-by-header run header "runname")))
		   ((set-state-status)
		    (if (tasks:need-server run-id)(tasks:start-and-wait-for-server tdbdat run-id 10))
		    (if (tasks:need-server run-id area-dat)(tasks:start-and-wait-for-server tdbdat run-id 10))
		    (debug:print 1 "Modifying state and staus for tests for run: " runkey " " (db:get-value-by-header run header "runname")))
		   ((print-run)
		    (debug:print 1 "Printing info for run " runkey ", run=" run ", tests=" tests ", header=" header)
		    action)
		   ((run-wait)
		    (debug:print 1 "Waiting for run " runkey ", run=" runnamepatt " to complete"))
		   ((archive)
1753
1754
1755
1756
1757
1758
1759
1760

1761
1762
1763
1764
1765
1766
1767
1756
1757
1758
1759
1760
1761
1762

1763
1764
1765
1766
1767
1768
1769
1770







-
+







	     (begin
	       (print "Updating " test-name " " fld " to " val)
	       (rmt:testmeta-update-field test-name fld val area-dat)))))
     '(("author" 2)("owner" 3)("description" 4)("reviewed" 5)("tags" 9)("jobgroup" 10)))))

;; Update test_meta for all tests
(define (runs:update-all-test_meta db)
  (let ((test-names (tests:get-all))) ;; (tests:get-valid-tests)))
  (let ((test-names (tests:get-all area-dat))) ;; (tests:get-valid-tests)))
    (for-each 
     (lambda (test-name)
       (let* ((test-conf    (mt:lazy-read-test-config test-name)))
	 (if test-conf (runs:update-test_meta test-name test-conf))))
     (hash-table-keys test-names))))

;; This could probably be refactored into one complex query ...

Modified server.scm from [21d5d83224] to [9238bd7591].

45
46
47
48
49
50
51
52

53
54
55
56



57
58
59
60
61
62
63
45
46
47
48
49
50
51

52
53



54
55
56
57
58
59
60
61
62
63







-
+

-
-
-
+
+
+







;; Call this to start the actual server
;;

;; all routes though here end in exit ...
;;
;; start_server
;;
(define (server:launch run-id)
(define (server:launch run-id area-dat)
  (case *transport-type*
    ((http)(http-transport:launch run-id))
    ((nmsg)(nmsg-transport:launch run-id))
    ((rpc)  (rpc-transport:launch run-id))
    ((http)(http-transport:launch run-id area-dat))
    ((nmsg)(nmsg-transport:launch run-id area-dat))
    ((rpc)  (rpc-transport:launch run-id area-dat))
    (else (debug:print 0 "ERROR: unknown server type " *transport-type*))))
;;       (else   (debug:print 0 "ERROR: No known transport set, transport=" transport ", using rpc")
;; 	      (rpc-transport:launch run-id)))))

;;======================================================================
;; S E R V E R   U T I L I T I E S 
;;======================================================================
230
231
232
233
234
235
236
237

238
239
240

241
242
243
244
245
246
247
230
231
232
233
234
235
236

237
238
239

240
241
242
243
244
245
246
247







-
+


-
+







       (if (eof-object? inl)
	   (case (string->symbol res)
	     ((NOREPLY)  #f)
	     ((LOGIN_OK) #t)
	     (else       #f))
	   (loop (read-line) inl))))))

(define (server:login toppath)
(define (server:login toppath area-dat)
  (lambda (toppath)
    (set! *last-db-access* (current-seconds))
    (if (equal? *toppath* toppath)
    (if (equal? (megatest:area-path area-dat) toppath)
	(begin
	  ;; (debug:print-info 2 "login successful")
	  #t)
	(begin
	  ;; (debug:print-info 2 "login failed")
	  #f))))

Modified tasks.scm from [c2412a5f28] to [af8f785c6d].

88
89
90
91
92
93
94
95

96
97
98
99
100
101
102
103
104
105
106
107

108
109
110
111
112
113
114
88
89
90
91
92
93
94

95
96
97
98
99
100
101
102
103
104
105
106

107
108
109
110
111
112
113
114







-
+











-
+







	     (debug:print 0 " exn=" (condition->list exn))))
       (let* ((toppath      (megatest:area-path area-dat))
	      (dbpath       (tasks:get-task-db-path area-dat))
	      (dbfile       (conc dbpath "/monitor.db"))
	      (avail        (tasks:wait-on-journal dbpath 10)) ;; wait up to about 10 seconds for the journal to go away
	      (exists       (file-exists? dbpath))
	      (write-access (file-write-access? dbpath))
	      (mdb          (cond ;; what the hek is *toppath* doing here?
	      (mdb          (cond ;; what the hek is toppath doing here?
			     ((and (string? toppath)(file-write-access? toppath))
			      (sqlite3:open-database dbfile))
			     ((file-read-access? dbpath)    (sqlite3:open-database dbfile))
			     (else (sqlite3:open-database ":memory:")))) ;; (never-give-up-open-db dbpath))
	      (handler      (make-busy-timeout 36000)))
	 (if (and exists
		  (not write-access))
	     (set! *db-write-access* write-access)) ;; only unset so other db's also can use this control
	 (sqlite3:set-busy-handler! mdb handler)
	 (db:set-sync mdb) ;; (sqlite3:execute mdb (conc "PRAGMA synchronous = 0;"))
	 ;;  (if (or (and (not exists)
	 ;; 	      (file-write-access? *toppath*))
	 ;; 	      (file-write-access? toppath))
	 ;; 	 (not (file-read-access? dbpath)))
	 ;;      (begin
	 ;; 
	 ;; TASKS QUEUE MOVED TO main.db
	 ;;
	 ;; (sqlite3:execute mdb "CREATE TABLE IF NOT EXISTS tasks_queue (id INTEGER PRIMARY KEY,
         ;;                        action TEXT DEFAULT '',
252
253
254
255
256
257
258
259

260
261
262
263
264
265
266
267
268
269
270
271
252
253
254
255
256
257
258

259





260
261
262
263
264
265
266







-
+
-
-
-
-
-







	(highnum        64000)
	(used-ports     '())
	(get-rand-port  (lambda ()
			  (+ lownum (random (- highnum lownum)))))
	(port-param     (if (and (args:get-arg "-port")
				 (string->number (args:get-arg "-port")))
			    (string->number (args:get-arg "-port"))
			    #f))
			    #f)))
	;; (config-port    (if (and (config-lookup  *configdat* "server" "port")
	;; 			 (string->number (config-lookup  *configdat* "server" "port")))
	;; 		    (string->number (config-lookup  *configdat* "server" "port"))
	;; 		    #f))
	)
    (sqlite3:for-each-row
     (lambda (port)
       (set! used-ports (cons port used-ports)))
     mdb
     "SELECT port FROM servers;")
    (cond
     ((and port-param res)   (if (> res port-param) res port-param))
359
360
361
362
363
364
365
366
367






368
369
370

371
372
373
374
375
376
377
354
355
356
357
358
359
360


361
362
363
364
365
366
367
368

369
370
371
372
373
374
375
376







-
-
+
+
+
+
+
+


-
+







    (sqlite3:for-each-row
     (lambda (id)
       (set! res id))
     mdb ;; NEEDS dbprep ADDED
     "SELECT id FROM servers WHERE run_id=? AND state = 'running';" run-id)
    res))

(define (tasks:need-server run-id)
  (configf:lookup *configdat* "server" "required"))
(define (tasks:need-server run-id area-dat)
  (let ((req (configf:lookup (megatest:area-configdat area-dat) "server" "required")))
    (if (and req
	     (equal? req "yes"))
	#t
	#f)))

;; 	(maxqry (cdr (rmt:get-max-query-average run-id)))
;; 	(threshold   (string->number (or (configf:lookup *configdat* "server" "server-query-threshold") "10"))))
;; 	(threshold   (string->number (or (configf:lookup configdat "server" "server-query-threshold") "10"))))
;;     (cond
;;      (forced 
;;       (if (common:low-noise-print 60 run-id "server required is set")
;; 	  (debug:print-info 0 "Server required is set, starting server for run-id " run-id "."))
;;       #t)
;;      ((> maxqry threshold)
;;       (if (common:low-noise-print 60 run-id "Max query time execeeded")
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
509
510
511
512
513
514
515





















516
517
518
519
520
521
522







-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-







     (lambda (count)
       (set! res count))
     mdb
     "SELECT count(id) FROM monitors WHERE last_update < (strftime('%s','now') - 300) AND username=?;"
     (car (user-information (current-user-id))))
    res))

;; 
(define (tasks:start-monitor db mdb)
  (if (> (tasks:get-num-alive-monitors mdb) 2) ;; have two running, no need for more
      (debug:print-info 1 "Not starting monitor, already have more than two running")
      (let* ((megatestdb     (conc *toppath* "/megatest.db"))
	     (monitordbf     (conc (db:dbfile-path #f) "/monitor.db"))
	     (last-db-update 0)) ;; (file-modification-time megatestdb)))
	(task:register-monitor mdb)
	(let loop ((count      0)
		   (next-touch 0)) ;; next-touch is the time where we need to update last_update
	  ;; if the db has been modified we'd best look at the task queue
	  (let ((modtime (file-modification-time megatestdbpath )))
	    (if (> modtime last-db-update)
		(tasks:process-queue db mdb last-db-update megatestdb next-touch))
	    ;; WARNING: Possible race conditon here!!
	    ;; should this update be immediately after the task-get-action call above?
	    (if (> (current-seconds) next-touch)
		(begin
		  (tasks:monitors-update mdb)
		  (loop (+ count 1)(+ (current-seconds) 240)))
		(loop (+ count 1) next-touch)))))))
      
;;======================================================================
;; T A S K S   Q U E U E
;;
;;   NOTE:: These operate on task_queue which is in main.db
;;
;;======================================================================

Modified tests.scm from [f04a81c96a] to [25307e2263].

30
31
32
33
34
35
36
37
38


39
40
41

42
43

44
45
46
47
48
49
50
30
31
32
33
34
35
36


37
38
39
40

41
42

43
44
45
46
47
48
49
50







-
-
+
+


-
+

-
+







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

;; Call this one to do all the work and get a standardized list of tests
(define (tests:get-all)
  (let* ((test-search-path   (tests:get-tests-search-path *configdat*)))
(define (tests:get-all area-dat)
  (let* ((test-search-path   (tests:get-tests-search-path (megatest:area-configdat area-dat))))
    (tests:get-valid-tests (make-hash-table) test-search-path)))

(define (tests:get-tests-search-path cfgdat)
(define (tests:get-tests-search-path cfgdat area-dat)
  (let ((paths (map cadr (configf:get-section cfgdat "tests-paths"))))
    (append paths (list (conc *toppath* "/tests")))))
    (append paths (list (conc (megatest:area-path area-dat) "/tests")))))

(define (tests:get-valid-tests test-registry tests-paths)
  (if (null? tests-paths) 
      test-registry
      (let loop ((hed (car tests-paths))
		 (tal (cdr tests-paths)))
	(if (file-exists? hed)
582
583
584
585
586
587
588
589
590


591
592
593
594
595
596
597
582
583
584
585
586
587
588


589
590
591
592
593
594
595
596
597







-
-
+
+







;;     (delete-duplicates
;;      (filter (lambda (testname)
;; 	       (tests:match test-patts testname #f))
;; 	     (map (lambda (testp)
;; 		    (last (string-split testp "/")))
;; 		  tests)))))

(define (tests:get-testconfig test-name test-registry system-allowed)
  (let* ((test-path    (hash-table-ref/default test-registry test-name (conc *toppath* "/tests/" test-name)))
(define (tests:get-testconfig test-name test-registry system-allowed area-dat)
  (let* ((test-path    (hash-table-ref/default test-registry test-name (conc (megatest:area-path area-dat) "/tests/" test-name)))
	 (test-configf (conc test-path "/testconfig"))
	 (testexists   (and (file-exists? test-configf)(file-read-access? test-configf)))
	 (tcfg         (if testexists
			   (read-config test-configf #f system-allowed environ-patt: (if system-allowed
											 "pre-launch-env-vars"
											 #f))
			   #f)))

Modified zmq-transport.scm from [07f0ba479b] to [fa40b1e46e].

64
65
66
67
68
69
70
71

72
73

74
75
76
77
78
79
80
64
65
66
67
68
69
70

71
72

73
74
75
76
77
78
79
80







-
+

-
+







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

(define-inline (zmqsock:get-pub  dat)(vector-ref dat 0))
(define-inline (zmqsock:get-pull dat)(vector-ref dat 1))
(define-inline (zmqsock:set-pub! dat s)(vector-set! dat s 0))
(define-inline (zmqsock:set-pull! dat s)(vector-set! dat s 0))

(define (zmq-transport:run hostn)
(define (zmq-transport:run hostn area-dat)
  (debug:print 2 "Attempting to start the server ...")
  (if (not *toppath*)
  (if (not (megatest:area-path area-dat))
      (if (not (setup-for-run))
	  (begin
	    (debug:print 0 "ERROR: cannot find megatest.config, cannot start server, exiting")
	    (exit))))
  (let* ((db              (open-db)) ;; here we *do not* want to be opening and closing the db
	 (zmq-sdat1       #f)
	 (zmq-sdat2       #f)
107
108
109
110
111
112
113
114

115
116
117
118
119
120
121
107
108
109
110
111
112
113

114
115
116
117
118
119
120
121







-
+







    (set! *cache-on* #t)

    (set! *runremote* (vector pull-socket pub-socket)) ;; overloading the use of (common:get-remote remote) BUG!?

    ;; what to do when we quit
    ;;
;;     (on-exit (lambda ()
;; 	       (if (and *toppath* *server-info*)
;; 	       (if (and toppath *server-info*)
;; 		   (open-run-close tasks:server-deregister-self tasks:open-db (car *server-info*))
;; 		   (let loop () 
;; 		     (let ((queue-len 0))
;; 		       (thread-sleep! (random 5))
;; 		       (mutex-lock! *incoming-mutex*)
;; 		       (set! queue-len (length *incoming-data*))
;; 		       (mutex-unlock! *incoming-mutex*)
357
358
359
360
361
362
363
364
365
366



367
368
369
370
371

372
373
374
375
376
377
378
357
358
359
360
361
362
363



364
365
366
367
368
369
370

371
372
373
374
375
376
377
378







-
-
-
+
+
+




-
+







              (tasks:server-deregister-self tdb (get-host-name))
              (thread-sleep! 1)
              (debug:print-info 0 "Max cached queries was " *max-cache-size*)
              (debug:print-info 0 "Server shutdown complete. Exiting")
              (exit)))))))

;; all routes though here end in exit ...
(define (zmq-transport:launch)
  (if (not *toppath*)
      (if (not (setup-for-run))
(define (zmq-transport:launch run-id area-dat)
  (if (not (megatest:area-path area-dat))
      (if (not (launch:setup-for-run area-dat))
	  (begin
	    (debug:print 0 "ERROR: cannot find megatest.config, exiting")
	    (exit))))
  (debug:print-info 2 "Starting zmq server")
  (if *toppath* 
  (if (megatest:area-path area-dat)
      (let* (;; (th1 (make-thread (lambda ()
	     ;;      	       (let ((server-info #f))
	     ;;      		 ;; wait for the server to be online and available
	     ;;      		 (let loop ()
	     ;;			   (debug:print-info 2 "Waiting for the server to come online before starting heartbeat")
	     ;;      		   (thread-sleep! 2)
	     ;;      		   (mutex-lock! *heartbeat-mutex*)