;;	Change History (most recent first):
;;  2 7/30/96  akh  add %expand-logical-directory
;;  1 7/26/96  akh  new file for old logical directories
;;  (do not edit before this line!!)
; compatibility with old logical directories


; Change History
;
;  9/30/96 slh   updated doc string from the one removed from help file

(in-package :ccl)

(let ((*warn-if-redefine* nil)
      (*warn-if-redefine-kernel* nil))

(defun def-logical-directory (logical-name physical-pathname &aux pair len old)
   "Defines a new logical directory name, adds it to *logical-directory-alist*,
and returns old definition. Physical-pathname may be NIL to remove the definition."
   (setq logical-name (string-arg logical-name)) ;coerces to simple-string
   (when (and (not (eql (setq len (length logical-name)) 0))
              (eq (schar logical-name (setq len (%i- len 1))) #\;)
              (not (%path-quoted-p logical-name len 0)))
     (setq logical-name (%substr logical-name 0 len)))
   (when physical-pathname
     (when (non-nil-symbol-p physical-pathname)
       (setq physical-pathname (symbol-name physical-pathname)))
     (if (stringp physical-pathname)
       (progn
         (setq physical-pathname (ensure-simple-string physical-pathname))
         (unless (or (eql (setq len (length physical-pathname)) 0)
                     (and (%str-member (schar physical-pathname (%i- len 1)) ":;")
                          (not (%path-quoted-p physical-pathname (%i- len 1) 0))))
           (setq physical-pathname (%str-cat physical-pathname ":"))))
       (setq physical-pathname (directory-namestring physical-pathname))))
   (setq pair (%str-assoc logical-name *logical-directory-alist*))
   (setq old (cdr pair))
   (if (null physical-pathname) ;remove
     (if pair (setq *logical-directory-alist*
                    (remove-from-alist (%car pair) *logical-directory-alist*)))
     (if pair (progn (%rplaca pair logical-name) ;In case new casification
                     (%rplacd pair physical-pathname))
         (push (cons logical-name physical-pathname)
               *logical-directory-alist*)))
   old)

(defun %expand-logical-directory (directory &optional no-error)
    (let ((cadr (%cadr directory)))
      (if (and (eq (%car directory) ':absolute) cadr (listp cadr))
        (let* ((name (%cadr cadr))
               (sub (assoc name *logical-directory-alist* :test #'string-equal)))
          (unless sub
            (if no-error
              (return-from %expand-logical-directory nil)
              (error "Undefined logical directory name ~S in ~S" name directory)))
          (multiple-value-bind (sstr start end) (get-sstring (%cdr sub))
            (let* ((sub-dir (%expand-logical-directory
                             (%directory-string-list sstr start end) no-error))         ; guaranteed freshly consed
                   (cddr (%cddr directory)))
              (if sub-dir
                (nconc sub-dir cddr)
                (if cddr
                  (cons ':relative cddr))))))
        directory)))

(defun directory-namestring (path)
  (let* ((dirlist (pathname-directory path))
         (host (pathname-host path))
         (result (%directory-list-namestring dirlist host)))
    (cond ((and (not host)   ; put in a quote if it is not logical but might appear to be
                (consp dirlist) 
                (eq (car dirlist) :absolute)
                (stringp (cadr dirlist))
                (null (cddr dirlist))
                (%str-assoc  (cadr dirlist) %logical-host-translations%))
           (let ((pos (%path-mem ":" result)))
             (%str-cat (%substr result 0  pos) "¶" 
                       (%substr result pos (length result)))))
          (t result))))

(defun enough-namestring (path &optional (defaults *default-pathname-defaults*))
  (if (null defaults) (namestring path)
      (let ((dir (pathname-directory path))
            (nam (pathname-name path))
            (typ (pathname-type path))
            (host (pathname-host path))
            (default-dir (pathname-directory defaults)))
        (when (equalp host (pathname-host defaults))
          (setq host nil))
        (setq host (if (and host (neq host :unspecific))
                     (%str-cat host ":")
                     ""))
        (cond ((equalp dir default-dir)
               (setq dir nil))
              ((and dir default-dir
                    (eq (car dir) :absolute)(eq (car default-dir) :absolute))
               (let (res) ; maybe make it relative to defaults
                 (do ((p1 (cdr dir) (cdr p1))
                      (p2 (cdr default-dir) (cdr p2)))
                     nil 
                   (cond ((null p1) (return nil))
                         ((null p2)
                          (when res
                            (setq dir (cons :relative p1)))
                          (return))
                         ((not (equalp (car p1)(car p2)))
                          (return nil))
                         (t (setq res t)))))))
        (when (equalp typ (pathname-type defaults))
          (setq typ nil))
        (when (and (null typ) (equalp nam (pathname-name defaults)))
          (setq nam nil))
        (when (and typ (neq typ :unspecific))
          (setq nam (if (null nam) (%str-cat "." typ) (%str-cat nam "." typ))))
        (cond (dir
               (setq dir (%directory-list-namestring dir))
               (if nam (%str-cat host dir nam)(%str-cat  host dir)))
              ((neq (length host) 0)
               (if nam (%str-cat host ";" nam)(%str-cat host ";")))
              (t (or nam ""))))))

(defun pathname (path)
  (when (streamp path) (setq path (%path-from-stream path)))
  (if (pathnamep path)
    path
    (multiple-value-bind (sstr start end) (get-sstring path)
      (let (directory name type host version pos)
        (multiple-value-setq (host pos)(pathname-host-sstr sstr start end))        
        (when pos (setq start pos))
        (multiple-value-setq (directory pos)(pathname-directory-sstr sstr start end host))
        (when directory (setq start pos))
        (multiple-value-setq (version pos)(pathname-version-sstr sstr start end))
        ; version is :unspecific :newest or "*" or 0
        (when pos (setq end pos))
        (multiple-value-setq (type pos)(pathname-type-sstr sstr start end))
        ; type-sstr should return beginning of type field
        (when pos (setq end pos))
        ; now everything else is the name
        (unless (eq start end)
          (setq name (%std-name-component (%substr sstr start end))))
        (cons-pathname directory
                       name
                       type
                       host
                       version)))))

(defun make-pathname (&key (host nil host-p) 
                           device
                           (directory nil directory-p)
                           (name nil name-p)
                           (type nil type-p)
                           (version nil version-p)
                           (defaults nil defaults-p) case
                           &aux path default-dir)
  (declare (ignore device))
  (when case (setq case (require-type case pathname-case-type)))
  (when (null host-p)
    (setq host (if defaults-p defaults *default-pathname-defaults*))
    (when (or  (stringp host)(pathnamep host))(setq host (pathname-host host))))
  (if directory-p 
    (setq directory (%std-directory-component directory host)))
  (if defaults
    (setq default-dir (pathname-directory defaults)))
  (cond ((null directory)(setq directory default-dir))
        ((and default-dir (eq (car directory) ':relative))
         (setq directory (append default-dir (cdr directory)))
         (when (memq :up directory)(remove-up directory))))  
  (setq name
        (if name-p
             (%std-name-component name)
             (and defaults (pathname-name defaults))))
  (setq type
        (if type-p
             (%std-type-component type)
             (and defaults (pathname-type defaults))))
  (setq version (if version-p
                  (%logical-version-component version)
                  (and defaults (pathname-version defaults))))  
  (setq path
        (cons-pathname directory name type host version))
  (when (and case (neq case :local))
    (setf (%pathname-directory path) (%reverse-component-case (%pathname-directory path) case)
          (%pathname-name path) (%reverse-component-case (%pathname-name path) case)
          (%pathname-type path) (%reverse-component-case (%pathname-type path) case)))
  path)

(defun %std-directory-component (directory &optional host)
  (cond ((null directory) nil)
        ((eq directory :wild) '(:absolute :wild-inferiors)) ; or :wild-inferiors? - yes
        ((stringp directory) (%directory-string-list directory 0 (length directory) host))
        ((listp directory)
         ;Standardize the directory list, taking care not to cons if nothing
         ;needs to be changed.
         (let ((names (%cdr directory)) (new-names ()) (logical nil))
           (when (eq (%car directory) ':absolute)
             (let ((name (car names)))
               (when (and (listp name)  (listp (%cdr name)) (null (%cddr name))
                          (eq (%car name) ':logical) (stringp (%cadr name)))
                 (setq logical (let ((new-str (%std-directory-part (%cadr name))))
                                 (if (eq new-str (%cadr name)) name (list ':logical new-str)))
                       names (%cdr names)))))
           (do ((nn names (%cdr nn)))
               ((null nn) (setq new-names (if new-names (nreverse new-names) names)))
             (let* ((name (car nn))
                    (new-name (cond ((consp name)
                                     (let ((new-str (%std-directory-part (%cadr name))))
                                       (if (eq new-str (%cadr name)) name (list ':logical new-str))))
                                    (t (%std-directory-part name)))))
               (unless (eq name new-name)
                 (unless new-names
                   (do ((new-nn names (%cdr new-nn)))
                       ((eq new-nn nn))
                     (push (%car new-nn) new-names))))
               (when (or new-names (neq name new-name))
                 (push new-name new-names))))
           (if (memq :up (or new-names names))
             (setq new-names (remove-up (or new-names (copy-list names)))))
           (ecase (%car directory)
             (:relative           
                  (cond (new-names         ; Just (:relative) is the same as NIL. - no it isnt
                         (if (eq new-names names)
                           directory
                           (cons ':relative new-names)))
                        (t directory)))
             (:absolute
                  (cond (logical
                         (if (and (eq new-names names) (eq logical (%cadr directory)))
                           directory
                           (list* ':absolute logical new-names)))
                        ((null new-names) directory)  ; But just (:absolute) IS the same as NIL
                        ((eq (%car new-names) ':up)
                         (report-bad-arg (%car new-names)'(not (member :up))))
                        ((eq new-names names) directory)
                        (t (cons ':absolute new-names)))))))
        (t (report-bad-arg directory '(or string list (member :wild))))))

(defun merge-pathnames (path &optional (defaults *default-pathname-defaults*)
                                       default-version)
  ;(declare (ignore default-version))
  (when (not (pathnamep path))(setq path (pathname path)))
  (when (not (pathnamep defaults))(setq defaults (pathname defaults)))
  (let* ((path-dir (pathname-directory path))
         (path-host (pathname-host path))
         (path-name (pathname-name path))
         (default-dir (and defaults (pathname-directory defaults)))
         (default-host (and defaults (pathname-host defaults)))
         ; take host from defaults iff path-dir is logical or absent 
         (host (cond ((and (memq path-host '(nil :unspecific))
                           (or (null path-dir)
                               (null (cdr path-dir))
                               (consp (cadr path-dir))
                               (and (eq :relative (car path-dir))
                                     (not (memq default-host '(nil :unspecific))))))
                          
                      default-host)
                     (t path-host)))
         (dir (cond ((null path-dir) default-dir)
                    ((null default-dir) path-dir)
                    ((eq (car path-dir) ':relative)
                     (let ((the-dir (append default-dir (%cdr path-dir))))
                       (when (memq ':up the-dir)(remove-up the-dir))
                       the-dir))
                    (t path-dir)))
         (nam (or path-name
                  (and defaults (pathname-name defaults))))
         (typ (or (pathname-type path)
                  (and defaults (pathname-type defaults))))
         (version (cond ((not path-name)(pathname-version defaults))
                        (t (pathname-version path)))))
    (when (and default-version (or (null version)(eq version :unspecific)))
      (setq version default-version))
    (if (and (pathnamep path)
             (eq dir (%pathname-directory path))
             (eq nam path-name)
             (eq typ (%pathname-type path))
             (eq host path-host)
             (eq version (pathname-version path)))
      path
      (progn (when (and host (neq host :unspecific)
                        (dolist (foo (cdr dir) nil)
                          (when (consp foo)(return t))))
               (setq dir (mapcar #'(lambda (e)
                                     (if (consp e)(cadr e) e))
                                 dir)))
             
             (cons-pathname dir nam typ host version)))))


(defun pathname-host-sstr (sstr start end &optional no-check)
  (when (not (%path-one-quoted-p ":" sstr start end))
    (let ((pos (%path-mem ":;" sstr start end)))
      (let ((host
             (when (and pos 
                        (neq pos start)   ; leading : doesnt specify a host
                        (eql (%schar sstr pos) #\:) ; a colon
                        (not (%path-mem ":" sstr (%i+ 1 pos) end))) ; the only colon
               (%substr sstr start pos))))
        (cond ((and host (or no-check (%str-assoc host %logical-host-translations%)))
               (values host (%i+ pos 1)))
              (host (when (%path-mem ";" sstr (%i+ 1 pos) end)
                      (error "~S is not a defined logical host" host)))
              ((and pos (eql (%schar sstr pos) #\:)
                    (%path-mem ":" sstr (%i+ pos 1) end)
                    (%path-mem ";" sstr (%i+ pos 1) end)) ; ???
               (error "~S is not a valid namestring" sstr))
              (t :unspecific))))))


(defun %directory-string-list (sstr start &optional (end (length sstr)) host)
  ;This must cons up a fresh list, %expand-logical-directory rplacd's it.
  (when (eq host :unspecific)(setq host nil))
  (labels ((std-part (sstr start end)
             (%std-directory-part (if (and (eq start 0) (eq end (length sstr)))
                                    sstr (%substr sstr start end))))
           (split (sstr start end)
             (unless (eql start end)
               (if (memq (%schar sstr start) '(#\: #\;))
                 (cons :up (split sstr (%i+ start 1) end))
                 (let* ((pos (or (%path-mem ":;" sstr start end) end))
                        (part (std-part sstr start pos)))
                   (cons (if (and (null host) (not (eql pos end)) (eql (%schar sstr pos) #\;))
                           (list :logical part)
                           part)
                         (unless (eq end pos)
                           (split sstr (%i+ pos 1) end))))))))
    (unless (eq start end)
      (let* ((pos (%path-mem ":;" sstr start end)))
              (cond ((null pos)
                     (list :absolute (std-part sstr start end)))
                    ((eq start pos)
                     (let ((rest (split sstr (%i+ pos 1) end)))
                       (cons ':relative rest)))
                    ((and (null host)(eql (%schar sstr pos) #\;))
                     (list* :absolute (list :logical (std-part sstr start pos)) (split sstr (%i+ pos 1) end)))
                    (t  (list* :absolute (std-part sstr start pos) (split sstr (%i+ pos 1) end))))))))

(defun %split-ccdirectory (dir)
  (let ((pos 0) (wildp nil)(rest dir)(logical nil))
    (dolist (e dir)
      (when (consp e) (setq logical t)(setq e (cadr e)))
      (case e
        (:wild (setq wildp '*))
        (:wild-inferiors 
         (setq wildp '**)
         (setq rest (cdr rest)))
        (t 
         (when (%path-mem "*" e)
           (cond ((string= e "**")
                  (setq rest (cdr rest))
                  (setq wildp '**))
                 ((eql 1 (length (the string e)))
                  (setq wildp '*))
                 (t (setq wildp t))))))
      (when wildp (return))
      (setq rest (cdr rest))
      (setq pos (%i+ 1 pos)))
    (cond ((not wildp)
           (values dir))
          (t (let (first)
               (when rest (setq rest (copy-list rest)))
               (dotimes (i pos)
                 (declare (fixnum i))
                 (push (car dir) first)
                 (setq dir (cdr dir)))
               (values (nreverse first) rest wildp (if wildp logical)))))))

(defun translate-component (source from to &optional reversible)                   
  (let ((orig-to to))
    (cond 
     ((and (consp source)(consp from)) ; source and from both logical 
      (setq source (cadr source) from (cadr from)))
     ((or (consp source)(consp from)) ;  or neither
      #-bccl (error "Something non-kosher in translate pathname")
      ))
    (when (memq from '(:wild :wild-inferiors)) (setq from "*"))
    (when (memq source '(:wild :wild-inferiors))(setq source "*"))
    (when (memq to '(:wild :wild-inferiors))(setq to "*"))
    (cond ((consp to)(setq to (cadr to))))  ;??
    (cond ((and (stringp to)(not (%path-mem "*" to)))
           to)
          ((and (or (not reversible)(not (stringp source))) ; <<
                (or (null to)
                    (and (stringp to)(or (string= to "**")(string= to "*")))))
           source)
          ((eq to :unspecific) to)  ; here we interpret :unspecific to mean don't want it
          ((not (stringp source)) to)
          (t 
           (let ((slen (length source)) srest match spos result (f2 nil) snextpos)
             (multiple-value-bind (tfirst trest twild)
                                  (%split-component to)
               (cond ((and to (not twild))(return-from translate-component to)))
               (multiple-value-bind (ffirst frest fwild)
                                    (%split-component from)          
                 (cond (fwild
                        (setq spos (if ffirst (length ffirst) 0))       ; start of source hunk
                        (if frest (setq f2 (%split-component frest)))
                        (setq snextpos (if f2 (%path-member f2 source spos) slen))
                        (setq match (%substr source spos snextpos))
                        (if frest (setq srest (%substr source snextpos slen)))
                        (setq result (if tfirst (%str-cat tfirst match) match))
                        (when frest 
                          (let ((foo (translate-component srest frest trest reversible)))
                            (when foo (setq result (%str-cat result foo))))))
                       (t  ; to is wild, from and source are not
                        (setq result (if tfirst (%str-cat tfirst source) source))
                        (when trest (setq result (%str-cat result trest))))))
               (if (consp orig-to)(list :logical result) result)))))))

; these better come after %expand-logical ...
(defun full-pathname (path &key (no-error t))
  (cond (no-error
         ; note that ignore-errors wont work until var %handlers% is defined (in l1-init)
         (setq path (ignore-errors
                     (translate-logical-pathname (merge-pathnames path))))
         (when (null path) (return-from full-pathname nil)))
        (t (setq path (translate-logical-pathname (merge-pathnames path)))))
  (let ((dir (%expand-logical-directory (%pathname-directory path) no-error)))
    (when (and no-error (not dir) (%pathname-directory path))(return-from full-pathname nil))
    (setq dir (absolute-directory-list dir))
    (unless (eq dir (%pathname-directory path))
      (setq path (cons-pathname dir (%pathname-name path) (%pathname-type path)
                                (pathname-host path)(pathname-version path))))
  path))

(defun mac-directory-namestring (path)
  (%path-mac-namestring   
    (%directory-list-namestring
     (%expand-logical-directory
      (pathname-directory (translate-logical-pathname (merge-pathnames path)))))))

(defun mac-directory-namestring-1 (path)
  (%path-mac-namestring   
    (%directory-list-namestring
     (%expand-logical-directory
      (pathname-directory path)))))

)