ViewVC logotype

Contents of /meta-cvs/F-A67E77395E9CA68BCC0B867637B54576

Parent Directory Parent Directory | Revision Log Revision Log

Revision 1.10 - (show annotations)
Sun Oct 6 07:05:46 2002 UTC (11 years, 6 months ago) by kaz
Branch: MAIN
CVS Tags: mcvs-1-0, mcvs-1-0-branch~merged-to-HEAD-1, mcvs-1-0-branch~merged-to-HEAD-0, mcvs-0-99, mcvs-0-98, mcvs-1-0-branch~branch-point, mcvs-0-97, mcvs-1-0-11, mcvs-1-0-10, mcvs-1-0-13, mcvs-1-0-12, mcvs-1-0-9, mcvs-1-0-8, mcvs-1-0-5, mcvs-1-0-4, mcvs-1-0-7, mcvs-1-0-6, mcvs-1-0-1, mcvs-1-0-2
Branch point for: mcvs-1-0-branch
Changes since 1.9: +2 -1 lines
* code/dirwalk.lisp (dirwalk): If the argument is not a directory,
the callback must still be invoked. This was done prior to
a 2002-05-20 commit. I can't quite remember why it was changed;
but I seem to recall thinking about the new dirwalk-skip catch,
and how it must be always visible to the callback closure, so
that the (skip) mechanism works.
1 ;;; This source file is part of the Meta-CVS program,
2 ;;; which is distributed under the GNU license.
3 ;;; Copyright 2002 Kaz Kylheku
5 (require "system")
6 (require "restart")
7 (provide "dirwalk")
9 ;; TODO: this sucks, it should put out canonicalized path names
10 (defun dirwalk-fi (dir-fi func &rest keys &key norecurse postorder)
11 (let ((dir-path (file-name dir-fi)))
12 (setf dir-path (cond
13 ((string-equal dir-path "")
14 #.(format nil "~a~a" *this-dir* *path-sep*))
15 ((eql (char dir-path (1- (length dir-path))) *path-sep*)
16 dir-path)
17 (t (format nil "~a~a" dir-path *path-sep*))))
18 (catch 'dirwalk-skip
19 (when (not postorder)
20 (funcall func dir-fi))
21 (with-open-dir (d dir-path)
22 (loop
23 (let ((name (readdir d)) entry-path fi)
24 (can-restart-here ("Continue processing directory ~a." dir-path)
25 (cond
26 ((null name) (return))
27 ((string-equal name *this-dir*) nil)
28 ((string-equal name *up-dir*) nil)
29 ((and (setf entry-path (format nil "~a~a" dir-path name))
30 (setf fi (stat entry-path))
31 nil))
32 ((and (not norecurse) (directory-p fi))
33 (apply #'dirwalk-fi fi func keys))
34 (t (funcall func fi)))))))
35 (when postorder
36 (funcall func dir-fi)))))
38 (defun dirwalk (dir-path func &rest keys &key norecurse postorder)
39 (declare (ignore norecurse postorder))
40 (let ((fi (stat dir-path)))
41 (if (directory-p fi)
42 (apply #'dirwalk-fi fi func keys)
43 (catch 'dirwalk-skip (funcall func fi)))))
45 (defun map-path (dir-path func)
46 (dirwalk dir-path #'(lambda (x) (funcall func (file-name x)))))
48 (defmacro for-each-path ((var dirpath) &body forms)
49 (let ((file-info (gensym "FILE-INFO-")))
50 `(dirwalk ,dirpath #'(lambda (,file-info)
51 (flet ((skip () (throw 'dirwalk-skip nil)))
52 (let ((,var (file-name ,file-info)))
53 ,@forms))))))
55 (defmacro for-each-file-info ((var dirpath &rest keys
56 &key norecurse postorder) &body forms)
57 (declare (ignore norecurse postorder))
58 `(dirwalk ,dirpath #'(lambda (,var)
59 (flet ((skip () (throw 'dirwalk-skip nil)))
60 ,@forms)) ,@keys))
62 (defun delete-recursive (dir-or-file)
63 (for-each-file-info (fi dir-or-file :postorder t)
64 (if (directory-p fi)
65 (rmdir (file-name fi))
66 (unlink (file-name fi)))))
68 (defun ensure-directories-gone (dir-or-file-to-erase)
69 "Intended as the inverse of Common Lisp's ensure-directories-exist, this
70 function erases the specified file. Then it tries to erase the parent
71 directory. If that succeeds, then it tries to erase the grandparent parent
72 directory and so on, until it encounters a directory that cannot be removed."
73 (if (directory-p dir-or-file-to-erase)
74 (rmdir dir-or-file-to-erase)
75 (unlink dir-or-file-to-erase))
77 (multiple-value-bind (base dir) (basename (canonicalize-path
78 dir-or-file-to-erase))
79 (declare (ignore base))
80 (handler-case
81 (loop
82 (rmdir dir)
83 (setf dir (canonicalize-path (path-cat dir *up-dir*))))
84 (error (x) (declare (ignore x)) (values)))))

  ViewVC Help
Powered by ViewVC 1.1.5