source: trunk/abcl/src/org/armedbear/lisp/pathnames.lisp @ 12617

Last change on this file since 12617 was 12617, checked in by Mark Evenson, 12 years ago

Move pathname functions to EXT; implement DEFSETF for URL pathnames.

Implemented DEFSETF functions for HOST, AUTHORITY, QUERY, and FRAGMENT
sections of URL pathname.

Moved PATHNAME-JAR-P and PATHNAME-URL-P to EXT.

EXT::%INVALIDATE-NAMESTRING resets the namestring after changing the
internal structure. Having to monkey around with the internal
structure of Pathname is just wrong: we should implement the get/set
accessor pattern in Java even though it would make the code more
verbose.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 19.2 KB
Line 
1;;; pathnames.lisp
2;;;
3;;; Copyright (C) 2003-2007 Peter Graves
4;;; $Id: pathnames.lisp 12617 2010-04-15 14:54:55Z 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 (eq (pathname-version to) :wild)
327                                      (pathname-version from)
328                                      (pathname-version to))
329                                  (translate-component (pathname-version source)
330                                                       (pathname-version from)
331                                                       (pathname-version to))))))
332
333(defun logical-host-p (canonical-host)
334  (multiple-value-bind (translations present)
335      (gethash canonical-host *logical-pathname-translations*)
336    (declare (ignore translations))
337    present))
338
339(defun logical-pathname-translations (host)
340  (multiple-value-bind (translations present)
341      (gethash (canonicalize-logical-host host) *logical-pathname-translations*)
342    (unless present
343      (error 'type-error
344             :datum host
345             :expected-type '(and string (satisfies logical-host-p))))
346    translations))
347
348(defun canonicalize-logical-pathname-translations (translations host)
349  (let (result)
350    (dolist (translation translations (nreverse result))
351      (let ((from (car translation))
352            (to (cadr translation)))
353        (push (list (if (typep from 'logical-pathname)
354                        from
355                        (parse-namestring from host))
356                    (pathname to))
357              result)))))
358
359(defun %set-logical-pathname-translations (host translations)
360  (setf host (canonicalize-logical-host host))
361  ;; Avoid undefined host error in CANONICALIZE-LOGICAL-PATHNAME-TRANSLATIONS.
362  (unless (logical-host-p host)
363    (setf (gethash host *logical-pathname-translations*) nil))
364  (setf (gethash host *logical-pathname-translations*)
365        (canonicalize-logical-pathname-translations translations host)))
366
367(defsetf logical-pathname-translations %set-logical-pathname-translations)
368
369(defun translate-logical-pathname (pathname &key)
370  (typecase pathname
371    (logical-pathname
372     (let* ((host (pathname-host pathname))
373            (translations (logical-pathname-translations host)))
374       (dolist (translation translations
375                            (error 'file-error
376                                   :pathname pathname
377                                   :format-control "No translation for ~S"
378                                   :format-arguments (list pathname)))
379         (let ((from-wildcard (car translation))
380               (to-wildcard (cadr translation)))
381           (when (pathname-match-p pathname from-wildcard)
382             (return (translate-logical-pathname
383                      (translate-pathname pathname from-wildcard to-wildcard))))))))
384    (pathname pathname)
385    (t
386     (translate-logical-pathname (pathname pathname)))))
387
388(defun load-logical-pathname-translations (host)
389  (declare (type string host))
390  (multiple-value-bind (ignore found)
391      (gethash (canonicalize-logical-host host)
392               *logical-pathname-translations*)
393    (declare (ignore ignore))
394    (unless found
395      (error "The logical host ~S was not found." host))))
396
397(defun logical-pathname (pathspec)
398  (typecase pathspec
399    (logical-pathname pathspec)
400    (string
401     (%make-logical-pathname pathspec))
402    (stream
403     (let ((result (pathname pathspec)))
404       (if (typep result 'logical-pathname)
405           result
406           (error 'simple-type-error
407                  :datum result
408                  :expected-type 'logical-pathname))))
409    (t
410     (error 'type-error
411            :datum pathspec
412            :expected-type '(or logical-pathname string stream)))))
413
414(defun parse-namestring (thing
415                         &optional host (default-pathname *default-pathname-defaults*)
416                         &key (start 0) end junk-allowed)
417  (declare (ignore junk-allowed)) ; FIXME
418  (cond ((eq host :unspecific)
419         (setf host nil))
420        ((consp host)) ;; A URL
421        (host
422         (setf host (canonicalize-logical-host host))))
423  (typecase thing
424    (stream
425     (values (pathname thing) start))
426    (pathname
427     (values thing start))
428    (string
429     (unless end
430       (setf end (length thing)))
431     (%parse-namestring (subseq thing start end) host default-pathname))
432    (t
433     (error 'type-error
434            :format-control "~S cannot be converted to a pathname."
435            :format-arguments (list thing)))))
436
437
438;;; Functions for dealing with URL Pathnames
439
440(in-package :extensions)
441
442(defun url-pathname-scheme (p)
443  (unless (pathname-url-p p)
444    (error "~A is not a URL pathname." p))
445  (getf (pathname-host p) :scheme))
446
447(defun set-url-pathname-scheme (p v)
448  (unless (pathname-url-p p)
449    (error "~A is not a URL pathname." p))
450  (let ((host (pathname-host p)))
451    (setf (getf host :scheme) v))
452  (%invalidate-namestring p))
453
454(defsetf url-pathname-scheme set-url-pathname-scheme)
455
456(defun url-pathname-authority (p)
457  (unless (pathname-url-p p)
458    (error "~A is not a URL pathname." p))
459  (getf (pathname-host p) :authority))
460
461(defun set-url-pathname-authority (p v)
462  (unless (pathname-url-p p)
463    (error "~A is not a URL pathname." p))
464  (let ((host (pathname-host p)))
465    (setf (getf host :authority) v))
466  (%invalidate-namestring p))
467
468(defsetf url-pathname-authority set-url-pathname-authority)
469
470(defun url-pathname-query (p)
471  (unless (pathname-url-p p)
472    (error "~A is not a URL pathname." p))
473  (getf (pathname-host p) :query))
474
475(defun set-url-pathname-query (p v)
476  (unless (pathname-url-p p)
477    (error "~A is not a URL pathname." p))
478  (let ((host (pathname-host p)))
479    (setf (getf host :query) v))
480  (%invalidate-namestring p))
481
482(defsetf url-pathname-query set-url-pathname-query)
483
484(defun url-pathname-fragment (p)
485  (unless (pathname-url-p p)
486    (error "~A is not a URL pathname." p))
487  (getf (pathname-host p) :fragment))
488
489(defun set-url-pathname-fragment (p v)
490  (unless (pathname-url-p p)
491    (error "~A is not a URL pathname." p))
492  (let ((host (pathname-host p)))
493    (setf (getf host :fragment) v))
494  (%invalidate-namestring p))
495
496(defsetf url-pathname-query set-url-pathname-fragment)
497
498(export '(url-pathname-scheme
499          url-pathname-authority
500          url-pathname-query
501          url-pathname-fragment) 
502        'ext)
Note: See TracBrowser for help on using the repository browser.