thin-provisioning-tools/functional-tests/temp-file.scm

(library
  (temp-file)

  (export
    working-directory
    with-dir-thunk
    with-dir
    with-temp-file-thunk
    with-temp-file-containing-thunk
    with-temp-file-sized-thunk
    with-temp-file
    with-temp-file-containing
    with-temp-file-sized
    disable-unlink)

  (import (chezscheme)
          (fmt fmt))

  ;; 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 working-dir) (dsp "/tmp-")
                                  (pad-char #\0 (pad/left 4 (num counter)))))))
           (set! counter (+ counter 1))
           (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 (with-temp-file-containing-thunk contents fn)
     (with-temp-file-thunk
       (lambda (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 (with-temp-file-sized-thunk size fn)
     (with-temp-file-thunk
       (lambda (path)
         (let ((cmd (fmt #f (dsp "fallocate -l ") (wrt size) (dsp " ") (dsp path))))
          (system cmd)
          (fn path)))))

   (define-syntax with-temp-file-sized
     (syntax-rules ()
       ((_ ((v size)) b1 b2 ...)
        (with-temp-file-sized-thunk
          size
          (lambda (v)
            b1 b2 ...)))

       ((_ ((v size) rest ...) b1 b2 ...)
        (with-temp-file-sized-thunk
          size (lambda (v)
                 (with-temp-file-sized (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))))
   )