Raymond Toy pushed to branch master at cmucl / cmucl

Commits: bc8cb405 by Raymond Toy at 2023-12-07T23:09:31+00:00 Fix #266: Support ~user in namestrings

- - - - - 81f0d53c by Raymond Toy at 2023-12-07T23:09:36+00:00 Merge branch 'issue-266-b-tilde-pathname-support' into 'master'

Fix #266: Support ~user in namestrings

Closes #266

See merge request cmucl/cmucl!180 - - - - -

7 changed files:

- src/code/exports.lisp - src/code/filesys.lisp - src/code/os.lisp - src/general-info/release-21f.md - src/i18n/locale/cmucl-os.pot - tests/os.lisp - tests/pathname.lisp

Changes:

===================================== src/code/exports.lisp ===================================== @@ -2074,7 +2074,7 @@ "FD-STREAM-P" "FIND-IF-IN-CLOSURE" "FOREIGN-SYMBOL-ADDRESS" "FOREIGN-SYMBOL-CODE-ADDRESS" "FOREIGN-SYMBOL-DATA-ADDRESS" "GET-PAGE-SIZE" "GET-SYSTEM-INFO" - "GET-USER-HOMEDIR-PATHNAME" + "GET-USER-HOMEDIR-NAMESTRING" "IGNORE-INTERRUPT" "INT-SAP" "INVALIDATE-DESCRIPTOR" "IO-TIMEOUT" "LISP-STREAM" "LONG-FLOAT-RADIX" "LONG-WORDS"

