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

Contents of /meta-cvs/F-A67E77395E9CA68BCC0B867637B54576

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5