[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