;; -*- Mode:LISP; Readtable:CL; Base:10; Package:(CL-PATHNAMES :USE LISP) -*-

;;;CL-PATHNAMES.LISP
;;;
;;;A structure-based pathname implementation.  Includes hosts and a minimal
;;;interface for the network software.

;;;Although designed to be portable in CommonLISP, a separate set of Lambdoid
;;;(ZetaLISP compatibility) features will be provided, in
;;;ZL-PATHNAME-COMPATIBILITY.
;;;
;;;A major goal in this implementation is to avoid the need for cluttering up
;;;the code with additional interfaces and special handling, e.g. for specific
;;;host types.

;;;The following CommonLISP interfaces are defined at the end of this file:

(in-package "CL-PATHNAMES" :use '("LISP") :nicknames '("CL-PATH"))

(export '(
	  ;;;Component accessors:
	  "$_PATHNAME-HOST"
	  "$_PATHNAME-DEVICE"
	  "$_PATHNAME-DIRECTORY"
	  "$_PATHNAME-NAME"
	  "$_PATHNAME-TYPE"
	  "$_PATHNAME-VERSION"
	  ;;;Related functions:
	  "FILE-$_NAMESTRING"
	  "DIRECTORY-$_NAMESTRING"
	  "ENOUGH-$_NAMESTRING"
	  "HOST-$_NAMESTRING"
	  "MAKE-$_PATHNAME"
	  "MERGE-$_PATHNAMES"
	  "$_NAMESTRING"
	  "PARSE-$_NAMESTRING"
	  "$_PATHNAME"
	  "$_PATHNAMEP"
	  "$_TRUENAME"))

;;;For compiling within this file only:

