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

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

Minor cleanup.

File size: 13.3 KB
Line 
1;;; pathnames.lisp
2;;;
3;;; Copyright (C) 2003-2005 Peter Graves
4;;; $Id: pathnames.lisp,v 1.23 2005-09-22 00:24:42 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 logical-host-p (canonical-host)
248  (multiple-value-bind (translations present)
249      (gethash canonical-host *logical-pathname-translations*)
250    (declare (ignore translations))
251    present))
252
253(defun logical-pathname-translations (host)
254  (multiple-value-bind (translations present)
255      (gethash (canonicalize-logical-host host) *logical-pathname-translations*)
256    (unless present
257      (error 'type-error
258             :datum host
259             :expected-type '(and string (satisfies logical-host-p))))
260    translations))
261
262(defun canonicalize-logical-pathname-translations (translations host)
263  (let (result)
264    (dolist (translation translations (nreverse result))
265      (let ((from (car translation))
266            (to (cadr translation)))
267        (push (list (if (typep from 'logical-pathname)
268                        from
269                        (parse-namestring from host))
270                    (pathname to))
271              result)))))
272
273(defun %set-logical-pathname-translations (host translations)
274  (setf host (canonicalize-logical-host host))
275  ;; Avoid undefined host error in CANONICALIZE-LOGICAL-PATHNAME-TRANSLATIONS.
276  (unless (logical-host-p host)
277    (setf (gethash host *logical-pathname-translations*) nil))
278  (setf (gethash host *logical-pathname-translations*)
279        (canonicalize-logical-pathname-translations translations host)))
280
281(defsetf logical-pathname-translations %set-logical-pathname-translations)
282
283(defun translate-logical-pathname (pathname &key)
284  (typecase pathname
285    (logical-pathname
286     (let* ((host (pathname-host pathname))
287            (translations (logical-pathname-translations host)))
288       (dolist (translation translations
289                            (error 'file-error
290                                   :pathname pathname
291                                   :format-control "No translation for ~S"
292                                   :format-arguments (list pathname)))
293         (let ((from-wildcard (car translation))
294               (to-wildcard (cadr translation)))
295           (when (pathname-match-p pathname from-wildcard)
296             (return (translate-logical-pathname
297                      (translate-pathname pathname from-wildcard to-wildcard))))))))
298    (pathname pathname)
299    (t
300     (translate-logical-pathname (pathname pathname)))))
301
302(defun load-logical-pathname-translations (host)
303  (declare (type string host))
304  (multiple-value-bind (ignore found)
305      (gethash (canonicalize-logical-host host)
306               *logical-pathname-translations*)
307    (declare (ignore ignore))
308    (unless found
309      (error "The logical host ~S was not found." host))))
310
311(defun logical-pathname (pathspec)
312  (typecase pathspec
313    (logical-pathname pathspec)
314    (string
315     (%make-logical-pathname pathspec))
316    (stream
317     (let ((result (pathname pathspec)))
318       (if (typep result 'logical-pathname)
319           result
320           (error 'simple-type-error
321                  :datum result
322                  :expected-type 'logical-pathname))))
323    (t
324     (error 'type-error
325            :datum pathspec
326            :expected-type '(or logical-pathname string stream)))))
327
328(defun parse-namestring (thing
329                         &optional host default-pathname
330                         &key (start 0) end junk-allowed)
331  (declare (ignore default-pathname junk-allowed)) ; FIXME
332  (cond ((eq host :unspecific)
333         (setf host nil))
334        (host
335         (setf host (canonicalize-logical-host host))))
336  (typecase thing
337    (stream
338     (values (pathname thing) start))
339    (pathname
340     (values thing start))
341    (string
342     (unless end
343       (setf end (length thing)))
344     (values (coerce-to-pathname thing host)
345             end))
346    (t
347     (error 'type-error
348            :format-control "~S cannot be converted to a pathname."
349            :format-arguments (list thing)))))
Note: See TracBrowser for help on using the repository browser.