ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-11-17 04:07:10 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

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

Browse source 
* 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 @@ (define strip-source
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
(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))
;; Don't follow symlinks.
lstat)))
(define (find-files dir regexp)
"Return the lexicographically sorted list of files under DIR whose basename