From a0e709d370242cf43d41151ab168e0319d90358b Mon Sep 17 00:00:00 2001 From: Joe Thornber Date: Wed, 11 Oct 2017 10:28:10 +0100 Subject: [PATCH] [functional-tests] Split dmtest off from run-tests --- functional-tests/dmtest | 12 ++ functional-tests/run-tests | 175 +---------------------------- functional-tests/test-runner.scm | 182 +++++++++++++++++++++++++++++++ 3 files changed, 196 insertions(+), 173 deletions(-) create mode 100755 functional-tests/dmtest create mode 100644 functional-tests/test-runner.scm diff --git a/functional-tests/dmtest b/functional-tests/dmtest new file mode 100755 index 0000000..072eb2d --- /dev/null +++ b/functional-tests/dmtest @@ -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) + diff --git a/functional-tests/run-tests b/functional-tests/run-tests index c08f40f..8def1f7 100755 --- a/functional-tests/run-tests +++ b/functional-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 *" nl - " run-tests run [--disable-unlink] *" 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)) - -;; () -> 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) diff --git a/functional-tests/test-runner.scm b/functional-tests/test-runner.scm new file mode 100644 index 0000000..b21f5f9 --- /dev/null +++ b/functional-tests/test-runner.scm @@ -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 *" nl + " run-tests run [--disable-unlink] *" 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)) + + ;; () -> 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)))))