From d171bd26f76aaa12d600542337b4186296c2c03d Mon Sep 17 00:00:00 2001 From: William Harold Newman Date: Thu, 31 May 2001 21:12:04 +0000 Subject: [PATCH] 0.6.12.21.flaky2: (This version has a flaky GC/memory-corruption problem. It's perfectly repeatable both on my OpenBSD box and on my Linux box -- just "sh run-tests.sh" -- which is why I thought it was worth saving this before I messed with it too much. But it's flaky in that all sorts of little harmless-looking program or test changes made while trying to isolate the problem can cause it to vanish.) Dan Barlow's logical pathname tests sbcl-devel 2001-05-31 added DEFUN SANE-DEFAULT-PATHNAME-DEFAULTS made all relative-to-absolute conversions go through *DEFAULT-PATHNAME-DEFAULTS*, so Unix current directory is only used to initialize *DEFAULT-PATHNAME-DEFAULTS* (and thus UNIX-MAYBE-PREPEND-CURRENT-DIRECTORY goes away) --- package-data-list.lisp-expr | 4 +- src/code/filesys.lisp | 9 ++-- src/code/primordial-extensions.lisp | 19 +++++++ tests/interface.pure.lisp | 1 + tests/pathnames.impure.lisp | 94 ++++++++++++++++++++++++++++++++++- version.lisp-expr | 2 +- 6 files changed, 120 insertions(+), 9 deletions(-) diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 1fc9049..cc62853 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -668,7 +668,7 @@ retained, possibly temporariliy, because it might be used internally." ;; miscellaneous non-standard but handy user-level functions.. "ASSQ" "DELQ" "MEMQ" "POSQ" "NEQ" "%FIND-PACKAGE-OR-LOSE" "FIND-UNDELETED-PACKAGE-OR-LOSE" - "SANE-PACKAGE" + "SANE-PACKAGE" "SANE-DEFAULT-PATHNAME-DEFAULTS" "CIRCULAR-LIST-P" "SWAPPED-ARGS-FUN" "ANY/TYPE" "EVERY/TYPE" @@ -1542,7 +1542,7 @@ no guarantees of interface stability." "EPROTONOSUPPORT" "UNIX-SIGBLOCK" "SIGIO" "ENOMEM" "SIGEMT" "EFAULT" "ENODEV" "EIO" "EVICEERR" "ETXTBSY" "EWOULDBLOCK" "EAGAIN" "EDESTADDRREQ" "ENOEXEC" "ENETUNREACH" "ENOTEMPTY" - "UNIX-MAYBE-PREPEND-CURRENT-DIRECTORY" "ENFILE" + "ENFILE" "SIGTTOU" "EEXIST" "SIGPROF" "SIGSTOP" "ENETRESET" "SIGURG" "ENOBUFS" "EPROCLIM" "EROFS" "ETOOMANYREFS" "UNIX-FILE-KIND" "ELOCAL" "UNIX-SIGSETMASK" "EREMOTE" "ESOCKTNOSUPPORT" diff --git a/src/code/filesys.lisp b/src/code/filesys.lisp index 586c970..58dce2a 100644 --- a/src/code/filesys.lisp +++ b/src/code/filesys.lisp @@ -787,11 +787,12 @@ (error 'simple-file-error :pathname pathname :format-control "can't use a wild pathname here")) - (let ((namestring (unix-namestring pathname t))) + (let* ((defaulted-pathname (merge-pathnames + pathname + (sane-default-pathname-defaults))) + (namestring (unix-namestring defaulted-pathname t))) (when (and namestring (sb!unix:unix-file-kind namestring)) - (let ((truename (sb!unix:unix-resolve-links - (sb!unix:unix-maybe-prepend-current-directory - namestring)))) + (let ((truename (sb!unix:unix-resolve-links namestring))) (when truename (let ((*ignore-wildcards* t)) (pathname (sb!unix:unix-simplify-pathname truename)))))))) diff --git a/src/code/primordial-extensions.lisp b/src/code/primordial-extensions.lisp index 7e8e78d..912873a 100644 --- a/src/code/primordial-extensions.lisp +++ b/src/code/primordial-extensions.lisp @@ -179,6 +179,25 @@ (type-of maybe-package)) '*package* really-package))))))) +;;; Access *DEFAULT-PATHNAME-DEFAULTS*, warning if it's silly. (Unlike +;;; the vaguely-analogous SANE-PACKAGE, we don't actually need to +;;; reset the variable when it's silly, since even crazy values of +;;; *DEFAULT-PATHNAME-DEFAULTS* don't leave the system in a state where +;;; it's hard to recover interactively.) +(defun sane-default-pathname-defaults () + (let* ((dfd *default-pathname-defaults*) + (dfd-dir (pathname-directory dfd))) + ;; It's generally not good to use a relative pathname for + ;; *DEFAULT-PATHNAME-DEFAULTS*, since relative pathnames + ;; are defined by merging into a default pathname (which is, + ;; by default, *DEFAULT-PATHNAME-DEFAULTS*). + (when (and (consp dfd-dir) + (eql (first dfd-dir) :relative)) + (warn + "~@<~S is a relative pathname. (But we'll try using it anyway.)~@:>" + '*default-pathname-defaults*)) + dfd)) + ;;; Give names to elements of a numeric sequence. (defmacro defenum ((&key (prefix "") (suffix "") (start 0) (step 1)) &rest identifiers) diff --git a/tests/interface.pure.lisp b/tests/interface.pure.lisp index e0672a8..3ef66b6 100644 --- a/tests/interface.pure.lisp +++ b/tests/interface.pure.lisp @@ -33,3 +33,4 @@ (when (find-package public-package) (check-ext-symbols-arglist public-package))) (terpri) +(print "done with interface.pure.lisp") diff --git a/tests/pathnames.impure.lisp b/tests/pathnames.impure.lisp index d462c1b..08dfa28 100644 --- a/tests/pathnames.impure.lisp +++ b/tests/pathnames.impure.lisp @@ -158,6 +158,96 @@ (assert (equal (namestring (translate-logical-pathname "test0:foo;bar;baz;mum.quux.3")) "/library/foo/foo/bar/baz/mum.quux")) - -;;; success + +;;;; MERGE-PATHNAME tests +;;;; +;;;; There are some things we don't bother testing, just because they're +;;;; not meaningful on the underlying filesystem anyway. +;;;; +;;;; Mostly that means that we don't do devices, we don't do versions +;;;; except minimally in LPNs (they get lost in the translation to +;;;; physical hosts, so it's not much of an issue), and we don't do +;;;; hosts except for LPN hosts +;;;; +;;;; Although these tests could conceivably be useful in principle for +;;;; other implementations, they depend quite heavily on the rules for +;;;; namestring parsing, which are implementation-specific. So, success +;;;; or failure in these tests doesn't tell you anything about +;;;; ansi-compliance unless your PARSE-NAMESTRING works like ours. + +(setf (logical-pathname-translations "scratch") + '(("**;*.*.*" "/usr/local/doc/**/*"))) + +(loop for (expected-result . params) in + `(;; trivial merge + (#P"/usr/local/doc/foo" #p"foo" #p"/usr/local/doc/") + ;; If pathname does not specify a host, device, directory, + ;; name, or type, each such component is copied from + ;; default-pathname. + ;; 1) no name, no type + (#p"/supplied-dir/name.type" #p"/supplied-dir/" #p"/dir/name.type") + ;; 2) no directory, no type + (#p"/dir/supplied-name.type" #p"supplied-name" #p"/dir/name.type") + ;; 3) no name, no dir (must use make-pathname as ".foo" is parsed + ;; as a name) + (#p"/dir/name.supplied-type" + ,(make-pathname :type "supplied-type") + #p"/dir/name.type") + ;; If (pathname-directory pathname) is a list whose car is + ;; :relative, and (pathname-directory default-pathname) is a + ;; list, then the merged directory is [...] + (#p"/aaa/bbb/ccc/ddd/qqq/www" #p"qqq/www" #p"/aaa/bbb/ccc/ddd/eee") + ;; except that if the resulting list contains a string or + ;; :wild immediately followed by :back, both of them are + ;; removed. + (#P"/aaa/bbb/ccc/blah/eee" + ;; "../" in a namestring is parsed as :up not :back, so make-pathname + ,(make-pathname :directory '(:relative :back "blah")) + #p"/aaa/bbb/ccc/ddd/eee") + ;; If (pathname-directory default-pathname) is not a list or + ;; (pathname-directory pathname) is not a list whose car is + ;; :relative, the merged directory is (or (pathname-directory + ;; pathname) (pathname-directory default-pathname)) + (#P"/absolute/path/name.type" + #p"/absolute/path/name" + #p"/dir/default-name.type") + ;; === logical pathnames === + ;; recognizes a logical pathname namestring when + ;; default-pathname is a logical pathname + ;; FIXME: 0.6.12.20 fails this one. + #+nil (#P"scratch:foo;name1" #p"name1" #p"scratch:foo;") + ;; or when the namestring begins with the name of a defined + ;; logical host followed by a colon [I assume that refers to pathname + ;; rather than default-pathname] + (#p"SCRATCH:FOO;NAME2" #p"scratch:;name2" #p"scratch:foo;") + ;; conduct the previous set of tests again, with a lpn first argument + (#P"SCRATCH:USR;LOCAL;DOC;FOO" #p"scratch:;foo" #p"/usr/local/doc/") + (#p"SCRATCH:SUPPLIED-DIR;NAME.TYPE" + #p"scratch:supplied-dir;" + #p"/dir/name.type") + (#p"SCRATCH:DIR;SUPPLIED-NAME.TYPE" + #p"scratch:;supplied-name" + #p"/dir/name.type") + (#p"SCRATCH:DIR;NAME.SUPPLIED-TYPE" + ,(make-pathname :host "scratch" :type "supplied-type") + #p"/dir/name.type") + (#p"SCRATCH:AAA;BBB;CCC;DDD;FOO;BAR" + ,(make-pathname :host "scratch" + :directory '(:relative "foo") + :name "bar") + #p"/aaa/bbb/ccc/ddd/eee") + (#p"SCRATCH:AAA;BBB;CCC;FOO;BAR" + ,(make-pathname :host "scratch" + :directory '(:relative :back "foo") + :name "bar") + #p"/aaa/bbb/ccc/ddd/eee") + (#p"SCRATCH:ABSOLUTE;PATH;NAME.TYPE" + #p"scratch:absolute;path;name" #p"/dir/default-name.type") + + ;; TODO: test version handling in LPNs + ) + do (assert (string= (namestring (apply #'merge-pathnames params)) + (namestring expected-result)))) + +;;;; success (quit :unix-status 104) diff --git a/version.lisp-expr b/version.lisp-expr index 2e6b066..bce2327 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -15,4 +15,4 @@ ;;; versions, and a string like "0.6.5.12" is used for versions which ;;; aren't released but correspond only to CVS tags or snapshots. -"0.6.12.21" +"0.6.12.22" -- 1.7.10.4