Raymond Toy pushed to branch issue-266-tilde-pathname-support at cmucl / cmucl

Commits:

6 changed files:

Changes:

  • src/code/exports.lisp
    ... ... @@ -2074,6 +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 2078 
     	   "IGNORE-INTERRUPT"
    2078 2079 
     	   "INT-SAP" "INVALIDATE-DESCRIPTOR" "IO-TIMEOUT"
    2079 2080 
     	   "LISP-STREAM" "LONG-FLOAT-RADIX" "LONG-WORDS"

  • src/code/os.lisp
    ... ... @@ -57,3 +57,33 @@
    57 57 
     	(error (intl:gettext "Unix system call getrusage failed: ~A.")
    58 58 
     	       (unix:get-unix-error-msg utime)))
    59 59 
           (values utime stime major-fault))))
    60 
    +
    61 
    +;;; GET-USER-HOMEDIR-PATHNAME  -- Public
    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)))))

  • src/general-info/release-21f.md
    ... ... @@ -38,6 +38,7 @@ public domain.
    38 38 
         * ~~#249~~ Replace LEA instruction with simpler shorter instructions in arithmetic vops for x86
    39 39 
         * ~~#253~~ Block-compile list-to-hashtable and callers
    40 40 
         * ~~#258~~ Remove `get-page-size` from linux-os.lisp
    41 
    +    * ~~#269~~ Add function to get user's home directory
    41 42 
       * Other changes:
    42 43 
       * Improvements to the PCL implementation of CLOS:
    43 44 
       * Changes to building procedure:

  • src/i18n/locale/cmucl-os.pot
    ... ... @@ -33,3 +33,12 @@ msgstr ""
    33 33 
     msgid "Unix system call getrusage failed: ~A."
    34 34 
     msgstr ""
    35 35
    36 
    +#: src/code/os.lisp
    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."
    43 
    +msgstr ""
    44 
    +

  • src/lisp/os-common.c
    ... ... @@ -863,3 +863,74 @@ os_software_version(void)
    863 863
    864 864 
         return result;
    865 865 
     }
    866 
    +
    867 
    +/*
    868 
    + * Return the home directory of the user named NAME.  If the user does
    869 
    + * not exist, returns NULL.  Also returns NULL if the home directory
    870 
    + * cannot be determined for any reason.  The parameter STATUS is 0 if
    871 
    + * getpwnam_r was successful.  Otherwise it is the return value from
    872 
    + * getpwnam_r or -1 if we ran out of memory for the buffer.
    873 
    + */
    874 
    +char *
    875 
    +os_get_user_homedir(const char* name, int *status)
    876 
    +{
    877 
    +    int buflen;
    878 
    +    char *buf = NULL;
    879 
    +    struct passwd pwd;
    880 
    +    struct passwd *result;
    881 
    +
    882 
    +    buflen = sysconf(_SC_GETPW_R_SIZE_MAX);
    883 
    +    /*
    884 
    +     * If sysconf failed, just try some possibly large enough value.
    885 
    +     */
    886 
    +    if (buflen == -1) {
    887 
    +        buflen = 1024;
    888 
    +    }
    889 
    +
    890 
    +    /*
    891 
    +     * sysconf may return a value that is not large enough, so start
    892 
    +     * with the given value and keep increasing it until we reach some
    893 
    +     * upper limit and give up.
    894 
    +     */
    895 
    +    while (buflen <= (1 << 20)) {
    896 
    +        buf = realloc(buf, buflen);
    897 
    +
    898 
    +        if (buf == NULL) {
    899 
    +            *status = -1;
    900 
    +            return NULL;
    901 
    +        }
    902 
    +
    903 
    +        *status = getpwnam_r(name, &pwd, buf, buflen, &result);
    904 
    +
    905 
    +        if (*status == 0) {
    906 
    +            /*
    907 
    +             * Success, or entry was not found.  If found, the result
    908 
    +             * is not NULL.  Return the result or NULL
    909 
    +             */
    910 
    +            char* path = result ? strdup(pwd.pw_dir) : NULL;
    911 
    +            free(buf);
    912 
    +            return path;
    913 
    +        }
    914 
    +
    915 
    +        /*
    916 
    +         * Check errno for ERANGE.  If so, the buffer was too small, so grow it.
    917 
    +         */
    918 
    +        if (errno == ERANGE) {
    919 
    +            buflen *= 2;
    920 
    +        } else {
    921 
    +            /*
    922 
    +             * Some other error.  Just return NULL
    923 
    +             */
    924 
    +            free(buf);
    925 
    +            return NULL;
    926 
    +        }
    927 
    +    }
    928 
    +
    929 
    +    /*
    930 
    +     * Ran out of space.  Just return NULL and set status to -1.
    931 
    +     */
    932 
    +    free(buf);
    933 
    +    *status = -1;
    934 
    +    return NULL;
    935 
    +}
    936 
    +

  • tests/os.lisp
    1 
    +(defpackage :os-tests
    2 
    +  (:use :cl :lisp-unit))
    3 
    +
    4 
    +(in-package "OS-TESTS")
    5 
    +
    6 
    +
    7 
    +(define-test user-homedir.1
    8 
    +  "Test user-homedir"
    9 
    +  (:tag :issues)
    10 
    +  ;; Simple test to see if get-user-homedir-pathname returns the
    11 
    +  ;; expected value.  Use getuid and getpwuid to figure out what the
    12 
    +  ;; name and home directory should be.
    13 
    +  (let* ((uid (unix:unix-getuid))
    14 
    +         (user-info (unix:unix-getpwuid uid)))
    15 
    +    (assert-true uid)
    16 
    +    (assert-true user-info)
    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)
    23 
    +        (assert-true info-dir)
    24 
    +        (assert-true info-name)
    25 
    +
    26 
    +        (assert-equal home-pathname expected-home-pathname)
    27 
    +        (assert-eql status 0)))))
    28 
    +
    29 
    +(define-test user-homedir.2
    30 
    +  "Test user-homedir"
    31 
    +  (:tag :issues)
    32 
    +  ;; Simple test to see if get-user-homedir-pathname returns the expected
    33 
    +  ;; value for a user that does not exist.  Well, we assume such a
    34 
    +  ;; user doesn't exist.
    35 
    +      (multiple-value-bind (home-pathname status)
    36 
    +          (system:get-user-homedir-pathname "zotuserunknown")
    37 
    +        (assert-eql home-pathname nil)
    38 
    +        (assert-eql status 0)))

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