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

Last change on this file since 12284 was 12284, checked in by ehuelsmann, 12 years ago

Delete unused function (split-directory-components).

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 15.7 KB
Line 
1;;; pathnames.lisp
2;;;
3;;; Copyright (C) 2003-2007 Peter Graves
4;;; $Id: pathnames.lisp 12284 2009-11-26 15:10:04Z ehuelsmann $
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 src from (cdr to) case)))
207    ((not (and src from))
208     ;; both are NIL --> TO is a wildcard which can't be matched
209     ;; either is NIL --> SRC can't be fully matched against FROM, vice versa
210     (throw 'failed-match))
211    ((not (member (car from) '(:wild :wild-inferiors)))
212     (unless (string= (casify (car src) case) (casify (car from) case))
213       (throw 'failed-match)) ;; FROM doesn't match SRC
214     (translate-directory-components-aux (cdr src) (cdr from) to case))
215    ((not (eq (car from) (car to))) ;; TO is NIL while FROM is not, or
216     (throw 'failed-match))         ;; FROM wildcard doesn't match TO wildcard
217    ((eq (car to) :wild)  ;; FROM and TO wildcards are :WILD
218     (cons (casify (car src) case)
219       (translate-directory-components-aux (cdr src) (cdr from) (cdr to) case)))
220    ((eq (car to) :wild-inferiors) ;; FROM and TO wildcards are :WILD-INFERIORS
221     (do ((src (cdr src) (cdr src))
222          (match (list (casify (car src) case))
223                 (cons (casify (car src) case) match)))
224         (NIL) ;; we'll exit the loop in different ways
225       (catch 'failed-match
226         (return-from translate-directory-components-aux
227           (append (reverse match) (translate-directory-components-aux
228                                        src (cdr from) (cdr to) case))))
229       (when (null src) ;; SRC is NIL and we're still here: error exit
230         (throw 'failed-match))))))
231
232(defun translate-directory-components (src from to case)
233  (catch 'failed-match
234    (return-from translate-directory-components
235      (translate-directory-components-aux src from to case)))
236  (error "Unsupported case in TRANSLATE-DIRECTORY-COMPONENTS."))
237
238
239(defun translate-directory (source from to case)
240  ;; FIXME The IGNORE-CASE argument to DIRECTORY-MATCH-P should not be nil on
241  ;; Windows or if the source pathname is a logical pathname.
242  ;; FIXME We can canonicalize logical pathnames to upper case, so we only need
243  ;; IGNORE-CASE for Windows.
244  (cond ((null source)
245         to)
246        ((equal source '(:absolute))
247         (remove :wild-inferiors to))
248        (t
249         (translate-directory-components source from to case))))
250
251;; "The resulting pathname is TO-WILDCARD with each wildcard or missing field
252;; replaced by a portion of SOURCE."
253(defun translate-pathname (source from-wildcard to-wildcard &key)
254  (unless (pathname-match-p source from-wildcard)
255    (error "~S and ~S do not match." source from-wildcard))
256  (let* ((source (pathname source))
257         (from   (pathname from-wildcard))
258         (to     (pathname to-wildcard))
259         (device (if (typep 'to 'logical-pathname)
260                     :unspecific
261                     (translate-component (pathname-device source)
262                                          (pathname-device from)
263                                          (pathname-device to))))
264         (case   (and (typep source 'logical-pathname)
265                      (or (featurep :unix) (featurep :windows))
266                      :downcase)))
267    (make-pathname :host      (pathname-host to)
268                   :device    (cond ((typep to 'logical-pathname)
269                                     :unspecific)
270                                    ((eq device :unspecific)
271                                     nil)
272                                    (t
273                                     device))
274                   :directory (translate-directory (pathname-directory source)
275                                                   (pathname-directory from)
276                                                   (pathname-directory to)
277                                                   case)
278                   :name      (translate-component (pathname-name source)
279                                                   (pathname-name from)
280                                                   (pathname-name to)
281                                                   case)
282                   :type      (translate-component (pathname-type source)
283                                                   (pathname-type from)
284                                                   (pathname-type to)
285                                                   case)
286                   :version   (if (null (pathname-host from))
287                                  (if (eq (pathname-version to) :wild)
288                                      (pathname-version from)
289                                      (pathname-version to))
290                                  (translate-component (pathname-version source)
291                                                       (pathname-version from)
292                                                       (pathname-version to))))))
293
294(defun logical-host-p (canonical-host)
295  (multiple-value-bind (translations present)
296      (gethash canonical-host *logical-pathname-translations*)
297    (declare (ignore translations))
298    present))
299
300(defun logical-pathname-translations (host)
301  (multiple-value-bind (translations present)
302      (gethash (canonicalize-logical-host host) *logical-pathname-translations*)
303    (unless present
304      (error 'type-error
305             :datum host
306             :expected-type '(and string (satisfies logical-host-p))))
307    translations))
308
309(defun canonicalize-logical-pathname-translations (translations host)
310  (let (result)
311    (dolist (translation translations (nreverse result))
312      (let ((from (car translation))
313            (to (cadr translation)))
314        (push (list (if (typep from 'logical-pathname)
315                        from
316                        (parse-namestring from host))
317                    (pathname to))
318              result)))))
319
320(defun %set-logical-pathname-translations (host translations)
321  (setf host (canonicalize-logical-host host))
322  ;; Avoid undefined host error in CANONICALIZE-LOGICAL-PATHNAME-TRANSLATIONS.
323  (unless (logical-host-p host)
324    (setf (gethash host *logical-pathname-translations*) nil))
325  (setf (gethash host *logical-pathname-translations*)
326        (canonicalize-logical-pathname-translations translations host)))
327
328(defsetf logical-pathname-translations %set-logical-pathname-translations)
329
330(defun translate-logical-pathname (pathname &key)
331  (typecase pathname
332    (logical-pathname
333     (let* ((host (pathname-host pathname))
334            (translations (logical-pathname-translations host)))
335       (dolist (translation translations
336                            (error 'file-error
337                                   :pathname pathname
338                                   :format-control "No translation for ~S"
339                                   :format-arguments (list pathname)))
340         (let ((from-wildcard (car translation))
341               (to-wildcard (cadr translation)))
342           (when (pathname-match-p pathname from-wildcard)
343             (return (translate-logical-pathname
344                      (translate-pathname pathname from-wildcard to-wildcard))))))))
345    (pathname pathname)
346    (t
347     (translate-logical-pathname (pathname pathname)))))
348
349(defun load-logical-pathname-translations (host)
350  (declare (type string host))
351  (multiple-value-bind (ignore found)
352      (gethash (canonicalize-logical-host host)
353               *logical-pathname-translations*)
354    (declare (ignore ignore))
355    (unless found
356      (error "The logical host ~S was not found." host))))
357
358(defun logical-pathname (pathspec)
359  (typecase pathspec
360    (logical-pathname pathspec)
361    (string
362     (%make-logical-pathname pathspec))
363    (stream
364     (let ((result (pathname pathspec)))
365       (if (typep result 'logical-pathname)
366           result
367           (error 'simple-type-error
368                  :datum result
369                  :expected-type 'logical-pathname))))
370    (t
371     (error 'type-error
372            :datum pathspec
373            :expected-type '(or logical-pathname string stream)))))
374
375(defun parse-namestring (thing
376                         &optional host (default-pathname *default-pathname-defaults*)
377                         &key (start 0) end junk-allowed)
378  (declare (ignore junk-allowed)) ; FIXME
379  (cond ((eq host :unspecific)
380         (setf host nil))
381        (host
382         (setf host (canonicalize-logical-host host))))
383  (typecase thing
384    (stream
385     (values (pathname thing) start))
386    (pathname
387     (values thing start))
388    (string
389     (unless end
390       (setf end (length thing)))
391     (%parse-namestring (subseq thing start end) host default-pathname))
392    (t
393     (error 'type-error
394            :format-control "~S cannot be converted to a pathname."
395            :format-arguments (list thing)))))
Note: See TracBrowser for help on using the repository browser.