| ︙ | | |
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
|
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
|
-
-
-
-
-
-
-
+
+
+
+
+
+
+
-
+
|
(include "env.scm")
(include "diff-report.scm")
(include "ods.scm")
(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
;;======================================================================
;; Test commands (i.e. for use inside tests)
;;======================================================================
(define (megatest:step step state status logfile msg)
(if (not (getenv "MT_CMDINFO"))
(begin
(let* ((cmdinfo (common:read-encoded-string (getenv "MT_CMDINFO")))
|
| ︙ | | |
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
|
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
|
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
|
(let ((comment (launch:load-logpro-dat run-id test-id step)))
;; (rmt:test-set-log! run-id test-id (conc stepname ".html"))))
(rmt:teststep-set-status! run-id test-id step state status (or comment msg) logfile))
(begin
(debug:print-error 0 *default-log-port* "You must specify :state and :status with every call to -step")
(exit 6))))))
;;======================================================================
;; full run
;;======================================================================
(define (handle-run-requests target runname keys keyvals need-clean)
(if (or (args:get-arg "-kill-rerun") (args:get-arg "-rerun-clean")) ;; first set states/statuses correct
;; For rerun-clean do we or do we not support the testpatt?
(let ((states (or (configf:lookup *configdat* "validvalues" "cleanrerun-states")
|
| ︙ | | |
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
|
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
|
-
-
-
+
+
+
-
+
-
-
+
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
-
-
-
+
+
+
+
+
-
-
-
-
-
-
-
+
+
+
+
+
+
+
-
+
-
-
+
+
-
+
|
target
(common:args-get-runname) ;; (or (args:get-arg "-runname")(args:get-arg ":runname"))
;; "%" ;; (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt")
(common:args-get-testpatt #f) ;; (args:get-arg "-testpatt")
;; state: states
status: statuses
new-state-status: "NOT_STARTED,n/a")))
;; RERUN ALL
(if (args:get-arg "-rerun-all") ;; first set states/statuses correct
(let* ((rconfig (full-runconfigs-read)))
(let* ((config-reruns (let ((x (configf:lookup *configdat* "setup" "reruns")))
(runs:run-tests target
;; csv processing record
(define (make-refdb:csv)
(vector
(make-sparse-array)
(make-hash-table)
(make-hash-table)
0
0))
(define-inline (refdb:csv-get-svec vec) (vector-ref vec 0))
(define-inline (refdb:csv-get-rows vec) (vector-ref vec 1))
(define-inline (refdb:csv-get-cols vec) (vector-ref vec 2))
(define-inline (refdb:csv-get-maxrow vec) (vector-ref vec 3))
(define-inline (refdb:csv-get-maxcol vec) (vector-ref vec 4))
(define-inline (refdb:csv-set-svec! vec val)(vector-set! vec 0 val))
(define-inline (refdb:csv-set-rows! vec val)(vector-set! vec 1 val))
(define-inline (refdb:csv-set-cols! vec val)(vector-set! vec 2 val))
(define-inline (refdb:csv-set-maxrow! vec val)(vector-set! vec 3 val))
(define-inline (refdb:csv-set-maxcol! vec val)(vector-set! vec 4 val))
(define (get-dat results sheetname)
(or (hash-table-ref/default results sheetname #f)
(let ((tmp-vec (make-refdb:csv)))
;; bracket open-output-file with code to make leading directory if it does not exist and handle exceptions
(define (open-logfile logpath-in)
(condition-case
(let* ((log-dir (or (pathname-directory logpath-in) "."))
(if (not (directory-exists? log-dir))
(system (conc "mkdir -p " log-dir)))
(open-output-file logpath))
(exn ()
(debug:print-error 0 *default-log-port* "Could not open log file for write: "logpath-in)
(define *didsomething* #t)
(exit 1))))
(getenv "MT_DEBUG_MODE"))))
(get-environment-variable "MT_DEBUG_MODE"))))
(set! *verbosity* (debug:calc-verbosity debugstr 'q))
(debug:check-verbosity *verbosity* debugstr)
;; if we were handed a bad verbosity rule then we will override it with 1 and continue
(if (not *verbosity*)(set! *verbosity* 1))
(if (and (not (args:get-arg "-debug-noprop"))
(or (args:get-arg "-debug")
(not (getenv "MT_DEBUG_MODE"))))
(setenv "MT_DEBUG_MODE" (if (list? *verbosity*)
(not (get-environment-variable "MT_DEBUG_MODE"))))
(set-environment-variable! "MT_DEBUG_MODE" (if (list? *verbosity*)
(string-intersperse (map conc *verbosity*) ",")
(conc *verbosity*))))))
;; check verbosity, #t is ok
(define (debug:check-verbosity verbosity vstr)
(if (not (or (number? verbosity)
(list? verbosity)))
(begin
(print "ERROR: Invalid debug value \"" vstr "\"")
#f)
#t))
;; Disabled help items
;; -rollup : (currently disabled) fill run (set by :runname) with latest test(s)
;; from prior runs with same keys
;; -daemonize : fork into background and disconnect from stdin/out
|
| ︙ | | |
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
|
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
|
-
+
-
+
-
+
|
(debug:print-error 0 *default-log-port* "Unrecognised arguments: " (string-intersperse (if (list? remargs) remargs (argv)) " ")))
;; before doing anything else change to the start-dir if provided
;;
(if (args:get-arg "-start-dir")
(if (common:file-exists? (args:get-arg "-start-dir"))
(let ((fullpath (common:real-path (args:get-arg "-start-dir"))))
(setenv "PWD" fullpath)
(set-environment-variable! "PWD" fullpath)
(change-directory fullpath))
(begin
(debug:print-error 0 *default-log-port* "non-existant start dir " (args:get-arg "-start-dir") " specified, exiting.")
(exit 1))))
;; 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)))
(if targ (set-environment-variable! "MT_TARGET" targ)))
;; The watchdog is to keep an eye on things like db sync etc.
;;
(init-watchdog)
;; (init-watchdog)
;; (define (debug:debug-mode n)
;; (cond
;; ((and (number? *verbosity*) ;; number number
;; (number? n))
;; (<= n *verbosity*))
;; ((and (list? *verbosity*) ;; list number
|
| ︙ | | |
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
|
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
|
-
-
+
+
+
-
+
|
(let ((newval (conc (args:get-arg "-testpatt") "/" (args:get-arg "-itempatt"))))
(debug:print 0 *default-log-port* "WARNING: -itempatt has been deprecated, please use -testpatt testpatt/itempatt method, new testpatt is "newval)
(hash-table-set! args:arg-hash "-testpatt" newval)
(hash-table-delete! args:arg-hash "-itempatt")))
(if (args:get-arg "-runtests")
(debug:print 0 *default-log-port* "WARNING: \"-runtests\" is deprecated. Use \"-run\" with \"-testpatt\" instead"))
(on-exit std-exit-procedure)
(let* ((temp-dir (or (args:get-arg "-target-db") (create-directory (conc "/tmp/" (getenv "USER") "/" (string-translate (current-directory) "/" "_")))))
(let* ((temp-dir (or (args:get-arg "-target-db") (create-directory (conc "/tmp/" (get-environment-variable "USER") "/" (string-translate (current-directory) "/" "_")))))
(target-db (conc temp-dir "/cached.db"))
(source-db (args:get-arg "-source-db")))
(db:cache-for-read-only source-db target-db)
(set! *didsomething* #t)))
;; handle a clean-cache request as early as possible
;;
|
| ︙ | | |
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
|
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
|
-
-
+
+
|
(else
(debug:print-error 0 *default-log-port* "-dumpmode of " (args:get-arg "-dumpmode") " not recognised")))
(set! *didsomething* #t)
(pop-directory)
(bdat-time-to-exit-set! *bdat* #t)))
(if (args:get-arg "-show-cmdinfo")
(if (or (args:get-arg ":value")(getenv "MT_CMDINFO"))
(let ((data (common:read-encoded-string (or (args:get-arg ":value")(getenv "MT_CMDINFO")))))
(if (or (args:get-arg ":value")(get-environment-variable "MT_CMDINFO"))
(let ((data (common:read-encoded-string (or (args:get-arg ":value")(get-environment-variable "MT_CMDINFO")))))
(if (equal? (args:get-arg "-dumpmode") "json")
(json-write data)
(pp data))
(set! *didsomething* #t))
(debug:print-info 0 *default-log-port* "environment variable MT_CMDINFO is not set")))
;;======================================================================
|
| ︙ | | |
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
|
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
|
-
+
-
+
|
;;======================================================================
;; Get paths to tests
;;======================================================================
;; Get test paths matching target, runname, and testpatt
(if (or (args:get-arg "-test-files")(args:get-arg "-test-paths"))
;; if we are in a test use the MT_CMDINFO data
(if (getenv "MT_CMDINFO")
(if (get-environment-variable "MT_CMDINFO")
(let* ((startingdir (current-directory))
(cmdinfo (common:read-encoded-string (getenv "MT_CMDINFO")))
(cmdinfo (common:read-encoded-string (get-environment-variable "MT_CMDINFO")))
(transport (assoc/default 'transport cmdinfo))
(testpath (assoc/default 'testpath cmdinfo))
(test-name (assoc/default 'test-name cmdinfo))
(runscript (assoc/default 'runscript cmdinfo))
(db-host (assoc/default 'db-host cmdinfo))
(run-id (assoc/default 'run-id cmdinfo))
(itemdat (assoc/default 'itemdat cmdinfo))
|
| ︙ | | |
2224
2225
2226
2227
2228
2229
2230
2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
|
2225
2226
2227
2228
2229
2230
2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
|
-
+
-
+
|
;; NEW POLICY - -setlog sets test overall log on every call.
(args:get-arg "-set-toplog")
(args:get-arg "-test-status")
(args:get-arg "-set-values")
(args:get-arg "-load-test-data")
(args:get-arg "-runstep")
(args:get-arg "-summarize-items"))
(if (not (getenv "MT_CMDINFO"))
(if (not (get-environment-variable "MT_CMDINFO"))
(begin
(debug:print-error 0 *default-log-port* "MT_CMDINFO env var not set, commands -test-status, -runstep and -setlog must be called *inside* a megatest environment!")
(exit 5))
(let* ((startingdir (current-directory))
(cmdinfo (common:read-encoded-string (getenv "MT_CMDINFO")))
(cmdinfo (common:read-encoded-string (get-environment-variable "MT_CMDINFO")))
(transport (assoc/default 'transport cmdinfo))
(testpath (assoc/default 'testpath cmdinfo))
(test-name (assoc/default 'test-name cmdinfo))
(runscript (assoc/default 'runscript cmdinfo))
(db-host (assoc/default 'db-host cmdinfo))
(run-id (assoc/default 'run-id cmdinfo))
(test-id (assoc/default 'test-id cmdinfo))
|
| ︙ | | |
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473
2474
2475
|
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473
2474
2475
2476
|
-
+
-
+
|
(args:get-arg "-target")
(args:get-arg "-runname")
(args:get-arg "-diff-html")
(args:get-arg "-diff-email"))
(set! *didsomething* #t)
(exit 0)))
(if (or (getenv "MT_RUNSCRIPT")
(if (or (get-environment-variable "MT_RUNSCRIPT")
(args:get-arg "-repl")
(args:get-arg "-load"))
(let* ((toppath (launch:setup)))
;; (dbstruct (if (and toppath
;; #;(common:on-homehost?))
;; (db:setup #f) ;; sets up main.db
;; #f))) ;; make-dbr:dbstruct path: toppath local: (args:get-arg "-local")) #f)))
(if *toppath*
(cond
((getenv "MT_RUNSCRIPT")
((get-environment-variable "MT_RUNSCRIPT")
;; How to run megatest scripts
;;
;; #!/bin/bash
;;
;; export MT_RUNSCRIPT=yes
;; megatest << EOF
;; (print "Hello world")
|
| ︙ | | |