/[cmucl]/src/code/pathname.lisp
ViewVC logotype

Contents of /src/code/pathname.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.5 - (hide annotations)
Sun Dec 22 01:44:14 1991 UTC (22 years, 4 months ago) by ram
Branch: MAIN
Changes since 1.4: +2 -2 lines
Changed WITH-PATHNAME to call PARSE-NAMESTRING on the result of FILE-NAME.
1 wlott 1.1 ;;; -*- Package: LISP -*-
2     ;;; **********************************************************************
3     ;;; This code was written as part of the CMU Common Lisp project at
4     ;;; Carnegie Mellon University, and has been placed in the public domain.
5     ;;; If you want to use this code or any part of CMU Common Lisp, please contact
6     ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
7     ;;;
8     (ext:file-comment
9 ram 1.5 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/pathname.lisp,v 1.5 1991/12/22 01:44:14 ram Exp $")
10 wlott 1.1 ;;;
11     ;;; **********************************************************************
12     ;;;
13     ;;; Machine/filesystem independent pathname functions for CMU Common Lisp.
14     ;;;
15     ;;; Written by William Lott
16     ;;; Earlier version written by Jim Large and Rob MacLachlan
17     ;;;
18     ;;; **********************************************************************
19    
20     (in-package "LISP")
21    
22     (export '(pathname pathnamep logical-pathname logical-pathname-p
23     parse-namestring merge-pathnames make-pathname
24     pathname-host pathname-device pathname-directory pathname-name
25     pathname-type pathname-version namestring file-namestring
26     directory-namestring host-namestring enough-namestring
27     wild-pathname-p pathname-match-p translate-pathname
28     translate-logical-pathname logical-pathname-translations
29     load-logical-pathname-translations *default-pathname-defaults*))
30    
31     (in-package "EXTENSIONS")
32     (export '(search-list clear-search-list enumerate-search-list))
33    
34     (in-package "LISP")
35    
36    
37    
38     ;;;; Structures and types.
39    
40     (defstruct (pathname
41     (:conc-name %pathname-)
42     (:print-function %print-pathname)
43     (:constructor
44     %make-pathname (host device directory name type version))
45     (:predicate pathnamep)
46     (:make-load-form-fun :just-dump-it-normally))
47     "Pathname is the structure of the file pathname. It consists of a
48     host, a device, a directory, a name, and a type."
49     (host nil :type (or host null))
50     (device nil :type (member nil :unspecific))
51     (directory nil :type list)
52     (name nil :type (or simple-string pattern null))
53     (type nil :type (or simple-string pattern null (member :unspecific)))
54     (version nil :type (or integer null (member :newest :wild))))
55    
56     (defun %print-pathname (pathname stream depth)
57     (declare (ignore depth))
58     (let ((namestring (handler-case (namestring pathname)
59     (error nil))))
60     (cond (namestring
61     (format stream "#p~S" namestring))
62     (*print-readably*
63     (error "~S Cannot be printed readably." pathname))
64     (*print-pretty*
65     (pprint-logical-block (stream nil :prefix "#<" :suffix ">")
66     (funcall (formatter
67     "~2IUnprintable pathname: ~_Host=~S, ~_Device=~S, ~_~
68     Directory=~:/LISP:PPRINT-FILL/, ~_Name=~S, ~_~
69     Type=~S, ~_Version=~S")
70     stream
71     (%pathname-host pathname)
72     (%pathname-device pathname)
73     (%pathname-directory pathname)
74     (%pathname-name pathname)
75     (%pathname-type pathname)
76     (%pathname-version pathname))))
77     (t
78     (funcall (formatter "#<Unprintable pathname, Host=~S, Device=~S, ~
79     Directory=~S, File=~S, Name=~S, Version=~S>")
80     stream
81     (%pathname-host pathname)
82     (%pathname-device pathname)
83     (%pathname-directory pathname)
84     (%pathname-name pathname)
85     (%pathname-type pathname)
86     (%pathname-version pathname))))))
87    
88     (defstruct (host
89     (:print-function %print-host))
90     (parse (required-argument) :type function)
91     (unparse (required-argument) :type function)
92     (unparse-host (required-argument) :type function)
93     (unparse-directory (required-argument) :type function)
94     (unparse-file (required-argument) :type function)
95     (unparse-enough (required-argument) :type function)
96     (customary-case (required-argument) :type (member :upper :lower)))
97    
98     (defun %print-host (host stream depth)
99     (declare (ignore depth))
100     (print-unreadable-object (host stream :type t :identity t)))
101    
102    
103     ;;;; Patterns
104    
105     (defstruct (pattern
106     (:print-function %print-pattern)
107     (:make-load-form-fun :just-dump-it-normally)
108     (:constructor make-pattern (pieces)))
109     (pieces nil :type list))
110    
111     (defun %print-pattern (pattern stream depth)
112     (declare (ignore depth))
113     (print-unreadable-object (pattern stream :type t)
114     (if *print-pretty*
115     (let ((*print-escape* t))
116     (pprint-fill stream (pattern-pieces pattern) nil))
117     (prin1 (pattern-pieces pattern) stream))))
118    
119     (defun pattern= (pattern1 pattern2)
120     (declare (type pattern pattern1 pattern2))
121     (let ((pieces1 (pattern-pieces pattern1))
122     (pieces2 (pattern-pieces pattern2)))
123     (and (= (length pieces1) (length pieces2))
124     (every #'(lambda (piece1 piece2)
125     (typecase piece1
126     (simple-string
127     (and (simple-string-p piece2)
128     (string= piece1 piece2)))
129     (cons
130     (and (consp piece2)
131     (eq (car piece1) (car piece2))
132     (string= (cdr piece1) (cdr piece2))))
133     (t
134     (eq piece1 piece2))))
135     pieces1
136     pieces2))))
137    
138    
139    
140     ;;;; Utilities.
141    
142     (defun compare-component (this that)
143     (or (eql this that)
144     (typecase this
145     (simple-string
146     (and (simple-string-p that)
147     (string= this that)))
148     (pattern
149     (and (pattern-p that)
150     (pattern= this that)))
151     (cons
152     (and (consp that)
153     (compare-component (car this) (car that))
154     (compare-component (cdr this) (cdr that)))))))
155    
156    
157     ;;;; Logical namestrings
158    
159     #|
160     (defstruct (logical-host
161     (:include host
162     (:parse #'parse-logical-namestring)
163     ...)
164     (:print-function %print-logical-host))
165     name
166     translations)
167    
168     (deftype logical-pathname ()
169     '(satisfies logical-pathname-p))
170    
171     (defun logical-pathname-p (thing)
172     "Return T if THING is a LOGICAL-PATHNAME, and NIL if not."
173     (and (pathnamep thing)
174     (logical-host-p (%pathname-host thing))))
175     |#
176    
177    
178     ;;;; Pathname functions.
179    
180     (defvar *default-pathname-defaults*)
181    
182     (defun pathname= (pathname1 pathname2)
183     (and (eq (%pathname-host pathname1)
184     (%pathname-host pathname2))
185     (compare-component (%pathname-device pathname1)
186     (%pathname-device pathname2))
187     (compare-component (%pathname-directory pathname1)
188     (%pathname-directory pathname2))
189     (compare-component (%pathname-name pathname1)
190     (%pathname-name pathname2))
191     (compare-component (%pathname-type pathname1)
192     (%pathname-type pathname2))
193     (compare-component (%pathname-version pathname1)
194     (%pathname-version pathname2))))
195    
196     (defmacro with-pathname ((var expr) &body body)
197     `(let ((,var (let ((,var ,expr))
198     (etypecase ,var
199     (pathname ,var)
200     (string (parse-namestring ,var))
201 ram 1.5 (stream (parse-namestring (file-name ,var)))))))
202 wlott 1.1 ,@body))
203    
204     (defun %print-namestring-parse-error (condition stream)
205     (format stream "Parse error in namestring: ~?~% ~A~% ~V@T^"
206     (namestring-parse-error-complaint condition)
207     (namestring-parse-error-arguments condition)
208     (namestring-parse-error-namestring condition)
209     (namestring-parse-error-offset condition)))
210    
211     (define-condition namestring-parse-error (error)
212     ((complaint (required-argument))
213     (arguments nil)
214     (namestring (required-argument))
215     (offset (required-argument)))
216     (:report %print-namestring-parse-error))
217    
218     (defun %parse-namestring (namestr start end host junk-allowed)
219     (declare (type string namestr)
220     (type index start end)
221     (type host host)
222     (values (or null pathname) index))
223     (cond (junk-allowed
224     (handler-case (%parse-namestring namestr start end host nil)
225     (namestring-parse-error (condition)
226     (values nil
227     (namestring-parse-error-offset condition)))))
228     ((simple-string-p namestr)
229     (multiple-value-bind
230     (new-host device directory file type version)
231     (funcall (host-parse host) namestr start end)
232     (values (%make-pathname (or new-host host)
233     device directory file type version)
234     end)))
235     (t
236     (%parse-namestring (coerce namestr 'simple-string)
237     start end host nil))))
238    
239     (defun parse-namestring (thing
240     &optional host (defaults *default-pathname-defaults*)
241     &key (start 0) end junk-allowed)
242     (declare (type pathnamelike thing)
243     (type (or null host) host)
244     (type pathnamelike defaults)
245     (type index start)
246     (type (or index null) end)
247     (type (or null (not null)) junk-allowed)
248     (values pathname index))
249     (if (stringp thing)
250     (%parse-namestring thing start (or end (length thing))
251     (or host
252     (with-pathname (defaults defaults)
253     (%pathname-host defaults)))
254     junk-allowed)
255     (with-pathname (pathname thing)
256     (when host
257     (unless (eq host (%pathname-host pathname))
258     (error "Hosts do not match: ~S and ~S."
259     host
260     (%pathname-host pathname))))
261     (values pathname start))))
262    
263     (defun pathname (thing)
264     (declare (type pathnamelike thing))
265     (with-pathname (pathname thing)
266     pathname))
267    
268     (defun maybe-diddle-case (thing diddle-p)
269     (declare (type (or list pattern simple-base-string (member :unspecific))
270     thing)
271     (values (or list pattern simple-base-string (member :unspecific))))
272     (if diddle-p
273     (labels ((check-for (pred in)
274     (etypecase in
275     (pattern
276     (dolist (piece (pattern-pieces in))
277     (when (typecase piece
278     (simple-string
279     (check-for pred piece))
280     (cons
281     (case (car in)
282     (:character-set
283     (check-for pred (cdr in))))))
284     (return t))))
285     (list
286     (dolist (x in)
287     (when (check-for pred x)
288     (return t))))
289     (simple-base-string
290     (dotimes (i (length in))
291     (when (funcall pred (schar in i))
292     (return t))))
293     ((member :unspecific)
294     nil)))
295     (diddle-with (fun thing)
296     (etypecase thing
297     (pattern
298     (make-pattern
299     (mapcar #'(lambda (piece)
300     (typecase piece
301     (simple-base-string
302     (funcall fun thing))
303     (cons
304     (case (car piece)
305     (:character-set
306     (cons :character-set
307     (funcall fun (cdr piece))))
308     (t
309     piece)))
310     (t
311     piece)))
312     (pattern-pieces thing))))
313     (list
314     (mapcar fun thing))
315     (simple-base-string
316     (funcall fun thing)))))
317     (let ((any-uppers (check-for #'upper-case-p thing))
318     (any-lowers (check-for #'lower-case-p thing)))
319     (cond ((and any-uppers any-lowers)
320     ;; Mixed case, stays the same.
321     thing)
322     (any-uppers
323     ;; All uppercase, becomes all lower case.
324     (diddle-with #'string-downcase thing))
325     (any-lowers
326     ;; All lowercase, becomes all upper case.
327     (diddle-with #'string-upcase thing))
328     (t
329     ;; No letters? I guess just leave it.
330     thing))))
331     thing))
332    
333     (defun merge-directories (dir1 dir2 diddle-case)
334     (if (eq (car dir1) :absolute)
335     dir1
336     (let ((results nil))
337     (flet ((add (dir)
338     (if (and (eq dir :back)
339     results
340     (not (eq (car results) :back)))
341     (pop results)
342     (push dir results))))
343     (dolist (dir (maybe-diddle-case dir2 diddle-case))
344     (add dir))
345     (dolist (dir (cdr dir1))
346     (add dir)))
347     (reverse results))))
348    
349     (defun merge-pathnames (pathname
350     &optional
351     (defaults *default-pathname-defaults*)
352     (default-version :newest))
353     (with-pathname (defaults defaults)
354 wlott 1.2 (let ((pathname (let ((*default-pathname-defaults* defaults))
355     (pathname pathname))))
356 wlott 1.1 (let* ((default-host (%pathname-host defaults))
357     (pathname-host (%pathname-host pathname))
358     (diddle-case
359     (and default-host pathname-host
360     (not (eq (host-customary-case default-host)
361     (host-customary-case pathname-host))))))
362     (%make-pathname (or pathname-host default-host)
363     (or (%pathname-device pathname)
364     (maybe-diddle-case (%pathname-device defaults)
365     diddle-case))
366     (merge-directories (%pathname-directory pathname)
367     (%pathname-directory defaults)
368     diddle-case)
369     (or (%pathname-name pathname)
370     (maybe-diddle-case (%pathname-name defaults)
371     diddle-case))
372     (or (%pathname-type pathname)
373     (maybe-diddle-case (%pathname-type defaults)
374     diddle-case))
375     (or (%pathname-version pathname)
376     default-version))))))
377    
378     (defun import-directory (directory diddle-case)
379     (etypecase directory
380     (null nil)
381     (list
382     (collect ((results))
383     (ecase (pop directory)
384     (:absolute
385     (results :absolute)
386     (when (search-list-p (car directory))
387     (results (pop directory))))
388     (:relative
389     (results :relative)))
390     (dolist (piece directory)
391     (cond ((eq piece :wild)
392     (results (make-pattern (list :multi-char-wild))))
393     ((eq piece :wild-inferiors)
394     (error ":WILD-INFERIORS not supported."))
395     ((member piece '(:up :back))
396     (results piece))
397     ((or (simple-string-p piece) (pattern-p piece))
398     (results (maybe-diddle-case piece diddle-case)))
399     ((stringp piece)
400     (results (maybe-diddle-case (coerce piece 'simple-string)
401     diddle-case)))
402     (t
403     (error "~S is not allowed as a directory component." piece))))
404     (results)))
405     (simple-string
406     `(:absolute
407     ,(maybe-diddle-case directory diddle-case)))
408     (string
409     `(:absolute
410     ,(maybe-diddle-case (coerce directory 'simple-string)
411     diddle-case)))))
412    
413     (defun make-pathname (&key host device directory name type version
414     defaults (case :local))
415     (declare (type (or host null) host)
416     (type (member nil :unspecific) device)
417     (type (or list string pattern (member :wild)) directory)
418     (type (or null string pattern (member :wild)) name)
419     (type (or null string pattern (member :wild)) type)
420     (type (or null integer (member :wild :newest)) version)
421     (type (or pathnamelike null) defaults)
422     (type (member :common :local) case))
423     (let* ((defaults (if defaults
424     (with-pathname (defaults defaults) defaults)))
425     (default-host (if defaults
426     (%pathname-host defaults)
427     (pathname-host *default-pathname-defaults*)))
428     (host (or host default-host))
429     (diddle-args (and (eq case :common)
430     (eq (host-customary-case host) :lower)))
431     (diddle-defaults
432     (not (eq (host-customary-case host)
433     (host-customary-case default-host)))))
434     (macrolet ((pick (var field)
435     `(cond ((eq ,var :wild)
436     (make-pattern (list :multi-char-wild)))
437     ((or (simple-string-p ,var)
438     (pattern-p ,var))
439     (maybe-diddle-case ,var diddle-args))
440     ((stringp ,var)
441     (maybe-diddle-case (coerce ,var 'simple-string)
442     diddle-args))
443     (,var
444     (maybe-diddle-case ,var diddle-args))
445     (defaults
446     (maybe-diddle-case (,field defaults)
447     diddle-defaults))
448     (t
449     nil))))
450     (%make-pathname
451     host
452     (or device (if defaults (%pathname-device defaults)))
453     (let ((dir (import-directory directory diddle-args)))
454     (if defaults
455     (merge-directories dir
456     (%pathname-directory defaults)
457     diddle-defaults)
458     dir))
459     (pick name %pathname-name)
460     (pick type %pathname-type)
461     (cond
462     (version version)
463     (defaults (%pathname-version defaults))
464     (t nil))))))
465    
466     (defun pathname-host (pathname &key (case :local))
467     (declare (type pathnamelike pathname)
468     (type (member :local :common) case)
469     (ignore case))
470     (with-pathname (pathname pathname)
471     (%pathname-host pathname)))
472    
473     (defun pathname-device (pathname &key (case :local))
474     (declare (type pathnamelike pathname)
475     (type (member :local :common) case))
476     (with-pathname (pathname pathname)
477     (maybe-diddle-case (%pathname-device pathname)
478     (and (eq case :common)
479     (eq (host-customary-case
480     (%pathname-host pathname))
481     :lower)))))
482    
483     (defun pathname-directory (pathname &key (case :local))
484     (declare (type pathnamelike pathname)
485     (type (member :local :common) case))
486     (with-pathname (pathname pathname)
487     (maybe-diddle-case (%pathname-directory pathname)
488     (and (eq case :common)
489     (eq (host-customary-case
490     (%pathname-host pathname))
491     :lower)))))
492    
493     (defun pathname-name (pathname &key (case :local))
494     (declare (type pathnamelike pathname)
495     (type (member :local :common) case))
496     (with-pathname (pathname pathname)
497     (maybe-diddle-case (%pathname-name pathname)
498     (and (eq case :common)
499     (eq (host-customary-case
500     (%pathname-host pathname))
501     :lower)))))
502    
503     (defun pathname-type (pathname &key (case :local))
504     (declare (type pathnamelike pathname)
505     (type (member :local :common) case))
506     (with-pathname (pathname pathname)
507     (maybe-diddle-case (%pathname-type pathname)
508     (and (eq case :common)
509     (eq (host-customary-case
510     (%pathname-host pathname))
511     :lower)))))
512    
513     (defun pathname-version (pathname)
514     (declare (type pathnamelike pathname))
515     (with-pathname (pathname pathname)
516     (%pathname-version pathname)))
517    
518     (defun namestring (pathname)
519     (declare (type pathnamelike pathname))
520     (with-pathname (pathname pathname)
521     (let ((host (%pathname-host pathname)))
522     (if host
523     (funcall (host-unparse host) pathname)
524     (error
525     "Cannot determine the namestring for pathnames with no host:~% ~S"
526     pathname)))))
527    
528     (defun host-namestring (pathname)
529     (declare (type pathnamelike pathname))
530     (with-pathname (pathname pathname)
531     (let ((host (%pathname-host pathname)))
532     (if host
533     (funcall (host-unparse-host host) pathname)
534     (error
535     "Cannot determine the namestring for pathnames with no host:~% ~S"
536     pathname)))))
537    
538     (defun directory-namestring (pathname)
539     (declare (type pathnamelike pathname))
540     (with-pathname (pathname pathname)
541     (let ((host (%pathname-host pathname)))
542     (if host
543     (funcall (host-unparse-directory host) pathname)
544     (error
545     "Cannot determine the namestring for pathnames with no host:~% ~S"
546     pathname)))))
547    
548     (defun file-namestring (pathname)
549     (declare (type pathnamelike pathname))
550     (with-pathname (pathname pathname)
551     (let ((host (%pathname-host pathname)))
552     (if host
553     (funcall (host-unparse-file host) pathname)
554     (error
555     "Cannot determine the namestring for pathnames with no host:~% ~S"
556     pathname)))))
557    
558     (defun enough-namestring (pathname
559     &optional (defaults *default-pathname-defaults*))
560     (declare (type pathnamelike pathname))
561     (with-pathname (pathname pathname)
562     (let ((host (%pathname-host pathname)))
563     (if host
564     (with-pathname (defaults defaults)
565     (funcall (host-unparse-enough host) pathname defaults))
566     (error
567     "Cannot determine the namestring for pathnames with no host:~% ~S"
568     pathname)))))
569    
570    
571     ;;;; Wild pathnames.
572    
573     (defun wild-pathname-p (pathname &optional field-key)
574     (declare (type pathnamelike pathname)
575     (type (member nil :host :device :directory :name :type :version)
576     field-key))
577     (with-pathname (pathname pathname)
578     (ecase field-key
579     ((nil)
580     (or (wild-pathname-p pathname :host)
581     (wild-pathname-p pathname :device)
582     (wild-pathname-p pathname :directory)
583     (wild-pathname-p pathname :name)
584     (wild-pathname-p pathname :type)
585     (wild-pathname-p pathname :version)))
586     (:host
587     (pattern-p (%pathname-host pathname)))
588     (:device
589     (pattern-p (%pathname-host pathname)))
590     (:directory
591     (some #'pattern-p (%pathname-directory pathname)))
592     (:name
593     (pattern-p (%pathname-name pathname)))
594     (:type
595     (pattern-p (%pathname-type pathname)))
596     (:version
597     (eq (%pathname-version pathname) :wild)))))
598    
599     (defun pattern-matches (pattern string)
600     (declare (type pattern pattern)
601     (type simple-string string))
602     (let ((len (length string)))
603     (labels ((maybe-prepend (subs cur-sub chars)
604     (if cur-sub
605     (let* ((len (length chars))
606     (new (make-string len))
607     (index len))
608     (dolist (char chars)
609     (setf (schar new (decf index)) char))
610     (cons new subs))
611     subs))
612     (matches (pieces start subs cur-sub chars)
613     (if (null pieces)
614     (if (= start len)
615     (values t (maybe-prepend subs cur-sub chars))
616     (values nil nil))
617     (let ((piece (car pieces)))
618     (etypecase piece
619     (simple-string
620     (let ((end (+ start (length piece))))
621     (and (<= end len)
622     (string= piece string
623     :start2 start :end2 end)
624     (matches (cdr pieces) end
625     (maybe-prepend subs cur-sub chars)
626     nil nil))))
627     (list
628     (ecase (car piece)
629     (:character-set
630     (and (< start len)
631     (let ((char (schar string start)))
632     (if (find char (cdr piece) :test #'char=)
633     (matches (cdr pieces) (1+ start) subs t
634     (cons char chars))))))))
635     ((member :single-char-wild)
636     (and (< start len)
637     (matches (cdr pieces) (1+ start) subs t
638     (cons (schar string start) chars))))
639     ((member :multi-char-wild)
640     (multiple-value-bind
641     (won new-subs)
642     (matches (cdr pieces) start subs t chars)
643     (if won
644     (values t new-subs)
645     (and (< start len)
646     (matches pieces (1+ start) subs t
647     (cons (schar string start)
648     chars)))))))))))
649     (multiple-value-bind
650     (won subs)
651     (matches (pattern-pieces pattern) 0 nil nil nil)
652     (values won (reverse subs))))))
653    
654     (defun components-match (this that)
655     (or (eq this that)
656     (typecase this
657     (simple-string
658     (typecase that
659     (pattern
660     (values (pattern-matches that this)))
661     (simple-string
662     (string= this that))))
663     (pattern
664     (and (pattern-p that)
665     (pattern= this that)))
666     (cons
667     (and (consp that)
668     (components-match (car this) (car that))
669     (components-match (cdr this) (cdr that))))
670 wlott 1.3 ((member :back :up :unspecific nil)
671 wlott 1.1 (and (pattern-p that)
672     (equal (pattern-pieces that) '(:multi-char-wild)))))))
673    
674     (defun pathname-match-p (pathname wildname)
675     (with-pathname (pathname pathname)
676     (with-pathname (wildname wildname)
677     (macrolet ((frob (field)
678     `(or (null (,field wildname))
679     (components-match (,field pathname)
680     (,field wildname)))))
681     (and (frob %pathname-host)
682     (frob %pathname-device)
683     (frob %pathname-directory)
684     (frob %pathname-name)
685     (frob %pathname-type)
686     (or (null (%pathname-version wildname))
687     (eq (%pathname-version wildname) :wild)
688     (eql (%pathname-version pathname)
689     (%pathname-version wildname))))))))
690    
691     (defun substitute-into (pattern subs)
692     (declare (type pattern pattern)
693     (type list subs))
694     (let ((in-wildcard nil)
695     (pieces nil)
696     (strings nil))
697     (dolist (piece (pattern-pieces pattern))
698     (cond ((simple-string-p piece)
699     (push piece strings)
700     (setf in-wildcard nil))
701     (in-wildcard)
702     ((null subs))
703     (t
704     (let ((sub (pop subs)))
705     (etypecase sub
706     (pattern
707     (when strings
708     (push (apply #'concatenate 'simple-string
709     (nreverse strings))
710     pieces))
711     (dolist (piece (pattern-pieces sub))
712     (push piece pieces)))
713     (simple-string
714     (push sub strings))))
715     (setf in-wildcard t))))
716     (when strings
717     (push (apply #'concatenate 'simple-string
718     (nreverse strings))
719     pieces))
720     (if (and pieces
721     (simple-string-p (car pieces))
722     (null (cdr pieces)))
723     (car pieces)
724     (make-pattern (nreverse pieces)))))
725    
726     (defun translate-component (source from to)
727     (typecase to
728     (pattern
729     (if (pattern-p from)
730     (typecase source
731     (pattern
732     (if (pattern= from source)
733     source
734     :error))
735     (simple-string
736     (multiple-value-bind
737     (won subs)
738     (pattern-matches from source)
739     (if won
740     (values (substitute-into to subs))
741     :error)))
742     (t
743     :error))
744     source))
745     ((member nil :wild)
746     source)
747     (t
748     (if (components-match source from)
749     to
750     :error))))
751    
752     (defun translate-directories (source from to)
753     (if (null to)
754     source
755     (let ((subs nil))
756     (loop
757     for from-part in from
758     for source-part in source
759     do (when (pattern-p from-part)
760     (typecase source-part
761     (pattern
762     (if (pattern= from-part source-part)
763     (setf subs (append subs (list source-part)))
764     (return-from translate-directories :error)))
765     (simple-string
766     (multiple-value-bind
767     (won new-subs)
768     (pattern-matches from-part source-part)
769     (if won
770     (setf subs (append subs new-subs))
771     (return-from translate-directories :error))))
772     ((member :back :up)
773     (if (equal (pattern-pieces from-part)
774     '(:multi-char-wild))
775     (setf subs (append subs (list source-part)))
776     (return-from translate-directories :error)))
777     (t
778     (return-from translate-directories :error)))))
779     (mapcar #'(lambda (to-part)
780     (if (pattern-p to-part)
781     (if (or (eq (car subs) :up) (eq (car subs) :back))
782     (if (equal (pattern-pieces to-part)
783     '(:multi-char-wild))
784     (pop subs)
785     (error "Can't splice ~S into the middle of a ~
786     wildcard pattern."
787     (car subs)))
788     (multiple-value-bind
789     (new new-subs)
790     (substitute-into to-part subs)
791     (setf subs new-subs)
792     new))
793     to-part))
794     to))))
795    
796     (defun translate-pathname (source from-wildname to-wildname &key)
797     (declare (type pathnamelike source from-wildname to-wildname))
798     (with-pathname (source source)
799     (with-pathname (from from-wildname)
800     (with-pathname (to to-wildname)
801     (macrolet ((frob (field)
802     `(let ((result (translate-component (,field source)
803     (,field from)
804     (,field to))))
805     (if (eq result :error)
806     (error "~S doesn't match ~S" source from)
807     result))))
808     (%make-pathname (frob %pathname-host)
809     (frob %pathname-device)
810     (let ((result (translate-directories
811     (%pathname-directory source)
812     (%pathname-directory from)
813     (%pathname-directory to))))
814     (if (eq result :error)
815     (error "~S doesn't match ~S" source from)
816     result))
817     (frob %pathname-name)
818     (frob %pathname-type)
819     (frob %pathname-version)))))))
820    
821    
822     ;;;; Search lists.
823    
824     ;;; The SEARCH-LIST structure.
825     ;;;
826     (defstruct (search-list
827     (:print-function %print-search-list)
828     (:make-load-form-fun
829     (lambda (search-list)
830     (values `(intern-search-list ',(search-list-name search-list))
831     nil))))
832     ;;
833     ;; The name of this search-list. Always stored in lowercase.
834     (name (required-argument) :type simple-string)
835     ;;
836     ;; T if this search-list has been defined. Otherwise NIL.
837     (defined nil :type (member t nil))
838     ;;
839     ;; The list of expansions for this search-list. Each expansion is the list
840     ;; of directory components to use in place of this search-list.
841 ram 1.4 (%expansions (%primitive c:make-value-cell nil))); :type list))
842    
843     (defun search-list-expansions (x)
844     (%primitive c:value-cell-ref (search-list-%expansions x)))
845    
846     (defun (setf search-list-expansions) (val x)
847     (%primitive c:value-cell-set (search-list-%expansions x) val))
848 wlott 1.1
849     (defun %print-search-list (sl stream depth)
850     (declare (ignore depth))
851     (print-unreadable-object (sl stream :type t)
852     (write-string (search-list-name sl) stream)))
853    
854     ;;; *SEARCH-LISTS* -- internal.
855     ;;;
856     ;;; Hash table mapping search-list names to search-list structures.
857     ;;;
858     (defvar *search-lists* (make-hash-table :test #'equal))
859    
860     ;;; INTERN-SEARCH-LIST -- internal interface.
861     ;;;
862     ;;; When search-lists are encountered in namestrings, they are converted to
863     ;;; search-list structures right then, instead of waiting until the search
864     ;;; list used. This allows us to verify ahead of time that there are no
865     ;;; circularities and makes expansion much quicker.
866     ;;;
867     (defun intern-search-list (name)
868     (let ((name (string-downcase name)))
869     (or (gethash name *search-lists*)
870     (let ((new (make-search-list :name name)))
871     (setf (gethash name *search-lists*) new)
872     new))))
873    
874     ;;; CLEAR-SEARCH-LIST -- public.
875     ;;;
876     ;;; Clear the definition. Note: we can't remove it from the hash-table
877     ;;; because there may be pathnames still refering to it. So we just clear
878     ;;; out the expansions and ste defined to NIL.
879     ;;;
880     (defun clear-search-list (name)
881     "Clear the current definition for the search-list NAME. Returns T if such
882     a definition existed, and NIL if not."
883     (let* ((name (string-downcase name))
884     (search-list (gethash name *search-lists*)))
885     (when (and search-list (search-list-defined search-list))
886     (setf (search-list-defined search-list) nil)
887     (setf (search-list-expansions search-list) nil)
888     t)))
889    
890     ;;; CLEAR-ALL-SEARCH-LISTS -- sorta public.
891     ;;;
892     ;;; Again, we can't actually remove the entries from the hash-table, so we
893     ;;; just mark them as being undefined.
894     ;;;
895     (defun clear-all-search-lists ()
896     "Clear the definition for all search-lists. Only use this if you know
897     what you are doing."
898     (maphash #'(lambda (name search-list)
899     (declare (ignore name))
900     (setf (search-list-defined search-list) nil)
901     (setf (search-list-expansions search-list) nil))
902     *search-lists*)
903     nil)
904    
905     ;;; EXTRACT-SEARCH-LIST -- internal.
906     ;;;
907     ;;; Extract the search-list from PATHNAME and return it. If PATHNAME
908     ;;; doesn't start with a search-list, then either error (if FLAME-IF-NONE
909     ;;; is true) or return NIL (if FLAME-IF-NONE is false).
910     ;;;
911     (defun extract-search-list (pathname flame-if-none)
912     (with-pathname (pathname pathname)
913     (let* ((directory (%pathname-directory pathname))
914     (search-list (cadr directory)))
915     (cond ((search-list-p search-list)
916     search-list)
917     (flame-if-none
918     (error "~S doesn't start with a search-list."))
919     (t
920     nil)))))
921    
922     ;;; SEARCH-LIST -- public.
923     ;;;
924     ;;; We have to convert the internal form of the search-list back into a
925     ;;; bunch of pathnames.
926     ;;;
927     (defun search-list (pathname)
928     "Return the expansions for the search-list starting PATHNAME. If PATHNAME
929     does not start with a search-list, then an error is signaled. If
930     the search-list has not been defined yet, then an error is signaled.
931     The expansion for a search-list can be set with SETF."
932     (with-pathname (pathname pathname)
933     (let ((search-list (extract-search-list pathname t))
934     (host (pathname-host pathname)))
935     (if (search-list-defined search-list)
936     (mapcar #'(lambda (directory)
937     (make-pathname :host host
938     :directory (cons :absolute directory)))
939     (search-list-expansions search-list))
940     (error "Search list ~S has not been defined yet." pathname)))))
941    
942     ;;; %SET-SEARCH-LIST -- public setf method
943     ;;;
944     ;;; Set the expansion for the search-list in PATHNAME. If this would result
945     ;;; in any circularities, we flame out. If anything goes wrong, we leave the
946     ;;; old defintion intact.
947     ;;;
948     (defun %set-search-list (pathname values)
949     (let ((search-list (extract-search-list pathname t)))
950     (labels
951     ((check (target-list path)
952     (when (eq search-list target-list)
953     (error "That would result in a circularity:~% ~
954     ~A~{ -> ~A~} -> ~A"
955     (search-list-name search-list)
956     (reverse path)
957     (search-list-name target-list)))
958     (when (search-list-p target-list)
959     (push (search-list-name target-list) path)
960     (dolist (expansion (search-list-expansions target-list))
961     (check (car expansion) path))))
962     (convert (pathname)
963     (with-pathname (pathname pathname)
964     (when (or (pathname-name pathname)
965     (pathname-type pathname)
966     (pathname-version pathname))
967     (error "Search-lists cannot expand into pathnames that have ~
968     a name, type, or ~%version specified:~% ~S"
969     pathname))
970     (let ((directory (pathname-directory pathname)))
971     (unless (eq (car directory) :absolute)
972     (error "Search-lists cannot expand into relative ~
973     pathnames:~% ~S"
974     pathname))
975     (let ((expansion (cdr directory)))
976     (check (car expansion) nil)
977     expansion)))))
978     (setf (search-list-expansions search-list)
979     (if (listp values)
980     (mapcar #'convert values)
981     (list (convert values)))))
982     (setf (search-list-defined search-list) t))
983     values)
984    
985     ;;; ENUMERATE-SEARCH-LIST -- public.
986     ;;;
987     (defmacro enumerate-search-list ((var pathname &optional result) &body body)
988     "Execute BODY with VAR bound to each successive possible expansion for
989     PATHNAME and then return RESULT. Note: if PATHNAME does not contain a
990     search-list, then BODY is executed exactly once. Everything is wrapped
991     in a block named NIL, so RETURN can be used to terminate early. Note:
992     VAR is *not* bound inside of RESULT."
993     (let ((body-name (gensym)))
994     `(block nil
995     (flet ((,body-name (,var)
996     ,@body))
997     (%enumerate-search-list ,pathname #',body-name)
998     ,result))))
999    
1000     (defun %enumerate-search-list (pathname function)
1001     (let ((search-list (extract-search-list pathname nil)))
1002     (cond
1003     ((not search-list)
1004     (funcall function pathname))
1005     ((not (search-list-defined search-list))
1006     (error "Undefined search list: ~A"
1007     (search-list-name search-list)))
1008     (t
1009     (let ((tail (cddr (pathname-directory pathname))))
1010     (dolist (expansion
1011     (search-list-expansions search-list))
1012     (%enumerate-search-list (make-pathname :defaults pathname
1013     :directory
1014     (cons :absolute
1015     (append expansion
1016     tail)))
1017     function)))))))

  ViewVC Help
Powered by ViewVC 1.1.5