diff options
Diffstat (limited to 'guix/build/utils.scm')
| -rw-r--r-- | guix/build/utils.scm | 61 |
1 files changed, 37 insertions, 24 deletions
diff --git a/guix/build/utils.scm b/guix/build/utils.scm index 40af785b88..2f3dc9cad0 100644 --- a/guix/build/utils.scm +++ b/guix/build/utils.scm @@ -134,9 +134,12 @@ return values of applying PROC to the port." (define* (copy-recursively source destination #:key (log (current-output-port)) - (follow-symlinks? #f)) + (follow-symlinks? #f) + keep-mtime?) "Copy SOURCE directory to DESTINATION. Follow symlinks if FOLLOW-SYMLINKS? -is true; otherwise, just preserve them. Write verbose output to the LOG port." +is true; otherwise, just preserve them. When KEEP-MTIME? is true, keep the +modification time of the files in SOURCE on those of DESTINATION. Write +verbose output to the LOG port." (define strip-source (let ((len (string-length source))) (lambda (file) @@ -152,10 +155,15 @@ is true; otherwise, just preserve them. Write verbose output to the LOG port." (let ((target (readlink file))) (symlink target dest))) (else - (copy-file file dest))))) + (copy-file file dest) + (when keep-mtime? + (set-file-time dest stat)))))) (lambda (dir stat result) ; down - (mkdir-p (string-append destination - (strip-source dir)))) + (let ((target (string-append destination + (strip-source dir)))) + (mkdir-p target) + (when keep-mtime? + (set-file-time target stat)))) (lambda (dir stat result) ; up result) (const #t) ; skip @@ -170,25 +178,30 @@ is true; otherwise, just preserve them. Write verbose output to the LOG port." stat lstat))) -(define (delete-file-recursively dir) - "Delete DIR recursively, like `rm -rf', without following symlinks. Report -but ignore errors." - (file-system-fold (const #t) ; enter? - (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* (delete-file-recursively dir + #:key follow-mounts?) + "Delete DIR recursively, like `rm -rf', without following symlinks. Don't +follow mount points either, unless FOLLOW-MOUNTS? is true. Report but ignore +errors." + (let ((dev (stat:dev (lstat dir)))) + (file-system-fold (lambda (dir stat result) ; enter? + (or follow-mounts? + (= 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 (find-files dir regexp) "Return the lexicographically sorted list of files under DIR whose basename |