Commit 71baaaa9 authored by wlott's avatar wlott
Browse files

Initial revision

parent 0d43d552
;;; -*- Package: LISP -*-
;;; **********************************************************************
;;; This code was written as part of the CMU Common Lisp project at
;;; Carnegie Mellon University, and has been placed in the public domain.
;;; If you want to use this code or any part of CMU Common Lisp, please contact
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/pathname.lisp,v 1.1 1991/12/16 10:29:04 wlott Exp $")
;;;
;;; **********************************************************************
;;;
;;; Machine/filesystem independent pathname functions for CMU Common Lisp.
;;;
;;; Written by William Lott
;;; Earlier version written by Jim Large and Rob MacLachlan
;;;
;;; **********************************************************************
(in-package "LISP")
(export '(pathname pathnamep logical-pathname logical-pathname-p
parse-namestring merge-pathnames make-pathname
pathname-host pathname-device pathname-directory pathname-name
pathname-type pathname-version namestring file-namestring
directory-namestring host-namestring enough-namestring
wild-pathname-p pathname-match-p translate-pathname
translate-logical-pathname logical-pathname-translations
load-logical-pathname-translations *default-pathname-defaults*))
(in-package "EXTENSIONS")
(export '(search-list clear-search-list enumerate-search-list))
(in-package "LISP")
;;;; Structures and types.
(defstruct (pathname
(:conc-name %pathname-)
(:print-function %print-pathname)
(:constructor
%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."
(host nil :type (or host null))
(device nil :type (member nil :unspecific))
(directory nil :type list)
(name nil :type (or simple-string pattern null))
(type nil :type (or simple-string pattern null (member :unspecific)))
(version nil :type (or integer null (member :newest :wild))))
(defun %print-pathname (pathname stream depth)
(declare (ignore depth))
(let ((namestring (handler-case (namestring pathname)
(error nil))))
(cond (namestring
(format stream "#p~S" namestring))
(*print-readably*
(error "~S Cannot be printed readably." pathname))
(*print-pretty*
(pprint-logical-block (stream nil :prefix "#<" :suffix ">")
(funcall (formatter
"~2IUnprintable pathname: ~_Host=~S, ~_Device=~S, ~_~
Directory=~:/LISP:PPRINT-FILL/, ~_Name=~S, ~_~
Type=~S, ~_Version=~S")
stream
(%pathname-host pathname)
(%pathname-device pathname)
(%pathname-directory pathname)
(%pathname-name pathname)
(%pathname-type pathname)
(%pathname-version pathname))))
(t
(funcall (formatter "#<Unprintable pathname, Host=~S, Device=~S, ~
Directory=~S, File=~S, Name=~S, Version=~S>")
stream
(%pathname-host pathname)
(%pathname-device pathname)
(%pathname-directory pathname)
(%pathname-name pathname)
(%pathname-type pathname)
(%pathname-version pathname))))))
(defstruct (host
(:print-function %print-host))
(parse (required-argument) :type function)
(unparse (required-argument) :type function)
(unparse-host (required-argument) :type function)
(unparse-directory (required-argument) :type function)
(unparse-file (required-argument) :type function)
(unparse-enough (required-argument) :type function)
(customary-case (required-argument) :type (member :upper :lower)))
(defun %print-host (host stream depth)
(declare (ignore depth))
(print-unreadable-object (host stream :type t :identity t)))
;;;; Patterns
(defstruct (pattern
(:print-function %print-pattern)
(:make-load-form-fun :just-dump-it-normally)
(:constructor make-pattern (pieces)))
(pieces nil :type list))
(defun %print-pattern (pattern stream depth)
(declare (ignore depth))
(print-unreadable-object (pattern stream :type t)
(if *print-pretty*
(let ((*print-escape* t))
(pprint-fill stream (pattern-pieces pattern) nil))
(prin1 (pattern-pieces pattern) stream))))
(defun pattern= (pattern1 pattern2)
(declare (type pattern pattern1 pattern2))
(let ((pieces1 (pattern-pieces pattern1))
(pieces2 (pattern-pieces pattern2)))
(and (= (length pieces1) (length pieces2))
(every #'(lambda (piece1 piece2)
(typecase piece1
(simple-string
(and (simple-string-p piece2)
(string= piece1 piece2)))
(cons
(and (consp piece2)
(eq (car piece1) (car piece2))
(string= (cdr piece1) (cdr piece2))))
(t
(eq piece1 piece2))))
pieces1
pieces2))))
;;;; Utilities.
(defun compare-component (this that)
(or (eql this that)
(typecase this
(simple-string
(and (simple-string-p that)
(string= this that)))
(pattern
(and (pattern-p that)
(pattern= this that)))
(cons
(and (consp that)
(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.
(defvar *default-pathname-defaults*)
(defun pathname= (pathname1 pathname2)
(and (eq (%pathname-host pathname1)
(%pathname-host pathname2))
(compare-component (%pathname-device pathname1)
(%pathname-device pathname2))
(compare-component (%pathname-directory pathname1)
(%pathname-directory pathname2))
(compare-component (%pathname-name pathname1)
(%pathname-name pathname2))
(compare-component (%pathname-type pathname1)
(%pathname-type pathname2))
(compare-component (%pathname-version pathname1)
(%pathname-version pathname2))))
(defmacro with-pathname ((var expr) &body body)
`(let ((,var (let ((,var ,expr))
(etypecase ,var
(pathname ,var)
(string (parse-namestring ,var))
(stream (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 (required-argument))
(arguments nil)
(namestring (required-argument))
(offset (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 pathnamelike 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 pathname index))
(if (stringp thing)
(%parse-namestring thing start (or end (length thing))
(or host
(with-pathname (defaults defaults)
(%pathname-host defaults)))
junk-allowed)
(with-pathname (pathname thing)
(when host
(unless (eq host (%pathname-host pathname))
(error "Hosts do not match: ~S and ~S."
host
(%pathname-host pathname))))
(values pathname start))))
(defun pathname (thing)
(declare (type pathnamelike thing))
(with-pathname (pathname thing)
pathname))
(defun maybe-diddle-case (thing diddle-p)
(declare (type (or list pattern simple-base-string (member :unspecific))
thing)
(values (or list pattern simple-base-string (member :unspecific))))
(if diddle-p
(labels ((check-for (pred in)
(etypecase in
(pattern
(dolist (piece (pattern-pieces in))
(when (typecase piece
(simple-string
(check-for pred piece))
(cons
(case (car in)
(:character-set
(check-for pred (cdr in))))))
(return t))))
(list
(dolist (x in)
(when (check-for pred x)
(return t))))
(simple-base-string
(dotimes (i (length in))
(when (funcall pred (schar in i))
(return t))))
((member :unspecific)
nil)))
(diddle-with (fun thing)
(etypecase thing
(pattern
(make-pattern
(mapcar #'(lambda (piece)
(typecase piece
(simple-base-string
(funcall fun thing))
(cons
(case (car piece)
(:character-set
(cons :character-set
(funcall fun (cdr piece))))
(t
piece)))
(t
piece)))
(pattern-pieces thing))))
(list
(mapcar fun thing))
(simple-base-string
(funcall fun thing)))))
(let ((any-uppers (check-for #'upper-case-p thing))
(any-lowers (check-for #'lower-case-p thing)))
(cond ((and any-uppers any-lowers)
;; Mixed case, stays the same.
thing)
(any-uppers
;; All uppercase, becomes all lower case.
(diddle-with #'string-downcase thing))
(any-lowers
;; All lowercase, becomes all upper case.
(diddle-with #'string-upcase thing))
(t
;; No letters? I guess just leave it.
thing))))
thing))
(defun merge-directories (dir1 dir2 diddle-case)
(if (eq (car dir1) :absolute)
dir1
(let ((results nil))
(flet ((add (dir)
(if (and (eq dir :back)
results
(not (eq (car results) :back)))
(pop results)
(push dir results))))
(dolist (dir (maybe-diddle-case dir2 diddle-case))
(add dir))
(dolist (dir (cdr dir1))
(add dir)))
(reverse results))))
(defun merge-pathnames (pathname
&optional
(defaults *default-pathname-defaults*)
(default-version :newest))
(with-pathname (defaults defaults)
(with-pathname (pathname (let ((*default-pathname-defaults* defaults))
pathname))
(let* ((default-host (%pathname-host defaults))
(pathname-host (%pathname-host pathname))
(diddle-case
(and default-host pathname-host
(not (eq (host-customary-case default-host)
(host-customary-case pathname-host))))))
(%make-pathname (or pathname-host default-host)
(or (%pathname-device pathname)
(maybe-diddle-case (%pathname-device defaults)
diddle-case))
(merge-directories (%pathname-directory pathname)
(%pathname-directory defaults)
diddle-case)
(or (%pathname-name pathname)
(maybe-diddle-case (%pathname-name defaults)
diddle-case))
(or (%pathname-type pathname)
(maybe-diddle-case (%pathname-type defaults)
diddle-case))
(or (%pathname-version pathname)
default-version))))))
(defun import-directory (directory diddle-case)
(etypecase directory
(null nil)
(list
(collect ((results))
(ecase (pop directory)
(:absolute
(results :absolute)
(when (search-list-p (car directory))
(results (pop directory))))
(:relative
(results :relative)))
(dolist (piece directory)
(cond ((eq piece :wild)
(results (make-pattern (list :multi-char-wild))))
((eq piece :wild-inferiors)
(error ":WILD-INFERIORS not supported."))
((member piece '(:up :back))
(results piece))
((or (simple-string-p piece) (pattern-p piece))
(results (maybe-diddle-case piece diddle-case)))
((stringp piece)
(results (maybe-diddle-case (coerce piece 'simple-string)
diddle-case)))
(t
(error "~S is not allowed as a directory component." piece))))
(results)))
(simple-string
`(:absolute
,(maybe-diddle-case directory diddle-case)))
(string
`(:absolute
,(maybe-diddle-case (coerce directory 'simple-string)
diddle-case)))))
(defun make-pathname (&key host device directory name type version
defaults (case :local))
(declare (type (or host null) host)
(type (member nil :unspecific) device)
(type (or list string pattern (member :wild)) directory)
(type (or null string pattern (member :wild)) name)
(type (or null string pattern (member :wild)) type)
(type (or null integer (member :wild :newest)) version)
(type (or pathnamelike null) defaults)
(type (member :common :local) case))
(let* ((defaults (if defaults
(with-pathname (defaults defaults) defaults)))
(default-host (if defaults
(%pathname-host defaults)
(pathname-host *default-pathname-defaults*)))
(host (or host default-host))
(diddle-args (and (eq case :common)
(eq (host-customary-case host) :lower)))
(diddle-defaults
(not (eq (host-customary-case host)
(host-customary-case default-host)))))
(macrolet ((pick (var field)
`(cond ((eq ,var :wild)
(make-pattern (list :multi-char-wild)))
((or (simple-string-p ,var)
(pattern-p ,var))
(maybe-diddle-case ,var diddle-args))
((stringp ,var)
(maybe-diddle-case (coerce ,var 'simple-string)
diddle-args))
(,var
(maybe-diddle-case ,var diddle-args))
(defaults
(maybe-diddle-case (,field defaults)
diddle-defaults))
(t
nil))))
(%make-pathname
host
(or device (if defaults (%pathname-device defaults)))
(let ((dir (import-directory directory diddle-args)))
(if defaults
(merge-directories dir
(%pathname-directory defaults)
diddle-defaults)
dir))
(pick name %pathname-name)
(pick type %pathname-type)
(cond
(version version)
(defaults (%pathname-version defaults))
(t nil))))))
(defun pathname-host (pathname &key (case :local))
(declare (type pathnamelike pathname)
(type (member :local :common) case)
(ignore case))
(with-pathname (pathname pathname)
(%pathname-host pathname)))
(defun pathname-device (pathname &key (case :local))
(declare (type pathnamelike pathname)
(type (member :local :common) case))
(with-pathname (pathname pathname)
(maybe-diddle-case (%pathname-device pathname)
(and (eq case :common)
(eq (host-customary-case
(%pathname-host pathname))
:lower)))))
(defun pathname-directory (pathname &key (case :local))
(declare (type pathnamelike pathname)
(type (member :local :common) case))
(with-pathname (pathname pathname)
(maybe-diddle-case (%pathname-directory pathname)
(and (eq case :common)
(eq (host-customary-case
(%pathname-host pathname))
:lower)))))
(defun pathname-name (pathname &key (case :local))
(declare (type pathnamelike pathname)
(type (member :local :common) case))
(with-pathname (pathname pathname)
(maybe-diddle-case (%pathname-name pathname)
(and (eq case :common)
(eq (host-customary-case
(%pathname-host pathname))
:lower)))))
(defun pathname-type (pathname &key (case :local))
(declare (type pathnamelike pathname)
(type (member :local :common) case))
(with-pathname (pathname pathname)
(maybe-diddle-case (%pathname-type pathname)
(and (eq case :common)
(eq (host-customary-case
(%pathname-host pathname))
:lower)))))
(defun pathname-version (pathname)
(declare (type pathnamelike pathname))
(with-pathname (pathname pathname)
(%pathname-version pathname)))
(defun namestring (pathname)
(declare (type pathnamelike pathname))
(with-pathname (pathname pathname)
(let ((host (%pathname-host pathname)))
(if host
(funcall (host-unparse host) pathname)
(error
"Cannot determine the namestring for pathnames with no host:~% ~S"
pathname)))))
(defun host-namestring (pathname)
(declare (type pathnamelike pathname))
(with-pathname (pathname pathname)
(let ((host (%pathname-host pathname)))
(if host
(funcall (host-unparse-host host) pathname)
(error
"Cannot determine the namestring for pathnames with no host:~% ~S"
pathname)))))
(defun directory-namestring (pathname)
(declare (type pathnamelike pathname))
(with-pathname (pathname pathname)
(let ((host (%pathname-host pathname)))
(if host
(funcall (host-unparse-directory host) pathname)
(error
"Cannot determine the namestring for pathnames with no host:~% ~S"
pathname)))))
(defun file-namestring (pathname)
(declare (type pathnamelike pathname))
(with-pathname (pathname pathname)
(let ((host (%pathname-host pathname)))
(if host
(funcall (host-unparse-file host) pathname)
(error
"Cannot determine the namestring for pathnames with no host:~% ~S"
pathname)))))
(defun enough-namestring (pathname
&optional (defaults *default-pathname-defaults*))
(declare (type pathnamelike pathname))
(with-pathname (pathname pathname)
(let ((host (%pathname-host pathname)))
(if host
(with-pathname (defaults defaults)
(funcall (host-unparse-enough host) pathname defaults))
(error
"Cannot determine the namestring for pathnames with no host:~% ~S"
pathname)))))
;;;; Wild pathnames.
(defun wild-pathname-p (pathname &optional field-key)
(declare (type pathnamelike pathname)
(type (member nil :host :device :directory :name :type :version)
field-key))
(with-pathname (pathname pathname)
(ecase field-key
((nil)
(or (wild-pathname-p pathname :host)
(wild-pathname-p pathname :device)
(wild-pathname-p pathname :directory)
(wild-pathname-p pathname :name)
(wild-pathname-p pathname :type)
(wild-pathname-p pathname :version)))
(:host
(pattern-p (%pathname-host pathname)))
(:device
(pattern-p (%pathname-host pathname)))
(:directory
(some #'pattern-p (%pathname-directory pathname)))
(:name
(pattern-p (%pathname-name pathname)))
(:type
(pattern-p (%pathname-type pathname)))
(:version
(eq (%pathname-version pathname) :wild)))))
(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))