ViewVC logotype

Contents of /meta-cvs/F-A67E77395E9CA68BCC0B867637B54576

Parent Directory Parent Directory | Revision Log Revision Log

Revision 1.7 - (show annotations)
Mon May 20 17:49:12 2002 UTC (11 years, 11 months ago) by kaz
Branch: MAIN
CVS Tags: mcvs-0-14, mcvs-0-13
Changes since 1.6: +19 -12 lines
Adding mcvs remap command.

* dirwalk.lisp (dirwalk-fi, dirwalk, for-each-file-info): Default
behavior is now preorder (visit directory before its entries).
A keyword is provided to select the old postorder behavior.
A catch is provided in dirwalk-fi that allows the caller to
skip processing the currently traversed directory. The for-each-*
macros provide a local function called (skip) to do this.
(delete-recursive): This function depends on postorder behavior
in for-each-file-info, so it explicitly selects it now.

* mcvs.lisp (*remap-options*): New constant.
(*mcvs-command-table*): Add entry for new function.
(*usage*): Describes new function.

* remap.lisp: New file.
(mcvs-remap, mcvs-remap-wrapper): New functions.
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 &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 (dirwalk-fi fi func))
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))))
44 (defun map-path (dir-path func)
45 (dirwalk dir-path #'(lambda (x) (funcall func (file-name x)))))
47 (defmacro for-each-path ((var dirpath) &body forms)
48 (let ((file-info (gensym "FILE-INFO-")))
49 `(dirwalk ,dirpath #'(lambda (,file-info)
50 (flet ((skip () (throw 'dirwalk-skip nil)))
51 (let ((,var (file-name ,file-info)))
52 ,@forms))))))
54 (defmacro for-each-file-info ((var dirpath &rest keys
55 &key norecurse postorder) &body forms)
56 (declare (ignore norecurse postorder))
57 `(dirwalk ,dirpath #'(lambda (,var)
58 (flet ((skip () (throw 'dirwalk-skip nil)))
59 ,@forms)) ,@keys))
61 (defun delete-recursive (dir-or-file)
62 (for-each-file-info (fi dir-or-file :postorder t)
63 (if (directory-p fi)
64 (rmdir (file-name fi))
65 (unlink (file-name fi)))))
67 (defun go-up ()
68 "Change current working directory one level up. If this cannot be done,
69 because the current working directory is root, returns nil. Otherwise
70 returns the name of the directory we just came from, relative to the
71 new parent, so that a chdir to this name will return to the original
72 directory"
73 (let ((dir-fi (stat *this-dir*)))
74 (when (is-root-p dir-fi)
75 (return-from go-up (values nil)))
76 (chdir *up-dir*)
77 (for-each-file-info (child *this-dir* :norecurse t)
78 (when (same-file-p child dir-fi)
79 (return-from go-up (values (basename (file-name child))))))
80 nil))
82 (defun ensure-directories-gone (dir-or-file-to-erase)
83 "Intended as the inverse of Common Lisp's ensure-directories-exist, this
84 function erases the specified file. Then it tries to erase the parent
85 directory. If that succeeds, then it tries to erase the grandparent parent
86 directory and so on, until it encounters a directory that cannot be removed."
87 (if (directory-p dir-or-file-to-erase)
88 (rmdir dir-or-file-to-erase)
89 (unlink dir-or-file-to-erase))
91 (multiple-value-bind (base dir) (basename (canonicalize-path
92 dir-or-file-to-erase))
93 (declare (ignore base))
94 (handler-case
95 (loop
96 (rmdir dir)
97 (setf dir (canonicalize-path (path-cat dir *up-dir*))))
98 (error (x) (declare (ignore x)) (values)))))

  ViewVC Help
Powered by ViewVC 1.1.5