(eval-when (compile)

(defvar *path-debug* t)
(defmacro path-debug (&rest args)
  (if *path-debug* ` (format *trace-output* ,@args)))
)


;;;Published variables:

(defvar *$_pathname-host-list* NIL
  "List containing all hosts that can serve in pathnames.")

;;;NB: ZetaLISP does pathname defaulting in an incompatible manner.
;;;I've tried to provide both ZL and CL compatibility in this
;;;implementation.  See *DEFAULT-$_PATHNAME-DEFAULTS-LIST*, below.

(defvar *default-$_pathname-defaults* nil
  "If non-NIL, this is a pathname that supplies default pathname information.
MAKE-$_PATHNAME and others use this to fill in omitted information.
If NIL, the host-specific defaults list *DEFAULT-$_PATHNAME-DEFAULTS-LIST*
  is then checked for an entry for the specified pathname host, or for the 
  default host *DEFAULT-$_PATHNAME_HOST*.")

(defvar *default-$_pathname-defaults-list* nil
  "If *DEFAULT-$_PATHNAME-DEFAULTS* is NIL, and this is non-NIL, it
  supplies host-specific default pathname information.
Functions such as MAKE-$_PATHNAME fill in omitted information from this
  list, using default information for the specified pathname host, or
  for the default pathname host *DEFAULT-$_PATHNAME_HOST*.")

(defvar *default-$_pathname-host* nil
  "If non-NIL, this the default host from which to obtain host-specific 
  default pathname information.
See *DEFAULT-$_PATHNAME-DEFAULTS-LIST*.")

(defvar *local-host* :unbound "The host corresponding to the local machine.")


;;;;;; Structure definitions

;;; BASIC-PATHNAME -- no-frills, for internal use only:

(defstruct ($_basic-pathname
	     (:print-function print-basic-pathname)
	     (:conc-name $_pathname_)
	     :named)
  ;;The accessors are <not> the same as the CommonLISP interfaces!
  ;;This defines, e.g., $_PATHNAME_HOST, not PATHNAME-HOST.
  ;;
  ;;Except for the host component, all slots are initialized to NIL.
  (host (error-no-host-supplied))
  device directory name type version)

;;;Normal, parseable pathname with namestring:

(defstruct ($_pathname
	     :named
	     (:print-function print-pathname)
	     (:include $_basic-pathname)
	     (:conc-name $_pathname_)
	     (:constructor internal-make-$_pathname
			   (&optional host device directory name type version namestring)))
  ;;The standard string representation is parsed from the $_BASIC-PATHNAME slots:
  namestring
  ;;Flag whether this pathname has been parsed
  parsed
  ;;A place to hang properties; use GETF to access values.
  property-list
  ;;A "truename" is the translated from this form of pathname to another one:
  truename)

;;;Hosts

(defstruct ($_host
	     :named
	     (:constructor make-$_host))
  name
  nicknames
  force-case
  namestring
  parsed
  ;;Functions for parsing full pathnames and components
  (parser 'parse-basic-pathname)
  ;;Functions for "printing" pathnames and components
  (pathname-printer 'default-pathname-printer)
  sample-pathname)

(defstruct ($_network-host :named (:include $_host))
  software-type
  hardware-type
  network-addresses
  networks)

;;;Pathname internal utilities

(defun error-no-host-supplied (&optional namestring)
  (error "Pathname ~@[~S ~]was not defined with a pathname host" namestring))

(defun print-basic-pathname (pathname &optional (stream *standard-output*) print-level)
  (declare (ignore print-level))
  (format stream "#<$_BASIC-PATHNAME ~S ~S ~S ~S ~S ~S>"
	  (safe-host-from-pathname pathname)
	  ($_pathname_device pathname)
	  ($_pathname_directory pathname)
	  ($_pathname_name pathname)
	  ($_pathname_type pathname)
	  ($_pathname_version pathname)))

(defmacro with-$_pathname-components ((var pathname) &body body)
  `(let ((,var ,pathname))
     (let ((host      ($_pathname_host ,var))
	   (device    ($_pathname_device ,var))
	   (directory ($_pathname_directory ,var))
	   (name      ($_pathname_name ,var))
	   (type      ($_pathname_type ,var))
	   (version   ($_pathname_version ,var)))
       ,@body)))

;;;Printing / name strings:

(defun default-pathname-printer (pathname &optional stream print-level)
  (declare (ignore print-level))
  (check-type pathname $_PATHNAME)
  (with-$_pathname-components (path pathname)
    (check-type host $_host)
    (flet ((print-it (s)
		     (format s "\"~A:~@[ ~A:~]~@[ (~{~A~^ ~})~]~{~@[ ~A~]~}~@[ ~S~]\""
			     ($_host-name host)
			     device directory
			     (list name type) version)))
      (if stream (print-it stream)
	(with-output-to-string (str)
	  (print-it str))))))

(defun print-pathname (pathname &optional (stream *standard-output*) print-level)
  (declare (ignore print-level))
  (let ((*print-escape* nil))
    (format stream "#<~A ~A>"
	    (type-of pathname)
	    (funcall (or ($_host-pathname-printer ($_pathname_host pathname))
			 'default-pathname-printer)
		     pathname nil))))

(defun print-host (host &optional (stream *standard-output*) print-level)
  (declare (ignore print-level))
  (format stream "#(HOST ~A)"
	  (or ($_host-name host) "<unnamed>")))

;;;Host internal utilities

(defun sample-$_pathname (host)
  (check-type host $_host)
  (or ($_host-sample-pathname host)
      (internal-make-$_pathname host)))

(defun host-type (host)
  (type-of host))


;;;Parsing / validation:

(defun parse-basic-pathname (namestring &optional host)
  (check-type namestring string)
  (setq namestring (string-trim '(#\space #\tab #\return) namestring))
  (let ((start 0) end tem)
    (when (and (setq tem (search "#\<" namestring)) (zerop tem))
      (setq start 2)
      (setq end
	    (do ((i (1- (length namestring)) (1- i)))
		((or (<= i 2) (char-equal #\> (char namestring i)))
		 i))))
    (flet ((read-one-part ()
	    (with-input-from-string (in namestring :start start :end end :index start)
	      (read in))))
      (path-debug "~&Parsing a ~S pathname" (read-one-part))
      (make-$_pathname
	:host      (let ((inhost (read-one-part)))
		     (or host inhost))
	:device    (read-one-part)
	:directory (read-one-part)
	:name      (read-one-part)
	:type      (read-one-part)
	:version   (read-one-part)))))

(defun internal-parse-$_pathname (pathname &optional (host ($_pathname_host pathname))
				  &aux parsed)
  (setf ($_pathname_parsed pathname)
	(setq parsed (let ((parser ($_host-parser host)))
		       (if parser (funcall parser ($_pathname_namestring pathname) t)))))
  (values pathname parsed))

(defmacro fix-type (var types &optional error-p)
  `(progn (check-type ,var ,(if error-p `(or ,@types) `(or ,@types null)))
	  (or ,var
	      ,(null error-p)
	      (error "~S is not initialized in pathname" ',var))))
      
(defun check-$_pathname (pathname)
  "Set PARSED flag if all is well."
  (with-$_pathname-components (path pathname)
    (fix-type host      ($_host) :must-be-supplied)
    (fix-type device    (string))
    (fix-type directory (list))
    (fix-type name      (string))
    (fix-type type      (string))
    (fix-type version   (number keyword))
    (setf ($_pathname_parsed path) t)
    path))

;;;Pathname defaulting:

;;;+++This is a mess:
(defun default-host ()
  (if *default-$_pathname-defaults*
      ($_pathname_host *default-$_pathname-defaults*)
    *default-$_pathname-host*))

(defun set-default-host (host)
  (setq *default-$_pathname-host* host))

(defsetf default-host set-default-host)

(defun default-pathname (&optional (host *default-$_pathname-host*) (use-per-host-defaults-p t))
  (or *default-$_pathname-defaults*
      (and use-per-host-defaults-p
	   (setq *default-$_pathname-defaults* 
		 (or (cdr (assoc host *default-$_pathname-defaults-list*))
		     (cdr (assoc NIL *default-$_pathname-defaults-list*)))))))

(defun set-default-pathname (pathname &optional (host *default-$_pathname-host*))
  (if (assoc host *default-$_pathname-defaults*)
      (setf (first (assoc host *default-$_pathname-defaults*)) host)
    (push (cons host (sample-$_pathname host)) *default-$_pathname-defaults*))
  (when host (set-default-pathname pathname NIL))
  (setq *default-$_pathname-defaults* pathname))

(defun default-sample-pathname ()
  (let ((host (default-host)))
    (and host (sample-$_pathname host))))

;;;;;;Published (CommonLISP) interfaces

(defun merge-$_pathnames (pathname &optional
			  (defaults *DEFAULT-$_PATHNAME-DEFAULTS*)
			  (default-version :newest))
  "This is the function that most programs should call on supplied file names.
Unspecified (NIL) components of PATHNAME are filled in from DEFAULTS.
Returns a pathname."
    (if (null (or pathname defaults))
	(error "Both PATHNAME and DEFAULTS are NIL")
      (let ((pathname (and pathname ($_pathname pathname)))
	    (defaults (and defaults ($_pathname defaults))))
	(if (null (and pathname defaults))
	    (or pathname defaults)
	  ;;;Merge components
	  (check-$_pathname
	    (let (name type)
	      (internal-make-$_pathname
		(or ($_pathname_host pathname) ($_pathname_host defaults))
		(or ($_pathname_device pathname) ($_pathname_device defaults))
		(or ($_pathname_directory pathname) ($_pathname_directory defaults))
		;;;+++This is just for debugging, so far.
		;;;Version depends on name/type:
		(setq name (or ($_pathname_name pathname) ($_pathname_name defaults)))
		(setq type (or ($_pathname_type pathname) ($_pathname_type defaults)))
		(if (or name type)
		    (or ($_pathname_version pathname) ($_pathname_version defaults)
			default-version)))))))))

(defun make-$_pathname (&key host device directory name type version
			(defaults (default-sample-pathname)))	;;;+++Turn off per-host defaulting!!!
  "Create a pathname, specifying components as keyword arguments.
Missing components are merged in from DEFAULTS, which defaults to a sample
  (mostly NULL) pathname for the host specified by *DEFAULT-$_PATHNAME-DEFAULTS*."
  (check-$_pathname
    (merge-$_pathnames
      (internal-make-$_pathname
	(or host (and defaults ($_pathname-host defaults)))
	device directory name type version)
      defaults version)))

;;;@@@Unfortunately, the code below requires that streams (and Flavors!) be
;;;defined previously.  Suggested cure: redo with CLOS.

(DEFUN $_PATHNAME (OBJECT)
  "Convert OBJECT to a $_pathname.
If it's a pathname, it is unchanged.
If it's a stream, its :PATHNAME operation is invoked.
If it's a string or symbol, it is parsed into a pathname."
  (etypecase object
    ($_pathname (check-$_pathname object))
    (stream (funcall object :pathname))
    ((or symbol string) (parse-$_namestring object))))

(defun $_PATHNAMEP (OBJECT)
  "T if OBJECT is a pathname."
  (typep object '$_pathname))

(DEFUN $_TRUENAME (OBJECT)
  "Returns the truename of the file OBJECT, as a pathname, refers to."
  (typecase object
    (stream (funcall object :$_truename))
    (t  ($_pathname_truename ($_pathname object)))))

(DEFUN $_NAMESTRING (OBJECT)
  "Convert OBJECT to a pathname and return its namestring."
  ($_pathname_namestring ($_pathname object))) 

(DEFUN $_PATHNAME-HOST (pathname)
  "Returns the host component of PATHNAME."
  ($_pathname_host ($_pathname pathname)))

(DEFUN $_PATHNAME-DEVICE (pathname)
  "Returns the device component of PATHNAME."
  ($_pathname_device ($_pathname pathname)))

(DEFUN $_PATHNAME-DIRECTORY (pathname)
  "Returns the directory component of PATHNAME."
  ($_pathname_directory ($_pathname pathname)))

(DEFUN $_PATHNAME-NAME (pathname)
  "Returns the name component of PATHNAME."
  ($_pathname_name ($_pathname pathname)))

(DEFUN $_PATHNAME-TYPE (pathname)
  "Returns the type component of PATHNAME."
  ($_pathname_type ($_pathname pathname)))

(DEFUN $_PATHNAME-VERSION (pathname)
  "Returns the version component of PATHNAME."
  ($_pathname_version ($_pathname pathname)))

;;;Load-time initializations:

;;;Define local host:

(setq *local-host* (make-$_host :name "LOCAL"))

;;;Make local host the default host:

(set-default-host *local-host*)