[Ecls-list] Improvements in enough-namestring

timothy tschaef at sbcglobal.net
Sun Jul 9 00:51:40 UTC 2006


Hello,

I've provided a patch to make enough-namestring be a little more
flexible in providing shortened names for subdirectories.  I sent a
message a couple of weeks ago about how it only returned a shortened
path if the directories matched exactly.  

It does not yet do anything fancy; it does nothing special
with :wild(-inferiors)?, :up or :back, or investigate symlinks. It still
does what one might expect with these in some cases, but not in all.
I've included a test and its results.


Tim S





--- src/c/pathname.d	2006-06-12 18:47:12.000000000 -0400
+++ src/c/pathname.d	2006-07-06 15:29:24.000000000 -0400
@@ -1117,22 +1097,56 @@
 @
 	defaults = cl_pathname(defaults);
 	path = cl_pathname(path);
+
+	/* The directory has to be handled specially. */
+	cl_object pathdir = path->pathname.directory;
+	cl_object pathdefdir = defaults->pathname.directory;
+	cl_object dir = pathdir;
+	if (Null(pathdir)) {
+	  dir = CONS(@':relative', Cnil);
+	}
+	else if ( Null(pathdefdir) || (CAR(pathdir) == @':relative') ) {
+	  /* nop */ 
+	}
+	else {
+	  /* Loop through and compare each element in PATHDIR and
+	     PATHDEFDIR, breaking if any are not eq. PATHDIR doesn't
+	     start with :RELATIVE, so if PATHDEFDIR is relative it
+	     will fail the comparison. */
+	  /* TODO: What about :up, :back, :wild? */
+	  for(; CONSP(pathdir) && CONSP(pathdefdir); 
+	      pathdir = CDR(pathdir),
+	      	pathdefdir = CDR(pathdefdir)) {
+	    if (!equalp(CAR(pathdir), CAR(pathdefdir)))
+	      break;
+	  }
+	  /* If we reached the end of the DEFAULTS directory,
+	     everything in it was equal to the associate PATHNAME
+	     element; return a relative list from the rest of PATHNAME */
+	     if (Null(pathdefdir)) {
+	       /* Don't need to COPY-LIST PATHDIR; make_pathname will
+                  do that below. */
+	       dir = CONS(@':relative', pathdir);
+	     }
+	}
+		
+
+#define EN_GET_EQUAL_PATH_EL(el) \
+	(equalp(path->pathname.el, defaults->pathname.el) ? \
+	 Cnil : path->pathname.el)
+
+	/* Don't squash the file name! */
+	cl_object fname = EN_GET_EQUAL_PATH_EL(name);
+	if (fname == Cnil) fname = path->pathname.name;
+
 	newpath
-	= make_pathname(equalp(path->pathname.host, defaults->pathname.host) ?
-			Cnil : path->pathname.host,
-	                equalp(path->pathname.device,
-			       defaults->pathname.device) ?
-			Cnil : path->pathname.device,
-	                equalp(path->pathname.directory,
-			       defaults->pathname.directory) ?
-			Cnil : path->pathname.directory,
-	                equalp(path->pathname.name, defaults->pathname.name) ?
-			Cnil : path->pathname.name,
-	                equalp(path->pathname.type, defaults->pathname.type) ?
-			Cnil : path->pathname.type,
-	                equalp(path->pathname.version,
-			       defaults->pathname.version) ?
-			Cnil : path->pathname.version);
+	= make_pathname(EN_GET_EQUAL_PATH_EL(host),
+	                EN_GET_EQUAL_PATH_EL(device),
+	                dir,
+	                fname,
+	                EN_GET_EQUAL_PATH_EL(type),
+	                EN_GET_EQUAL_PATH_EL(version));
+#undef EN_GET_EQUAL_PATH_EL
 	newpath->pathname.logical = path->pathname.logical;
 	@(return ecl_namestring(newpath, 1))
 @)






(in-package :cl-user)

