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

Contents of /src/code/pathname.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5