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

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

Fix TRANSLATE-LOGICAL-PATHNAME regression.

Problem and solution found by Alan Ruttenburg.

Closes ticket:83.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 15.9 KB
Line 
1;;; pathnames.lisp
2;;;
3;;; Copyright (C) 2003-2007 Peter Graves
4;;; $Id: pathnames.lisp 12417 2010-02-04 09:42:16Z 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  (let* ((windows-p (featurep :windows))
138         (ignore-case (or windows-p (typep pathname 'logical-pathname))))
139    (cond ((and windows-p
140                (not (component-match-p (pathname-device pathname)
141                                        (pathname-device wildcard)
142                                        ignore-case)))
143           nil)
144          ((not (directory-match-p (pathname-directory pathname)
145                                   (pathname-directory wildcard)
146                                   ignore-case))
147           nil)
148          ((not (component-match-p (pathname-name pathname)
149                                   (pathname-name wildcard)
150                                   ignore-case))
151           nil)
152          ((not (component-match-p (pathname-type pathname)
153                                   (pathname-type wildcard)
154                                   ignore-case))
155           nil)
156          (t
157           t))))
158
159(defun wild-p (component)
160  (or (eq component :wild)
161      (and (stringp component)
162           (position #\* component))))
163
164(defun casify (thing case)
165  (typecase thing
166    (string
167     (case case
168       (:upcase (string-upcase thing))
169       (:downcase (string-downcase thing))
170       (t thing)))
171    (list
172     (let (result)
173       (dolist (component thing (nreverse result))
174         (push (casify component case) result))))
175    (t
176     thing)))
177
178(defun translate-component (source from to &optional case)
179  (declare (ignore from))
180  (cond ((or (eq to :wild) (null to))
181         ;; "If the piece in TO-WILDCARD is :WILD or NIL, the piece in source
182         ;; is copied into the result."
183         (casify source case))
184        ((and to (not (wild-p to)))
185        ;; "If the piece in TO-WILDCARD is present and not wild, it is copied
186        ;; into the result."
187         to)
188        (t
189         ;; "Otherwise, the piece in TO-WILDCARD might be a complex wildcard
190         ;; such as "foo*bar" and the piece in FROM-WILDCARD should be wild;
191         ;; the portion of the piece in SOURCE that matches the wildcard
192         ;; portion of the piece in FROM-WILDCARD replaces the wildcard portion
193         ;; of the piece in TO-WILDCARD and the value produced is used in the
194         ;; result."
195         ;; FIXME
196         (error "Unsupported wildcard pattern: ~S" to))))
197
198
199(defun translate-directory-components-aux (src from to case)
200  (cond
201    ((and (null src) (null from) (null to))
202     NIL)
203    ((and to
204          (not (member (car to) '(:wild :wild-inferiors))))
205     (cons (casify (car to) case)
206           (translate-directory-components-aux 
207            src from (cdr to) case)))
208    ((and (not src) 
209          (eq (car from) :wild-inferiors) 
210          (eq (car to) :wild-inferiors))
211     (translate-directory-components-aux src (cdr from) (cdr to) case))
212    ((not (and src from))
213     ;; both are NIL --> TO is a wildcard which can't be matched
214     ;; either is NIL --> SRC can't be fully matched against FROM, vice versa
215     (throw 'failed-match))
216    ((not (member (car from) '(:wild :wild-inferiors)))
217     (unless (string= (casify (car src) case) (casify (car from) case))
218       (throw 'failed-match)) ;; FROM doesn't match SRC
219     (translate-directory-components-aux (cdr src) (cdr from) to case))
220    ((not (eq (car from) (car to))) ;; TO is NIL while FROM is not, or
221     (throw 'failed-match))         ;; FROM wildcard doesn't match TO wildcard
222    ((eq (car to) :wild)  ;; FROM and TO wildcards are :WILD
223     (cons (casify (car src) case)
224       (translate-directory-components-aux (cdr src) (cdr from) (cdr to) case)))
225    ((eq (car to) :wild-inferiors) ;; FROM and TO wildcards are :WILD-INFERIORS
226     (do ((src (cdr src) (cdr src))
227          (match (list (casify (car src) case))
228                 (cons (casify (car src) case) match)))
229         (NIL) ;; we'll exit the loop in different ways
230       (catch 'failed-match
231         (return-from translate-directory-components-aux
232           (append (reverse match) 
233                   (translate-directory-components-aux
234                    src (cdr from) (cdr to) case))))
235       (when (null src) ;; SRC is NIL and we're still here: error exit
236         (throw 'failed-match))))))
237
238(defun translate-directory-components (src from to case)
239  (catch 'failed-match
240    (return-from translate-directory-components
241      (translate-directory-components-aux src from to case)))
242  (error "Unsupported case in TRANSLATE-DIRECTORY-COMPONENTS."))
243
244
245(defun translate-directory (source from to case)
246  ;; FIXME The IGNORE-CASE argument to DIRECTORY-MATCH-P should not be nil on
247  ;; Windows or if the source pathname is a logical pathname.
248  ;; FIXME We can canonicalize logical pathnames to upper case, so we only need
249  ;; IGNORE-CASE for Windows.
250  (cond ((null source)
251         to)
252        ((equal source '(:absolute))
253         (remove :wild-inferiors to))
254        (t
255         (translate-directory-components source from to case))))
256
257;; "The resulting pathname is TO-WILDCARD with each wildcard or missing field
258;; replaced by a portion of SOURCE."
259(defun translate-pathname (source from-wildcard to-wildcard &key)
260  (unless (pathname-match-p source from-wildcard)
261    (error "~S and ~S do not match." source from-wildcard))
262  (let* ((source (pathname source))
263         (from   (pathname from-wildcard))
264         (to     (pathname to-wildcard))
265         (device (if (typep 'to 'logical-pathname)
266                     :unspecific
267                     (translate-component (pathname-device source)
268                                          (pathname-device from)
269                                          (pathname-device to))))
270         (case   (and (typep source 'logical-pathname)
271                      (or (featurep :unix) (featurep :windows))
272                      :downcase)))
273    (make-pathname :host      (pathname-host to)
274                   :device    (cond ((typep to 'logical-pathname)
275                                     :unspecific)
276                                    ((eq device :unspecific)
277                                     nil)
278                                    (t
279                                     device))
280                   :directory (translate-directory (pathname-directory source)
281                                                   (pathname-directory from)
282                                                   (pathname-directory to)
283                                                   case)
284                   :name      (translate-component (pathname-name source)
285                                                   (pathname-name from)
286                                                   (pathname-name to)
287                                                   case)
288                   :type      (translate-component (pathname-type source)
289                                                   (pathname-type from)
290                                                   (pathname-type to)
291                                                   case)
292                   :version   (if (null (pathname-host from))
293                                  (if (eq (pathname-version to) :wild)
294                                      (pathname-version from)
295                                      (pathname-version to))
296                                  (translate-component (pathname-version source)
297                                                       (pathname-version from)
298                                                       (pathname-version to))))))
299
300(defun logical-host-p (canonical-host)
301  (multiple-value-bind (translations present)
302      (gethash canonical-host *logical-pathname-translations*)
303    (declare (ignore translations))
304    present))
305
306(defun logical-pathname-translations (host)
307  (multiple-value-bind (translations present)
308      (gethash (canonicalize-logical-host host) *logical-pathname-translations*)
309    (unless present
310      (error 'type-error
311             :datum host
312             :expected-type '(and string (satisfies logical-host-p))))
313    translations))
314
315(defun canonicalize-logical-pathname-translations (translations host)
316  (let (result)
317    (dolist (translation translations (nreverse result))
318      (let ((from (car translation))
319            (to (cadr translation)))
320        (push (list (if (typep from 'logical-pathname)
321                        from
322                        (parse-namestring from host))
323                    (pathname to))
324              result)))))
325
326(defun %set-logical-pathname-translations (host translations)
327  (setf host (canonicalize-logical-host host))
328  ;; Avoid undefined host error in CANONICALIZE-LOGICAL-PATHNAME-TRANSLATIONS.
329  (unless (logical-host-p host)
330    (setf (gethash host *logical-pathname-translations*) nil))
331  (setf (gethash host *logical-pathname-translations*)
332        (canonicalize-logical-pathname-translations translations host)))
333
334(defsetf logical-pathname-translations %set-logical-pathname-translations)
335
336(defun translate-logical-pathname (pathname &key)
337  (typecase pathname
338    (logical-pathname
339     (let* ((host (pathname-host pathname))
340            (translations (logical-pathname-translations host)))
341       (dolist (translation translations
342                            (error 'file-error
343                                   :pathname pathname
344                                   :format-control "No translation for ~S"
345                                   :format-arguments (list pathname)))
346         (let ((from-wildcard (car translation))
347               (to-wildcard (cadr translation)))
348           (when (pathname-match-p pathname from-wildcard)
349             (return (translate-logical-pathname
350                      (translate-pathname pathname from-wildcard to-wildcard))))))))
351    (pathname pathname)
352    (t
353     (translate-logical-pathname (pathname pathname)))))
354
355(defun load-logical-pathname-translations (host)
356  (declare (type string host))
357  (multiple-value-bind (ignore found)
358      (gethash (canonicalize-logical-host host)
359               *logical-pathname-translations*)
360    (declare (ignore ignore))
361    (unless found
362      (error "The logical host ~S was not found." host))))
363
364(defun logical-pathname (pathspec)
365  (typecase pathspec
366    (logical-pathname pathspec)
367    (string
368     (%make-logical-pathname pathspec))
369    (stream
370     (let ((result (pathname pathspec)))
371       (if (typep result 'logical-pathname)
372           result
373           (error 'simple-type-error
374                  :datum result
375                  :expected-type 'logical-pathname))))
376    (t
377     (error 'type-error
378            :datum pathspec
379            :expected-type '(or logical-pathname string stream)))))
380
381(defun parse-namestring (thing
382                         &optional host (default-pathname *default-pathname-defaults*)
383                         &key (start 0) end junk-allowed)
384  (declare (ignore junk-allowed)) ; FIXME
385  (cond ((eq host :unspecific)
386         (setf host nil))
387        (host
388         (setf host (canonicalize-logical-host host))))
389  (typecase thing
390    (stream
391     (values (pathname thing) start))
392    (pathname
393     (values thing start))
394    (string
395     (unless end
396       (setf end (length thing)))
397     (%parse-namestring (subseq thing start end) host default-pathname))
398    (t
399     (error 'type-error
400            :format-control "~S cannot be converted to a pathname."
401            :format-arguments (list thing)))))
Note: See TracBrowser for help on using the repository browser.