/[meta-cvs]/meta-cvs/F-123D61C8FE941733281D2B08C15CD438
ViewVC logotype

Contents of /meta-cvs/F-123D61C8FE941733281D2B08C15CD438

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.7 - (hide annotations)
Sun Feb 3 18:12:10 2002 UTC (12 years, 2 months ago) by kaz
Branch: MAIN
CVS Tags: mcvs-0-4, latest-patch
Changes since 1.6: +43 -3 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 kaz 1.6 ;;; This source file is part of the Meta-CVS program,
2 kaz 1.5 ;;; which is distributed under the GNU license.
3     ;;; Copyright 2002 Kaz Kylheku
4    
5 kaz 1.1 (require "split")
6     (provide "posix")
7    
8 kaz 1.4 (eval-when (:compile-toplevel :load-toplevel :execute)
9     (defconstant *up-dir* "..")
10     (defconstant *this-dir* ".")
11     (defconstant *path-sep* "/"))
12 kaz 1.1
13     (defun canonicalize-path (path)
14     "Simplifies a POSIX path by eliminating . components, splicing out as many ..
15     components as possible, and condensing multiple slashes. A trailing slash is
16     guaranteed to be preserved, if it follows something that could be a file or
17     directory. Two values are returned, the simplified path and a boolean value
18     which is true if there are any .. components that could not be spliced out."
19     (let ((split-path (split-fields path "/"))
20     uncanceled-up)
21    
22     ;; First, if the path has at least two components,
23     ;; replace the first empty one with the symbol :root
24     ;; and the last empty one with :dir. These indicate a
25     ;; leading and trailing /
26     (when (and (> (length split-path) 1))
27     (when (string= (first split-path) "")
28     (setf (first split-path) :root))
29     (when (string= (first (last split-path)) "")
30     (setf (first (last split-path)) :dir)))
31    
32     ;; Next, squash out all of the . and empty components,
33     ;; and replace .. components with :up symbol.
34     (setf split-path (mapcan #'(lambda (item)
35     (cond
36     ((string= item "") nil)
37     ((string= item ".") nil)
38     ((string= item "..") (list :up))
39     (t (list item))))
40     split-path))
41     (let (folded-path)
42     ;; Now, we use a pushdown automaton to reduce the .. paths
43     ;; The remaining stack is the reversed path.
44     (dolist (item split-path)
45     (case item
46     ((:up)
47     (case (first folded-path)
48     ((:root)) ;; do nothing
49     ((:up nil) (push item folded-path) (setf uncanceled-up t))
50     (otherwise (pop folded-path))))
51     ((:dir)
52     (case (first folded-path)
53     ((:root :up nil))
54     (otherwise (push (format nil "~a/" (pop folded-path))
55     folded-path))))
56     (otherwise
57     (push item folded-path))))
58     (setf split-path (nreverse folded-path)))
59    
60     ;; If there are at least two components, remove a leading :root
61     ;; and add a / to the first component. If there are 0 components
62     ;; add a "." component.
63     (if (zerop (length split-path))
64     (push "." split-path)
65     (when (eq (first split-path) :root)
66     (pop split-path)
67     (push (format nil "/~a" (or (pop split-path) "")) split-path)))
68    
69     ;; Map remaining symbols back to strings
70     (setf split-path (mapcar #'(lambda (item)
71     (case item
72     ((:up) "..")
73     (otherwise item))) split-path))
74    
75     ;; Convert back to text
76     (values (reduce #'(lambda (x y) (format nil "~a/~a" x y)) split-path)
77     uncanceled-up)))
78    
79     (defun basename (path)
80 kaz 1.7 "Splits the path into base name and directory, returned as two values.
81 kaz 1.1 If the path is / then . and / are returned. The rightmost slash is
82     used to determine the split between the path and the base name. If there
83 kaz 1.3 is a rightmost slash, then everything up to but not including that slash is
84 kaz 1.1 returned as the directory (second) value, and everything to the right is
85     returned as the base name (first) value. If there is no rightmost slash,
86     then the directory is returned as NIL, and the path is the entire base name.
87     If the path has a trailing slash, then that trailing slash is part of the base
88     name, and does not count as the rightmost slash."
89     (let* ((pos1 (position #\/ path :from-end t))
90     (pos2 (position #\/ path :end pos1 :from-end t)))
91     (cond
92     ((string= path "/")
93     (values "." "/"))
94     ((null pos1)
95     (values path nil))
96     ((= (1+ pos1) (length path))
97     (if (null pos2)
98     (values path nil)
99 kaz 1.3 (values (subseq path (1+ pos2)) (subseq path 0 pos2))))
100 kaz 1.1 (t
101 kaz 1.3 (values (subseq path (1+ pos1)) (subseq path 0 pos1))))))
102 kaz 1.1
103     (defun path-equal (p1 p2)
104     (string= p1 p2))
105 kaz 1.2 (declaim (inline path-equal))
106 kaz 1.1
107 kaz 1.2 (defun path-prefix-equal (shorter longer)
108     (let ((ls (length shorter)) (ll (length longer)))
109     (cond
110     ((> ls ll) nil)
111     ((not (string= shorter longer :end2 ls)) nil)
112     ((= ls ll) t)
113     ((and (> ls 0)
114     (char-equal (char shorter (1- ls)) #\/)
115     (char-equal (char longer (1- ls))) #\/) t)
116     ((char-equal (char longer ls) #\/) t)
117     (t nil))))
118 kaz 1.1
119 kaz 1.4 (eval-when (:compile-toplevel :load-toplevel :execute)
120     (defun path-cat (first-component &rest components)
121     (reduce #'(lambda (x y) (format nil "~a/~a" x y)) components
122     :initial-value first-component)))
123 kaz 1.7
124     (defun arglist-to-command-string (arglist)
125     "Convert list of strings, assumed to be an argument vector, into
126     a single command string that can be submitted to a POSIX command
127     interpreter. This requires escaping of all shell meta-characters."
128     (let ((command (make-array '(1024)
129     :element-type 'character
130     :adjustable t
131     :fill-pointer 0)))
132     (dolist (arg arglist command)
133     (dotimes (i (length arg))
134     (let ((ch (char arg i)))
135     (when (find ch #(#\' #\" #\* #\[ #\] #\?
136     #\$ #\{ #\} #\" #\space #\tab
137     #\( #\) #\< #\> #\| #\; #\&))
138     (vector-push-extend #\\ command))
139     (vector-push-extend ch command)))
140     (vector-push-extend #\space command))))
141    
142     (defun execute-program (&rest arg-list)
143     (let ((command (if (consp (first arg-list))
144     (arglist-to-command-string (first arg-list))
145     (arglist-to-command-string arg-list))))
146     (shell-interpreter command)))
147    
148     (defun execute-program-xargs (fixed-args &optional extra-args)
149     (let* ((fixed-size (reduce #'(lambda (x y)
150     (+ x (length y) 1))
151     fixed-args
152     :initial-value 0))
153     (size fixed-size))
154     (if extra-args
155     (let (chopped-arg)
156     (dolist (arg extra-args)
157     (push arg chopped-arg)
158     (when (> (incf size (1+ (length arg))) *argument-limit*)
159     (execute-program (append fixed-args (nreverse chopped-arg)))
160     (setf chopped-arg nil)
161     (setf size fixed-size)))
162     (when chopped-arg
163     (execute-program (append fixed-args (nreverse chopped-arg)))))
164     (execute-program fixed-args))))

  ViewVC Help
Powered by ViewVC 1.1.5