/[meta-cvs]/meta-cvs/F-A67E77395E9CA68BCC0B867637B54576
ViewVC logotype

Contents of /meta-cvs/F-A67E77395E9CA68BCC0B867637B54576

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.2 - (hide annotations)
Fri Jan 25 03:53:24 2002 UTC (12 years, 2 months ago) by kaz
Branch: MAIN
Changes since 1.1: +1 -0 lines
mcvs-add: do not allow addition of files that are in MCVS area.
1 kaz 1.1 (require "system")
2     (require "restart")
3     (provide "dirwalk")
4    
5 kaz 1.2 ;; TODO: this sucks, it should put out canonicalized path names
6 kaz 1.1 (defun dirwalk-fi (dir-fi func &key norecurse)
7     (let ((dir-path (file-name dir-fi)))
8     (setf dir-path (cond
9     ((string-equal dir-path "")
10     #.(format nil "~a~a" *this-dir* *path-sep*))
11     ((eql (char dir-path (1- (length dir-path))) *path-sep*)
12     dir-path)
13     (t (format nil "~a~a" dir-path *path-sep*))))
14     (unwind-protect
15     (with-open-dir (d dir-path)
16     (loop
17     (let ((name (readdir d)) entry-path fi)
18     (can-restart-here ("Continue processing directory ~a." dir-path)
19     (cond
20     ((null name) (return))
21     ((string-equal name *this-dir*) nil)
22     ((string-equal name *up-dir*) nil)
23     ((and (setf entry-path (format nil "~a~a" dir-path name))
24     (setf fi (stat entry-path))
25     nil))
26     ((and (not norecurse) (directory-p fi))
27     (dirwalk-fi fi func))
28     (t (funcall func fi)))))))
29     (funcall func dir-fi))))
30    
31     (defun dirwalk (dir-path func &rest keys &key norecurse)
32     (let ((fi (stat dir-path)))
33     (if (directory-p fi)
34     (apply #'dirwalk-fi fi func keys)
35     (funcall func fi))))
36    
37     (defun map-path (dir-path func)
38     (dirwalk dir-path #'(lambda (x) (funcall func (file-name x)))))
39    
40     (defmacro for-each-path ((var dirpath) &body forms)
41     (let ((file-info (gensym "FILE-INFO-")))
42     `(dirwalk ,dirpath #'(lambda (,file-info)
43     (let ((,var (file-name ,file-info))) ,@forms)))))
44    
45     (defmacro for-each-file-info ((var dirpath &rest keys &key norecurse) &body forms)
46     (let ((condition (gensym "CONDITION-")))
47     `(dirwalk ,dirpath #'(lambda (,var) ,@forms) ,@keys)))
48    
49     (defun delete-recursive (dir-or-file)
50     (for-each-file-info (fi dir-or-file)
51     (if (directory-p fi)
52     (rmdir (file-name fi))
53     (unlink (file-name fi)))))
54    
55     (defun go-up ()
56     "Change current working directory one level up. If this cannot be done,
57     because the current working directory is root, returns nil. Otherwise
58     returns the name of the directory we just came from, relative to the
59     new parent, so that a chdir to this name will return to the original
60     directory"
61     (let ((dir-fi (stat *this-dir*)))
62     (when (is-root-p dir-fi)
63     (return-from go-up (values nil)))
64     (chdir *up-dir*)
65     (for-each-file-info (child *this-dir* :norecurse t)
66     (when (same-file-p child dir-fi)
67     (return-from go-up (values (basename (file-name child))))))
68     nil))
69    
70     (defun ensure-directories-gone (dir-or-file-to-erase)
71     "Intended as the inverse of Common Lisp's ensure-directories-exist, this
72     function erases the specified file. Then it tries to erase the parent
73     directory. If that succeeds, then it tries to erase the grandparent parent
74     directory and so on, until it encounters a directory that cannot be removed."
75     (if (directory-p dir-or-file-to-erase)
76     (rmdir dir-or-file-to-erase)
77     (unlink dir-or-file-to-erase))
78    
79     (multiple-value-bind (base dir) (basename dir-or-file-to-erase)
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