@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
"NANOSLEEP"
"UID-USERNAME"
"UID-HOMEDIR"
+ "USER-HOMEDIR"
"WITH-RESTARTED-SYSCALL"
"SB-MKSTEMP"
*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)))
\f
;;;; DIRECTORY
(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)
((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)))
: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)
(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
;;; 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
(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) #\\)))))
: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)
(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))
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))
}
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] == '/') {
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 */
\f
/*
(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
;;; 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"
projects / sbcl.git / commitdiff