1.0.21.35: fix build / SAVE-LISP-AND-DIE on non-GENCGC platforms
[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-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-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 as-directory)
89   (declare (type simple-string namestring)
90            (type index start end))
91   (setf namestring (coerce namestring 'simple-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            (directory (if (and as-directory
100                                (string/= "" (car (last components))))
101                           components
102                           (butlast components)))
103            (name-and-type
104             (unless as-directory
105               (let* ((end (first (last components)))
106                      (dot (position #\. end :from-end t)))
107                 ;; FIXME: can we get this dot-interpretation knowledge
108                 ;; from existing code?  EXTRACT-NAME-TYPE-AND-VERSION
109                 ;; does slightly more work than that.
110                 (cond
111                   ((string= end "")
112                    (list nil nil))
113                   ((and dot (> dot 0))
114                    (list (subseq end 0 dot) (subseq end (1+ dot))))
115                   (t
116                    (list end nil)))))))
117       (values nil
118               nil
119               (cons (if absolute :absolute :relative) directory)
120               (first name-and-type)
121               (second name-and-type)
122               nil))))
123
124 (/show0 "filesys.lisp 300")
125
126 (defun unparse-unix-host (pathname)
127   (declare (type pathname pathname)
128            (ignore pathname))
129   ;; this host designator needs to be recognized as a physical host in
130   ;; PARSE-NAMESTRING. Until sbcl-0.7.3.x, we had "Unix" here, but
131   ;; that's a valid Logical Hostname, so that's a bad choice. -- CSR,
132   ;; 2002-05-09
133   "")
134
135 (defun unparse-unix-piece (thing)
136   (etypecase thing
137     ((member :wild) "*")
138     (simple-string
139      (let* ((srclen (length thing))
140             (dstlen srclen))
141        (dotimes (i srclen)
142          (case (schar thing i)
143            ((#\* #\? #\[)
144             (incf dstlen))))
145        (let ((result (make-string dstlen))
146              (dst 0))
147          (dotimes (src srclen)
148            (let ((char (schar thing src)))
149              (case char
150                ((#\* #\? #\[)
151                 (setf (schar result dst) #\\)
152                 (incf dst)))
153              (setf (schar result dst) char)
154              (incf dst)))
155          result)))
156     (pattern
157      (collect ((strings))
158        (dolist (piece (pattern-pieces thing))
159          (etypecase piece
160            (simple-string
161             (strings piece))
162            (symbol
163             (ecase piece
164               (:multi-char-wild
165                (strings "*"))
166               (:single-char-wild
167                (strings "?"))))
168            (cons
169             (case (car piece)
170               (:character-set
171                (strings "[")
172                (strings (cdr piece))
173                (strings "]"))
174               (t
175                (error "invalid pattern piece: ~S" piece))))))
176        (apply #'concatenate
177               'simple-string
178               (strings))))))
179
180 (defun unparse-unix-directory-list (directory)
181   (declare (type list directory))
182   (collect ((pieces))
183     (when directory
184       (ecase (pop directory)
185         (:absolute
186          (pieces "/"))
187         (:relative
188          ;; nothing special
189          ))
190       (dolist (dir directory)
191         (typecase dir
192           ((member :up)
193            (pieces "../"))
194           ((member :back)
195            (error ":BACK cannot be represented in namestrings."))
196           ((member :wild-inferiors)
197            (pieces "**/"))
198           ((or simple-string pattern (member :wild))
199            (pieces (unparse-unix-piece dir))
200            (pieces "/"))
201           (t
202            (error "invalid directory component: ~S" dir)))))
203     (apply #'concatenate 'simple-string (pieces))))
204
205 (defun unparse-unix-directory (pathname)
206   (declare (type pathname pathname))
207   (unparse-unix-directory-list (%pathname-directory pathname)))
208
209 (defun unparse-unix-file (pathname)
210   (declare (type pathname pathname))
211   (collect ((strings))
212     (let* ((name (%pathname-name pathname))
213            (type (%pathname-type pathname))
214            (type-supplied (not (or (null type) (eq type :unspecific)))))
215       ;; Note: by ANSI 19.3.1.1.5, we ignore the version slot when
216       ;; translating logical pathnames to a filesystem without
217       ;; versions (like Unix).
218       (when name
219         (when (and (null type)
220                    (typep name 'string)
221                    (> (length name) 0)
222                    (position #\. name :start 1))
223           (error "too many dots in the name: ~S" pathname))
224         (when (and (typep name 'string)
225                    (string= name ""))
226           (error "name is of length 0: ~S" pathname))
227         (strings (unparse-unix-piece name)))
228       (when type-supplied
229         (unless name
230           (error "cannot specify the type without a file: ~S" pathname))
231         (when (typep type 'simple-string)
232           (when (position #\. type)
233             (error "type component can't have a #\. inside: ~S" pathname)))
234         (strings ".")
235         (strings (unparse-unix-piece type))))
236     (apply #'concatenate 'simple-string (strings))))
237
238 (/show0 "filesys.lisp 406")
239
240 (defun unparse-unix-namestring (pathname)
241   (declare (type pathname pathname))
242   (concatenate 'simple-string
243                (unparse-unix-directory pathname)
244                (unparse-unix-file pathname)))
245
246 (defun unparse-native-unix-namestring (pathname as-file)
247   (declare (type pathname pathname))
248   (let* ((directory (pathname-directory pathname))
249          (name (pathname-name pathname))
250          (name-present-p (typep name '(not (member nil :unspecific))))
251          (name-string (if name-present-p name ""))
252          (type (pathname-type pathname))
253          (type-present-p (typep type '(not (member nil :unspecific))))
254          (type-string (if type-present-p type "")))
255     (when name-present-p
256       (setf as-file nil))
257     (coerce
258      (with-output-to-string (s)
259        (when directory
260          (ecase (car directory)
261            (:absolute (write-char #\/ s))
262            (:relative)))
263        (loop for (piece . subdirs) on (cdr directory)
264           do (typecase piece
265                ((member :up) (write-string ".." s))
266                (string (write-string piece s))
267                (t (error "ungood directory segment in NATIVE-NAMESTRING: ~S"
268                          piece)))
269           if (or subdirs (stringp name))
270           do (write-char #\/ s)
271           else
272           do (unless as-file
273                (write-char #\/ s)))
274        (if name-present-p
275            (progn
276              (unless (stringp name-string) ;some kind of wild field
277                (error "ungood name component in NATIVE-NAMESTRING: ~S" name))
278              (write-string name-string s)
279              (when type-present-p
280                (unless (stringp type-string) ;some kind of wild field
281                  (error "ungood type component in NATIVE-NAMESTRING: ~S" type))
282                (write-char #\. s)
283                (write-string type-string s)))
284            (when type-present-p ; type without a name
285              (error
286               "type component without a name component in NATIVE-NAMESTRING: ~S"
287               type))))
288      'simple-string)))
289
290 (defun unparse-unix-enough (pathname defaults)
291   (declare (type pathname pathname defaults))
292   (flet ((lose ()
293            (error "~S cannot be represented relative to ~S."
294                   pathname defaults)))
295     (collect ((strings))
296       (let* ((pathname-directory (%pathname-directory pathname))
297              (defaults-directory (%pathname-directory defaults))
298              (prefix-len (length defaults-directory))
299              (result-directory
300               (cond ((null pathname-directory) '(:relative))
301                     ((eq (car pathname-directory) :relative)
302                      pathname-directory)
303                     ((and (> prefix-len 0)
304                           (>= (length pathname-directory) prefix-len)
305                           (compare-component (subseq pathname-directory
306                                                      0 prefix-len)
307                                              defaults-directory))
308                      ;; Pathname starts with a prefix of default. So
309                      ;; just use a relative directory from then on out.
310                      (cons :relative (nthcdr prefix-len pathname-directory)))
311                     ((eq (car pathname-directory) :absolute)
312                      ;; We are an absolute pathname, so we can just use it.
313                      pathname-directory)
314                     (t
315                      (bug "Bad fallthrough in ~S" 'unparse-unix-enough)))))
316         (strings (unparse-unix-directory-list result-directory)))
317       (let* ((pathname-type (%pathname-type pathname))
318              (type-needed (and pathname-type
319                                (not (eq pathname-type :unspecific))))
320              (pathname-name (%pathname-name pathname))
321              (name-needed (or type-needed
322                               (and pathname-name
323                                    (not (compare-component pathname-name
324                                                            (%pathname-name
325                                                             defaults)))))))
326         (when name-needed
327           (unless pathname-name (lose))
328           (when (and (null pathname-type)
329                      (typep pathname-name 'simple-string)
330                      (position #\. pathname-name :start 1))
331             (error "too many dots in the name: ~S" pathname))
332           (strings (unparse-unix-piece pathname-name)))
333         (when type-needed
334           (when (or (null pathname-type) (eq pathname-type :unspecific))
335             (lose))
336           (when (typep pathname-type 'simple-string)
337             (when (position #\. pathname-type)
338               (error "type component can't have a #\. inside: ~S" pathname)))
339           (strings ".")
340           (strings (unparse-unix-piece pathname-type))))
341       (apply #'concatenate 'simple-string (strings)))))
342
343 (defun simplify-unix-namestring (src)
344   (declare (type simple-string src))
345   (let* ((src-len (length src))
346          (dst (make-string src-len :element-type 'character))
347          (dst-len 0)
348          (dots 0)
349          (last-slash nil))
350     (macrolet ((deposit (char)
351                  `(progn
352                     (setf (schar dst dst-len) ,char)
353                     (incf dst-len))))
354       (dotimes (src-index src-len)
355         (let ((char (schar src src-index)))
356           (cond ((char= char #\.)
357                  (when dots
358                    (incf dots))
359                  (deposit char))
360                 ((char= char #\/)
361                  (case dots
362                    (0
363                     ;; either ``/...' or ``...//...'
364                     (unless last-slash
365                       (setf last-slash dst-len)
366                       (deposit char)))
367                    (1
368                     ;; either ``./...'' or ``..././...''
369                     (decf dst-len))
370                    (2
371                     ;; We've found ..
372                     (cond
373                       ((and last-slash (not (zerop last-slash)))
374                        ;; There is something before this ..
375                        (let ((prev-prev-slash
376                               (position #\/ dst :end last-slash :from-end t)))
377                          (cond ((and (= (+ (or prev-prev-slash 0) 2)
378                                         last-slash)
379                                      (char= (schar dst (- last-slash 2)) #\.)
380                                      (char= (schar dst (1- last-slash)) #\.))
381                                 ;; The something before this .. is another ..
382                                 (deposit char)
383                                 (setf last-slash dst-len))
384                                (t
385                                 ;; The something is some directory or other.
386                                 (setf dst-len
387                                       (if prev-prev-slash
388                                           (1+ prev-prev-slash)
389                                           0))
390                                 (setf last-slash prev-prev-slash)))))
391                       (t
392                        ;; There is nothing before this .., so we need to keep it
393                        (setf last-slash dst-len)
394                        (deposit char))))
395                    (t
396                     ;; something other than a dot between slashes
397                     (setf last-slash dst-len)
398                     (deposit char)))
399                  (setf dots 0))
400                 (t
401                  (setf dots nil)
402                  (setf (schar dst dst-len) char)
403                  (incf dst-len))))))
404     (when (and last-slash (not (zerop last-slash)))
405       (case dots
406         (1
407          ;; We've got  ``foobar/.''
408          (decf dst-len))
409         (2
410          ;; We've got ``foobar/..''
411          (unless (and (>= last-slash 2)
412                       (char= (schar dst (1- last-slash)) #\.)
413                       (char= (schar dst (- last-slash 2)) #\.)
414                       (or (= last-slash 2)
415                           (char= (schar dst (- last-slash 3)) #\/)))
416            (let ((prev-prev-slash
417                   (position #\/ dst :end last-slash :from-end t)))
418              (if prev-prev-slash
419                  (setf dst-len (1+ prev-prev-slash))
420                  (return-from simplify-unix-namestring
421                    (coerce "./" 'simple-string))))))))
422     (cond ((zerop dst-len)
423            "./")
424           ((= dst-len src-len)
425            dst)
426           (t
427            (subseq dst 0 dst-len)))))