===================================== src/code/filesys.lisp ===================================== @@ -301,105 +301,136 @@ (return (values (remove-backslashes namestr start 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) (declare (type simple-base-string namestr) (type index start end)) - (multiple-value-bind - (absolute pieces) - (split-at-slashes namestr start end) - (let ((search-list - (if absolute - nil - (let ((first (car pieces))) - (multiple-value-bind - (search-list new-start) - (maybe-extract-search-list namestr - (car first) (cdr first)) - (when search-list - ;; Lose if this search-list is already defined as - ;; a logical host. Since the syntax for - ;; search-lists and logical pathnames are the - ;; same, we can't allow the creation of one when - ;; the other is defined. - (when (find-logical-host search-list nil) - (error (intl:gettext "~A already names a logical host") search-list)) - (setf absolute t) - (setf (car first) new-start)) - search-list))))) - (multiple-value-bind (name type version) - (let* ((tail (car (last pieces))) - (tail-start (car tail)) - (tail-end (cdr tail))) - (unless (= tail-start tail-end) - (setf pieces (butlast pieces)) - (cond ((string= namestr ".." :start1 tail-start :end1 tail-end) - ;; ".." is a directory. Add this piece to the - ;; list of pieces, and make the name/type/version - ;; nil. - (setf pieces (append pieces (list (cons tail-start tail-end)))) - (values nil nil nil)) - ((string= namestr "." :start1 tail-start :end1 tail-end) - ;; "." is a directory as well. - (setf pieces (append pieces (list (cons tail-start tail-end)))) - (values nil nil nil)) - ((not (find-if-not #'(lambda (c) - (char= c #.)) - namestr :start tail-start :end tail-end)) - ;; Got a bunch of dots. Make it a file of the - ;; same name, and type the empty string. - (values (subseq namestr tail-start (1- tail-end)) "" nil)) - (t - (extract-name-type-and-version namestr tail-start tail-end))))) - ;; PVE: Make sure there are no illegal characters in the name - ;; such as #\Null and #/. - (when (and (stringp name) - (find-if #'(lambda (x) - (or (char= x #\Null) (char= x #/))) - name)) - (error 'parse-error)) - ;; Now we have everything we want. So return it. - (values nil ; no host for unix namestrings. - nil ; no devices for unix namestrings. - (collect ((dirs)) - (when search-list - (dirs (intern-search-list search-list))) - (dolist (piece pieces) - (let ((piece-start (car piece)) - (piece-end (cdr piece))) - (unless (= piece-start piece-end) - (cond ((string= namestr ".." :start1 piece-start - :end1 piece-end) - (dirs :up)) - ((string= namestr "**" :start1 piece-start - :end1 piece-end) - (dirs :wild-inferiors)) - (t - (dirs (maybe-make-pattern namestr - piece-start - piece-end))))))) - (cond (absolute - (cons :absolute (dirs))) - ((dirs) - ;; "." in a :relative directory is the same - ;; as if it weren't there, so remove them. - (cons :relative (delete "." (dirs) :test #'equal))) - (t - ;; If there is no directory and the name is - ;; "." and the type is NIL, we really got - ;; directory ".", so make it so. - (if (and (equal name ".") - (null type)) - (list :relative) - nil)))) - ;; A file with name "." and type NIL can't be the name - ;; of file on Unix because it's a directory. This was - ;; handled above, so we can just set the name to nil. - (if (and (equal name ".") - (null type)) - nil - name) - type - version))))) + ;; Look for "~user/" (or "~/"). If found replace it with the user's + ;; home directory + (multiple-value-bind (namestr start end) + (expand-tilde-user-name namestr start end) + (multiple-value-bind + (absolute pieces) + (split-at-slashes namestr start end) + (let ((search-list + (if absolute + nil + (let ((first (car pieces))) + (multiple-value-bind + (search-list new-start) + (maybe-extract-search-list namestr + (car first) (cdr first)) + (when search-list + ;; Lose if this search-list is already defined as + ;; a logical host. Since the syntax for + ;; search-lists and logical pathnames are the + ;; same, we can't allow the creation of one when + ;; the other is defined. + (when (find-logical-host search-list nil) + (error (intl:gettext "~A already names a logical host") search-list)) + (setf absolute t) + (setf (car first) new-start)) + search-list))))) + (multiple-value-bind (name type version) + (let* ((tail (car (last pieces))) + (tail-start (car tail)) + (tail-end (cdr tail))) + (unless (= tail-start tail-end) + (setf pieces (butlast pieces)) + (cond ((string= namestr ".." :start1 tail-start :end1 tail-end) + ;; ".." is a directory. Add this piece to the + ;; list of pieces, and make the name/type/version + ;; nil. + (setf pieces (append pieces (list (cons tail-start tail-end)))) + (values nil nil nil)) + ((string= namestr "." :start1 tail-start :end1 tail-end) + ;; "." is a directory as well. + (setf pieces (append pieces (list (cons tail-start tail-end)))) + (values nil nil nil)) + ((not (find-if-not #'(lambda (c) + (char= c #.)) + namestr :start tail-start :end tail-end)) + ;; Got a bunch of dots. Make it a file of the + ;; same name, and type the empty string. + (values (subseq namestr tail-start (1- tail-end)) "" nil)) + (t + (extract-name-type-and-version namestr tail-start tail-end))))) + ;; PVE: Make sure there are no illegal characters in the name + ;; such as #\Null and #/. + (when (and (stringp name) + (find-if #'(lambda (x) + (or (char= x #\Null) (char= x #/))) + name)) + (error 'parse-error)) + ;; Now we have everything we want. So return it. + (values nil ; no host for unix namestrings. + nil ; no devices for unix namestrings. + (collect ((dirs)) + (when search-list + (dirs (intern-search-list search-list))) + (dolist (piece pieces) + (let ((piece-start (car piece)) + (piece-end (cdr piece))) + (unless (= piece-start piece-end) + (cond ((string= namestr ".." :start1 piece-start + :end1 piece-end) + (dirs :up)) + ((string= namestr "**" :start1 piece-start + :end1 piece-end) + (dirs :wild-inferiors)) + (t + (dirs (maybe-make-pattern namestr + piece-start + piece-end))))))) + (cond (absolute + (cons :absolute (dirs))) + ((dirs) + ;; "." in a :relative directory is the same + ;; as if it weren't there, so remove them. + (cons :relative (delete "." (dirs) :test #'equal))) + (t + ;; If there is no directory and the name is + ;; "." and the type is NIL, we really got + ;; directory ".", so make it so. + (if (and (equal name ".") + (null type)) + (list :relative) + nil)))) + ;; A file with name "." and type NIL can't be the name + ;; of file on Unix because it's a directory. This was + ;; handled above, so we can just set the name to nil. + (if (and (equal name ".") + (null type)) + nil + name) + type + version))))))

(defun unparse-unix-host (pathname) (declare (type pathname pathname)

===================================== src/code/os.lisp ===================================== @@ -58,32 +58,39 @@ (unix:get-unix-error-msg utime))) (values utime stime major-fault))))

-;;; GET-USER-HOMEDIR-PATHNAME -- Public +;;; GET-USER-HOMEDIR-NAMESTRING -- Public ;;; -(defun get-user-homedir-pathname (name) - _N"Get the user home directory for user named NAME. Two values are - returned: the pathname of the home directory and a status code. If - the home directory does not exist NIL is returned. The status is 0 - if no errors occurred. Otherwise a non-zero value is returned. - Examining errno may give information about what failed." - (alien:with-alien ((status c-call:int)) - (let (result) - (unwind-protect - (progn - (setf result - (alien:alien-funcall - (alien:extern-alien "os_get_user_homedir" - (function (alien:* c-call:c-string) - c-call:c-string - (* c-call:int))) - name - (alien:addr status))) - (if (and (zerop status) - (not (alien:null-alien result))) - (values (pathname - (concatenate 'string - (alien:cast result c-call:c-string) - "/")) - status) - (values nil status))) - (alien:free-alien result))))) +(defun get-user-homedir-namestring (name) + _N"Get the user home directory for user named NAME. If NAME is the empty + string, the home directory of the current user is returned. + + Two values are returned: the pathname of the home directory and a + status code. If the home directory does not exist NIL is returned. + The status is 0 if no errors occurred. Otherwise a non-zero value + is returned. Examining errno may give information about what failed." + (cond + ((zerop (length name)) + (multiple-value-bind (user-info status) + (unix:unix-getpwuid (unix:unix-getuid)) + (values (when user-info + (unix:user-info-dir user-info)) + status))) + (t + (alien:with-alien ((status c-call:int)) + (let (result) + (unwind-protect + (progn + (setf result + (alien:alien-funcall + (alien:extern-alien "os_get_user_homedir" + (function (alien:* c-call:c-string) + c-call:c-string + (* c-call:int))) + 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)))))))

===================================== src/general-info/release-21f.md ===================================== @@ -39,6 +39,7 @@ public domain. * ~~#253~~ Block-compile list-to-hashtable and callers * ~~#258~~ Remove `get-page-size` from linux-os.lisp * ~~#269~~ Add function to get user's home directory + * ~~#266~~ Support "~user" in namestrings * Other changes: * Improvements to the PCL implementation of CLOS: * Changes to building procedure:

===================================== src/i18n/locale/cmucl-os.pot ===================================== @@ -35,10 +35,12 @@ msgstr ""

#: src/code/os.lisp msgid "" -"Get the user home directory for user named NAME. Two values are\n" -" returned: the pathname of the home directory and a status code. If\n" -" the home directory does not exist NIL is returned. The status is 0\n" -" if no errors occurred. Otherwise a non-zero value is returned.\n" -" Examining errno may give information about what failed." +"Get the user home directory for user named NAME. If NAME is the empty\n" +" string, the home directory of the current user is returned.\n" +"\n" +" Two values are returned: the pathname of the home directory and a\n" +" 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 ""

===================================== tests/os.lisp ===================================== @@ -7,7 +7,7 @@ (define-test user-homedir.1 "Test user-homedir" (: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 ;; name and home directory should be. (let* ((uid (unix:unix-getuid)) @@ -15,15 +15,13 @@ (assert-true uid) (assert-true user-info) (let* ((info-dir (unix:user-info-dir user-info)) - (info-name (unix:user-info-name user-info)) - (expected-home-pathname (pathname - (concatenate 'string info-dir "/")))) - (multiple-value-bind (home-pathname status) - (system:get-user-homedir-pathname info-name) + (info-name (unix:user-info-name user-info))) + (multiple-value-bind (home-namestring status) + (system:get-user-homedir-namestring info-name) (assert-true info-dir) (assert-true info-name)

- (assert-equal home-pathname expected-home-pathname) + (assert-equal home-namestring info-dir) (assert-eql status 0)))))

(define-test user-homedir.2 @@ -33,6 +31,6 @@ ;; value for a user that does not exist. Well, we assume such a ;; user doesn't exist. (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 status 0)))

===================================== tests/pathname.lisp ===================================== @@ -111,3 +111,34 @@ test (assert-equal printed-value (output 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))))

View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/8e067da95a2c8e3dad645be...