;;; -*- Mode:LISP; Package:(SIMPLE-PATHNAMES USE LISP NICKNAMES (SPATH)); 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.

;;; COMMONLISP INTERFACES:
;;;
;;; Structure accessors:
;;;
;;; S$PATHNAME-DEVICE
;;; S$PATHNAME-DIRECTORY
;;; S$PATHNAME-HOST
;;; S$PATHNAME-NAME
;;; S$PATHNAME-TYPE
;;; S$PATHNAME-VERSION
;;;
;;; Related forms:
;;;
;;; S$NAMESTRING
;;; FILE-S$NAMESTRING
;;; DIRECTORY-S$NAMESTRING
;;; HOST-S$NAMESTRING
;;; ENOUGH-S$NAMESTRING
;;;
;;; Utility functions
;;;
;;; MAKE-S$PATHNAME
;;; MERGE-S$PATHNAMES
;;; PARSE-S$NAMESTRING
;;; S$PATHNAME
;;; S$PATHNAMEP
;;; S$TRUENAME
;;; 

(defvar *s$debug t)
(defmacro s$debug (&rest args)
  `(and *s$debug (format *trace-output* ,@args)))

;;;@@@Redo this with CLOS:

(DEFUN S$PATHNAME (OBJECT)
  "Convert OBJECT to a s$pathname.
If it's a s$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 s$pathname."
  (ETYPECASE OBJECT
    (S$PATHNAME (check-s$pathname OBJECT))
    (STREAM (funcall OBJECT :PATHNAME))
    ((OR SYMBOL STRING) (parse-s$namestring object))))

(defun S$PATHNAMEP (OBJECT)
  "T if OBJECT is a s$pathname."
  (TYPEP OBJECT 'S$PATHNAME))

(DEFUN S$TRUENAME (OBJECT)
  "Convert OBJECT to a s$pathname, then return the s$truename of the file it refers to."
  (typecase object
    (stream (funcall OBJECT :S$TRUENAME))
    (t  (s$pathname-truename (s$pathname object)))))

(DEFUN S$NAMESTRING (OBJECT)
  "Convert OBJECT to a s$pathname and return its S$NAMESTRING."
  (s$pathname-namestring (s$pathname object))) 

(DEFVAR *S$PATHNAME-HOST-LIST* NIL
  "List containing all hosts that can serve in s$pathnames.")

;;; These are the actual base structures:

(defstruct (s$canonical-pathname
	     (:print-function s$print-canonical-pathname)
	     :named)
  (host (default-host))
  device directory name type version)

(defun s$print-canonical-pathname (cpath &optional (stream *standard-output*) print-level)
  (declare (ignore print-level))
  (format stream "#(S$PATHNAME ~S  ~S ~S ~S ~S ~S)"
	  (s$host-name (s$canonical-pathname-host cpath))
	  (s$canonical-pathname-device cpath)
	  (s$canonical-pathname-directory cpath)
	  (s$canonical-pathname-name cpath)
	  (s$canonical-pathname-type cpath)
	  (s$canonical-pathname-version cpath)))

(defstruct (s$pathname
	     :named
	     (:include s$canonical-pathname)
	     (:constructor internal-make-s$pathname (&optional host device directory name type version)))
;  ;;Each component of a pathname is a similarly named structure, e.g. s$host.
;  host
;  device
;  directory
;  name
;  type
;  version
  ;;A place to hang (closure) functions
  operations
  ;;A place to hang properties; use GETF to access values.
  property-list
  ;;The standard name string representation:
  namestring
  ;;The "truename" was translated from another form of pathname to this one:
  truename
  ;;Flag whether this pathname has been parsed
  parsed)

(defstruct (s$host :named)
  variety
  name
  nicknames
  force-case
  namestring
  parsed
  ;;Functions for parsing full pathnames and components
  (parser 'parse-canonical-pathname)
;  pathname-device-parser
;  pathname-name-parser
;  pathname-type-parser
;  pathname-version-parser
;  pathname-namestring-parser
  ;;Functions for "printing" pathnames and components
  (printer 'print-canonical-pathname)
;  pathname-device-printer
;  pathname-name-printer
;  pathname-type-printer
;  pathname-version-printer
;  pathname-namestring-printer
  )

(defstruct (s$network-host :named (:include s$host))
  network-addresses
  networks)

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

(defmacro with-s$pathname-components ((var pathname) &body body)
  `(let ((,var ,pathname))
     (let ((variety   (s$pathname-variety ,var))
	   (host      (s$pathname-host ,var))
	   (device    (s$pathname-device ,var))
	   (directory (s$pathname-directory ,var))
	   (name      (s$pathname-name ,var))
	   (type      (s$pathname-type ,var))
	   (version   (s$pathname-version ,var)))
       ,@body)
     ,var))

