From 9df2abae0a60d757448f06f0cc90213ec9fa775b Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Wed, 10 Nov 2010 17:49:30 +0000 Subject: [PATCH] 1.0.44.21: expand ~ in pathnames ~/... => (:ABSOLUTE :HOME ...) ~user/... => (:ABSOLUTE (:HOME "user") ...) Translation back to NAMESTRING reinstates the tilde, so we retain read/write consistency. NATIVE-NAMESTRING is responsible for getting the actual full path to specified home directory. This late resolution is necessary to have (open "~/foo") and (open #p"~/foo") open the same file in compiled code -- regardless of who compiled the file. Tilde is treated specially only at the start of the first directory component: it doesn't need to be escaped anywhere else. After trying out the various options (escape everywhere, escape in directory components, escape at the start of directory components, escape at the start of all components) this seemed both least intrusive and least ambiguous when documented -- not to mention most backwards compatible. Currently escaping the tilde does not work on Windows, but this is due to current general inability to escape the first directory component on Windows, since \\ is used also as a directory separator for non-native pathnames as well. See lp#673625. Test-case added for this. (:HOME "user") also doesn't work on Windows, which is documented in the manual. --- doc/manual/pathnames.texinfo | 18 +++++++ package-data-list.lisp-expr | 1 + src/code/filesys.lisp | 36 +++++++------- src/code/pathname.lisp | 16 ++++++- src/code/target-pathname.lisp | 32 ++++++++----- src/code/unix-pathname.lisp | 104 +++++++++++++++++++++++++++-------------- src/code/unix.lisp | 17 +++++-- src/code/win32-pathname.lisp | 98 +++++++++++++++++++++++++------------- src/code/win32.lisp | 8 ++-- src/runtime/wrap.c | 17 +++++-- tests/pathnames.impure.lisp | 25 ++++++++++ version.lisp-expr | 2 +- 12 files changed, 264 insertions(+), 110 deletions(-) diff --git a/doc/manual/pathnames.texinfo b/doc/manual/pathnames.texinfo index f3bf30f..50c3260 100644 --- a/doc/manual/pathnames.texinfo +++ b/doc/manual/pathnames.texinfo @@ -70,6 +70,24 @@ implementation-defined and so need documentation. @c * Other symbols and integers have implementation-defined meaning. @c (19.2.2.4.6) +@subsection Home Directory Specifiers + +SBCL accepts the keyword @code{:home} and a list of the form +@code{(:home "username")} as a directory component immediately +following @code{:absolute}. + +@code{:home} is represented in namestrings by @code{~/} and +@code{(:home "username"} by @code{~username/} at the start of the +namestring. Tilde-characters elsewhere in namestrings represent +themselves. + +Home directory specifiers are resolved to home directory of the +current or specified user by @code{native-namestring}, which is used +by the implementation to translate pathnames before passing them on to +operating system specific routines. + +Using @code{(:home "user")} form on Windows signals an error. + @subsection The SYS Logical Pathname Host @cindex Logical pathnames diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index cd9b6a2..43b7dec 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -2349,6 +2349,7 @@ no guarantees of interface stability." "NANOSLEEP" "UID-USERNAME" "UID-HOMEDIR" + "USER-HOMEDIR" "WITH-RESTARTED-SYSCALL" "SB-MKSTEMP" diff --git a/src/code/filesys.lisp b/src/code/filesys.lisp index a0d844e..d1933d6 100644 --- a/src/code/filesys.lisp +++ b/src/code/filesys.lisp @@ -542,30 +542,32 @@ Experimental: interface subject to change." *default-pathname-defaults* :as-directory t)))) +(defun user-homedir-namestring (&optional username) + (if username + (sb!unix:user-homedir username) + (let ((env-home (posix-getenv "HOME"))) + (if (and env-home (not (string= env-home ""))) + env-home + #!-win32 + (sb!unix:uid-homedir (sb!unix:unix-getuid)))))) + ;;; (This is an ANSI Common Lisp function.) (defun user-homedir-pathname (&optional host) #!+sb-doc "Return the home directory of the user as a pathname. If the HOME environment variable has been specified, the directory it designates is returned; otherwise obtains the home directory from the operating -system." +system. HOST argument is ignored by SBCL." (declare (ignore host)) - (let ((env-home (posix-getenv "HOME"))) - (values - (parse-native-namestring - (if (and env-home (not (string= env-home ""))) - env-home - #!-win32 - (sb!unix:uid-homedir (sb!unix:unix-getuid)) - #!+win32 - ;; Needs to bypass PARSE-NATIVE-NAMESTRING & ENSURE-TRAILING-SLASH - ;; What?! -- RMK, 2007-12-31 - (return-from user-homedir-pathname - (sb!win32::get-folder-pathname sb!win32::csidl_profile))) - #!-win32 sb!impl::*unix-host* - #!+win32 sb!impl::*win32-host* - *default-pathname-defaults* - :as-directory t)))) + (values + (parse-native-namestring + (or (user-homedir-namestring) + #!+win32 + (sb!win32::get-folder-namestring sb!win32::csidl_profile)) + #!-win32 sb!impl::*unix-host* + #!+win32 sb!impl::*win32-host* + *default-pathname-defaults* + :as-directory t))) ;;;; DIRECTORY diff --git a/src/code/pathname.lisp b/src/code/pathname.lisp index 7f9d4cf..bd0471f 100644 --- a/src/code/pathname.lisp +++ b/src/code/pathname.lisp @@ -141,8 +141,20 @@ (when directory (ecase (pop directory) (:absolute - (pieces "/")) - (:relative)) + (let ((next (pop directory))) + (cond ((eq :home next) + (pieces "~")) + ((and (consp next) (eq :home (car next))) + (pieces "~") + (pieces (second next))) + ((and (plusp (length next)) (char= #\~ (char next 0))) + ;; The only place we need to escape the tilde. + (pieces "\\") + (pieces next)) + (next + (push next directory))) + (pieces "/"))) + (:relative)) (dolist (dir directory) (typecase dir ((member :up) diff --git a/src/code/target-pathname.lisp b/src/code/target-pathname.lisp index 196f50a..52e81dc 100644 --- a/src/code/target-pathname.lisp +++ b/src/code/target-pathname.lisp @@ -515,17 +515,27 @@ the operating system native pathname conventions." ((member :unspecific) '(:relative)) (list (collect ((results)) - (results (pop directory)) - (dolist (piece directory) - (cond ((member piece '(:wild :wild-inferiors :up :back)) - (results piece)) - ((or (simple-string-p piece) (pattern-p piece)) - (results (maybe-diddle-case piece diddle-case))) - ((stringp piece) - (results (maybe-diddle-case (coerce piece 'simple-string) - diddle-case))) - (t - (error "~S is not allowed as a directory component." piece)))) + (let ((root (pop directory))) + (if (member root '(:relative :absolute)) + (results root) + (error "List of directory components must start with ~S or ~S." + :absolute :relative))) + (when directory + (let ((next (pop directory))) + (if (or (eq :home next) + (typep next '(cons (eql :home) (cons string null)))) + (results next) + (push next directory))) + (dolist (piece directory) + (cond ((member piece '(:wild :wild-inferiors :up :back)) + (results piece)) + ((or (simple-string-p piece) (pattern-p piece)) + (results (maybe-diddle-case piece diddle-case))) + ((stringp piece) + (results (maybe-diddle-case (coerce piece 'simple-string) + diddle-case))) + (t + (error "~S is not allowed as a directory component." piece))))) (results))) (simple-string `(:absolute ,(maybe-diddle-case directory diddle-case))) diff --git a/src/code/unix-pathname.lisp b/src/code/unix-pathname.lisp index 05c8307..7393052 100644 --- a/src/code/unix-pathname.lisp +++ b/src/code/unix-pathname.lisp @@ -55,35 +55,53 @@ :complaint "can't embed #\\Nul or #\\/ in Unix namestring" :namestring namestring :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= namestring ".." - :start1 piece-start - :end1 piece-end) - (dirs :up)) - ((string= namestring "**" - :start1 piece-start - :end1 piece-end) - (dirs :wild-inferiors)) - (t - (dirs (maybe-make-pattern namestring - piece-start - piece-end))))))) - (cond (absolute - (cons :absolute (dirs))) - ((dirs) - (cons :relative (dirs))) - (t - nil))) - name - type - version)))) + + (let (home) + ;; Deal with ~ and ~user + (when (car pieces) + (destructuring-bind (start . end) (car pieces) + (when (and (not absolute) + (not (eql start end)) + (string= namestring "~" + :start1 start + :end1 (1+ start))) + (setf absolute t) + (if (> end (1+ start)) + (setf home (list :home (subseq namestring (1+ start) end))) + (setf home :home)) + (pop pieces)))) + + ;; 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= namestring ".." + :start1 piece-start + :end1 piece-end) + (dirs :up)) + ((string= namestring "**" + :start1 piece-start + :end1 piece-end) + (dirs :wild-inferiors)) + (t + (dirs (maybe-make-pattern namestring + piece-start + piece-end))))))) + (cond (absolute + (if home + (list* :absolute home (dirs)) + (cons :absolute (dirs)))) + ((dirs) + (cons :relative (dirs))) + (t + nil))) + name + type + version))))) (defun parse-native-unix-namestring (namestring start end as-directory) (declare (type simple-string namestring) @@ -183,15 +201,29 @@ (coerce (with-output-to-string (s) (when directory - (ecase (car directory) - (:absolute (write-char #\/ s)) + (ecase (pop directory) + (:absolute + (let ((next (pop directory))) + (cond ((eq :home next) + (write-string (user-homedir-namestring) s)) + ((and (consp next) (eq :home (car next))) + (let ((where (user-homedir-namestring (second next)))) + (if where + (write-string where s) + (error "User homedir unknown for: ~S" (second next))))) + (next + (push next directory))) + (write-char #\/ s))) (:relative))) - (loop for (piece . subdirs) on (cdr directory) + (loop for (piece . subdirs) on directory do (typecase piece - ((member :up) (write-string ".." s)) - (string (write-string piece s)) - (t (error "ungood directory segment in NATIVE-NAMESTRING: ~S" - piece))) + ((member :up) + (write-string ".." s)) + (string + (write-string piece s)) + (t + (error "ungood directory segment in NATIVE-NAMESTRING: ~S" + piece))) if (or subdirs (stringp name)) do (write-char #\/ s) else diff --git a/src/code/unix.lisp b/src/code/unix.lisp index ae5875f..cddbca0 100644 --- a/src/code/unix.lisp +++ b/src/code/unix.lisp @@ -446,11 +446,18 @@ corresponds to NAME, or NIL if there is none." ;;; Return the namestring of the home directory, being careful to ;;; include a trailing #\/ #!-win32 -(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))) +(progn + (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))) + + (defun user-homedir (uid) + (or (newcharstar-string (alien-funcall (extern-alien "user_homedir" + (function (* char) c-string)) + 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 diff --git a/src/code/win32-pathname.lisp b/src/code/win32-pathname.lisp index 38cc6f0..5c0f9a5 100644 --- a/src/code/win32-pathname.lisp +++ b/src/code/win32-pathname.lisp @@ -39,6 +39,11 @@ (defun split-at-slashes-and-backslashes (namestr start end) (declare (type simple-string namestr) (type index start end)) + ;; FIXME: There is a fundamental brokenness in using the same + ;; character as escape character and directory separator in + ;; non-native pathnames. (PATHNAME-DIRECTORY #P"\\*/") should + ;; probably be (:RELATIVE "*") everywhere, but on Windows it's + ;; (:ABSOLUTE :WILD)! See lp#673625. (let ((absolute (and (/= start end) (or (char= (schar namestr start) #\/) (char= (schar namestr start) #\\))))) @@ -83,35 +88,53 @@ :complaint "can't embed #\\Nul or #\\/ in Unix namestring" :namestring namestring :offset position)))) - ;; Now we have everything we want. So return it. - (values nil ; no host for Win32 namestrings - device - (collect ((dirs)) - (dolist (piece pieces) - (let ((piece-start (car piece)) - (piece-end (cdr piece))) - (unless (= piece-start piece-end) - (cond ((string= namestring ".." - :start1 piece-start - :end1 piece-end) - (dirs :up)) - ((string= namestring "**" - :start1 piece-start - :end1 piece-end) - (dirs :wild-inferiors)) - (t - (dirs (maybe-make-pattern namestring - piece-start - piece-end))))))) - (cond (absolute - (cons :absolute (dirs))) - ((dirs) - (cons :relative (dirs))) - (t - nil))) - name - type - version))))) + + (let (home) + ;; Deal with ~ and ~user. + (when (car pieces) + (destructuring-bind (start . end) (car pieces) + (when (and (not absolute) + (not (eql start end)) + (string= namestring "~" + :start1 start + :end1 (1+ start))) + (setf absolute t) + (if (> end (1+ start)) + (setf home (list :home (subseq namestring (1+ start) end))) + (setf home :home)) + (pop pieces)))) + + ;; Now we have everything we want. So return it. + (values nil ; no host for Win32 namestrings + device + (collect ((dirs)) + (dolist (piece pieces) + (let ((piece-start (car piece)) + (piece-end (cdr piece))) + (unless (= piece-start piece-end) + (cond ((string= namestring ".." + :start1 piece-start + :end1 piece-end) + (dirs :up)) + ((string= namestring "**" + :start1 piece-start + :end1 piece-end) + (dirs :wild-inferiors)) + (t + (dirs (maybe-make-pattern namestring + piece-start + piece-end))))))) + (cond (absolute + (if home + (list* :absolute home (dirs)) + (cons :absolute (dirs)))) + ((dirs) + (cons :relative (dirs))) + (t + nil))) + name + type + version)))))) (defun parse-native-win32-namestring (namestring start end as-directory) (declare (type simple-string namestring) @@ -227,10 +250,21 @@ (when device (write-string (unparse-win32-device pathname t) s)) (when directory - (ecase (car directory) - (:absolute (write-char #\\ s)) + (ecase (pop directory) + (:absolute + (let ((next (pop directory))) + (cond ((eq :home next) + (write-string (user-homedir-namestring) s)) + ((and (consp next) (eq :home (car next))) + (let ((where (user-homedir-namestring (second next)))) + (if where + (write-string where s) + (error "User homedir unknown for: ~S" (second next))))) + (next + (push next directory))) + (write-char #\\ s))) (:relative))) - (loop for (piece . subdirs) on (cdr directory) + (loop for (piece . subdirs) on directory do (typecase piece ((member :up) (write-string ".." s)) (string (write-string piece s)) diff --git a/src/code/win32.lisp b/src/code/win32.lisp index 37696c3..c970412 100644 --- a/src/code/win32.lisp +++ b/src/code/win32.lisp @@ -432,14 +432,16 @@ err-code (get-last-error-message err-code)))) -(defun get-folder-pathname (csidl) +(defun get-folder-namestring (csidl) "http://msdn.microsoft.com/library/en-us/shellcc/platform/shell/reference/functions/shgetfolderpath.asp" (with-alien ((apath (* char) (make-system-buffer (1+ max_path)))) (syscall (("SHGetFolderPath" 20 t) int handle int handle dword (* char)) - (parse-native-namestring - (concatenate 'string (cast-and-free apath) "\\")) + (concatenate 'string (cast-and-free apath) "\\") 0 csidl 0 0 apath))) +(defun get-folder-pathname (csidl) + (parse-native-namestring (get-folder-namestring csidl))) + (defun sb!unix:posix-getcwd () (with-alien ((apath (* char) (make-system-buffer (1+ max_path)))) (with-sysfun (afunc ("GetCurrentDirectory" 8 t) dword dword (* char)) diff --git a/src/runtime/wrap.c b/src/runtime/wrap.c index 8493bf6..c17b0f1 100644 --- a/src/runtime/wrap.c +++ b/src/runtime/wrap.c @@ -317,10 +317,9 @@ uid_username(int uid) } char * -uid_homedir(uid_t uid) +passwd_homedir(struct passwd *p) { - struct passwd *p = getpwuid(uid); - if(p) { + if (p) { /* Let's be careful about this, shall we? */ size_t len = strlen(p->pw_dir); if (p->pw_dir[len-1] == '/') { @@ -342,6 +341,18 @@ uid_homedir(uid_t uid) return 0; } } + +char * +user_homedir(char *name) +{ + return passwd_homedir(getpwnam(name)); +} + +char * +uid_homedir(uid_t uid) +{ + return passwd_homedir(getpwuid(uid)); +} #endif /* !LISP_FEATURE_WIN32 */ /* diff --git a/tests/pathnames.impure.lisp b/tests/pathnames.impure.lisp index 7f8f065..7246924 100644 --- a/tests/pathnames.impure.lisp +++ b/tests/pathnames.impure.lisp @@ -568,4 +568,29 @@ (ignore-errors (delete-file bar)) (setf (logical-pathname-translations "SYS") translations)))) +(with-test (:name :tilde-expansion) + (assert (equal '(:absolute :home "foo") (pathname-directory "~/foo/bar.txt"))) + (assert (equal '(:absolute (:home "jdoe") "quux") (pathname-directory "~jdoe/quux/"))) + (assert (equal "~/foo/x" (namestring (make-pathname :directory '(:absolute :home "foo") + :name "x")))) + (assert (equal (native-namestring (merge-pathnames "a/b.c" (user-homedir-pathname))) + (native-namestring #p"~/a/b.c"))) + ;; Not a directory. + (assert (equal (native-namestring #p"~foo") "~foo")) + ;; Not at the start of the first directory + (assert (equal (native-namestring #p"foo/~/bar") + #-win32 "foo/~/bar" + #+win32 "foo\\~\\bar"))) + +;;; lp#673625 +(with-test (:name :pathname-escape-first-directory-component + :fails-on :win32) + ;; ~ / :HOME + (assert (equal (pathname-directory #p"\\~/foo/") '(:relative "~" "foo"))) + (assert (equal (native-namestring #p"\\~/foo/") "~/foo/")) + (assert (equal (namestring (make-pathname :directory '(:absolute "~zot"))) + "\\~zot/")) + ;; * / :WILD + (assert (equal (pathname-directory #p"\\*/") '(:relative "*")))) + ;;;; success diff --git a/version.lisp-expr b/version.lisp-expr index 08d4db6..348bbc3 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.44.20" +"1.0.44.21" -- 1.7.10.4