nixo
/
guix-devel
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

utils: 'delete-file-recursively' doesn't follow mount points by default. 

* guix/build/utils.scm (delete-file-recursively): Add #:follow-mounts?
  parameter and honor it.
This commit is contained in:
Ludovic Courtès 2014-05-20 14:45:58 +02:00
parent 953c9fcf8c
commit d84a7be667
1 changed files with 23 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

41
guix/build/utils.scm
View File

@ -178,25 +178,30 @@ verbose output to the LOG port."
stat stat
lstat))) lstat)))
(define (delete-file-recursively dir) (define* (delete-file-recursively dir
"Delete DIR recursively, like `rm -rf', without following symlinks. Report #:key follow-mounts?)
but ignore errors." "Delete DIR recursively, like `rm -rf', without following symlinks. Don't
(file-system-fold (const #t) ; enter? follow mount points either, unless FOLLOW-MOUNTS? is true. Report but ignore
(lambda (file stat result) ; leaf errors."
(delete-file file)) (let ((dev (stat:dev (lstat dir))))
(const #t) ; down (file-system-fold (lambda (dir stat result) ; enter?
(lambda (dir stat result) ; up (or follow-mounts?
(rmdir dir)) (= dev (stat:dev stat))))
(const #t) ; skip (lambda (file stat result) ; leaf
(lambda (file stat errno result) (delete-file file))
(format (current-error-port) (const #t) ; down
"warning: failed to delete ~a: ~a~%" (lambda (dir stat result) ; up
file (strerror errno))) (rmdir dir))
#t (const #t) ; skip
dir (lambda (file stat errno result)
(format (current-error-port)
"warning: failed to delete ~a: ~a~%"
file (strerror errno)))
#t
dir
;; Don't follow symlinks. ;; Don't follow symlinks.
lstat)) lstat)))
(define (find-files dir regexp) (define (find-files dir regexp)
"Return the lexicographically sorted list of files under DIR whose basename "Return the lexicographically sorted list of files under DIR whose basename