source: trunk/j/src/org/armedbear/lisp/pathnames.lisp @ 9997

Last change on this file since 9997 was 9997, checked in by piso, 16 years ago

Moved CANONICALIZE-LOGICAL-HOST to LogicalPathname?.java.

File size: 13.4 KB
Line 
1;;; pathnames.lisp
2;;;
3;;; Copyright (C) 2003-2005 Peter Graves
4;;; $Id: pathnames.lisp,v 1.22 2005-09-22 00:24:12 piso Exp $
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., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
19
20(in-package #:system)
21
22(export '(logical-host-p))
23
24(defun pathname-host (pathname &key (case :local))
25  (%pathname-host pathname case))
26
27(defun pathname-device (pathname &key (case :local))
28  (%pathname-device pathname case))
29
30(defun pathname-directory (pathname &key (case :local))
31  (%pathname-directory pathname case))
32
33(defun pathname-name (pathname &key (case :local))
34  (%pathname-name pathname case))
35
36(defun pathname-type (pathname &key (case :local))
37  (%pathname-type pathname case))
38
39(defun wild-pathname-p (pathname &optional field-key)
40  (%wild-pathname-p pathname field-key))
41
42(defun component-match-p (thing wild ignore-case)
43  (cond ((eq wild :wild)
44         t)
45        ((null wild)
46         t)
47        (ignore-case
48         (equalp thing wild))
49        (t
50         (equal thing wild))))
51
52(defun directory-match-components (thing wild ignore-case)
53  (loop
54    (cond ((endp thing)
55           (return (or (endp wild) (equal wild '(:wild-inferiors)))))
56          ((endp wild)
57           (return nil)))
58    (let ((x (car thing))
59          (y (car wild)))
60      (when (eq y :wild-inferiors)
61        (return t))
62      (unless (component-match-p x y ignore-case)
63        (return nil))
64      (setf thing (cdr thing)
65            wild  (cdr wild)))))
66
67(defun directory-match-p (thing wild ignore-case)
68  (cond ((eq wild :wild)
69         t)
70        ((null wild)
71         t)
72        ((and ignore-case (equalp thing wild))
73         t)
74        ((equal thing wild)
75         t)
76        ((and (null thing) (equal wild '(:absolute :wild-inferiors)))
77         t)
78        ((and (consp thing) (consp wild))
79         (if (eq (%car thing) (%car wild))
80             (directory-match-components (%cdr thing) (%cdr wild) ignore-case)
81             nil))
82        (t
83         nil)))
84
85(defun pathname-match-p (pathname wildcard)
86  (setf pathname (pathname pathname)
87        wildcard (pathname wildcard))
88  (unless (component-match-p (pathname-host pathname) (pathname-host wildcard) nil)
89    (return-from pathname-match-p nil))
90  (let* ((windows-p (featurep :windows))
91         (ignore-case (or windows-p (typep pathname 'logical-pathname))))
92    (cond ((and windows-p
93                (not (component-match-p (pathname-device pathname)
94                                        (pathname-device wildcard)
95                                        ignore-case)))
96           nil)
97          ((not (directory-match-p (pathname-directory pathname)
98                                   (pathname-directory wildcard)
99                                   ignore-case))
100           nil)
101          ((not (component-match-p (pathname-name pathname)
102                                   (pathname-name wildcard)
103                                   ignore-case))
104           nil)
105          ((not (component-match-p (pathname-type pathname)
106                                   (pathname-type wildcard)
107                                   ignore-case))
108           nil)
109          (t
110           t))))
111
112(defun wild-p (component)
113  (or (eq component :wild)
114      (and (stringp component)
115           (position #\* component))))
116
117(defun casify (thing case)
118  (typecase thing
119    (string
120     (case case
121       (:upcase (string-upcase thing))
122       (:downcase (string-downcase thing))
123       (t thing)))
124    (list
125     (let (result)
126       (dolist (component thing (nreverse result))
127         (push (casify component case) result))))
128    (t
129     thing)))
130
131(defun split-directory-components (directory)
132  (declare (optimize safety))
133  (declare (type list directory))
134  (unless (memq (car directory) '(:absolute :relative))
135    (error "Ill-formed directory list: ~S" directory))
136  (let (result sublist)
137    (push (car directory) result)
138    (dolist (component (cdr directory))
139      (cond ((memq component '(:wild :wild-inferiors))
140             (when sublist
141               (push (nreverse sublist) result)
142               (setf sublist nil))
143             (push component result))
144            (t
145             (push component sublist))))
146    (when sublist
147      (push (nreverse sublist) result))
148    (nreverse result)))
149
150(defun translate-component (source from to &optional case)
151  (cond ((or (eq to :wild) (null to))
152         ;; "If the piece in TO-WILDCARD is :WILD or NIL, the piece in source
153         ;; is copied into the result."
154         (casify source case))
155        ((and to (not (wild-p to)))
156        ;; "If the piece in TO-WILDCARD is present and not wild, it is copied
157        ;; into the result."
158         to)
159        (t
160         ;; "Otherwise, the piece in TO-WILDCARD might be a complex wildcard
161         ;; such as "foo*bar" and the piece in FROM-WILDCARD should be wild;
162         ;; the portion of the piece in SOURCE that matches the wildcard
163         ;; portion of the piece in FROM-WILDCARD replaces the wildcard portion
164         ;; of the piece in TO-WILDCARD and the value produced is used in the
165         ;; result."
166         ;; FIXME
167         (error "Unsupported TO-WILDCARD pattern: ~S" to))))
168
169(defun translate-directory-components (source from to case)
170  (cond ((null to)
171         nil
172         )
173        ((memq (car to) '(:absolute :relative))
174         (cons (car to)
175               (translate-directory-components (cdr source) (cdr from) (cdr to) case))
176         )
177        ((eq (car to) :wild)
178         (if (eq (car from) :wild)
179             ;; Grab the next chunk from SOURCE.
180             (append (casify (car source) case)
181                     (translate-directory-components (cdr source) (cdr from) (cdr to) case))
182             (error "Unsupported case 1: ~S ~S ~S" source from to))
183         )
184        ((eq (car to) :wild-inferiors)
185         ;; Grab the next chunk from SOURCE.
186         (append (casify (car source) case)
187                 (translate-directory-components (cdr source) (cdr from) (cdr to) case))
188         )
189        (t
190         ;; "If the piece in TO-WILDCARD is present and not wild, it is copied
191         ;; into the result."
192         (append (casify (car to) case)
193                 (translate-directory-components source from (cdr to) case))
194         )
195        ))
196
197(defun translate-directory (source from to case)
198  ;; FIXME The IGNORE-CASE argument to DIRECTORY-MATCH-P should not be nil on
199  ;; Windows or if the source pathname is a logical pathname.
200  ;; FIXME We can canonicalize logical pathnames to upper case, so we only need
201  ;; IGNORE-CASE for Windows.
202  (cond ((null source)
203         to)
204        ((equal source '(:absolute))
205         (remove :wild-inferiors to))
206        (t
207         (translate-directory-components (split-directory-components source)
208                                         (split-directory-components from)
209                                         (split-directory-components to)
210                                         case))))
211
212;; "The resulting pathname is TO-WILDCARD with each wildcard or missing field
213;; replaced by a portion of SOURCE."
214(defun translate-pathname (source from-wildcard to-wildcard &key)
215  (unless (pathname-match-p source from-wildcard)
216    (error "~S and ~S do not match." source from-wildcard))
217  (let ((source (pathname source))
218        (from   (pathname from-wildcard))
219        (to     (pathname to-wildcard))
220        (case   (and (typep source 'logical-pathname)
221                     (featurep :unix)
222                     :downcase)))
223    (make-pathname :host      (pathname-host to)
224                   :device    (translate-component (pathname-device source)
225                                                   (pathname-device from)
226                                                   (pathname-device to))
227                   :directory (translate-directory (pathname-directory source)
228                                                   (pathname-directory from)
229                                                   (pathname-directory to)
230                                                   case)
231                   :name      (translate-component (pathname-name source)
232                                                   (pathname-name from)
233                                                   (pathname-name to)
234                                                   case)
235                   :type      (translate-component (pathname-type source)
236                                                   (pathname-type from)
237                                                   (pathname-type to)
238                                                   case)
239                   :version   (if (null (pathname-host from))
240                                  (if (eq (pathname-version to) :wild)
241                                      (pathname-version from)
242                                      (pathname-version to))
243                                  (translate-component (pathname-version source)
244                                                       (pathname-version from)
245                                                       (pathname-version to))))))
246
247;; (defun canonicalize-logical-host (host)
248;;   (string-upcase host))
249
250(defun logical-host-p (canonical-host)
251  (multiple-value-bind (translations present)
252      (gethash canonical-host *logical-pathname-translations*)
253    (declare (ignore translations))
254    present))
255
256(defun logical-pathname-translations (host)
257  (multiple-value-bind (translations present)
258      (gethash (canonicalize-logical-host host) *logical-pathname-translations*)
259    (unless present
260      (error 'type-error
261             :datum host
262             :expected-type '(and string (satisfies logical-host-p))))
263    translations))
264
265(defun canonicalize-logical-pathname-translations (translations host)
266  (let (result)
267    (dolist (translation translations (nreverse result))
268      (let ((from (car translation))
269            (to (cadr translation)))
270        (push (list (if (typep from 'logical-pathname)
271                        from
272                        (parse-namestring from host))
273                    (pathname to))
274              result)))))
275
276(defun %set-logical-pathname-translations (host translations)
277  (setf host (canonicalize-logical-host host))
278  ;; Avoid undefined host error in CANONICALIZE-LOGICAL-PATHNAME-TRANSLATIONS.
279  (unless (logical-host-p host)
280    (setf (gethash host *logical-pathname-translations*) nil))
281  (setf (gethash host *logical-pathname-translations*)
282        (canonicalize-logical-pathname-translations translations host)))
283
284(defsetf logical-pathname-translations %set-logical-pathname-translations)
285
286(defun translate-logical-pathname (pathname &key)
287  (typecase pathname
288    (logical-pathname
289     (let* ((host (pathname-host pathname))
290            (translations (logical-pathname-translations host)))
291       (dolist (translation translations
292                            (error 'file-error
293                                   :pathname pathname
294                                   :format-control "No translation for ~S"
295                                   :format-arguments (list pathname)))
296         (let ((from-wildcard (car translation))
297               (to-wildcard (cadr translation)))
298           (when (pathname-match-p pathname from-wildcard)
299             (return (translate-logical-pathname
300                      (translate-pathname pathname from-wildcard to-wildcard))))))))
301    (pathname pathname)
302    (t
303     (translate-logical-pathname (pathname pathname)))))
304
305(defun load-logical-pathname-translations (host)
306  (declare (type string host))
307  (multiple-value-bind (ignore found)
308      (gethash (canonicalize-logical-host host)
309               *logical-pathname-translations*)
310    (declare (ignore ignore))
311    (unless found
312      (error "The logical host ~S was not found." host))))
313
314(defun logical-pathname (pathspec)
315  (typecase pathspec
316    (logical-pathname pathspec)
317    (string
318     (%make-logical-pathname pathspec))
319    (stream
320     (let ((result (pathname pathspec)))
321       (if (typep result 'logical-pathname)
322           result
323           (error 'simple-type-error
324                  :datum result
325                  :expected-type 'logical-pathname))))
326    (t
327     (error 'type-error
328            :datum pathspec
329            :expected-type '(or logical-pathname string stream)))))
330
331(defun parse-namestring (thing
332                         &optional host default-pathname
333                         &key (start 0) end junk-allowed)
334  (declare (ignore default-pathname junk-allowed)) ; FIXME
335  (cond ((eq host :unspecific)
336         (setf host nil))
337        (host
338         (setf host (canonicalize-logical-host host))))
339  (typecase thing
340    (stream
341     (values (pathname thing) start))
342    (pathname
343     (values thing start))
344    (string
345     (unless end
346       (setf end (length thing)))
347     (values (coerce-to-pathname thing host)
348             end))
349    (t
350     (error 'type-error
351            :format-control "~S cannot be converted to a pathname."
352            :format-arguments (list thing)))))
Note: See TracBrowser for help on using the repository browser.