diff options
| -rw-r--r-- | Makefile.am | 1 | ||||
| -rw-r--r-- | mumi/test-utils.scm | 55 |
2 files changed, 56 insertions, 0 deletions
diff --git a/Makefile.am b/Makefile.am index 0d68fe0..9426c26 100644 --- a/Makefile.am +++ b/Makefile.am @@ -51,6 +51,7 @@ SOURCES = \ mumi/send-email.scm \ mumi/config.scm \ mumi/debbugs.scm \ + mumi/test-utils.scm \ mumi/xapian.scm TEST_EXTENSIONS = .scm diff --git a/mumi/test-utils.scm b/mumi/test-utils.scm new file mode 100644 index 0000000..b33ffc4 --- /dev/null +++ b/mumi/test-utils.scm @@ -0,0 +1,55 @@ +;;; mumi -- Mediocre, uh, mail interface +;;; Copyright © 2020 Ricardo Wurmus <rekado@elephly.net> +;;; +;;; This program is free software: you can redistribute it and/or +;;; modify it under the terms of the GNU Affero General Public License +;;; as published by the Free Software Foundation, either version 3 of +;;; the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Affero General Public License for more details. +;;; +;;; You should have received a copy of the GNU Affero General Public +;;; License along with this program. If not, see +;;; <http://www.gnu.org/licenses/>. + +(define-module (mumi test-utils) + #:use-module (mumi xapian) + #:use-module (srfi srfi-19) + #:use-module (srfi srfi-64) + #:use-module (ice-9 ftw) + #:export (delete-file-recursively mock)) + +(define* (delete-file-recursively dir) + "Delete DIR recursively, like `rm -rf', without following symlinks. +Report but ignore errors." + (let ((dev (stat:dev (lstat dir)))) + (file-system-fold (lambda (dir stat result) ; enter? + (= dev (stat:dev stat))) + (lambda (file stat result) ; leaf + (delete-file file)) + (const #t) ; down + (lambda (dir stat result) ; up + (rmdir dir)) + (const #t) ; skip + (lambda (file stat errno result) + (format (current-error-port) + "warning: failed to delete ~a: ~a~%" + file (strerror errno))) + #t + dir + + ;; Don't follow symlinks. + lstat))) + +(define-syntax-rule (mock (module proc replacement) body ...) + "Within BODY, replace the definition of PROC from MODULE with the definition +given by REPLACEMENT." + (let* ((m (resolve-module 'module)) + (original (module-ref m 'proc))) + (dynamic-wind + (lambda () (module-set! m 'proc replacement)) + (lambda () body ...) + (lambda () (module-set! m 'proc original))))) |