[functional-tests] Split dmtest off from run-tests
This commit is contained in:
parent
74e2506734
commit
a0e709d370
12
functional-tests/dmtest
Executable file
12
functional-tests/dmtest
Executable file
@ -0,0 +1,12 @@
|
||||
#! /usr/bin/scheme-script
|
||||
|
||||
(import (rnrs)
|
||||
(test-runner)
|
||||
(bcache bcache-tests)
|
||||
(device-mapper dm-tests))
|
||||
|
||||
(register-bcache-tests)
|
||||
(register-dm-tests)
|
||||
|
||||
(run-tests)
|
||||
|
@ -1,185 +1,14 @@
|
||||
#! /usr/bin/scheme-script
|
||||
|
||||
(import (rnrs)
|
||||
(only (chezscheme) load-shared-object)
|
||||
(fmt fmt)
|
||||
(list-utils)
|
||||
(functional-tests)
|
||||
(bcache bcache-tests)
|
||||
(test-runner)
|
||||
(cache-functional-tests)
|
||||
(era-functional-tests)
|
||||
(parser-combinators)
|
||||
(only (srfi s1 lists) break)
|
||||
(regex)
|
||||
(srfi s8 receive)
|
||||
(temp-file)
|
||||
(thin-functional-tests))
|
||||
|
||||
;;------------------------------------------------
|
||||
|
||||
;; Returns #t if the xs list matches prefix
|
||||
(define (begins-with prefix xs)
|
||||
(cond
|
||||
((null? prefix) #t)
|
||||
((null? xs) #f)
|
||||
((eq? (car prefix) (car xs))
|
||||
(begins-with (cdr prefix) (cdr xs)))
|
||||
(else #f)))
|
||||
|
||||
(define (split-list xs sep)
|
||||
(define (safe-cdr xs)
|
||||
(if (null? xs) '() (cdr xs)))
|
||||
|
||||
(if (null? xs)
|
||||
'()
|
||||
(receive (p r) (break (lambda (c)
|
||||
(eq? c sep))
|
||||
xs)
|
||||
(cons p (split-list (safe-cdr r) sep)))))
|
||||
|
||||
(define (string->syms str sep)
|
||||
(map (lambda (cs)
|
||||
(string->symbol
|
||||
(list->string cs)))
|
||||
(split-list (string->list str) sep)))
|
||||
|
||||
(define (mk-string-matcher pattern)
|
||||
(let ((prefix (string->syms pattern #\/)))
|
||||
(lambda (keys)
|
||||
(begins-with prefix keys))))
|
||||
|
||||
(define (mk-regex-matcher pattern)
|
||||
(let ((rx (regex pattern)))
|
||||
(lambda (keys)
|
||||
(rx (apply string-append
|
||||
(intersperse "/"
|
||||
(map symbol->string keys)))))))
|
||||
|
||||
(define (string-prefix? p str)
|
||||
(and (>= (string-length str) (string-length p))
|
||||
(string=? p (substring str 0 (string-length p)))))
|
||||
|
||||
;; If the filter begins with 're:' then we make a regex matcher, otherwise
|
||||
;; we use a simple string matcher.
|
||||
(define (mk-single-matcher pattern)
|
||||
(if (string-prefix? "re:" pattern)
|
||||
(mk-regex-matcher (substring pattern 3 (string-length pattern)))
|
||||
(mk-string-matcher pattern)))
|
||||
|
||||
(define (mk-filter patterns)
|
||||
(if (null? patterns)
|
||||
; accept everything if no patterns
|
||||
(lambda (_) #t)
|
||||
|
||||
; Otherwise accept tests that pass a pattern
|
||||
(let ((filters (map mk-single-matcher patterns)))
|
||||
(fold-left (lambda (fn-a fn-b)
|
||||
(lambda (keys)
|
||||
(or (fn-a keys)
|
||||
(fn-b keys))))
|
||||
(car filters)
|
||||
(cdr filters)))))
|
||||
|
||||
(define (exec-help)
|
||||
(fmt (current-error-port)
|
||||
"Usage:" nl
|
||||
" run-tests help" nl
|
||||
" run-tests list <pattern>*" nl
|
||||
" run-tests run [--disable-unlink] <pattern>*" nl nl
|
||||
(justify
|
||||
(string-append
|
||||
"Patterns are used to select tests. There are two forms a pattern can take; "
|
||||
"either a literal such as 'cache-check/bad-option', or a regular expression (prefix with 're:')."))
|
||||
nl
|
||||
"eg," nl
|
||||
" run-tests run cache-check/bad-option" nl
|
||||
" run-tests run re:help" nl
|
||||
" run-tests run cache-check thin-check re:.*missing.*file" nl
|
||||
))
|
||||
|
||||
(define (exec-run args)
|
||||
(let ((pred (mk-filter args)))
|
||||
(if (run-scenarios (filter pred (list-scenarios)))
|
||||
(exit)
|
||||
(exit #f))))
|
||||
|
||||
(define (exec-list args)
|
||||
(let ((pred (mk-filter args)))
|
||||
(describe-scenarios (filter pred (list-scenarios)))))
|
||||
|
||||
;;------------------------------------------------
|
||||
;; Command line parser
|
||||
|
||||
(define whitespace
|
||||
(many+ (charset " \t\n")))
|
||||
|
||||
(define (whitespace-delim ma)
|
||||
(>> (opt whitespace)
|
||||
(<* ma (opt whitespace))))
|
||||
|
||||
(define (cmd-word str)
|
||||
(whitespace-delim (lit str)))
|
||||
|
||||
(define (switch str)
|
||||
(whitespace-delim (>> (lit "--") (lit str))))
|
||||
|
||||
(define not-switch
|
||||
(whitespace-delim
|
||||
(parse-m (<- c (neg-charset "- \t"))
|
||||
(<- cs (many* (neg-charset " \t")))
|
||||
(pure (list->string (cons c cs))))))
|
||||
|
||||
(define (maybe ma)
|
||||
(alt (>> ma (pure #t))
|
||||
(pure #f)))
|
||||
|
||||
(define help-command-line
|
||||
(>> (cmd-word "help") (pure exec-help)))
|
||||
|
||||
(define run-command-line
|
||||
(parse-m
|
||||
(cmd-word "run")
|
||||
(<- dunlink (maybe (switch "disable-unlink")))
|
||||
(<- args (many* not-switch))
|
||||
(pure (lambda ()
|
||||
(if dunlink
|
||||
(disable-unlink (exec-run args))
|
||||
(exec-run args))))))
|
||||
|
||||
(define list-command-line
|
||||
(parse-m
|
||||
(cmd-word "list")
|
||||
(<- args (many* not-switch))
|
||||
(pure (lambda () (exec-list args)))))
|
||||
|
||||
(define command-line-parser
|
||||
(one-of help-command-line
|
||||
run-command-line
|
||||
list-command-line))
|
||||
|
||||
(define (bad-command-line)
|
||||
(fmt (current-error-port) (dsp "bad command line\n"))
|
||||
(exec-help)
|
||||
(exit 1))
|
||||
|
||||
;; (<string>) -> thunk
|
||||
(define (parse-command-line)
|
||||
(let ((args (cdr (command-line))))
|
||||
(receive (v st)
|
||||
(parse command-line-parser
|
||||
(apply string-append
|
||||
(intersperse " " (cdr (command-line)))))
|
||||
(if (success? st)
|
||||
v
|
||||
bad-command-line))))
|
||||
|
||||
;;------------------------------------------------
|
||||
|
||||
(register-thin-tests)
|
||||
(register-cache-tests)
|
||||
(register-era-tests)
|
||||
(register-bcache-tests)
|
||||
|
||||
(with-dir "test-output"
|
||||
((parse-command-line)))
|
||||
(run-tests)
|
||||
|
||||
|
182
functional-tests/test-runner.scm
Normal file
182
functional-tests/test-runner.scm
Normal file
@ -0,0 +1,182 @@
|
||||
(library
|
||||
(test-runner)
|
||||
(export run-tests)
|
||||
|
||||
(import (rnrs)
|
||||
(only (chezscheme) load-shared-object)
|
||||
(fmt fmt)
|
||||
(list-utils)
|
||||
(functional-tests)
|
||||
(bcache bcache-tests)
|
||||
(cache-functional-tests)
|
||||
(era-functional-tests)
|
||||
(parser-combinators)
|
||||
(only (srfi s1 lists) break)
|
||||
(regex)
|
||||
(srfi s8 receive)
|
||||
(temp-file)
|
||||
(thin-functional-tests))
|
||||
|
||||
;;------------------------------------------------
|
||||
|
||||
;; Returns #t if the xs list matches prefix
|
||||
(define (begins-with prefix xs)
|
||||
(cond
|
||||
((null? prefix) #t)
|
||||
((null? xs) #f)
|
||||
((eq? (car prefix) (car xs))
|
||||
(begins-with (cdr prefix) (cdr xs)))
|
||||
(else #f)))
|
||||
|
||||
(define (split-list xs sep)
|
||||
(define (safe-cdr xs)
|
||||
(if (null? xs) '() (cdr xs)))
|
||||
|
||||
(if (null? xs)
|
||||
'()
|
||||
(receive (p r) (break (lambda (c)
|
||||
(eq? c sep))
|
||||
xs)
|
||||
(cons p (split-list (safe-cdr r) sep)))))
|
||||
|
||||
(define (string->syms str sep)
|
||||
(map (lambda (cs)
|
||||
(string->symbol
|
||||
(list->string cs)))
|
||||
(split-list (string->list str) sep)))
|
||||
|
||||
(define (mk-string-matcher pattern)
|
||||
(let ((prefix (string->syms pattern #\/)))
|
||||
(lambda (keys)
|
||||
(begins-with prefix keys))))
|
||||
|
||||
(define (mk-regex-matcher pattern)
|
||||
(let ((rx (regex pattern)))
|
||||
(lambda (keys)
|
||||
(rx (apply string-append
|
||||
(intersperse "/"
|
||||
(map symbol->string keys)))))))
|
||||
|
||||
(define (string-prefix? p str)
|
||||
(and (>= (string-length str) (string-length p))
|
||||
(string=? p (substring str 0 (string-length p)))))
|
||||
|
||||
;; If the filter begins with 're:' then we make a regex matcher, otherwise
|
||||
;; we use a simple string matcher.
|
||||
(define (mk-single-matcher pattern)
|
||||
(if (string-prefix? "re:" pattern)
|
||||
(mk-regex-matcher (substring pattern 3 (string-length pattern)))
|
||||
(mk-string-matcher pattern)))
|
||||
|
||||
(define (mk-filter patterns)
|
||||
(if (null? patterns)
|
||||
; accept everything if no patterns
|
||||
(lambda (_) #t)
|
||||
|
||||
; Otherwise accept tests that pass a pattern
|
||||
(let ((filters (map mk-single-matcher patterns)))
|
||||
(fold-left (lambda (fn-a fn-b)
|
||||
(lambda (keys)
|
||||
(or (fn-a keys)
|
||||
(fn-b keys))))
|
||||
(car filters)
|
||||
(cdr filters)))))
|
||||
|
||||
(define (exec-help)
|
||||
(fmt (current-error-port)
|
||||
"Usage:" nl
|
||||
" run-tests help" nl
|
||||
" run-tests list <pattern>*" nl
|
||||
" run-tests run [--disable-unlink] <pattern>*" nl nl
|
||||
(justify
|
||||
(string-append
|
||||
"Patterns are used to select tests. There are two forms a pattern can take; "
|
||||
"either a literal such as 'cache-check/bad-option', or a regular expression (prefix with 're:')."))
|
||||
nl
|
||||
"eg," nl
|
||||
" run-tests run cache-check/bad-option" nl
|
||||
" run-tests run re:help" nl
|
||||
" run-tests run cache-check thin-check re:.*missing.*file" nl
|
||||
))
|
||||
|
||||
(define (exec-run args)
|
||||
(let ((pred (mk-filter args)))
|
||||
(if (run-scenarios (filter pred (list-scenarios)))
|
||||
(exit)
|
||||
(exit #f))))
|
||||
|
||||
(define (exec-list args)
|
||||
(let ((pred (mk-filter args)))
|
||||
(describe-scenarios (filter pred (list-scenarios)))))
|
||||
|
||||
;;------------------------------------------------
|
||||
;; Command line parser
|
||||
|
||||
(define whitespace
|
||||
(many+ (charset " \t\n")))
|
||||
|
||||
(define (whitespace-delim ma)
|
||||
(>> (opt whitespace)
|
||||
(<* ma (opt whitespace))))
|
||||
|
||||
(define (cmd-word str)
|
||||
(whitespace-delim (lit str)))
|
||||
|
||||
(define (switch str)
|
||||
(whitespace-delim (>> (lit "--") (lit str))))
|
||||
|
||||
(define not-switch
|
||||
(whitespace-delim
|
||||
(parse-m (<- c (neg-charset "- \t"))
|
||||
(<- cs (many* (neg-charset " \t")))
|
||||
(pure (list->string (cons c cs))))))
|
||||
|
||||
(define (maybe ma)
|
||||
(alt (>> ma (pure #t))
|
||||
(pure #f)))
|
||||
|
||||
(define help-command-line
|
||||
(>> (cmd-word "help") (pure exec-help)))
|
||||
|
||||
(define run-command-line
|
||||
(parse-m
|
||||
(cmd-word "run")
|
||||
(<- dunlink (maybe (switch "disable-unlink")))
|
||||
(<- args (many* not-switch))
|
||||
(pure (lambda ()
|
||||
(if dunlink
|
||||
(disable-unlink (exec-run args))
|
||||
(exec-run args))))))
|
||||
|
||||
(define list-command-line
|
||||
(parse-m
|
||||
(cmd-word "list")
|
||||
(<- args (many* not-switch))
|
||||
(pure (lambda () (exec-list args)))))
|
||||
|
||||
(define command-line-parser
|
||||
(one-of help-command-line
|
||||
run-command-line
|
||||
list-command-line))
|
||||
|
||||
(define (bad-command-line)
|
||||
(fmt (current-error-port) (dsp "bad command line\n"))
|
||||
(exec-help)
|
||||
(exit 1))
|
||||
|
||||
;; (<string>) -> thunk
|
||||
(define (parse-command-line)
|
||||
(let ((args (cdr (command-line))))
|
||||
(receive (v st)
|
||||
(parse command-line-parser
|
||||
(apply string-append
|
||||
(intersperse " " (cdr (command-line)))))
|
||||
(if (success? st)
|
||||
v
|
||||
bad-command-line))))
|
||||
|
||||
;;------------------------------------------------
|
||||
|
||||
(define (run-tests)
|
||||
(with-dir "test-output"
|
||||
((parse-command-line)))))
|
Loading…
Reference in New Issue
Block a user