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

Contents of /src/code/pathname.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.5 - (show 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 ;;; -*- 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.5 1991/12/22 01:44:14 ram 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 (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 (let ((pathname (let ((*default-pathname-defaults* defaults))
355 (pathname pathname))))
356 (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 ((member :back :up :unspecific nil)
671 (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 (%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
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