| ︙ | | | ︙ | |
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
41
42
43
|
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
;;
;; (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:)
(prefix sqlite3 sqlite3:)
nanomsg)
(declare (uses common))
(declare (uses margs))
(declare (uses configf))
;; (declare (uses rmt))
(use ducttape-lib)
(include "megatest-fossil-hash.scm")
(require-library stml)
;; stuff for the mapper and checker functions
;;
|
>
>
>
>
>
>
>
>
>
|
|
>
>
>
|
|
|
<
<
<
<
|
|
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
41
42
43
44
45
46
47
48
49
50
51
|
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
;;
(declare (uses common))
(declare (uses margs))
(declare (uses configf))
(declare (uses pkts))
;; (declare (uses rmt))
;; (include "common.scm")
(include "megatest-version.scm")
;; fake out readline usage of toplevel-command
(define (toplevel-command . a) #f)
(import
srfi-1
;; posix
srfi-69 breadline ;; regex regex-case srfi-69 apropos json http-client directory-utils rpc typed-records;; (srfi 18) extras)
srfi-19 srfi-18
;; extras
chicken.format
pkts regex regex-case
(prefix dbi dbi:)
(prefix sqlite3 sqlite3:)
nanomsg)
(import ducttape-lib)
(include "megatest-fossil-hash.scm")
(require-library stml)
;; stuff for the mapper and checker functions
;;
|
| ︙ | | | ︙ | |
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
|
extra-dat: `(a ,runkey) ;; we need the run key for marking the run as launched
)))
(with-output-to-file
(conc pktsdir "/" uuid ".pkt")
(lambda ()
(print pkt))))))
;; (use trace)(trace create-run-pkt)
(define (contains list x) (cond ((null? list) #f) ((eq? (car list) x) #t) (else (contains (cdr list) x))))
;; collect all needed data and create run pkts for contours with changed inputs
;;
(define (generate-run-pkts mtconf toppath)
(let ((std-runname (conc "sched" (time->string (seconds->local-time (current-seconds)) "%M%H%d")))
(packets-generated 0))
|
|
|
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
|
extra-dat: `(a ,runkey) ;; we need the run key for marking the run as launched
)))
(with-output-to-file
(conc pktsdir "/" uuid ".pkt")
(lambda ()
(print pkt))))))
;; (import trace)(trace create-run-pkt)
(define (contains list x) (cond ((null? list) #f) ((eq? (car list) x) #t) (else (contains (cdr list) x))))
;; collect all needed data and create run pkts for contours with changed inputs
;;
(define (generate-run-pkts mtconf toppath)
(let ((std-runname (conc "sched" (time->string (seconds->local-time (current-seconds)) "%M%H%d")))
(packets-generated 0))
|
| ︙ | | | ︙ | |
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
|
(conc "megatest " (if (not (member action '("sync")))
(conc action " " action-param)
"") (if (member action '("-run" "-rerun-clean" "-rerun-all" "-kill-rerun"))
"-rerun DEAD,ABORT,KILLED"
""))
pkta)))
;; (use trace)(trace pkt->cmdline)
(define (write-pkt pktsdir uuid pkt)
(if pktsdir
(with-output-to-file
(conc pktsdir "/" uuid ".pkt")
(lambda ()
(print pkt)))
|
|
|
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
|
(conc "megatest " (if (not (member action '("sync")))
(conc action " " action-param)
"") (if (member action '("-run" "-rerun-clean" "-rerun-all" "-kill-rerun"))
"-rerun DEAD,ABORT,KILLED"
""))
pkta)))
;; (import trace)(trace pkt->cmdline)
(define (write-pkt pktsdir uuid pkt)
(if pktsdir
(with-output-to-file
(conc pktsdir "/" uuid ".pkt")
(lambda ()
(print pkt)))
|
| ︙ | | | ︙ | |
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
|
(begin
(stml:main #f)
(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)
|
|
|
|
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
|
(begin
(stml:main #f)
(exit)))
(if (or (args:get-arg "-repl")
(args:get-arg "-load"))
(begin
;; (import extras) ;; might not be needed
;; (import csi)
(import breadline)
(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)
|
| ︙ | | | ︙ | |