Raymond Toy pushed to branch master at cmucl / cmucl

Commits:

7 changed files:

Changes:

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

  • src/code/filesys.lisp
    ... ... @@ -301,105 +301,136 @@
    301 301 
     	     (return (values (remove-backslashes namestr start index)
    302 302 
     			     (1+ index)))))))))
    303 303
    304 
    +(defun expand-tilde-user-name (str start end)
    305 
    +  ;; Quick exit if STR doesn't start with ~ or we have an empty string.
    306 
    +  (when (or (= start end)
    307 
    +            (char/= (schar str start) #\~))
    308 
    +    (return-from expand-tilde-user-name
    309 
    +      (values str start end)))
    310 
    +
    311 
    +  (let ((end-user (position #\/ str :start start :end end)))
    312 
    +    ;; Quick exit if we can't find a "/" to terminate the user name.
    313 
    +    (unless end-user
    314 
    +      (return-from expand-tilde-user-name
    315 
    +        (values str start end)))
    316 
    +    (let* ((user-name (subseq str (1+ start) end-user))
    317 
    +           (homedir (get-user-homedir-namestring user-name)))
    318 
    +      (unless homedir
    319 
    +        (error "Unknown user ~S in namestring ~S" user-name (subseq str start end)))
    320 
    +      ;; Replace the ~user part with the home directory, adjusting END
    321 
    +      ;; because of the replacement.
    322 
    +      (values (concatenate 'simple-base-string
    323 
    +                           (subseq str 0 start)
    324 
    +                           homedir
    325 
    +                           (subseq str end-user))
    326 
    +              start
    327 
    +              (+ end (- (length homedir)
    328 
    +                        (length user-name)
    329 
    +                        1))))))
    330 
    +
    304 331 
     (defun parse-unix-namestring (namestr start end)
    305 332 
       (declare (type simple-base-string namestr)
    306 333 
     	   (type index start end))
    307 
    -  (multiple-value-bind
    308 
    -      (absolute pieces)
    309 
    -      (split-at-slashes namestr start end)
    310 
    -    (let ((search-list
    311 
    -	   (if absolute
    312 
    -	       nil
    313 
    -	       (let ((first (car pieces)))
    314 
    -		 (multiple-value-bind
    315 
    -		       (search-list new-start)
    316 
    -		     (maybe-extract-search-list namestr
    317 
    -						(car first) (cdr first))
    318 
    -		   (when search-list
    319 
    -		     ;; Lose if this search-list is already defined as
    320 
    -		     ;; a logical host.  Since the syntax for
    321 
    -		     ;; search-lists and logical pathnames are the
    322 
    -		     ;; same, we can't allow the creation of one when
    323 
    -		     ;; the other is defined.
    324 
    -		     (when (find-logical-host search-list nil)
    325 
    -		       (error (intl:gettext "~A already names a logical host") search-list))
    326 
    -		     (setf absolute t)
    327 
    -		     (setf (car first) new-start))
    328 
    -		   search-list)))))
    329 
    -      (multiple-value-bind (name type version)
    330 
    -	  (let* ((tail (car (last pieces)))
    331 
    -		 (tail-start (car tail))
    332 
    -		 (tail-end (cdr tail)))
    333 
    -	    (unless (= tail-start tail-end)
    334 
    -	      (setf pieces (butlast pieces))
    335 
    -	      (cond ((string= namestr ".." :start1 tail-start :end1 tail-end)
    336 
    -		     ;; ".." is a directory.  Add this piece to the
    337 
    -		     ;; list of pieces, and make the name/type/version
    338 
    -		     ;; nil.
    339 
    -		     (setf pieces (append pieces (list (cons tail-start tail-end))))
    340 
    -		     (values nil nil nil))
    341 
    -		    ((string= namestr "." :start1 tail-start :end1 tail-end)
    342 
    -		     ;; "." is a directory as well.
    343 
    -		     (setf pieces (append pieces (list (cons tail-start tail-end))))
    344 
    -		     (values nil nil nil))
    345 
    -		    ((not (find-if-not #'(lambda (c)
    346 
    -					   (char= c #\.))
    347 
    -				       namestr :start tail-start :end tail-end))
    348 
    -		     ;; Got a bunch of dots.  Make it a file of the
    349 
    -		     ;; same name, and type the empty string.
    350 
    -		     (values (subseq namestr tail-start (1- tail-end)) "" nil))
    351 
    -		    (t
    352 
    -		     (extract-name-type-and-version namestr tail-start tail-end)))))
    353 
    -	;; PVE: Make sure there are no illegal characters in the name
    354 
    -	;; such as #\Null and #\/.
    355 
    -	(when (and (stringp name)
    356 
    -                   (find-if #'(lambda (x)
    357 
    -				(or (char= x #\Null) (char= x #\/)))
    358 
    -			    name))
    359 
    -	  (error 'parse-error))
    360 
    -	;; Now we have everything we want.  So return it.
    361 
    -	(values nil ; no host for unix namestrings.
    362 
    -		nil ; no devices for unix namestrings.
    363 
    -		(collect ((dirs))
    364 
    -		  (when search-list
    365 
    -		    (dirs (intern-search-list search-list)))
    366 
    -		  (dolist (piece pieces)
    367 
    -		    (let ((piece-start (car piece))
    368 
    -			  (piece-end (cdr piece)))
    369 
    -		      (unless (= piece-start piece-end)
    370 
    -			(cond ((string= namestr ".." :start1 piece-start
    371 
    -					     :end1 piece-end)
    372 
    -			       (dirs :up))
    373 
    -			      ((string= namestr "**" :start1 piece-start
    374 
    -					:end1 piece-end)
    375 
    -			       (dirs :wild-inferiors))
    376 
    -			      (t
    377 
    -			       (dirs (maybe-make-pattern namestr
    378 
    -							 piece-start
    379 
    -							 piece-end)))))))
    380 
    -		  (cond (absolute
    381 
    -			 (cons :absolute (dirs)))
    382 
    -			((dirs)
    383 
    -			 ;; "." in a :relative directory is the same
    384 
    -			 ;; as if it weren't there, so remove them.
    385 
    -			 (cons :relative (delete "." (dirs) :test #'equal)))
    386 
    -			(t
    387 
    -			 ;; If there is no directory and the name is
    388 
    -			 ;; "." and the type is NIL, we really got
    389 
    -			 ;; directory ".", so make it so.
    390 
    -			 (if (and (equal name ".")
    391 
    -				  (null type))
    392 
    -			     (list :relative)
    393 
    -			 nil))))
    394 
    -		;; A file with name "." and type NIL can't be the name
    395 
    -		;; of file on Unix because it's a directory.  This was
    396 
    -		;; handled above, so we can just set the name to nil.
    397 
    -		(if (and (equal name ".")
    398 
    -			 (null type))
    399 
    -		    nil
    400 
    -		    name)
    401 
    -		type
    402 
    -		version)))))
    334 
    +  ;; Look for "~user/" (or "~/").  If found replace it with the user's
    335 
    +  ;; home directory
    336 
    +  (multiple-value-bind (namestr start end)
    337 
    +      (expand-tilde-user-name namestr start end)
    338 
    +    (multiple-value-bind
    339 
    +          (absolute pieces)
    340 
    +        (split-at-slashes namestr start end)
    341 
    +      (let ((search-list
    342 
    +	      (if absolute
    343 
    +	          nil
    344 
    +	          (let ((first (car pieces)))
    345 
    +		    (multiple-value-bind
    346 
    +		          (search-list new-start)
    347 
    +		        (maybe-extract-search-list namestr
    348 
    +						   (car first) (cdr first))
    349 
    +		      (when search-list
    350 
    +		        ;; Lose if this search-list is already defined as
    351 
    +		        ;; a logical host.  Since the syntax for
    352 
    +		        ;; search-lists and logical pathnames are the
    353 
    +		        ;; same, we can't allow the creation of one when
    354 
    +		        ;; the other is defined.
    355 
    +		        (when (find-logical-host search-list nil)
    356 
    +		          (error (intl:gettext "~A already names a logical host") search-list))
    357 
    +		        (setf absolute t)
    358 
    +		        (setf (car first) new-start))
    359 
    +		      search-list)))))
    360 
    +        (multiple-value-bind (name type version)
    361 
    +	    (let* ((tail (car (last pieces)))
    362 
    +		   (tail-start (car tail))
    363 
    +		   (tail-end (cdr tail)))
    364 
    +	      (unless (= tail-start tail-end)
    365 
    +	        (setf pieces (butlast pieces))
    366 
    +	        (cond ((string= namestr ".." :start1 tail-start :end1 tail-end)
    367 
    +		       ;; ".." is a directory.  Add this piece to the
    368 
    +		       ;; list of pieces, and make the name/type/version
    369 
    +		       ;; nil.
    370 
    +		       (setf pieces (append pieces (list (cons tail-start tail-end))))
    371 
    +		       (values nil nil nil))
    372 
    +		      ((string= namestr "." :start1 tail-start :end1 tail-end)
    373 
    +		       ;; "." is a directory as well.
    374 
    +		       (setf pieces (append pieces (list (cons tail-start tail-end))))
    375 
    +		       (values nil nil nil))
    376 
    +		      ((not (find-if-not #'(lambda (c)
    377 
    +					     (char= c #\.))
    378 
    +				         namestr :start tail-start :end tail-end))
    379 
    +		       ;; Got a bunch of dots.  Make it a file of the
    380 
    +		       ;; same name, and type the empty string.
    381 
    +		       (values (subseq namestr tail-start (1- tail-end)) "" nil))
    382 
    +		      (t
    383 
    +		       (extract-name-type-and-version namestr tail-start tail-end)))))
    384 
    +	  ;; PVE: Make sure there are no illegal characters in the name
    385 
    +	  ;; such as #\Null and #\/.
    386 
    +	  (when (and (stringp name)
    387 
    +                     (find-if #'(lambda (x)
    388 
    +				  (or (char= x #\Null) (char= x #\/)))
    389 
    +			      name))
    390 
    +	    (error 'parse-error))
    391 
    +	  ;; Now we have everything we want.  So return it.
    392 
    +	  (values nil               ; no host for unix namestrings.
    393 
    +		  nil               ; no devices for unix namestrings.
    394 
    +		  (collect ((dirs))
    395 
    +		    (when search-list
    396 
    +		      (dirs (intern-search-list search-list)))
    397 
    +		    (dolist (piece pieces)
    398 
    +		      (let ((piece-start (car piece))
    399 
    +			    (piece-end (cdr piece)))
    400 
    +		        (unless (= piece-start piece-end)
    401 
    +			  (cond ((string= namestr ".." :start1 piece-start
    402 
    +					               :end1 piece-end)
    403 
    +			         (dirs :up))
    404 
    +			        ((string= namestr "**" :start1 piece-start
    405 
    +					               :end1 piece-end)
    406 
    +			         (dirs :wild-inferiors))
    407 
    +			        (t
    408 
    +			         (dirs (maybe-make-pattern namestr
    409 
    +							   piece-start
    410 
    +							   piece-end)))))))
    411 
    +		    (cond (absolute
    412 
    +			   (cons :absolute (dirs)))
    413 
    +			  ((dirs)
    414 
    +			   ;; "." in a :relative directory is the same
    415 
    +			   ;; as if it weren't there, so remove them.
    416 
    +			   (cons :relative (delete "." (dirs) :test #'equal)))
    417 
    +			  (t
    418 
    +			   ;; If there is no directory and the name is
    419 
    +			   ;; "." and the type is NIL, we really got
    420 
    +			   ;; directory ".", so make it so.
    421 
    +			   (if (and (equal name ".")
    422 
    +				    (null type))
    423 
    +			       (list :relative)
    424 
    +			       nil))))
    425 
    +		  ;; A file with name "." and type NIL can't be the name
    426 
    +		  ;; of file on Unix because it's a directory.  This was
    427 
    +		  ;; handled above, so we can just set the name to nil.
    428 
    +		  (if (and (equal name ".")
    429 
    +			   (null type))
    430 
    +		      nil
    431 
    +		      name)
    432 
    +		  type
    433 
    +		  version))))))
    403 434
    404 435 
     (defun unparse-unix-host (pathname)
    405 436 
       (declare (type pathname pathname)

  • src/code/os.lisp
    ... ... @@ -58,32 +58,39 @@
    58 58 
     	       (unix:get-unix-error-msg utime)))
    59 59 
           (values utime stime major-fault))))
    60 60
    61 
    -;;; GET-USER-HOMEDIR-PATHNAME  -- Public
    61 
    +;;; GET-USER-HOMEDIR-NAMESTRING  -- Public
    62 62 
     ;;;
    63 
    -(defun get-user-homedir-pathname (name)
    64 
    -  _N"Get the user home directory for user named NAME.  Two values are
    65 
    -  returned: the pathname of the home directory and a status code.  If
    66 
    -  the home directory does not exist NIL is returned.  The status is 0
    67 
    -  if no errors occurred.  Otherwise a non-zero value is returned.
    68 
    -  Examining errno may give information about what failed."
    69 
    -  (alien:with-alien ((status c-call:int))
    70 
    -    (let (result)
    71 
    -      (unwind-protect
    72 
    -           (progn
    73 
    -             (setf result
    74 
    -                   (alien:alien-funcall
    75 
    -                    (alien:extern-alien "os_get_user_homedir"
    76 
    -                                        (function (alien:* c-call:c-string)
    77 
    -                                                  c-call:c-string
    78 
    -                                                  (* c-call:int)))
    79 
    -                    name
    80 
    -                    (alien:addr status)))
    81 
    -             (if (and (zerop status)
    82 
    -                      (not (alien:null-alien result)))
    83 
    -                 (values (pathname
    84 
    -                          (concatenate 'string
    85 
    -                                       (alien:cast result c-call:c-string)
    86 
    -                                       "/"))
    87 
    -                         status)
    88 
    -                 (values nil status)))
    89 
    -        (alien:free-alien result)))))
    63 
    +(defun get-user-homedir-namestring (name)
    64 
    +  _N"Get the user home directory for user named NAME.  If NAME is the empty
    65 
    +  string, the home directory of the current user is returned.
    66 
    +
    67 
    +  Two values are returned: the pathname of the home directory and a
    68 
    +  status code.  If the home directory does not exist NIL is returned.
    69 
    +  The status is 0 if no errors occurred.  Otherwise a non-zero value
    70 
    +  is returned. Examining errno may give information about what failed."
    71 
    +  (cond
    72 
    +    ((zerop (length name))
    73 
    +     (multiple-value-bind (user-info status)
    74 
    +         (unix:unix-getpwuid (unix:unix-getuid))
    75 
    +       (values (when user-info
    76 
    +                 (unix:user-info-dir user-info))
    77 
    +               status)))
    78 
    +    (t
    79 
    +     (alien:with-alien ((status c-call:int))
    80 
    +       (let (result)
    81 
    +         (unwind-protect
    82 
    +              (progn
    83 
    +                (setf result
    84 
    +                      (alien:alien-funcall
    85 
    +                       (alien:extern-alien "os_get_user_homedir"
    86 
    +                                           (function (alien:* c-call:c-string)
    87 
    +                                                     c-call:c-string
    88 
    +                                                     (* c-call:int)))
    89 
    +                       name
    90 
    +                       (alien:addr status)))
    91 
    +                (if (and (zerop status)
    92 
    +                         (not (alien:null-alien result)))
    93 
    +                    (values (alien:cast result c-call:c-string)
    94 
    +                            status)
    95 
    +                    (values nil status)))
    96 
    +           (alien:free-alien result)))))))

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

  • src/i18n/locale/cmucl-os.pot
    ... ... @@ -35,10 +35,12 @@ msgstr ""
    35 35
    36 36 
     #: src/code/os.lisp
    37 37 
     msgid ""
    38 
    -"Get the user home directory for user named NAME.  Two values are\n"
    39 
    -"  returned: the pathname of the home directory and a status code.  If\n"
    40 
    -"  the home directory does not exist NIL is returned.  The status is 0\n"
    41 
    -"  if no errors occurred.  Otherwise a non-zero value is returned.\n"
    42 
    -"  Examining errno may give information about what failed."
    38 
    +"Get the user home directory for user named NAME.  If NAME is the empty\n"
    39 
    +"  string, the home directory of the current user is returned.\n"
    40 
    +"\n"
    41 
    +"  Two values are returned: the pathname of the home directory and a\n"
    42 
    +"  status code.  If the home directory does not exist NIL is returned.\n"
    43 
    +"  The status is 0 if no errors occurred.  Otherwise a non-zero value\n"
    44 
    +"  is returned. Examining errno may give information about what failed."
    43 45 
     msgstr ""
    44 46

  • tests/os.lisp
    ... ... @@ -7,7 +7,7 @@
    7 7 
     (define-test user-homedir.1
    8 8 
       "Test user-homedir"
    9 9 
       (:tag :issues)
    10 
    -  ;; Simple test to see if get-user-homedir-pathname returns the
    10 
    +  ;; Simple test to see if get-user-homedir-namestring returns the
    11 11 
       ;; expected value.  Use getuid and getpwuid to figure out what the
    12 12 
       ;; name and home directory should be.
    13 13 
       (let* ((uid (unix:unix-getuid))
    ... ... @@ -15,15 +15,13 @@
    15 15 
         (assert-true uid)
    16 16 
         (assert-true user-info)
    17 17 
         (let* ((info-dir (unix:user-info-dir user-info))
    18 
    -           (info-name (unix:user-info-name user-info))
    19 
    -           (expected-home-pathname (pathname
    20 
    -                                    (concatenate 'string info-dir "/"))))
    21 
    -      (multiple-value-bind (home-pathname status)
    22 
    -          (system:get-user-homedir-pathname info-name)
    18 
    +           (info-name (unix:user-info-name user-info)))
    19 
    +      (multiple-value-bind (home-namestring status)
    20 
    +          (system:get-user-homedir-namestring info-name)
    23 21 
             (assert-true info-dir)
    24 22 
             (assert-true info-name)
    25 23
    26 
    -        (assert-equal home-pathname expected-home-pathname)
    24 
    +        (assert-equal home-namestring info-dir)
    27 25 
             (assert-eql status 0)))))
    28 26
    29 27 
     (define-test user-homedir.2
    ... ... @@ -33,6 +31,6 @@
    33 31 
       ;; value for a user that does not exist.  Well, we assume such a
    34 32 
       ;; user doesn't exist.
    35 33 
           (multiple-value-bind (home-pathname status)
    36 
    -          (system:get-user-homedir-pathname "zotuserunknown")
    34 
    +          (system:get-user-homedir-namestring "zotuserunknown")
    37 35 
             (assert-eql home-pathname nil)
    38 36 
             (assert-eql status 0)))

  • tests/pathname.lisp
    ... ... @@ -111,3 +111,34 @@
    111 111 
     	  test
    112 112 
     	(assert-equal printed-value (output pathname))
    113 113 
     	(assert-equal namestring (namestring pathname))))))
    114 
    +
    115 
    +(define-test issue.266.pathname-tilde.unknown-user
    116 
    +    (:tag :issues)
    117 
    +  ;; This assumes that there's no user named "zotunknown".
    118 
    +  (assert-error 'simple-error (parse-namestring "~zotunknown/*.*")))
    119 
    +
    120 
    +(define-test issue.266.pathname-tilde.1
    121 
    +    (:tag :issues)
    122 
    +  ;; Simple test for ~ in pathnames.  Get a directory list using
    123 
    +  ;; #P"~/*.*".  This should produce exactly the same list as the
    124 
    +  ;; #search-list P"home:*.*".
    125 
    +  (let ((dir-home (directory #p"home:*.*" :truenamep nil :follow-links nil))
    126 
    +        (dir-tilde (directory #p"~/*.*" :truenamep nil :follow-links nil)))
    127 
    +    (assert-equal dir-tilde dir-home)))
    128 
    +
    129 
    +(define-test issue.266.pathname-tilde.2
    130 
    +    (:tag :issues)
    131 
    +  ;; Simple test for ~ in pathnames.  Get a directory list using
    132 
    +  ;; #P"~user/*.*".  This should produce exactly the same list as the
    133 
    +  ;; #search-list P"home:*.*".  We determine the user name via getuid
    134 
    +  ;; #and getpwuid.
    135 
    +  (let ((user-name (unix:user-info-name (unix:unix-getpwuid (unix:unix-getuid)))))
    136 
    +    (assert-true user-name)
    137 
    +    (let* ((dir-home (directory #p"home:*.*" :truenamep nil :follow-links nil))
    138 
    +
    139 
    +           (dir-tilde (directory (concatenate 'string
    140 
    +                                              "~"
    141 
    +                                              user-name
    142 
    +                                              "/*.*")
    143 
    +                                 :truenamep nil :follow-links nil)))
    144 
    +      (assert-equal dir-tilde dir-home))))

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.common-lisp.net. Manage all notifications · Help