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

Contents of /src/code/pathname.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.8 - (show annotations)
Mon Feb 24 00:52:13 1992 UTC (22 years, 1 month ago) by wlott
Branch: MAIN
Changes since 1.7: +2 -2 lines
Fixed the ``mumble doesn't start with a search-list'' error message.
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 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/pathname.lisp,v 1.8 1992/02/24 00:52:13 wlott Exp $")
10 ;;;
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 (stream (parse-namestring (file-name ,var)))))))
202 ,@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 (or (eq (car dir1) :absolute)
335 (null dir2))
336 dir1
337 (let ((results nil))
338 (flet ((add (dir)
339 (if (and (eq dir :back)
340 results
341 (not (eq (car results) :back)))
342 (pop results)
343 (push dir results))))
344 (dolist (dir (maybe-diddle-case dir2 diddle-case))
345 (add dir))
346 (dolist (dir (cdr dir1))
347 (add dir)))
348 (reverse results))))
349
350 (defun merge-pathnames (pathname
351 &optional
352 (defaults *default-pathname-defaults*)
353 (default-version :newest))
354 (with-pathname (defaults defaults)
355 (let ((pathname (let ((*default-pathname-defaults* defaults))
356 (pathname pathname))))
357 (let* ((default-host (%pathname-host defaults))
358 (pathname-host (%pathname-host pathname))
359 (diddle-case
360 (and default-host pathname-host
361 (not (eq (host-customary-case default-host)
362 (host-customary-case pathname-host))))))
363 (%make-pathname (or pathname-host default-host)
364 (or (%pathname-device pathname)
365 (maybe-diddle-case (%pathname-device defaults)
366 diddle-case))
367 (merge-directories (%pathname-directory pathname)
368 (%pathname-directory defaults)
369 diddle-case)
370 (or (%pathname-name pathname)
371 (maybe-diddle-case (%pathname-name defaults)
372 diddle-case))
373 (or (%pathname-type pathname)
374 (maybe-diddle-case (%pathname-type defaults)
375 diddle-case))
376 (or (%pathname-version pathname)
377 default-version))))))
378
379 (defun import-directory (directory diddle-case)
380 (etypecase directory
381 (null nil)
382 (list
383 (collect ((results))
384 (ecase (pop directory)
385 (:absolute
386 (results :absolute)
387 (when (search-list-p (car directory))
388 (results (pop directory))))
389 (:relative
390 (results :relative)))
391 (dolist (piece directory)
392 (cond ((eq piece :wild)
393 (results (make-pattern (list :multi-char-wild))))
394 ((eq piece :wild-inferiors)
395 (error ":WILD-INFERIORS not supported."))
396 ((member piece '(:up :back))
397 (results piece))
398 ((or (simple-string-p piece) (pattern-p piece))
399 (results (maybe-diddle-case piece diddle-case)))
400 ((stringp piece)
401 (results (maybe-diddle-case (coerce piece 'simple-string)
402 diddle-case)))
403 (t
404 (error "~S is not allowed as a directory component." piece))))
405 (results)))
406 (simple-string
407 `(:absolute
408 ,(maybe-diddle-case directory diddle-case)))
409 (string
410 `(:absolute
411 ,(maybe-diddle-case (coerce directory 'simple-string)
412 diddle-case)))))
413
414 (defun make-pathname (&key host device directory name type version
415 defaults (case :local))
416 (declare (type (or host null) host)
417 (type (member nil :unspecific) device)
418 (type (or list string pattern (member :wild)) directory)
419 (type (or null string pattern (member :wild)) name)
420 (type (or null string pattern (member :wild)) type)
421 (type (or null integer (member :wild :newest)) version)
422 (type (or pathnamelike null) defaults)
423 (type (member :common :local) case))
424 (let* ((defaults (if defaults
425 (with-pathname (defaults defaults) defaults)))
426 (default-host (if defaults
427 (%pathname-host defaults)
428 (pathname-host *default-pathname-defaults*)))
429 (host (or host default-host))
430 (diddle-args (and (eq case :common)
431 (eq (host-customary-case host) :lower)))
432 (diddle-defaults
433 (not (eq (host-customary-case host)
434 (host-customary-case default-host)))))
435 (macrolet ((pick (var field)
436 `(cond ((eq ,var :wild)
437 (make-pattern (list :multi-char-wild)))
438 ((or (simple-string-p ,var)
439 (pattern-p ,var))
440 (maybe-diddle-case ,var diddle-args))
441 ((stringp ,var)
442 (maybe-diddle-case (coerce ,var 'simple-string)
443 diddle-args))
444 (,var
445 (maybe-diddle-case ,var diddle-args))
446 (defaults
447 (maybe-diddle-case (,field defaults)
448 diddle-defaults))
449 (t
450 nil))))
451 (%make-pathname
452 host
453 (or device (if defaults (%pathname-device defaults)))
454 (let ((dir (import-directory directory diddle-args)))
455 (if defaults
456 (merge-directories dir
457 (%pathname-directory defaults)
458 diddle-defaults)
459 dir))
460 (pick name %pathname-name)
461 (pick type %pathname-type)
462 (cond
463 (version version)
464 (defaults (%pathname-version defaults))
465 (t nil))))))
466
467 (defun pathname-host (pathname &key (case :local))
468 (declare (type pathnamelike pathname)
469 (type (member :local :common) case)
470 (ignore case))
471 (with-pathname (pathname pathname)
472 (%pathname-host pathname)))
473
474 (defun pathname-device (pathname &key (case :local))
475 (declare (type pathnamelike pathname)
476 (type (member :local :common) case))
477 (with-pathname (pathname pathname)
478 (maybe-diddle-case (%pathname-device pathname)
479 (and (eq case :common)
480 (eq (host-customary-case
481 (%pathname-host pathname))
482 :lower)))))
483
484 (defun pathname-directory (pathname &key (case :local))
485 (declare (type pathnamelike pathname)
486 (type (member :local :common) case))
487 (with-pathname (pathname pathname)
488 (maybe-diddle-case (%pathname-directory pathname)
489 (and (eq case :common)
490 (eq (host-customary-case
491 (%pathname-host pathname))
492 :lower)))))
493
494 (defun pathname-name (pathname &key (case :local))
495 (declare (type pathnamelike pathname)
496 (type (member :local :common) case))
497 (with-pathname (pathname pathname)
498 (maybe-diddle-case (%pathname-name pathname)
499 (and (eq case :common)
500 (eq (host-customary-case
501 (%pathname-host pathname))
502 :lower)))))
503
504 (defun pathname-type (pathname &key (case :local))
505 (declare (type pathnamelike pathname)
506 (type (member :local :common) case))
507 (with-pathname (pathname pathname)
508 (maybe-diddle-case (%pathname-type pathname)
509 (and (eq case :common)
510 (eq (host-customary-case
511 (%pathname-host pathname))
512 :lower)))))
513
514 (defun pathname-version (pathname)
515 (declare (type pathnamelike pathname))
516 (with-pathname (pathname pathname)
517 (%pathname-version pathname)))
518
519 (defun namestring (pathname)
520 (declare (type pathnamelike pathname))
521 (with-pathname (pathname pathname)
522 (let ((host (%pathname-host pathname)))
523 (if host
524 (funcall (host-unparse host) pathname)
525 (error
526 "Cannot determine the namestring for pathnames with no host:~% ~S"
527 pathname)))))
528
529 (defun host-namestring (pathname)
530 (declare (type pathnamelike pathname))
531 (with-pathname (pathname pathname)
532 (let ((host (%pathname-host pathname)))
533 (if host
534 (funcall (host-unparse-host host) pathname)
535 (error
536 "Cannot determine the namestring for pathnames with no host:~% ~S"
537 pathname)))))
538
539 (defun directory-namestring (pathname)
540 (declare (type pathnamelike pathname))
541 (with-pathname (pathname pathname)
542 (let ((host (%pathname-host pathname)))
543 (if host
544 (funcall (host-unparse-directory host) pathname)
545 (error
546 "Cannot determine the namestring for pathnames with no host:~% ~S"
547 pathname)))))
548
549 (defun file-namestring (pathname)
550 (declare (type pathnamelike pathname))
551 (with-pathname (pathname pathname)
552 (let ((host (%pathname-host pathname)))
553 (if host
554 (funcall (host-unparse-file host) pathname)
555 (error
556 "Cannot determine the namestring for pathnames with no host:~% ~S"
557 pathname)))))
558
559 (defun enough-namestring (pathname
560 &optional (defaults *default-pathname-defaults*))
561 (declare (type pathnamelike pathname))
562 (with-pathname (pathname pathname)
563 (let ((host (%pathname-host pathname)))
564 (if host
565 (with-pathname (defaults defaults)
566 (funcall (host-unparse-enough host) pathname defaults))
567 (error
568 "Cannot determine the namestring for pathnames with no host:~% ~S"
569 pathname)))))
570
571
572 ;;;; Wild pathnames.
573
574 (defun wild-pathname-p (pathname &optional field-key)
575 (declare (type pathnamelike pathname)
576 (type (member nil :host :device :directory :name :type :version)
577 field-key))
578 (with-pathname (pathname pathname)
579 (ecase field-key
580 ((nil)
581 (or (wild-pathname-p pathname :host)
582 (wild-pathname-p pathname :device)
583 (wild-pathname-p pathname :directory)
584 (wild-pathname-p pathname :name)
585 (wild-pathname-p pathname :type)
586 (wild-pathname-p pathname :version)))
587 (:host
588 (pattern-p (%pathname-host pathname)))
589 (:device
590 (pattern-p (%pathname-host pathname)))
591 (:directory
592 (some #'pattern-p (%pathname-directory pathname)))
593 (:name
594 (pattern-p (%pathname-name pathname)))
595 (:type
596 (pattern-p (%pathname-type pathname)))
597 (:version
598 (eq (%pathname-version pathname) :wild)))))
599
600 (defun pattern-matches (pattern string)
601 (declare (type pattern pattern)
602 (type simple-string string))
603 (let ((len (length string)))
604 (labels ((maybe-prepend (subs cur-sub chars)
605 (if cur-sub
606 (let* ((len (length chars))
607 (new (make-string len))
608 (index len))
609 (dolist (char chars)
610 (setf (schar new (decf index)) char))
611 (cons new subs))
612 subs))
613 (matches (pieces start subs cur-sub chars)
614 (if (null pieces)
615 (if (= start len)
616 (values t (maybe-prepend subs cur-sub chars))
617 (values nil nil))
618 (let ((piece (car pieces)))
619 (etypecase piece
620 (simple-string
621 (let ((end (+ start (length piece))))
622 (and (<= end len)
623 (string= piece string
624 :start2 start :end2 end)
625 (matches (cdr pieces) end
626 (maybe-prepend subs cur-sub chars)
627 nil nil))))
628 (list
629 (ecase (car piece)
630 (:character-set
631 (and (< start len)
632 (let ((char (schar string start)))
633 (if (find char (cdr piece) :test #'char=)
634 (matches (cdr pieces) (1+ start) subs t
635 (cons char chars))))))))
636 ((member :single-char-wild)
637 (and (< start len)
638 (matches (cdr pieces) (1+ start) subs t
639 (cons (schar string start) chars))))
640 ((member :multi-char-wild)
641 (multiple-value-bind
642 (won new-subs)
643 (matches (cdr pieces) start subs t chars)
644 (if won
645 (values t new-subs)
646 (and (< start len)
647 (matches pieces (1+ start) subs t
648 (cons (schar string start)
649 chars)))))))))))
650 (multiple-value-bind
651 (won subs)
652 (matches (pattern-pieces pattern) 0 nil nil nil)
653 (values won (reverse subs))))))
654
655 (defun components-match (this that)
656 (or (eq this that)
657 (typecase this
658 (simple-string
659 (typecase that
660 (pattern
661 (values (pattern-matches that this)))
662 (simple-string
663 (string= this that))))
664 (pattern
665 (and (pattern-p that)
666 (pattern= this that)))
667 (cons
668 (and (consp that)
669 (components-match (car this) (car that))
670 (components-match (cdr this) (cdr that))))
671 ((member :back :up :unspecific nil)
672 (and (pattern-p that)
673 (equal (pattern-pieces that) '(:multi-char-wild)))))))
674
675 (defun pathname-match-p (pathname wildname)
676 (with-pathname (pathname pathname)
677 (with-pathname (wildname wildname)
678 (macrolet ((frob (field)
679 `(or (null (,field wildname))
680 (components-match (,field pathname)
681 (,field wildname)))))
682 (and (frob %pathname-host)
683 (frob %pathname-device)
684 (frob %pathname-directory)
685 (frob %pathname-name)
686 (frob %pathname-type)
687 (or (null (%pathname-version wildname))
688 (eq (%pathname-version wildname) :wild)
689 (eql (%pathname-version pathname)
690 (%pathname-version wildname))))))))
691
692 (defun substitute-into (pattern subs)
693 (declare (type pattern pattern)
694 (type list subs))
695 (let ((in-wildcard nil)
696 (pieces nil)
697 (strings nil))
698 (dolist (piece (pattern-pieces pattern))
699 (cond ((simple-string-p piece)
700 (push piece strings)
701 (setf in-wildcard nil))
702 (in-wildcard)
703 ((null subs))
704 (t
705 (let ((sub (pop subs)))
706 (etypecase sub
707 (pattern
708 (when strings
709 (push (apply #'concatenate 'simple-string
710 (nreverse strings))
711 pieces))
712 (dolist (piece (pattern-pieces sub))
713 (push piece pieces)))
714 (simple-string
715 (push sub strings))))
716 (setf in-wildcard t))))
717 (when strings
718 (push (apply #'concatenate 'simple-string
719 (nreverse strings))
720 pieces))
721 (if (and pieces
722 (simple-string-p (car pieces))
723 (null (cdr pieces)))
724 (car pieces)
725 (make-pattern (nreverse pieces)))))
726
727 (defun translate-component (source from to)
728 (typecase to
729 (pattern
730 (if (pattern-p from)
731 (typecase source
732 (pattern
733 (if (pattern= from source)
734 source
735 :error))
736 (simple-string
737 (multiple-value-bind
738 (won subs)
739 (pattern-matches from source)
740 (if won
741 (values (substitute-into to subs))
742 :error)))
743 (t
744 :error))
745 source))
746 ((member nil :wild)
747 source)
748 (t
749 (if (components-match source from)
750 to
751 :error))))
752
753 (defun translate-directories (source from to)
754 (if (null to)
755 source
756 (let ((subs nil))
757 (loop
758 for from-part in from
759 for source-part in source
760 do (when (pattern-p from-part)
761 (typecase source-part
762 (pattern
763 (if (pattern= from-part source-part)
764 (setf subs (append subs (list source-part)))
765 (return-from translate-directories :error)))
766 (simple-string
767 (multiple-value-bind
768 (won new-subs)
769 (pattern-matches from-part source-part)
770 (if won
771 (setf subs (append subs new-subs))
772 (return-from translate-directories :error))))
773 ((member :back :up)
774 (if (equal (pattern-pieces from-part)
775 '(:multi-char-wild))
776 (setf subs (append subs (list source-part)))
777 (return-from translate-directories :error)))
778 (t
779 (return-from translate-directories :error)))))
780 (mapcar #'(lambda (to-part)
781 (if (pattern-p to-part)
782 (if (or (eq (car subs) :up) (eq (car subs) :back))
783 (if (equal (pattern-pieces to-part)
784 '(:multi-char-wild))
785 (pop subs)
786 (error "Can't splice ~S into the middle of a ~
787 wildcard pattern."
788 (car subs)))
789 (multiple-value-bind
790 (new new-subs)
791 (substitute-into to-part subs)
792 (setf subs new-subs)
793 new))
794 to-part))
795 to))))
796
797 (defun translate-pathname (source from-wildname to-wildname &key)
798 (declare (type pathnamelike source from-wildname to-wildname))
799 (with-pathname (source source)
800 (with-pathname (from from-wildname)
801 (with-pathname (to to-wildname)
802 (macrolet ((frob (field)
803 `(let ((result (translate-component (,field source)
804 (,field from)
805 (,field to))))
806 (if (eq result :error)
807 (error "~S doesn't match ~S" source from)
808 result))))
809 (%make-pathname (frob %pathname-host)
810 (frob %pathname-device)
811 (let ((result (translate-directories
812 (%pathname-directory source)
813 (%pathname-directory from)
814 (%pathname-directory to))))
815 (if (eq result :error)
816 (error "~S doesn't match ~S" source from)
817 result))
818 (frob %pathname-name)
819 (frob %pathname-type)
820 (frob %pathname-version)))))))
821
822
823 ;;;; Search lists.
824
825 ;;; The SEARCH-LIST structure.
826 ;;;
827 (defstruct (search-list
828 (:print-function %print-search-list)
829 (:make-load-form-fun
830 (lambda (search-list)
831 (values `(intern-search-list ',(search-list-name search-list))
832 nil))))
833 ;;
834 ;; The name of this search-list. Always stored in lowercase.
835 (name (required-argument) :type simple-string)
836 ;;
837 ;; T if this search-list has been defined. Otherwise NIL.
838 (defined nil :type (member t nil))
839 ;;
840 ;; The list of expansions for this search-list. Each expansion is the list
841 ;; of directory components to use in place of this search-list.
842 (%expansions (%primitive c:make-value-cell nil))); :type list))
843
844 (defun search-list-expansions (x)
845 (%primitive c:value-cell-ref (search-list-%expansions x)))
846
847 (defun (setf search-list-expansions) (val x)
848 (%primitive c:value-cell-set (search-list-%expansions x) val))
849
850 (defun %print-search-list (sl stream depth)
851 (declare (ignore depth))
852 (print-unreadable-object (sl stream :type t)
853 (write-string (search-list-name sl) stream)))
854
855 ;;; *SEARCH-LISTS* -- internal.
856 ;;;
857 ;;; Hash table mapping search-list names to search-list structures.
858 ;;;
859 (defvar *search-lists* (make-hash-table :test #'equal))
860
861 ;;; INTERN-SEARCH-LIST -- internal interface.
862 ;;;
863 ;;; When search-lists are encountered in namestrings, they are converted to
864 ;;; search-list structures right then, instead of waiting until the search
865 ;;; list used. This allows us to verify ahead of time that there are no
866 ;;; circularities and makes expansion much quicker.
867 ;;;
868 (defun intern-search-list (name)
869 (let ((name (string-downcase name)))
870 (or (gethash name *search-lists*)
871 (let ((new (make-search-list :name name)))
872 (setf (gethash name *search-lists*) new)
873 new))))
874
875 ;;; CLEAR-SEARCH-LIST -- public.
876 ;;;
877 ;;; Clear the definition. Note: we can't remove it from the hash-table
878 ;;; because there may be pathnames still refering to it. So we just clear
879 ;;; out the expansions and ste defined to NIL.
880 ;;;
881 (defun clear-search-list (name)
882 "Clear the current definition for the search-list NAME. Returns T if such
883 a definition existed, and NIL if not."
884 (let* ((name (string-downcase name))
885 (search-list (gethash name *search-lists*)))
886 (when (and search-list (search-list-defined search-list))
887 (setf (search-list-defined search-list) nil)
888 (setf (search-list-expansions search-list) nil)
889 t)))
890
891 ;;; CLEAR-ALL-SEARCH-LISTS -- sorta public.
892 ;;;
893 ;;; Again, we can't actually remove the entries from the hash-table, so we
894 ;;; just mark them as being undefined.
895 ;;;
896 (defun clear-all-search-lists ()
897 "Clear the definition for all search-lists. Only use this if you know
898 what you are doing."
899 (maphash #'(lambda (name search-list)
900 (declare (ignore name))
901 (setf (search-list-defined search-list) nil)
902 (setf (search-list-expansions search-list) nil))
903 *search-lists*)
904 nil)
905
906 ;;; EXTRACT-SEARCH-LIST -- internal.
907 ;;;
908 ;;; Extract the search-list from PATHNAME and return it. If PATHNAME
909 ;;; doesn't start with a search-list, then either error (if FLAME-IF-NONE
910 ;;; is true) or return NIL (if FLAME-IF-NONE is false).
911 ;;;
912 (defun extract-search-list (pathname flame-if-none)
913 (with-pathname (pathname pathname)
914 (let* ((directory (%pathname-directory pathname))
915 (search-list (cadr directory)))
916 (cond ((search-list-p search-list)
917 search-list)
918 (flame-if-none
919 (error "~S doesn't start with a search-list." pathname))
920 (t
921 nil)))))
922
923 ;;; SEARCH-LIST -- public.
924 ;;;
925 ;;; We have to convert the internal form of the search-list back into a
926 ;;; bunch of pathnames.
927 ;;;
928 (defun search-list (pathname)
929 "Return the expansions for the search-list starting PATHNAME. If PATHNAME
930 does not start with a search-list, then an error is signaled. If
931 the search-list has not been defined yet, then an error is signaled.
932 The expansion for a search-list can be set with SETF."
933 (with-pathname (pathname pathname)
934 (let ((search-list (extract-search-list pathname t))
935 (host (pathname-host pathname)))
936 (if (search-list-defined search-list)
937 (mapcar #'(lambda (directory)
938 (make-pathname :host host
939 :directory (cons :absolute directory)))
940 (search-list-expansions search-list))
941 (error "Search list ~S has not been defined yet." pathname)))))
942
943 ;;; %SET-SEARCH-LIST -- public setf method
944 ;;;
945 ;;; Set the expansion for the search-list in PATHNAME. If this would result
946 ;;; in any circularities, we flame out. If anything goes wrong, we leave the
947 ;;; old defintion intact.
948 ;;;
949 (defun %set-search-list (pathname values)
950 (let ((search-list (extract-search-list pathname t)))
951 (labels
952 ((check (target-list path)
953 (when (eq search-list target-list)
954 (error "That would result in a circularity:~% ~
955 ~A~{ -> ~A~} -> ~A"
956 (search-list-name search-list)
957 (reverse path)
958 (search-list-name target-list)))
959 (when (search-list-p target-list)
960 (push (search-list-name target-list) path)
961 (dolist (expansion (search-list-expansions target-list))
962 (check (car expansion) path))))
963 (convert (pathname)
964 (with-pathname (pathname pathname)
965 (when (or (pathname-name pathname)
966 (pathname-type pathname)
967 (pathname-version pathname))
968 (error "Search-lists cannot expand into pathnames that have ~
969 a name, type, or ~%version specified:~% ~S"
970 pathname))
971 (let ((directory (pathname-directory pathname)))
972 (let ((expansion
973 (if directory
974 (ecase (car directory)
975 (:absolute (cdr directory))
976 (:relative (cons (intern-search-list "default")
977 (cdr directory))))
978 (list (intern-search-list "default")))))
979 (check (car expansion) nil)
980 expansion)))))
981 (setf (search-list-expansions search-list)
982 (if (listp values)
983 (mapcar #'convert values)
984 (list (convert values)))))
985 (setf (search-list-defined search-list) t))
986 values)
987
988 ;;; ENUMERATE-SEARCH-LIST -- public.
989 ;;;
990 (defmacro enumerate-search-list ((var pathname &optional result) &body body)
991 "Execute BODY with VAR bound to each successive possible expansion for
992 PATHNAME and then return RESULT. Note: if PATHNAME does not contain a
993 search-list, then BODY is executed exactly once. Everything is wrapped
994 in a block named NIL, so RETURN can be used to terminate early. Note:
995 VAR is *not* bound inside of RESULT."
996 (let ((body-name (gensym)))
997 `(block nil
998 (flet ((,body-name (,var)
999 ,@body))
1000 (%enumerate-search-list ,pathname #',body-name)
1001 ,result))))
1002
1003 (defun %enumerate-search-list (pathname function)
1004 (let ((search-list (extract-search-list pathname nil)))
1005 (cond
1006 ((not search-list)
1007 (funcall function pathname))
1008 ((not (search-list-defined search-list))
1009 (error "Undefined search list: ~A"
1010 (search-list-name search-list)))
1011 (t
1012 (let ((tail (cddr (pathname-directory pathname))))
1013 (dolist (expansion
1014 (search-list-expansions search-list))
1015 (%enumerate-search-list (make-pathname :defaults pathname
1016 :directory
1017 (cons :absolute
1018 (append expansion
1019 tail)))
1020 function)))))))

  ViewVC Help
Powered by ViewVC 1.1.5