(defvar *enough-namestring_tests*
  `(("/A/b/C/"
     ("/A/b/C/drink-up.sot"
      "/A/b/C/loozer/whiskey.sot"
      "/A/b/C/loozer/whiskey"
      "/A/b/whiskey.sot"
      "/A/"
      "whiskey.sot"
      "loozer/whiskey.sot"
      "C/loozer/whisky.sot"
      ""))
    ("A/b/C" ("A/b/C" "A/b/C/loozer" "b/C" "/A/b/C" "/A/" ""))
    ("/" ("/A/b/C/drink-up.sot" "/A/b/C/" "/A/" ""))
    ("" ("/A/b/C/drink-up.sot" "/A/b/C/loozer/whiskey.sot"
	 "/A/b/C/loozer/whiskey" "/A/b/whiskey.sot"
	 "/A/" "whiskey.sot" "loozer/whiskey.sot" "C/loozer/whisky.sot"))
    ("/A/*/C/drink-up.sot"
     ("/A/*/C/drink-up.sot" "/A/b/C/drink-up.sot"
"/A/b/C/loozer/whiskey.*"
      "/A/b/C/loozer/*.sot" "/A/**/whiskey.sot" ""))
    ("/A/b/../c/d.sot" ("/A/b/../c/d.sot" "/A/b/../c/D/e.sot"
"/A/c/d.sot" "../c/d.sot"
			"c/e/d.sot"))  ))


(defun test_enough-namestring ()
  (labels ((test-path (path defaults)
		      (let ((e-ns (enough-namestring path defaults)))
			(format t "~A~%" (make-string 70 :initial-element #\-))
			(format t "Testing ~W with defaults ~W:~%" path defaults)
			(format t "(enough-namestring ~W ~W) -> ~W~%"
				path defaults e-ns)
			(format t "Testing for merge-pathname compatability:~W~%"
				(equalp (merge-pathnames e-ns defaults)
					(merge-pathnames (parse-namestring path nil defaults)
							 defaults))) ))
	   (test-default+paths (default+paths)
			       (let ((defaults (first default+paths))
				     (paths (second default+paths)))
				 (mapc (lambda (path)
					 (handler-case (test-path path defaults)
						       (error (error) (format t "Error: ~S~%" error))))
				       paths))))
    (mapc #'test-default+paths *enough-namestring_tests*))
  (VALUES))

----------------------------------------------------------------------
Testing "/A/b/C/drink-up.sot" with defaults "/A/b/C/":
(enough-namestring "/A/b/C/drink-up.sot" "/A/b/C/") -> "drink-up.sot"
Testing for merge-pathname compatability:T
----------------------------------------------------------------------
Testing "/A/b/C/loozer/whiskey.sot" with defaults "/A/b/C/":
(enough-namestring "/A/b/C/loozer/whiskey.sot" "/A/b/C/") ->
"loozer/whiskey.sot"
Testing for merge-pathname compatability:T
----------------------------------------------------------------------
Testing "/A/b/C/loozer/whiskey" with defaults "/A/b/C/":
(enough-namestring "/A/b/C/loozer/whiskey" "/A/b/C/") ->
"loozer/whiskey"
Testing for merge-pathname compatability:T
----------------------------------------------------------------------
Testing "/A/b/whiskey.sot" with defaults "/A/b/C/":
(enough-namestring "/A/b/whiskey.sot" "/A/b/C/") -> "/A/b/whiskey.sot"
Testing for merge-pathname compatability:T
----------------------------------------------------------------------
Testing "/A/" with defaults "/A/b/C/":
(enough-namestring "/A/" "/A/b/C/") -> "/A/"
Testing for merge-pathname compatability:T
----------------------------------------------------------------------
Testing "whiskey.sot" with defaults "/A/b/C/":
(enough-namestring "whiskey.sot" "/A/b/C/") -> "whiskey.sot"
Testing for merge-pathname compatability:T
----------------------------------------------------------------------
Testing "loozer/whiskey.sot" with defaults "/A/b/C/":
(enough-namestring "loozer/whiskey.sot" "/A/b/C/") ->
"loozer/whiskey.sot"
Testing for merge-pathname compatability:T
----------------------------------------------------------------------
Testing "C/loozer/whisky.sot" with defaults "/A/b/C/":
(enough-namestring "C/loozer/whisky.sot" "/A/b/C/") ->
"C/loozer/whisky.sot"
Testing for merge-pathname compatability:T
----------------------------------------------------------------------
Testing "" with defaults "/A/b/C/":
(enough-namestring "" "/A/b/C/") -> ""
Testing for merge-pathname compatability:T
----------------------------------------------------------------------
Testing "A/b/C" with defaults "A/b/C":
(enough-namestring "A/b/C" "A/b/C") -> "A/b/C"
Testing for merge-pathname compatability:T
----------------------------------------------------------------------
Testing "A/b/C/loozer" with defaults "A/b/C":
(enough-namestring "A/b/C/loozer" "A/b/C") -> "A/b/C/loozer"
Testing for merge-pathname compatability:T
----------------------------------------------------------------------
Testing "b/C" with defaults "A/b/C":
(enough-namestring "b/C" "A/b/C") -> "b/C"
Testing for merge-pathname compatability:T
----------------------------------------------------------------------
Testing "/A/b/C" with defaults "A/b/C":
(enough-namestring "/A/b/C" "A/b/C") -> "/A/b/C"
Testing for merge-pathname compatability:T
----------------------------------------------------------------------
Testing "/A/" with defaults "A/b/C":
(enough-namestring "/A/" "A/b/C") -> "/A/"
Testing for merge-pathname compatability:T
----------------------------------------------------------------------
Testing "" with defaults "A/b/C":
(enough-namestring "" "A/b/C") -> ""
Testing for merge-pathname compatability:T
----------------------------------------------------------------------
Testing "/A/b/C/drink-up.sot" with defaults "/":
(enough-namestring "/A/b/C/drink-up.sot" "/") -> "A/b/C/drink-up.sot"
Testing for merge-pathname compatability:T
----------------------------------------------------------------------
Testing "/A/b/C/" with defaults "/":
(enough-namestring "/A/b/C/" "/") -> "A/b/C/"
Testing for merge-pathname compatability:T
----------------------------------------------------------------------
Testing "/A/" with defaults "/":
(enough-namestring "/A/" "/") -> "A/"
Testing for merge-pathname compatability:T
----------------------------------------------------------------------
Testing "" with defaults "/":
(enough-namestring "" "/") -> ""
Testing for merge-pathname compatability:T
----------------------------------------------------------------------
Testing "/A/b/C/drink-up.sot" with defaults "":
(enough-namestring "/A/b/C/drink-up.sot" "") -> "/A/b/C/drink-up.sot"
Testing for merge-pathname compatability:T
----------------------------------------------------------------------
Testing "/A/b/C/loozer/whiskey.sot" with defaults "":
(enough-namestring "/A/b/C/loozer/whiskey.sot" "") ->
"/A/b/C/loozer/whiskey.sot"
Testing for merge-pathname compatability:T
----------------------------------------------------------------------
Testing "/A/b/C/loozer/whiskey" with defaults "":
(enough-namestring "/A/b/C/loozer/whiskey" "") ->
"/A/b/C/loozer/whiskey"
Testing for merge-pathname compatability:T
----------------------------------------------------------------------
Testing "/A/b/whiskey.sot" with defaults "":
(enough-namestring "/A/b/whiskey.sot" "") -> "/A/b/whiskey.sot"
Testing for merge-pathname compatability:T
----------------------------------------------------------------------
Testing "/A/" with defaults "":
(enough-namestring "/A/" "") -> "/A/"
Testing for merge-pathname compatability:T
----------------------------------------------------------------------
Testing "whiskey.sot" with defaults "":
(enough-namestring "whiskey.sot" "") -> "whiskey.sot"
Testing for merge-pathname compatability:T
----------------------------------------------------------------------
Testing "loozer/whiskey.sot" with defaults "":
(enough-namestring "loozer/whiskey.sot" "") -> "loozer/whiskey.sot"
Testing for merge-pathname compatability:T
----------------------------------------------------------------------
Testing "C/loozer/whisky.sot" with defaults "":
(enough-namestring "C/loozer/whisky.sot" "") -> "C/loozer/whisky.sot"
Testing for merge-pathname compatability:T
----------------------------------------------------------------------
Testing "/A/*/C/drink-up.sot" with defaults "/A/*/C/drink-up.sot":
(enough-namestring "/A/*/C/drink-up.sot" "/A/*/C/drink-up.sot") ->
"drink-up"
Testing for merge-pathname compatability:T
----------------------------------------------------------------------
Testing "/A/b/C/drink-up.sot" with defaults "/A/*/C/drink-up.sot":
(enough-namestring "/A/b/C/drink-up.sot" "/A/*/C/drink-up.sot") ->
"/A/b/C/drink-up"
Testing for merge-pathname compatability:T
----------------------------------------------------------------------
Testing "/A/b/C/loozer/whiskey.*" with defaults "/A/*/C/drink-up.sot":
(enough-namestring "/A/b/C/loozer/whiskey.*" "/A/*/C/drink-up.sot") ->
"/A/b/C/loozer/whiskey.*"
Testing for merge-pathname compatability:T
----------------------------------------------------------------------
Testing "/A/b/C/loozer/*.sot" with defaults "/A/*/C/drink-up.sot":
(enough-namestring "/A/b/C/loozer/*.sot" "/A/*/C/drink-up.sot") ->
"/A/b/C/loozer/*"
Testing for merge-pathname compatability:T
----------------------------------------------------------------------
Testing "/A/**/whiskey.sot" with defaults "/A/*/C/drink-up.sot":
(enough-namestring "/A/**/whiskey.sot" "/A/*/C/drink-up.sot") ->
"/A/**/whiskey"
Testing for merge-pathname compatability:T
----------------------------------------------------------------------
Testing "" with defaults "/A/*/C/drink-up.sot":
(enough-namestring "" "/A/*/C/drink-up.sot") -> ""
Testing for merge-pathname compatability:T
> (pathname-directory
"/usr/share/stuff/../common-lisp/source/iterate/iterate.asd")
(:ABSOLUTE "usr" "share" "stuff" :UP "common-lisp" "source" "iterate")
> ;;; Evaluating defvar *enough-namestring_tests*
*ENOUGH-NAMESTRING_TESTS*
> (test_enough-namestring)
----------------------------------------------------------------------
Testing "/A/b/C/drink-up.sot" with defaults "/A/b/C/":
(enough-namestring "/A/b/C/drink-up.sot" "/A/b/C/") -> "drink-up.sot"
Testing for merge-pathname compatability:T
----------------------------------------------------------------------
Testing "/A/b/C/loozer/whiskey.sot" with defaults "/A/b/C/":
(enough-namestring "/A/b/C/loozer/whiskey.sot" "/A/b/C/") ->
"loozer/whiskey.sot"
Testing for merge-pathname compatability:T
----------------------------------------------------------------------
Testing "/A/b/C/loozer/whiskey" with defaults "/A/b/C/":
(enough-namestring "/A/b/C/loozer/whiskey" "/A/b/C/") ->
"loozer/whiskey"
Testing for merge-pathname compatability:T
----------------------------------------------------------------------
Testing "/A/b/whiskey.sot" with defaults "/A/b/C/":
(enough-namestring "/A/b/whiskey.sot" "/A/b/C/") -> "/A/b/whiskey.sot"
Testing for merge-pathname compatability:T
----------------------------------------------------------------------
Testing "/A/" with defaults "/A/b/C/":
(enough-namestring "/A/" "/A/b/C/") -> "/A/"
Testing for merge-pathname compatability:T
----------------------------------------------------------------------
Testing "whiskey.sot" with defaults "/A/b/C/":
(enough-namestring "whiskey.sot" "/A/b/C/") -> "whiskey.sot"
Testing for merge-pathname compatability:T
----------------------------------------------------------------------
Testing "loozer/whiskey.sot" with defaults "/A/b/C/":
(enough-namestring "loozer/whiskey.sot" "/A/b/C/") ->
"loozer/whiskey.sot"
Testing for merge-pathname compatability:T
----------------------------------------------------------------------
Testing "C/loozer/whisky.sot" with defaults "/A/b/C/":
(enough-namestring "C/loozer/whisky.sot" "/A/b/C/") ->
"C/loozer/whisky.sot"
Testing for merge-pathname compatability:T
----------------------------------------------------------------------
Testing "" with defaults "/A/b/C/":
(enough-namestring "" "/A/b/C/") -> ""
Testing for merge-pathname compatability:T
----------------------------------------------------------------------
Testing "A/b/C" with defaults "A/b/C":
(enough-namestring "A/b/C" "A/b/C") -> "A/b/C"
Testing for merge-pathname compatability:T
----------------------------------------------------------------------
Testing "A/b/C/loozer" with defaults "A/b/C":
(enough-namestring "A/b/C/loozer" "A/b/C") -> "A/b/C/loozer"
Testing for merge-pathname compatability:T
----------------------------------------------------------------------
Testing "b/C" with defaults "A/b/C":
(enough-namestring "b/C" "A/b/C") -> "b/C"
Testing for merge-pathname compatability:T
----------------------------------------------------------------------
Testing "/A/b/C" with defaults "A/b/C":
(enough-namestring "/A/b/C" "A/b/C") -> "/A/b/C"
Testing for merge-pathname compatability:T
----------------------------------------------------------------------
Testing "/A/" with defaults "A/b/C":
(enough-namestring "/A/" "A/b/C") -> "/A/"
Testing for merge-pathname compatability:T
----------------------------------------------------------------------
Testing "" with defaults "A/b/C":
(enough-namestring "" "A/b/C") -> ""
Testing for merge-pathname compatability:T
----------------------------------------------------------------------
Testing "/A/b/C/drink-up.sot" with defaults "/":
(enough-namestring "/A/b/C/drink-up.sot" "/") -> "A/b/C/drink-up.sot"
Testing for merge-pathname compatability:T
----------------------------------------------------------------------
Testing "/A/b/C/" with defaults "/":
(enough-namestring "/A/b/C/" "/") -> "A/b/C/"
Testing for merge-pathname compatability:T
----------------------------------------------------------------------
Testing "/A/" with defaults "/":
(enough-namestring "/A/" "/") -> "A/"
Testing for merge-pathname compatability:T
----------------------------------------------------------------------
Testing "" with defaults "/":
(enough-namestring "" "/") -> ""
Testing for merge-pathname compatability:T
----------------------------------------------------------------------
Testing "/A/b/C/drink-up.sot" with defaults "":
(enough-namestring "/A/b/C/drink-up.sot" "") -> "/A/b/C/drink-up.sot"
Testing for merge-pathname compatability:T
----------------------------------------------------------------------
Testing "/A/b/C/loozer/whiskey.sot" with defaults "":
(enough-namestring "/A/b/C/loozer/whiskey.sot" "") ->
"/A/b/C/loozer/whiskey.sot"
Testing for merge-pathname compatability:T
----------------------------------------------------------------------
Testing "/A/b/C/loozer/whiskey" with defaults "":
(enough-namestring "/A/b/C/loozer/whiskey" "") ->
"/A/b/C/loozer/whiskey"
Testing for merge-pathname compatability:T
----------------------------------------------------------------------
Testing "/A/b/whiskey.sot" with defaults "":
(enough-namestring "/A/b/whiskey.sot" "") -> "/A/b/whiskey.sot"
Testing for merge-pathname compatability:T
----------------------------------------------------------------------
Testing "/A/" with defaults "":
(enough-namestring "/A/" "") -> "/A/"
Testing for merge-pathname compatability:T
----------------------------------------------------------------------
Testing "whiskey.sot" with defaults "":
(enough-namestring "whiskey.sot" "") -> "whiskey.sot"
Testing for merge-pathname compatability:T
----------------------------------------------------------------------
Testing "loozer/whiskey.sot" with defaults "":
(enough-namestring "loozer/whiskey.sot" "") -> "loozer/whiskey.sot"
Testing for merge-pathname compatability:T
----------------------------------------------------------------------
Testing "C/loozer/whisky.sot" with defaults "":
(enough-namestring "C/loozer/whisky.sot" "") -> "C/loozer/whisky.sot"
Testing for merge-pathname compatability:T
----------------------------------------------------------------------
Testing "/A/*/C/drink-up.sot" with defaults "/A/*/C/drink-up.sot":
(enough-namestring "/A/*/C/drink-up.sot" "/A/*/C/drink-up.sot") ->
"drink-up"
Testing for merge-pathname compatability:T
----------------------------------------------------------------------
Testing "/A/b/C/drink-up.sot" with defaults "/A/*/C/drink-up.sot":
(enough-namestring "/A/b/C/drink-up.sot" "/A/*/C/drink-up.sot") ->
"/A/b/C/drink-up"
Testing for merge-pathname compatability:T
----------------------------------------------------------------------
Testing "/A/b/C/loozer/whiskey.*" with defaults "/A/*/C/drink-up.sot":
(enough-namestring "/A/b/C/loozer/whiskey.*" "/A/*/C/drink-up.sot") ->
"/A/b/C/loozer/whiskey.*"
Testing for merge-pathname compatability:T
----------------------------------------------------------------------
Testing "/A/b/C/loozer/*.sot" with defaults "/A/*/C/drink-up.sot":
(enough-namestring "/A/b/C/loozer/*.sot" "/A/*/C/drink-up.sot") ->
"/A/b/C/loozer/*"
Testing for merge-pathname compatability:T
----------------------------------------------------------------------
Testing "/A/**/whiskey.sot" with defaults "/A/*/C/drink-up.sot":
(enough-namestring "/A/**/whiskey.sot" "/A/*/C/drink-up.sot") ->
"/A/**/whiskey"
Testing for merge-pathname compatability:T
----------------------------------------------------------------------
Testing "" with defaults "/A/*/C/drink-up.sot":
(enough-namestring "" "/A/*/C/drink-up.sot") -> ""
Testing for merge-pathname compatability:T
----------------------------------------------------------------------
Testing "/A/b/../c/d.sot" with defaults "/A/b/../c/d.sot":
(enough-namestring "/A/b/../c/d.sot" "/A/b/../c/d.sot") -> "d"
Testing for merge-pathname compatability:T
----------------------------------------------------------------------
Testing "/A/b/../c/D/e.sot" with defaults "/A/b/../c/d.sot":
(enough-namestring "/A/b/../c/D/e.sot" "/A/b/../c/d.sot") -> "D/e"
Testing for merge-pathname compatability:T
----------------------------------------------------------------------
Testing "/A/c/d.sot" with defaults "/A/b/../c/d.sot":
(enough-namestring "/A/c/d.sot" "/A/b/../c/d.sot") -> "/A/c/d"
Testing for merge-pathname compatability:T
----------------------------------------------------------------------
Testing "../c/d.sot" with defaults "/A/b/../c/d.sot":
(enough-namestring "../c/d.sot" "/A/b/../c/d.sot") -> "../c/d"
Testing for merge-pathname compatability:T
----------------------------------------------------------------------
Testing "c/e/d.sot" with defaults "/A/b/../c/d.sot":
(enough-namestring "c/e/d.sot" "/A/b/../c/d.sot") -> "c/e/d"
Testing for merge-pathname compatability:T






More information about the ecl-devel mailing list