1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
|
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
|
-
-
+
+
+
-
+
-
|
;; Copyright 2006-2012, Matthew Welland.
;;
;; This program is made available under the GNU GPL version 2.0 or
;; greater. See the accompanying file COPYING for details.
;;
;; This program is distributed WITHOUT ANY WARRANTY; without even the
;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;; PURPOSE.
;; (include "common.scm")
;; (include "megatest-version.scm")
(use sqlite3 srfi-1 posix regex regex-case srfi-69 base64 format readline apropos json
http-client directory-utils z3 srfi-18) ;; extras)
(use sqlite3 srfi-1 posix regex regex-case srfi-69 base64 format readline apropos json http-client directory-utils rpc ;; (srfi 18) extras)
http-client srfi-18) ;; zmq extras)
(import (prefix sqlite3 sqlite3:))
(import (prefix base64 base64:))
(import (prefix rpc rpc:))
;; (use zmq)
(declare (uses common))
(declare (uses megatest-version))
(declare (uses margs))
(declare (uses runs))
(declare (uses launch))
(declare (uses server))
(declare (uses client))
(declare (uses tests))
(declare (uses genexample))
(declare (uses daemon))
(declare (uses db))
;; (declare (uses sdb))
;; (declare (uses filedb))
(declare (uses tdb))
(declare (uses mt))
(declare (uses api))
(declare (uses tasks)) ;; only used for debugging.
(define *db* #f) ;; this is only for the repl, do not use in general!!!!
|
︙ | | |
129
130
131
132
133
134
135
136
137
138
139
140
141
142
|
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
|
+
|
-import-megatest.db : migrate a database from v1.55 series to v1.60 series
-sync-to-megatest.db : migrate data back to megatest.db
-update-meta : update the tests metadata for all tests
-setvars VAR1=val1,VAR2=val2 : Add environment variables to a run NB// these are
overwritten by values set in config files.
-server -|hostname : start the server (reduces contention on megatest.db), use
- to automatically figure out hostname
-transport http|zmq : use http or zmq for transport (default is http)
-daemonize : fork into background and disconnect from stdin/out
-log logfile : send stdout and stderr to logfile
-list-servers : list the servers
-stop-server id : stop server specified by id (see output of -list-servers), use
0 to kill all
-repl : start a repl (useful for extending megatest)
-load file.scm : load and run file.scm
|
︙ | | |
204
205
206
207
208
209
210
211
212
213
214
215
216
217
|
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
|
+
+
|
":expected"
":tol"
":units"
;; misc
"-start-dir"
"-server"
"-stop-server"
"-transport"
"-kill-server"
"-port"
"-extract-ods"
"-pathmod"
"-env2file"
"-setvars"
"-set-state-status"
"-set-run-status"
|
︙ | | |
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
|
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
|
+
-
+
+
+
|
"-q" ;; quiet 0, errors/warnings only
)
args:arg-hash
0))
;; The watchdog is to keep an eye on things like db sync etc.
;;
(define *time-zero* (current-seconds))
(define *watchdog*
(make-thread
(lambda ()
(thread-sleep! 0.05) ;; delay for startup
(let ((legacy-sync (configf:lookup *configdat* "setup" "megatest-db")))
(let ((legacy-sync (configf:lookup *configdat* "setup" "megatest-db"))
(debug-mode (debug:debug-mode 1))
(last-time (current-seconds)))
(let loop ()
;; sync for filesystem local db writes
;;
(let ((start-time (current-seconds))
(servers-started (make-hash-table)))
(for-each
(lambda (run-id)
|
︙ | | |
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
|
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
|
-
-
+
+
+
+
+
+
+
-
+
|
(debug:print-info 0 "Sync of newdb to olddb for run-id " run-id " completed in " sync-time " seconds")))
;; (if (> sync-time 10) ;; took more than ten seconds, start a server for this run
;; (begin
;; (debug:print-info 0 "Sync is taking a long time, start up a server to assist for run " run-id)
;; (server:kind-run run-id)))))
(hash-table-delete! *db-local-sync* run-id)))
(mutex-unlock! *db-multi-sync-mutex*))
(hash-table-keys *db-local-sync*)))
(hash-table-keys *db-local-sync*))
(if (and debug-mode
(> (- start-time last-time) 14))
(begin
(set! last-time start-time)
(debug:print-info 0 "timestamp -> " (seconds->time-string (current-seconds)) ", time since start -> " (seconds->hr-min-sec (- (current-seconds) *time-zero*))))))
;; keep going unless time to exit
;;
(if (not *time-to-exit*)
(begin
(thread-sleep! 1) ;; wait one second before syncing again
(thread-sleep! 5) ;; wait five seconds before syncing again, we'll also sync on exit
(loop)))))
"Watchdog thread")))
(thread-start! *watchdog*)
(if (args:get-arg "-log")
(let ((oup (open-output-file (args:get-arg "-log"))))
|
︙ | | |
473
474
475
476
477
478
479
480
481
482
483
484
485
486
|
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
|
+
+
+
+
+
+
+
+
|
))
(if (args:get-arg "-ping")
(let* ((run-id (string->number (args:get-arg "-run-id")))
(host:port (args:get-arg "-ping")))
(server:ping run-id host:port)))
;; (set! *did-something* #t)
;; (begin
;; (print ((rpc:procedure 'testing (car host-port)(cadr host-port))))
;; (case (server:get-transport)
;; ((http)(http:ping run-id host-port))
;; ((rpc) (rpc:procedure 'server:login (car host-port)(cadr host-port));; *toppath*)) ;; (rpc-transport:ping run-id (car host-port)(cadr host-port)))
;; (else (debug:print 0 "ERROR: No transport set")(exit)))))
;;======================================================================
;; Start the server - can be done in conjunction with -runall or -runtests (one day...)
;; we start the server if not running else start the client thread
;;======================================================================
(if (args:get-arg "-server")
|
︙ | | |
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
|
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
|
-
+
+
|
;; 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")))
"-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))
|
︙ | | |
906
907
908
909
910
911
912
913
914
915
916
917
918
919
|
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
|
+
|
;;======================================================================
;; 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")
(let* ((startingdir (current-directory))
(cmdinfo (common:read-encoded-string (getenv "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))
(state (args:get-arg ":state"))
|
︙ | | |
953
954
955
956
957
958
959
960
961
962
963
964
965
966
|
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
|
+
|
;;======================================================================
;; Archive tests matching target, runname, and testpatt
(if (args:get-arg "-archive")
;; if we are in a test use the MT_CMDINFO data
(if (getenv "MT_CMDINFO")
(let* ((startingdir (current-directory))
(cmdinfo (common:read-encoded-string (getenv "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))
(state (args:get-arg ":state"))
|
︙ | | |
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
|
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
|
+
|
(define (megatest:step step state status logfile msg)
(if (not (getenv "MT_CMDINFO"))
(begin
(debug:print 0 "ERROR: MT_CMDINFO env var not set, -step must be called *inside* a megatest invoked environment!")
(exit 5))
(let* ((cmdinfo (common:read-encoded-string (getenv "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))
(itemdat (assoc/default 'itemdat cmdinfo))
|
︙ | | |
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
|
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
|
+
|
(args:get-arg "-summarize-items"))
(if (not (getenv "MT_CMDINFO"))
(begin
(debug:print 0 "ERROR: 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")))
(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))
(itemdat (assoc/default 'itemdat cmdinfo))
|
︙ | | |