19
20
21
22
23
24
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
|
;; (include "common.scm")
;; (include "megatest-version.scm")
;; fake out readline usage of toplevel-command
(define (toplevel-command . a) #f)
(use srfi-1 posix srfi-69 readline ;; regex regex-case srfi-69 apropos json http-client directory-utils rpc typed-records;; (srfi 18) extras)
srfi-19 srfi-18 extras format pkts regex regex-case
(prefix dbi dbi:)
)
;; (declare (uses common))
(declare (uses margs))
(declare (uses configf))
;; (declare (uses rmt))
;; (use ducttape-lib)
;; (require-library stml)
mtutil, part of the Megatest tool suite, documentation at http://www.kiatoa.com/fossils/megatest
version " megatest-version "
license GPL, Copyright Matt Welland 2006-2017
Usage: mtutil action [options]
-h : this help
-manual : show the Megatest user manual
-version : print megatest version (currently " megatest-version ")
Examples:
Called as " (string-intersperse (argv) " ") "
Version " megatest-version ", built from " megatest-fossil-hash ))
;; first token is our action, but only if no leading dash
(define *action* (if (and (> (length (argv)) 1)
(not (string-match "^\\-.*" (cadr (argv)))))
(cadr (argv))
#f))
(define *remargs*
(args:get-args
(if *action* (cdr (argv)) (argv))
'("-log")
'("-h")
args:arg-hash
0))
(if (args:get-arg "-h")
(begin
(print help)
(exit)))
(if (or (args:get-arg "-repl")
(args:get-arg "-load"))
(begin
(import extras) ;; might not be needed
;; (import csi)
(import readline)
(import apropos)
;; (import (prefix sqlite3 sqlite3:)) ;; doesn't work ...
(install-history-file (get-environment-variable "HOME") ".mtutil_history") ;; [homedir] [filename] [nlines])
(current-input-port (make-readline-port "mtutil> "))
(if (args:get-arg "-repl")
(repl)
(load (args:get-arg "-load")))))
#|
(define mtconf (car (simple-setup #f)))
(define dat (common:with-queue-db mtconf (lambda (conn)(get-pkts conn '()))))
(pp (pkts#flatten-all dat '((cmd . ((parent . P)(url . M)))(runtype . ((parent . P)))) 'id 'group-id 'uuid 'parent 'pkt-type 'pkt 'processed))
|#
|
|
>
|
|
<
<
<
|
|
>
>
>
>
>
>
|
|
|
>
|
|
|
|
>
>
>
|
>
>
>
>
>
>
>
|
|
|
|
|
|
|
|
|
|
>
|
>
>
>
>
>
>
>
|
19
20
21
22
23
24
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
|
;; (include "common.scm")
;; (include "megatest-version.scm")
;; fake out readline usage of toplevel-command
(define (toplevel-command . a) #f)
(use srfi-1 posix srfi-69 readline ;; regex regex-case srfi-69 apropos json http-client directory-utils rpc typed-records;; (srfi 18) extras)
srfi-19 srfi-18 extras format regex regex-case
(prefix dbi dbi:)
matchable
)
;; (declare (uses common))
(declare (uses margs))
(declare (uses configfmod))
(declare (uses servermod))
(include "megatest-version.scm")
(include "megatest-fossil-hash.scm")
(define help (conc "
mtserv, part of the Megatest tool suite, documentation at http://www.kiatoa.com/fossils/megatest
version " megatest-version "
license GPL, Copyright Matt Welland 2006-2017
Usage: mtserv action [options]
-h : this help
-manual : show the Megatest user manual
-version : print megatest version (currently " megatest-version ")
-start-dir path : switch to dir at start
actions:
server : start server
repl : start repl
Examples:
Called as " (string-intersperse (argv) " ") "
Version " megatest-version ", built from " megatest-fossil-hash ))
;; first token is our action, but only if no leading dash
(define *action* (if (and (> (length (argv)) 1)
(not (string-match "^\\-.*" (cadr (argv)))))
(cadr (argv))
#f))
(define *remargs*
(args:get-args
(if *action* (cdr (argv)) (argv))
'("-log")
'("-h"
)
args:arg-hash
0))
(if (args:get-arg "-h")
(begin
(print help)
(exit)))
(if (args:get-arg "-start-dir")
(let* ((start-dir (args:get-arg "-start-dir")))
(if (and (file-exists? start-dir)
(directory? start-dir))
(change-directory start-dir)
(begin
(print "FATAL: cannot find or access "start-dir)
(exit 1)))))
(if *action*
(case (string->symbol *action*)
((server) (server:run))
((repl)
(import extras) ;; might not be needed
;; (import csi)
(import readline)
(import apropos)
;; (import (prefix sqlite3 sqlite3:)) ;; doesn't work ...
(install-history-file (get-environment-variable "HOME") ".mtserv_history") ;; [homedir] [filename] [nlines])
(current-input-port (make-readline-port "mtserv> "))
(print "Starting repl...")
(repl))
;; (if (args:get-arg "-load")
;; (load (args:get-arg "-load"))
;; (repl)))
(else
(print "Action \""*action*"\" not recognised.")
(print help)))
(begin
(print "No action provided.")
(print help)))
#|
(define mtconf (car (simple-setup #f)))
(define dat (common:with-queue-db mtconf (lambda (conn)(get-pkts conn '()))))
(pp (pkts#flatten-all dat '((cmd . ((parent . P)(url . M)))(runtype . ((parent . P)))) 'id 'group-id 'uuid 'parent 'pkt-type 'pkt 'processed))
|#
|