Commit 9b578e1d authored by phg's avatar phg
Browse files

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".
parent 79ce97bb
......@@ -6,7 +6,7 @@
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/pathname.lisp,v 1.12 1992/08/19 17:45:33 phg Exp $")
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/pathname.lisp,v 1.13 1992/09/03 12:52:51 phg Exp $")
;;;
;;; **********************************************************************
;;;
......@@ -35,10 +35,11 @@
(in-package "LISP")
;;;; Structures and types.
;;; Pathname structure holds the essential properties of the parsed path.
(defstruct (pathname
(:conc-name %pathname-)
(:print-function %print-pathname)
......@@ -46,15 +47,24 @@
%make-pathname (host device directory name type version))
(:predicate pathnamep)
(:make-load-form-fun :just-dump-it-normally))
"Pathname is the structure of the file pathname. It consists of a
host, a device, a directory, a name, and a type."
;; Slot holds the host, at present either a UNIX or logical host.
(host nil :type (or host null))
;; Device is the name of a logical or physical device holding files.
(device nil :type (member nil :unspecific))
;; A list of strings that are the component subdirectory components.
(directory nil :type list)
;; The filename.
(name nil :type (or simple-string pattern null))
;; The type extension of the file.
(type nil :type (or simple-string pattern null (member :unspecific)))
;; The version number of the file, a positive integer, but not supported
;; on standard UNIX filesystems.
(version nil :type (or integer null (member :newest :wild))))
;;; %PRINT-PATHNAME -- Internal
;;;
;;; The printed representation of the pathname structure.
;;;
(defun %print-pathname (pathname stream depth)
(declare (ignore depth))
(let ((namestring (handler-case (namestring pathname)
......@@ -87,6 +97,12 @@
(%pathname-type pathname)
(%pathname-version pathname))))))
;;;; HOST structure
;;; The host structure holds the functions that both parse the pathname
;;; information into sturcture slot entries, and after translation the inverse
;;; (unparse) functions.
;;;
(defstruct (host
(:print-function %print-host))
(parse (required-argument) :type function)
......@@ -97,6 +113,8 @@
(unparse-enough (required-argument) :type function)
(customary-case (required-argument) :type (member :upper :lower)))
;;; %PRINT-HOST -- Internal
;;;
(defun %print-host (host stream depth)
(declare (ignore depth))
(print-unreadable-object (host stream :type t :identity t)))
......@@ -104,12 +122,17 @@
;;;; Patterns
;;; Patterns are a list of entries and wildcards used for pattern matches
;;; of translations.
(defstruct (pattern
(:print-function %print-pattern)
(:make-load-form-fun :just-dump-it-normally)
(:constructor make-pattern (pieces)))
(pieces nil :type list))
;;; %PRINT-PATTERN -- Internal
;;;
(defun %print-pattern (pattern stream depth)
(declare (ignore depth))
(print-unreadable-object (pattern stream :type t)
......@@ -118,6 +141,8 @@
(pprint-fill stream (pattern-pieces pattern) nil))
(prin1 (pattern-pieces pattern) stream))))
;;; PATTERN= -- Internal
;;;
(defun pattern= (pattern1 pattern2)
(declare (type pattern pattern1 pattern2))
(let ((pieces1 (pattern-pieces pattern1))
......@@ -137,10 +162,125 @@
pieces1
pieces2))))
;;; PATTERN-MATCHES -- Internal
;;;
(defun pattern-matches (pattern string)
(declare (type pattern pattern)
(type simple-string string))
(let ((len (length string)))
(labels ((maybe-prepend (subs cur-sub chars)
(if cur-sub
(let* ((len (length chars))
(new (make-string len))
(index len))
(dolist (char chars)
(setf (schar new (decf index)) char))
(cons new subs))
subs))
(matches (pieces start subs cur-sub chars)
(if (null pieces)
(if (= start len)
(values t (maybe-prepend subs cur-sub chars))
(values nil nil))
(let ((piece (car pieces)))
(etypecase piece
(simple-string
(let ((end (+ start (length piece))))
(and (<= end len)
(string= piece string
:start2 start :end2 end)
(matches (cdr pieces) end
(maybe-prepend subs cur-sub chars)
nil nil))))
(list
(ecase (car piece)
(:character-set
(and (< start len)
(let ((char (schar string start)))
(if (find char (cdr piece) :test #'char=)
(matches (cdr pieces) (1+ start) subs t
(cons char chars))))))))
((member :single-char-wild)
(and (< start len)
(matches (cdr pieces) (1+ start) subs t
(cons (schar string start) chars))))
((member :multi-char-wild)
(multiple-value-bind
(won new-subs)
(matches (cdr pieces) start subs t chars)
(if won
(values t new-subs)
(and (< start len)
(matches pieces (1+ start) subs t
(cons (schar string start)
chars)))))))))))
(multiple-value-bind
(won subs)
(matches (pattern-pieces pattern) 0 nil nil nil)
(values won (reverse subs))))))
;;; COMPONENTS-MATCH -- Internal
;;;
;;; Wilds in to are matched against from where both are either lists
;;; containing :wild and :wild-inferiors, patterns or strings.
;;; FROM = :WILD-INFERIORS or :WILD handled separately for directory
;;; component. Not communative.
;;;
(defun components-match (from to)
(or (eq from to)
(typecase from
(simple-base-string
(typecase to
(pattern
(values (pattern-matches to from)))
(simple-base-string
(string-equal from to))))
(pattern
(and (pattern-p to) (pattern= from to)))
((member :wild) ; :WILD component matches any string, or pattern or NIL.
(or (stringp to)
(logical-host-p to)
(pattern-p to)
(member to '(nil :unspecific :wild :wild-inferiors))))
(cons ; Watch for wildcards.
(and (consp from)
(let ((from1 (first from))
(from2 nil)
(to1 (first to)))
(typecase from1
((member :wild)
(or (stringp to1)
(pattern-p to1)
(not to1)
(eq to1 :unspecific)))
((member :wild-inferiors)
(setf from2 (second from))
(cond ((not from2)
;; Nothing left of from, hence anything else in to
;; matches :wild-inferiors.
t)
((components-match
(rest (rest from))
(rest (member from2 to :test #'equal))))))
(keyword ; :unspecific, :up, :back
(and (keywordp to1)
(eq from1 to1)
(components-match (rest from) (rest to))))
(string
(and (stringp to1)
(string-equal from1 to1)
(components-match (rest from) (rest to))))))))
((member :back :up :unspecific nil)
(and (pattern-p from)
(equal (pattern-pieces from) '(:multi-char-wild)))))))
;;;; Utilities.
;;; COMPARE-COMPONENT -- Internal
;;;
;;; A predicate for comparing two pathname slot component sub-entries.
;;;
(defun compare-component (this that)
(or (eql this that)
(typecase this
......@@ -155,32 +295,15 @@
(compare-component (car this) (car that))
(compare-component (cdr this) (cdr that)))))))
;;;; Logical namestrings
#|
(defstruct (logical-host
(:include host
(:parse #'parse-logical-namestring)
...)
(:print-function %print-logical-host))
name
translations)
(deftype logical-pathname ()
'(satisfies logical-pathname-p))
(defun logical-pathname-p (thing)
"Return T if THING is a LOGICAL-PATHNAME, and NIL if not."
(and (pathnamep thing)
(logical-host-p (%pathname-host thing))))
|#
;;;; Pathname functions.
;;; Implementation determined defaults to pathname slots.
(defvar *default-pathname-defaults*)
;;; PATHNAME= -- Internal
;;;
(defun pathname= (pathname1 pathname2)
(and (eq (%pathname-host pathname1)
(%pathname-host pathname2))
......@@ -195,6 +318,10 @@
(compare-component (%pathname-version pathname1)
(%pathname-version pathname2))))
;;; WITH-PATHNAME -- Internal
;;; Converts the var, a pathname designator (a pathname, or string, or
;;; stream), into a pathname.
;;;
(defmacro with-pathname ((var expr) &body body)
`(let ((,var (let ((,var ,expr))
(etypecase ,var
......@@ -203,101 +330,19 @@
(stream (parse-namestring (file-name ,var)))))))
,@body))
(defun %print-namestring-parse-error (condition stream)
(format stream "Parse error in namestring: ~?~% ~A~% ~V@T^"
(namestring-parse-error-complaint condition)
(namestring-parse-error-arguments condition)
(namestring-parse-error-namestring condition)
(namestring-parse-error-offset condition)))
(define-condition namestring-parse-error (error)
((complaint :init-form (required-argument))
(arguments :init-form nil)
(namestring :init-form (required-argument))
(offset :init-form (required-argument)))
(:report %print-namestring-parse-error))
(defun %parse-namestring (namestr start end host junk-allowed)
(declare (type string namestr)
(type index start end)
(type host host)
(values (or null pathname) index))
(cond (junk-allowed
(handler-case (%parse-namestring namestr start end host nil)
(namestring-parse-error (condition)
(values nil (namestring-parse-error-offset condition)))))
((simple-string-p namestr)
(multiple-value-bind
(new-host device directory file type version)
(funcall (host-parse host) namestr start end)
(values (%make-pathname (or new-host host)
device
directory
file
type
version)
end)))
(t
(%parse-namestring (coerce namestr 'simple-string)
start end host nil))))
(defun parse-namestring (thing
&optional host (defaults *default-pathname-defaults*)
&key (start 0) end junk-allowed)
(declare (type (or simple-base-string stream pathname) thing)
(type (or null host) host)
(type pathnamelike defaults)
(type index start)
(type (or index null) end)
(type (or null (not null)) junk-allowed)
(values (or null pathname) index))
(cond ((stringp thing)
(let* ((end1 (or end (length thing)))
(things-host nil)
(hosts-name (when host
(funcall (host-parse host) thing start end1))))
(setf things-host
(maybe-extract-logical-host thing start end1))
(when (and host things-host) ; A logical host and host are defined.
(unless (string= things-host hosts-name)
(error "Hosts do not match: ~S in ~S and ~S."
things-host thing host)))
(if things-host
(unless (gethash (string-downcase things-host) *search-lists*)
;; Not a search-list name, make it a logical-host name.
(setf host (intern-logical-host things-host))))
(%parse-namestring thing start end1
(or host
(with-pathname (defaults defaults)
(%pathname-host defaults)))
junk-allowed)))
((pathnamep thing)
(when host
(unless (eq host (%pathname-host thing))
(error "Hosts do not match: ~S and ~S."
host
(%pathname-host thing))))
(values thing start))
((streamp thing)
(let ((host-name (funcall (host-unparse-host host) host))
(stream-type (type-of thing))
(stream-host-name (host-namestring thing)))
(unless (or (eq stream-type 'fd-stream)
;;********Change fd-stream to file-stream in sources too.
(eq stream-type 'synonym-stream))
(error "Stream ~S was created with other than OPEN, WITH-OPEN-FILE~
or MAKE-SYNONYM-FILE." thing))
(unless (string-equal stream-host-name host-name)
(error "Hosts do not match: ~S and ~S."
host
host-name)))
(values thing start))))
;;; PATHNAME -- Interface
;;;
(defun pathname (thing)
"Convert thing (a pathname, string or stream) into a pathname."
(declare (type pathnamelike thing))
(with-pathname (pathname thing)
pathname))
;;; MAYBE-DIDDLE-CASE -- Internal
;;;
;;; Change the case of thing if diddle-p T.
;;;
(defun maybe-diddle-case (thing diddle-p)
(declare (type (or list pattern simple-base-string (member :unspecific))
thing)
......@@ -369,6 +414,8 @@
thing))))
thing))
;;; MERGE-DIRECTORIES -- Internal
;;;
(defun merge-directories (dir1 dir2 diddle-case)
(if (or (eq (car dir1) :absolute)
(null dir2))
......@@ -386,10 +433,14 @@
(add dir)))
(reverse results))))
;;; MERGE-PATHNAMES -- Interface
;;;
(defun merge-pathnames (pathname
&optional
(defaults *default-pathname-defaults*)
(default-version :newest))
"Construct a filled in pathname by completing the unspecified components
from the defaults."
(with-pathname (defaults defaults)
(let ((pathname (let ((*default-pathname-defaults* defaults))
(pathname pathname))))
......@@ -415,6 +466,8 @@
(or (%pathname-version pathname)
default-version))))))
;;; IMPORT-DIRECTORY -- Internal
;;;
(defun import-directory (directory diddle-case)
(etypecase directory
(null nil)
......@@ -450,6 +503,8 @@
,(maybe-diddle-case (coerce directory 'simple-string)
diddle-case)))))
;;; MAKE-PATHNAME -- Interface
;;;
(defun make-pathname (&key (host nil hostp)
(device nil devp)
(directory nil dirp)
......@@ -457,6 +512,8 @@
(type nil typep)
(version nil versionp)
defaults (case :local))
"Makes a new pathname from the component arguments. Note that host is a host-
structure."
(declare (type (or host null) host)
(type (member nil :unspecific) device)
(type (or list string pattern (member :wild)) directory)
......@@ -508,14 +565,20 @@
(defaults (%pathname-version defaults))
(t nil))))))
;;; PATHNAME-HOST -- Interface
;;;
(defun pathname-host (pathname &key (case :local))
"Accessor for the pathname's host."
(declare (type pathnamelike pathname)
(type (member :local :common) case)
(ignore case))
(with-pathname (pathname pathname)
(%pathname-host pathname)))
;;; PATHNAME-DEVICE -- Interface
;;;
(defun pathname-device (pathname &key (case :local))
"Accessor for pathname's device."
(declare (type pathnamelike pathname)
(type (member :local :common) case))
(with-pathname (pathname pathname)
......@@ -525,7 +588,10 @@
(%pathname-host pathname))
:lower)))))
;;; PATHNAME-DIRECTORY -- Interface
;;;
(defun pathname-directory (pathname &key (case :local))
"Accessor for the pathname's directory list."
(declare (type pathnamelike pathname)
(type (member :local :common) case))
(with-pathname (pathname pathname)
......@@ -534,8 +600,10 @@
(eq (host-customary-case
(%pathname-host pathname))
:lower)))))
;;; PATHNAME-NAME -- Interface
;;;
(defun pathname-name (pathname &key (case :local))
"Accessor for the pathname's name."
(declare (type pathnamelike pathname)
(type (member :local :common) case))
(with-pathname (pathname pathname)
......@@ -545,7 +613,10 @@
(%pathname-host pathname))
:lower)))))
;;; PATHNAME-TYPE
;;;
(defun pathname-type (pathname &key (case :local))
"Accessor for the pathname's name."
(declare (type pathnamelike pathname)
(type (member :local :common) case))
(with-pathname (pathname pathname)
......@@ -554,12 +625,117 @@
(eq (host-customary-case
(%pathname-host pathname))
:lower)))))
;;; PATHNAME-VERSION
;;;
(defun pathname-version (pathname)
"Accessor for the pathname's version."
(declare (type pathnamelike pathname))
(with-pathname (pathname pathname)
(%pathname-version pathname)))
;;;; Namestrings
;;; %PRINT-NAMESTRING-PARSE-ERROR -- Internal
;;;
(defun %print-namestring-parse-error (condition stream)
(format stream "Parse error in namestring: ~?~% ~A~% ~V@T^"
(namestring-parse-error-complaint condition)
(namestring-parse-error-arguments condition)
(namestring-parse-error-namestring condition)
(namestring-parse-error-offset condition)))
(define-condition namestring-parse-error (error)
((complaint :init-form (required-argument))
(arguments :init-form nil)
(namestring :init-form (required-argument))
(offset :init-form (required-argument)))
(:report %print-namestring-parse-error))
;;; %PARSE-NAMESTRING -- Internal
;;;
(defun %parse-namestring (namestr start end host junk-allowed)
(declare (type string namestr)
(type index start end)
(type host host)
(values (or null pathname) index))
(cond (junk-allowed
(handler-case (%parse-namestring namestr start end host nil)
(namestring-parse-error (condition)
(values nil (namestring-parse-error-offset condition)))))
((simple-string-p namestr)
(multiple-value-bind
(new-host device directory file type version)
(funcall (host-parse host) namestr start end)
(values (%make-pathname (or new-host host)
device
directory
file
type
version)
end)))
(t
(%parse-namestring (coerce namestr 'simple-string)
start end host nil))))
;;; PARSE-NAMESTRING -- Interface
;;;
(defun parse-namestring (thing
&optional host (defaults *default-pathname-defaults*)
&key (start 0) end junk-allowed)
"Converts thing, a pathname designator, into a pathname structure, returns
the printed representation."
(declare (type (or simple-base-string stream pathname) thing)
(type (or null host) host)
(type pathnamelike defaults)
(type index start)
(type (or index null) end)
(type (or null (not null)) junk-allowed)
(values (or null pathname) index))
(cond ((stringp thing)
(let* ((end1 (or end (length thing)))
(things-host nil)
(hosts-name (when host
(funcall (host-parse host) thing start end1))))
(setf things-host
(maybe-extract-logical-host thing start end1))
(when (and host things-host) ; A logical host and host are defined.
(unless (string= things-host hosts-name)
(error "Hosts do not match: ~S in ~S and ~S."
things-host thing host)))
(if things-host
(unless (gethash (string-downcase things-host) *search-lists*)
;; Not a search-list name, make it a logical-host name.
(setf host (intern-logical-host things-host))))
(%parse-namestring thing start end1
(or host
(with-pathname (defaults defaults)
(%pathname-host defaults)))
junk-allowed)))
((pathnamep thing)
(when host
(unless (eq host (%pathname-host thing))
(error "Hosts do not match: ~S and ~S."
host
(%pathname-host thing))))
(values thing start))
((streamp thing)
(let ((host-name (funcall (host-unparse-host host) host))
(stream-type (type-of thing))
(stream-host-name (host-namestring thing)))
(unless (or (eq stream-type 'fd-stream)
;;********Change fd-stream to file-stream in sources too.
(eq stream-type 'synonym-stream))
(error "Stream ~S was created with other than OPEN, WITH-OPEN-FILE~
or MAKE-SYNONYM-FILE." thing))
(unless (string-equal stream-host-name host-name)
(error "Hosts do not match: ~S and ~S."
host
host-name)))
(values thing start))))
;;; NAMESTRING -- Interface
;;;
(defun namestring (pathname)
"Construct the full (name)string form of the pathname."
(declare (type pathnamelike pathname))
......@@ -574,7 +750,10 @@
"Cannot determine the namestring for pathnames with no ~
host:~% ~S" pathname))))))
;;; HOST-NAMESTRING -- Interface
;;;
(defun host-namestring (pathname)
"Returns a string representation of the name of the host in the pathname."
(declare (type pathnamelike pathname))
(with-pathname (pathname pathname)
(let ((host (%pathname-host pathname)))
......@@ -584,7 +763,10 @@
"Cannot determine the namestring for pathnames with no host:~% ~S"
pathname)))))
;;; DIRECTORY-NAMESTRING -- Interface
;;;
(defun directory-namestring (pathname)
"Returns a string representation of the directories used in the pathname."
(declare (type pathnamelike pathname))
(with-pathname (pathname pathname)
(let ((host (%pathname-host pathname)))
......@@ -594,7 +776,10 @@
"Cannot determine the namestring for pathnames with no host:~% ~S"
pathname)))))
;;; FILE-NAMESTRING -- Interface
;;;
(defun file-namestring (pathname)
"Returns a string representation of the name used in the pathname."
(declare (type pathnamelike pathname))
(with-pathname (pathname pathname)
(let ((host (%pathname-host pathname)))
......@@ -604,8 +789,12 @@
"Cannot determine the namestring for pathnames with no host:~% ~S"