From 3c14ace4ad57c7b7c1e59b75a44ccf2475267676 Mon Sep 17 00:00:00 2001
From: rtoy <rtoy>
Date: Mon, 19 Sep 2005 21:04:43 +0000
Subject: [PATCH] o Print out the host name when we're printing out
 LOGICAL-HOST   objects.  (Makes it easier to see what the logical host is
 when   describe'ing a pathname.)

o Fix some issues with UNPARSE-ENOUGH-NAMESTRING
  o It should return a string, not the pathname object.  (Noted by
    Peter Graves on cmucl-imp, 2005-09-18.)
  o The directory paths must have something more in common than just
    :ABSOLUTE before we produce a relative directory path.  Fixes the
    issue of always returning relative paths even if the directories
    don't match at all.

o In ENOUGH-NAMESTRING, if the host for the pathname isn't the same as
  the host for the defaults, just return the pathname.  I (rtoy) think
  this is right.  It doesn't make sense to do anything if the hosts
  are different.
---
 code/pathname.lisp | 72 ++++++++++++++++++++++++++++------------------
 1 file changed, 44 insertions(+), 28 deletions(-)

diff --git a/code/pathname.lisp b/code/pathname.lisp
index 87822f244..3e2717246 100644
--- a/code/pathname.lisp
+++ b/code/pathname.lisp
@@ -4,7 +4,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/pathname.lisp,v 1.76 2005/09/16 21:27:35 rtoy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/pathname.lisp,v 1.77 2005/09/19 21:04:43 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -59,6 +59,11 @@
   (declare (ignore depth))
   (print-unreadable-object (host stream :type t)))
 
+(defun %print-logical-host (host stream depth)
+  (declare (ignore depth))
+  (print-unreadable-object (host stream :type t)
+    (write (logical-host-name host) :stream stream)))
+
 (defstruct (logical-host
 	    (:include host
 		      (:parse #'parse-logical-namestring)
@@ -69,6 +74,7 @@
 		      (:unparse-file #'unparse-unix-file)
 		      (:unparse-enough #'unparse-enough-namestring)
 		      (:customary-case :upper))
+	    (:print-function %print-logical-host)
 	    (:make-load-form-fun make-logical-host-load-form-fun))
   (name "" :type simple-base-string)
   (translations nil :type list)
@@ -1094,7 +1100,12 @@ a host-structure or string."
     (let ((host (%pathname-host pathname)))
       (if host
 	  (with-pathname (defaults defaults)
-	    (funcall (host-unparse-enough host) pathname defaults))
+	    ;; Give up if the hosts are different.  I (rtoy) don't
+	    ;; think it makes sense to do anything if the hosts are
+	    ;; different.
+	    (if (equal host (%pathname-host defaults))
+		(funcall (host-unparse-enough host) pathname defaults)
+		pathname))
 	  (error
 	   "Cannot determine the namestring for pathnames with no host:~%  ~S"
 	   pathname)))))
@@ -1930,32 +1941,37 @@ a host-structure or string."
 ;;;
 (defun unparse-enough-namestring (pathname defaults)
   (let* ((path-dir (pathname-directory pathname))
-        (def-dir (pathname-directory defaults))
-        (enough-dir
-         ;; Go down the directory lists to see what matches.  What's
-         ;; left is what we want, more or less.
-         (cond ((and (eq (first path-dir) (first def-dir))
-                     (eq (first path-dir) :absolute))
-                ;; Both paths are :absolute, so find where the common
-                ;; parts end and return what's left
-                (do* ((p (rest path-dir) (rest p))
-                      (d (rest def-dir) (rest d)))
-                     ((or (endp p) (endp d)
-                          (not (equal (first p) (first d))))
-                      `(:relative ,@p))))
-               (t
-                ;; At least one path is :relative, so just return the
-                ;; original path.  If the original path is :relative,
-                ;; then that's the right one.  If PATH-DIR is
-                ;; :absolute, we want to return that except when
-                ;; DEF-DIR is :absolute, as handled above. so return
-                ;; the original directory.
-                path-dir))))
-    (make-pathname :host (%pathname-host pathname)
-                  :directory enough-dir
-                  :name (pathname-name pathname)
-                  :type (pathname-type pathname)
-                  :version (pathname-version pathname))))
+	 (def-dir (pathname-directory defaults))
+	 (enough-dir
+	  ;; Go down the directory lists to see what matches.  What's
+	  ;; left is what we want, more or less.  But there has to be
+	  ;; something in common.
+	  (cond ((and (eq (first path-dir) (first def-dir))
+		      (eq (first path-dir) :absolute)
+		      (second path-dir)
+		      (second def-dir)
+		      (equal (second path-dir) (second def-dir)))
+		 ;; Both paths are :absolute, so find where the common
+		 ;; parts end and return what's left
+		 (do* ((p (rest path-dir) (rest p))
+		       (d (rest def-dir) (rest d)))
+		      ((or (endp p) (endp d)
+			   (not (equal (first p) (first d))))
+		       `(:relative ,@p))))
+		(t
+		 ;; Both paths are absolute, but there's nothing in
+		 ;; common, so return the original.  Or one path is
+		 ;; :relative, so just return the original path.  If
+		 ;; the original path is :relative, then that's the
+		 ;; right one.  If PATH-DIR is :absolute, we want to
+		 ;; return that except when DEF-DIR is :absolute, as
+		 ;; handled above. so return the original directory.
+		 path-dir))))
+    (namestring (make-pathname :host (%pathname-host pathname)
+			       :directory enough-dir
+			       :name (pathname-name pathname)
+			       :type (pathname-type pathname)
+			       :version (pathname-version pathname)))))
 
 ;;; UNPARSE-LOGICAL-NAMESTRING -- Internal
 ;;;
-- 
GitLab