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

Contents of /meta-cvs/F-123D61C8FE941733281D2B08C15CD438

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.18.2.4 - (hide annotations)
Thu Jan 30 11:04:43 2003 UTC (11 years, 2 months ago) by kaz
Branch: mcvs-1-0-branch
CVS Tags: mcvs-1-0-5, mcvs-1-0-4, mcvs-1-0-1, mcvs-1-0-2
Changes since 1.18.2.3: +1 -1 lines
* code/posix.lisp: Move some (declaim inline) to the correct
location, before the function to be inlined.

* code/clisp-unix.lisp: Likewise.
* code/cmucl-unix.lisp: Likewise.
* code/mapping.lisp: Likewise.
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 kaz 1.18.2.2 (defvar *mcvs-editor* nil)
14 kaz 1.11
15 kaz 1.18.2.1 (defconstant *argument-limit* (* 64 1024))
16    
17 kaz 1.1 (defun canonicalize-path (path)
18     "Simplifies a POSIX path by eliminating . components, splicing out as many ..
19     components as possible, and condensing multiple slashes. A trailing slash is
20     guaranteed to be preserved, if it follows something that could be a file or
21     directory. Two values are returned, the simplified path and a boolean value
22     which is true if there are any .. components that could not be spliced out."
23     (let ((split-path (split-fields path "/"))
24     uncanceled-up)
25    
26     ;; First, if the path has at least two components,
27     ;; replace the first empty one with the symbol :root
28     ;; and the last empty one with :dir. These indicate a
29     ;; leading and trailing /
30     (when (and (> (length split-path) 1))
31     (when (string= (first split-path) "")
32     (setf (first split-path) :root))
33     (when (string= (first (last split-path)) "")
34     (setf (first (last split-path)) :dir)))
35    
36     ;; Next, squash out all of the . and empty components,
37     ;; and replace .. components with :up symbol.
38     (setf split-path (mapcan #'(lambda (item)
39     (cond
40     ((string= item "") nil)
41     ((string= item ".") nil)
42     ((string= item "..") (list :up))
43     (t (list item))))
44     split-path))
45     (let (folded-path)
46     ;; Now, we use a pushdown automaton to reduce the .. paths
47     ;; The remaining stack is the reversed path.
48     (dolist (item split-path)
49     (case item
50     ((:up)
51     (case (first folded-path)
52     ((:root)) ;; do nothing
53     ((:up nil) (push item folded-path) (setf uncanceled-up t))
54     (otherwise (pop folded-path))))
55     ((:dir)
56     (case (first folded-path)
57     ((:root :up nil))
58 kaz 1.15 (otherwise (push (concatenate 'string (pop folded-path) "/")
59 kaz 1.1 folded-path))))
60     (otherwise
61     (push item folded-path))))
62     (setf split-path (nreverse folded-path)))
63    
64     ;; If there are at least two components, remove a leading :root
65     ;; and add a / to the first component. If there are 0 components
66     ;; add a "." component.
67     (if (zerop (length split-path))
68     (push "." split-path)
69     (when (eq (first split-path) :root)
70     (pop split-path)
71 kaz 1.15 (push (concatenate 'string "/" (or (pop split-path) "")) split-path)))
72 kaz 1.1
73     ;; Map remaining symbols back to strings
74     (setf split-path (mapcar #'(lambda (item)
75     (case item
76     ((:up) "..")
77     (otherwise item))) split-path))
78    
79     ;; Convert back to text
80 kaz 1.15 (values (reduce #'(lambda (x y) (concatenate 'string x "/" y)) split-path)
81 kaz 1.1 uncanceled-up)))
82    
83     (defun basename (path)
84 kaz 1.7 "Splits the path into base name and directory, returned as two values.
85 kaz 1.1 If the path is / then . and / are returned. The rightmost slash is
86     used to determine the split between the path and the base name. If there
87 kaz 1.3 is a rightmost slash, then everything up to but not including that slash is
88 kaz 1.1 returned as the directory (second) value, and everything to the right is
89     returned as the base name (first) value. If there is no rightmost slash,
90     then the directory is returned as NIL, and the path is the entire base name.
91     If the path has a trailing slash, then that trailing slash is part of the base
92     name, and does not count as the rightmost slash."
93     (let* ((pos1 (position #\/ path :from-end t))
94     (pos2 (position #\/ path :end pos1 :from-end t)))
95     (cond
96     ((string= path "/")
97     (values "." "/"))
98     ((null pos1)
99     (values path nil))
100     ((= (1+ pos1) (length path))
101     (if (null pos2)
102     (values path nil)
103 kaz 1.3 (values (subseq path (1+ pos2)) (subseq path 0 pos2))))
104 kaz 1.1 (t
105 kaz 1.3 (values (subseq path (1+ pos1)) (subseq path 0 pos1))))))
106 kaz 1.1
107 kaz 1.10 (defun suffix (path &optional (separator-char #\.))
108     (let ((name (basename path)))
109     (let ((pos (position separator-char name)))
110     (cond
111     ((eql pos 0)
112     (values nil name))
113     (pos
114     (values (subseq name (1+ pos)) (subseq name 0 pos)))
115     (t (values nil name))))))
116 kaz 1.8
117 kaz 1.18.2.4 (declaim (inline path-equal))
118 kaz 1.1 (defun path-equal (p1 p2)
119     (string= p1 p2))
120    
121 kaz 1.2 (defun path-prefix-equal (shorter longer)
122     (let ((ls (length shorter)) (ll (length longer)))
123     (cond
124     ((> ls ll) nil)
125     ((not (string= shorter longer :end2 ls)) nil)
126     ((= ls ll) t)
127     ((and (> ls 0)
128     (char-equal (char shorter (1- ls)) #\/)
129     (char-equal (char longer (1- ls))) #\/) t)
130     ((char-equal (char longer ls) #\/) t)
131     (t nil))))
132 kaz 1.1
133 kaz 1.4 (eval-when (:compile-toplevel :load-toplevel :execute)
134     (defun path-cat (first-component &rest components)
135     (reduce #'(lambda (x y) (format nil "~a/~a" x y)) components
136     :initial-value first-component)))
137 kaz 1.7
138 kaz 1.13 (defun path-absolute-p (path)
139 kaz 1.18 (unless (zerop (length path))
140     (char= (char path 0) #\/)))
141 kaz 1.13
142 kaz 1.12 (defun parse-posix-namestring (path)
143 kaz 1.14 (let ((split-path (split-fields path "/")))
144     (let ((dir (butlast split-path))
145     (name (first (last split-path))))
146     (apply #'make-pathname
147     `(,@(when dir
148     `(:directory ,(if (string= "" (first dir))
149     `(:absolute ,@(rest dir))
150     `(:relative ,@dir))))
151     ,@(when name
152     `(:name ,name)))))))
153 kaz 1.12
154 kaz 1.7 (defun arglist-to-command-string (arglist)
155     "Convert list of strings, assumed to be an argument vector, into
156     a single command string that can be submitted to a POSIX command
157     interpreter. This requires escaping of all shell meta-characters."
158     (let ((command (make-array '(1024)
159     :element-type 'character
160     :adjustable t
161     :fill-pointer 0)))
162     (dolist (arg arglist command)
163     (dotimes (i (length arg))
164     (let ((ch (char arg i)))
165     (when (find ch #(#\' #\" #\* #\[ #\] #\?
166     #\$ #\{ #\} #\" #\space #\tab
167     #\( #\) #\< #\> #\| #\; #\&))
168     (vector-push-extend #\\ command))
169     (vector-push-extend ch command)))
170     (vector-push-extend #\space command))))
171    
172 kaz 1.8 (defun execute-program-xargs (fixed-args &optional extra-args fixed-trail-args)
173 kaz 1.7 (let* ((fixed-size (reduce #'(lambda (x y)
174     (+ x (length y) 1))
175 kaz 1.8 (append fixed-args fixed-trail-args)
176     :initial-value 0))
177 kaz 1.7 (size fixed-size))
178     (if extra-args
179     (let (chopped-arg)
180     (dolist (arg extra-args)
181     (push arg chopped-arg)
182     (when (> (incf size (1+ (length arg))) *argument-limit*)
183 kaz 1.9 (when (not (execute-program (append fixed-args
184     (nreverse chopped-arg)
185     fixed-trail-args)))
186     (return nil))
187 kaz 1.7 (setf chopped-arg nil)
188     (setf size fixed-size)))
189     (when chopped-arg
190 kaz 1.8 (execute-program (append fixed-args (nreverse chopped-arg)
191     fixed-trail-args))))
192 kaz 1.7 (execute-program fixed-args))))
193 kaz 1.10
194 kaz 1.16 (defun invoke-editor-on (name)
195 kaz 1.18.2.3 (let ((editor (or *mcvs-editor*
196     (env-lookup "CVSEDITOR")
197     (env-lookup "VISUAL")
198     (env-lookup "EDITOR" "vi"))))
199 kaz 1.10 (execute-program `(,editor ,name))))

  ViewVC Help
Powered by ViewVC 1.1.5