Megatest

Diff
Login

Differences From Artifact [165242d338]:

To Artifact [a64d336b91]:


94
95
96
97
98
99
100


101
102
103
104
105
106
107
	  sql-de-lite
	  stack
	  typed-records
	  s11n
	  sparse-vectors
	  sxml-serializer
	  sxml-modifications


	  system-information
	  z3
	  spiffy
	  uri-common
	  intarweb
	  http-client
	  spiffy-request-vars







>
>







94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
	  sql-de-lite
	  stack
	  typed-records
	  s11n
	  sparse-vectors
	  sxml-serializer
	  sxml-modifications
	  (prefix sxml-modifications sxml-)
	  sxml-transforms
	  system-information
	  z3
	  spiffy
	  uri-common
	  intarweb
	  http-client
	  spiffy-request-vars
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(include "test_records.scm")

(include "common.scm")
(include "megatest-fossil-hash.scm")

(include "configf.scm")
(include "margs.scm")
(include "process.scm")
(include "keys.scm")
(include "portlogger.scm")
(include "db.scm")







|







176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(include "test_records.scm")

(include "common.scm")
;; (include "megatest-fossil-hash.scm")

(include "configf.scm")
(include "margs.scm")
(include "process.scm")
(include "keys.scm")
(include "portlogger.scm")
(include "db.scm")
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
;;;      
;;;      ;; Added for csv stuff - will be removed
;;;      ;;
;;;      ;; (use sparse-vectors)
;;;      ;; 
;;;      ;; (require-library mutils)
;;;      
;;;      ;; copied from egg call-with-environment-variables
;;;      ;;
;;;      (define (call-with-environment-variables variables thunk)
;;;        ;; @("Sets up environment variable via dynamic-wind which are taken down after thunk."
;;;        ;;   (variables "An alist of the form {{'((\"var\" . \"value\") ...)}}")
;;;        ;;   (thunk "The thunk to execute with a modified environment"))
;;;        (let ((pre-existing-variables
;;;               (map (lambda (var-value)
;;;                      (let ((var (car var-value)))
;;;                        (cons var (get-environment-variable var))))
;;;                    variables)))
;;;          (dynamic-wind
;;;              (lambda () (void))
;;;              (lambda ()
;;;      ;;           (use posix)
;;;                (for-each (lambda (var-value)
;;;                            (setenv (car var-value) (cdr var-value)))
;;;                  variables)
;;;                (thunk))
;;;              (lambda ()
;;;                (for-each (lambda (var-value)
;;;                            (let ((var (car var-value))
;;;                                  (value (cdr var-value)))
;;;                              (if value
;;;                                  (setenv var value)
;;;                                  (unsetenv var))))
;;;                  pre-existing-variables)))))
;;;      
;;;      
;;;      
;;;      (define *usage-log-file* #f)    ;; put path to file for logging usage in this var in the ~/.megatestrc file
;;;      (define *usage-use-seconds* #t) ;; for Epoc seconds in usage logging change this to #t in ~/.megatestrc file
;;;      
;;;      ;; load the ~/.megatestrc file, put (use trace)(trace-call-sites #t)(trace function-you-want-to-trace) in this file
;;;      ;;







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







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
256
257
;;;      
;;;      ;; Added for csv stuff - will be removed
;;;      ;;
;;;      ;; (use sparse-vectors)
;;;      ;; 
;;;      ;; (require-library mutils)
;;;      
;; copied from egg call-with-environment-variables
;;
(define (call-with-environment-variables variables thunk)
  ;; @("Sets up environment variable via dynamic-wind which are taken down after thunk."
  ;;   (variables "An alist of the form {{'((\"var\" . \"value\") ...)}}")
  ;;   (thunk "The thunk to execute with a modified environment"))
  (let ((pre-existing-variables
         (map (lambda (var-value)
                (let ((var (car var-value)))
                  (cons var (get-environment-variable var))))
              variables)))
    (dynamic-wind
        (lambda () (void))
        (lambda ()
;;           (use posix)
          (for-each (lambda (var-value)
                      (setenv (car var-value) (cdr var-value)))
            variables)
          (thunk))
        (lambda ()
          (for-each (lambda (var-value)
                      (let ((var (car var-value))
                            (value (cdr var-value)))
                        (if value
                            (setenv var value)
                            (unsetenv var))))
            pre-existing-variables)))))

;;;      
;;;      
;;;      (define *usage-log-file* #f)    ;; put path to file for logging usage in this var in the ~/.megatestrc file
;;;      (define *usage-use-seconds* #t) ;; for Epoc seconds in usage logging change this to #t in ~/.megatestrc file
;;;      
;;;      ;; load the ~/.megatestrc file, put (use trace)(trace-call-sites #t)(trace function-you-want-to-trace) in this file
;;;      ;;
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
;;;      ;;
;;;      (let ((targ (or (args:get-arg "-reqtarg")(args:get-arg "-target"))))
;;;        (if targ (setenv "MT_TARGET" targ)))
;;;      
;;;      ;; The watchdog is to keep an eye on things like db sync etc.
;;;      ;;
;;;      

;;;      ;; TODO: for multiple areas, we will have multiple watchdogs; and multiple threads to manage
;;;      (define *watchdog* (make-thread
;;;      		    (lambda ()
;;;      		      (handle-exceptions
;;;      			  exn
;;;      			  (begin
;;;      			    (print-call-chain)
;;;      			    (print " message: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn))
;;;      			(common:watchdog)))
;;;      		    "Watchdog thread"))
;;;      
;;;      ;;(if (not (args:get-arg "-server"))
;;;      ;;    (thread-start! *watchdog*)) ;; if starting a server; wait till we get to running state before kicking off watchdog
;;;      (let* ((no-watchdog-args
;;;             '("-list-runs"
;;;               "-testdata-csv"
;;;               "-list-servers"
;;;               "-server"







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







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
;;;      ;;
;;;      (let ((targ (or (args:get-arg "-reqtarg")(args:get-arg "-target"))))
;;;        (if targ (setenv "MT_TARGET" targ)))
;;;      
;;;      ;; The watchdog is to keep an eye on things like db sync etc.
;;;      ;;
;;;      

;; TODO: for multiple areas, we will have multiple watchdogs; and multiple threads to manage
(define *watchdog* (make-thread
		    (lambda ()
		      (handle-exceptions
			  exn
			  (begin
			    (print-call-chain)
			    (print " message: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn))
			(common:watchdog)))
		    "Watchdog thread"))

;;;      ;;(if (not (args:get-arg "-server"))
;;;      ;;    (thread-start! *watchdog*)) ;; if starting a server; wait till we get to running state before kicking off watchdog
;;;      (let* ((no-watchdog-args
;;;             '("-list-runs"
;;;               "-testdata-csv"
;;;               "-list-servers"
;;;               "-server"
1168
1169
1170
1171
1172
1173
1174

1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
;;;                             targets))
;;;                  ((json)
;;;                   (json-write targets))
;;;                  (else
;;;                   (debug:print-error 0 *default-log-port* "dump output format " (args:get-arg "-dumpmode") " not supported for -list-targets")))
;;;                (set! *didsomething* #t))))
;;;      

;;;      ;; cache the runconfigs in $MT_LINKTREE/$MT_TARGET/$MT_RUNNAME/.runconfig
;;;      ;;
;;;      (define (full-runconfigs-read)
;;;      ;; in the envprocessing branch the below code replaces the further below code
;;;      ;;  (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
;;;      	     (common:file-exists? cfgf)
;;;      	     (file-writable? cfgf)
;;;      	     (common:use-cache?))
;;;      	(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))))
;;;                                 (runconfig:read (conc *toppath* "/runconfigs.config") target #f))))
;;;      	  (if (and rundir ;; have all needed variabless
;;;      		   (directory-exists? rundir)
;;;      		   (file-writable? rundir))
;;;      	      (begin
;;;                      (if (not (common:in-running-test?))
;;;                          (configf:write-alist data cfgf))
;;;      		;; force re-read of megatest.config - this resolves circular references between megatest.config
;;;      		(launch:setup force-reread: #t)
;;;      		;; (launch:cache-config) ;; there are two independent config cache locations, turning this one off for now. MRW.
;;;      		)) ;; 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







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







1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187

1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
;;;                             targets))
;;;                  ((json)
;;;                   (json-write targets))
;;;                  (else
;;;                   (debug:print-error 0 *default-log-port* "dump output format " (args:get-arg "-dumpmode") " not supported for -list-targets")))
;;;                (set! *didsomething* #t))))
;;;      

;; cache the runconfigs in $MT_LINKTREE/$MT_TARGET/$MT_RUNNAME/.runconfig
;;
(define (full-runconfigs-read)
;; in the envprocessing branch the below code replaces the further below code
;;  (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
	     (common:file-exists? cfgf)
	     (file-writable? cfgf)
	     (common:use-cache?))
	(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))))
                           (runconfig:read (conc *toppath* "/runconfigs.config") target #f))))
	  (if (and rundir ;; have all needed variabless
		   (directory-exists? rundir)
		   (file-writable? rundir))
	      (begin
                (if (not (common:in-running-test?))
                    (configf:write-alist data cfgf))
		;; force re-read of megatest.config - this resolves circular references between megatest.config
		(launch:setup force-reread: #t)
		;; (launch:cache-config) ;; there are two independent config cache locations, turning this one off for now. MRW.
		)) ;; 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