(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
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.
sbcl-0.7.0, available as a patch against sbcl-0.7.0 at
<http://designix.com.au/brian/SBCL/sbcl-0.7.0-unicode.p0.gz>.
* 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
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"
(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")
(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
))
t)
\f
;;; (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
\f
;;;; 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.
(%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
"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))))))
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.
#include <string.h>
#include <unistd.h>
#include <pwd.h>
+#include <stdio.h>
#include "runtime.h"
#include "sbcl.h"
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;
+ }
+}
\f
/*
* functions to get miscellaneous C-level variables
;;; 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
(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)
;;; 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"
projects / sbcl.git / commitdiff