Megatest

Check-in [a1d77f1a3b]
Login
Overview
Comment:Merged envprocessing into v1.60
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | v1.60_defunct
Files: files | file ages | folders
SHA1: a1d77f1a3b9c9db457a994ed8fa47f6ae9f234e8
User & Date: matt on 2016-03-06 20:52:59
Other Links: branch diff | manifest | tags
Context
2016-03-06
23:21
Check if process still ACTUALLY running and if not go ahead and start the test check-in: 93b72f20b1 user: matt tags: v1.60_defunct
20:52
Merged envprocessing into v1.60 check-in: a1d77f1a3b user: matt tags: v1.60_defunct
2016-03-04
14:11
tweak ordering of config processing again Closed-Leaf check-in: 0bfc8baff4 user: mrwellan tags: envprocessing
2016-02-25
16:55
Added envcap functionality Leaf check-in: e2bc4c591a user: mrwellan tags: v1.60
Changes

Modified common.scm from [faa48a9ca2] to [0341960d9f].

41
42
43
44
45
46
47

48

49

50
51

52
53
54
55
56
57
58
      (debug:print 0 "ERROR: bad value for setenv, key=" key ", value=" val)))

(define home (getenv "HOME"))
(define user (getenv "USER"))

;; GLOBAL GLETCHES
(define *db-keys* #f)

(define *configinfo* #f)

(define *configdat*  #f)

(define *toppath*    #f)
(define *already-seen-runconfig-info* #f)

(define *waiting-queue*     (make-hash-table))
(define *test-meta-updated* (make-hash-table))
(define *globalexitstatus*  0) ;; attempt to work around possible thread issues
(define *passnum*           0) ;; when running track calls to run-tests or similar
(define *write-frequency*   (make-hash-table)) ;; run-id => (vector (current-seconds) 0))
(define *alt-log-file* #f)  ;; used by -log
(define *common:denoise*    (make-hash-table)) ;; for low noise printing







>
|
>
|
>
|

>







41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
      (debug:print 0 "ERROR: bad value for setenv, key=" key ", value=" val)))

(define home (getenv "HOME"))
(define user (getenv "USER"))

;; GLOBAL GLETCHES
(define *db-keys* #f)

(define *configinfo*   #f)   ;; raw results from setup, includes toppath and table from megatest.config
(define *runconfigdat* #f)   ;; run configs data
(define *configdat*    #f)   ;; megatest.config data
(define *configstatus* #f)   ;; status of data; 'fulldata : all processing done, #f : no data yet, 'partialdata : partial read done
(define *toppath*      #f)
(define *already-seen-runconfig-info* #f)

(define *waiting-queue*     (make-hash-table))
(define *test-meta-updated* (make-hash-table))
(define *globalexitstatus*  0) ;; attempt to work around possible thread issues
(define *passnum*           0) ;; when running track calls to run-tests or similar
(define *write-frequency*   (make-hash-table)) ;; run-id => (vector (current-seconds) 0))
(define *alt-log-file* #f)  ;; used by -log
(define *common:denoise*    (make-hash-table)) ;; for low noise printing
445
446
447
448
449
450
451





452
453
454



455
456
457
458
459
460
461
462
463
464
465

466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
			    "%"))
	 (testpatt    (or (and (equal? args-testpatt "%")
			       rtestpatt)
			  args-testpatt)))
    (if rtestpatt (debug:print-info 0 "TESTPATT from runconfigs: " rtestpatt))
    testpatt))






(define (common:args-get-runname)
  (or (args:get-arg "-runname")
      (args:get-arg ":runname")))




(define (common:args-get-target #!key (split #f))
  (let* ((keys    (keys:config-get-fields *configdat*))
	 (numkeys (length keys))
	 (target  (if (args:get-arg "-reqtarg")
		      (args:get-arg "-reqtarg")
		      (if (args:get-arg "-target")
			  (args:get-arg "-target")
			  (getenv "MT_TARGET"))))
	 (tlist   (if target (string-split target "/" #t) '()))
	 (valid   (if target

		      (and (not (null? tlist))
			   (eq? numkeys (length tlist))
			   (null? (filter string-null? tlist)))
		      #f)))
    (if valid
	(if split
	    tlist
	    target)
	(if target
	    (begin
	      (debug:print 0 "ERROR: Invalid target, spaces or blanks not allowed \"" target "\", target should be: " (string-intersperse keys "/"))
	      #f)
	    #f))))

;;======================================================================
;; M I S C   L I S T S
;;======================================================================








>
>
>
>
>

|
|
>
>
>


|

<
|
<
|
|


>
|
|
|







|







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

471

472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
			    "%"))
	 (testpatt    (or (and (equal? args-testpatt "%")
			       rtestpatt)
			  args-testpatt)))
    (if rtestpatt (debug:print-info 0 "TESTPATT from runconfigs: " rtestpatt))
    testpatt))

(define (common:get-linktree)
  (or (getenv "MT_LINKTREE")
      (if *configdat*
	  (configf:lookup *configdat* "setup" "linktree"))))

(define (common:args-get-runname)
  (let ((res (or (args:get-arg "-runname")
		 (args:get-arg ":runname")
		 (getenv "MT_RUNNAME"))))
    ;; (if res (set-environment-variable "MT_RUNNAME" res)) ;; not sure if this is a good idea. side effect and all ...
    res))

(define (common:args-get-target #!key (split #f))
  (let* ((keys    (if *configdat* (keys:config-get-fields *configdat*) '()))
	 (numkeys (length keys))

	 (target  (or (args:get-arg "-reqtarg")

		      (args:get-arg "-target")
		      (getenv "MT_TARGET")))
	 (tlist   (if target (string-split target "/" #t) '()))
	 (valid   (if target
		      (or (null? keys) ;; probably don't know our keys yet
			  (and (not (null? tlist))
			       (eq? numkeys (length tlist))
			       (null? (filter string-null? tlist))))
		      #f)))
    (if valid
	(if split
	    tlist
	    target)
	(if target
	    (begin
	      (debug:print 0 "ERROR: Invalid target, spaces or blanks not allowed \"" target "\", target should be: " (string-intersperse keys "/") ", have " tlist " for elements")
	      #f)
	    #f))))

;;======================================================================
;; M I S C   L I S T S
;;======================================================================

Modified configf.scm from [39c9b380ea] to [ab4120ebb1].

97
98
99
100
101
102
103


104
105
106
107
108
109
110
				((rget)           (conc "(lambda (ht)(runconfigs-get ht \"" cmd "\"))"))
				(else "(lambda (ht)(print \"ERROR\") \"ERROR\")"))))
		;; (print "fullcmd=" fullcmd)
		(handle-exceptions
		 exn
		 (begin
		   (debug:print 0 "WARNING: failed to process config input \"" l "\"")


		   (set! result (conc "#{( " cmdtype ") " cmd"}")))
		 (if (or allow-system
			 (not (member cmdtype '("system" "shell"))))
		     (with-input-from-string fullcmd
		       (lambda ()
			 (set! result ((eval (read)) ht))))
		    (set! result (conc "#{(" cmdtype ") "  cmd "}"))))







>
>







97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
				((rget)           (conc "(lambda (ht)(runconfigs-get ht \"" cmd "\"))"))
				(else "(lambda (ht)(print \"ERROR\") \"ERROR\")"))))
		;; (print "fullcmd=" fullcmd)
		(handle-exceptions
		 exn
		 (begin
		   (debug:print 0 "WARNING: failed to process config input \"" l "\"")
		   (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))
		   ;; (print "exn=" (condition->list exn))
		   (set! result (conc "#{( " cmdtype ") " cmd"}")))
		 (if (or allow-system
			 (not (member cmdtype '("system" "shell"))))
		     (with-input-from-string fullcmd
		       (lambda ()
			 (set! result ((eval (read)) ht))))
		    (set! result (conc "#{(" cmdtype ") "  cmd "}"))))
157
158
159
160
161
162
163
164







165
166
167
168
169
170
171
			inl)
		       (else
			(configf:process-line inl ht allow-processing)))))
	    (if (and (string? res)
		     (not (equal? (hash-table-ref/default settings "trim-trailing-spaces" "no") "no")))
		(string-substitute "\\s+$" "" res)
		res))))))
      







;; read a config file, returns hash table of alists

;; read a config file, returns hash table of alists
;; adds to ht if given (must be #f otherwise)
;; envion-patt is a regex spec that identifies sections that will be eval'd
;; in the environment on the fly
;; sections: #f => get all, else list of sections to gather







|
>
>
>
>
>
>
>







159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
			inl)
		       (else
			(configf:process-line inl ht allow-processing)))))
	    (if (and (string? res)
		     (not (equal? (hash-table-ref/default settings "trim-trailing-spaces" "no") "no")))
		(string-substitute "\\s+$" "" res)
		res))))))
  
(define (calc-allow-system allow-system section sections)
  (if sections
      (and (or (equal? "default" section)
	       (member section sections))
	   allow-system) ;; account for sections and return allow-system as it might be a symbol such as return-strings
      allow-system))
    
;; read a config file, returns hash table of alists

;; read a config file, returns hash table of alists
;; adds to ht if given (must be #f otherwise)
;; envion-patt is a regex spec that identifies sections that will be eval'd
;; in the environment on the fly
;; sections: #f => get all, else list of sections to gather
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
	;; WARNING: This is a risky change but really, we should not return an empty hash table if no file read?
	#f) ;; (if (not ht)(make-hash-table) ht))
      (let ((inp        (open-input-file path))
	    (res        (if (not ht)(make-hash-table) ht))
	    (metapath   (if (or (debug:debug-mode 9)
				keep-filenames)
			    path #f)))
	(let loop ((inl               (configf:read-line inp res allow-system settings)) ;; (read-line inp))
		   (curr-section-name (if curr-section curr-section "default"))
		   (var-flag #f);; turn on for key-var-pr and cont-ln-rx, turn off elsewhere
		   (lead     #f))
	  (debug:print-info 8 "curr-section-name: " curr-section-name " var-flag: " var-flag "\n   inl: \"" inl "\"")
	  (if (eof-object? inl) 
	      (begin
		(close-input-port inp)
		(hash-table-delete! res "") ;; we are using "" as a dumping ground and must remove it before returning the ht
		(debug:print 9 "END: " path)
		res)
	      (regex-case 
	       inl 
	       (configf:comment-rx _                  (loop (configf:read-line inp res allow-system settings) curr-section-name #f #f))
	       (configf:blank-l-rx _                  (loop (configf:read-line inp res allow-system settings) curr-section-name #f #f))
	       (configf:settings   ( x setting val  ) (begin
							(hash-table-set! settings setting val)
							(loop (configf:read-line inp res allow-system settings) curr-section-name #f #f)))
	       (configf:include-rx ( x include-file ) (let* ((curr-conf-dir (pathname-directory path))
							     (full-conf     (if (absolute-pathname? include-file)
										include-file
										(nice-path 
										 (conc (if curr-conf-dir
											   curr-conf-dir
											   ".")
										       "/" include-file)))))
							(if (file-exists? full-conf)
							    (begin
							      ;; (push-directory conf-dir)
							      (debug:print 9 "Including: " full-conf)
							      (read-config full-conf res allow-system environ-patt: environ-patt curr-section: curr-section-name sections: sections settings: settings keep-filenames: keep-filenames)
							      ;; (pop-directory)
							      (loop (configf:read-line inp res allow-system settings) curr-section-name #f #f))
							    (begin
							      (debug:print '(2 9) "INFO: include file " include-file " not found (called from " path ")")
							      (debug:print 2 "        " full-conf)
							      (loop (configf:read-line inp res allow-system settings) curr-section-name #f #f)))))
	       (configf:section-rx ( x section-name ) (begin
							;; call post-section-procs
							(for-each 
							 (lambda (dat)
							   (let ((patt (car dat))
								 (proc (cdr dat)))
							     (if (string-match patt curr-section-name)
								 (proc curr-section-name section-name res path))))
							 post-section-procs)
							(loop (configf:read-line inp res allow-system settings)
							      ;; if we have the sections list then force all settings into "" and delete it later?
							      (if (or (not sections) 
								      (member section-name sections))
								  section-name "") ;; stick everything into ""
							      #f #f)))
	       (configf:key-sys-pr ( x key cmd      ) (if allow-system
							  (let ((alist    (hash-table-ref/default res curr-section-name '()))
								(val-proc (lambda ()
									    (let* ((start-time (current-seconds))
										   (cmdres     (process:cmd-run->list cmd))
										   (delta      (- (current-seconds) start-time))
										   (status     (cadr cmdres))
										   (res        (car  cmdres)))







|












|
|


|














|



|









|





|







189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
	;; WARNING: This is a risky change but really, we should not return an empty hash table if no file read?
	#f) ;; (if (not ht)(make-hash-table) ht))
      (let ((inp        (open-input-file path))
	    (res        (if (not ht)(make-hash-table) ht))
	    (metapath   (if (or (debug:debug-mode 9)
				keep-filenames)
			    path #f)))
	(let loop ((inl               (configf:read-line inp res (calc-allow-system allow-system curr-section sections) settings)) ;; (read-line inp))
		   (curr-section-name (if curr-section curr-section "default"))
		   (var-flag #f);; turn on for key-var-pr and cont-ln-rx, turn off elsewhere
		   (lead     #f))
	  (debug:print-info 8 "curr-section-name: " curr-section-name " var-flag: " var-flag "\n   inl: \"" inl "\"")
	  (if (eof-object? inl) 
	      (begin
		(close-input-port inp)
		(hash-table-delete! res "") ;; we are using "" as a dumping ground and must remove it before returning the ht
		(debug:print 9 "END: " path)
		res)
	      (regex-case 
	       inl 
	       (configf:comment-rx _                  (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))
	       (configf:blank-l-rx _                  (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))
	       (configf:settings   ( x setting val  ) (begin
							(hash-table-set! settings setting val)
							(loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)))
	       (configf:include-rx ( x include-file ) (let* ((curr-conf-dir (pathname-directory path))
							     (full-conf     (if (absolute-pathname? include-file)
										include-file
										(nice-path 
										 (conc (if curr-conf-dir
											   curr-conf-dir
											   ".")
										       "/" include-file)))))
							(if (file-exists? full-conf)
							    (begin
							      ;; (push-directory conf-dir)
							      (debug:print 9 "Including: " full-conf)
							      (read-config full-conf res allow-system environ-patt: environ-patt curr-section: curr-section-name sections: sections settings: settings keep-filenames: keep-filenames)
							      ;; (pop-directory)
							      (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))
							    (begin
							      (debug:print '(2 9) "INFO: include file " include-file " not found (called from " path ")")
							      (debug:print 2 "        " full-conf)
							      (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)))))
	       (configf:section-rx ( x section-name ) (begin
							;; call post-section-procs
							(for-each 
							 (lambda (dat)
							   (let ((patt (car dat))
								 (proc (cdr dat)))
							     (if (string-match patt curr-section-name)
								 (proc curr-section-name section-name res path))))
							 post-section-procs)
							(loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings)
							      ;; if we have the sections list then force all settings into "" and delete it later?
							      (if (or (not sections) 
								      (member section-name sections))
								  section-name "") ;; stick everything into ""
							      #f #f)))
	       (configf:key-sys-pr ( x key cmd      ) (if (calc-allow-system allow-system curr-section-name sections)
							  (let ((alist    (hash-table-ref/default res curr-section-name '()))
								(val-proc (lambda ()
									    (let* ((start-time (current-seconds))
										   (cmdres     (process:cmd-run->list cmd))
										   (delta      (- (current-seconds) start-time))
										   (status     (cadr cmdres))
										   (res        (car  cmdres)))
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
										  (debug:print-info 9 "for line \"" inl "\"\n  command: " cmd " took " delta " seconds to run with output:\n   " res))
									      (if (null? res)
										  ""
										  (string-intersperse res " "))))))
							    (hash-table-set! res curr-section-name 
									     (config:assoc-safe-add alist
									   			    key 
												    (case allow-system
												      ((return-procs) val-proc)
												      ((return-string) cmd)
												      (else (val-proc)))
												    metadata: metapath))
							    (loop (configf:read-line inp res allow-system settings) curr-section-name #f #f))
							  (loop (configf:read-line inp res allow-system settings) curr-section-name #f #f)))
	       (configf:key-val-pr ( x key unk1 val unk2 ) (let* ((alist   (hash-table-ref/default res curr-section-name '()))
								  (envar   (and environ-patt (string-search (regexp environ-patt) curr-section-name)))
								  (realval (if envar
									       (config:eval-string-in-environment val)
									       val)))
							     (debug:print-info 6 "read-config env setting, envar: " envar " realval: " realval " val: " val " key: " key " curr-section-name: " curr-section-name)
							     (if envar (safe-setenv key realval))
							     (debug:print 10 "   setting: [" curr-section-name "] " key " = " val)
							     (hash-table-set! res curr-section-name 
									      (config:assoc-safe-add alist key realval metadata: metapath))
							     (loop (configf:read-line inp res allow-system settings) curr-section-name key #f)))
	       (configf:key-no-val ( x key val)             (let* ((alist   (hash-table-ref/default res curr-section-name '())))
							      (debug:print 10 "   setting: [" curr-section-name "] " key " = #t")
							      (hash-table-set! res curr-section-name 
									       (config:assoc-safe-add alist key #t metadata: metapath))
							      (loop (configf:read-line inp res allow-system settings) curr-section-name key #f)))
	       ;; if a continued line
	       (configf:cont-ln-rx ( x whsp val     ) (let ((alist (hash-table-ref/default res curr-section-name '())))
						(if var-flag             ;; if set to a string then we have a continued var
						    (let ((newval (conc 
								   (config-lookup res curr-section-name var-flag) "\n"
								   ;; trim lead from the incoming whsp to support some indenting.
								   (if lead
								       (string-substitute (regexp lead) "" whsp)
								       "")
								   val)))
						      ;; (print "val: " val "\nnewval: \"" newval "\"\nvarflag: " var-flag)
						      (hash-table-set! res curr-section-name 
								       (config:assoc-safe-add alist var-flag newval metadata: metapath))
						      (loop (configf:read-line inp res allow-system settings) curr-section-name var-flag (if lead lead whsp)))
						    (loop (configf:read-line inp res allow-system settings) curr-section-name #f #f))))
	       (else (debug:print 0 "ERROR: problem parsing " path ",\n   \"" inl "\"")
		     (set! var-flag #f)
		     (loop (configf:read-line inp res allow-system settings) curr-section-name #f #f))))))))
  
;; pathenvvar will set the named var to the path of the config
(define (find-and-read-config fname #!key (environ-patt #f)(given-toppath #f)(pathenvvar #f))
  (let* ((curr-dir   (current-directory))
         (configinfo (find-config fname toppath: given-toppath))
	 (toppath    (car configinfo))
	 (configfile (cadr configinfo))







|




|
|










|




|













|
|


|







263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
										  (debug:print-info 9 "for line \"" inl "\"\n  command: " cmd " took " delta " seconds to run with output:\n   " res))
									      (if (null? res)
										  ""
										  (string-intersperse res " "))))))
							    (hash-table-set! res curr-section-name 
									     (config:assoc-safe-add alist
									   			    key 
												    (case (calc-allow-system allow-system curr-section-name sections)
												      ((return-procs) val-proc)
												      ((return-string) cmd)
												      (else (val-proc)))
												    metadata: metapath))
							    (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))
							  (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)))
	       (configf:key-val-pr ( x key unk1 val unk2 ) (let* ((alist   (hash-table-ref/default res curr-section-name '()))
								  (envar   (and environ-patt (string-search (regexp environ-patt) curr-section-name)))
								  (realval (if envar
									       (config:eval-string-in-environment val)
									       val)))
							     (debug:print-info 6 "read-config env setting, envar: " envar " realval: " realval " val: " val " key: " key " curr-section-name: " curr-section-name)
							     (if envar (safe-setenv key realval))
							     (debug:print 10 "   setting: [" curr-section-name "] " key " = " val)
							     (hash-table-set! res curr-section-name 
									      (config:assoc-safe-add alist key realval metadata: metapath))
							     (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name key #f)))
	       (configf:key-no-val ( x key val)             (let* ((alist   (hash-table-ref/default res curr-section-name '())))
							      (debug:print 10 "   setting: [" curr-section-name "] " key " = #t")
							      (hash-table-set! res curr-section-name 
									       (config:assoc-safe-add alist key #t metadata: metapath))
							      (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name key #f)))
	       ;; if a continued line
	       (configf:cont-ln-rx ( x whsp val     ) (let ((alist (hash-table-ref/default res curr-section-name '())))
						(if var-flag             ;; if set to a string then we have a continued var
						    (let ((newval (conc 
								   (config-lookup res curr-section-name var-flag) "\n"
								   ;; trim lead from the incoming whsp to support some indenting.
								   (if lead
								       (string-substitute (regexp lead) "" whsp)
								       "")
								   val)))
						      ;; (print "val: " val "\nnewval: \"" newval "\"\nvarflag: " var-flag)
						      (hash-table-set! res curr-section-name 
								       (config:assoc-safe-add alist var-flag newval metadata: metapath))
						      (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name var-flag (if lead lead whsp)))
						    (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))))
	       (else (debug:print 0 "ERROR: problem parsing " path ",\n   \"" inl "\"")
		     (set! var-flag #f)
		     (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))))))))
  
;; pathenvvar will set the named var to the path of the config
(define (find-and-read-config fname #!key (environ-patt #f)(given-toppath #f)(pathenvvar #f))
  (let* ((curr-dir   (current-directory))
         (configinfo (find-config fname toppath: given-toppath))
	 (toppath    (car configinfo))
	 (configfile (cadr configinfo))

Modified dashboard.scm from [71913c62bc] to [53c344e229].

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

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

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

(define *useserver* (cond
		     ((args:get-arg "-use-local") #f)
		     ((configf:lookup *configdat* "dashboard" "use-server")







|







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

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

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

(define *useserver* (cond
		     ((args:get-arg "-use-local") #f)
		     ((configf:lookup *configdat* "dashboard" "use-server")
237
238
239
240
241
242
243

244
245
246
247
248
249
250
	(if same-time
	    (string>? item-path1 item-path2)
	    test1-older)
	(if same-time
	    (string>? test-name1 test-name2)
	    test1-older))))
    

;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") )
(define (update-rundat runnamepatt numruns testnamepatt keypatts)
  (let* ((referenced-run-ids '())
	 (allruns     (if *useserver*
			  (rmt:get-runs runnamepatt numruns *start-run-offset* keypatts)
			  (db:get-runs *dbstruct-local* runnamepatt numruns ;; (+ numruns 1) ;; (/ numruns 2))
				      *start-run-offset* keypatts)))







>







237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
	(if same-time
	    (string>? item-path1 item-path2)
	    test1-older)
	(if same-time
	    (string>? test-name1 test-name2)
	    test1-older))))
    
;; create a virtual table of all the tests
;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") )
(define (update-rundat runnamepatt numruns testnamepatt keypatts)
  (let* ((referenced-run-ids '())
	 (allruns     (if *useserver*
			  (rmt:get-runs runnamepatt numruns *start-run-offset* keypatts)
			  (db:get-runs *dbstruct-local* runnamepatt numruns ;; (+ numruns 1) ;; (/ numruns 2))
				      *start-run-offset* keypatts)))

Modified db.scm from [bc1592a9a9] to [69f200d345].

726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
;;  'old2new      - sync megatest.db records to .db/{main,1,2 ...}.db
;;  'new2old      - sync .db/{main,1,2,3 ...}.db to megatest.db
;;  'closeall     - close all opened dbs
;;
;;  run-ids: '(1 2 3 ...) or #f (for all)
;;
(define (db:multi-db-sync run-ids . options)
  (let* ((toppath  (launch:setup-for-run))
	 (dbstruct (if toppath (make-dbr:dbstruct path: toppath) #f))
	 (mtdb     (if toppath (db:open-megatest-db)))
	 (allow-cleanup (if run-ids #f #t))
	 (run-ids  (if run-ids 
		       run-ids
		       (if toppath (begin
				     (db:delay-if-busy mtdb)







|







726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
;;  'old2new      - sync megatest.db records to .db/{main,1,2 ...}.db
;;  'new2old      - sync .db/{main,1,2,3 ...}.db to megatest.db
;;  'closeall     - close all opened dbs
;;
;;  run-ids: '(1 2 3 ...) or #f (for all)
;;
(define (db:multi-db-sync run-ids . options)
  (let* ((toppath  (launch:setup))
	 (dbstruct (if toppath (make-dbr:dbstruct path: toppath) #f))
	 (mtdb     (if toppath (db:open-megatest-db)))
	 (allow-cleanup (if run-ids #f #t))
	 (run-ids  (if run-ids 
		       run-ids
		       (if toppath (begin
				     (db:delay-if-busy mtdb)

Modified docs/manual/Makefile from [e2d37f7054] to [a64e790e18].

1
2
3
4
5
6
7
8
9
10

ASCPATH = $(shell which asciidoc)
EXEPATH = $(shell realpath $(ASCPATH))
BINPATH = $(shell dirname $(EXEPATH))
DISPATH = $(shell dirname $(BINPATH))

# broad_goals.csv  needed_features.csv : tables/*.dat
#         ./refdb2csv tables

# in a makefile recipe, $< denotes the first dependency; $@ the target


|







1
2
3
4
5
6
7
8
9
10

ASCPATH = $(shell which asciidoc)
EXEPATH = $(shell readlink -f $(ASCPATH))
BINPATH = $(shell dirname $(EXEPATH))
DISPATH = $(shell dirname $(BINPATH))

# broad_goals.csv  needed_features.csv : tables/*.dat
#         ./refdb2csv tables

# in a makefile recipe, $< denotes the first dependency; $@ the target

Modified docs/manual/megatest_manual.html from [56893fab94] to [b68f6ebfc8].

1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
<div class="content monospaced">
<pre>runscript main.csh</pre>
</div></div>
</div>
</div>
<div class="sect2">
<h3 id="_requirements_section">Requirements section</h3>
<div class="sect3">
<h4 id="_header_2">Header</h4>
<div class="listingblock">
<div class="content monospaced">
<pre>[requirements]</pre>
</div></div>
</div>
<div class="sect3">
<h4 id="_wait_on_other_tests">Wait on Other Tests</h4>
<div class="listingblock">
<div class="content monospaced">
<pre># A normal waiton waits for the prior tests to be COMPLETED
# and PASS, CHECK or WAIVED
waiton test1 test2</pre>







|
<
|



<







1175
1176
1177
1178
1179
1180
1181
1182

1183
1184
1185
1186

1187
1188
1189
1190
1191
1192
1193
<div class="content monospaced">
<pre>runscript main.csh</pre>
</div></div>
</div>
</div>
<div class="sect2">
<h3 id="_requirements_section">Requirements section</h3>
<div class="listingblock">

<div class="title">Header</div>
<div class="content monospaced">
<pre>[requirements]</pre>
</div></div>

<div class="sect3">
<h4 id="_wait_on_other_tests">Wait on Other Tests</h4>
<div class="listingblock">
<div class="content monospaced">
<pre># A normal waiton waits for the prior tests to be COMPLETED
# and PASS, CHECK or WAIVED
waiton test1 test2</pre>
1216
1217
1218
1219
1220
1221
1222















1223
1224
1225
1226
1227
1228
1229
"itemmatch" are synonyms.</p></div>
<div class="listingblock">
<div class="content monospaced">
<pre>[requirements]
mode itemmatch</pre>
</div></div>
</div>















</div>
<div class="sect2">
<h3 id="_itemmap_handling">Itemmap Handling</h3>
<div class="paragraph"><p>For cases were the dependent test has a similar but not identical
itempath to the downstream test an itemmap can allow for itemmatch
mode</p></div>
<div class="listingblock">







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
"itemmatch" are synonyms.</p></div>
<div class="listingblock">
<div class="content monospaced">
<pre>[requirements]
mode itemmatch</pre>
</div></div>
</div>
</div>
<div class="sect2">
<h3 id="_overriding_enviroment_variables">Overriding Enviroment Variables</h3>
<div class="paragraph"><p>Override variables before starting the test. Can include files (perhaps generated by megatest -envdelta or similar).</p></div>
<div class="listingblock">
<div class="content monospaced">
<pre>[pre-launch-env-vars]
VAR1 value1

# Get some generated settings
[include ../generated-vars.config]

# Use this trick to unset variables
#{scheme (unsetenv "FOOBAR")}</pre>
</div></div>
</div>
<div class="sect2">
<h3 id="_itemmap_handling">Itemmap Handling</h3>
<div class="paragraph"><p>For cases were the dependent test has a similar but not identical
itempath to the downstream test an itemmap can allow for itemmatch
mode</p></div>
<div class="listingblock">
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
<div class="title">Testconfig for Test C</div>
<div class="content monospaced">
<pre>[requirements]
waiton A B

[itemmap]
A (\d+)/aa aa/\1
B (\d+)/bb bb/\1</pre>
</div></div>
<div class="listingblock">
<div class="title">Testconfig for Test D</div>
<div class="content monospaced">
<pre>[requirements]
waiton C
itemmap (\d+)/res \1/aa</pre>







|







1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
<div class="title">Testconfig for Test C</div>
<div class="content monospaced">
<pre>[requirements]
waiton A B

[itemmap]
A (\d+)/aa aa/\1
B (\d+)/bb</pre>
</div></div>
<div class="listingblock">
<div class="title">Testconfig for Test D</div>
<div class="content monospaced">
<pre>[requirements]
waiton C
itemmap (\d+)/res \1/aa</pre>
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328

1329
1330
1331
1332
1333
1334
1335
1336
<div class="listingblock">
<div class="title">Autogeneration waiton list for dynamic flow dependency trees</div>
<div class="content monospaced">
<pre>[requirements]
# With a toplevel test you may wish to generate your list
# of tests to run dynamically
#
# waiton #{shell get-valid-tests-to-run.sh}</pre>
</div></div>
</div>
<div class="sect3">
<h4 id="_run_time_limit_2">Run time limit</h4>
<div class="listingblock">
<div class="content monospaced">

<pre>runtimelim 1h 2m 3s  # this will automatically kill the test if it runs for more than 1h 2m and 3s</pre>
</div></div>
</div>
<div class="sect3">
<h4 id="_skip">Skip</h4>
<div class="paragraph"><p>A test with a skip section will conditional skip running.</p></div>
<div class="listingblock">
<div class="title">Skip section example</div>







|






>
|







1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
<div class="listingblock">
<div class="title">Autogeneration waiton list for dynamic flow dependency trees</div>
<div class="content monospaced">
<pre>[requirements]
# With a toplevel test you may wish to generate your list
# of tests to run dynamically
#
waiton #{shell get-valid-tests-to-run.sh}</pre>
</div></div>
</div>
<div class="sect3">
<h4 id="_run_time_limit_2">Run time limit</h4>
<div class="listingblock">
<div class="content monospaced">
<pre>[requirements]
runtimelim 1h 2m 3s  # this will automatically kill the test if it runs for more than 1h 2m and 3s</pre>
</div></div>
</div>
<div class="sect3">
<h4 id="_skip">Skip</h4>
<div class="paragraph"><p>A test with a skip section will conditional skip running.</p></div>
<div class="listingblock">
<div class="title">Skip section example</div>
1483
1484
1485
1486
1487
1488
1489











































1490
1491
1492
1493
1494
1495
1496

# Archives will be organised under these paths like this:
#  &lt;testsuite&gt;/&lt;creationdate&gt;
# Within the archive the data is structured like this:
#  &lt;target&gt;/&lt;runname&gt;/&lt;test&gt;/
archive0 /mfs/myarchive-data/adisk1</pre>
</div></div>











































</div>
</div>
<div class="sect1">
<h2 id="_programming_api">Programming API</h2>
<div class="sectionbody">
<div class="paragraph"><p>These routines can be called from the megatest repl.</p></div>
<table class="tableblock frame-topbot grid-all"







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553

# Archives will be organised under these paths like this:
#  &lt;testsuite&gt;/&lt;creationdate&gt;
# Within the archive the data is structured like this:
#  &lt;target&gt;/&lt;runname&gt;/&lt;test&gt;/
archive0 /mfs/myarchive-data/adisk1</pre>
</div></div>
</div>
</div>
<div class="sect1">
<h2 id="_handling_environment_variables">Handling Environment Variables</h2>
<div class="sectionbody">
<div class="paragraph"><p>It is often necessary to capture and or manipulate environment
variables. Megatest has some facilities built in to help.</p></div>
<div class="sect2">
<h3 id="_capture_variables">Capture variables</h3>
<div class="listingblock">
<div class="title">Commands</div>
<div class="content monospaced">
<pre># capture the current enviroment into a db called envdat.db under
# the context "before"
megatest -envcap before

# capture the current environment into a db called startup.db with
# context "after"
megatest -envcap after startup.db

# write the diff from before to after
megatest -envdelta before-after -dumpmode bash</pre>
</div></div>
<div class="paragraph"><p>Dump modes include bash, csh and config. You can include config data
into megatest.config or runconfigs.config.</p></div>
<div class="listingblock">
<div class="title">Example of generating and using config data</div>
<div class="content monospaced">
<pre>megatest -envcap original
# do some stuff here
megatest -envcap munged
megatest -envdelta original-munged -dumpmode ini -o modified.config</pre>
</div></div>
<div class="paragraph"><p>Then in runconfigs.config</p></div>
<div class="listingblock">
<div class="title">Example of using modified.config in a testconfig</div>
<div class="content monospaced">
<pre>cat testconfig

[pre-launch-env-vars]
[include modified.config]</pre>
</div></div>
</div>
</div>
</div>
<div class="sect1">
<h2 id="_programming_api">Programming API</h2>
<div class="sectionbody">
<div class="paragraph"><p>These routines can be called from the megatest repl.</p></div>
<table class="tableblock frame-topbot grid-all"
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
</div>
</div>
</div>
<div id="footnotes"><hr></div>
<div id="footer">
<div id="footer-text">
Version 1.0<br>
Last updated
 2015-09-10 21:54:17 MST
</div>
</div>
</body>
</html>







|
<




1711
1712
1713
1714
1715
1716
1717
1718

1719
1720
1721
1722
</div>
</div>
</div>
<div id="footnotes"><hr></div>
<div id="footer">
<div id="footer-text">
Version 1.0<br>
Last updated 2015-09-13 12:16:43 MST

</div>
</div>
</body>
</html>

Modified docs/manual/reference.txt from [88bde1cc13] to [d17e965846].

87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
-------------------
runscript main.csh
-------------------

Requirements section
~~~~~~~~~~~~~~~~~~~~

Header
^^^^^^

-------------------
[requirements]
-------------------

Wait on Other Tests
^^^^^^^^^^^^^^^^^^^








|
<
<







87
88
89
90
91
92
93
94


95
96
97
98
99
100
101
-------------------
runscript main.csh
-------------------

Requirements section
~~~~~~~~~~~~~~~~~~~~

.Header


-------------------
[requirements]
-------------------

Wait on Other Tests
^^^^^^^^^^^^^^^^^^^

130
131
132
133
134
135
136
















137
138
139
140
141
142
143
was historically called "itemwait" mode. The terms "itemwait" and
"itemmatch" are synonyms.

-------------------
[requirements]
mode itemmatch
-------------------

















Itemmap Handling
~~~~~~~~~~~~~~~~

For cases were the dependent test has a similar but not identical
itempath to the downstream test an itemmap can allow for itemmatch
mode







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
was historically called "itemwait" mode. The terms "itemwait" and
"itemmatch" are synonyms.

-------------------
[requirements]
mode itemmatch
-------------------

Overriding Enviroment Variables
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

Override variables before starting the test. Can include files (perhaps generated by megatest -envdelta or similar).

--------------------
[pre-launch-env-vars]
VAR1 value1

# Get some generated settings
[include ../generated-vars.config]

# Use this trick to unset variables
#{scheme (unsetenv "FOOBAR")}
--------------------

Itemmap Handling
~~~~~~~~~~~~~~~~

For cases were the dependent test has a similar but not identical
itempath to the downstream test an itemmap can allow for itemmatch
mode
184
185
186
187
188
189
190

191
192
193
194
195
196
197
198
.Testconfig for Test C
----------------------
[requirements]
waiton A B

[itemmap]
A (\d+)/aa aa/\1

B (\d+)/bb --------------------

.Testconfig for Test D
----------------------
[requirements]
waiton C
itemmap (\d+)/res \1/aa
----------------------







>
|







198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
.Testconfig for Test C
----------------------
[requirements]
waiton A B

[itemmap]
A (\d+)/aa aa/\1
B (\d+)/bb 
----------------------

.Testconfig for Test D
----------------------
[requirements]
waiton C
itemmap (\d+)/res \1/aa
----------------------
382
383
384
385
386
387
388












































389
390
391
392
393
394
395

# Archives will be organised under these paths like this:
#  <testsuite>/<creationdate>
# Within the archive the data is structured like this:
#  <target>/<runname>/<test>/
archive0 /mfs/myarchive-data/adisk1
--------------













































Programming API
---------------

These routines can be called from the megatest repl. 

.API Server Management Calls







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454

# Archives will be organised under these paths like this:
#  <testsuite>/<creationdate>
# Within the archive the data is structured like this:
#  <target>/<runname>/<test>/
archive0 /mfs/myarchive-data/adisk1
--------------

Handling Environment Variables
------------------------------

It is often necessary to capture and or manipulate environment
variables. Megatest has some facilities built in to help.

Capture variables
~~~~~~~~~~~~~~~~~

.Commands
------------------------------
# capture the current enviroment into a db called envdat.db under
# the context "before"
megatest -envcap before

# capture the current environment into a db called startup.db with 
# context "after"
megatest -envcap after startup.db

# write the diff from before to after
megatest -envdelta before-after -dumpmode bash
------------------------------

Dump modes include bash, csh and config. You can include config data
into megatest.config or runconfigs.config.

.Example of generating and using config data
------------------------------
megatest -envcap original
# do some stuff here
megatest -envcap munged
megatest -envdelta original-munged -dumpmode ini -o modified.config
------------------------------

Then in runconfigs.config

.Example of using modified.config in a testconfig
------------------------------
cat testconfig

[pre-launch-env-vars]
[include modified.config]
------------------------------

Programming API
---------------

These routines can be called from the megatest repl. 

.API Server Management Calls

Modified docs/manual/server.png from [524d8b2847] to [a508d3edd1].

cannot compute difference between binary files

Modified env.scm from [32a90275e2] to [15c6fe90f1].

25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43


44
45
46
47
48
49



















































50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72

73

74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105


































































                    val TEXT NOT NULL,
                       CONSTRAINT envvars_constraint UNIQUE (context,var))"))))
    (set-busy-handler! db (busy-timeout 10000))
    db))

;; save vars in given context, this is NOT incremental by default
;;
(define (env:save-env-vars db context #!key (incremental #f))
  (with-transaction
   db
   (lambda ()
     ;; first clear out any vars for this context
     (if (not incremental)(exec (sql db "DELETE FROM envvars WHERE context=?") context))
     (for-each
      (lambda (varval)
	(let ((var (car varval))
	      (val (cdr varval)))
	  (if incremental (exec (sql db "DELETE FROM envvars WHERE context=? AND var=?") context var))
	  (exec (sql db "INSERT INTO envvars (context,var,val) VALUES (?,?,?)") context var val)))


	(get-environment-variables)))))

;; apply contexts to current environment
;;  - each context is applied in the given order
;;  - variables in the paths list are split on the separator and the components
;;    merged using simple delta addition



















































;;
(define (env:apply-contexts db basecontext contexts paths outputf formats)
  
  (for-each
   (lambda (context)
     (query
      (for-each-row
       (lambda (row)
	 (let ((var  (car row))
	       (vala (cadr row))
	       (valb (caddr row)))
	    ;;(print "var: " var " vala: " vala " valb" valb " paths: " paths)
	   (if (assoc var paths) ;; this var is a PATH
	       (let ((current (get-environment-variable var))) ;; use this NOT vala
	         ;;(pp paths)
                 ;;(pp var)
		 (env:process-path-envvar var (cadr (assoc var paths)) current valb))
	       (begin
		 (setenv var valb))))))
      (sql db "SELECT b.var,a.val,b.val FROM envvars AS a JOIN envvars AS b ON a.var=b.var WHERE a.context=? AND b.context=? AND a.val != b.val")
      ;;(sql db "SELECT b.var,a.val,b.val FROM envvars AS a JOIN envvars AS b ON a.var=b.var WHERE a.context=? AND b.context=?")
      basecontext context))
   contexts))



(define (env:blind-merge l1 l2)
  (if (null? l1) l2
      (if (null? l2) l1
	  (cons (car l1) (cons (car l2) (env:blind-merge (cdr l1) (cdr l2)))))))

;; given a before and an after envvar calculate a new merged path
;;
(define (env:merge-path-envvar separator patha pathb)
  (let* ((patha-parts  (string-split patha separator))
	 (pathb-parts  (string-split pathb separator))
	 (common-parts (lset-intersection equal? patha-parts pathb-parts))
	 (final        (delete-duplicates ;; env:blind-merge 
			(append pathb-parts common-parts patha-parts))))
;;     (print "BEFORE:   " (string-intersperse patha-parts  "\n       "))
;;     (print "AFTER:    " (string-intersperse pathb-parts  "\n       "))
;;     (print "COMMON:   " (string-intersperse common-parts "\n       "))
    (string-intersperse final separator)))

(define (env:process-path-envvar varname separator patha pathb)
  (begin
    (print "Process-path-envvar: " varname)
  ) 
  (let ((newpath (env:merge-path-envvar separator patha pathb)))
    (setenv varname newpath)))

(define (env:have-context db context)
  (> (query fetch-value (sql db "SELECT count(id) FROM envvars WHERE context=?") context)
     0))

;; this is so the calling block does not need to import sql-de-lite
(define (env:close-database db)
  (close-database db))









































































|











>
>
|

|



>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>

|
|
<
<
|
|
|
|
|
<
<
<
<
<
<
<
<
|
<
|
<
|
>

>



















<
<
<










>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
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
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
                    val TEXT NOT NULL,
                       CONSTRAINT envvars_constraint UNIQUE (context,var))"))))
    (set-busy-handler! db (busy-timeout 10000))
    db))

;; save vars in given context, this is NOT incremental by default
;;
(define (env:save-env-vars db context #!key (incremental #f)(vardat #f))
  (with-transaction
   db
   (lambda ()
     ;; first clear out any vars for this context
     (if (not incremental)(exec (sql db "DELETE FROM envvars WHERE context=?") context))
     (for-each
      (lambda (varval)
	(let ((var (car varval))
	      (val (cdr varval)))
	  (if incremental (exec (sql db "DELETE FROM envvars WHERE context=? AND var=?") context var))
	  (exec (sql db "INSERT INTO envvars (context,var,val) VALUES (?,?,?)") context var val)))
	(if vardat
	    (hash-table->alist vardat)
	    (get-environment-variables))))))

;; merge contexts in the order given
;;  - each context is applied in the given order
;;  - variables in the paths list are split on the separator and the components
;;    merged using simple delta addition
;;    returns a hash of the merged vars
;;
(define (env:merge-contexts db basecontext contexts paths)
  (let ((result (make-hash-table)))
    (for-each
     (lambda (context)
       (query
	(for-each-row
	 (lambda (row)
	   (let ((var  (car row))
		 (val  (cadr row)))
	     (hash-table-set! result var 
			      (if (and (hash-table-ref/default results var #f)
				       (assoc var paths)) ;; this var is a path and there is a previous path
				  (let ((sep (cadr (assoc var paths))))
				    (env:merge-path-envvar sep (hash-table-ref results var) valb))
				  valb)))))
	(sql db "SELECT var,val FROM envvars WHERE context=?")
	context))
     contexts)
    result))

;;  get list of removed variables between two contexts
;;
(define (env:get-removed db contexta contextb)
  (let ((result (make-hash-table)))
    (query
     (for-each-row
      (lambda (row)
	(let ((var  (car row))
	      (val  (cadr row)))
	  (hash-table-set! result var val))))
     (sql db "SELECT var,val FROM envvars WHERE context=? AND var NOT IN (SELECT var FROM envvars WHERE context=?)")
     contexta contextb)
    result))

;;  get list of variables added to contextb from contexta
;;
(define (env:get-added db contexta contextb)
  (let ((result (make-hash-table)))
    (query
     (for-each-row
      (lambda (row)
	(let ((var  (car row))
	      (val  (cadr row)))
	  (hash-table-set! result var val))))
     (sql db "SELECT var,val FROM envvars WHERE context=? AND var NOT IN (SELECT var FROM envvars WHERE context=?)")
     contextb contexta)
    result))

;;  get list of variables in both contexta and contexb that have been changed
;;
(define (env:get-changed db contexta contextb)
  (let ((result (make-hash-table)))


    (query
     (for-each-row
      (lambda (row)
	(let ((var  (car row))
	      (val  (cadr row)))








	  (hash-table-set! result var val))))

     (sql db "SELECT var,val FROM envvars AS a WHERE context=? AND val != (SELECT val FROM envvars WHERE var=a.var AND context=?)")

     contexta contextb)
    result))

;;
(define (env:blind-merge l1 l2)
  (if (null? l1) l2
      (if (null? l2) l1
	  (cons (car l1) (cons (car l2) (env:blind-merge (cdr l1) (cdr l2)))))))

;; given a before and an after envvar calculate a new merged path
;;
(define (env:merge-path-envvar separator patha pathb)
  (let* ((patha-parts  (string-split patha separator))
	 (pathb-parts  (string-split pathb separator))
	 (common-parts (lset-intersection equal? patha-parts pathb-parts))
	 (final        (delete-duplicates ;; env:blind-merge 
			(append pathb-parts common-parts patha-parts))))
;;     (print "BEFORE:   " (string-intersperse patha-parts  "\n       "))
;;     (print "AFTER:    " (string-intersperse pathb-parts  "\n       "))
;;     (print "COMMON:   " (string-intersperse common-parts "\n       "))
    (string-intersperse final separator)))

(define (env:process-path-envvar varname separator patha pathb)



  (let ((newpath (env:merge-path-envvar separator patha pathb)))
    (setenv varname newpath)))

(define (env:have-context db context)
  (> (query fetch-value (sql db "SELECT count(id) FROM envvars WHERE context=?") context)
     0))

;; this is so the calling block does not need to import sql-de-lite
(define (env:close-database db)
  (close-database db))

(define (env:lazy-hash-table->alist indat)
  (if (hash-table? indat)
      (let ((dat (hash-table->alist indat)))
	(if (null? dat)
	    #f 
	    dat))
      #f))

(define (env:print added removed changed)
  (let ((a  (env:lazy-hash-table->alist added))
	(r  (env:lazy-hash-table->alist removed))
	(c  (env:lazy-hash-table->alist changed)))
    (case (if (args:get-arg "-dumpmode")
	      (string->symbol (args:get-arg "-dumpmode"))
	      'bash)
      ((bash)
       (if a
	   (begin
	     (print "# Added vars")
	     (map (lambda (dat)(print "export " (car dat) "=" (cdr dat)))
		  (hash-table->alist added))))
       (if r
	   (begin
	     (print "# Removed vars")
	     (map (lambda (dat)(print "unset " (car dat)))
		  (hash-table->alist removed))))
       (if c
	   (begin
	     (print "# Changed vars")
	     (map (lambda (dat)(print "export " (car dat) "=" (cdr dat)))
		  (hash-table->alist changed)))))
      ((csh)
       (if a
	   (begin
	     (print "# Added vars")
	     (map (lambda (dat)(print "setenv " (car dat) " " (cdr dat)))
		  (hash-table->alist added))))
       (if r
	   (begin
	     (print "# Removed vars")
	     (map (lambda (dat)(print "unsetenv " (car dat)))
		  (hash-table->alist removed))))
       (if c
	   (begin
	     (print "# Changed vars")
	     (map (lambda (dat)(print "setenv " (car dat) " " (cdr dat)))
		  (hash-table->alist changed)))))
      ((config ini)
       (if a
	   (begin
	     (print "# Added vars")
	     (map (lambda (dat)(print (car dat) " " (cdr dat)))
		  (hash-table->alist added))))
       (if r
	   (begin
	     (print "# Removed vars")
	     (map (lambda (dat)(print "#{scheme (unsetenv \"" (car dat) "\")}"))
		  (hash-table->alist removed))))
       (if c
	   (begin
	     (print "# Changed vars")
	     (map (lambda (dat)(print (car dat) " " (cdr dat)))
		  (hash-table->alist changed)))))
      (else
       (debug:print 0 "ERROR: No dumpmode specified, use -dumpmode [bash|csh|config]")))))

Modified launch.scm from [390d72793b] to [e9781be215].

243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
		  (debug:print 0 "INFO: Not starting job yet - directory " top-path " not found")
		  (thread-sleep! 10)
		  (loop (+ count 1)))))

	  (let ((sighand (lambda (signum)
			   ;; (signal-mask! signum) ;; to mask or not? seems to cause issues in exiting
			   (if (eq? signum signal/stop)
			 (debug:print 0 "ERROR: attempt to STOP process. Exiting."))
			   (set! *time-to-exit* #t)
			   (print "Received signal " signum ", cleaning up before exit. Please wait...")
			   (let ((th1 (make-thread (lambda ()
						     (tests:test-force-state-status! run-id test-id "INCOMPLETE" "KILLED")
						     (print "Killed by signal " signum ". Exiting")
						     (thread-sleep! 1)
						     (exit 1))))







|







243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
		  (debug:print 0 "INFO: Not starting job yet - directory " top-path " not found")
		  (thread-sleep! 10)
		  (loop (+ count 1)))))

	  (let ((sighand (lambda (signum)
			   ;; (signal-mask! signum) ;; to mask or not? seems to cause issues in exiting
			   (if (eq? signum signal/stop)
			       (debug:print 0 "ERROR: attempt to STOP process. Exiting."))
			   (set! *time-to-exit* #t)
			   (print "Received signal " signum ", cleaning up before exit. Please wait...")
			   (let ((th1 (make-thread (lambda ()
						     (tests:test-force-state-status! run-id test-id "INCOMPLETE" "KILLED")
						     (print "Killed by signal " signum ". Exiting")
						     (thread-sleep! 1)
						     (exit 1))))
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
	      (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))
	  ;; (runs:set-megatest-env-vars run-id inkeys: keys inkeyvals: keyvals) ;; these may be needed by the launching process
	  ;; one of these is defunct/redundant ...
	  (if (not (launch:setup-for-run force: #t))
	      (begin
		(debug:print 0 "Failed to setup, exiting") 
		;; (sqlite3:finalize! db)
		;; (sqlite3:finalize! tdb)
		(exit 1)))
	  (change-directory *toppath*) 

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







|










|







282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
	      (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))
	  ;; (runs:set-megatest-env-vars run-id inkeys: keys inkeyvals: keyvals) ;; these may be needed by the launching process
	  ;; one of these is defunct/redundant ...
	  (if (not (launch:setup force: #t))
	      (begin
		(debug:print 0 "Failed to setup, exiting") 
		;; (sqlite3:finalize! db)
		;; (sqlite3:finalize! tdb)
		(exit 1)))
	  (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)
	    ;; (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))
429
430
431
432
433
434
435

436


437









438
439
440
441
442
443
444
				 ;; then, if runscript ran ok (or did not get called)
				 ;; do all the ezsteps (if any)
				 (if ezsteps
				     (let* ((testconfig ;; (read-config (conc work-area "/testconfig") #f #t environ-patt: "pre-launch-env-vars")) ;; FIXME??? is allow-system ok here?
					     ;; NOTE: it is tempting to turn off force-create of testconfig but dynamic
					     ;;       ezstep names need a full re-eval here.
					     (tests:get-testconfig test-name tconfigreg #t force-create: #t)) ;; 'return-procs)))

					    (ezstepslst (hash-table-ref/default testconfig "ezsteps" '())))


				       (hash-table-set! *testconfigs* test-name testconfig) ;; cached for lazy reads later ...









				       (if (not (file-exists? ".ezsteps"))(create-directory ".ezsteps"))
				       ;; if ezsteps was defined then we are sure to have at least one step but check anyway
				       (if (not (> (length ezstepslst) 0))
					   (debug:print 0 "ERROR: ezsteps defined but ezstepslst is zero length")
					   (let loop ((ezstep (car ezstepslst))
						      (tal    (cdr ezstepslst))
						      (prevstep #f))







>
|
>
>
|
>
>
>
>
>
>
>
>
>







429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
				 ;; then, if runscript ran ok (or did not get called)
				 ;; do all the ezsteps (if any)
				 (if ezsteps
				     (let* ((testconfig ;; (read-config (conc work-area "/testconfig") #f #t environ-patt: "pre-launch-env-vars")) ;; FIXME??? is allow-system ok here?
					     ;; NOTE: it is tempting to turn off force-create of testconfig but dynamic
					     ;;       ezstep names need a full re-eval here.
					     (tests:get-testconfig test-name tconfigreg #t force-create: #t)) ;; 'return-procs)))
					    (ezstepslst (if (hash-table? testconfig)
							    (hash-table-ref/default testconfig "ezsteps" '())
							    #f)))
				       (if testconfig
					   (hash-table-set! *testconfigs* test-name testconfig) ;; cached for lazy reads later ...
					   (begin
					     (launch:setup)
					     (debug:print 0 "WARNING: no testconfig found for " test-name " in search path:\n  "
							  (string-intersperse (tests:get-tests-search-path *configdat*) "\n  "))))
				       ;; after all that, still no testconfig? Time to abort
				       (if (not testconfig)
					   (begin
					     (debug:print 0 "ERROR: Failed to resolve megatest.config, runconfigs.config and testconfig issues. Giving up now")
					     (exit 1)))
				       (if (not (file-exists? ".ezsteps"))(create-directory ".ezsteps"))
				       ;; if ezsteps was defined then we are sure to have at least one step but check anyway
				       (if (not (> (length ezstepslst) 0))
					   (debug:print 0 "ERROR: ezsteps defined but ezstepslst is zero length")
					   (let loop ((ezstep (car ezstepslst))
						      (tal    (cdr ezstepslst))
						      (prevstep #f))
578
579
580
581
582
583
584
585














586






















587

588


589




590
591

592

593
594
595

596
597



598

599


600


601

602
603


604







605
606
607
608
609





610

611
612
613
614
615
616
617
618


619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
	      (rmt:update-run-stats run-id (rmt:get-raw-run-stats run-id)))
	    (mutex-unlock! m)
	    (debug:print 2 "Output from running " fullrunscript ", pid " (launch:einf-pid exit-info) " in work area " 
			 work-area ":\n====\n exit code " (launch:einf-exit-code exit-info) "\n" "====\n")
	    (if (not (launch:einf-exit-status exit-info))
		(exit 4)))))))

;; set up the very basics needed for doing anything here.














(define (launch:setup-for-run #!key (force #f))






















  ;; would set values for KEYS in the environment here for better support of env-override but 

  ;; have chicken/egg scenario. need to read megatest.config then read it again. Going to 


  ;; pass on that idea for now




  ;; special case
  (if (or force (not (hash-table? *configdat*)))  ;; no need to re-open on every call

      (begin

	(set! *configinfo* (or (if (get-environment-variable "MT_CMDINFO") ;; we are inside a test - do not reprocess configs
				   (let ((alistconfig (conc (get-environment-variable "MT_LINKTREE") "/"
							    (get-environment-variable "MT_TARGET")   "/"

							    (get-environment-variable "MT_RUNNAME")  "/"
							    ".megatest.cfg-"  megatest-version "-" megatest-fossil-hash)))



				     (if (file-exists? alistconfig)

					 (list (configf:read-alist alistconfig)


					       (get-environment-variable "MT_RUN_AREA_HOME"))


					 #f))

				   #f) ;; no config cached - give up
			       (let ((runname (or (args:get-arg "-runname")(args:get-arg ":runname"))))


				 (if runname (setenv "MT_RUNNAME" runname))







				 (find-and-read-config 
				  (if (args:get-arg "-config")(args:get-arg "-config") "megatest.config")
				  environ-patt: "env-override"
				  given-toppath: (get-environment-variable "MT_RUN_AREA_HOME")
				  pathenvvar: "MT_RUN_AREA_HOME"))))





	(set! *configdat*  (if (car *configinfo*)(car *configinfo*) #f))

	(set! *toppath*    (if (car *configinfo*)(cadr *configinfo*) #f))
	(let* ((tmptransport (configf:lookup *configdat* "server" "transport"))
	       (transport    (if tmptransport (string->symbol tmptransport) 'http)))
	  (if (member transport '(http rpc nmsg))
	      (set! *transport-type* transport)
	      (begin
		(debug:print 0 "ERROR: Unrecognised transport " transport)
		(exit))))


	(let ((linktree (configf:lookup *configdat* "setup" "linktree"))) ;; link tree is critical
	  (if linktree
	      (if (not (file-exists? linktree))
		  (begin
		    (handle-exceptions
		     exn
		     (begin
		       (debug:print 0 "ERROR: Something went wrong when trying to create linktree dir at " linktree)
		       (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))
		       (exit 1))
		     (create-directory linktree #t))))
	      (begin
		(debug:print 0 "ERROR: linktree not defined in [setup] section of megatest.config")
		(exit 1)))
	  (if linktree
	      (let ((dbdir (conc linktree "/.db")))
		(handle-exceptions
		 exn
		 (begin
		   (debug:print 0 "ERROR: failed to create the " dbdir " area for your database files")
		   (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)))
		 (if (not (directory-exists? dbdir))(create-directory dbdir)))
		(setenv "MT_LINKTREE" linktree))
	      (begin
		(debug:print 0 "ERROR: linktree is required in your megatest.config [setup] section")
		(exit 1)))
	  (if (and *toppath*
		   (directory-exists? *toppath*))
	      (setenv "MT_RUN_AREA_HOME" *toppath*)
	      (begin
		(debug:print 0 "ERROR: failed to find the top path to your Megatest area.")
		(exit 1)))
	  )))
  *toppath*)

(define (launch:cache-config)
  ;; if we have a linktree and -runtests and -target and the directory exists dump the config
  ;; to megatest-(current-seconds).cfg and symlink it to megatest.cfg
  (if (and *configdat* 
	   (or (args:get-arg "-run")
	       (args:get-arg "-runtests")))
      (let* ((linktree (get-environment-variable "MT_LINKTREE"))
	     (target   (common:args-get-target))
	     (runname  (or (args:get-arg "-runname")
			   (args:get-arg ":runname")))
	     (fulldir  (conc linktree "/"
			     target "/"
			     runname)))
	(debug:print-info 0 "Have -runtests with target=" target ", runname=" runname ", fulldir=" fulldir ", testpatt=" (or (args:get-arg "-testpatt") "%"))
	(if (file-exists? linktree) ;; can't proceed without linktree
	    (begin
	      (if (not (file-exists? fulldir))
		  (create-directory fulldir #t)) ;; need to protect with exception handler 
	      (if (and target
		       runname
		       (file-exists? fulldir))
		  (let ((tmpfile  (conc fulldir "/.megatest.cfg." (current-seconds)))
			(targfile (conc fulldir "/.megatest.cfg-"  megatest-version "-" megatest-fossil-hash)))
		    (debug:print-info 0 "Caching megatest.config in " fulldir "/.megatest.cfg")
		    (configf:write-alist *configdat* tmpfile)
		    (system (conc "ln -sf " tmpfile " " targfile))
		    )))))))

(define (get-best-disk confdat testconfig)
  (let* ((disks   (or (and testconfig (hash-table-ref/default testconfig "disks" #f))
		      (hash-table-ref/default confdat "disks" #f)))
	 (minspace (let ((m (configf:lookup confdat "setup" "minspace")))
		     (string->number (or m "10000")))))
    (if disks 







|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
>
|
>
>
|
>
>
>
>
|
|
>
|
>
|
<
|
>
|
|
>
>
>
|
>
|
>
>
|
>
>
|
>
|
<
>
>
|
>
>
>
>
>
>
>
|
|
|
|
|
>
>
>
>
>
|
>
|
<
<
<
|
|
|
|
>
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
<
<
<
<
<
<
<
<
<
<
|
|
|
|
|
|
<
<
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<







590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650

651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668

669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691



692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711











712
713
714
715
716
717


718




























719
720
721
722
723
724
725
	      (rmt:update-run-stats run-id (rmt:get-raw-run-stats run-id)))
	    (mutex-unlock! m)
	    (debug:print 2 "Output from running " fullrunscript ", pid " (launch:einf-pid exit-info) " in work area " 
			 work-area ":\n====\n exit code " (launch:einf-exit-code exit-info) "\n" "====\n")
	    (if (not (launch:einf-exit-status exit-info))
		(exit 4)))))))

;; gather available information, if legit read configs in this order:
;;
;;   if have cache;
;;      read it a return it
;;   else
;;     megatest.config     (do not cache)
;;     runconfigs.config   (cache if all vars avail)
;;     megatest.config     (cache if all vars avail)
;;   returns:
;;     *toppath*
;;   side effects:
;;     sets; *configdat*    (megatest.config info)
;;           *runconfigdat* (runconfigs.config info)
;;           *configstatus* (status of the read data)
;;
(define (launch:setup #!key (force #f))
  (let* ((toppath  (or *toppath* (getenv "MT_RUN_AREA_HOME"))) ;; preserve toppath
	 (runname  (common:args-get-runname))
	 (target   (common:args-get-target))
	 (linktree (common:get-linktree))
	 (sections (if target (list "default" target) #f)) ;; for runconfigs
	 (mtconfig (or (args:get-arg "-config") "megatest.config")) ;; allow overriding megatest.config 
	 (rundir   (if (and runname target linktree)(conc linktree "/" target "/" runname) #f))
	 (mtcachef (and rundir (conc rundir "/" ".megatest.cfg-"  megatest-version "-" megatest-fossil-hash)))
	 (rccachef (and rundir (conc rundir "/" ".runconfigs.cfg-"  megatest-version "-" megatest-fossil-hash)))
	 (cancreate (and rundir (file-exists? rundir)(file-write-access? rundir))))
    ;; (print "runname: " runname " target: " target " mtcachef: " mtcachef " rccachef: " rccachef)
    (set! *toppath* toppath) ;; This is needed when we are running as a test using CMDINFO as a datasource
    (cond
     ;; data was read and cached and available in *configstatus*, toppath has already been set
     ((eq? *configstatus* 'fulldata)
      *toppath*)
     ;; if mtcachef exists just read it, however we need to assume toppath is available in $MT_RUN_AREA_HOME
     ((and mtcachef (file-exists? mtcachef) (get-environment-variable "MT_RUN_AREA_HOME"))
      (set! *configdat*    (configf:read-alist mtcachef))
      (set! *runconfigdat* (configf:read-alist rccachef))
      (set! *configinfo*   (list *configdat*  (get-environment-variable "MT_RUN_AREA_HOME")))
      (set! *configstatus* 'fulldata)
      (set! *toppath*      (get-environment-variable "MT_RUN_AREA_HOME"))
      *toppath*)
     ;; we have all the info needed to fully process runconfigs and megatest.config
     (mtcachef              
      (let* ((first-pass (find-and-read-config        ;; NB// sets MT_RUN_AREA_HOME as side effect
				  mtconfig
				  environ-patt: "env-override"
				  given-toppath: toppath
				  pathenvvar: "MT_RUN_AREA_HOME"))
	     (first-rundat  (read-config (conc toppath "/runconfigs.config") *runconfigdat* #t 
					 sections: sections)))
	(set! *runconfigdat* first-rundat)
	(if first-pass  ;; 
	    (begin
	      (set! *configdat*  (car first-pass))
	      (set! *configinfo* first-pass)

	      (set! *toppath*    (or toppath (cadr first-pass))) ;; use the gathered data unless already have it
	      (set! toppath      *toppath*)
	      (setenv "MT_RUN_AREA_HOME" *toppath*)
	      ;; the seed read is done, now read runconfigs, cache it then read megatest.config one more time and cache it
	      (let* ((keys         (rmt:get-keys))
		     (key-vals     (keys:target->keyval keys target))
		     (linktree     (or (getenv "MT_LINKTREE")
				       (if *configdat* (configf:lookup *configdat* "setup" "linktree") #f)))
		     (second-pass  (find-and-read-config
				    mtconfig
				    environ-patt: "env-override"
				    given-toppath: toppath
				    pathenvvar: "MT_RUN_AREA_HOME"))
		     (runconfigdat (begin     ;; this read of the runconfigs will see any adjustments made by re-reading megatest.config
				     (for-each (lambda (kt)
						 (setenv (car kt) (cadr kt)))
					       key-vals)
				     (read-config (conc toppath "/runconfigs.config") *runconfigdat* #t 

						  sections: sections))))
		(if cancreate (configf:write-alist runconfigdat rccachef))
		(set! *runconfigdat* runconfigdat)
		(if cancreate (configf:write-alist *configdat* mtcachef))
		(if cancreate (set! *configstatus* 'fulldata))))
	    ;; no configs found? should not happen but let's try to recover gracefully, return an empty hash-table
	    (set! *configdat* (make-hash-table))
	    )))
     ;; else read what you can and set the flag accordingly
     (else
      (let* ((cfgdat   (find-and-read-config 
			(or (args:get-arg "-config") "megatest.config")
			environ-patt: "env-override"
			given-toppath: (get-environment-variable "MT_RUN_AREA_HOME")
			pathenvvar: "MT_RUN_AREA_HOME")))
	(if cfgdat
	    (let* ((toppath  (or (get-environment-variable "MT_RUN_AREA_HOME")(cadr cfgdat)))
		   (rdat     (read-config (conc toppath
						"/runconfigs.config") *runconfigdat* #t sections: sections)))
	      (set! *configinfo*   cfgdat)
	      (set! *configdat*    (car cfgdat))
	      (set! *runconfigdat* rdat)
	      (set! *toppath*      toppath)



	      (set! *configstatus* 'partial))
	    (begin
	      (debug:print 0 "ERROR: No " mtconfig " file found. Giving up.")
	      (exit 2))))))
    ;; additional house keeping
    (let* ((linktree (or (getenv "MT_LINKTREE")
			 (if *configdat* (configf:lookup *configdat* "setup" "linktree") #f))))
      (if linktree
	  (if (not (file-exists? linktree))
	      (begin
		(handle-exceptions
		 exn
		 (begin
		   (debug:print 0 "ERROR: Something went wrong when trying to create linktree dir at " linktree)
		   (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))
		   (exit 1))
		 (create-directory linktree #t))))
	  (begin
	    (debug:print 0 "ERROR: linktree not defined in [setup] section of megatest.config")
	    ;; (exit 1)











	    )))
    (if (and *toppath*
	     (directory-exists? *toppath*))
	(setenv "MT_RUN_AREA_HOME" *toppath*)
	(begin
	  (debug:print 0 "ERROR: failed to find the top path to your Megatest area.")))


    *toppath*))





























(define (get-best-disk confdat testconfig)
  (let* ((disks   (or (and testconfig (hash-table-ref/default testconfig "disks" #f))
		      (hash-table-ref/default confdat "disks" #f)))
	 (minspace (let ((m (configf:lookup confdat "setup" "minspace")))
		     (string->number (or m "10000")))))
    (if disks 

Modified megatest.scm from [5ea6d9acef] to [f136b9759b].

231
232
233
234
235
236
237

238
239
240
241
242
243
244
			"-transport"
			"-kill-server"
			"-port"
			"-extract-ods"
			"-pathmod"
			"-env2file"
			"-envcap"

			"-setvars"
			"-set-state-status"
			"-set-run-status"
			"-debug" ;; for *verbosity* > 2
			"-gen-megatest-test"
			"-override-timeout"
			"-test-files"  ;; -test-paths is for listing all







>







231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
			"-transport"
			"-kill-server"
			"-port"
			"-extract-ods"
			"-pathmod"
			"-env2file"
			"-envcap"
			"-envdelta"
			"-setvars"
			"-set-state-status"
			"-set-run-status"
			"-debug" ;; for *verbosity* > 2
			"-gen-megatest-test"
			"-override-timeout"
			"-test-files"  ;; -test-paths is for listing all
310
311
312
313
314
315
316


317
318
319
320


321
322
323
324
325
326
327
			"-logging"
			"-v" ;; verbose 2, more than normal (normal is 1)
			"-q" ;; quiet 0, errors/warnings only
		       )
		 args:arg-hash
		 0))



(if (and (not (null? remargs))
	 (not (or
	       (args:get-arg "-runstep"))
	      ;; add more args that use remargs here


	      ))
    (debug:print 0 "ERROR: Unrecognised arguments: " (string-intersperse (if (list? remargs) remargs (argv))  " ")))

;; immediately set MT_TARGET if -reqtarg or -target are available
;;
(let ((targ (or (args:get-arg "-reqtarg")(args:get-arg "-target"))))
  (if targ (setenv "MT_TARGET" targ)))







>
>


|
|
>
>







311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
			"-logging"
			"-v" ;; verbose 2, more than normal (normal is 1)
			"-q" ;; quiet 0, errors/warnings only
		       )
		 args:arg-hash
		 0))

;; Add args that use remargs here
;;
(if (and (not (null? remargs))
	 (not (or
	       (args:get-arg "-runstep")
	       (args:get-arg "-envcap")
	       (args:get-arg "-envdelta")
	       )
	      ))
    (debug:print 0 "ERROR: Unrecognised arguments: " (string-intersperse (if (list? remargs) remargs (argv))  " ")))

;; immediately set MT_TARGET if -reqtarg or -target are available
;;
(let ((targ (or (args:get-arg "-reqtarg")(args:get-arg "-target"))))
  (if targ (setenv "MT_TARGET" targ)))
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475

(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)))
      (print 
       (string-intersperse 
	(map (lambda (x)
	       (string-intersperse 
		x
		" => "))
	     (common:get-disks *configdat*))







|







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

(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)))
      (print 
       (string-intersperse 
	(map (lambda (x)
	       (string-intersperse 
		x
		" => "))
	     (common:get-disks *configdat*))
660
661
662
663
664
665
666











































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
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
;;       (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")

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

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

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

(if (or (args:get-arg "-list-servers")
	(args:get-arg "-stop-server"))
    (let ((tl (launch:setup-for-run)))
      (if tl 
	  (let* ((tdbdat  (tasks:open-db))
		 (servers (tasks:get-all-servers (db:delay-if-busy tdbdat)))
		 (fmtstr  "~5a~12a~8a~20a~24a~10a~10a~10a~10a\n")
		 (servers-to-kill '())
		 (killinfo   (args:get-arg "-stop-server"))
		 (khost-port (if killinfo (if (substring-index ":" killinfo)(string-split ":") #f) #f))







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>










|






|




|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|






|







665
666
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
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
;;       (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)))))

;;======================================================================
;; Capture, save and manipulate environments
;;======================================================================

;; NOTE: Keep these above the section where the server or client code is setup

(let ((envcap (args:get-arg "-envcap")))
  (if envcap
      (let* ((db      (env:open-db (if (null? remargs) "envdat.db" (car remargs)))))
	(env:save-env-vars db envcap)
	(env:close-database db)
	(set! *didsomething* #t))))

;; delta "language" will eventually be res=a+b-c but for now it is just res=a-b 
;;
(let ((envdelta (args:get-arg "-envdelta")))
  (if envdelta
      (let ((match (string-split envdelta "-")));; (string-match "([a-z0-9_]+)=([a-z0-9_\\-,]+)" envdelta)))
	(if (not (null? match))
	    (let* ((db        (env:open-db (if (null? remargs) "envdat.db" (car remargs))))
		   ;; (resctx    (cadr match))
		   ;; (equn      (caddr match))
		   (parts     match) ;; (string-split equn "-"))
		   (minuend   (car parts))
		   (subtraend (cadr parts))
		   (added     (env:get-added   db minuend subtraend))
		   (removed   (env:get-removed db minuend subtraend))
		   (changed   (env:get-changed db minuend subtraend)))
	      ;; (pp (hash-table->alist added))
	      ;; (pp (hash-table->alist removed))
	      ;; (pp (hash-table->alist changed))
	      (if (args:get-arg "-o")
		  (with-output-to-file
		      (args:get-arg "-o")
		    (lambda ()
		      (env:print added removed changed)))
		  (env:print added removed changed))
	      (env:close-database db)
	      (set! *didsomething* #t))
	    (debug:print 0 "ERROR: Parameter to -envdelta should be new=star-end")))))



;;======================================================================
;; 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")

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

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

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

(if (or (args:get-arg "-list-servers")
	(args:get-arg "-stop-server"))
    (let ((tl (launch:setup)))
      (if tl 
	  (let* ((tdbdat  (tasks:open-db))
		 (servers (tasks:get-all-servers (db:delay-if-busy tdbdat)))
		 (fmtstr  "~5a~12a~8a~20a~24a~10a~10a~10a~10a\n")
		 (servers-to-kill '())
		 (killinfo   (args:get-arg "-stop-server"))
		 (khost-port (if killinfo (if (substring-index ":" killinfo)(string-split ":") #f) #f))
777
778
779
780
781
782
783


784














785
786
787
788
789
790
791
792
793
794
795








796
797
798
799
800
801
802
803
804
805
806
807
		   targets))
	((json)
	 (json-write targets))
	(else
	 (debug:print 0 "ERROR: dump output format " (args:get-arg "-dumpmode") " not supported for -list-targets")))
      (set! *didsomething* #t)))



(define (full-runconfigs-read)














  (let* ((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*)
		     (if key-vals
			 (for-each (lambda (kt)
				     (setenv (car kt) (cadr kt)))
				   key-vals))
		     (read-config (conc *toppath* "/runconfigs.config") #f #t sections: sections))))








    data))


(if (args:get-arg "-show-runconfig")
    (let ((tl (launch:setup-for-run)))
      (push-directory *toppath*)
      (let ((data (full-runconfigs-read)))
	;; keep this one local
	(cond
	 ((and (args:get-arg "-section")
	       (args:get-arg "-var"))
	  (let ((val (or (configf:lookup data (args:get-arg "-section")(args:get-arg "-var"))







>
>

>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
|
|
|
|
|
|
|
|
|
|
>
>
>
>
>
>
>
>
|

<

|







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
858
859
860
861
862
863
864
865
866
867
868
869

870
871
872
873
874
875
876
877
878
		   targets))
	((json)
	 (json-write targets))
	(else
	 (debug:print 0 "ERROR: dump output format " (args:get-arg "-dumpmode") " not supported for -list-targets")))
      (set! *didsomething* #t)))

;; get the runconfigs
;;
(define (full-runconfigs-read)
  (if (eq? *configstatus* 'fulldata)
      *runconfigdat*
      (begin
	(launch:setup)
	*runconfigdat*)))

;;   (let* ((rundir (if (and (getenv "MT_LINKTREE")(getenv "MT_TARGET")(getenv "MT_RUNNAME"))
;; 		     (conc (getenv "MT_LINKTREE") "/" (getenv "MT_TARGET") "/" (getenv "MT_RUNNAME"))
;; 		     #f))
;; 	 (cfgf   (if rundir (conc rundir "/.runconfig." megatest-version "-" megatest-fossil-hash) #f)))
;;     (if (and cfgf
;; 	     (file-exists? cfgf)
;; 	     (file-write-access? cfgf))
;; 	(configf:read-alist cfgf)
;; 	(let* ((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*)
;; 			   (if key-vals
;; 			       (for-each (lambda (kt)
;; 					   (setenv (car kt) (cadr kt)))
;; 					 key-vals))
;; 			   (read-config (conc *toppath* "/runconfigs.config") #f #t sections: sections))))
;; 	  (if (and rundir ;; have all needed variabless
;; 		   (directory-exists? rundir)
;; 		   (file-write-access? rundir))
;; 	      (begin
;; 		(configf:write-alist data cfgf)
;; 		;; force re-read of megatest.config - this resolves circular references between megatest.config
;; 		(launch:setup force: #t)
;; 		(launch:cache-config))) ;; we can safely cache megatest.config since we have a valid runconfig
;; 	  data))))


(if (args:get-arg "-show-runconfig")
    (let ((tl (launch:setup)))
      (push-directory *toppath*)
      (let ((data (full-runconfigs-read)))
	;; keep this one local
	(cond
	 ((and (args:get-arg "-section")
	       (args:get-arg "-var"))
	  (let ((val (or (configf:lookup data (args:get-arg "-section")(args:get-arg "-var"))
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
	  (configf:config->ini 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))
	  (data *configdat*)) ;; (read-config "megatest.config" #f #t)))
      (push-directory *toppath*)
      ;; keep this one local
      (cond 
       ((and (args:get-arg "-section")
	     (args:get-arg "-var"))
	(let ((val (configf:lookup data (args:get-arg "-section")(args:get-arg "-var"))))







|







886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
	  (configf:config->ini 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))
	  (data *configdat*)) ;; (read-config "megatest.config" #f #t)))
      (push-directory *toppath*)
      ;; keep this one local
      (cond 
       ((and (args:get-arg "-section")
	     (args:get-arg "-var"))
	(let ((val (configf:lookup data (args:get-arg "-section")(args:get-arg "-var"))))
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966

;; NOTE: list-runs and list-db-targets operate on local db!!!
;;
;; IDEA: megatest list -runname blah% ...
;;
(if (or (args:get-arg "-list-runs")
	(args:get-arg "-list-db-targets"))
    (if (launch:setup-for-run)
	(let* (;; (dbstruct    (make-dbr:dbstruct path: *toppath* local: (args:get-arg "-local")))
	       (runpatt     (args:get-arg "-list-runs"))
	       (testpatt    (common:args-get-testpatt #f))
	       ;; (if (args:get-arg "-testpatt") 
	       ;;  	        (args:get-arg "-testpatt") 
	       ;;  	        "%"))
	       (keys        (rmt:get-keys)) ;; (db:get-keys dbstruct))







|







1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037

;; NOTE: list-runs and list-db-targets operate on local db!!!
;;
;; IDEA: megatest list -runname blah% ...
;;
(if (or (args:get-arg "-list-runs")
	(args:get-arg "-list-db-targets"))
    (if (launch:setup)
	(let* (;; (dbstruct    (make-dbr:dbstruct path: *toppath* local: (args:get-arg "-local")))
	       (runpatt     (args:get-arg "-list-runs"))
	       (testpatt    (common:args-get-testpatt #f))
	       ;; (if (args:get-arg "-testpatt") 
	       ;;  	        (args:get-arg "-testpatt") 
	       ;;  	        "%"))
	       (keys        (rmt:get-keys)) ;; (db:get-keys dbstruct))
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
		  (ods:list->ods tempdir ouf sheets))))
	  ;; (system (conc "rm -rf " tempdir))
	  (set! *didsomething* #t))))

;; Don't think I need this. Incorporated into -list-runs instead
;;
;; (if (and (args:get-arg "-since")
;; 	 (launch:setup-for-run))
;;     (let* ((since-time (string->number (args:get-arg "-since")))
;; 	   (run-ids    (db:get-changed-run-ids since-time)))
;;       ;; (rmt:get-tests-for-runs-mindata run-ids testpatt states status not-in)
;;       (print (sort run-ids <))
;;       (set! *didsomething* #t)))
      
      







|







1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
		  (ods:list->ods tempdir ouf sheets))))
	  ;; (system (conc "rm -rf " tempdir))
	  (set! *didsomething* #t))))

;; Don't think I need this. Incorporated into -list-runs instead
;;
;; (if (and (args:get-arg "-since")
;; 	 (launch:setup))
;;     (let* ((since-time (string->number (args:get-arg "-since")))
;; 	   (run-ids    (db:get-changed-run-ids since-time)))
;;       ;; (rmt:get-tests-for-runs-mindata run-ids testpatt states status not-in)
;;       (print (sort run-ids <))
;;       (set! *didsomething* #t)))
      
      
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
	       (target    (args:get-arg "-target"))
	       (toppath   (assoc/default 'toppath   cmdinfo)))
	  (change-directory toppath)
	  (if (not target)
	      (begin
		(debug:print 0 "ERROR: -target is required.")
		(exit 1)))
	  (if (not (launch:setup-for-run))
	      (begin
		(debug:print 0 "Failed to setup, giving up on -test-paths or -test-files, exiting")
		(exit 1)))
	  (let* ((keys     (rmt:get-keys))
		 ;; db:test-get-paths must not be run remote
		 (paths    (tests:test-get-paths-matching keys target (args:get-arg "-test-files"))))
	    (set! *didsomething* #t)







|







1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
	       (target    (args:get-arg "-target"))
	       (toppath   (assoc/default 'toppath   cmdinfo)))
	  (change-directory toppath)
	  (if (not target)
	      (begin
		(debug:print 0 "ERROR: -target is required.")
		(exit 1)))
	  (if (not (launch:setup))
	      (begin
		(debug:print 0 "Failed to setup, giving up on -test-paths or -test-files, exiting")
		(exit 1)))
	  (let* ((keys     (rmt:get-keys))
		 ;; db:test-get-paths must not be run remote
		 (paths    (tests:test-get-paths-matching keys target (args:get-arg "-test-files"))))
	    (set! *didsomething* #t)
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
	     (db-host   (assoc/default 'db-host   cmdinfo))
	     (run-id    (assoc/default 'run-id    cmdinfo))
	     (test-id   (assoc/default 'test-id   cmdinfo))
	     (itemdat   (assoc/default 'itemdat   cmdinfo))
	     (work-area (assoc/default 'work-area cmdinfo))
	     (db        #f))
	(change-directory testpath)
	(if (not (launch:setup-for-run))
	    (begin
	      (debug:print 0 "Failed to setup, exiting")
	      (exit 1)))
	(if (and state status)
	    (rmt:teststep-set-status! run-id test-id step state status msg logfile)
	    (begin
	      (debug:print 0 "ERROR: You must specify :state and :status with every call to -step")







|







1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
	     (db-host   (assoc/default 'db-host   cmdinfo))
	     (run-id    (assoc/default 'run-id    cmdinfo))
	     (test-id   (assoc/default 'test-id   cmdinfo))
	     (itemdat   (assoc/default 'itemdat   cmdinfo))
	     (work-area (assoc/default 'work-area cmdinfo))
	     (db        #f))
	(change-directory testpath)
	(if (not (launch:setup))
	    (begin
	      (debug:print 0 "Failed to setup, exiting")
	      (exit 1)))
	(if (and state status)
	    (rmt:teststep-set-status! run-id test-id step state status msg logfile)
	    (begin
	      (debug:print 0 "ERROR: You must specify :state and :status with every call to -step")
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
	       (run-id    (assoc/default 'run-id    cmdinfo))
	       (test-id   (assoc/default 'test-id   cmdinfo))
	       (itemdat   (assoc/default 'itemdat   cmdinfo))
	       (work-area (assoc/default 'work-area cmdinfo))
	       (db        #f) ;; (open-db))
	       (state     (args:get-arg ":state"))
	       (status    (args:get-arg ":status")))
	  (if (not (launch:setup-for-run))
	      (begin
		(debug:print 0 "Failed to setup, exiting")
		(exit 1)))

	  (if (args:get-arg "-runstep")(debug:print-info 1 "Running -runstep, first change to directory " work-area))
	  (change-directory work-area)
	  ;; can setup as client for server mode now







|







1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
	       (run-id    (assoc/default 'run-id    cmdinfo))
	       (test-id   (assoc/default 'test-id   cmdinfo))
	       (itemdat   (assoc/default 'itemdat   cmdinfo))
	       (work-area (assoc/default 'work-area cmdinfo))
	       (db        #f) ;; (open-db))
	       (state     (args:get-arg ":state"))
	       (status    (args:get-arg ":status")))
	  (if (not (launch:setup))
	      (begin
		(debug:print 0 "Failed to setup, exiting")
		(exit 1)))

	  (if (args:get-arg "-runstep")(debug:print-info 1 "Running -runstep, first change to directory " work-area))
	  (change-directory work-area)
	  ;; can setup as client for server mode now
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
;; Various helper commands can go below here
;;======================================================================

(if (or (args:get-arg "-showkeys")
        (args:get-arg "-show-keys"))
    (let ((db #f)
	  (keys #f))
      (if (not (launch:setup-for-run))
	  (begin
	    (debug:print 0 "Failed to setup, exiting")
	    (exit 1)))
      (set! keys (rmt:get-keys)) ;;  db))
      (debug:print 1 "Keys: " (string-intersperse keys ", "))
      (if (sqlite3:database? db)(sqlite3:finalize! db))
      (set! *didsomething* #t)))







|







1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
;; Various helper commands can go below here
;;======================================================================

(if (or (args:get-arg "-showkeys")
        (args:get-arg "-show-keys"))
    (let ((db #f)
	  (keys #f))
      (if (not (launch:setup))
	  (begin
	    (debug:print 0 "Failed to setup, exiting")
	    (exit 1)))
      (set! keys (rmt:get-keys)) ;;  db))
      (debug:print 1 "Keys: " (string-intersperse keys ", "))
      (if (sqlite3:database? db)(sqlite3:finalize! db))
      (set! *didsomething* #t)))
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804

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

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

(if (args:get-arg "-cleanup-db")
    (begin
      (if (not (launch:setup-for-run))
	  (begin
	    (debug:print 0 "Failed to setup, exiting") 
	    (exit 1)))
      ;; keep this one local
      ;; (open-run-close db:clean-up #f)
      (db:multi-db-sync 
       #f ;; do all run-ids
       ;; 'new2old
       'killservers
       'dejunk
       ;; 'adj-testids
       ;; 'old2new
       'new2old
       )
      (set! *didsomething* #t)))

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

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

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

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

;; fakeout readline

(if (or (args:get-arg "-repl")
	(args:get-arg "-load"))
    (let* ((toppath (launch:setup-for-run))
	   (dbstruct (if toppath (make-dbr:dbstruct path: toppath local: (args:get-arg "-local")) #f)))
      (if dbstruct
	  (begin
	    (set! *db* dbstruct)
	    (set! *client-non-blocking-mode* #t)
	    (import extras) ;; might not be needed
	    ;; (import csi)







|









|


















|












|
















|







1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875

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

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

(if (args:get-arg "-cleanup-db")
    (begin
      (if (not (launch:setup))
	  (begin
	    (debug:print 0 "Failed to setup, exiting") 
	    (exit 1)))
      ;; keep this one local
      ;; (open-run-close db:clean-up #f)
      (db:multi-db-sync 
       #f ;; do all run-ids
       ;; 'new2old
       'killservers
       'dejunk
       ;; 'adj-testids
       ;; 'old2new
       'new2old
       )
      (set! *didsomething* #t)))

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

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

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

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

;; fakeout readline

(if (or (args:get-arg "-repl")
	(args:get-arg "-load"))
    (let* ((toppath (launch:setup))
	   (dbstruct (if toppath (make-dbr:dbstruct path: toppath local: (args:get-arg "-local")) #f)))
      (if dbstruct
	  (begin
	    (set! *db* dbstruct)
	    (set! *client-non-blocking-mode* #t)
	    (import extras) ;; might not be needed
	    ;; (import csi)
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
;; Wait on a run to complete
;;======================================================================

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

;; ;; ;; redo me ;; Not converted to use dbstruct yet







|







1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
;; Wait on a run to complete
;;======================================================================

(if (and (args:get-arg "-run-wait")
	 (not (or (args:get-arg "-run")
		  (args:get-arg "-runtests")))) ;; run-wait is built into runtests now
    (begin
      (if (not (launch:setup))
	  (begin
	    (debug:print 0 "Failed to setup, exiting") 
	    (exit 1)))
      (operate-on 'run-wait)
      (set! *didsomething* #t)))

;; ;; ;; redo me ;; Not converted to use dbstruct yet
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
    (begin
      (db:multi-db-sync 
       #f ;; do all run-ids
       'new2old
       )
      (set! *didsomething* #t)))

;;======================================================================
;; Capture, save and manipulate environments
;;======================================================================

(let ((envcap (args:get-arg "-envcap")))
  (if envcap
      (if (substring-index "=" envcap)
	  (let* ((parts   (string-split envcap "="))
		 (fname   (car parts))
		 (context (cadr parts))
		 (db      (env:open-db fname)))
	    (env:save-env-vars db context)
	    (env:close-database db)
	    (set! *didsomething* #t))
	  (begin
	    (debug:print 0 "ERROR: Parameter to -envcap should be <filename>=<context>. E.G. envdat=original, got: " envcap)
	    (set! *didsomething* #t)))))

;;======================================================================
;; Exit and clean up
;;======================================================================

(if *runremote* (close-all-connections!))

(if (not *didsomething*)







<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<







1948
1949
1950
1951
1952
1953
1954


















1955
1956
1957
1958
1959
1960
1961
    (begin
      (db:multi-db-sync 
       #f ;; do all run-ids
       'new2old
       )
      (set! *didsomething* #t)))



















;;======================================================================
;; Exit and clean up
;;======================================================================

(if *runremote* (close-all-connections!))

(if (not *didsomething*)

Modified newdashboard.scm from [8ecdd4ecf2] to [d467002de9].

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

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

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

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







|







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

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

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

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

Modified runs.scm from [935b1bd2d6] to [5207c84013].

38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
;; This is the *new* methodology. One record to inform them and in the chaos, organise them.
;;
;; NOT YET UTILIZED
;;
(define (runs:create-run-record)
  (let* ((mconfig      (if *configdat*
		           *configdat*
		           (if (launch:setup-for-run)
		               *configdat*
		               (begin
		                 (debug:print 0 "ERROR: Called setup in a non-megatest area, exiting")
		                 (exit 1)))))
	  (runrec      (runs:runrec-make-record))
	  (target      (common:args-get-target))
	  (runname     (common:args-get-runname))







|







38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
;; This is the *new* methodology. One record to inform them and in the chaos, organise them.
;;
;; NOT YET UTILIZED
;;
(define (runs:create-run-record)
  (let* ((mconfig      (if *configdat*
		           *configdat*
		           (if (launch:setup)
		               *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     (common:args-get-runname))
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
      (exit 3))
     ((not runname)
      (debug:print 0 "ERROR: Missing required parameter for " switchname ", you must specify the run name with -runname runname")
      (exit 3))
     (else
      (let (;; (db   #f)
	    (keys #f))
	(if (launch:setup-for-run)
	    (launch:cache-config)
	    (begin 
	      (debug:print 0 "Failed to setup, exiting")
	      (exit 1)))
	(set! keys (keys:config-get-fields *configdat*))
	;; have enough to process -target or -reqtarg here
	(if (args:get-arg "-reqtarg")
	    (let* ((runconfigf (conc  *toppath* "/runconfigs.config")) ;; DO NOT EVALUATE ALL 







|
<







1778
1779
1780
1781
1782
1783
1784
1785

1786
1787
1788
1789
1790
1791
1792
      (exit 3))
     ((not runname)
      (debug:print 0 "ERROR: Missing required parameter for " switchname ", you must specify the run name with -runname runname")
      (exit 3))
     (else
      (let (;; (db   #f)
	    (keys #f))
	(if (not (launch:setup))

	    (begin 
	      (debug:print 0 "Failed to setup, exiting")
	      (exit 1)))
	(set! keys (keys:config-get-fields *configdat*))
	;; have enough to process -target or -reqtarg here
	(if (args:get-arg "-reqtarg")
	    (let* ((runconfigf (conc  *toppath* "/runconfigs.config")) ;; DO NOT EVALUATE ALL 

Modified server.scm from [7b411d8eb3] to [109c6639f4].

205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
;;
(define (server:ping run-id host:port)
  (let ((tdbdat (tasks:open-db)))
    (let* ((host-port (let ((slst (string-split   host:port ":")))
			(if (eq? (length slst) 2)
			    (list (car slst)(string->number (cadr slst)))
			    #f)))
	   (toppath       (launch:setup-for-run))
	   (server-db-dat (if (not host-port)(tasks:get-server (db:delay-if-busy tdbdat) run-id) #f)))
      (if (not run-id)
	  (begin
	    (debug:print 0 "ERROR: must specify run-id when doing ping, -run-id n")
	    (print "ERROR: No run-id")
	    (exit 1))
	  (if (and (not host-port)







|







205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
;;
(define (server:ping run-id host:port)
  (let ((tdbdat (tasks:open-db)))
    (let* ((host-port (let ((slst (string-split   host:port ":")))
			(if (eq? (length slst) 2)
			    (list (car slst)(string->number (cadr slst)))
			    #f)))
	   (toppath       (launch:setup))
	   (server-db-dat (if (not host-port)(tasks:get-server (db:delay-if-busy tdbdat) run-id) #f)))
      (if (not run-id)
	  (begin
	    (debug:print 0 "ERROR: must specify run-id when doing ping, -run-id n")
	    (print "ERROR: No run-id")
	    (exit 1))
	  (if (and (not host-port)

Modified tests/fullrun/megatest.config from [007216e935] to [b33d7c11dc].

91
92
93
94
95
96
97



98
99
100
101
102
103
104
htmlviewercmd arora

# -runtests automatically deletes the records for tests with the listed states on starting up a run allowing them to re-run
#     (nb// this is in addition to NOT_STARTED which is automatically re-run)
#
allow-auto-rerun INCOMPLETE ZERO_ITEMS
# could add: STUCK STUCK/DEAD UNKNOWN KILLED KILLREQ PREQ_DISCARD




[validvalues]
state start end 0 1 - 2
status pass fail n/a 0 1 running - 2

# These are set before all tests, override them 
# in the testconfig [pre-launch-env-overrides] section







>
>
>







91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
htmlviewercmd arora

# -runtests automatically deletes the records for tests with the listed states on starting up a run allowing them to re-run
#     (nb// this is in addition to NOT_STARTED which is automatically re-run)
#
allow-auto-rerun INCOMPLETE ZERO_ITEMS
# could add: STUCK STUCK/DEAD UNKNOWN KILLED KILLREQ PREQ_DISCARD

# Try this
reruns 0

[validvalues]
state start end 0 1 - 2
status pass fail n/a 0 1 running - 2

# These are set before all tests, override them 
# in the testconfig [pre-launch-env-overrides] section