1 ;;;; pathname parsing for Unix filesystems
3 ;;;; This software is part of the SBCL system. See the README file for
6 ;;;; This software is derived from the CMU CL system, which was
7 ;;;; written at Carnegie Mellon University and released into the
8 ;;;; public domain. The software is in the public domain and is
9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
10 ;;;; files for more information.
12 (in-package "SB!IMPL")
14 (def!struct (unix-host
15 (:make-load-form-fun make-host-load-form)
17 (parse #'parse-unix-namestring)
18 (parse-native #'parse-native-unix-namestring)
19 (unparse #'unparse-unix-namestring)
20 (unparse-native #'unparse-native-unix-namestring)
21 (unparse-host #'unparse-unix-host)
22 (unparse-directory #'unparse-physical-directory)
23 (unparse-file #'unparse-unix-file)
24 (unparse-enough #'unparse-unix-enough)
25 (unparse-directory-separator "/")
26 (simplify-namestring #'simplify-unix-namestring)
27 (customary-case :lower))))
29 (defvar *physical-host* (make-unix-host))
31 ;;; Take a string and return a list of cons cells that mark the char
32 ;;; separated subseq. The first value is true if absolute directories
34 (defun split-at-slashes (namestr start end)
35 (declare (type simple-string namestr)
36 (type index start end))
37 (let ((absolute (and (/= start end)
38 (char= (schar namestr start) #\/))))
41 ;; Next, split the remainder into slash-separated chunks.
44 (let ((slash (position #\/ namestr :start start :end end)))
45 (pieces (cons start (or slash end)))
48 (setf start (1+ slash))))
49 (values absolute (pieces)))))
51 (defun parse-unix-namestring (namestring start end)
52 (declare (type simple-string namestring)
53 (type index start end))
54 (setf namestring (coerce namestring 'simple-string))
55 (multiple-value-bind (absolute pieces)
56 (split-at-slashes namestring start end)
57 (multiple-value-bind (name type version)
58 (let* ((tail (car (last pieces)))
59 (tail-start (car tail))
60 (tail-end (cdr tail)))
61 (unless (= tail-start tail-end)
62 (setf pieces (butlast pieces))
63 (extract-name-type-and-version namestring tail-start tail-end)))
66 (let ((position (position-if (lambda (char)
67 (or (char= char (code-char 0))
71 (error 'namestring-parse-error
72 :complaint "can't embed #\\Nul or #\\/ in Unix namestring"
73 :namestring namestring
77 ;; Deal with ~ and ~user
79 (destructuring-bind (start . end) (car pieces)
80 (when (and (not absolute)
82 (string= namestring "~"
86 (if (> end (1+ start))
87 (setf home (list :home (subseq namestring (1+ start) end)))
91 ;; Now we have everything we want. So return it.
92 (values nil ; no host for Unix namestrings
93 nil ; no device for Unix namestrings
95 (dolist (piece pieces)
96 (let ((piece-start (car piece))
97 (piece-end (cdr piece)))
98 (unless (= piece-start piece-end)
99 (cond ((string= namestring ".."
103 ((string= namestring "**"
106 (dirs :wild-inferiors))
108 (dirs (maybe-make-pattern namestring
113 (list* :absolute home (dirs))
114 (cons :absolute (dirs))))
116 (cons :relative (dirs)))
123 (defun parse-native-unix-namestring (namestring start end as-directory)
124 (declare (type simple-string namestring)
125 (type index start end))
126 (setf namestring (coerce namestring 'simple-string))
127 (multiple-value-bind (absolute ranges)
128 (split-at-slashes namestring start end)
129 (let* ((components (loop for ((start . end) . rest) on ranges
130 for piece = (subseq namestring start end)
131 collect (if (and (string= piece "..") rest)
134 (directory (if (and as-directory
135 (string/= "" (car (last components))))
137 (butlast components)))
140 (let* ((end (first (last components)))
141 (dot (position #\. end :from-end t)))
142 ;; FIXME: can we get this dot-interpretation knowledge
143 ;; from existing code? EXTRACT-NAME-TYPE-AND-VERSION
144 ;; does slightly more work than that.
149 (list (subseq end 0 dot) (subseq end (1+ dot))))
154 (cons (if absolute :absolute :relative) directory)
155 (first name-and-type)
156 (second name-and-type)
159 (/show0 "filesys.lisp 300")
161 (defun unparse-unix-host (pathname)
162 (declare (type pathname pathname)
164 ;; this host designator needs to be recognized as a physical host in
165 ;; PARSE-NAMESTRING. Until sbcl-0.7.3.x, we had "Unix" here, but
166 ;; that's a valid Logical Hostname, so that's a bad choice. -- CSR,
170 (defun unparse-unix-file (pathname)
171 (declare (type pathname pathname))
173 (let* ((name (%pathname-name pathname))
174 (type (%pathname-type pathname))
175 (type-supplied (not (or (null type) (eq type :unspecific)))))
176 ;; Note: by ANSI 19.3.1.1.5, we ignore the version slot when
177 ;; translating logical pathnames to a filesystem without
178 ;; versions (like Unix).
180 (when (and (null type)
183 (position #\. name :start 1))
184 (error "too many dots in the name: ~S" pathname))
185 (when (and (typep name 'string)
187 (error "name is of length 0: ~S" pathname))
188 (strings (unparse-physical-piece name)))
191 (error "cannot specify the type without a file: ~S" pathname))
192 (when (typep type 'simple-string)
193 (when (position #\. type)
194 (error "type component can't have a #\. inside: ~S" pathname)))
196 (strings (unparse-physical-piece type))))
197 (apply #'concatenate 'simple-string (strings))))
199 (/show0 "filesys.lisp 406")
201 (defun unparse-unix-namestring (pathname)
202 (declare (type pathname pathname))
203 (concatenate 'simple-string
204 (unparse-physical-directory pathname)
205 (unparse-unix-file pathname)))
207 (defun unparse-native-unix-namestring (pathname as-file)
208 (declare (type pathname pathname))
209 (let* ((directory (pathname-directory pathname))
210 (name (pathname-name pathname))
211 (name-present-p (typep name '(not (member nil :unspecific))))
212 (name-string (if name-present-p name ""))
213 (type (pathname-type pathname))
214 (type-present-p (typep type '(not (member nil :unspecific))))
215 (type-string (if type-present-p type "")))
219 (with-output-to-string (s)
221 (ecase (pop directory)
223 (let ((next (pop directory)))
224 (cond ((eq :home next)
225 (write-string (user-homedir-namestring) s))
226 ((and (consp next) (eq :home (car next)))
227 (let ((where (user-homedir-namestring (second next))))
229 (write-string where s)
230 (error "User homedir unknown for: ~S" (second next)))))
232 (push next directory)))
235 (loop for (piece . subdirs) on directory
238 (write-string ".." s))
240 (write-string piece s))
242 (error "ungood directory segment in NATIVE-NAMESTRING: ~S"
244 if (or subdirs (stringp name))
245 do (write-char #\/ s)
251 (unless (stringp name-string) ;some kind of wild field
252 (error "ungood name component in NATIVE-NAMESTRING: ~S" name))
253 (write-string name-string s)
255 (unless (stringp type-string) ;some kind of wild field
256 (error "ungood type component in NATIVE-NAMESTRING: ~S" type))
258 (write-string type-string s)))
259 (when type-present-p ; type without a name
261 "type component without a name component in NATIVE-NAMESTRING: ~S"
265 (defun unparse-unix-enough (pathname defaults)
266 (declare (type pathname pathname defaults))
268 (error "~S cannot be represented relative to ~S."
271 (let* ((pathname-directory (%pathname-directory pathname))
272 (defaults-directory (%pathname-directory defaults))
273 (prefix-len (length defaults-directory))
275 (cond ((null pathname-directory) '(:relative))
276 ((eq (car pathname-directory) :relative)
278 ((and (> prefix-len 0)
279 (>= (length pathname-directory) prefix-len)
280 (compare-component (subseq pathname-directory
283 ;; Pathname starts with a prefix of default. So
284 ;; just use a relative directory from then on out.
285 (cons :relative (nthcdr prefix-len pathname-directory)))
286 ((eq (car pathname-directory) :absolute)
287 ;; We are an absolute pathname, so we can just use it.
290 (bug "Bad fallthrough in ~S" 'unparse-unix-enough)))))
291 (strings (unparse-physical-directory-list result-directory)))
292 (let* ((pathname-type (%pathname-type pathname))
293 (type-needed (and pathname-type
294 (not (eq pathname-type :unspecific))))
295 (pathname-name (%pathname-name pathname))
296 (name-needed (or type-needed
298 (not (compare-component pathname-name
302 (unless pathname-name (lose))
303 (when (and (null pathname-type)
304 (typep pathname-name 'simple-string)
305 (position #\. pathname-name :start 1))
306 (error "too many dots in the name: ~S" pathname))
307 (strings (unparse-physical-piece pathname-name)))
309 (when (or (null pathname-type) (eq pathname-type :unspecific))
311 (when (typep pathname-type 'simple-string)
312 (when (position #\. pathname-type)
313 (error "type component can't have a #\. inside: ~S" pathname)))
315 (strings (unparse-physical-piece pathname-type))))
316 (apply #'concatenate 'simple-string (strings)))))
318 (defun simplify-unix-namestring (src)
319 (declare (type simple-string src))
320 (let* ((src-len (length src))
321 (dst (make-string src-len :element-type 'character))
325 (macrolet ((deposit (char)
327 (setf (schar dst dst-len) ,char)
329 (dotimes (src-index src-len)
330 (let ((char (schar src src-index)))
331 (cond ((char= char #\.)
338 ;; either ``/...' or ``...//...'
340 (setf last-slash dst-len)
343 ;; either ``./...'' or ``..././...''
348 ((and last-slash (not (zerop last-slash)))
349 ;; There is something before this ..
350 (let ((prev-prev-slash
351 (position #\/ dst :end last-slash :from-end t)))
352 (cond ((and (= (+ (or prev-prev-slash 0) 2)
354 (char= (schar dst (- last-slash 2)) #\.)
355 (char= (schar dst (1- last-slash)) #\.))
356 ;; The something before this .. is another ..
358 (setf last-slash dst-len))
360 ;; The something is some directory or other.
365 (setf last-slash prev-prev-slash)))))
367 ;; There is nothing before this .., so we need to keep it
368 (setf last-slash dst-len)
371 ;; something other than a dot between slashes
372 (setf last-slash dst-len)
377 (setf (schar dst dst-len) char)
379 (when (and last-slash (not (zerop last-slash)))
382 ;; We've got ``foobar/.''
385 ;; We've got ``foobar/..''
386 (unless (and (>= last-slash 2)
387 (char= (schar dst (1- last-slash)) #\.)
388 (char= (schar dst (- last-slash 2)) #\.)
390 (char= (schar dst (- last-slash 3)) #\/)))
391 (let ((prev-prev-slash
392 (position #\/ dst :end last-slash :from-end t)))
394 (setf dst-len (1+ prev-prev-slash))
395 (return-from simplify-unix-namestring
396 (coerce "./" 'simple-string))))))))
397 (cond ((zerop dst-len)
402 (subseq dst 0 dst-len)))))