From 8a632c14b592472873cfb214239c9387bc1a1ced Mon Sep 17 00:00:00 2001 From: Richard M Kreuter Date: Mon, 31 Dec 2007 18:39:23 +0000 Subject: [PATCH] 1.0.13.4: Removing UNIX-NAMESTRING, part 4 * PROBE-FILE, TRUENAME, FILE-WRITE-DATE, FILE-AUTHOR rewritten. Truenames now 78% more truthful. --- package-data-list.lisp-expr | 5 +- src/code/filesys.lisp | 235 ++++++++++++++++++++++++++++----------- src/code/pathname.lisp | 2 - src/code/unix.lisp | 83 +++----------- src/runtime/wrap.c | 37 ++++++ tools-for-build/grovel-headers.c | 1 + tools-for-build/ldso-stubs.lisp | 1 + version.lisp-expr | 2 +- 8 files changed, 229 insertions(+), 137 deletions(-) diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index dd90ecc6c..24d4e262a 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -2163,8 +2163,9 @@ no guarantees of interface stability." "UNIX-GETTIMEOFDAY" "UNIX-GETUID" "UNIX-GID" "UNIX-IOCTL" "UNIX-ISATTY" "UNIX-LSEEK" "UNIX-LSTAT" "UNIX-MKDIR" "UNIX-MKSTEMP" "UNIX-OPEN" "UNIX-PATHNAME" "UNIX-PID" - "UNIX-PIPE" "UNIX-READ" "UNIX-READLINK" "UNIX-RENAME" - "UNIX-SELECT" "UNIX-STAT" "UNIX-UID" "UNIX-UNLINK" "UNIX-WRITE" + "UNIX-PIPE" "UNIX-READ" "UNIX-READLINK" "UNIX-REALPATH" + "UNIX-RENAME" "UNIX-SELECT" "UNIX-STAT" "UNIX-UID" + "UNIX-UNLINK" "UNIX-WRITE" "WINSIZE" "WRITEGRP" "WRITEOTH" "WRITEOWN" "WS-COL" "WS-ROW" "WS-XPIXEL" "WS-YPIXEL" "WNOHANG" "WSTOPPED" "WUNTRACED" "W_OK" "X_OK" diff --git a/src/code/filesys.lisp b/src/code/filesys.lisp index b166710c4..04e6503e4 100644 --- a/src/code/filesys.lisp +++ b/src/code/filesys.lisp @@ -476,45 +476,183 @@ (1 (first matches)) (t (bug "!ENUMERATE-MATCHES returned more than one match on a non-wild pathname"))))) -;;;; TRUENAME and PROBE-FILE +;;;; TRUENAME, PROBE-FILE, FILE-AUTHOR, FILE-WRITE-DATE. -;;; This is only trivially different from PROBE-FILE, which is silly -;;; but ANSI. -(defun truename (pathname) - #!+sb-doc - "Return the pathname for the actual file described by PATHNAME. -An error of type FILE-ERROR is signalled if no such file exists, or the -pathname is wild. - -Under Unix, the TRUENAME of a broken symlink is considered to be the name of -the broken symlink itself." - (let ((result (probe-file pathname))) - (unless result +;;; Rewritten in 12/2007 by RMK, replacing 13+ year old CMU code that +;;; made a mess of things in order to support search lists (which SBCL +;;; has never had). These are now all relatively straightforward +;;; wrappers around stat(2) and realpath(2), with the same basic logic +;;; in all cases. The wrinkles to be aware of: +;;; +;;; * SBCL defines the truename of an existing, dangling or +;;; self-referring symlink to be the symlink itself. +;;; * The old version of PROBE-FILE merged the pathspec against +;;; *DEFAULT-PATHNAME-DEFAULTS* twice, and so lost when *D-P-D* +;;; was a relative pathname. Even if the case where *D-P-D* is a +;;; relative pathname is problematic, there's no particular reason +;;; to get that wrong, so let's try not to. +;;; * Note that while stat(2) is probably atomic, getting the truename +;;; for a filename involves poking all over the place, and so is +;;; subject to race conditions if other programs mutate the file +;;; system while we're resolving symlinks. So it's not implausible for +;;; realpath(3) to fail even if stat(2) succeeded. There's nothing +;;; obvious we can do about this, however. +;;; * Windows' apparent analogue of realpath(3) is called +;;; GetFullPathName, and it's a bit less useful than realpath(3). +;;; In particular, while realpath(3) errors in case the file doesn't +;;; exist, GetFullPathName seems to return a filename in all cases. +;;; As realpath(3) is not atomic anyway, we only ever call it when +;;; we think a file exists, so just be careful when rewriting this +;;; routine. +(defun query-file-system (pathspec query-for enoent-errorp) + (let ((pathname (translate-logical-pathname + (merge-pathnames + (pathname pathspec) + (sane-default-pathname-defaults))))) + (when (wild-pathname-p pathname) (error 'simple-file-error :pathname pathname - :format-control "The file ~S does not exist." - :format-arguments (list (namestring pathname)))) - result)) + :format-control "~@" + :format-arguments (list query-for pathname pathspec))) + (let ((filename (native-namestring pathname :as-file t))) + (multiple-value-bind (existsp errno ino mode nlink uid gid rdev size + atime mtime) + (sb!unix:unix-stat filename) + (declare (ignore ino nlink gid rdev size atime)) + (if existsp + (case query-for + (:truename (parse-native-namestring + ;; Note: in case the file is stat'able, POSIX + ;; realpath(3) gets us a canonical absolute + ;; filename, even if the post-merge PATHNAME + ;; is not absolute... + (multiple-value-bind (realpath errno) + (sb!unix:unix-realpath filename) + (if realpath + realpath + (simple-file-perror "couldn't resolve ~A" + filename errno))) + (pathname-host pathname) + (sane-default-pathname-defaults) + ;; ... but without any trailing slash. + :as-directory (eql (logand mode sb!unix:s-ifmt) + sb!unix:s-ifdir))) + (:author (sb!unix:uid-username uid)) + (:write-date (+ unix-to-universal-time mtime))) + (progn + ;; SBCL has for many years had a policy that a pathname + ;; that names an existing, dangling or self-referential + ;; symlink denotes the symlink itself. stat(2) fails + ;; and sets errno to ELOOP in this case, but we must + ;; distinguish cases where the symlink exists from ones + ;; where there's a loop in the apparent containing + ;; directory. + #!-win32 + (multiple-value-bind (linkp ignore ino mode nlink uid gid rdev + size atime mtime) + (sb!unix:unix-lstat filename) + (declare (ignore ignore ino mode nlink gid rdev size atime)) + (when (and (or (= errno sb!unix:enoent) + (= errno sb!unix:eloop)) + linkp) + (return-from query-file-system + (case query-for + (:truename + ;; So here's a trick: since lstat succeded, + ;; FILENAME exists, so its directory exists and + ;; only the non-directory part is loopy. So + ;; let's resolve FILENAME's directory part with + ;; realpath(3), in order to get a canonical + ;; absolute name for the directory, and then + ;; return a pathname having PATHNAME's name, + ;; type, and version, but the rest from the + ;; truename of the directory. Since we turned + ;; PATHNAME into FILENAME "as a file", FILENAME + ;; does not end in a slash, and so we get the + ;; directory part of FILENAME by reparsing + ;; FILENAME and masking off its name, type, and + ;; version bits. But note not to call ourselves + ;; recursively, because we don't want to + ;; re-merge against *DEFAULT-PATHNAME-DEFAULTS*, + ;; since PATHNAME may be a relative pathname. + (merge-pathnames + (parse-native-namestring + (multiple-value-bind (realpath errno) + (sb!unix:unix-realpath + (native-namestring + (make-pathname + :name :unspecific + :type :unspecific + :version :unspecific + :defaults (parse-native-namestring + filename + (pathname-host pathname) + (sane-default-pathname-defaults))))) + (if realpath + realpath + (simple-file-perror "couldn't resolve ~A" + filename errno))) + (pathname-host pathname) + (sane-default-pathname-defaults) + :as-directory t) + pathname)) + (:author (sb!unix:uid-username uid)) + (:write-date (+ unix-to-universal-time mtime)))))) + ;; If we're still here, the file doesn't exist; return + ;; NIL or error. + (if (and (= errno sb!unix:enoent) (not enoent-errorp)) + nil + (simple-file-perror + (format nil "failed to find the ~A of ~~A" query-for) + pathspec errno)))))))) + + +(defun probe-file (pathspec) + #!+sb-doc + "Return the truename of PATHSPEC if such a file exists, the +coercion of PATHSPEC to a pathname if PATHSPEC names a symlink +that links to itself or to a file that doesn't exist, or NIL if +errno is set to ENOENT after trying to stat(2) the file. An +error of type FILE-ERROR is signaled if PATHSPEC is a wild +pathname, or for any other circumstance where stat(2) fails." + (query-file-system pathspec :truename nil)) + + +(defun truename (pathspec) + #!+sb-doc + "If PATHSPEC is a pathname that names an existing file, return +a pathname that denotes a canonicalized name for the file. If +pathspec is a stream associated with a file, return a pathname +that denotes a canonicalized name for the file associated with +the stream. + +An error of type FILE-ERROR is signalled if no such file exists +or if the file system is such that a canonicalized file name +cannot be determined or if the pathname is wild. + +Under Unix, the TRUENAME of a symlink that links to itself or to +a file that doesn't exist is considered to be the name of the +broken symlink itself." + ;; Note that eventually this routine might be different for streams + ;; than for other pathname designators. + (if (streamp pathspec) + (query-file-system pathspec :truename t) + (query-file-system pathspec :truename t))) + +(defun file-author (pathspec) + #!+sb-doc + "Return the author of the file specified by PATHSPEC. Signal an +error of type FILE-ERROR if no such file exists, or if PATHSPEC +is a wild pathname." + (query-file-system pathspec :write-date t)) -(defun probe-file (pathname) +(defun file-write-date (pathspec) #!+sb-doc - "Return a pathname which is the truename of the file if it exists, or NIL -otherwise. An error of type FILE-ERROR is signaled if pathname is wild." - (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 t)) - (let ((trueishname (sb!unix:unix-resolve-links namestring))) - (when trueishname - (let* ((*ignore-wildcards* t) - (name (simplify-namestring - trueishname - (pathname-host defaulted-pathname)))) - (if (eq (sb!unix:unix-file-kind name) :directory) - ;; FIXME: this might work, but it's ugly. - (pathname (concatenate 'string name "/")) - (pathname name)))))))) + "Return the write date of the file specified by PATHSPEC. +An error of type FILE-ERROR is signaled if no such file exists, +or if PATHSPEC is a wild pathname." + (query-file-system pathspec :write-date t)) ;;;; miscellaneous other operations @@ -595,35 +733,6 @@ system." ;; Needs to bypass PARSE-NATIVE-NAMESTRING & ENSURE-TRAILING-SLASH (return-from user-homedir-pathname (sb!win32::get-folder-pathname sb!win32::csidl_profile))))))) - -(defun file-write-date (file) - #!+sb-doc - "Return file's creation date, or NIL if it doesn't exist. - An error of type file-error is signaled if file is a wild pathname" - (let ((name (unix-namestring file t))) - (when name - (multiple-value-bind - (res dev ino mode nlink uid gid rdev size atime mtime) - (sb!unix:unix-stat name) - (declare (ignore dev ino mode nlink uid gid rdev size atime)) - (when res - (+ unix-to-universal-time mtime)))))) - -(defun file-author (file) - #!+sb-doc - "Return the file author as a string, or NIL if the author cannot be - determined. Signal an error of type FILE-ERROR if FILE doesn't exist, - or FILE is a wild pathname." - (let ((name (unix-namestring (pathname file) t))) - (unless name - (error 'simple-file-error - :pathname file - :format-control "~S doesn't exist." - :format-arguments (list file))) - (multiple-value-bind (winp dev ino mode nlink uid) - (sb!unix:unix-stat name) - (declare (ignore dev ino mode nlink)) - (and winp (sb!unix:uid-username uid))))) ;;;; DIRECTORY diff --git a/src/code/pathname.lisp b/src/code/pathname.lisp index 542aa094c..cea8b1381 100644 --- a/src/code/pathname.lisp +++ b/src/code/pathname.lisp @@ -26,7 +26,6 @@ (unparse-file (missing-arg) :type function) (unparse-enough (missing-arg) :type function) (unparse-directory-separator (missing-arg) :type simple-string) - (simplify-namestring (missing-arg) :type function) (customary-case (missing-arg) :type (member :upper :lower))) (def!method print-object ((host host) stream) @@ -52,7 +51,6 @@ (unparse-file #'unparse-logical-file) (unparse-enough #'unparse-enough-namestring) (unparse-directory-separator ";") - (simplify-namestring #'identity) (customary-case :upper))) (name "" :type simple-string) (translations nil :type list) diff --git a/src/code/unix.lisp b/src/code/unix.lisp index f23ea2837..e3a4ba27e 100644 --- a/src/code/unix.lisp +++ b/src/code/unix.lisp @@ -463,6 +463,20 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." (declare (ignore path)) nil) +(defun unix-realpath (path) + (declare (type unix-pathname path)) + (with-alien ((ptr (* char) + (alien-funcall (extern-alien + "sb_realpath" + (function (* char) c-string)) + path))) + (if (null-alien ptr) + (values nil (get-errno)) + (multiple-value-prog1 + (values (with-alien ((c-string c-string ptr)) c-string) + nil) + (free-alien ptr))))) + ;;; UNIX-UNLINK accepts a name and deletes the directory entry for that ;;; name and the file if this is the last link. (defun unix-unlink (name) @@ -938,76 +952,7 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." #!-win32 ((eql kind s-iflnk) :link) (t :special)))))) - -;;; Is the Unix pathname PATHNAME relative, instead of absolute? (E.g. -;;; "passwd" or "etc/passwd" instead of "/etc/passwd"?) -(defun relative-unix-pathname? (pathname) - (declare (type simple-string pathname)) - (or (zerop (length pathname)) - (char/= (schar pathname 0) #\/))) - -;;; Return PATHNAME with all symbolic links resolved. PATHNAME should -;;; already be a complete absolute Unix pathname, since at least in -;;; sbcl-0.6.12.36 we're called only from TRUENAME, and only after -;;; paths have been converted to absolute paths, so we don't need to -;;; try to handle any more generality than that. -(defun unix-resolve-links (pathname) - (declare (type simple-string pathname)) - ;; KLUDGE: The Win32 platform doesn't have symbolic links, so - ;; short-cut this computation (and the check for being an absolute - ;; unix pathname...) - #!+win32 (return-from unix-resolve-links pathname) - (aver (not (relative-unix-pathname? pathname))) - ;; KLUDGE: readlink and lstat are unreliable if given symlinks - ;; ending in slashes -- fix the issue here instead of waiting for - ;; libc to change... - ;; - ;; but be careful! Must not strip the final slash from "/". (This - ;; adjustment might be a candidate for being transferred into the C - ;; code in a wrap_readlink() function, too.) CSR, 2006-01-18 - (let ((len (length pathname))) - (when (and (> len 1) (eql #\/ (schar pathname (1- len)))) - (setf pathname (subseq pathname 0 (1- len))))) - (/noshow "entering UNIX-RESOLVE-LINKS") - (loop with previous-pathnames = nil do - (/noshow pathname previous-pathnames) - (let ((link (unix-readlink pathname))) - (/noshow link) - ;; Unlike the old CMU CL code, we handle a broken symlink by - ;; returning the link itself. That way, CL:TRUENAME on a - ;; broken link returns the link itself, so that CL:DIRECTORY - ;; can return broken links, so that even without - ;; Unix-specific extensions to do interesting things with - ;; them, at least Lisp programs can see them and, if - ;; necessary, delete them. (This is handy e.g. when your - ;; managed-by-Lisp directories are visited by Emacs, which - ;; creates broken links as notes to itself.) - (if (null link) - (return pathname) - (let ((new-pathname - (simplify-namestring - (if (relative-unix-pathname? link) - (let* ((dir-len (1+ (position #\/ - pathname - :from-end t))) - (dir (subseq pathname 0 dir-len))) - (/noshow dir) - (concatenate 'string dir link)) - link)))) - (if (unix-file-kind new-pathname) - (setf pathname new-pathname) - (return pathname))))) - ;; To generalize the principle that even if portable Lisp code - ;; can't do anything interesting with a broken symlink, at - ;; least it should be able to see and delete it, when we - ;; detect a cyclic link, we return the link itself. (So even - ;; though portable Lisp code can't do anything interesting - ;; with a cyclic link, at least it can see it and delete it.) - (if (member pathname previous-pathnames :test #'string=) - (return pathname) - (push pathname previous-pathnames)))) - (defconstant micro-seconds-per-internal-time-unit (/ 1000000 sb!xc:internal-time-units-per-second)) diff --git a/src/runtime/wrap.c b/src/runtime/wrap.c index af8b30ee8..a51070217 100644 --- a/src/runtime/wrap.c +++ b/src/runtime/wrap.c @@ -32,6 +32,8 @@ #include #include #include +#include +#include #ifndef LISP_FEATURE_WIN32 #include #include @@ -158,6 +160,41 @@ wrapped_readlink(char *path) #endif /* + * realpath(3), including a wrapper for Windows. + */ +char * sb_realpath (char *path) +{ +#ifndef LISP_FEATURE_WIN32 + char *ret; + int errnum; + + if ((ret = calloc(PATH_MAX, sizeof(char))) == NULL) + return NULL; + if (realpath(path, ret) == NULL) { + errnum = errno; + free(ret); + errno = errnum; + return NULL; + } + return(ret); +#else + char *ret; + char *cp; + int errnum; + + if ((ret = calloc(MAX_PATH, sizeof(char))) == NULL) + return NULL; + if (GetFullPathName(path, MAX_PATH, ret, cp) == 0) { + errnum = errno; + free(ret); + errno = errnum; + return NULL; + } + return(ret); +#endif +} + +/* * stat(2) stuff */ diff --git a/tools-for-build/grovel-headers.c b/tools-for-build/grovel-headers.c index ae6a1bfaa..43ce773f6 100644 --- a/tools-for-build/grovel-headers.c +++ b/tools-for-build/grovel-headers.c @@ -308,6 +308,7 @@ main(int argc, char *argv[]) deferrno("eintr", EINTR); deferrno("eio", EIO); deferrno("eexist", EEXIST); + deferrno("eloop", ELOOP); deferrno("espipe", ESPIPE); deferrno("ewouldblock", EWOULDBLOCK); printf("\n"); diff --git a/tools-for-build/ldso-stubs.lisp b/tools-for-build/ldso-stubs.lisp index ef0c94680..5df857a06 100644 --- a/tools-for-build/ldso-stubs.lisp +++ b/tools-for-build/ldso-stubs.lisp @@ -246,6 +246,7 @@ ldso_stub__ ## fct: ; \\ "read" "readdir" "readlink" + "realpath" "recv" "rename" "rmdir" diff --git a/version.lisp-expr b/version.lisp-expr index 4f6b09b79..55eeb3164 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"1.0.13.3" +"1.0.13.4" -- 2.11.4.GIT