thin-provisioning-tools/functional-tests/temp-file.scm
2017-08-25 11:26:45 +01:00

145 lines
3.9 KiB
Scheme

(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))))
)