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

Contents of /meta-cvs/F-123D61C8FE941733281D2B08C15CD438

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.13 - (show annotations)
Fri Apr 5 02:25:35 2002 UTC (12 years ago) by kaz
Branch: MAIN
CVS Tags: mcvs-0-14, mcvs-0-11, mcvs-0-13, mcvs-0-12
Changes since 1.12: +3 -0 lines
Absolute paths resolved against sandbox root.

* posix.lisp (path-absolute-p): New function. Predicate to
test whether a path is absolute.

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

  ViewVC Help
Powered by ViewVC 1.1.5