Skip to content
Snippets Groups Projects
Commit 81f0d53c authored by Raymond Toy's avatar Raymond Toy
Browse files

Merge branch 'issue-266-b-tilde-pathname-support' into 'master'

Fix #266: Support ~user in namestrings

Closes #266

See merge request cmucl/cmucl!180
parents 8e067da9 bc8cb405
No related branches found
No related tags found
No related merge requests found
...@@ -2074,7 +2074,7 @@ ...@@ -2074,7 +2074,7 @@
"FD-STREAM-P" "FIND-IF-IN-CLOSURE" "FOREIGN-SYMBOL-ADDRESS" "FD-STREAM-P" "FIND-IF-IN-CLOSURE" "FOREIGN-SYMBOL-ADDRESS"
"FOREIGN-SYMBOL-CODE-ADDRESS" "FOREIGN-SYMBOL-DATA-ADDRESS" "FOREIGN-SYMBOL-CODE-ADDRESS" "FOREIGN-SYMBOL-DATA-ADDRESS"
"GET-PAGE-SIZE" "GET-SYSTEM-INFO" "GET-PAGE-SIZE" "GET-SYSTEM-INFO"
"GET-USER-HOMEDIR-PATHNAME" "GET-USER-HOMEDIR-NAMESTRING"
"IGNORE-INTERRUPT" "IGNORE-INTERRUPT"
"INT-SAP" "INVALIDATE-DESCRIPTOR" "IO-TIMEOUT" "INT-SAP" "INVALIDATE-DESCRIPTOR" "IO-TIMEOUT"
"LISP-STREAM" "LONG-FLOAT-RADIX" "LONG-WORDS" "LISP-STREAM" "LONG-FLOAT-RADIX" "LONG-WORDS"
......
...@@ -301,105 +301,136 @@ ...@@ -301,105 +301,136 @@
(return (values (remove-backslashes namestr start index) (return (values (remove-backslashes namestr start index)
(1+ index))))))))) (1+ index)))))))))
(defun expand-tilde-user-name (str start end)
;; Quick exit if STR doesn't start with ~ or we have an empty string.
(when (or (= start end)
(char/= (schar str start) #\~))
(return-from expand-tilde-user-name
(values str start end)))
(let ((end-user (position #\/ str :start start :end end)))
;; Quick exit if we can't find a "/" to terminate the user name.
(unless end-user
(return-from expand-tilde-user-name
(values str start end)))
(let* ((user-name (subseq str (1+ start) end-user))
(homedir (get-user-homedir-namestring user-name)))
(unless homedir
(error "Unknown user ~S in namestring ~S" user-name (subseq str start end)))
;; Replace the ~user part with the home directory, adjusting END
;; because of the replacement.
(values (concatenate 'simple-base-string
(subseq str 0 start)
homedir
(subseq str end-user))
start
(+ end (- (length homedir)
(length user-name)
1))))))
(defun parse-unix-namestring (namestr start end) (defun parse-unix-namestring (namestr start end)
(declare (type simple-base-string namestr) (declare (type simple-base-string namestr)
(type index start end)) (type index start end))
(multiple-value-bind ;; Look for "~user/" (or "~/"). If found replace it with the user's
(absolute pieces) ;; home directory
(split-at-slashes namestr start end) (multiple-value-bind (namestr start end)
(let ((search-list (expand-tilde-user-name namestr start end)
(if absolute (multiple-value-bind
nil (absolute pieces)
(let ((first (car pieces))) (split-at-slashes namestr start end)
(multiple-value-bind (let ((search-list
(search-list new-start) (if absolute
(maybe-extract-search-list namestr nil
(car first) (cdr first)) (let ((first (car pieces)))
(when search-list (multiple-value-bind
;; Lose if this search-list is already defined as (search-list new-start)
;; a logical host. Since the syntax for (maybe-extract-search-list namestr
;; search-lists and logical pathnames are the (car first) (cdr first))
;; same, we can't allow the creation of one when (when search-list
;; the other is defined. ;; Lose if this search-list is already defined as
(when (find-logical-host search-list nil) ;; a logical host. Since the syntax for
(error (intl:gettext "~A already names a logical host") search-list)) ;; search-lists and logical pathnames are the
(setf absolute t) ;; same, we can't allow the creation of one when
(setf (car first) new-start)) ;; the other is defined.
search-list))))) (when (find-logical-host search-list nil)
(multiple-value-bind (name type version) (error (intl:gettext "~A already names a logical host") search-list))
(let* ((tail (car (last pieces))) (setf absolute t)
(tail-start (car tail)) (setf (car first) new-start))
(tail-end (cdr tail))) search-list)))))
(unless (= tail-start tail-end) (multiple-value-bind (name type version)
(setf pieces (butlast pieces)) (let* ((tail (car (last pieces)))
(cond ((string= namestr ".." :start1 tail-start :end1 tail-end) (tail-start (car tail))
;; ".." is a directory. Add this piece to the (tail-end (cdr tail)))
;; list of pieces, and make the name/type/version (unless (= tail-start tail-end)
;; nil. (setf pieces (butlast pieces))
(setf pieces (append pieces (list (cons tail-start tail-end)))) (cond ((string= namestr ".." :start1 tail-start :end1 tail-end)
(values nil nil nil)) ;; ".." is a directory. Add this piece to the
((string= namestr "." :start1 tail-start :end1 tail-end) ;; list of pieces, and make the name/type/version
;; "." is a directory as well. ;; nil.
(setf pieces (append pieces (list (cons tail-start tail-end)))) (setf pieces (append pieces (list (cons tail-start tail-end))))
(values nil nil nil)) (values nil nil nil))
((not (find-if-not #'(lambda (c) ((string= namestr "." :start1 tail-start :end1 tail-end)
(char= c #\.)) ;; "." is a directory as well.
namestr :start tail-start :end tail-end)) (setf pieces (append pieces (list (cons tail-start tail-end))))
;; Got a bunch of dots. Make it a file of the (values nil nil nil))
;; same name, and type the empty string. ((not (find-if-not #'(lambda (c)
(values (subseq namestr tail-start (1- tail-end)) "" nil)) (char= c #\.))
(t namestr :start tail-start :end tail-end))
(extract-name-type-and-version namestr tail-start tail-end))))) ;; Got a bunch of dots. Make it a file of the
;; PVE: Make sure there are no illegal characters in the name ;; same name, and type the empty string.
;; such as #\Null and #\/. (values (subseq namestr tail-start (1- tail-end)) "" nil))
(when (and (stringp name) (t
(find-if #'(lambda (x) (extract-name-type-and-version namestr tail-start tail-end)))))
(or (char= x #\Null) (char= x #\/))) ;; PVE: Make sure there are no illegal characters in the name
name)) ;; such as #\Null and #\/.
(error 'parse-error)) (when (and (stringp name)
;; Now we have everything we want. So return it. (find-if #'(lambda (x)
(values nil ; no host for unix namestrings. (or (char= x #\Null) (char= x #\/)))
nil ; no devices for unix namestrings. name))
(collect ((dirs)) (error 'parse-error))
(when search-list ;; Now we have everything we want. So return it.
(dirs (intern-search-list search-list))) (values nil ; no host for unix namestrings.
(dolist (piece pieces) nil ; no devices for unix namestrings.
(let ((piece-start (car piece)) (collect ((dirs))
(piece-end (cdr piece))) (when search-list
(unless (= piece-start piece-end) (dirs (intern-search-list search-list)))
(cond ((string= namestr ".." :start1 piece-start (dolist (piece pieces)
:end1 piece-end) (let ((piece-start (car piece))
(dirs :up)) (piece-end (cdr piece)))
((string= namestr "**" :start1 piece-start (unless (= piece-start piece-end)
:end1 piece-end) (cond ((string= namestr ".." :start1 piece-start
(dirs :wild-inferiors)) :end1 piece-end)
(t (dirs :up))
(dirs (maybe-make-pattern namestr ((string= namestr "**" :start1 piece-start
piece-start :end1 piece-end)
piece-end))))))) (dirs :wild-inferiors))
(cond (absolute (t
(cons :absolute (dirs))) (dirs (maybe-make-pattern namestr
((dirs) piece-start
;; "." in a :relative directory is the same piece-end)))))))
;; as if it weren't there, so remove them. (cond (absolute
(cons :relative (delete "." (dirs) :test #'equal))) (cons :absolute (dirs)))
(t ((dirs)
;; If there is no directory and the name is ;; "." in a :relative directory is the same
;; "." and the type is NIL, we really got ;; as if it weren't there, so remove them.
;; directory ".", so make it so. (cons :relative (delete "." (dirs) :test #'equal)))
(if (and (equal name ".") (t
(null type)) ;; If there is no directory and the name is
(list :relative) ;; "." and the type is NIL, we really got
nil)))) ;; directory ".", so make it so.
;; A file with name "." and type NIL can't be the name (if (and (equal name ".")
;; of file on Unix because it's a directory. This was (null type))
;; handled above, so we can just set the name to nil. (list :relative)
(if (and (equal name ".") nil))))
(null type)) ;; A file with name "." and type NIL can't be the name
nil ;; of file on Unix because it's a directory. This was
name) ;; handled above, so we can just set the name to nil.
type (if (and (equal name ".")
version))))) (null type))
nil
name)
type
version))))))
(defun unparse-unix-host (pathname) (defun unparse-unix-host (pathname)
(declare (type pathname pathname) (declare (type pathname pathname)
......
...@@ -58,32 +58,39 @@ ...@@ -58,32 +58,39 @@
(unix:get-unix-error-msg utime))) (unix:get-unix-error-msg utime)))
(values utime stime major-fault)))) (values utime stime major-fault))))
;;; GET-USER-HOMEDIR-PATHNAME -- Public ;;; GET-USER-HOMEDIR-NAMESTRING -- Public
;;; ;;;
(defun get-user-homedir-pathname (name) (defun get-user-homedir-namestring (name)
_N"Get the user home directory for user named NAME. Two values are _N"Get the user home directory for user named NAME. If NAME is the empty
returned: the pathname of the home directory and a status code. If string, the home directory of the current user is returned.
the home directory does not exist NIL is returned. The status is 0
if no errors occurred. Otherwise a non-zero value is returned. Two values are returned: the pathname of the home directory and a
Examining errno may give information about what failed." status code. If the home directory does not exist NIL is returned.
(alien:with-alien ((status c-call:int)) The status is 0 if no errors occurred. Otherwise a non-zero value
(let (result) is returned. Examining errno may give information about what failed."
(unwind-protect (cond
(progn ((zerop (length name))
(setf result (multiple-value-bind (user-info status)
(alien:alien-funcall (unix:unix-getpwuid (unix:unix-getuid))
(alien:extern-alien "os_get_user_homedir" (values (when user-info
(function (alien:* c-call:c-string) (unix:user-info-dir user-info))
c-call:c-string status)))
(* c-call:int))) (t
name (alien:with-alien ((status c-call:int))
(alien:addr status))) (let (result)
(if (and (zerop status) (unwind-protect
(not (alien:null-alien result))) (progn
(values (pathname (setf result
(concatenate 'string (alien:alien-funcall
(alien:cast result c-call:c-string) (alien:extern-alien "os_get_user_homedir"
"/")) (function (alien:* c-call:c-string)
status) c-call:c-string
(values nil status))) (* c-call:int)))
(alien:free-alien result))))) name
(alien:addr status)))
(if (and (zerop status)
(not (alien:null-alien result)))
(values (alien:cast result c-call:c-string)
status)
(values nil status)))
(alien:free-alien result)))))))
...@@ -39,6 +39,7 @@ public domain. ...@@ -39,6 +39,7 @@ public domain.
* ~~#253~~ Block-compile list-to-hashtable and callers * ~~#253~~ Block-compile list-to-hashtable and callers
* ~~#258~~ Remove `get-page-size` from linux-os.lisp * ~~#258~~ Remove `get-page-size` from linux-os.lisp
* ~~#269~~ Add function to get user's home directory * ~~#269~~ Add function to get user's home directory
* ~~#266~~ Support "~user" in namestrings
* Other changes: * Other changes:
* Improvements to the PCL implementation of CLOS: * Improvements to the PCL implementation of CLOS:
* Changes to building procedure: * Changes to building procedure:
......
...@@ -35,10 +35,12 @@ msgstr "" ...@@ -35,10 +35,12 @@ msgstr ""
#: src/code/os.lisp #: src/code/os.lisp
msgid "" msgid ""
"Get the user home directory for user named NAME. Two values are\n" "Get the user home directory for user named NAME. If NAME is the empty\n"
" returned: the pathname of the home directory and a status code. If\n" " string, the home directory of the current user is returned.\n"
" the home directory does not exist NIL is returned. The status is 0\n" "\n"
" if no errors occurred. Otherwise a non-zero value is returned.\n" " Two values are returned: the pathname of the home directory and a\n"
" Examining errno may give information about what failed." " status code. If the home directory does not exist NIL is returned.\n"
" The status is 0 if no errors occurred. Otherwise a non-zero value\n"
" is returned. Examining errno may give information about what failed."
msgstr "" msgstr ""
...@@ -7,7 +7,7 @@ ...@@ -7,7 +7,7 @@
(define-test user-homedir.1 (define-test user-homedir.1
"Test user-homedir" "Test user-homedir"
(:tag :issues) (:tag :issues)
;; Simple test to see if get-user-homedir-pathname returns the ;; Simple test to see if get-user-homedir-namestring returns the
;; expected value. Use getuid and getpwuid to figure out what the ;; expected value. Use getuid and getpwuid to figure out what the
;; name and home directory should be. ;; name and home directory should be.
(let* ((uid (unix:unix-getuid)) (let* ((uid (unix:unix-getuid))
...@@ -15,15 +15,13 @@ ...@@ -15,15 +15,13 @@
(assert-true uid) (assert-true uid)
(assert-true user-info) (assert-true user-info)
(let* ((info-dir (unix:user-info-dir user-info)) (let* ((info-dir (unix:user-info-dir user-info))
(info-name (unix:user-info-name user-info)) (info-name (unix:user-info-name user-info)))
(expected-home-pathname (pathname (multiple-value-bind (home-namestring status)
(concatenate 'string info-dir "/")))) (system:get-user-homedir-namestring info-name)
(multiple-value-bind (home-pathname status)
(system:get-user-homedir-pathname info-name)
(assert-true info-dir) (assert-true info-dir)
(assert-true info-name) (assert-true info-name)
(assert-equal home-pathname expected-home-pathname) (assert-equal home-namestring info-dir)
(assert-eql status 0))))) (assert-eql status 0)))))
(define-test user-homedir.2 (define-test user-homedir.2
...@@ -33,6 +31,6 @@ ...@@ -33,6 +31,6 @@
;; value for a user that does not exist. Well, we assume such a ;; value for a user that does not exist. Well, we assume such a
;; user doesn't exist. ;; user doesn't exist.
(multiple-value-bind (home-pathname status) (multiple-value-bind (home-pathname status)
(system:get-user-homedir-pathname "zotuserunknown") (system:get-user-homedir-namestring "zotuserunknown")
(assert-eql home-pathname nil) (assert-eql home-pathname nil)
(assert-eql status 0))) (assert-eql status 0)))
...@@ -111,3 +111,34 @@ ...@@ -111,3 +111,34 @@
test test
(assert-equal printed-value (output pathname)) (assert-equal printed-value (output pathname))
(assert-equal namestring (namestring pathname)))))) (assert-equal namestring (namestring pathname))))))
(define-test issue.266.pathname-tilde.unknown-user
(:tag :issues)
;; This assumes that there's no user named "zotunknown".
(assert-error 'simple-error (parse-namestring "~zotunknown/*.*")))
(define-test issue.266.pathname-tilde.1
(:tag :issues)
;; Simple test for ~ in pathnames. Get a directory list using
;; #P"~/*.*". This should produce exactly the same list as the
;; #search-list P"home:*.*".
(let ((dir-home (directory #p"home:*.*" :truenamep nil :follow-links nil))
(dir-tilde (directory #p"~/*.*" :truenamep nil :follow-links nil)))
(assert-equal dir-tilde dir-home)))
(define-test issue.266.pathname-tilde.2
(:tag :issues)
;; Simple test for ~ in pathnames. Get a directory list using
;; #P"~user/*.*". This should produce exactly the same list as the
;; #search-list P"home:*.*". We determine the user name via getuid
;; #and getpwuid.
(let ((user-name (unix:user-info-name (unix:unix-getpwuid (unix:unix-getuid)))))
(assert-true user-name)
(let* ((dir-home (directory #p"home:*.*" :truenamep nil :follow-links nil))
(dir-tilde (directory (concatenate 'string
"~"
user-name
"/*.*")
:truenamep nil :follow-links nil)))
(assert-equal dir-tilde dir-home))))
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment