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

Contents of /src/code/pathname.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.12 - (show annotations)
Wed Aug 19 17:45:33 1992 UTC (21 years, 8 months ago) by phg
Branch: MAIN
Changes since 1.11: +896 -61 lines
Logical pathname functions added to bring CMUCL up to the ANSI X3J13/92-102
standard.
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.12 1992/08/19 17:45:33 phg Exp $")
10 ;;;
11 ;;; **********************************************************************
12 ;;;
13 ;;; Machine/filesystem independent pathname functions for CMU Common Lisp.
14 ;;;
15 ;;; Written by William Lott, enhancements for logical-pathnames
16 ;;; written by Paul Gleichauf.
17 ;;; Earlier version written by Jim Large and Rob MacLachlan
18 ;;;
19 ;;; **********************************************************************
20
21 (in-package "LISP")
22
23 (export '(pathname pathnamep logical-pathname logical-pathname-p
24 parse-namestring merge-pathnames make-pathname
25 pathname-host pathname-device pathname-directory pathname-name
26 pathname-type pathname-version namestring file-namestring
27 directory-namestring host-namestring enough-namestring
28 wild-pathname-p pathname-match-p translate-pathname
29 translate-logical-pathname logical-pathname-translations
30 load-logical-pathname-translations *default-pathname-defaults*))
31
32 (in-package "EXTENSIONS")
33 (export '(search-list search-list-defined-p clear-search-list
34 enumerate-search-list))
35
36 (in-package "LISP")
37
38
39
40 ;;;; Structures and types.
41
42 (defstruct (pathname
43 (:conc-name %pathname-)
44 (:print-function %print-pathname)
45 (:constructor
46 %make-pathname (host device directory name type version))
47 (:predicate pathnamep)
48 (:make-load-form-fun :just-dump-it-normally))
49 "Pathname is the structure of the file pathname. It consists of a
50 host, a device, a directory, a name, and a type."
51 (host nil :type (or host null))
52 (device nil :type (member nil :unspecific))
53 (directory nil :type list)
54 (name nil :type (or simple-string pattern null))
55 (type nil :type (or simple-string pattern null (member :unspecific)))
56 (version nil :type (or integer null (member :newest :wild))))
57
58 (defun %print-pathname (pathname stream depth)
59 (declare (ignore depth))
60 (let ((namestring (handler-case (namestring pathname)
61 (error nil))))
62 (cond (namestring
63 (format stream "#p~S" namestring))
64 (*print-readably*
65 (error "~S Cannot be printed readably." pathname))
66 (*print-pretty*
67 (pprint-logical-block (stream nil :prefix "#<" :suffix ">")
68 (funcall (formatter
69 "~2IUnprintable pathname: ~_Host=~S, ~_Device=~S, ~_~
70 Directory=~:/LISP:PPRINT-FILL/, ~_Name=~S, ~_~
71 Type=~S, ~_Version=~S")
72 stream
73 (%pathname-host pathname)
74 (%pathname-device pathname)
75 (%pathname-directory pathname)
76 (%pathname-name pathname)
77 (%pathname-type pathname)
78 (%pathname-version pathname))))
79 (t
80 (funcall (formatter "#<Unprintable pathname, Host=~S, Device=~S, ~
81 Directory=~S, File=~S, Name=~S, Version=~S>")
82 stream
83 (%pathname-host pathname)
84 (%pathname-device pathname)
85 (%pathname-directory pathname)
86 (%pathname-name pathname)
87 (%pathname-type pathname)
88 (%pathname-version pathname))))))
89
90 (defstruct (host
91 (:print-function %print-host))
92 (parse (required-argument) :type function)
93 (unparse (required-argument) :type function)
94 (unparse-host (required-argument) :type function)
95 (unparse-directory (required-argument) :type function)
96 (unparse-file (required-argument) :type function)
97 (unparse-enough (required-argument) :type function)
98 (customary-case (required-argument) :type (member :upper :lower)))
99
100 (defun %print-host (host stream depth)
101 (declare (ignore depth))
102 (print-unreadable-object (host stream :type t :identity t)))
103
104
105 ;;;; Patterns
106
107 (defstruct (pattern
108 (:print-function %print-pattern)
109 (:make-load-form-fun :just-dump-it-normally)
110 (:constructor make-pattern (pieces)))
111 (pieces nil :type list))
112
113 (defun %print-pattern (pattern stream depth)
114 (declare (ignore depth))
115 (print-unreadable-object (pattern stream :type t)
116 (if *print-pretty*
117 (let ((*print-escape* t))
118 (pprint-fill stream (pattern-pieces pattern) nil))
119 (prin1 (pattern-pieces pattern) stream))))
120
121 (defun pattern= (pattern1 pattern2)
122 (declare (type pattern pattern1 pattern2))
123 (let ((pieces1 (pattern-pieces pattern1))
124 (pieces2 (pattern-pieces pattern2)))
125 (and (= (length pieces1) (length pieces2))
126 (every #'(lambda (piece1 piece2)
127 (typecase piece1
128 (simple-string
129 (and (simple-string-p piece2)
130 (string= piece1 piece2)))
131 (cons
132 (and (consp piece2)
133 (eq (car piece1) (car piece2))
134 (string= (cdr piece1) (cdr piece2))))
135 (t
136 (eq piece1 piece2))))
137 pieces1
138 pieces2))))
139
140
141
142 ;;;; Utilities.
143
144 (defun compare-component (this that)
145 (or (eql this that)
146 (typecase this
147 (simple-string
148 (and (simple-string-p that)
149 (string= this that)))
150 (pattern
151 (and (pattern-p that)
152 (pattern= this that)))
153 (cons
154 (and (consp that)
155 (compare-component (car this) (car that))
156 (compare-component (cdr this) (cdr that)))))))
157
158
159 ;;;; Logical namestrings
160
161 #|
162 (defstruct (logical-host
163 (:include host
164 (:parse #'parse-logical-namestring)
165 ...)
166 (:print-function %print-logical-host))
167 name
168 translations)
169
170 (deftype logical-pathname ()
171 '(satisfies logical-pathname-p))
172
173 (defun logical-pathname-p (thing)
174 "Return T if THING is a LOGICAL-PATHNAME, and NIL if not."
175 (and (pathnamep thing)
176 (logical-host-p (%pathname-host thing))))
177 |#
178
179
180 ;;;; Pathname functions.
181
182 (defvar *default-pathname-defaults*)
183
184 (defun pathname= (pathname1 pathname2)
185 (and (eq (%pathname-host pathname1)
186 (%pathname-host pathname2))
187 (compare-component (%pathname-device pathname1)
188 (%pathname-device pathname2))
189 (compare-component (%pathname-directory pathname1)
190 (%pathname-directory pathname2))
191 (compare-component (%pathname-name pathname1)
192 (%pathname-name pathname2))
193 (compare-component (%pathname-type pathname1)
194 (%pathname-type pathname2))
195 (compare-component (%pathname-version pathname1)
196 (%pathname-version pathname2))))
197
198 (defmacro with-pathname ((var expr) &body body)
199 `(let ((,var (let ((,var ,expr))
200 (etypecase ,var
201 (pathname ,var)
202 (string (parse-namestring ,var))
203 (stream (parse-namestring (file-name ,var)))))))
204 ,@body))
205
206 (defun %print-namestring-parse-error (condition stream)
207 (format stream "Parse error in namestring: ~?~% ~A~% ~V@T^"
208 (namestring-parse-error-complaint condition)
209 (namestring-parse-error-arguments condition)
210 (namestring-parse-error-namestring condition)
211 (namestring-parse-error-offset condition)))
212
213 (define-condition namestring-parse-error (error)
214 ((complaint :init-form (required-argument))
215 (arguments :init-form nil)
216 (namestring :init-form (required-argument))
217 (offset :init-form (required-argument)))
218 (:report %print-namestring-parse-error))
219
220 (defun %parse-namestring (namestr start end host junk-allowed)
221 (declare (type string namestr)
222 (type index start end)
223 (type host host)
224 (values (or null pathname) index))
225 (cond (junk-allowed
226 (handler-case (%parse-namestring namestr start end host nil)
227 (namestring-parse-error (condition)
228 (values nil (namestring-parse-error-offset condition)))))
229 ((simple-string-p namestr)
230 (multiple-value-bind
231 (new-host device directory file type version)
232 (funcall (host-parse host) namestr start end)
233 (values (%make-pathname (or new-host host)
234 device
235 directory
236 file
237 type
238 version)
239 end)))
240 (t
241 (%parse-namestring (coerce namestr 'simple-string)
242 start end host nil))))
243
244 (defun parse-namestring (thing
245 &optional host (defaults *default-pathname-defaults*)
246 &key (start 0) end junk-allowed)
247 (declare (type (or simple-base-string stream pathname) thing)
248 (type (or null host) host)
249 (type pathnamelike defaults)
250 (type index start)
251 (type (or index null) end)
252 (type (or null (not null)) junk-allowed)
253 (values (or null pathname) index))
254 (cond ((stringp thing)
255 (let* ((end1 (or end (length thing)))
256 (things-host nil)
257 (hosts-name (when host
258 (funcall (host-parse host) thing start end1))))
259 (setf things-host
260 (maybe-extract-logical-host thing start end1))
261 (when (and host things-host) ; A logical host and host are defined.
262 (unless (string= things-host hosts-name)
263 (error "Hosts do not match: ~S in ~S and ~S."
264 things-host thing host)))
265 (if things-host
266 (unless (gethash (string-downcase things-host) *search-lists*)
267 ;; Not a search-list name, make it a logical-host name.
268 (setf host (intern-logical-host things-host))))
269 (%parse-namestring thing start end1
270 (or host
271 (with-pathname (defaults defaults)
272 (%pathname-host defaults)))
273 junk-allowed)))
274 ((pathnamep thing)
275 (when host
276 (unless (eq host (%pathname-host thing))
277 (error "Hosts do not match: ~S and ~S."
278 host
279 (%pathname-host thing))))
280 (values thing start))
281 ((streamp thing)
282 (let ((host-name (funcall (host-unparse-host host) host))
283 (stream-type (type-of thing))
284 (stream-host-name (host-namestring thing)))
285 (unless (or (eq stream-type 'fd-stream)
286 ;;********Change fd-stream to file-stream in sources too.
287 (eq stream-type 'synonym-stream))
288 (error "Stream ~S was created with other than OPEN, WITH-OPEN-FILE~
289 or MAKE-SYNONYM-FILE." thing))
290 (unless (string-equal stream-host-name host-name)
291 (error "Hosts do not match: ~S and ~S."
292 host
293 host-name)))
294 (values thing start))))
295
296 (defun pathname (thing)
297 (declare (type pathnamelike thing))
298 (with-pathname (pathname thing)
299 pathname))
300
301 (defun maybe-diddle-case (thing diddle-p)
302 (declare (type (or list pattern simple-base-string (member :unspecific))
303 thing)
304 (values (or list pattern simple-base-string (member :unspecific))))
305 (if diddle-p
306 (labels ((check-for (pred in)
307 (etypecase in
308 (pattern
309 (dolist (piece (pattern-pieces in))
310 (when (typecase piece
311 (simple-string
312 (check-for pred piece))
313 (cons
314 (case (car in)
315 (:character-set
316 (check-for pred (cdr in))))))
317 (return t))))
318 (list
319 (dolist (x in)
320 (when (check-for pred x)
321 (return t))))
322 (simple-base-string
323 (dotimes (i (length in))
324 (when (funcall pred (schar in i))
325 (return t))))
326 ((member :unspecific :up :absolute :relative)
327 nil)))
328 (diddle-with (fun thing)
329 (etypecase thing
330 (pattern
331 (make-pattern
332 (mapcar #'(lambda (piece)
333 (typecase piece
334 (simple-base-string
335 (funcall fun thing))
336 (cons
337 (case (car piece)
338 (:character-set
339 (cons :character-set
340 (funcall fun (cdr piece))))
341 (t
342 piece)))
343 (t
344 piece)))
345 (pattern-pieces thing))))
346 (list
347 (mapcar fun thing))
348 (simple-base-string
349 (funcall fun thing))
350 ((member :unspecific :up :absolute :relative)
351 thing))))
352 (let ((any-uppers (check-for #'upper-case-p thing))
353 (any-lowers (check-for #'lower-case-p thing)))
354 (cond ((and any-uppers any-lowers)
355 ;; Mixed case, stays the same.
356 thing)
357 (any-uppers
358 ;; All uppercase, becomes all lower case.
359 (diddle-with #'(lambda (x) (if (stringp x)
360 (string-downcase x)
361 x)) thing))
362 (any-lowers
363 ;; All lowercase, becomes all upper case.
364 (diddle-with #'(lambda (x) (if (stringp x)
365 (string-upcase x)
366 x)) thing))
367 (t
368 ;; No letters? I guess just leave it.
369 thing))))
370 thing))
371
372 (defun merge-directories (dir1 dir2 diddle-case)
373 (if (or (eq (car dir1) :absolute)
374 (null dir2))
375 dir1
376 (let ((results nil))
377 (flet ((add (dir)
378 (if (and (eq dir :back)
379 results
380 (not (eq (car results) :back)))
381 (pop results)
382 (push dir results))))
383 (dolist (dir (maybe-diddle-case dir2 diddle-case))
384 (add dir))
385 (dolist (dir (cdr dir1))
386 (add dir)))
387 (reverse results))))
388
389 (defun merge-pathnames (pathname
390 &optional
391 (defaults *default-pathname-defaults*)
392 (default-version :newest))
393 (with-pathname (defaults defaults)
394 (let ((pathname (let ((*default-pathname-defaults* defaults))
395 (pathname pathname))))
396 (let* ((default-host (%pathname-host defaults))
397 (pathname-host (%pathname-host pathname))
398 (diddle-case
399 (and default-host pathname-host
400 (not (eq (host-customary-case default-host)
401 (host-customary-case pathname-host))))))
402 (%make-pathname (or pathname-host default-host)
403 (or (%pathname-device pathname)
404 (maybe-diddle-case (%pathname-device defaults)
405 diddle-case))
406 (merge-directories (%pathname-directory pathname)
407 (%pathname-directory defaults)
408 diddle-case)
409 (or (%pathname-name pathname)
410 (maybe-diddle-case (%pathname-name defaults)
411 diddle-case))
412 (or (%pathname-type pathname)
413 (maybe-diddle-case (%pathname-type defaults)
414 diddle-case))
415 (or (%pathname-version pathname)
416 default-version))))))
417
418 (defun import-directory (directory diddle-case)
419 (etypecase directory
420 (null nil)
421 (list
422 (collect ((results))
423 (ecase (pop directory)
424 (:absolute
425 (results :absolute)
426 (when (search-list-p (car directory))
427 (results (pop directory))))
428 (:relative
429 (results :relative)))
430 (dolist (piece directory)
431 (cond ((eq piece :wild)
432 (results (make-pattern (list :multi-char-wild))))
433 ((eq piece :wild-inferiors)
434 (results piece))
435 ((member piece '(:up :back))
436 (results piece))
437 ((or (simple-string-p piece) (pattern-p piece))
438 (results (maybe-diddle-case piece diddle-case)))
439 ((stringp piece)
440 (results (maybe-diddle-case (coerce piece 'simple-string)
441 diddle-case)))
442 (t
443 (error "~S is not allowed as a directory component." piece))))
444 (results)))
445 (simple-string
446 `(:absolute
447 ,(maybe-diddle-case directory diddle-case)))
448 (string
449 `(:absolute
450 ,(maybe-diddle-case (coerce directory 'simple-string)
451 diddle-case)))))
452
453 (defun make-pathname (&key (host nil hostp)
454 (device nil devp)
455 (directory nil dirp)
456 (name nil namep)
457 (type nil typep)
458 (version nil versionp)
459 defaults (case :local))
460 (declare (type (or host null) host)
461 (type (member nil :unspecific) device)
462 (type (or list string pattern (member :wild)) directory)
463 (type (or null string pattern (member :wild)) name)
464 (type (or null string pattern (member :unspecific :wild)) type)
465 (type (or null integer (member :unspecific :wild :newest)) version)
466 (type (or pathnamelike null) defaults)
467 (type (member :common :local) case))
468 (let* ((defaults (if defaults
469 (with-pathname (defaults defaults) defaults)))
470 (default-host (if defaults
471 (%pathname-host defaults)
472 (pathname-host *default-pathname-defaults*)))
473 (host (if hostp host default-host))
474 (diddle-args (and (eq case :common)
475 (eq (host-customary-case host) :lower)))
476 (diddle-defaults
477 (not (eq (host-customary-case host)
478 (host-customary-case default-host)))))
479 (macrolet ((pick (var varp field)
480 `(cond ((eq ,var :wild)
481 (make-pattern (list :multi-char-wild)))
482 ((or (simple-string-p ,var)
483 (pattern-p ,var))
484 (maybe-diddle-case ,var diddle-args))
485 ((stringp ,var)
486 (maybe-diddle-case (coerce ,var 'simple-string)
487 diddle-args))
488 (,varp
489 (maybe-diddle-case ,var diddle-args))
490 (defaults
491 (maybe-diddle-case (,field defaults)
492 diddle-defaults))
493 (t
494 nil))))
495 (%make-pathname
496 host
497 (if devp device (if defaults (%pathname-device defaults)))
498 (let ((dir (import-directory directory diddle-args)))
499 (if (and defaults (not dirp))
500 (merge-directories dir
501 (%pathname-directory defaults)
502 diddle-defaults)
503 dir))
504 (pick name namep %pathname-name)
505 (pick type typep %pathname-type)
506 (cond
507 (versionp version)
508 (defaults (%pathname-version defaults))
509 (t nil))))))
510
511 (defun pathname-host (pathname &key (case :local))
512 (declare (type pathnamelike pathname)
513 (type (member :local :common) case)
514 (ignore case))
515 (with-pathname (pathname pathname)
516 (%pathname-host pathname)))
517
518 (defun pathname-device (pathname &key (case :local))
519 (declare (type pathnamelike pathname)
520 (type (member :local :common) case))
521 (with-pathname (pathname pathname)
522 (maybe-diddle-case (%pathname-device pathname)
523 (and (eq case :common)
524 (eq (host-customary-case
525 (%pathname-host pathname))
526 :lower)))))
527
528 (defun pathname-directory (pathname &key (case :local))
529 (declare (type pathnamelike pathname)
530 (type (member :local :common) case))
531 (with-pathname (pathname pathname)
532 (maybe-diddle-case (%pathname-directory pathname)
533 (and (eq case :common)
534 (eq (host-customary-case
535 (%pathname-host pathname))
536 :lower)))))
537
538 (defun pathname-name (pathname &key (case :local))
539 (declare (type pathnamelike pathname)
540 (type (member :local :common) case))
541 (with-pathname (pathname pathname)
542 (maybe-diddle-case (%pathname-name pathname)
543 (and (eq case :common)
544 (eq (host-customary-case
545 (%pathname-host pathname))
546 :lower)))))
547
548 (defun pathname-type (pathname &key (case :local))
549 (declare (type pathnamelike pathname)
550 (type (member :local :common) case))
551 (with-pathname (pathname pathname)
552 (maybe-diddle-case (%pathname-type pathname)
553 (and (eq case :common)
554 (eq (host-customary-case
555 (%pathname-host pathname))
556 :lower)))))
557
558 (defun pathname-version (pathname)
559 (declare (type pathnamelike pathname))
560 (with-pathname (pathname pathname)
561 (%pathname-version pathname)))
562
563 (defun namestring (pathname)
564 "Construct the full (name)string form of the pathname."
565 (declare (type pathnamelike pathname))
566 (with-pathname (pathname pathname)
567 (let ((host (%pathname-host pathname)))
568 (cond ((logical-host-p host)
569 (funcall (logical-host-unparse host) pathname))
570 ((host-p host)
571 (funcall (host-unparse host) pathname))
572 (t
573 (error
574 "Cannot determine the namestring for pathnames with no ~
575 host:~% ~S" pathname))))))
576
577 (defun host-namestring (pathname)
578 (declare (type pathnamelike pathname))
579 (with-pathname (pathname pathname)
580 (let ((host (%pathname-host pathname)))
581 (if host
582 (funcall (host-unparse-host host) pathname)
583 (error
584 "Cannot determine the namestring for pathnames with no host:~% ~S"
585 pathname)))))
586
587 (defun directory-namestring (pathname)
588 (declare (type pathnamelike pathname))
589 (with-pathname (pathname pathname)
590 (let ((host (%pathname-host pathname)))
591 (if host
592 (funcall (host-unparse-directory host) pathname)
593 (error
594 "Cannot determine the namestring for pathnames with no host:~% ~S"
595 pathname)))))
596
597 (defun file-namestring (pathname)
598 (declare (type pathnamelike pathname))
599 (with-pathname (pathname pathname)
600 (let ((host (%pathname-host pathname)))
601 (if host
602 (funcall (host-unparse-file host) pathname)
603 (error
604 "Cannot determine the namestring for pathnames with no host:~% ~S"
605 pathname)))))
606
607 (defun enough-namestring (pathname
608 &optional (defaults *default-pathname-defaults*))
609 (declare (type pathnamelike pathname))
610 (with-pathname (pathname pathname)
611 (let ((host (%pathname-host pathname)))
612 (if host
613 (with-pathname (defaults defaults)
614 (funcall (host-unparse-enough host) pathname defaults))
615 (error
616 "Cannot determine the namestring for pathnames with no host:~% ~S"
617 pathname)))))
618
619
620 ;;;; Wild pathnames.
621
622 (defun wild-pathname-p (pathname &optional field-key)
623 (declare (type pathnamelike pathname)
624 (type (member nil :host :device :directory :name :type :version)
625 field-key))
626 (with-pathname (pathname pathname)
627 (ecase field-key
628 ((nil)
629 (or (wild-pathname-p pathname :host)
630 (wild-pathname-p pathname :device)
631 (wild-pathname-p pathname :directory)
632 (wild-pathname-p pathname :name)
633 (wild-pathname-p pathname :type)
634 (wild-pathname-p pathname :version)))
635 (:host
636 (pattern-p (%pathname-host pathname)))
637 (:device
638 (pattern-p (%pathname-host pathname)))
639 (:directory
640 (some #'pattern-p (%pathname-directory pathname)))
641 (:name
642 (pattern-p (%pathname-name pathname)))
643 (:type
644 (pattern-p (%pathname-type pathname)))
645 (:version
646 (eq (%pathname-version pathname) :wild)))))
647
648 (defun pattern-matches (pattern string)
649 (declare (type pattern pattern)
650 (type simple-string string))
651 (let ((len (length string)))
652 (labels ((maybe-prepend (subs cur-sub chars)
653 (if cur-sub
654 (let* ((len (length chars))
655 (new (make-string len))
656 (index len))
657 (dolist (char chars)
658 (setf (schar new (decf index)) char))
659 (cons new subs))
660 subs))
661 (matches (pieces start subs cur-sub chars)
662 (if (null pieces)
663 (if (= start len)
664 (values t (maybe-prepend subs cur-sub chars))
665 (values nil nil))
666 (let ((piece (car pieces)))
667 (etypecase piece
668 (simple-string
669 (let ((end (+ start (length piece))))
670 (and (<= end len)
671 (string= piece string
672 :start2 start :end2 end)
673 (matches (cdr pieces) end
674 (maybe-prepend subs cur-sub chars)
675 nil nil))))
676 (list
677 (ecase (car piece)
678 (:character-set
679 (and (< start len)
680 (let ((char (schar string start)))
681 (if (find char (cdr piece) :test #'char=)
682 (matches (cdr pieces) (1+ start) subs t
683 (cons char chars))))))))
684 ((member :single-char-wild)
685 (and (< start len)
686 (matches (cdr pieces) (1+ start) subs t
687 (cons (schar string start) chars))))
688 ((member :multi-char-wild)
689 (multiple-value-bind
690 (won new-subs)
691 (matches (cdr pieces) start subs t chars)
692 (if won
693 (values t new-subs)
694 (and (< start len)
695 (matches pieces (1+ start) subs t
696 (cons (schar string start)
697 chars)))))))))))
698 (multiple-value-bind
699 (won subs)
700 (matches (pattern-pieces pattern) 0 nil nil nil)
701 (values won (reverse subs))))))
702
703 (defun components-match (from to)
704 "Wilds in to are matched against from where both are either lists containing
705 :wild and :wild-inferiors, patterns or strings. FROM = :WILD-INFERIORS or
706 :WILD handled separately for directory component. Not communative."
707 (or (eq from to)
708 (typecase from
709 (simple-base-string
710 (typecase to
711 (pattern
712 (values (pattern-matches to from)))
713 (simple-base-string
714 (string-equal from to))))
715 (pattern
716 (and (pattern-p to) (pattern= from to)))
717 ((member :wild) ; :WILD component matches any string, or pattern or NIL.
718 (or (stringp to)
719 (logical-host-p to)
720 (pattern-p to)
721 (member to '(nil :unspecific :wild :wild-inferiors))))
722 (cons ; Watch for wildcards.
723 (and (consp from)
724 (let ((from1 (first from))
725 (from2 nil)
726 (to1 (first to)))
727 (typecase from1
728 ((member :wild)
729 (or (stringp to1)
730 (pattern-p to1)
731 (not to1)
732 (eq to1 ':unspecific)))
733 ((member :wild-inferiors)
734 (setf from2 (second from))
735 (cond ((not from2)
736 ;; Nothing left of from, hence anything else in to
737 ;; matches :wild-inferiors.
738 t)
739 ((components-match
740 (rest (rest from))
741 (rest (member from2 to :test #'equal))))))
742 (keyword ; :unspecific, :up, :back
743 (and (keywordp to1)
744 (eq from1 to1)
745 (components-match (rest from) (rest to))))
746 (string
747 (and (stringp to1)
748 (string-equal from1 to1)
749 (components-match (rest from) (rest to))))))))
750 ((member :back :up :unspecific nil)
751 (and (pattern-p from)
752 (equal (pattern-pieces from) '(:multi-char-wild)))))))
753
754 (defun pathname-match-p (pathname wildname)
755 "Pathname matches the wildname template?"
756 (with-pathname (pathname pathname)
757 (with-pathname (wildname wildname)
758 (macrolet ((frob (field)
759 `(or (null (,field wildname))
760 (components-match (,field wildname)
761 (,field pathname)))))
762 (and (frob %pathname-host)
763 (frob %pathname-device)
764 (frob %pathname-directory)
765 (frob %pathname-name)
766 (frob %pathname-type)
767 (or (null (%pathname-version wildname))
768 (eq (%pathname-version wildname) :wild)
769 (eql (%pathname-version pathname)
770 (%pathname-version wildname))))))))
771
772 (defun substitute-into (pattern subs)
773 (declare (type pattern pattern)
774 (type list subs))
775 (let ((in-wildcard nil)
776 (pieces nil)
777 (strings nil))
778 (dolist (piece (pattern-pieces pattern))
779 (cond ((simple-string-p piece)
780 (push piece strings)
781 (setf in-wildcard nil))
782 (in-wildcard)
783 ((null subs))
784 (t
785 (let ((sub (pop subs)))
786 (etypecase sub
787 (pattern
788 (when strings
789 (push (apply #'concatenate 'simple-string
790 (nreverse strings))
791 pieces))
792 (dolist (piece (pattern-pieces sub))
793 (push piece pieces)))
794 (simple-string
795 (push sub strings))))
796 (setf in-wildcard t))))
797 (when strings
798 (push (apply #'concatenate 'simple-string
799 (nreverse strings))
800 pieces))
801 (if (and pieces
802 (simple-string-p (car pieces))
803 (null (cdr pieces)))
804 (car pieces)
805 (make-pattern (nreverse pieces)))))
806
807 (defun translate-component (source from to)
808 (typecase to
809 (pattern
810 (if (pattern-p from)
811 (typecase source
812 (pattern
813 (if (pattern= from source)
814 source
815 :error))
816 (simple-string
817 (multiple-value-bind
818 (won subs)
819 (pattern-matches from source)
820 (if won
821 (values (substitute-into to subs))
822 :error)))
823 (t
824 :error))
825 source))
826 ((member nil :wild)
827 source)
828 (t
829 (if (components-match source from)
830 to
831 :error))))
832
833 (defun translate-directories (source from to)
834 (if (null to)
835 source
836 (let ((subs nil))
837 (loop
838 for from-part in from
839 for source-part in source
840 do (when (pattern-p from-part)
841 (typecase source-part
842 (pattern
843 (if (pattern= from-part source-part)
844 (setf subs (append subs (list source-part)))
845 (return-from translate-directories :error)))
846 (simple-string
847 (multiple-value-bind
848 (won new-subs)
849 (pattern-matches from-part source-part)
850 (if won
851 (setf subs (append subs new-subs))
852 (return-from translate-directories :error))))
853 ((member :back :up)
854 (if (equal (pattern-pieces from-part)
855 '(:multi-char-wild))
856 (setf subs (append subs (list source-part)))
857 (return-from translate-directories :error)))
858 (t
859 (return-from translate-directories :error)))))
860 (mapcar #'(lambda (to-part)
861 (if (pattern-p to-part)
862 (if (or (eq (car subs) :up) (eq (car subs) :back))
863 (if (equal (pattern-pieces to-part)
864 '(:multi-char-wild))
865 (pop subs)
866 (error "Can't splice ~S into the middle of a ~
867 wildcard pattern."
868 (car subs)))
869 (multiple-value-bind
870 (new new-subs)
871 (substitute-into to-part subs)
872 (setf subs new-subs)
873 new))
874 to-part))
875 to))))
876
877 (defun translate-pathname (source from-wildname to-wildname &key)
878 (declare (type pathnamelike source from-wildname to-wildname))
879 (with-pathname (source source)
880 (with-pathname (from from-wildname)
881 (with-pathname (to to-wildname)
882 (macrolet ((frob (field)
883 `(let ((result (translate-component (,field source)
884 (,field from)
885 (,field to))))
886 (if (eq result :error)
887 (error "~S doesn't match ~S" source from)
888 result))))
889 (%make-pathname (frob %pathname-host)
890 (frob %pathname-device)
891 (let ((result (translate-directories
892 (%pathname-directory source)
893 (%pathname-directory from)
894 (%pathname-directory to))))
895 (if (eq result :error)
896 (error "~S doesn't match ~S" source from)
897 result))
898 (frob %pathname-name)
899 (frob %pathname-type)
900 (frob %pathname-version)))))))
901
902
903 ;;;; Search lists.
904
905 ;;; The SEARCH-LIST structure.
906 ;;;
907 (defstruct (search-list
908 (:print-function %print-search-list)
909 (:make-load-form-fun
910 (lambda (search-list)
911 (values `(intern-search-list ',(search-list-name search-list))
912 nil))))
913 ;;
914 ;; The name of this search-list. Always stored in lowercase.
915 (name (required-argument) :type simple-string)
916 ;;
917 ;; T if this search-list has been defined. Otherwise NIL.
918 (defined nil :type (member t nil))
919 ;;
920 ;; The list of expansions for this search-list. Each expansion is the list
921 ;; of directory components to use in place of this search-list.
922 (%expansions (%primitive c:make-value-cell nil))); :type list))
923
924 (defun search-list-expansions (x)
925 (%primitive c:value-cell-ref (search-list-%expansions x)))
926
927 (defun (setf search-list-expansions) (val x)
928 (%primitive c:value-cell-set (search-list-%expansions x) val))
929
930 (defun %print-search-list (sl stream depth)
931 (declare (ignore depth))
932 (print-unreadable-object (sl stream :type t)
933 (write-string (search-list-name sl) stream)))
934
935 ;;; *SEARCH-LISTS* -- internal.
936 ;;;
937 ;;; Hash table mapping search-list names to search-list structures.
938 ;;;
939 (defvar *search-lists* (make-hash-table :test #'equal))
940
941 ;;; INTERN-SEARCH-LIST -- internal interface.
942 ;;;
943 ;;; When search-lists are encountered in namestrings, they are converted to
944 ;;; search-list structures right then, instead of waiting until the search
945 ;;; list used. This allows us to verify ahead of time that there are no
946 ;;; circularities and makes expansion much quicker.
947 ;;;
948 (defun intern-search-list (name)
949 (let ((name (string-downcase name)))
950 (or (gethash name *search-lists*)
951 (let ((new (make-search-list :name name)))
952 (setf (gethash name *search-lists*) new)
953 new))))
954
955 ;;; CLEAR-SEARCH-LIST -- public.
956 ;;;
957 ;;; Clear the definition. Note: we can't remove it from the hash-table
958 ;;; because there may be pathnames still refering to it. So we just clear
959 ;;; out the expansions and ste defined to NIL.
960 ;;;
961 (defun clear-search-list (name)
962 "Clear the current definition for the search-list NAME. Returns T if such
963 a definition existed, and NIL if not."
964 (let* ((name (string-downcase name))
965 (search-list (gethash name *search-lists*)))
966 (when (and search-list (search-list-defined search-list))
967 (setf (search-list-defined search-list) nil)
968 (setf (search-list-expansions search-list) nil)
969 t)))
970
971 ;;; CLEAR-ALL-SEARCH-LISTS -- sorta public.
972 ;;;
973 ;;; Again, we can't actually remove the entries from the hash-table, so we
974 ;;; just mark them as being undefined.
975 ;;;
976 (defun clear-all-search-lists ()
977 "Clear the definition for all search-lists. Only use this if you know
978 what you are doing."
979 (maphash #'(lambda (name search-list)
980 (declare (ignore name))
981 (setf (search-list-defined search-list) nil)
982 (setf (search-list-expansions search-list) nil))
983 *search-lists*)
984 nil)
985
986 ;;; EXTRACT-SEARCH-LIST -- internal.
987 ;;;
988 ;;; Extract the search-list from PATHNAME and return it. If PATHNAME
989 ;;; doesn't start with a search-list, then either error (if FLAME-IF-NONE
990 ;;; is true) or return NIL (if FLAME-IF-NONE is false).
991 ;;;
992 (defun extract-search-list (pathname flame-if-none)
993 (with-pathname (pathname pathname)
994 (let* ((directory (%pathname-directory pathname))
995 (search-list (cadr directory)))
996 (cond ((search-list-p search-list)
997 search-list)
998 (flame-if-none
999 (error "~S doesn't start with a search-list." pathname))
1000 (t
1001 nil)))))
1002
1003 ;;; SEARCH-LIST -- public.
1004 ;;;
1005 ;;; We have to convert the internal form of the search-list back into a
1006 ;;; bunch of pathnames.
1007 ;;;
1008 (defun search-list (pathname)
1009 "Return the expansions for the search-list starting PATHNAME. If PATHNAME
1010 does not start with a search-list, then an error is signaled. If
1011 the search-list has not been defined yet, then an error is signaled.
1012 The expansion for a search-list can be set with SETF."
1013 (with-pathname (pathname pathname)
1014 (let ((search-list (extract-search-list pathname t))
1015 (host (pathname-host pathname)))
1016 (if (search-list-defined search-list)
1017 (mapcar #'(lambda (directory)
1018 (make-pathname :host host
1019 :directory (cons :absolute directory)))
1020 (search-list-expansions search-list))
1021 (error "Search list ~S has not been defined yet." pathname)))))
1022
1023 ;;; SEARCH-LIST-DEFINED-P -- public.
1024 ;;;
1025 (defun search-list-defined-p (pathname)
1026 "Returns T if the search-list starting PATHNAME is currently defined, and
1027 NIL otherwise. An error is signaled if PATHNAME does not start with a
1028 search-list."
1029 (with-pathname (pathname pathname)
1030 (search-list-defined (extract-search-list pathname t))))
1031
1032 ;;; %SET-SEARCH-LIST -- public setf method
1033 ;;;
1034 ;;; Set the expansion for the search-list in PATHNAME. If this would result
1035 ;;; in any circularities, we flame out. If anything goes wrong, we leave the
1036 ;;; old defintion intact.
1037 ;;;
1038 (defun %set-search-list (pathname values)
1039 (let ((search-list (extract-search-list pathname t)))
1040 (labels
1041 ((check (target-list path)
1042 (when (eq search-list target-list)
1043 (error "That would result in a circularity:~% ~
1044 ~A~{ -> ~A~} -> ~A"
1045 (search-list-name search-list)
1046 (reverse path)
1047 (search-list-name target-list)))
1048 (when (search-list-p target-list)
1049 (push (search-list-name target-list) path)
1050 (dolist (expansion (search-list-expansions target-list))
1051 (check (car expansion) path))))
1052 (convert (pathname)
1053 (with-pathname (pathname pathname)
1054 (when (or (pathname-name pathname)
1055 (pathname-type pathname)
1056 (pathname-version pathname))
1057 (error "Search-lists cannot expand into pathnames that have ~
1058 a name, type, or ~%version specified:~% ~S"
1059 pathname))
1060 (let ((directory (pathname-directory pathname)))
1061 (let ((expansion
1062 (if directory
1063 (ecase (car directory)
1064 (:absolute (cdr directory))
1065 (:relative (cons (intern-search-list "default")
1066 (cdr directory))))
1067 (list (intern-search-list "default")))))
1068 (check (car expansion) nil)
1069 expansion)))))
1070 (setf (search-list-expansions search-list)
1071 (if (listp values)
1072 (mapcar #'convert values)
1073 (list (convert values)))))
1074 (setf (search-list-defined search-list) t))
1075 values)
1076
1077 ;;; ENUMERATE-SEARCH-LIST -- public.
1078 ;;;
1079 (defmacro enumerate-search-list ((var pathname &optional result) &body body)
1080 "Execute BODY with VAR bound to each successive possible expansion for
1081 PATHNAME and then return RESULT. Note: if PATHNAME does not contain a
1082 search-list, then BODY is executed exactly once. Everything is wrapped
1083 in a block named NIL, so RETURN can be used to terminate early. Note:
1084 VAR is *not* bound inside of RESULT."
1085 (let ((body-name (gensym)))
1086 `(block nil
1087 (flet ((,body-name (,var)
1088 ,@body))
1089 (%enumerate-search-list ,pathname #',body-name)
1090 ,result))))
1091
1092 (defun %enumerate-search-list (pathname function)
1093 (let ((search-list (extract-search-list pathname nil)))
1094 (cond
1095 ((not search-list)
1096 (funcall function pathname))
1097 ((not (search-list-defined search-list))
1098 (error "Undefined search list: ~A"
1099 (search-list-name search-list)))
1100 (t
1101 (let ((tail (cddr (pathname-directory pathname))))
1102 (dolist (expansion
1103 (search-list-expansions search-list))
1104 (%enumerate-search-list (make-pathname :defaults pathname
1105 :directory
1106 (cons :absolute
1107 (append expansion
1108 tail)))
1109 function)))))))
1110
1111
1112 ;;;; Logical pathname support. ANSI 92-102 specification.
1113
1114 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1115 ;;;
1116 ;;; Logical pathnames have the following format:
1117 ;;;
1118 ;;; logical-namestring ::=
1119 ;;; [host ":"] [";"] {directory ";"}* [name] ["." type ["." version]]
1120 ;;;
1121 ;;; host ::= word
1122 ;;; directory ::= word | wildcard-word | **
1123 ;;; name ::= word | wildcard-word
1124 ;;; type ::= word | wildcard-word
1125 ;;; version ::= pos-int | newest | NEWEST | *
1126 ;;; word ::= {uppercase-letter | digit | -}+
1127 ;;; wildcard-word ::= [word] '* {word '*}* [word]
1128 ;;; pos-int ::= integer > 0
1129 ;;;
1130 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1131
1132 ;; Logical pathnames are a subclass of pathnames and can use the same
1133 ;; data structures with the device slot necessarily nil. The current lack of
1134 ;; an integrated efficient CLOS means that the classes are mimiced using
1135 ;; structures. They follow the pattern set by search-lists, a CMUCL specific
1136 ;; extension.
1137
1138 (defstruct (logical-host
1139 (:include host
1140 (:parse #'parse-logical-namestring)
1141 (:unparse #'unparse-logical-namestring)
1142 (:unparse-host #'unparse-logical-host)
1143 (:unparse-directory #'unparse-logical-directory)
1144 (:unparse-file #'unparse-logical-file)
1145 (:unparse-enough #'identity)
1146 (:customary-case ':lower)))
1147 (name "" :type simple-string)
1148 (translations nil :type list)
1149 (canon-transls nil :type list))
1150
1151 (deftype logical-pathname ()
1152 '(satisfies logical-pathname-p))
1153
1154 (defun logical-pathname-p (thing)
1155 "Return T if THING is a LOGICAL-PATHNAME object."
1156 (and (pathnamep thing)
1157 (logical-host-p (%pathname-host thing))))
1158
1159 ;;; *LOGICAL-PATHNAMES* --internal.
1160 ;;;
1161 ;;; Hash table searching maps a logical-pathname's host to their physical
1162 ;;; pathname translation.
1163
1164 (defvar *logical-pathnames* (make-hash-table :test #'equal))
1165
1166 (define-condition logical-namestring-parse-error (error)
1167 ((complaint :init-form (required-argument))
1168 (arguments :init-form nil)
1169 (namestring :init-form (required-argument))
1170 (offset :init-form (required-argument)))
1171 (:report %print-namestring-parse-error))
1172
1173 (defun maybe-make-logical-pattern (namestr start end)
1174 "Take the ; reduced strings and break them into words and wildcard-words."
1175 (declare (type simple-base-string namestr)
1176 (type index start end))
1177 (collect ((pattern))
1178 (let ((last-regular-char nil)
1179 (look-ahead+1 nil)
1180 (index start)
1181 (char nil))
1182 (flet ((flush-pending-regulars ()
1183 (when last-regular-char
1184 (pattern (subseq namestr last-regular-char index))
1185 (setf last-regular-char nil))))
1186 (loop
1187 (when (>= index end)
1188 (return))
1189 (setf char (schar namestr index))
1190 (cond ((or (char= #\. char) (char= #\; char)) ; End of pattern piece.
1191 (flush-pending-regulars))
1192 ((or (char= #\- char) ; Hyphen is a legal word character.
1193 (alphanumericp char)) ; Building a word.
1194 (unless last-regular-char
1195 (setf last-regular-char index)))
1196 ((char= #\* char) ; Wildcard word, :wild or wildcard-inferior.
1197 (if (<= end index)
1198 (setf look-ahead+1 nil)
1199 (setf look-ahead+1 (schar namestr (1+ index))))
1200 (cond ((or (char= #\. look-ahead+1)
1201 (char= #\; look-ahead+1))
1202 (flush-pending-regulars)
1203 (pattern :wild)
1204 (incf index)) ; skip * and ;
1205 ((and (char= #\* look-ahead+1)
1206 (char= #\; (schar namestr (+ 2 index))))
1207 (pattern :wild-inferiors)
1208 (setq last-regular-char nil)
1209 (incf index 2)) ; skip ** and ;
1210 (t ; wildcard-word, keep going
1211 (flush-pending-regulars)
1212 (pattern :wild)
1213 (incf index)
1214 (unless last-regular-char
1215 (setf last-regular-char index))
1216 )))
1217 (t (error "Incorrect logical pathname syntax.")))
1218 (incf index))
1219 (flush-pending-regulars))
1220 (cond ((null (pattern))
1221 "")
1222 ((and (null (cdr (pattern)))
1223 (simple-string-p (car (pattern))))
1224 (car (pattern)))
1225 ((= 1 (length (pattern)))
1226 (let ((elmt (first (pattern))))
1227 (if (or (eq elmt ':wild) (eq elmt ':wild-inferiors))
1228 elmt)))
1229 (t
1230 (make-pattern (pattern)))))))
1231
1232 (defun intern-logical-host (name)
1233 (declare (simple-string name)
1234 (values logical-host))
1235 (let ((name (string-upcase name)))
1236 (or (gethash name *logical-pathnames*)
1237 (let ((new (make-logical-host :name name)))
1238 (setf (gethash name *logical-pathnames*) new)
1239 new))))
1240
1241 ;;; parse-namestring and merge-pathnames must be upgraded to include
1242 ;;; logical-namestrings, as required by the ANSI spec.
1243
1244 ;;; A large set of functions must be upgraded to accept logical-pathnames,
1245 ;;; even if they do not accept logical-pathname strings.
1246
1247 (defun extract-logical-name-type-and-version (namestr start end)
1248 (declare (type simple-base-string namestr)
1249 (type index start end))
1250 (let* ((last-dot (position #\. namestr :start (1+ start) :end end
1251 :from-end t))
1252 (second-to-last-dot (and last-dot
1253 (position #\. namestr :start (1+ start)
1254 :end last-dot :from-end t)))
1255 (version :newest))
1256 ;; If there is a second-to-last dot, check to see if there is a valid
1257 ;; version after the last dot.
1258 (when second-to-last-dot
1259 (cond ((and (= (+ last-dot 2) end)
1260 (char= (schar namestr (1+ last-dot)) #\*))
1261 (setf version :wild))
1262 ((and (< (1+ last-dot) end)
1263 (do ((index (1+ last-dot) (1+ index)))
1264 ((= index end) t)
1265 (unless (char<= #\0 (schar namestr index) #\9)
1266 (return nil))))
1267 (setf version
1268 (parse-integer namestr :start (1+ last-dot) :end end)))
1269 (t
1270 (setf second-to-last-dot nil))))
1271 (cond (second-to-last-dot
1272 (values (maybe-make-logical-pattern
1273 namestr start second-to-last-dot)
1274 (maybe-make-logical-pattern
1275 namestr (1+ second-to-last-dot) last-dot)
1276 version))
1277 (last-dot
1278 (values (maybe-make-logical-pattern namestr start last-dot)
1279 (maybe-make-logical-pattern namestr (1+ last-dot) end)
1280 version))
1281 (t
1282 (values (maybe-make-logical-pattern namestr start end)
1283 nil
1284 version)))))
1285
1286 (declaim (inline copy-string))
1287
1288 (defun copy-string (str start end)
1289 (declare (type simple-base-string str)
1290 (type index start end)
1291 (values simple-base-string))
1292 (let* ((bnd (- end start))
1293 (len (length str))
1294 (res (make-string bnd)))
1295 (if (and (<= start end) (<= bnd len))
1296 (dotimes (i bnd res)
1297 (setf (schar res i) (schar str i)))
1298 (error "Cannot copy string ~S given the bounds ~D,~D" str start end))))
1299
1300 (defun logical-word-p (word)
1301 (declare (type simple-base-string word)
1302 (values boolean))
1303 (let ((ch nil))
1304 (dotimes (i (length word))
1305 (setf ch (schar word i))
1306 (unless (or (alphanumericp ch) (eq ch #\-))
1307 (return-from logical-word-p nil))))
1308 t)
1309
1310 (defun maybe-extract-logical-host (namestr start end)
1311 "Verify whether there is a logical host prefix in the namestr. If one is
1312 found return its name and the index of the remainder of the namestring.
1313 If not return nil."
1314 (declare (type simple-base-string namestr)
1315 (type index start)
1316 (type index start end)
1317 (values (or (member :wild) simple-base-string null) (or null index)))
1318 (let ((colon-pos (position #\: namestr :start start :end end)))
1319 (if colon-pos
1320 (let ((host (copy-string namestr start colon-pos)))
1321 (cond ((logical-word-p host)
1322 (return-from maybe-extract-logical-host
1323 (values (string-upcase host) (1+ colon-pos))))
1324 ((string= host "*")
1325 (return-from maybe-extract-logical-host
1326 (values ':wild (1+ colon-pos))))))
1327 ;; Implied host
1328 (values nil 0))))
1329
1330 (defun parse-logical-namestring (namestr start end)
1331 "Break up a logical-namestring into its constituent parts."
1332 (declare (type simple-base-string namestr)
1333 (type index start end)
1334 (values (or logical-host null)
1335 (or (member nil :unspecific) simple-base-string)
1336 list
1337 (or simple-base-string list pattern (member :wild))
1338 (or simple-string pattern null (member :unspecific :wild))
1339 (or integer null (member :newest :wild))))
1340 (multiple-value-bind ; Parse for :
1341 (host place)
1342 (maybe-extract-logical-host namestr start end)
1343 (typecase host
1344 (keyword t) ; :wild for example.
1345 (simple-string ; Already a search-list element?
1346 (unless (gethash (string-downcase host) *search-lists*)
1347 (setf host (intern-logical-host host))))
1348 (null nil))
1349 (multiple-value-bind
1350 (absolute pieces)
1351 (split-at-slashes namestr place end #\;)
1352 ;; Logical paths follow opposite convention of physical pathnames.
1353 (setf absolute (not absolute))
1354 (multiple-value-bind (name type version)
1355 (let* ((tail (car (last pieces)))
1356 (tail-start (car tail))
1357 (tail-end (cdr tail)))
1358 (unless (= tail-start tail-end)
1359 (setf pieces (butlast pieces))
1360 (extract-logical-name-type-and-version
1361 namestr tail-start tail-end)))
1362 ;; Now we have everything we want. So return it.
1363 (values host
1364 ':unspecific
1365 (collect ((dirs))
1366 (dolist (piece pieces)
1367 (let ((piece-start (car piece))
1368 (piece-end (cdr piece)))
1369 (unless (= piece-start piece-end)
1370 (let ((dir (maybe-make-logical-pattern namestr
1371 piece-start
1372 piece-end)))
1373 (if (and (simple-string-p dir)
1374 (string= dir ".."))
1375 (dirs :up)
1376 (dirs dir))))))
1377 (cond (absolute
1378 (cons :absolute (dirs)))
1379 ((dirs)
1380 (cons :relative (dirs)))
1381 (t
1382 nil)))
1383 name
1384 type
1385 version)))))
1386
1387 (defun unparse-logical-directory-list (directory)
1388 (declare (type list directory))
1389 (collect ((pieces))
1390 (when directory
1391 (ecase (pop directory)
1392 (:absolute
1393 ;; Nothing special.
1394 )
1395 (:relative
1396 (pieces ";")
1397 ))
1398 (dolist (dir directory)
1399 (cond ((or (stringp dir) (pattern-p dir))
1400 (pieces (unparse-logical-piece dir))
1401 (pieces ";"))
1402 ((eq dir ':wild)
1403 (pieces "*;"))
1404 ((eq dir ':wild-inferiors)
1405 (pieces "**;"))
1406 (t
1407 (error "Invalid directory component: ~S" dir)))))
1408 (apply #'concatenate 'simple-string (pieces))))
1409
1410 (defun unparse-logical-directory (pathname)
1411 (declare (type pathname pathname))
1412 (unparse-logical-directory-list (%pathname-directory pathname)))
1413
1414 (defun unparse-logical-piece (thing)
1415 (etypecase thing
1416 (simple-string
1417 (let* ((srclen (length thing))
1418 (dstlen srclen))
1419 (dotimes (i srclen)
1420 (case (schar thing i)
1421 (#\*
1422 (incf dstlen))))
1423 (let ((result (make-string dstlen))
1424 (dst 0))
1425 (dotimes (src srclen)
1426 (let ((char (schar thing src)))
1427 (case char
1428 (#\*
1429 (setf (schar result dst) #\\)
1430 (incf dst)))
1431 (setf (schar result dst) char)
1432 (incf dst)))
1433 result)))
1434 (pattern
1435 (collect ((strings))
1436 (dolist (piece (pattern-pieces thing))
1437 (typecase piece
1438 (simple-string
1439 (strings piece))
1440 (keyword
1441 (cond ((eq piece ':wild-inferiors)
1442 (strings "**"))
1443 ((eq piece ':wild)
1444 (strings "*"))
1445 (t (error "Invalid keyword: ~S" piece))))
1446 (t
1447 (error "Invalid pattern piece: ~S" piece))))
1448 (apply #'concatenate
1449 'simple-string
1450 (strings))))))
1451
1452 (defun unparse-logical-file (pathname)
1453 (declare (type pathname pathname))
1454 (declare (type pathname pathname))
1455 (unparse-unix-file pathname))
1456
1457 (defun unparse-logical-host (pathname)
1458 (declare (type logical-pathname pathname))
1459 (logical-host-name (%pathname-host pathname)))
1460
1461 (defun unparse-logical-namestring (pathname)
1462 (declare (type logical-pathname pathname))
1463 (concatenate 'simple-string
1464 (unparse-logical-host pathname) ":"
1465 (unparse-logical-directory pathname)
1466 (unparse-logical-file pathname)))
1467
1468 ;;; Logical-pathname must signal a type error of type type-error.
1469
1470 (defun logical-pathname (pathspec)
1471 "Converts the pathspec argument to a logical-pathname and returns it."
1472 (declare (type (or logical-pathname string stream) pathspec)
1473 (values logical-pathname))
1474 ;; Decide whether to typedef logical-pathname, logical-pathname-string,
1475 ;; or streams for which the pathname function returns a logical-pathname.
1476 (cond ((logical-pathname-p pathspec) pathspec)
1477 ((stringp pathspec)
1478 (if (maybe-extract-logical-host pathspec 0 (length pathspec))
1479 (pathname pathspec)
1480 (error "Pathspec is not a logical pathname prefaced by <host>:.")))
1481 ((streamp pathspec)
1482 (if (logical-pathname-p pathspec)
1483 (pathname pathspec)
1484 (error "Stream ~S is not a logical-pathname." pathspec)))
1485 (t
1486 (error "~S is not either ~%
1487 a logical-pathname object, or~%
1488 a logical pathname namestring, or~%
1489 a stream named by a logical pathname." pathspec))))
1490
1491
1492 (defun translations-test-p (transl-list host)
1493 "Verify that the list of translations consists of lists and prepare
1494 canonical translations from the pathnames."
1495 (declare (type logical-host host)
1496 (type list transl-list)
1497 (values boolean))
1498 (let ((can-transls nil))
1499 (setf can-transls (make-list (length transl-list))
1500 (logical-host-canon-transls host) can-transls)
1501 (do* ((i 0 (1+ i))
1502 (tr (nth i transl-list) (nth i transl-list))
1503 (from-path (first tr) (first tr))
1504 (to-path (second tr) (second tr))
1505 (c-tr (nth i can-transls) (nth i can-transls)))
1506 ((<= (length transl-list) i))
1507 (setf c-tr (make-list 2))
1508 (if (logical-pathname-p from-path)
1509 (setf (first c-tr) from-path)
1510 (setf (first c-tr) (parse-namestring from-path host)))
1511 (if (pathnamep to-path)
1512 (setf (second c-tr) to-path)
1513 (setf (second c-tr) (parse-namestring to-path)))
1514 ;; Verify form of translations.
1515 (unless (and (or (logical-pathname-p from-path)
1516 (first c-tr))
1517 (second c-tr))
1518 (return-from translations-test-p nil))
1519 (setf (nth i can-transls) c-tr)))
1520 (setf (logical-host-translations host) transl-list)
1521 t)
1522
1523 (defun logical-pathname-translations (host)
1524 "Return the (logical) host object argument's list of translations."
1525 (declare (type (or simple-base-string logical-host) host)
1526 (values list))
1527 (etypecase host
1528 (simple-string
1529 (setf host (string-upcase host))
1530 (let ((host-struc (gethash host *logical-pathnames*)))
1531 (if host-struc
1532 (logical-host-translations host-struc)
1533 (error "HOST ~S is not defined." host))))
1534 (logical-host
1535 (logical-host-translations host))))
1536
1537 (defun (setf logical-pathname-translations) (translations host)
1538 "Set the translations list for the logical host argument.
1539 Return translations."
1540 (declare (type (or simple-base-string logical-host) host)
1541 (type list translations)
1542 (values list))
1543 (typecase host
1544 (simple-base-string
1545 (setf host (string-upcase host))
1546 (multiple-value-bind
1547 (hash-host xst?)
1548 (gethash host *logical-pathnames*)
1549 (unless xst?
1550 (intern-logical-host host)
1551 (setf hash-host (gethash host *logical-pathnames*)))
1552 (unless (translations-test-p translations hash-host)
1553 (error "Translations ~S is not a list of pairs of from-, ~
1554 to-pathnames." translations)))
1555 translations)
1556 (t
1557 (unless (translations-test-p translations host)
1558 (error "Translations ~S is not a list of pairs of from-, ~
1559 to-pathnames." translations))
1560 translations)))
1561
1562 ;;; The search mechanism for loading pathname translations uses the CMUCL
1563 ;;; extension of search-lists. The user can add to the library: search-list
1564 ;;; using setf. The file for translations should have the name defined by
1565 ;;; the host name (a string) and with type component "translations".
1566
1567 (defun save-logical-pathname-translations (host directory)
1568 "Save the translations for host in the file named host in
1569 the directory argument. This is an internal convenience function and
1570 not part of the ANSI standard."
1571 (declare (type simple-base-string host directory))
1572 (setf host (string-upcase host))
1573 (let* ((p-name (make-pathname :directory (%pathname-directory
1574 (pathname directory))
1575 :name host
1576 :type "translations"
1577 :version :newest))
1578 (new-stuff (gethash host *logical-pathnames*))
1579 (new-transl (logical-host-translations new-stuff)))
1580 (with-open-file (out-str p-name
1581 :direction :output
1582 :if-exists :new-version
1583 :if-does-not-exist :create)
1584 (write new-transl :stream out-str)
1585 (format t "Created a new version of the file:~% ~
1586 ~S~% ~
1587 containing logical-pathname translations:~% ~
1588 ~S~% ~
1589 for the host:~% ~
1590 ~S.~%" p-name new-transl host))))
1591
1592 ;;; Define a SYS area for system dependent logical translations, should we
1593 ;;; ever want to use them.
1594
1595 (progn
1596 (intern-logical-host "SYS")
1597 (save-logical-pathname-translations "SYS" "library:"))
1598
1599 (defun load-logical-pathname-translations (host)
1600 "Search for a logical pathname named host, if not already defined. If already
1601 defined no attempt to find or load a definition is attempted and NIL is
1602 returned. If host is not already defined, but definition is found and loaded
1603 successfully, T is returned, else error."
1604 (declare (type simple-base-string host)
1605 (values boolean))
1606 (setf host (string-upcase host))
1607 (let ((p-name nil)
1608 (p-trans nil))
1609 (multiple-value-bind
1610 (log-host xst?)
1611 (gethash host *logical-pathnames*)
1612 (if xst?
1613 ;; host already has a set of defined translations.
1614 (return-from load-logical-pathname-translations nil)
1615 (enumerate-search-list (p "library:")
1616 (setf p-name (make-pathname :host (%pathname-host p)
1617 :directory (%pathname-directory p)
1618 :device (%pathname-device p)
1619 :name host
1620 :type "translations"
1621 :version :newest))
1622 (if (member p-name (directory p) :test #'pathname=)
1623 (with-open-file (in-str p-name
1624 :direction :input
1625 :if-does-not-exist :error)
1626 (setf p-trans (read in-str))
1627 (setf log-host (intern-logical-host host))
1628 (format t ";; Loading ~S~%" p-name)
1629 (unless (translations-test-p p-trans log-host)
1630 (error "Translations ~S is not a list of pairs of from-, ~
1631 to-pathnames." p-trans))
1632 (format t ";; Loading done.~%")
1633 (return-from load-logical-pathname-translations t))))))))
1634
1635 (defun compile-file-pathname (file-path &key output-file)
1636 (declare (type (or string stream pathname logical-pathname) file-path)
1637 (type (or string stream pathname logical-pathname) output-file)
1638 (values pathname))
1639 (with-pathname (path file-path)
1640 (cond ((and (logical-pathname-p path) (not output-file))
1641 (make-pathname :host (%pathname-host path)
1642 :directory (%pathname-directory path)
1643 :device (%pathname-device path)
1644 :name (%pathname-name path)
1645 :type (c:backend-fasl-file-type c:*backend*)))
1646 ((logical-pathname-p path)
1647 (translate-logical-pathname path))
1648 (t file-path))))
1649
1650 (defmacro translate-wild-p (to-obj)
1651 "Translate :wild?"
1652 (declare (type keyword to-obj))
1653 `(etypecase ,to-obj
1654 ((or (member :wild :unspecific nil :up :back)
1655 string
1656 pattern)
1657 t)))
1658
1659 (defun intermediate-rep (from to)
1660 "A logical component transition function that translates from one argument
1661 to the other. This function is specific to the CMUCL implementation."
1662 (declare (type (or logical-host host simple-base-string pattern symbol list)
1663 from)
1664 (type (or logical-host host simple-base-string pattern symbol list)
1665 to)
1666 (values
1667 (or logical-host host simple-base-string pattern list symbol)))
1668 (etypecase from
1669 (logical-host
1670 (if (or (host-p to) (logical-host-p to))
1671 to))
1672 (host
1673 (if (host-p to)
1674 to))
1675 (simple-base-string
1676 (etypecase to
1677 (pattern
1678 (multiple-value-bind
1679 (won subs)
1680 (pattern-matches to from)
1681 (if won
1682 (values (substitute-into to subs))
1683 (error "String ~S failed to match pattern ~S" from to))))
1684 (simple-base-string to)
1685 ((member nil :wild :wild-inferiors) from)))
1686 (pattern
1687 (etypecase to
1688 (pattern
1689 (if (pattern= to from)
1690 to
1691 (error "Patterns ~S and ~S do not match.")))))
1692 ((member :absolute :relative)
1693 (if (eq to from)
1694 to
1695 (error "The directory bases (FROM = ~S, TO = ~S) for the logical ~%~
1696 pathname translation are not consistently relative or absolute." from to)))
1697 ((member :wild)
1698 (etypecase to
1699 ((or string
1700 pattern
1701 (member nil :unspecific :newest :wild :wild-inferiors))
1702 to)))
1703 ((member :wild-inferiors) ; Only when single directory component.
1704 (etypecase to
1705 ((or string pattern cons (member nil :unspecific :wild :wild-inferiors))
1706 to)))
1707 ((member :unspecific nil)
1708 from)
1709 ((member :newest)
1710 (case to
1711 (:wild from)
1712 (:unspecific :unspecific)
1713 (:newest to)
1714 ((member nil) from)))))
1715
1716 (proclaim '(inline translate-logical-component copy-sublist))
1717
1718 (defun translate-logical-component (source from to)
1719 (intermediate-rep (intermediate-rep source from) to))
1720
1721 (defun copy-sublist (lst &key start end)
1722 (let* ((res (make-list (- end start))))
1723 (do ((i start (1+ start))
1724 (j 0 (1+ j)))
1725 ((<= start i))
1726 (setf (nth j res) (nth i lst)))
1727 res))
1728
1729 (defun translate-logical-directory (source from to)
1730 "Translate logical directories within the UNIX heirarchical file system."
1731 ;; Handle unfilled components.
1732 (if (or (eql source ':UNSPECIFIC)
1733 (eql from ':UNSPECIFIC)
1734 (eql to ':UNSPECIFIC))
1735 (return-from translate-logical-directory ':UNSPECIFIC))
1736 (if (or (not source) (not from) (not to))
1737 (return-from translate-logical-directory nil))
1738 ;; Handle directory component abbreviated as a wildcard.
1739 (if (member source '(:WILD :WILD-INFERIORS))
1740 (setf source '(:ABSOLUTE :WILD-INFERIORS)))
1741 (if (member source '(:WILD :WILD-INFERIORS))
1742 (setf source '(:ABSOLUTE :WILD-INFERIORS)))
1743 (if (member source '(:WILD :WILD-INFERIORS))
1744 (setf to '(:ABSOLUTE :WILD-INFERIORS)))
1745 ;; Make two stage translation, storing the intermediate results in ires
1746 ;; and finally returned in the list rres.
1747 (let ((ires nil)
1748 (rres nil)
1749 (dummy nil)
1750 (slen (length source))
1751 (flen (length from))
1752 (tlen (length to)))
1753 (do* ((i 0 (1+ i))
1754 (j 0 (1+ j))
1755 (k 0)
1756 (s-el (nth i source) (nth i source))
1757 (s-next-el nil)
1758 (f-el (nth j from) (nth j from)))
1759 ((<= slen i))
1760 (cond ((eq s-el ':wild-inferiors)
1761 (setf s-next-el (nth (+ 1 i) source)) ; NIL if beyond end.
1762 (if (setf k (position s-next-el from :start (1+ j)))
1763 ;; Found it, splice this portion into ires.
1764 (setf ires
1765 (append ires
1766 (copy-sublist from :start j :end (1- k)))
1767 j (1- k))
1768 (progn
1769 ;; Either did not find next source element in from,
1770 ;; or was nil.
1771 (setf ires
1772 (append ires
1773 (copy-sublist from :start j :end flen)))
1774 (unless (= i (1- slen))
1775 (error "Source ~S inconsistent with from translation ~
1776 ~S~%." source from)))))
1777 (t
1778 (setf ires (append ires (list (intermediate-rep s-el f-el)))))))
1779 ;; Remember to add leftover elements of from.
1780 (if (< slen flen)
1781 (setf ires (append ires (last from (- flen slen)))))
1782 (do* ((i 0 (1+ i))
1783 (j 0 (1+ j))
1784 (k 0)
1785 (irlen (length ires))
1786 (ir-el (nth i ires) (nth i ires))
1787 (ir-next-el nil)
1788 (t-el (nth j to) (nth j to)))
1789 ((<= tlen i))
1790 ;; Remember to add leftover elements of to.
1791 (cond ((eq ir-el ':wild-inferiors)
1792 (setf ir-next-el (nth (+ 1 i) ires)) ; NIL if beyond end.
1793 (if (setf k (position ir-next-el from :start (1+ j)))
1794 ;; Found it, splice this portion into rres.
1795 (setf rres
1796 (append rres
1797 (copy-sublist from :start j :end (1- k)))
1798 j (1- k))
1799 (progn
1800 ;; Either did not find next source element in from,
1801 ;; or was nil.
1802 (setf rres
1803 (append rres
1804 (copy-sublist from :start j :end tlen)))
1805 (unless (= i (1- irlen))
1806 (error "Intermediate path ~S inconsistent with to~
1807 translation ~S~%." ires to)))))
1808 (t (if (setf dummy (intermediate-rep ir-el t-el))
1809 (setf rres (append rres (list dummy)))))))
1810 (if (< flen tlen)
1811 (setf rres (append rres (last to (- tlen flen)))))
1812 rres))
1813
1814 (deftype physical-pathname ()
1815 '(not (or (satisfies wild-pathname-p)
1816 (satisfies logical-pathname-p))))
1817
1818 (defun translate-logical-pathname (pathname &key)
1819 "Translates pathname to a physical pathname, which is returned."
1820 (declare (type logical-pathname pathname))
1821 (with-pathname (source pathname)
1822 (etypecase source
1823 (physical-pathname source)
1824 (logical-pathname
1825 (let ((source-host (%pathname-host source))
1826 (result-path nil))
1827 (unless (gethash
1828 (funcall (logical-host-unparse-host source-host) source)
1829 *logical-pathnames*)
1830 (error "The logical host ~S is not defined.~%"
1831 (logical-host-name source-host)))
1832 (dolist (src-transl (logical-host-canon-transls source-host)
1833 (error "~S has no matching translation for ~
1834 logical host ~S.~%"
1835 pathname (logical-host-name source-host)))
1836 (when (pathname-match-p source (first src-transl))
1837 (macrolet ((frob (field)
1838 `(let* ((from (first src-transl))
1839 (to (second src-transl))
1840 (result (translate-logical-component
1841 (,field source)
1842 (,field from)
1843 (,field to))))
1844 result)))
1845 (setf result-path
1846 (%make-pathname (frob %pathname-host)
1847 ':unspecific
1848 (let* ((from (first src-transl))
1849 (to (second src-transl))
1850 (result
1851 (translate-logical-directory
1852 (%pathname-directory source)
1853 (%pathname-directory from)
1854 (%pathname-directory to))))
1855 (if (eq result ':error)
1856 (error "~S doesn't match ~S"
1857 source from)
1858 result))
1859 (frob %pathname-name)
1860 (frob %pathname-type)
1861 (frob %pathname-version))))
1862 (etypecase result-path
1863 (logical-pathname
1864 (translate-logical-pathname result-path))
1865 (physical-pathname
1866 (return-from translate-logical-pathname result-path))))))))))
1867
1868
1869
1870

  ViewVC Help
Powered by ViewVC 1.1.5