From b48a0ada03337a26f59744ed1df794b21420ea90 Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Thu, 18 Apr 2002 21:58:56 +0000 Subject: [PATCH] 0.7.2.16: Fix bug 160 (USER-HOMEDIR-PATHNAME) ... new uid_homedir function in wrap.c ... wrap it up some more in unix.lisp ... actually use it in filesys.lisp Also fixes to namestring parsing ... treat potentially logical pathname namestrings correctly ... remove last vestiges of search-list parsing from unix-namestring parsing --- BUGS | 15 ++-- NEWS | 6 +- package-data-list.lisp-expr | 2 +- src/code/filesys.lisp | 162 +++++++++++++---------------------------- src/code/target-pathname.lisp | 81 ++++++++++++++++++--- src/code/unix.lisp | 8 ++ src/runtime/wrap.c | 28 +++++++ tests/pathnames.impure.lisp | 9 ++- version.lisp-expr | 2 +- 9 files changed, 174 insertions(+), 139 deletions(-) diff --git a/BUGS b/BUGS index 7be13df..8d12392 100644 --- a/BUGS +++ b/BUGS @@ -1301,16 +1301,6 @@ WORKAROUND: (reported by Christophe Rhodes and Martin Atzmueller sbcl-devel 2002-05-15) -160: - USER-HOMEDIR-PATHNAME returns a pathname that SBCL can't do anything - with. Probably we should return an absolute physical pathname - instead. (Reported by Peter van Eynde sbcl-devel 2002-03-29) - -161: - Typep on certain SATISFIES types doesn't take account of the fact - that the function could cause an error; e.g. (TYPEP #\! '(SATISFIES - FBOUNDP)) raises an error when it should return NIL. - 162: (reported by Robert E. Brown 2002-04-16) When a function is called with too few arguments, causing the @@ -1331,6 +1321,11 @@ WORKAROUND: isn't too surprising since there are many differences in stack implementation and GC conservatism between the X86 and other ports.) +163: + HOST-NAMESTRING on a Unix pathname returns "Unix", which isn't + treated as a valid host by anything else in the system. (Reported by + Erik Naggum on comp.lang.lisp 2002-04-18) + DEFUNCT CATEGORIES OF BUGS IR1-#: These labels were used for bugs related to the old IR1 interpreter. diff --git a/NEWS b/NEWS index 1be50c3..f3273bb 100644 --- a/NEWS +++ b/NEWS @@ -1091,7 +1091,11 @@ changes in sbcl-0.7.3 relative to sbcl-0.7.2: sbcl-0.7.0, available as a patch against sbcl-0.7.0 at . * Bugfix to GET-DISPATCH-MACRO-CHAR, now returning NIL for undefined - dispatch macro character combinations (thanks to Alexey Dejenka) + dispatch macro character combinations. (thanks to Alexey Dejenka) + * Bugfix in PARSE-NAMESTRING: we now correctly parse unix namestrings + that superficially look like logical namestrings correctly. + * USER-HOMEDIR-PATHNAME now returns a (physical) pathname that SBCL + can deal with. planned incompatible changes in 0.7.x: * When the profiling interface settles down, maybe in 0.7.x, maybe diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 5ee2e99..c8bcf36 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -1543,7 +1543,7 @@ needed by the current implementation of SBCL, and makes no guarantees of interface stability." :use ("CL" "SB!ALIEN" "SB!EXT" "SB!INT" "SB!SYS") :export (;; wrappers around Unix stuff to give just what Lisp needs - "UID-USERNAME" + "UID-USERNAME" "UID-HOMEDIR" ;; stuff with a one-to-one mapping to Unix constructs "D-INO" "D-NAME" "D-NAMLEN" "D-OFF" "D-RECLEN" diff --git a/src/code/filesys.lisp b/src/code/filesys.lisp index ca50147..05809d3 100644 --- a/src/code/filesys.lisp +++ b/src/code/filesys.lisp @@ -215,100 +215,57 @@ (setf start (1+ slash)))) (values absolute (pieces))))) -;;; the thing before a colon in a logical path -(def!struct (logical-hostname (:make-load-form-fun - (lambda (x) - (values `(make-logical-hostname - ,(logical-hostname-name x)) - nil))) - (:copier nil) - (:constructor make-logical-hostname (name))) - (name (missing-arg) :type simple-string)) - -(defun maybe-extract-logical-hostname (namestr start end) - (declare (type simple-base-string namestr) - (type index start end)) - (let ((quoted nil)) - (do ((index start (1+ index))) - ((= index end) - (values nil start)) - (if quoted - (setf quoted nil) - (case (schar namestr index) - (#\\ - (setf quoted t)) - (#\: - (return (values (make-logical-hostname - (remove-backslashes namestr start index)) - (1+ index))))))))) - (defun parse-unix-namestring (namestr start end) (declare (type simple-base-string namestr) (type index start end)) (multiple-value-bind (absolute pieces) (split-at-slashes namestr start end) - (let ((logical-hostname - (if absolute - nil - (let ((first (car pieces))) - (multiple-value-bind (logical-hostname new-start) - (maybe-extract-logical-hostname namestr - (car first) - (cdr first)) - (when logical-hostname - (setf absolute t) - (setf (car first) new-start)) - logical-hostname))))) - (declare (type (or null logical-hostname) logical-hostname)) - (multiple-value-bind (name type version) - (let* ((tail (car (last pieces))) - (tail-start (car tail)) - (tail-end (cdr tail))) - (unless (= tail-start tail-end) - (setf pieces (butlast pieces)) - (extract-name-type-and-version namestr tail-start tail-end))) - - (when (stringp name) - (let ((position (position-if (lambda (char) - (or (char= char (code-char 0)) - (char= char #\/))) - name))) - (when position - (error 'namestring-parse-error - :complaint "can't embed #\\Nul or #\\/ in Unix namestring" - :namestring namestr - :offset position)))) - - ;; Now we have everything we want. So return it. - (values nil ; no host for Unix namestrings - nil ; no device for Unix namestrings - (collect ((dirs)) - (when logical-hostname - (dirs logical-hostname)) - (dolist (piece pieces) - (let ((piece-start (car piece)) - (piece-end (cdr piece))) - (unless (= piece-start piece-end) - (cond ((string= namestr ".." - :start1 piece-start - :end1 piece-end) - (dirs :up)) - ((string= namestr "**" - :start1 piece-start - :end1 piece-end) - (dirs :wild-inferiors)) - (t - (dirs (maybe-make-pattern namestr - piece-start - piece-end))))))) - (cond (absolute - (cons :absolute (dirs))) - ((dirs) - (cons :relative (dirs))) - (t - nil))) - name - type - version))))) + (multiple-value-bind (name type version) + (let* ((tail (car (last pieces))) + (tail-start (car tail)) + (tail-end (cdr tail))) + (unless (= tail-start tail-end) + (setf pieces (butlast pieces)) + (extract-name-type-and-version namestr tail-start tail-end))) + + (when (stringp name) + (let ((position (position-if (lambda (char) + (or (char= char (code-char 0)) + (char= char #\/))) + name))) + (when position + (error 'namestring-parse-error + :complaint "can't embed #\\Nul or #\\/ in Unix namestring" + :namestring namestr + :offset position)))) + ;; Now we have everything we want. So return it. + (values nil ; no host for Unix namestrings + nil ; no device for Unix namestrings + (collect ((dirs)) + (dolist (piece pieces) + (let ((piece-start (car piece)) + (piece-end (cdr piece))) + (unless (= piece-start piece-end) + (cond ((string= namestr ".." + :start1 piece-start + :end1 piece-end) + (dirs :up)) + ((string= namestr "**" + :start1 piece-start + :end1 piece-end) + (dirs :wild-inferiors)) + (t + (dirs (maybe-make-pattern namestr + piece-start + piece-end))))))) + (cond (absolute + (cons :absolute (dirs))) + ((dirs) + (cons :relative (dirs))) + (t + nil))) + name + type + version)))) (/show0 "filesys.lisp 300") @@ -368,17 +325,7 @@ (when directory (ecase (pop directory) (:absolute - (cond ((logical-hostname-p (car directory)) - ;; FIXME: The old CMU CL "search list" extension is - ;; gone, but the old machinery is still being used - ;; clumsily here and elsewhere, to represent anything - ;; which belongs before a colon prefix in the ANSI - ;; pathname machinery. This should be cleaned up, - ;; using simpler machinery with more mnemonic names. - (pieces (logical-hostname-name (pop directory))) - (pieces ":")) - (t - (pieces "/")))) + (pieces "/")) (:relative ;; nothing special )) @@ -829,21 +776,10 @@ t) ;;; (This is an ANSI Common Lisp function.) -;;; -;;; This is obtained from the logical name \"home:\", which is set -;;; up for us at initialization time. (defun user-homedir-pathname (&optional host) "Return the home directory of the user as a pathname." (declare (ignore host)) - ;; Note: CMU CL did #P"home:" here instead of using a call to - ;; PATHNAME. Delaying construction of the pathname until we're - ;; running in a target Lisp lets us avoid figuring out how to dump - ;; cross-compilation host Lisp PATHNAME objects into a target Lisp - ;; object file. It also might have a small positive effect on - ;; efficiency, in that we don't allocate a PATHNAME we don't need, - ;; but it it could also have a larger negative effect. Hopefully - ;; it'll be OK. -- WHN 19990714 - (pathname "home:")) + (pathname (sb!unix:uid-homedir (sb!unix:unix-getuid)))) (defun file-write-date (file) #!+sb-doc diff --git a/src/code/target-pathname.lisp b/src/code/target-pathname.lisp index bf64660..f259f2f 100644 --- a/src/code/target-pathname.lisp +++ b/src/code/target-pathname.lisp @@ -605,6 +605,41 @@ a host-structure or string." ;;;; namestrings +;;; Handle the case for PARSE-NAMESTRING parsing a potentially +;;; syntactically valid logical namestring with an explicit host. +;;; +;;; This then isn't fully general -- we are relying on the fact that +;;; we will only pass to parse-namestring namestring with an explicit +;;; logical host, so that we can pass the host return from +;;; parse-logical-namestring through to %PARSE-NAMESTRING as a truth +;;; value. Yeah, this is probably a KLUDGE - CSR, 2002-04-18 +(defun parseable-logical-namestring-p (namestr start end) + (catch 'exit + (handler-bind + ((namestring-parse-error (lambda (c) + (declare (ignore c)) + (throw 'exit nil)))) + (let ((colon (position #\: namestr :start start :end end))) + (when colon + (let ((potential-host + (logical-word-or-lose (subseq namestr start colon)))) + ;; depending on the outcome of CSR comp.lang.lisp post + ;; "can PARSE-NAMESTRING create logical hosts, we may need + ;; to do things with potential-host (create it + ;; temporarily, parse the namestring and unintern the + ;; logical host potential-host on failure. + (declare (ignore potential-host)) + (let ((result + (handler-bind + ((simple-type-error (lambda (c) + (declare (ignore c)) + (throw 'exit nil)))) + (parse-logical-namestring namestr start end)))) + ;; if we got this far, we should have an explicit host + ;; (first return value of parse-logical-namestring) + (aver result) + result))))))) + ;;; Handle the case where PARSE-NAMESTRING is actually parsing a ;;; namestring. We pick off the :JUNK-ALLOWED case then find a host to ;;; use for parsing, call the parser, then check whether the host matches. @@ -618,16 +653,42 @@ a host-structure or string." (%parse-namestring namestr host defaults start end nil) (namestring-parse-error (condition) (values nil (namestring-parse-error-offset condition)))) - (let* ((end (or end (length namestr))) - (parse-host (or host - (extract-logical-host-prefix namestr start end) - (pathname-host defaults)))) - (unless parse-host - (error "When no HOST argument is supplied, the DEFAULTS argument ~ - must have a non-null PATHNAME-HOST.")) - + (let* ((end (or end (length namestr)))) (multiple-value-bind (new-host device directory file type version) - (funcall (host-parse parse-host) namestr start end) + ;; Comments below are quotes from the HyperSpec + ;; PARSE-NAMESTRING entry, reproduced here to demonstrate + ;; that we actually have to do things this way rather than + ;; some possibly more logical way. - CSR, 2002-04-18 + (cond + ;; "If host is a logical host then thing is parsed as a + ;; logical pathname namestring on the host." + (host (funcall (host-parse host) namestr start end)) + ;; "If host is nil and thing is a syntactically valid + ;; logical pathname namestring containing an explicit + ;; host, then it is parsed as a logical pathname + ;; namestring." + ((parseable-logical-namestring-p namestr start end) + (parse-logical-namestring namestr start end)) + ;; "If host is nil, default-pathname is a logical + ;; pathname, and thing is a syntactically valid logical + ;; pathname namestring without an explicit host, then it + ;; is parsed as a logical pathname namestring on the + ;; host that is the host component of default-pathname." + ;; + ;; "Otherwise, the parsing of thing is + ;; implementation-defined." + ;; + ;; Both clauses are handled here, as the default + ;; *DEFAULT-PATHNAME-DEFAULTS has a SB-IMPL::UNIX-HOST + ;; for a host. + ((pathname-host defaults) + (funcall (host-parse (pathname-host defaults)) namestr start end)) + ;; I don't think we should ever get here, as the default + ;; host will always have a non-null HOST, given that we + ;; can't create a new pathname without going through + ;; *DEFAULT-PATHNAME-DEFAULTS*, which has a non-null + ;; host... + (t (bug "Fallen through COND in %PARSE-NAMESTRING"))) (when (and host new-host (not (eq new-host host))) (error 'simple-type-error :datum new-host @@ -643,7 +704,7 @@ a host-structure or string." "The host in the namestring, ~S,~@ does not match the explicit HOST argument, ~S." :format-arguments (list new-host host))) - (let ((pn-host (or new-host parse-host))) + (let ((pn-host (or new-host host (pathname-host defaults)))) (values (%make-maybe-logical-pathname pn-host device directory file type version) end)))))) diff --git a/src/code/unix.lisp b/src/code/unix.lisp index 0035134..abd35fc 100644 --- a/src/code/unix.lisp +++ b/src/code/unix.lisp @@ -348,6 +348,14 @@ uid)) (error "found no match for Unix uid=~S" uid))) +;;; Return the namestring of the home directory, being careful to +;;; include a trailing #\/ +(defun uid-homedir (uid) + (or (newcharstar-string (alien-funcall (extern-alien "uid_homedir" + (function (* char) int)) + uid)) + (error "failed to resolve home directory for Unix uid=~S" uid))) + ;;; Invoke readlink(2) on the file name specified by PATH. Return ;;; (VALUES LINKSTRING NIL) on success, or (VALUES NIL ERRNO) on ;;; failure. diff --git a/src/runtime/wrap.c b/src/runtime/wrap.c index 49b5c24..a3d8881 100644 --- a/src/runtime/wrap.c +++ b/src/runtime/wrap.c @@ -30,6 +30,7 @@ #include #include #include +#include #include "runtime.h" #include "sbcl.h" @@ -253,6 +254,33 @@ uid_username(int uid) return 0; } } + +char * +uid_homedir(uid_t uid) +{ + struct passwd *p = getpwuid(uid); + if(p) { + /* Let's be careful about this, shall we? */ + size_t len = strlen(p->pw_dir); + if (p->pw_dir[len-1] == '/') { + return strdup(p->pw_dir); + } else { + char *result = malloc(len + 2); + if (result) { + int nchars = sprintf(result,"%s/",p->pw_dir); + if (nchars == len + 1) { + return result; + } else { + return 0; + } + } else { + return 0; + } + } + } else { + return 0; + } +} /* * functions to get miscellaneous C-level variables diff --git a/tests/pathnames.impure.lisp b/tests/pathnames.impure.lisp index b14b99f..c7ee31b 100644 --- a/tests/pathnames.impure.lisp +++ b/tests/pathnames.impure.lisp @@ -111,9 +111,9 @@ ;;; turning one logical pathname into another: (setf (logical-pathname-translations "foo") - '(("tohome;*.*.*" "home:*.*.*"))) -(assert (equal (namestring (translate-logical-pathname "foo:tohome;x.y")) - "home:x.y")) + '(("todemo;*.*.*" "demo0:*.*.*"))) +(assert (equal (namestring (translate-logical-pathname "foo:todemo;x.y")) + (namestring (translate-logical-pathname "demo0:x.y")))) ;;; ANSI, in its wisdom, specifies that it's an error (specifically a ;;; TYPE-ERROR) to query the system about the translations of a string @@ -122,6 +122,9 @@ (let ((cond (grab-condition (logical-pathname-translations "unregistered-host")))) (assert (typep cond 'type-error))) +(assert (not (string-equal (host-namestring (parse-namestring "OTHER-HOST:ILLEGAL/LPN")) "OTHER-HOST"))) +(assert (string-equal (pathname-name (parse-namestring "OTHER-HOST:ILLEGAL/LPN")) "LPN")) + ;;; FIXME: A comment on this section up to sbcl-0.6.11.30 or so said ;;; examples from CLHS: Section 19.4, LOGICAL-PATHNAME-TRANSLATIONS ;;; (sometimes converted to the Un*x way of things) diff --git a/version.lisp-expr b/version.lisp-expr index ff4289f..7f9da57 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -18,4 +18,4 @@ ;;; for internal versions, especially for internal versions off the ;;; main CVS branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.7.2.15" +"0.7.2.16" -- 1.7.10.4