0.9.12.3:
[sbcl.git] / src / code / unix-pathname.lisp
1 ;;;; pathname parsing for Unix filesystems
2
3 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; more information.
5 ;;;;
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.
11
12 (in-package "SB!IMPL")
13
14 ;;; Take a string and return a list of cons cells that mark the char
15 ;;; separated subseq. The first value is true if absolute directories
16 ;;; location.
17 (defun split-at-slashes (namestr start end)
18   (declare (type simple-base-string namestr)
19            (type index start end))
20   (let ((absolute (and (/= start end)
21                        (char= (schar namestr start) #\/))))
22     (when absolute
23       (incf start))
24     ;; Next, split the remainder into slash-separated chunks.
25     (collect ((pieces))
26       (loop
27         (let ((slash (position #\/ namestr :start start :end end)))
28           (pieces (cons start (or slash end)))
29           (unless slash
30             (return))
31           (setf start (1+ slash))))
32       (values absolute (pieces)))))
33
34 (defun parse-unix-namestring (namestring start end)
35   (declare (type simple-string namestring)
36            (type index start end))
37   (setf namestring (coerce namestring 'simple-base-string))
38   (multiple-value-bind (absolute pieces)
39       (split-at-slashes namestring start end)
40     (multiple-value-bind (name type version)
41         (let* ((tail (car (last pieces)))
42                (tail-start (car tail))
43                (tail-end (cdr tail)))
44           (unless (= tail-start tail-end)
45             (setf pieces (butlast pieces))
46             (extract-name-type-and-version namestring tail-start tail-end)))
47
48       (when (stringp name)
49         (let ((position (position-if (lambda (char)
50                                        (or (char= char (code-char 0))
51                                            (char= char #\/)))
52                                      name)))
53           (when position
54             (error 'namestring-parse-error
55                    :complaint "can't embed #\\Nul or #\\/ in Unix namestring"
56                    :namestring namestring
57                    :offset position))))
58       ;; Now we have everything we want. So return it.
59       (values nil ; no host for Unix namestrings
60               nil ; no device for Unix namestrings
61               (collect ((dirs))
62                 (dolist (piece pieces)
63                   (let ((piece-start (car piece))
64                         (piece-end (cdr piece)))
65                     (unless (= piece-start piece-end)
66                       (cond ((string= namestring ".."
67                                       :start1 piece-start
68                                       :end1 piece-end)
69                              (dirs :up))
70                             ((string= namestring "**"
71                                       :start1 piece-start
72                                       :end1 piece-end)
73                              (dirs :wild-inferiors))
74                             (t
75                              (dirs (maybe-make-pattern namestring
76                                                        piece-start
77                                                        piece-end)))))))
78                 (cond (absolute
79                        (cons :absolute (dirs)))
80                       ((dirs)
81                        (cons :relative (dirs)))
82                       (t
83                        nil)))
84               name
85               type
86               version))))
87
88 (defun parse-native-unix-namestring (namestring start end)
89   (declare (type simple-string namestring)
90            (type index start end))
91   (setf namestring (coerce namestring 'simple-base-string))
92   (multiple-value-bind (absolute ranges)
93       (split-at-slashes namestring start end)
94     (let* ((components (loop for ((start . end) . rest) on ranges
95                              for piece = (subseq namestring start end)
96                              collect (if (and (string= piece "..") rest)
97                                          :up
98                                          piece)))
99            (name-and-type
100             (let* ((end (first (last components)))
101                    (dot (position #\. end :from-end t)))
102               ;; FIXME: can we get this dot-interpretation knowledge
103               ;; from existing code?  EXTRACT-NAME-TYPE-AND-VERSION
104               ;; does slightly more work than that.
105               (cond
106                 ((string= end "")
107                  (list nil nil))
108                 ((and dot (> dot 0))
109                  (list (subseq end 0 dot) (subseq end (1+ dot))))
110                 (t
111                  (list end nil))))))
112       (values nil
113               nil
114               (cons (if absolute :absolute :relative) (butlast components))
115               (first name-and-type)
116               (second name-and-type)
117               nil))))
118
119 (/show0 "filesys.lisp 300")
120
121 (defun unparse-unix-host (pathname)
122   (declare (type pathname pathname)
123            (ignore pathname))
124   ;; this host designator needs to be recognized as a physical host in
125   ;; PARSE-NAMESTRING. Until sbcl-0.7.3.x, we had "Unix" here, but
126   ;; that's a valid Logical Hostname, so that's a bad choice. -- CSR,
127   ;; 2002-05-09
128   "")
129
130 (defun unparse-unix-piece (thing)
131   (etypecase thing
132     ((member :wild) "*")
133     (simple-string
134      (let* ((srclen (length thing))
135             (dstlen srclen))
136        (dotimes (i srclen)
137          (case (schar thing i)
138            ((#\* #\? #\[)
139             (incf dstlen))))
140        (let ((result (make-string dstlen))
141              (dst 0))
142          (dotimes (src srclen)
143            (let ((char (schar thing src)))
144              (case char
145                ((#\* #\? #\[)
146                 (setf (schar result dst) #\\)
147                 (incf dst)))
148              (setf (schar result dst) char)
149              (incf dst)))
150          result)))
151     (pattern
152      (collect ((strings))
153        (dolist (piece (pattern-pieces thing))
154          (etypecase piece
155            (simple-string
156             (strings piece))
157            (symbol
158             (ecase piece
159               (:multi-char-wild
160                (strings "*"))
161               (:single-char-wild
162                (strings "?"))))
163            (cons
164             (case (car piece)
165               (:character-set
166                (strings "[")
167                (strings (cdr piece))
168                (strings "]"))
169               (t
170                (error "invalid pattern piece: ~S" piece))))))
171        (apply #'concatenate
172               'simple-base-string
173               (strings))))))
174
175 (defun unparse-unix-directory-list (directory)
176   (declare (type list directory))
177   (collect ((pieces))
178     (when directory
179       (ecase (pop directory)
180         (:absolute
181          (pieces "/"))
182         (:relative
183          ;; nothing special
184          ))
185       (dolist (dir directory)
186         (typecase dir
187           ((member :up)
188            (pieces "../"))
189           ((member :back)
190            (error ":BACK cannot be represented in namestrings."))
191           ((member :wild-inferiors)
192            (pieces "**/"))
193           ((or simple-string pattern (member :wild))
194            (pieces (unparse-unix-piece dir))
195            (pieces "/"))
196           (t
197            (error "invalid directory component: ~S" dir)))))
198     (apply #'concatenate 'simple-base-string (pieces))))
199
200 (defun unparse-unix-directory (pathname)
201   (declare (type pathname pathname))
202   (unparse-unix-directory-list (%pathname-directory pathname)))
203
204 (defun unparse-unix-file (pathname)
205   (declare (type pathname pathname))
206   (collect ((strings))
207     (let* ((name (%pathname-name pathname))
208            (type (%pathname-type pathname))
209            (type-supplied (not (or (null type) (eq type :unspecific)))))
210       ;; Note: by ANSI 19.3.1.1.5, we ignore the version slot when
211       ;; translating logical pathnames to a filesystem without
212       ;; versions (like Unix).
213       (when name
214         (when (and (null type)
215                    (typep name 'string)
216                    (> (length name) 0)
217                    (position #\. name :start 1))
218           (error "too many dots in the name: ~S" pathname))
219         (when (and (typep name 'string)
220                    (string= name ""))
221           (error "name is of length 0: ~S" pathname))
222         (strings (unparse-unix-piece name)))
223       (when type-supplied
224         (unless name
225           (error "cannot specify the type without a file: ~S" pathname))
226         (when (typep type 'simple-string)
227           (when (position #\. type)
228             (error "type component can't have a #\. inside: ~S" pathname)))
229         (strings ".")
230         (strings (unparse-unix-piece type))))
231     (apply #'concatenate 'simple-base-string (strings))))
232
233 (/show0 "filesys.lisp 406")
234
235 (defun unparse-unix-namestring (pathname)
236   (declare (type pathname pathname))
237   (concatenate 'simple-base-string
238                (unparse-unix-directory pathname)
239                (unparse-unix-file pathname)))
240
241 (defun unparse-native-unix-namestring (pathname)
242   (declare (type pathname pathname))
243   (let ((directory (pathname-directory pathname))
244         (name (pathname-name pathname))
245         (type (pathname-type pathname)))
246     (coerce
247      (with-output-to-string (s)
248        (ecase (car directory)
249          (:absolute (write-char #\/ s))
250          (:relative))
251        (dolist (piece (cdr directory))
252          (typecase piece
253            ((member :up) (write-string ".." s))
254            (string (write-string piece s))
255            (t (error "ungood piece in NATIVE-NAMESTRING: ~S" piece)))
256          (write-char #\/ s))
257        (when name
258          (unless (stringp name)
259            (error "non-STRING name in NATIVE-NAMESTRING: ~S" name))
260          (write-string name s)
261          (when type
262            (unless (stringp type)
263              (error "non-STRING type in NATIVE-NAMESTRING: ~S" name))
264            (write-char #\. s)
265            (write-string type s))))
266      'simple-base-string)))
267
268 (defun unparse-unix-enough (pathname defaults)
269   (declare (type pathname pathname defaults))
270   (flet ((lose ()
271            (error "~S cannot be represented relative to ~S."
272                   pathname defaults)))
273     (collect ((strings))
274       (let* ((pathname-directory (%pathname-directory pathname))
275              (defaults-directory (%pathname-directory defaults))
276              (prefix-len (length defaults-directory))
277              (result-directory
278               (cond ((null pathname-directory) '(:relative))
279                     ((eq (car pathname-directory) :relative)
280                      pathname-directory)
281                     ((and (> prefix-len 1)
282                           (>= (length pathname-directory) prefix-len)
283                           (compare-component (subseq pathname-directory
284                                                      0 prefix-len)
285                                              defaults-directory))
286                      ;; Pathname starts with a prefix of default. So
287                      ;; just use a relative directory from then on out.
288                      (cons :relative (nthcdr prefix-len pathname-directory)))
289                     ((eq (car pathname-directory) :absolute)
290                      ;; We are an absolute pathname, so we can just use it.
291                      pathname-directory)
292                     (t
293                      (bug "Bad fallthrough in ~S" 'unparse-unix-enough)))))
294         (strings (unparse-unix-directory-list result-directory)))
295       (let* ((pathname-type (%pathname-type pathname))
296              (type-needed (and pathname-type
297                                (not (eq pathname-type :unspecific))))
298              (pathname-name (%pathname-name pathname))
299              (name-needed (or type-needed
300                               (and pathname-name
301                                    (not (compare-component pathname-name
302                                                            (%pathname-name
303                                                             defaults)))))))
304         (when name-needed
305           (unless pathname-name (lose))
306           (when (and (null pathname-type)
307                      (position #\. pathname-name :start 1))
308             (error "too many dots in the name: ~S" pathname))
309           (strings (unparse-unix-piece pathname-name)))
310         (when type-needed
311           (when (or (null pathname-type) (eq pathname-type :unspecific))
312             (lose))
313           (when (typep pathname-type 'simple-base-string)
314             (when (position #\. pathname-type)
315               (error "type component can't have a #\. inside: ~S" pathname)))
316           (strings ".")
317           (strings (unparse-unix-piece pathname-type))))
318       (apply #'concatenate 'simple-string (strings)))))