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

Contents of /meta-cvs/F-A67E77395E9CA68BCC0B867637B54576

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.13 - (hide annotations)
Fri Nov 24 04:53:50 2006 UTC (7 years, 4 months ago) by kaz
Branch: MAIN
CVS Tags: asdf-import-branch~merged-to-HEAD-0, mcvs-1-1-98, asdf-import-branch~branch-point, HEAD
Branch point for: asdf-import-branch
Changes since 1.12: +1 -1 lines
Stylistic change.

* code/add.lisp: Change in-package calls not to use the all-caps
"META-CVS" string string, but rather the :meta-cvs keyword.
* code/branch.lisp: Likewise.
* code/chatter.lisp: Likewise.
* code/checkout.lisp: Likewise.
* code/clisp-unix.lisp: Likewise.
* code/cmucl-unix.lisp: Likewise.
* code/convert.lisp: Likewise.
* code/create.lisp: Likewise.
* code/dirwalk.lisp: Likewise.
* code/error.lisp: Likewise.
* code/execute.lisp: Likewise.
* code/filt.lisp: Likewise.
* code/find-bind.lisp: Likewise.
* code/generic.lisp: Likewise.
* code/grab.lisp: Likewise.
* code/link.lisp: Likewise.
* code/main.lisp: Likewise.
* code/mapping.lisp: Likewise.
* code/memoize.lisp: Likewise.
* code/move.lisp: Likewise.
* code/multi-hash.lisp: Likewise.
* code/options.lisp: Likewise.
* code/paths.lisp: Likewise.
* code/print.lisp: Likewise.
* code/prop.lisp: Likewise.
* code/purge.lisp: Likewise.
* code/rcs-utils.lisp: Likewise.
* code/remap.lisp: Likewise.
* code/remove.lisp: Likewise.
* code/restart.lisp: Likewise.
* code/restore.lisp: Likewise.
* code/seqfuncs.lisp: Likewise.
* code/slot-refs.lisp: Likewise.
* code/split.lisp: Likewise.
* code/sync.lisp: Likewise.
* code/types.lisp: Likewise.
* code/unix.lisp: Likewise.
* code/update.lisp: Likewise.
* code/watch.lisp: Likewise.
1 kaz 1.5 ;;; This source file is part of the Meta-CVS program,
2 kaz 1.3 ;;; which is distributed under the GNU license.
3     ;;; Copyright 2002 Kaz Kylheku
4    
5 kaz 1.13 (in-package :meta-cvs)
6 kaz 1.1
7 kaz 1.2 ;; TODO: this sucks, it should put out canonicalized path names
8 kaz 1.8 (defun dirwalk-fi (dir-fi func &rest keys &key norecurse postorder)
9 kaz 1.1 (let ((dir-path (file-name dir-fi)))
10     (setf dir-path (cond
11     ((string-equal dir-path "")
12     #.(format nil "~a~a" *this-dir* *path-sep*))
13     ((eql (char dir-path (1- (length dir-path))) *path-sep*)
14     dir-path)
15     (t (format nil "~a~a" dir-path *path-sep*))))
16 kaz 1.7 (catch 'dirwalk-skip
17     (when (not postorder)
18     (funcall func dir-fi))
19 kaz 1.1 (with-open-dir (d dir-path)
20     (loop
21     (let ((name (readdir d)) entry-path fi)
22     (can-restart-here ("Continue processing directory ~a." dir-path)
23     (cond
24     ((null name) (return))
25     ((string-equal name *this-dir*) nil)
26     ((string-equal name *up-dir*) nil)
27     ((and (setf entry-path (format nil "~a~a" dir-path name))
28     (setf fi (stat entry-path))
29     nil))
30     ((and (not norecurse) (directory-p fi))
31 kaz 1.8 (apply #'dirwalk-fi fi func keys))
32 kaz 1.1 (t (funcall func fi)))))))
33 kaz 1.7 (when postorder
34     (funcall func dir-fi)))))
35 kaz 1.1
36 kaz 1.7 (defun dirwalk (dir-path func &rest keys &key norecurse postorder)
37     (declare (ignore norecurse postorder))
38 kaz 1.1 (let ((fi (stat dir-path)))
39     (if (directory-p fi)
40 kaz 1.10 (apply #'dirwalk-fi fi func keys)
41     (catch 'dirwalk-skip (funcall func fi)))))
42 kaz 1.1
43     (defun map-path (dir-path func)
44     (dirwalk dir-path #'(lambda (x) (funcall func (file-name x)))))
45    
46     (defmacro for-each-path ((var dirpath) &body forms)
47     (let ((file-info (gensym "FILE-INFO-")))
48     `(dirwalk ,dirpath #'(lambda (,file-info)
49 kaz 1.7 (flet ((skip () (throw 'dirwalk-skip nil)))
50     (let ((,var (file-name ,file-info)))
51     ,@forms))))))
52 kaz 1.1
53 kaz 1.7 (defmacro for-each-file-info ((var dirpath &rest keys
54     &key norecurse postorder) &body forms)
55     (declare (ignore norecurse postorder))
56     `(dirwalk ,dirpath #'(lambda (,var)
57     (flet ((skip () (throw 'dirwalk-skip nil)))
58     ,@forms)) ,@keys))
59 kaz 1.1
60     (defun delete-recursive (dir-or-file)
61 kaz 1.7 (for-each-file-info (fi dir-or-file :postorder t)
62 kaz 1.1 (if (directory-p fi)
63     (rmdir (file-name fi))
64     (unlink (file-name fi)))))
65    
66     (defun ensure-directories-gone (dir-or-file-to-erase)
67     "Intended as the inverse of Common Lisp's ensure-directories-exist, this
68     function erases the specified file. Then it tries to erase the parent
69     directory. If that succeeds, then it tries to erase the grandparent parent
70     directory and so on, until it encounters a directory that cannot be removed."
71     (if (directory-p dir-or-file-to-erase)
72     (rmdir dir-or-file-to-erase)
73     (unlink dir-or-file-to-erase))
74    
75 kaz 1.6 (multiple-value-bind (base dir) (basename (canonicalize-path
76     dir-or-file-to-erase))
77 kaz 1.4 (declare (ignore base))
78 kaz 1.1 (handler-case
79     (loop
80     (rmdir dir)
81     (setf dir (canonicalize-path (path-cat dir *up-dir*))))
82     (error (x) (declare (ignore x)) (values)))))

  ViewVC Help
Powered by ViewVC 1.1.5