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

;;;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:
;;;
;;;Component accessors:
;;;
;;; $_PATHNAME-DEVICE
;;; $_PATHNAME-DIRECTORY
;;; $_PATHNAME-HOST
;;; $_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
;;;

;;;Utility functions

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


;;;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, supplies default pathname information.
MAKE-$_PATHNAME and others fill in omitted information from this pathname.
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 this is non-NIL, and if *default-$_pathname-defaults* is NIL, this list
  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

;;; Pathnames

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

(defstruct ($_basic-pathname
	     (:print-function print-basic-pathname)
	     (:conc-name $_pathname_)
	     :named)
  ;;The accessors are <not> the same as the CommonLISP interfaces!
  ;;
  ;; $_pathname_host
  ;; $_pathname_device
  ;; $_pathname_directory
  ;; $_pathname_name
  ;; $_pathname_type
  ;; $_pathname_version
  ;;
  ;;The standard string representation is constructed from the remaining slots:
  namestring
  ;;Except for the host host component, all slots are initialized to NIL.
  ;;Code is responsible for checking. 
  (host (error-no-host-supplied namestring))
  device directory name type version)

(defun print-basic-pathname (cpath &optional (stream *standard-output*) print-level)
  (declare (ignore print-level))
  (format stream "#<$_PATHNAME ~S ~S ~S ~S ~S ~S>"
	  (block name ($_host-name
			(or ($_pathname_host cpath)
			    (return-from name '|<Error: no host for pathname>|))))
	  ($_pathname_device cpath)
	  ($_pathname_directory cpath)
	  ($_pathname_name cpath)
	  ($_pathname_type cpath)
	  ($_pathname_version cpath)))

(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)))
  ;;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)
  
(defun default-pathname-printer (pathname &optional stream print-level &aux host)
  (declare (ignore print-level))
  (setq host ($_pathname_host pathname))
  (check-type host $_host)
  (with-$_pathname-components (path pathname)
    (flet ((print-it (s)
		     (format s "~A:~@[ ~A:~]~@[ (~{~A~})~]~{~@[ ~A~]~}"
			     ($_host-name host)
			     (list device directory 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>"
	    'pathname
	    (default-pathname-printer pathname stream))))


;;;;;;Hosts
;;;

(defstruct ($_host :named)
  name
  nicknames
  force-case
  namestring
  parsed
  ;;Functions for parsing full pathnames and components
  (parser 'parse-basic-pathname)
  ;;Functions for "printing" pathnames and components
  (print-pathname-fcn #'default-pathname-printer)
;  (print-host-name-fcn #'default-host-name-printer)
;  (print-pathname-device-fcn #'default-pathname-component-printer)
;  (print-pathname-name-fcn #'default-pathname-component-printer)
;  (print-pathname-type-fcn #'default-pathname-component-printer)
;  (print-pathname-version-fcn #'default-pathname-component-printer)
;  (print-pathname-namestring-fcn #'default-pathname-component-printer)
  )

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

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

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

;(defvar $host-name-terminator-character #\:)
;(defvar $device-terminator-character #\:)
;(defvar $name-type-separator-character #\space)
;(defvar $type-version-separator-character #\space)

;(defun default-host-name-printer (host-name &optional stream pathname)
;  (declare (ignore pathname))
;  (flet ((printer (stream)
;		  (format stream "~A~C" host-name $host-name-terminator-character)))
;    (cond
;      ((eq stream nil)
;       (with-output-to-string (s)
;	 (printer s)))
;      ((eq stream t)
;       (printer *standard-output*))
;      (t
;       (printer stream)))))

;(defun default-device-name-printer (device-name &optional stream pathname)
;  (declare (ignore pathname))
;  (flet ((printer (stream)
;		  (format stream "~A~C" device-name $device-terminator-character)))
;    (cond
;      ((eq stream nil)
;       (with-output-to-string (s)
;	 (printer s)))
;      ((eq stream t)
;       (printer *standard-output*))
;      (t
;       (printer stream)))))

;(defun default-pathname-component-printer (component &optional stream pathname)
;  (declare (ignore pathname))
;  (flet ((printer (stream)
;		  (princ component stream)
;		  (write-char #\space stream)))
;    (cond
;      ((eq stream nil)
;       (with-output-to-string (s)
;	 (printer s)))
;      ((eq stream t)
;       (printer *standard-output*))
;      (t
;       (printer stream)))))


;  (flet ((printer (printer-fcn) (or printer-fcn #'default-pathname-component-printer)))
;    (let ((print-host-name-fcn           (printer (print-host-name-fcn host)))
;	  (print-pathname-device-fcn     (printer (print-pathname-device-fcn host)))
;	  (print-pathname-name-fcn       (printer (print-pathname-name-fcn host)))
;	  (print-pathname-type-fcn       (printer (print-pathname-type-fcn host)))
;	  (print-pathname-version-fcn    (printer (print-pathname-version-fcn host)))
;	  (print-pathname-namestring-fcn (printer (print-pathname-namestring-fcn host))))
;      (flet ((print-pathname-to-stream (s)
;	      (funcall print-host-name-fcn          ($_host-name host) s)
;	      (funcall print-pathname-device-fcn    ($_pathname_device pathname) s)
;	      (funcall print-pathname-directory-fcn ($_pathname_directory pathname) s)
;	      (funcall print-pathname-name-fcn      ($_pathname_name pathname) s)
;	      (write-char $name-type-separator-character stream)
;	      (funcall print-pathname-type-fcn      ($_pathname_type pathname) s)
;	      (write-char $type-version-separator-character stream)
;	      (funcall print-pathname-version-fcn   ($_pathname_version pathname) s)))
;	(if (null stream)
;	    (with-output-to-string (str)
;	      (print-pathname-to-stream str))
;	  (print-pathname-to-stream stream))))))
	      
;;;Parsing / validation:

(defun $_pathname_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)))))

(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 internal-parse-$_pathname (pathname &optional (host ($_pathname_host pathname)))
  (setf ($_pathname_parsed pathname)
	(let ((parser ($_pathname_parser host)))
	  (if parser (funcall parser pathname) t))))
      
(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))
    (internal-parse-pathname path)))

(defun sample-$_pathname (host)
  (make-$_pathname :host host))

;;;Pathname defaulting.  (Also see variables in beginning.)

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

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

(defsetf default-host set-default-host)

(defun default-pathname (&optional (host *default-$_pathname_host*) &aux defaults)
  (if host
      (setq defaults (cdr (assoc host *default-$_pathname-defaults*))))
  (or defaults
      (setq defaults (cdr (assoc NIL *default-$_pathname-defaults*)))))

;;;;;;Published (CommonLISP) interfaces
;;;

(defun make-$_pathname (&key host device directory name type version)
  "Create a pathname, specifying components as keyword arguments.
The host is defaulted from *DEFAULT-$_PATHNAME_HOST*, and the other
components are then defaulted from the appropriate entry in *DEFAULT-$_PATHNAME-DEFAULTS*."
  (check-$_pathname
    (internal-make-$_pathname host device directory name type version)))

;;;@@@Some of the functions below check their arguments, trying hard to
;;;find / check for a pathname.  Unfortunately, this requires that the
;;;other datatypes (particularly streams) be defined already.  (Too bad
;;;if your definition of streams requires pathnames.) 
;;;
;;;Suggested cure: redo these routines (if not all this code) with CLOS.

(DEFUN $_PATHNAME (OBJECT)
  "Convert OBJECT to a $_pathname.
If it's a pathname, it is unchanged.
If it's a functional object (e.g., a stream), the :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)
  "Convert OBJECT to a pathname, then return the truename of the file it 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))) 

;;;The component accessors don't convert their arguments to pathnames.
;;;Provide the Common Lisp functions to do so:

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