;; -*- 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 advertised functions are defined at the end of this file.

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

(export '(
	  ;;;;;;CommonLISP:
	  ;;;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"
	  ;;;Also:
	  "DEFINE-$_HOST"))

;;;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)))
)

(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))))


;;;Published variables:

;;;@@@Uses string values for nicknames!!!
(defvar *$_pathname-host-table* (make-hash-table :test 'equal :size 50.)
  "Table 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))
  host-type
  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>"
	  ($_pathname_host 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

(defvar *non-alpha-host-name-characters* '(#\- #\_ #\$))

(defun check-or-fix-host-spec (host)
  (check-type host (or $_host string (and symbol (not (member t nil)))))
  (if (typep host '$_host) host
    (let ((fix-host
	    (remove-if-not #'(lambda (char)
			       (or (alpha-char-p char)
				   (member char *non-alpha-host-name-characters*)))
			   (substitute #\- #\space
				       (setq host (string-upcase host))))))
      (if (string-equal fix-host host)
	  host
	(prog1 fix-host
	       (cerror "Use host name ~S instead of ~S"
		       "Illegal (non-alpha) characters in host name ~*~S"
		       fix-host host))))))

(defun sample-$_pathname (host)
  (setq host (check-or-fix-host-spec host))
  (or ($_host-sample-pathname host)
      (internal-make-$_pathname host)))

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

(defun pathname-$_host (host &optional no-error-p)
  (do () ()
    (setq host (check-or-fix-host-spec host))
    (if (typep host '$_host) (return host))
    (setq host (string-upcase host))
    (let ((lookup-host (find-host-in-table host)))
      (cond
	(lookup-host)
	((null no-error-p) nil)
	(t (error "~A is not a known pathname host"))))))

(defun parse-$_host (host &optional no-error-p lookup-host-fcn)
  "Return a host object for name HOST, taken from the HOST-ALIST.
This is the right function to use for finding file/network hosts,
  but is not right for parsing random pathnames (use GET-PATHNAME-HOST).
HOST can also be a host object already; then it's simply returned.
NO-ERROR-P says just return NIL if there is no such host known.
If LOOKUP-HOST-FCN is non-NIL, it gets called
  to give it a chance to create a host and add it to the host table."
  (let ((hostname host)
	(host (pathname-$_host host nil)))
    (cond
      ((and (null host) no-error-p)
       (format t "~&~:[Outa hosts~;Lookup hosts~]" lookup-host-fcn)
       (check-type lookup-host-fcn (or null (satisfies functionp)))
       (and lookup-host-fcn
	    (funcall lookup-host-fcn hostname)))
       ((null host)
	(error "~A is not a known pathname host" hostname))
       ((not (typep host '$_host))
	(error "Invalid object ~S returned from PATHNAME-$_HOST" host))
       ((not (typep host '$_network-host))
	(error "Pathname host ~A is not a file/network host" ($_host-name host)))
       ((null ($_network-host-networks host))
	(error "File/network host ~A is not on any networks" ($_host-name host)))
       (t host))))

;  (do () ()
;    (setq host (check-or-fix-host-spec host))
;    (cond
;      ((not (typep host '$_host)))
;      ((not (typep host '$_network-host))
;       (error "Pathname host ~A is not a file/network host" ($_host-name host)))
;      ((null ($_network-host-networks))
;       (error "File/network host ~A is not on any networks" ($_host-name host)))
;      (t (return host)))
;    (setq host (string-upcase host))
;    (do ((lookup-host (find-host-in-table host))
;	 (done nil))
;	((print done)
;	  (or no-error-p (setq host (check-type host $_host "a known host"))))
;      (cond
;	(lookup-host (setq host lookup-host done t))
;	((null no-error-p) (print (setq done t)))
;	(lookup-host-fcn
;	 (setq lookup-host (funcall lookup-host-fcn)))
;	(t (return-from parse-$_host nil))))))

;;;Stupid version for now, permits duplicates (by nickname)...

(defun put-host-in-table (host)
 (declare (values host host-name))
 (check-type host $_host)
 (let ((hostname ($_host-name host)))
   (multiple-value-bind (found-host found-name)
       (find-host-in-table hostname)
     (cond
       ((and found-host found-name)
	(cerror "Define host ~A after removing ~A"
		"The definition for host ~A conflicts with host ~A"
		hostname
		found-name))
       ;;Not checking valid redefinitions yet...
       (found-host
	(format t "~&Defining ~A, found ~S" hostname found-host)
	;;Primary name may have changed
	(setq found-name ($_host-name found-host)))
       (t (format t "~&Defining new host ~A" hostname)))
     ;;;Remove previous entry for name found under
     (when found-name
       ;;;Remove previous entry as host 
       (remhash found-name *$_pathname-host-table*)
       ;;;Remove any references from nickname
       (maphash #'(lambda (nickname realname)
		    (and (stringp nickname)
			 (stringp realname)
			 (string-equal found-name nickname)
			 (remhash nickname *$_pathname-host-table*)))
		 *$_pathname-host-table*))
     ;;;Insert new host def
     (setf (gethash hostname *$_pathname-host-table*) host)
     ;;;Install nickname pointers
     (dolist (name ($_host-nicknames host))
       (setf (gethash name *$_pathname-host-table*) hostname)))))

(defun find-host-in-table (hostname &optional nickname-ok)
  (declare (values host host-name))
  (let ((entry (gethash hostname *$_pathname-host-table*)))
    (cond
      ((typep entry '$_host) entry)
      ((null nickname-ok) nil)
      ((stringp entry)
       ;;Once-only recursive search for primary name entry from nickname:
       (values (find-host-in-table entry nil) entry)))))

;;;Exhaustively search table? Will I need this?
(defun search-host-table (hostname)
  (maphash #'(lambda (found-name found-host)
	       (if (member hostname ($_host-nicknames found-host) :test 'string-equal)
		   (return-from search-host-table (values found-host found-name))))
	   *$_pathname-host-table*))

(defun define-$_host (name &key nicknames verbose-mode
		      host-type software-type hardware-type networks)
  (flet ((notify-maybe
	   (format-string query-string &rest format-args)
	   (ecase verbose-mode
	     (nil)
	     (:warn-only
	      (t
		(y-or-n-p
		  (concatenate 'string
			       (apply 'format nil format-string format-args)
			       '(#\return)
			       (apply 'format nil query-string format-args))))))))
    ;;;
    (setq name (check-or-fix-host-spec name))
    (fix-type nicknames (list))
    ;;;Types
    (fix-type host-type (string symbol))
    (fix-type software-type (string symbol))
    (fix-type hardware-type (string symbol))
    (put-host-in-table
      ;;;@@@Major lossage here.  Can't extend host types this way!
      (make-$_network-_host :name name :nicknames nicknames
			    :host-type host-type
			    :software-type (or software-type host-type)
			    :hardware-type (or hardware-type host-type)
			    :networks networks))))

;;;Pathname 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 (namestring &optional host defaults
				  &aux parsed)
  (declare (values pathname end))
  (setf ($_pathname_parsed pathname)
	(setq parsed (let ((parser ($_host-parser host)))
		       (if parser (funcall parser namestring t)))))
  (values pathname parsed))
      
(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 parse-$_namestring (object &optional host defaults
			   &key start end junk-allowed)
  "Parse OBJECT into a pathname.
OBJECT is usually a string to be parsed into a pathname, or a symbol
  \(in which case its print name is used).
OBJECT can also be a pathname or stream, in which case no parsing is needed, 
  and the equal or corresponding pathname, respectively, is returned."
  (etypecase object
    ($_pathname (check-$_pathname object))
    (stream (funcall object :pathname))
    ((or symbol string)
     (internal-parse-$_namestring object host defaults start end junk-allowed))

(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) (internal-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* (define-$_host :name "LOCAL"))

;;;Make local host the default host:

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