︙ | | | ︙ | |
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
|
(declare (uses tdb))
(declare (uses mt))
(declare (uses api))
(declare (uses tasks)) ;; only used for debugging.
(declare (uses env))
(declare (uses diff-report))
;; (declare (uses ftail))
;; (import ftail)
(define *db* #f) ;; this is only for the repl, do not use in general!!!!
(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(include "megatest-fossil-hash.scm")
(use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 (prefix base64 base64:)
readline apropos json http-client directory-utils typed-records
http-client srfi-18 extras format)
;; Added for csv stuff - will be removed
;;
(use sparse-vectors)
(require-library mutils)
|
>
>
>
>
>
>
>
|
|
|
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
|
(declare (uses tdb))
(declare (uses mt))
(declare (uses api))
(declare (uses tasks)) ;; only used for debugging.
(declare (uses env))
(declare (uses diff-report))
(declare (uses adjutant))
(import adjutant)
(declare (uses mttop))
(import mttop)
;; (declare (uses ftail))
;; (import ftail)
(define *db* #f) ;; this is only for the repl, do not use in general!!!!
(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(include "megatest-fossil-hash.scm")
(use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 (prefix base64 base64:)
readline apropos json http-client directory-utils typed-records matchable
http-client srfi-18 extras format call-with-environment-variables)
;; Added for csv stuff - will be removed
;;
(use sparse-vectors)
(require-library mutils)
|
︙ | | | ︙ | |
100
101
102
103
104
105
106
107
108
109
110
111
112
113
|
version " megatest-version "
license GPL, Copyright Matt Welland 2006-2017
Usage: megatest [options]
-h : this help
-manual : show the Megatest user manual
-version : print megatest version (currently " megatest-version ")
Launching and managing runs
-run : run all tests or as specified by -testpatt
-remove-runs : remove the data for a run, requires -runname and -testpatt
Optionally use :state and :status, use -keep-records to remove only
the run data. Use -kill-wait to override the 10 second
per test wait after kill delay (e.g. -kill-wait 0).
|
>
|
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
|
version " megatest-version "
license GPL, Copyright Matt Welland 2006-2017
Usage: megatest [options]
-h : this help
-manual : show the Megatest user manual
-version : print megatest version (currently " megatest-version ")
help : help for the new Megatest interface
Launching and managing runs
-run : run all tests or as specified by -testpatt
-remove-runs : remove the data for a run, requires -runname and -testpatt
Optionally use :state and :status, use -keep-records to remove only
the run data. Use -kill-wait to override the 10 second
per test wait after kill delay (e.g. -kill-wait 0).
|
︙ | | | ︙ | |
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
|
-sync-to-megatest.db : pull data from cache files in /tmp/$USER to megatest.db
-sync-to dest : sync to new postgresql central style database
-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
-adjutant C,M : start the server/adjutant with allocated cores C and Mem M (Gig),
use 0,0 to auto use full machine
-transport http|rpc : use http or rpc for transport (default is http)
-log logfile : send stdout and stderr to logfile
-list-servers : list the servers
-kill-servers : kill all servers
-repl : start a repl (useful for extending megatest)
-load file.scm : load and run file.scm
|
|
|
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
|
-sync-to-megatest.db : pull data from cache files in /tmp/$USER to megatest.db
-sync-to dest : sync to new postgresql central style database
-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
-adjutant host-type : start the server/adjutant with given host-type
use 0,0 to auto use full machine
-transport http|rpc : use http or rpc for transport (default is http)
-log logfile : send stdout and stderr to logfile
-list-servers : list the servers
-kill-servers : kill all servers
-repl : start a repl (useful for extending megatest)
-load file.scm : load and run file.scm
|
︙ | | | ︙ | |
266
267
268
269
270
271
272
273
274
275
276
277
278
279
|
Called as " (string-intersperse (argv) " ") "
Version " megatest-version ", built from " megatest-fossil-hash ))
;; -gui : start a gui interface
;; -config fname : override the runconfigs file with fname
;; process args
(define remargs (args:get-args
(argv)
(list "-runtests" ;; run a specific test
"-config" ;; override the config file name
"-append-config"
"-execute" ;; run the command encoded in the base64 parameter
|
>
>
>
>
|
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
|
Called as " (string-intersperse (argv) " ") "
Version " megatest-version ", built from " megatest-fossil-hash ))
;; -gui : start a gui interface
;; -config fname : override the runconfigs file with fname
(mttop-run (command-line-arguments)
'("help"))
;; process args
(define remargs (args:get-args
(argv)
(list "-runtests" ;; run a specific test
"-config" ;; override the config file name
"-append-config"
"-execute" ;; run the command encoded in the base64 parameter
|
︙ | | | ︙ | |
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
|
;;
(if (args:get-arg "-server")
(let ((tl (launch:setup))
(transport-type (string->symbol (or (args:get-arg "-transport") "http"))))
(server:launch 0 transport-type)
(set! *didsomething* #t)))
;; The adjutant is a bit different, it does NOT run (launch:setup) as it is not necessarily tied to
;; a specific Megatest area. Detail are being hashed out and this may change.
;;
(if (args:get-arg "-adjutant")
(begin
(adjutant-run)
(set! *didsomething* #t)))
(if (or (args:get-arg "-list-servers")
(args:get-arg "-kill-servers"))
(let ((tl (launch:setup)))
(if tl ;; all roads from here exit
(let* ((servers (server:get-list *toppath*))
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
>
>
>
>
>
>
>
>
>
>
|
|
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
|
;;
(if (args:get-arg "-server")
(let ((tl (launch:setup))
(transport-type (string->symbol (or (args:get-arg "-transport") "http"))))
(server:launch 0 transport-type)
(set! *didsomething* #t)))
(define (naylist->alist inlst)
(map (lambda (dat)
(cons (car dat)
(or (if (list? (cdr dat))
(if (null? (cdr dat)) ""
(cadr dat))
(cdr dat))
""))) ;; we need a string for call-with-environment-variables
inlst))
;; The adjutant is a bit different, it does NOT run (launch:setup) as it is not necessarily tied to
;; a specific Megatest area. Detail are being hashed out and this may change.
;;
(if (args:get-arg "-adjutant")
(let* ((host-type (args:get-arg "-adjutant")))
(launch:setup) ;; dang it, wish this wasn't needed
(print "Running the adjutant!")
(let loop ((wait-count 0))
(if (< wait-count 10) ;; 6 x 10 seconds = one minute
(let* ((dat (rmt:no-sync-take-job host-type)))
(match dat
((id ht vars exekey cmdline state event-time last-update)
(let ((vars-alist (with-input-from-string vars read)
))
(print "Vars:")
(pp vars-alist)
(call-with-environment-variables
(naylist->alist vars-alist)
(lambda ()
(system cmdline))))
(loop 0))
(else
(thread-sleep! 10)
(loop (+ wait-count 1)))))
(print "I'm bored. Exiting.")))
;; (adjutant-run (args:get-arg "-ajutant") rmt:no-sync-take-job)
(set! *didsomething* #t)))
(if (or (args:get-arg "-list-servers")
(args:get-arg "-kill-servers"))
(let ((tl (launch:setup)))
(if tl ;; all roads from here exit
(let* ((servers (server:get-list *toppath*))
|
︙ | | | ︙ | |