source: branches/1.1.x/src/org/armedbear/lisp/pathnames.lisp

Last change on this file was 13300, checked in by Mark Evenson, 13 years ago

TRANSLATE-PATHNAME uses source version if to version if :wild or nil.

This aligns the behavior to what SBCL does. The original behavior of
ABCL of using the from version would result in a lot of the usages of
TRANSLATE-PATHNAME with wildcards to produce a wild version in the
result which is probably never the intention.
  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 19.3 KB
Line 
1;;; pathnames.lisp
2;;;
3;;; Copyright (C) 2003-2007 Peter Graves
4;;; $Id: pathnames.lisp 13300 2011-05-27 13:06:08Z mevenson $
5;;;
6;;; This program is free software; you can redistribute it and/or
7;;; modify it under the terms of the GNU General Public License
8;;; as published by the Free Software Foundation; either version 2
9;;; of the License, or (at your option) any later version.
10;;;
11;;; This program is distributed in the hope that it will be useful,
12;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14;;; GNU General Public License for more details.
15;;;
16;;; You should have received a copy of the GNU General Public License
17;;; along with this program; if not, write to the Free Software
18;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
19;;;
20;;; As a special exception, the copyright holders of this library give you
21;;; permission to link this library with independent modules to produce an
22;;; executable, regardless of the license terms of these independent
23;;; modules, and to copy and distribute the resulting executable under
24;;; terms of your choice, provided that you also meet, for each linked
25;;; independent module, the terms and conditions of the license of that
26;;; module.  An independent module is a module which is not derived from
27;;; or based on this library.  If you modify this library, you may extend
28;;; this exception to your version of the library, but you are not
29;;; obligated to do so.  If you do not wish to do so, delete this
30;;; exception statement from your version.
31
32(in-package "SYSTEM")
33
34(export '(logical-host-p))
35
36(defun pathname-host (pathname &key (case :local))
37  (%pathname-host pathname case))
38
39(defun pathname-device (pathname &key (case :local))
40  (%pathname-device pathname case))
41
42(defun pathname-directory (pathname &key (case :local))
43  (%pathname-directory pathname case))
44
45(defun pathname-name (pathname &key (case :local))
46  (%pathname-name pathname case))
47
48(defun pathname-type (pathname &key (case :local))
49  (%pathname-type pathname case))
50
51(defun wild-pathname-p (pathname &optional field-key)
52  (%wild-pathname-p pathname field-key))
53
54(defun component-match-wild-p (thing wild ignore-case)
55  (let ((testfunc (if ignore-case #'equalp #'equal)))
56    (labels ((split-string (delim str)
57         (flet ((finder (char) (find char delim)))
58     (loop  for x = (position-if-not #'finder str) then
59          (position-if-not #'finder str :start (or y (length str)))
60        for y = (position-if #'finder str :start x) then
61          (position-if #'finder str :start (or x (length str))) while x 
62        collect (subseq str x y))))
63       (positions-larger (thing substrings previous-pos)
64         (let ((new-pos (search (car substrings) 
65              thing 
66              :start2 previous-pos
67              :test testfunc)))
68     (or 
69      (not substrings)
70      (and new-pos
71           (>= new-pos previous-pos)
72           (positions-larger thing 
73           (cdr substrings) 
74           new-pos))))))
75      (let ((split-result (split-string "*" wild)))
76  (and (positions-larger thing split-result 0)
77       (if (eql (elt wild 0) #\*)
78     t
79     (eql (search (first split-result) thing :test testfunc) 0))
80       (if (eql (elt wild (1- (length wild))) #\*)
81     t
82     (let ((last-split-result (first (last split-result))))
83       (eql (search last-split-result thing :from-end t 
84        :test testfunc)
85      (- (length thing) (length last-split-result))))))))))
86
87(defun component-match-p (thing wild ignore-case)
88  (cond ((eq wild :wild)
89         t)
90        ((null wild)
91         t)
92        ((and (stringp wild) (position #\* wild))
93   (component-match-wild-p thing wild ignore-case))
94        (ignore-case
95         (equalp thing wild))
96        (t
97         (equal thing wild))))
98
99(defun directory-match-components (thing wild ignore-case)
100  (loop
101    (cond ((endp thing)
102           (return (or (endp wild) (equal wild '(:wild-inferiors)))))
103          ((endp wild)
104           (return nil)))
105    (let ((x (car thing))
106          (y (car wild)))
107      (when (eq y :wild-inferiors)
108        (return t))
109      (unless (component-match-p x y ignore-case)
110        (return nil))
111      (setf thing (cdr thing)
112            wild  (cdr wild)))))
113
114(defun directory-match-p (thing wild ignore-case)
115  (cond ((eq wild :wild)
116         t)
117        ((null wild)
118         t)
119        ((and ignore-case (equalp thing wild))
120         t)
121        ((equal thing wild)
122         t)
123        ((and (null thing) (equal wild '(:absolute :wild-inferiors)))
124         t)
125        ((and (consp thing) (consp wild))
126         (if (eq (%car thing) (%car wild))
127             (directory-match-components (%cdr thing) (%cdr wild) ignore-case)
128             nil))
129        (t
130         nil)))
131
132(defun pathname-match-p (pathname wildcard)
133  (setf pathname (pathname pathname)
134        wildcard (pathname wildcard))
135  (unless (component-match-p (pathname-host pathname) (pathname-host wildcard) nil)
136    (return-from pathname-match-p nil))
137  (when (and (pathname-jar-p pathname) 
138             (pathname-jar-p wildcard))
139    (unless 
140        (every (lambda (value) (not (null value)))
141               (mapcar #'pathname-match-p 
142                       (pathname-device pathname) 
143                       (pathname-device wildcard)))
144      (return-from pathname-match-p nil)))
145  (when (or (and (pathname-jar-p pathname)
146                 (not (pathname-jar-p wildcard)))
147            (and (not (pathname-jar-p pathname))
148                 (pathname-jar-p wildcard)))
149    (return-from pathname-match-p nil))
150  (let* ((windows-p (featurep :windows))
151         (ignore-case (or windows-p (typep pathname 'logical-pathname))))
152    (cond ((and windows-p
153                (not (pathname-jar-p pathname))
154                (not (pathname-jar-p wildcard))
155                (not (component-match-p (pathname-device pathname)
156                                        (pathname-device wildcard)
157                                        ignore-case)))
158           nil)
159          ((not (directory-match-p (pathname-directory pathname)
160                                   (pathname-directory wildcard)
161                                   ignore-case))
162           nil)
163          ((not (component-match-p (pathname-name pathname)
164                                   (pathname-name wildcard)
165                                   ignore-case))
166           nil)
167          ((not (component-match-p (pathname-type pathname)
168                                   (pathname-type wildcard)
169                                   ignore-case))
170           nil)
171          (t
172           t))))
173
174(defun wild-p (component)
175  (or (eq component :wild)
176      (and (stringp component)
177           (position #\* component))))
178
179(defun casify (thing case)
180  (typecase thing
181    (string
182     (case case
183       (:upcase (string-upcase thing))
184       (:downcase (string-downcase thing))
185       (t thing)))
186    (list
187     (let (result)
188       (dolist (component thing (nreverse result))
189         (push (casify component case) result))))
190    (t
191     thing)))
192
193(defun translate-component (source from to &optional case)
194  (declare (ignore from))
195  (cond ((or (eq to :wild) (null to))
196         ;; "If the piece in TO-WILDCARD is :WILD or NIL, the piece in source
197         ;; is copied into the result."
198         (casify source case))
199        ((and to (not (wild-p to)))
200        ;; "If the piece in TO-WILDCARD is present and not wild, it is copied
201        ;; into the result."
202         to)
203        (t
204         ;; "Otherwise, the piece in TO-WILDCARD might be a complex wildcard
205         ;; such as "foo*bar" and the piece in FROM-WILDCARD should be wild;
206         ;; the portion of the piece in SOURCE that matches the wildcard
207         ;; portion of the piece in FROM-WILDCARD replaces the wildcard portion
208         ;; of the piece in TO-WILDCARD and the value produced is used in the
209         ;; result."
210         ;; FIXME
211         (error "Unsupported wildcard pattern: ~S" to))))
212
213(defun translate-jar-device (source from to &optional case)
214  (declare (ignore case)) ; FIXME
215  (unless to
216    (return-from translate-jar-device nil))
217  (when (not (= (length source) 
218                (length from)
219                (length to)))
220    (error "Unsupported pathname translation for unequal jar ~
221  references: ~S != ~S != ~S" source from to))
222  (mapcar #'translate-pathname source from to))
223
224(defun translate-directory-components-aux (src from to case)
225  (cond
226    ((and (null src) (null from) (null to))
227     NIL)
228    ((and to
229          (not (member (car to) '(:wild :wild-inferiors))))
230     (cons (casify (car to) case)
231           (translate-directory-components-aux 
232            src from (cdr to) case)))
233    ((and (not src) 
234          (eq (car from) :wild-inferiors) 
235          (eq (car to) :wild-inferiors))
236     (translate-directory-components-aux src (cdr from) (cdr to) case))
237    ((not (and src from))
238     ;; both are NIL --> TO is a wildcard which can't be matched
239     ;; either is NIL --> SRC can't be fully matched against FROM, vice versa
240     (throw 'failed-match))
241    ((not (member (car from) '(:wild :wild-inferiors)))
242     (unless (string= (casify (car src) case) (casify (car from) case))
243       (throw 'failed-match)) ;; FROM doesn't match SRC
244     (translate-directory-components-aux (cdr src) (cdr from) to case))
245    ((not (eq (car from) (car to))) ;; TO is NIL while FROM is not, or
246     (throw 'failed-match))         ;; FROM wildcard doesn't match TO wildcard
247    ((eq (car to) :wild)  ;; FROM and TO wildcards are :WILD
248     (cons (casify (car src) case)
249       (translate-directory-components-aux (cdr src) (cdr from) (cdr to) case)))
250    ((eq (car to) :wild-inferiors) ;; FROM and TO wildcards are :WILD-INFERIORS
251     (do ((src (cdr src) (cdr src))
252          (match (list (casify (car src) case))
253                 (cons (casify (car src) case) match)))
254         (NIL) ;; we'll exit the loop in different ways
255       (catch 'failed-match
256         (return-from translate-directory-components-aux
257           (append (reverse match) 
258                   (translate-directory-components-aux
259                    src (cdr from) (cdr to) case))))
260       (when (and (null src) 
261                  (eq (car from) :wild-inferiors)
262                  (eq (car to) :wild-inferiors))
263         (return-from translate-directory-components-aux nil))
264       (when (null src) ;; SRC is NIL and we're still here: error exit
265         (throw 'failed-match))))))
266
267(defun translate-directory-components (src from to case)
268  (catch 'failed-match
269    (return-from translate-directory-components
270      (translate-directory-components-aux src from to case)))
271  (error "Unsupported case in TRANSLATE-DIRECTORY-COMPONENTS."))
272
273
274(defun translate-directory (source from to case)
275  ;; FIXME The IGNORE-CASE argument to DIRECTORY-MATCH-P should not be nil on
276  ;; Windows or if the source pathname is a logical pathname.
277  ;; FIXME We can canonicalize logical pathnames to upper case, so we only need
278  ;; IGNORE-CASE for Windows.
279  (cond ((null source)
280         to)
281        ((equal source '(:absolute))
282         (remove :wild-inferiors to))
283        (t
284         (translate-directory-components source from to case))))
285
286;; "The resulting pathname is TO-WILDCARD with each wildcard or missing field
287;; replaced by a portion of SOURCE."
288(defun translate-pathname (source from-wildcard to-wildcard &key)
289  (unless (pathname-match-p source from-wildcard)
290    (error "~S and ~S do not match." source from-wildcard))
291  (let* ((source (pathname source))
292         (from   (pathname from-wildcard))
293         (to     (pathname to-wildcard))
294         (device (if (typep 'to 'logical-pathname)
295                     :unspecific
296                     (if (pathname-jar-p source)
297                         (translate-jar-device (pathname-device source)
298                                               (pathname-device from)
299                                               (pathname-device to))
300                         (translate-component (pathname-device source)
301                                              (pathname-device from)
302                                              (pathname-device to)))))
303         (case   (and (typep source 'logical-pathname)
304                      (or (featurep :unix) (featurep :windows))
305                      :downcase)))
306    (make-pathname :host      (pathname-host to)
307                   :device    (cond ((typep to 'logical-pathname)
308                                     :unspecific)
309                                    ((eq device :unspecific)
310                                     nil)
311                                    (t
312                                     device))
313                   :directory (translate-directory (pathname-directory source)
314                                                   (pathname-directory from)
315                                                   (pathname-directory to)
316                                                   case)
317                   :name      (translate-component (pathname-name source)
318                                                   (pathname-name from)
319                                                   (pathname-name to)
320                                                   case)
321                   :type      (translate-component (pathname-type source)
322                                                   (pathname-type from)
323                                                   (pathname-type to)
324                                                   case)
325                   :version   (if (null (pathname-host from))
326                                  (if (or (eq (pathname-version to) :wild)
327                                          (eq (pathname-version to) nil))
328                                      (pathname-version source)
329                                      (pathname-version to))
330                                  (translate-component (pathname-version source)
331                                                       (pathname-version from)
332                                                       (pathname-version to))))))
333
334(defun logical-host-p (canonical-host)
335  (multiple-value-bind (translations present)
336      (gethash canonical-host *logical-pathname-translations*)
337    (declare (ignore translations))
338    present))
339
340(defun logical-pathname-translations (host)
341  (multiple-value-bind (translations present)
342      (gethash (canonicalize-logical-host host) *logical-pathname-translations*)
343    (unless present
344      (error 'type-error
345             :datum host
346             :expected-type '(and string (satisfies logical-host-p))))
347    translations))
348
349(defun canonicalize-logical-pathname-translations (translations host)
350  (let (result)
351    (dolist (translation translations (nreverse result))
352      (let ((from (car translation))
353            (to (cadr translation)))
354        (push (list (if (typep from 'logical-pathname)
355                        from
356                        (parse-namestring from host))
357                    (pathname to))
358              result)))))
359
360(defun %set-logical-pathname-translations (host translations)
361  (setf host (canonicalize-logical-host host))
362  ;; Avoid undefined host error in CANONICALIZE-LOGICAL-PATHNAME-TRANSLATIONS.
363  (unless (logical-host-p host)
364    (setf (gethash host *logical-pathname-translations*) nil))
365  (setf (gethash host *logical-pathname-translations*)
366        (canonicalize-logical-pathname-translations translations host)))
367
368(defsetf logical-pathname-translations %set-logical-pathname-translations)
369
370(defun translate-logical-pathname (pathname &key)
371  (typecase pathname
372    (logical-pathname
373     (let* ((host (pathname-host pathname))
374            (translations (logical-pathname-translations host)))
375       (dolist (translation translations
376                            (error 'file-error
377                                   :pathname pathname
378                                   :format-control "No translation for ~S"
379                                   :format-arguments (list pathname)))
380         (let ((from-wildcard (car translation))
381               (to-wildcard (cadr translation)))
382           (when (pathname-match-p pathname from-wildcard)
383             (return (translate-logical-pathname
384                      (translate-pathname pathname from-wildcard to-wildcard))))))))
385    (pathname pathname)
386    (t
387     (translate-logical-pathname (pathname pathname)))))
388
389(defun load-logical-pathname-translations (host)
390  (declare (type string host))
391  (multiple-value-bind (ignore found)
392      (gethash (canonicalize-logical-host host)
393               *logical-pathname-translations*)
394    (declare (ignore ignore))
395    (unless found
396      (error "The logical host ~S was not found." host))))
397
398(defun logical-pathname (pathspec)
399  (typecase pathspec
400    (logical-pathname pathspec)
401    (string
402     (%make-logical-pathname pathspec))
403    (stream
404     (let ((result (pathname pathspec)))
405       (if (typep result 'logical-pathname)
406           result
407           (error 'simple-type-error
408                  :datum result
409                  :expected-type 'logical-pathname))))
410    (t
411     (error 'type-error
412            :datum pathspec
413            :expected-type '(or logical-pathname string stream)))))
414
415(defun parse-namestring (thing
416                         &optional host (default-pathname *default-pathname-defaults*)
417                         &key (start 0) end junk-allowed)
418  (declare (ignore junk-allowed)) ; FIXME
419  (cond ((eq host :unspecific)
420         (setf host nil))
421        ((consp host)) ;; A URL
422        (host
423         (setf host (canonicalize-logical-host host))))
424  (typecase thing
425    (stream
426     (values (pathname thing) start))
427    (pathname
428     (values thing start))
429    (string
430     (unless end
431       (setf end (length thing)))
432     (%parse-namestring (subseq thing start end) host default-pathname))
433    (t
434     (error 'type-error
435            :format-control "~S cannot be converted to a pathname."
436            :format-arguments (list thing)))))
437
438
439;;; Functions for dealing with URL Pathnames
440
441(in-package :extensions)
442
443(defun url-pathname-scheme (p)
444  (unless (pathname-url-p p)
445    (error "~A is not a URL pathname." p))
446  (getf (pathname-host p) :scheme))
447
448(defun set-url-pathname-scheme (p v)
449  (unless (pathname-url-p p)
450    (error "~A is not a URL pathname." p))
451  (let ((host (pathname-host p)))
452    (setf (getf host :scheme) v))
453  (%invalidate-namestring p))
454
455(defsetf url-pathname-scheme set-url-pathname-scheme)
456
457(defun url-pathname-authority (p)
458  (unless (pathname-url-p p)
459    (error "~A is not a URL pathname." p))
460  (getf (pathname-host p) :authority))
461
462(defun set-url-pathname-authority (p v)
463  (unless (pathname-url-p p)
464    (error "~A is not a URL pathname." p))
465  (let ((host (pathname-host p)))
466    (setf (getf host :authority) v))
467  (%invalidate-namestring p))
468
469(defsetf url-pathname-authority set-url-pathname-authority)
470
471(defun url-pathname-query (p)
472  (unless (pathname-url-p p)
473    (error "~A is not a URL pathname." p))
474  (getf (pathname-host p) :query))
475
476(defun set-url-pathname-query (p v)
477  (unless (pathname-url-p p)
478    (error "~A is not a URL pathname." p))
479  (let ((host (pathname-host p)))
480    (setf (getf host :query) v))
481  (%invalidate-namestring p))
482
483(defsetf url-pathname-query set-url-pathname-query)
484
485(defun url-pathname-fragment (p)
486  (unless (pathname-url-p p)
487    (error "~A is not a URL pathname." p))
488  (getf (pathname-host p) :fragment))
489
490(defun set-url-pathname-fragment (p v)
491  (unless (pathname-url-p p)
492    (error "~A is not a URL pathname." p))
493  (let ((host (pathname-host p)))
494    (setf (getf host :fragment) v))
495  (%invalidate-namestring p))
496
497(defsetf url-pathname-query set-url-pathname-fragment)
498
499(export '(url-pathname-scheme
500          url-pathname-authority
501          url-pathname-query
502          url-pathname-fragment) 
503        'ext)
Note: See TracBrowser for help on using the repository browser.