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

Contents of /meta-cvs/F-A67E77395E9CA68BCC0B867637B54576

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.6 - (show annotations)
Sun Feb 3 18:12:10 2002 UTC (12 years, 2 months ago) by kaz
Branch: MAIN
CVS Tags: mcvs-0-6, mcvs-0-9, mcvs-0-5, mcvs-0-4, mcvs-0-7, mcvs-0-8, mcvs-0-11, mcvs-0-10, mcvs-0-12, latest-patch, deferred-adds-branch~branch-point
Branch point for: deferred-adds-branch
Changes since 1.5: +2 -1 lines
Added workaround for operating system argument passing limitations,
resembling the Unix xargs utility. Also, trimmed some fat
from the basename function.

* clisp-linux.lisp: (*argument-limit*): New constant added.
(arglist-to-command-string): Function removed.
(execute-program): Function removed.
(shell-interpreter): New function, wrapper for CLISP's shell
function, turns exit status into T (success) or NIL (failure).

* diff.lisp (mcvs-diff): Uses execute-program-xargs instead
of execute-program.

* posix.lisp (basename): Does not canonicalize path name. This
turns out to be an unnecessary performance hit in some cases.
(arglist-to-command-string): New function. Similar to what was
removed from clisp-linux, but this one properly escapes all
shell metacharacters.
(execute-program): New function, calls shell-interpreter.
(execute-program-xargs): New function. Takes two argument lists.
Forms one or more command lines by combining the first argument list
with one or more pieces of the second argument list, and
executes each command. The length of the pieces is determined
by the argument passing limit.

* dirwalk.lisp (ensure-directories-gone): Add use of
canonicalize-path because basename doesn't do it.
1 ;;; This source file is part of the Meta-CVS program,
2 ;;; which is distributed under the GNU license.
3 ;;; Copyright 2002 Kaz Kylheku
4
5 (require "system")
6 (require "restart")
7 (provide "dirwalk")
8
9 ;; TODO: this sucks, it should put out canonicalized path names
10 (defun dirwalk-fi (dir-fi func &key norecurse)
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 (unwind-protect
19 (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 (dirwalk-fi fi func))
32 (t (funcall func fi)))))))
33 (funcall func dir-fi))))
34
35 (defun dirwalk (dir-path func &rest keys &key norecurse)
36 (declare (ignore norecurse))
37 (let ((fi (stat dir-path)))
38 (if (directory-p fi)
39 (apply #'dirwalk-fi fi func keys)
40 (funcall func fi))))
41
42 (defun map-path (dir-path func)
43 (dirwalk dir-path #'(lambda (x) (funcall func (file-name x)))))
44
45 (defmacro for-each-path ((var dirpath) &body forms)
46 (let ((file-info (gensym "FILE-INFO-")))
47 `(dirwalk ,dirpath #'(lambda (,file-info)
48 (let ((,var (file-name ,file-info))) ,@forms)))))
49
50 (defmacro for-each-file-info ((var dirpath &rest keys &key norecurse) &body forms)
51 (declare (ignore norecurse))
52 `(dirwalk ,dirpath #'(lambda (,var) ,@forms) ,@keys))
53
54 (defun delete-recursive (dir-or-file)
55 (for-each-file-info (fi dir-or-file)
56 (if (directory-p fi)
57 (rmdir (file-name fi))
58 (unlink (file-name fi)))))
59
60 (defun go-up ()
61 "Change current working directory one level up. If this cannot be done,
62 because the current working directory is root, returns nil. Otherwise
63 returns the name of the directory we just came from, relative to the
64 new parent, so that a chdir to this name will return to the original
65 directory"
66 (let ((dir-fi (stat *this-dir*)))
67 (when (is-root-p dir-fi)
68 (return-from go-up (values nil)))
69 (chdir *up-dir*)
70 (for-each-file-info (child *this-dir* :norecurse t)
71 (when (same-file-p child dir-fi)
72 (return-from go-up (values (basename (file-name child))))))
73 nil))
74
75 (defun ensure-directories-gone (dir-or-file-to-erase)
76 "Intended as the inverse of Common Lisp's ensure-directories-exist, this
77 function erases the specified file. Then it tries to erase the parent
78 directory. If that succeeds, then it tries to erase the grandparent parent
79 directory and so on, until it encounters a directory that cannot be removed."
80 (if (directory-p dir-or-file-to-erase)
81 (rmdir dir-or-file-to-erase)
82 (unlink dir-or-file-to-erase))
83
84 (multiple-value-bind (base dir) (basename (canonicalize-path
85 dir-or-file-to-erase))
86 (declare (ignore base))
87 (handler-case
88 (loop
89 (rmdir dir)
90 (setf dir (canonicalize-path (path-cat dir *up-dir*))))
91 (error (x) (declare (ignore x)) (values)))))

  ViewVC Help
Powered by ViewVC 1.1.5