[functional-tests] Lexically scoped temp file stuff

functional-tests/cache-functional-tests.scm

@@ -15,12 +15,18 @@
 
   (define (current-metadata) "metadata.bin")
 
-  (define (temp-cache-xml)
+  (define cwd "/tmp")
-    (temp-file-containing (fmt #f (generate-xml 512 1024 128))))
+
+  (define-syntax with-cache-xml
+    (syntax-rules ()
+      ((_ (v) b1 b2 ...)
+       (with-temp-file-containing ((v (fmt #f (generate-xml 512 1024 128))))
+         b1 b2 ...))))
 
   (define (%with-valid-metadata thunk)
-    (cache-restore "-i" (temp-cache-xml) "-o" (current-metadata))
+    (with-cache-xml (xml)
-    (thunk))
+      (cache-restore "-i" xml "-o" (current-metadata))
+      (thunk)))
 
   (define-syntax with-valid-metadata
     (syntax-rules ()
@@ -109,6 +115,7 @@ Options:
                      (receive (_ stderr) (run-fail "cache_check" (current-metadata))
                               (assert-starts-with "syscall 'open' failed: Permission denied" stderr))))
   |#
+
   (define-scenario (cache-check fails-with-corrupt-metadata)
                    "Fail with corrupt superblock"
                    (with-corrupt-metadata
@@ -120,4 +127,27 @@ Options:
                      (receive (stdout stderr) (run-fail "cache_check" "-q" (current-metadata))
                               (assert-eof stdout)
                               (assert-eof stderr))))
+
+  (define-scenario (cache-check failing-quiet)
+                   "Fail quietly with --quiet"
+                   (with-corrupt-metadata
+                     (receive (stdout stderr) (run-fail "cache_check" "--quiet" (current-metadata))
+                              (assert-eof stdout)
+                              (assert-eof stderr))))
+
+  (define-scenario (cache-check valid-metadata-passes)
+                   "A valid metadata area passes"
+                   (with-valid-metadata
+                     (cache-check (current-metadata))))
+
+  (define-scenario (cache-check deliberately-fail)
+                   "remove me"
+                   (fail (dsp "bad bad bad")))
+
+  (define-scenario (cache-check bad-metadata-version)
+                   "Invalid metadata version fails"
+                   (with-cache-xml (xml)
+                     (cache-restore "-i" xml "-o" (current-metadata)
+                                    "--debug-override-metadata-version" "12345")
+                     (run-fail "cache_check" (current-metadata))))
 )

functional-tests/functional-tests.scm

@@ -79,9 +79,10 @@
   (define (build-command-line cmd-and-args)
     (apply fmt #f (map dsp (intersperse " " cmd-and-args))))
 
+  (define cwd "/tmp")
+
   (define (run . cmd-and-args)
-    (let ((stdout-file (temp-file))
+    (with-temp-file (stdout-file stderr-file)
-          (stderr-file (temp-file)))
                     (let ((cmd (fmt #f
                                     (dsp (build-command-line cmd-and-args))
                                     (dsp " > ")
@@ -171,13 +172,19 @@
                      (scenario-desc
                        (hashtable-ref scenarios keys #f)))))
 
+  (define (test-dir cwd keys)
+    (apply string-append cwd "/"
+           (intersperse "/" (map symbol->string keys))))
+
   (define-syntax define-scenario
-    (syntax-rules ()
+    (lambda (x)
-      ((_ syms desc body ...)
+      (syntax-case x ()
-       (add-scenario 'syms
+                   ((k keys desc b1 b2 ...)
+                    #'(add-scenario 'keys
                                     (make-scenario desc
                                                    (lambda ()
-                                      body ...))))))
+                                                     (with-dir (test-dir "." 'keys)
+                                                               b1 b2 ...))))))))
 
   (define (fail msg)
     (raise (condition

functional-tests/run-tests

@@ -9,6 +9,7 @@
         (only (srfi s1 lists) break)
         (regex)
         (srfi s8 receive)
+	(temp-file)
         (thin-functional-tests))
 
 ;;------------------------------------------------
@@ -85,9 +86,6 @@
 ;;------------------------------------------------
 ;; Command line parser
 
-(define (switch str)
-  (>> (lit "--") (lit str)))
-
 (define whitespace
   (many+ (charset " \t\n")))
 
@@ -95,17 +93,34 @@
   (>> (opt whitespace)
       (<* ma (opt whitespace))))
 
+(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)))))
+    (pure (list->string (cons c cs))))))
+
+(define (maybe ma)
+ (alt (>> ma (pure #t))
+  (pure #f)))
+
+(define help-command-line
+ (>> (switch "help") (pure exec-help)))
+
+(define run-command-line
+ (parse-m
+  (switch "run")
+  (<- dunlink (maybe (switch "disable-unlink")))
+  (<- args (many* not-switch))
+  (pure (lambda ()
+	 (if dunlink
+	  (disable-unlink (exec-run args))
+	  (exec-run args))))))
 
 (define command-line-parser
-  (alt (>> (switch "help") (pure exec-help))
+ (one-of help-command-line run-command-line))
-       (parse-m (switch "run")
-                (<- args (many* (whitespace-delim not-switch)))
-                (pure (lambda ()
-                        (exec-run args))))))
 
 (define (bad-command-line)
   (fmt (current-error-port) (dsp "bad command line\n")))
@@ -116,8 +131,7 @@
     (receive (v st)
              (parse command-line-parser
                     (apply string-append
-                           (intersperse " "
+                           (intersperse " " (cdr (command-line)))))
-                                        (cdr (command-line)))))
              (if (success? st)
                  v
                  bad-command-line))))
@@ -126,5 +140,6 @@
 
 (register-thin-tests)
 (register-cache-tests)
-((parse-command-line))
+(with-dir "test-output"
+ ((parse-command-line)))
 

functional-tests/temp-file.scm

@@ -2,25 +2,121 @@
   (temp-file)
 
   (export
-    temp-file
+    working-directory
-    temp-file-containing)
+    with-dir-thunk
+    with-dir
+    with-temp-file-thunk
+    with-temp-file-containing-thunk
+    with-temp-file
+    with-temp-file-containing
+    disable-unlink)
 
-  (import (rnrs)
+  (import (chezscheme)
           (fmt fmt))
 
-  (define temp-file
+  ;; FIXME: global var!  Not thread safe.
+  (define working-dir "/tmp")
+
+  (define (working-directory) working-dir)
+
+  (define (mkdir-p)
+    (system (string-append "mkdir -p " working-dir)))
+
+  (define (with-dir-thunk path thunk)
+    (fluid-let ((working-dir (string-append working-dir "/" path)))
+               (mkdir-p)
+               (thunk)))
+
+  (define-syntax with-dir
+    (syntax-rules ()
+      ((_ path b1 b2 ...)
+       (with-dir-thunk path (lambda () b1 b2 ...)))))
+
+  (define (with-temp-dir-thunk path thunk)
+    (with-dir-thunk path
+                    (lambda ()
+                      (auto-unlink-file path
+                                   (thunk)))))
+
+   (define temp-filename
      (let ((counter 0))
       (lambda ()
         (let loop ()
-        (let ((path (fmt #f (cat (dsp "/tmp/thinp-functional-tests-")
+         (let ((path (fmt #f (cat (dsp working-dir) (dsp "/tmp-")
                                   (pad-char #\0 (pad/left 4 (num counter)))))))
            (set! counter (+ counter 1))
-          (if (file-exists? path) (loop) path))))))
+           (if (file-exists? path)
+               (loop)
+               path))))))
+
+   ;; fn takes the path
+   (define (with-temp-file-thunk fn)
+     (let ((path (temp-filename)))
+      (auto-unlink-file path
+        (lambda () (fn path)))))
+
+   (define-syntax with-temp-file
+     (syntax-rules ()
+       ((_ (v) b1 b2 ...)
+        (with-temp-file-thunk
+          (lambda (v)
+            b1 b2 ...)))
+
+       ((_ (v1 v2 ...) b1 b2 ...)
+        (with-temp-file-thunk
+          (lambda (v1)
+            (with-temp-file (v2 ...) b1 b2 ...))))))
 
    ;; Creates a temporary file with the specified contents.
-  (define (temp-file-containing contents)
+   (define (with-temp-file-containing-thunk contents fn)
-    (let ((path (temp-file)))
+     (with-temp-file-thunk
-     (with-output-to-file path (lambda () (put-string (current-output-port) contents)))
+       (lambda (path)
-     path))
+         (with-output-to-file path (lambda ()
+                                     (put-string (current-output-port) contents)))
+         (fn path))))
 
+   (define-syntax with-temp-file-containing
+     (syntax-rules ()
+       ((_ ((v txt)) b1 b2 ...)
+        (with-temp-file-containing-thunk
+          txt (lambda (v) b1 b2 ...)))
+
+       ((_ ((v txt) rest ...) b1 b2 ...)
+        (with-temp-file-containing-thunk
+          txt (lambda (v txt)
+                (with-temp-file-containing (rest ...)
+                                           b1 b2 ...))))))
+
+   ;;-------------------------
+
+   (define should-unlink #t)
+
+   (define (disable-unlink-thunk fn)
+     (fluid-let ((should-unlink #f))
+                (fn)))
+
+   (define-syntax disable-unlink
+     (syntax-rules ()
+       ((_ b1 b2 ...)
+        (disable-unlink-thunk
+          (lambda () b1 b2 ...)))))
+
+   ;; FIXME: use 'run' so we get logging
+   (define (unlink-file path)
+     (when should-unlink
+       (system (string-append "rm -f " path))))
+
+   (define (unlink-dir path)
+     (when should-unlink
+       (system (string-append "rmdir -f " path))))
+
+   (define (auto-unlink-file path thunk)
+     (dynamic-wind (lambda () #t)
+                   thunk
+                   (lambda () (unlink-file path))))
+
+   (define (auto-unlink-dir path thunk)
+     (dynamic-wind (lambda () #t)
+                   thunk
+                   (lambda () (unlink-dir path))))
    )

functional-tests/thin-functional-tests.scm

@@ -18,18 +18,24 @@
   (define-tool thin-restore)
   (define-tool thin-rmap)
 
+  ;; FIXME: use a temp file
   (define (current-metadata) "metadata.bin")
 
-  (define (temp-thin-xml)
+  ;; FIXME: remove
-    (temp-file-containing (fmt #f (generate-xml 10 1000))))
+  (define cwd "/tmp")
 
-  (define (%with-valid-metadata thunk)
+  (define-syntax with-thin-xml
-    (thin-restore "-i" (temp-thin-xml) "-o" (current-metadata))
+    (syntax-rules ()
-    (thunk))
+      ((_ (v) b1 b2 ...)
+       (with-temp-file-containing ((v (fmt #f (generate-xml 10 1000))))
+                                  b1 b2 ...))))
 
   (define-syntax with-valid-metadata
     (syntax-rules ()
-      ((_ body ...) (%with-valid-metadata (lambda () body ...)))))
+      ((_ b1 b2 ...)
+       (with-thin-xml (xml)
+                      (thin-restore "-i" xml "-o" (current-metadata))
+                      b1 b2 ...))))
 
   ;;; It would be nice if the metadata was at least similar to valid data.
   (define (%with-corrupt-metadata thunk)
@@ -182,28 +188,32 @@ Where:
 
    (define-scenario (thin-restore tiny-output-file)
                     "Fails if the output file is too small."
-                   (let ((outfile (temp-file)))
+                    (with-temp-file (outfile)
                       (run-ok "dd if=/dev/zero" (fmt #f (dsp "of=") (dsp outfile)) "bs=4k count=1")
-                    (receive (_ stderr) (run-fail "thin_restore" "-i" (temp-thin-xml) "-o" outfile)
+                      (with-thin-xml (xml)
-                             (assert-starts-with thin-restore-outfile-too-small-text stderr))))
+                        (receive (_ stderr) (run-fail "thin_restore" "-i" xml "-o" outfile)
+                          (assert-starts-with thin-restore-outfile-too-small-text stderr)))))
 
    (define-scenario (thin-restore q)
                     "thin_restore accepts -q"
-            (receive (stdout _) (thin-restore "-i" (temp-thin-xml) "-o" (current-metadata) "-q")
+                    (with-thin-xml (xml)
-                     (assert-eof stdout)))
+                      (receive (stdout _) (thin-restore "-i" xml "-o" (current-metadata) "-q")
+                        (assert-eof stdout))))
 
    (define-scenario (thin-restore quiet)
                     "thin_restore accepts --quiet"
-            (receive (stdout _) (thin-restore "-i" (temp-thin-xml) "-o" (current-metadata) "--quiet")
+                    (with-thin-xml (xml)
-                     (assert-eof stdout)))
+                      (receive (stdout _) (thin-restore "-i" xml "-o" (current-metadata) "--quiet")
+                        (assert-eof stdout))))
 
    (define-scenario (thin-dump restore-is-noop)
                     "thin_dump followed by thin_restore is a noop."
                     (with-valid-metadata
                       (receive (d1-stdout _) (thin-dump (current-metadata))
-                       (thin-restore "-i" (temp-file-containing d1-stdout) "-o" (current-metadata))
+                        (with-temp-file-containing ((xml d1-stdout))
+                          (thin-restore "-i" xml "-o" (current-metadata))
                           (receive (d2-stdout _) (thin-dump (current-metadata))
-                                (assert-equal d1-stdout d2-stdout)))))
+                            (assert-equal d1-stdout d2-stdout))))))
 
    ;;;-----------------------------------------------------------
    ;;; thin_rmap scenarios