Skip to content
Browse files

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.
  • Loading branch information...
1 parent 110ebca commit 9df2abae0a60d757448f06f0cc90213ec9fa775b @nikodemus nikodemus committed
View
18 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
View
1 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"
View
36 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
View
16 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)
View
32 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)))
View
104 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
View
17 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
View
98 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))
View
8 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))
View
17 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 */
/*
View
25 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
View
2 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"

0 comments on commit 9df2aba

Please sign in to comment.
Something went wrong with that request. Please try again.