;;;Parsing / validation:

(defun s$pathname-parse-canonical-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))))
      (s$debug "~&Parsing a ~S pathname" (read-one-part))
      (make-s$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 nil-value)
  `(progn (check-type ,var ,(if nil-value `(or ,@types null) `(or ,@types)))
	  (or ,var
	      (setq ,var ,nil-value)
	      ,(null nil-value)
	      (error "~S is not initialized in pathname" ',var))))

(defun internal-parse-s$pathname (pathname &optional (host (s$pathname-host pathname)))
  (setf (s$pathname-parsed pathname)
	(let ((parser (s$pathname-parser host)))
	  (if parser (funcall parser pathname) t))))
      
(defun check-s$pathname (pathname)
  "Set PARSED flag if all is well."
  (with-s$pathname-components (path pathname)
    (fix-type variety   (keyword) :s$canonical-pathname)
    (fix-type host      (s$host))
    (fix-type device    (string))
    (fix-type directory (list) nil)
    (fix-type name      (string))
    (fix-type type      (string))
    (fix-type version   (number keyword))
    (internal-parse-pathname path)))

;;;Pathname defaulting:

(defvar *default-s$pathname-host* nil
  "If non-NIL, this the default host from which to obtain default pathname information.
See *DEFAULT-S$PATHNAME-DEFAULTS*.")

(defvar *default-s$pathname-defaults* nil
  "If non-NIL, supplies default pathname information.
Functions such as MAKE-S$PATHNAME fill in omitted information from this list,
using default information for the specified pathname host, or 
for the default pathname host *DEFAULT-S$PATHNAME-HOST*.")

(defun default-host ()
  *default-s$pathname-defaults*)

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

(defsetf default-host set-default-host)

(defun default-pathname (&optional (host *default-s$pathname-host*) &aux defaults)
  (if host
      (setq defaults (cdr (assoc host *default-s$pathname-defaults*))))
  (or defaults
      (setq defaults (cdr (assoc NIL *default-s$pathname-defaults*)))))

(defvar local-host (make-s$host :name "LOCAL"))

(set-default-host local-host)

;;;Pathname construction:

(defun sample-s$pathname (host)
  (make-s$pathname :host host))

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

;;;; The s$pathname component accessors, which were around before Common Lisp, didn't convert their
;;;; arguments to s$pathnames.  Now the Common Lisp functions do so.
;(DEFUN S$PATHNAME-HOST (P)
;  "Returns the host P is on."
;  (S$PATHNAME-RAW-HOST (S$PATHNAME P)))
;(DEFSUBST S$PATHNAME-DEVICE (P)
;  "Returns the device component of P."
;  (SEND (S$PATHNAME P) :DEVICE))
;(DEFSUBST S$PATHNAME-DIRECTORY (P)
;  "Returns the directory component of P."
;  (SEND (S$PATHNAME P) :DIRECTORY))
;(DEFSUBST S$PATHNAME-NAME (P)
;  "Returns the name of P."
;  (SEND (S$PATHNAME P) :NAME))
;(DEFSUBST S$PATHNAME-TYPE (P)
;  "Returns the type of P."
;  (SEND (S$PATHNAME P) :TYPE))
;(DEFSUBST S$PATHNAME-VERSION (P)
;  "Returns the version of P."
;  (SEND (S$PATHNAME P) :VERSION))
;;;; > Why are these different ?
;(DEFSUBST S$PATHNAME-PROPERTY-LIST (P)
;  "Returns the list of properties of P, which must be a s$pathname object."
;  (SYMEVAL-IN-INSTANCE P 'SI:PROPERTY-LIST))
;(DEFSUBST S$PATHNAME-PLIST (P) 
;  "Returns the list of properties of P, which must be a s$pathname object"
;  (S$PATHNAME-PROPERTY-LIST P))