X-Git-Url: https://git.hcoop.net/bpt/guile.git/blobdiff_plain/09831f943c156eb534608ce91225602b42a567e5..8ab3d8a0681777eb329ac533be51d557267ccf32:/libguile/posix.c?ds=sidebyside diff --git a/libguile/posix.c b/libguile/posix.c index 813cda850..8a83a1e7e 100644 --- a/libguile/posix.c +++ b/libguile/posix.c @@ -1,59 +1,47 @@ -/* Copyright (C) 1995, 96, 97, 98, 99, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc. * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, - * Boston, MA 02111-1307 USA - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public + * License as published by the Free Software Foundation; either + * version 2.1 of the License, or (at your option) any later version. * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. + * This library is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. */ + * You should have received a copy of the GNU Lesser General Public + * License along with this library; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ +#if HAVE_CONFIG_H +# include +#endif + +/* Make GNU/Linux libc declare everything it has. */ +#define _GNU_SOURCE #include +#include + #include "libguile/_scm.h" +#include "libguile/dynwind.h" #include "libguile/fports.h" #include "libguile/scmsigs.h" #include "libguile/feature.h" #include "libguile/strings.h" +#include "libguile/srfi-13.h" +#include "libguile/srfi-14.h" #include "libguile/vectors.h" +#include "libguile/lang.h" #include "libguile/validate.h" #include "libguile/posix.h" +#include "libguile/i18n.h" +#include "libguile/threads.h" #ifdef HAVE_STRING_H @@ -86,7 +74,21 @@ extern char *ttyname(); #include #include +#ifdef HAVE_PWD_H #include +#endif +#ifdef HAVE_IO_H +#include +#endif +#ifdef HAVE_WINSOCK2_H +#include +#endif + +#ifdef __MINGW32__ +/* Some defines for Windows here. */ +# include +# define pipe(fd) _pipe (fd, 256, O_BINARY) +#endif /* __MINGW32__ */ #if HAVE_SYS_WAIT_H # include @@ -100,33 +102,43 @@ extern char *ttyname(); #include -extern FILE *popen (); extern char ** environ; +#ifdef HAVE_GRP_H #include +#endif +#ifdef HAVE_SYS_UTSNAME_H #include - -#if HAVE_DIRENT_H -# include -# define NAMLEN(dirent) strlen((dirent)->d_name) -#else -# define dirent direct -# define NAMLEN(dirent) (dirent)->d_namlen -# if HAVE_SYS_NDIR_H -# include -# endif -# if HAVE_SYS_DIR_H -# include -# endif -# if HAVE_NDIR_H -# include -# endif #endif #ifdef HAVE_SETLOCALE #include #endif +#if HAVE_CRYPT_H +# include +#endif + +#ifdef HAVE_NETDB_H +#include /* for MAXHOSTNAMELEN on Solaris */ +#endif + +#ifdef HAVE_SYS_PARAM_H +#include /* for MAXHOSTNAMELEN */ +#endif + +#if HAVE_SYS_RESOURCE_H +# include +#endif + +#if HAVE_SYS_FILE_H +# include +#endif + +#if HAVE_CRT_EXTERNS_H +#include /* for Darwin _NSGetEnviron */ +#endif + /* Some Unix systems don't define these. CPP hair is dangerous, but this seems safe enough... */ #ifndef R_OK @@ -145,6 +157,12 @@ extern char ** environ; #define F_OK 0 #endif +/* No prototype for this on Solaris 10. The man page says it's in + ... but it lies. */ +#if ! HAVE_DECL_SETHOSTNAME +int sethostname (char *name, size_t namelen); +#endif + /* On NextStep, doesn't define struct utime, unless we #define _POSIX_SOURCE before #including it. I think this is less of a kludge than defining struct utimbuf ourselves. */ @@ -162,7 +180,44 @@ extern char ** environ; /* Please don't add any more #includes or #defines here. The hack above means that _POSIX_SOURCE may be #defined, which will - encourage header files to do strange things. */ + encourage header files to do strange things. + + FIXME: Maybe should undef _POSIX_SOURCE after it's done its job. + + FIXME: Probably should do all the includes first, then all the fallback + declarations and defines, in case things are not in the header we + imagine. */ + + + + +/* On Apple Darwin in a shared library there's no "environ" to access + directly, instead the address of that variable must be obtained with + _NSGetEnviron(). */ +#if HAVE__NSGETENVIRON && defined (PIC) +#define environ (*_NSGetEnviron()) +#endif + + + +/* Two often used patterns + */ + +#define WITH_STRING(str,cstr,code) \ + do { \ + char *cstr = scm_to_locale_string (str); \ + code; \ + free (cstr); \ + } while (0) + +#define STRING_SYSCALL(str,cstr,code) \ + do { \ + int eno; \ + char *cstr = scm_to_locale_string (str); \ + SCM_SYSCALL (code); \ + eno = errno; free (cstr); errno = eno; \ + } while (0) + SCM_SYMBOL (sym_read_pipe, "read pipe"); @@ -170,19 +225,19 @@ SCM_SYMBOL (sym_write_pipe, "write pipe"); SCM_DEFINE (scm_pipe, "pipe", 0, 0, 0, (), - "Returns a newly created pipe: a pair of ports which are linked\n" - "together on the local machine. The CAR is the input port and\n" - "the CDR is the output port. Data written (and flushed) to the\n" - "output port can be read from the input port.\n" - "Pipes are commonly used for communication with a newly\n" - "forked child process. The need to flush the output port\n" - "can be avoided by making it unbuffered using @code{setvbuf}.\n\n" - "Writes occur atomically provided the size of the data in\n" - "bytes is not greater than the value of @code{PIPE_BUF}\n" - "Note that the output port is likely to block if too much data\n" - "(typically equal to @code{PIPE_BUF}) has been written but not\n" - "yet read from the input port\n" - ) + "Return a newly created pipe: a pair of ports which are linked\n" + "together on the local machine. The @emph{car} is the input\n" + "port and the @emph{cdr} is the output port. Data written (and\n" + "flushed) to the output port can be read from the input port.\n" + "Pipes are commonly used for communication with a newly forked\n" + "child process. The need to flush the output port can be\n" + "avoided by making it unbuffered using @code{setvbuf}.\n" + "\n" + "Writes occur atomically provided the size of the data in bytes\n" + "is not greater than the value of @code{PIPE_BUF}. Note that\n" + "the output port is likely to block if too much data (typically\n" + "equal to @code{PIPE_BUF}) has been written but not yet read\n" + "from the input port.") #define FUNC_NAME s_scm_pipe { int fd[2], rv; @@ -202,41 +257,85 @@ SCM_DEFINE (scm_pipe, "pipe", 0, 0, 0, #ifdef HAVE_GETGROUPS SCM_DEFINE (scm_getgroups, "getgroups", 0, 0, 0, (), - "Returns a vector of integers representing the current supplimentary group IDs.") + "Return a vector of integers representing the current\n" + "supplementary group IDs.") #define FUNC_NAME s_scm_getgroups { - SCM grps, ans; - int ngroups = getgroups (0, NULL); - if (!ngroups) + SCM result; + int ngroups; + size_t size; + GETGROUPS_T *groups; + + ngroups = getgroups (0, NULL); + if (ngroups <= 0) SCM_SYSERROR; - SCM_NEWCELL(grps); - SCM_DEFER_INTS; - { - GETGROUPS_T *groups; - int val; - groups = SCM_MUST_MALLOC_TYPE_NUM(GETGROUPS_T,ngroups); - val = getgroups(ngroups, groups); - if (val < 0) - { - int en = errno; - scm_must_free((char *)groups); - errno = en; - SCM_SYSERROR; - } - SCM_SETCHARS(grps, groups); /* set up grps as a GC protect */ - SCM_SETLENGTH(grps, 0L + ngroups * sizeof(GETGROUPS_T), scm_tc7_string); - ans = scm_make_vector (SCM_MAKINUM(ngroups), SCM_UNDEFINED); - while (--ngroups >= 0) SCM_VELTS(ans)[ngroups] = SCM_MAKINUM(groups[ngroups]); - SCM_SETCHARS(grps, groups); /* to make sure grps stays around. */ - SCM_ALLOW_INTS; - return ans; - } + size = ngroups * sizeof (GETGROUPS_T); + groups = scm_malloc (size); + getgroups (ngroups, groups); + + result = scm_c_make_vector (ngroups, SCM_BOOL_F); + while (--ngroups >= 0) + SCM_SIMPLE_VECTOR_SET (result, ngroups, scm_from_ulong (groups[ngroups])); + + free (groups); + return result; } #undef FUNC_NAME #endif +#ifdef HAVE_SETGROUPS +SCM_DEFINE (scm_setgroups, "setgroups", 1, 0, 0, + (SCM group_vec), + "Set the current set of supplementary group IDs to the integers\n" + "in the given vector @var{vec}. The return value is\n" + "unspecified.\n" + "\n" + "Generally only the superuser can set the process group IDs.") +#define FUNC_NAME s_scm_setgroups +{ + size_t ngroups; + size_t size; + size_t i; + int result; + int save_errno; + GETGROUPS_T *groups; + + SCM_VALIDATE_VECTOR (SCM_ARG1, group_vec); + + ngroups = SCM_SIMPLE_VECTOR_LENGTH (group_vec); + /* validate before allocating, so we don't have to worry about leaks */ + for (i = 0; i < ngroups; i++) + { + unsigned long ulong_gid; + GETGROUPS_T gid; + SCM_VALIDATE_ULONG_COPY (1, SCM_SIMPLE_VECTOR_REF (group_vec, i), + ulong_gid); + gid = ulong_gid; + if (gid != ulong_gid) + SCM_OUT_OF_RANGE (1, SCM_SIMPLE_VECTOR_REF (group_vec, i)); + } + + size = ngroups * sizeof (GETGROUPS_T); + if (size / sizeof (GETGROUPS_T) != ngroups) + SCM_OUT_OF_RANGE (SCM_ARG1, scm_from_int (ngroups)); + groups = scm_malloc (size); + for(i = 0; i < ngroups; i++) + groups [i] = SCM_NUM2ULONG (1, SCM_SIMPLE_VECTOR_REF (group_vec, i)); + + result = setgroups (ngroups, groups); + save_errno = errno; /* don't let free() touch errno */ + free (groups); + errno = save_errno; + if (result < 0) + SCM_SYSERROR; + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME +#endif + +#ifdef HAVE_GETPWENT SCM_DEFINE (scm_getpwuid, "getpw", 0, 1, 0, (SCM user), "Look up an entry in the user database. @var{obj} can be an integer,\n" @@ -244,13 +343,10 @@ SCM_DEFINE (scm_getpwuid, "getpw", 0, 1, 0, "or getpwent respectively.") #define FUNC_NAME s_scm_getpwuid { - SCM result; struct passwd *entry; - SCM *ve; - result = scm_make_vector (SCM_MAKINUM (7), SCM_UNSPECIFIED); - ve = SCM_VELTS (result); - if (SCM_UNBNDP (user) || SCM_FALSEP (user)) + SCM result = scm_c_make_vector (7, SCM_UNSPECIFIED); + if (SCM_UNBNDP (user) || scm_is_false (user)) { SCM_SYSCALL (entry = getpwent ()); if (! entry) @@ -258,36 +354,35 @@ SCM_DEFINE (scm_getpwuid, "getpw", 0, 1, 0, return SCM_BOOL_F; } } - else if (SCM_INUMP (user)) + else if (scm_is_integer (user)) { - entry = getpwuid (SCM_INUM (user)); + entry = getpwuid (scm_to_int (user)); } else { - SCM_VALIDATE_ROSTRING (1,user); - if (SCM_SUBSTRP (user)) - user = scm_makfromstr (SCM_ROCHARS (user), SCM_ROLENGTH (user), 0); - entry = getpwnam (SCM_ROCHARS (user)); + WITH_STRING (user, c_user, + entry = getpwnam (c_user)); } if (!entry) SCM_MISC_ERROR ("entry not found", SCM_EOL); - ve[0] = scm_makfrom0str (entry->pw_name); - ve[1] = scm_makfrom0str (entry->pw_passwd); - ve[2] = scm_ulong2num ((unsigned long) entry->pw_uid); - ve[3] = scm_ulong2num ((unsigned long) entry->pw_gid); - ve[4] = scm_makfrom0str (entry->pw_gecos); + SCM_SIMPLE_VECTOR_SET(result, 0, scm_from_locale_string (entry->pw_name)); + SCM_SIMPLE_VECTOR_SET(result, 1, scm_from_locale_string (entry->pw_passwd)); + SCM_SIMPLE_VECTOR_SET(result, 2, scm_from_ulong (entry->pw_uid)); + SCM_SIMPLE_VECTOR_SET(result, 3, scm_from_ulong (entry->pw_gid)); + SCM_SIMPLE_VECTOR_SET(result, 4, scm_from_locale_string (entry->pw_gecos)); if (!entry->pw_dir) - ve[5] = scm_makfrom0str (""); + SCM_SIMPLE_VECTOR_SET(result, 5, scm_from_locale_string ("")); else - ve[5] = scm_makfrom0str (entry->pw_dir); + SCM_SIMPLE_VECTOR_SET(result, 5, scm_from_locale_string (entry->pw_dir)); if (!entry->pw_shell) - ve[6] = scm_makfrom0str (""); + SCM_SIMPLE_VECTOR_SET(result, 6, scm_from_locale_string ("")); else - ve[6] = scm_makfrom0str (entry->pw_shell); + SCM_SIMPLE_VECTOR_SET(result, 6, scm_from_locale_string (entry->pw_shell)); return result; } #undef FUNC_NAME +#endif /* HAVE_GETPWENT */ #ifdef HAVE_SETPWENT @@ -298,7 +393,7 @@ SCM_DEFINE (scm_setpwent, "setpw", 0, 1, 0, "@code{endpwent} procedures are implemented on top of this.") #define FUNC_NAME s_scm_setpwent { - if (SCM_UNBNDP (arg) || SCM_FALSEP (arg)) + if (SCM_UNBNDP (arg) || scm_is_false (arg)) endpwent (); else setpwent (); @@ -308,7 +403,7 @@ SCM_DEFINE (scm_setpwent, "setpw", 0, 1, 0, #endif - +#ifdef HAVE_GETGRENT /* Combines getgrgid and getgrnam. */ SCM_DEFINE (scm_getgrgid, "getgr", 0, 1, 0, (SCM name), @@ -317,12 +412,10 @@ SCM_DEFINE (scm_getgrgid, "getgr", 0, 1, 0, "or getgrent respectively.") #define FUNC_NAME s_scm_getgrgid { - SCM result; struct group *entry; - SCM *ve; - result = scm_make_vector (SCM_MAKINUM (4), SCM_UNSPECIFIED); - ve = SCM_VELTS (result); - if (SCM_UNBNDP (name) || SCM_FALSEP (name)) + SCM result = scm_c_make_vector (4, SCM_UNSPECIFIED); + + if (SCM_UNBNDP (name) || scm_is_false (name)) { SCM_SYSCALL (entry = getgrent ()); if (! entry) @@ -330,21 +423,18 @@ SCM_DEFINE (scm_getgrgid, "getgr", 0, 1, 0, return SCM_BOOL_F; } } - else if (SCM_INUMP (name)) - SCM_SYSCALL (entry = getgrgid (SCM_INUM (name))); + else if (scm_is_integer (name)) + SCM_SYSCALL (entry = getgrgid (scm_to_int (name))); else - { - SCM_VALIDATE_ROSTRING (1,name); - SCM_COERCE_SUBSTR (name); - SCM_SYSCALL (entry = getgrnam (SCM_ROCHARS (name))); - } + STRING_SYSCALL (name, c_name, + entry = getgrnam (c_name)); if (!entry) SCM_SYSERROR; - ve[0] = scm_makfrom0str (entry->gr_name); - ve[1] = scm_makfrom0str (entry->gr_passwd); - ve[2] = scm_ulong2num ((unsigned long) entry->gr_gid); - ve[3] = scm_makfromstrs (-1, entry->gr_mem); + SCM_SIMPLE_VECTOR_SET(result, 0, scm_from_locale_string (entry->gr_name)); + SCM_SIMPLE_VECTOR_SET(result, 1, scm_from_locale_string (entry->gr_passwd)); + SCM_SIMPLE_VECTOR_SET(result, 2, scm_from_ulong (entry->gr_gid)); + SCM_SIMPLE_VECTOR_SET(result, 3, scm_makfromstrs (-1, entry->gr_mem)); return result; } #undef FUNC_NAME @@ -358,14 +448,14 @@ SCM_DEFINE (scm_setgrent, "setgr", 0, 1, 0, "@code{endgrent} procedures are implemented on top of this.") #define FUNC_NAME s_scm_setgrent { - if (SCM_UNBNDP (arg) || SCM_FALSEP (arg)) + if (SCM_UNBNDP (arg) || scm_is_false (arg)) endgrent (); else setgrent (); return SCM_UNSPECIFIED; } #undef FUNC_NAME - +#endif /* HAVE_GETGRENT */ SCM_DEFINE (scm_kill, "kill", 2, 0, 0, @@ -394,11 +484,14 @@ SCM_DEFINE (scm_kill, "kill", 2, 0, 0, "@end defvar") #define FUNC_NAME s_scm_kill { - SCM_VALIDATE_INUM (1,pid); - SCM_VALIDATE_INUM (2,sig); /* Signal values are interned in scm_init_posix(). */ - if (kill ((int) SCM_INUM (pid), (int) SCM_INUM (sig)) != 0) - SCM_SYSERROR; +#ifdef HAVE_KILL + if (kill (scm_to_int (pid), scm_to_int (sig)) != 0) +#else + if (scm_to_int (pid) == getpid ()) + if (raise (scm_to_int (sig)) != 0) +#endif + SCM_SYSERROR; return SCM_UNSPECIFIED; } #undef FUNC_NAME @@ -445,39 +538,36 @@ SCM_DEFINE (scm_waitpid, "waitpid", 1, 1, 0, int i; int status; int ioptions; - SCM_VALIDATE_INUM (1,pid); if (SCM_UNBNDP (options)) ioptions = 0; else { - SCM_VALIDATE_INUM (2,options); /* Flags are interned in scm_init_posix. */ - ioptions = SCM_INUM (options); + ioptions = scm_to_int (options); } - SCM_SYSCALL (i = waitpid (SCM_INUM (pid), &status, ioptions)); + SCM_SYSCALL (i = waitpid (scm_to_int (pid), &status, ioptions)); if (i == -1) SCM_SYSERROR; - return scm_cons (SCM_MAKINUM (0L + i), SCM_MAKINUM (0L + status)); + return scm_cons (scm_from_int (i), scm_from_int (status)); } #undef FUNC_NAME #endif /* HAVE_WAITPID */ +#ifndef __MINGW32__ SCM_DEFINE (scm_status_exit_val, "status:exit-val", 1, 0, 0, (SCM status), - "Returns the exit status value, as would be\n" - "set if a process ended normally through a\n" - "call to @code{exit} or @code{_exit}, if any, otherwise @code{#f}.") + "Return the exit status value, as would be set if a process\n" + "ended normally through a call to @code{exit} or @code{_exit},\n" + "if any, otherwise @code{#f}.") #define FUNC_NAME s_scm_status_exit_val { int lstatus; - SCM_VALIDATE_INUM (1,status); - /* On Ultrix, the WIF... macros assume their argument is an lvalue; - go figure. SCM_INUM does not yield an lvalue. */ - lstatus = SCM_INUM (status); + go figure. */ + lstatus = scm_to_int (status); if (WIFEXITED (lstatus)) - return (SCM_MAKINUM (WEXITSTATUS (lstatus))); + return (scm_from_int (WEXITSTATUS (lstatus))); else return SCM_BOOL_F; } @@ -485,17 +575,15 @@ SCM_DEFINE (scm_status_exit_val, "status:exit-val", 1, 0, 0, SCM_DEFINE (scm_status_term_sig, "status:term-sig", 1, 0, 0, (SCM status), - "Returns the signal number which terminated the\n" - "process, if any, otherwise @code{#f}.") + "Return the signal number which terminated the process, if any,\n" + "otherwise @code{#f}.") #define FUNC_NAME s_scm_status_term_sig { int lstatus; - SCM_VALIDATE_INUM (1,status); - - lstatus = SCM_INUM (status); + lstatus = scm_to_int (status); if (WIFSIGNALED (lstatus)) - return SCM_MAKINUM (WTERMSIG (lstatus)); + return scm_from_int (WTERMSIG (lstatus)); else return SCM_BOOL_F; } @@ -503,39 +591,41 @@ SCM_DEFINE (scm_status_term_sig, "status:term-sig", 1, 0, 0, SCM_DEFINE (scm_status_stop_sig, "status:stop-sig", 1, 0, 0, (SCM status), - "Returns the signal number which stopped the\n" - "process, if any, otherwise @code{#f}.") + "Return the signal number which stopped the process, if any,\n" + "otherwise @code{#f}.") #define FUNC_NAME s_scm_status_stop_sig { int lstatus; - SCM_VALIDATE_INUM (1,status); - - lstatus = SCM_INUM (status); + lstatus = scm_to_int (status); if (WIFSTOPPED (lstatus)) - return SCM_MAKINUM (WSTOPSIG (lstatus)); + return scm_from_int (WSTOPSIG (lstatus)); else return SCM_BOOL_F; } #undef FUNC_NAME +#endif /* __MINGW32__ */ +#ifdef HAVE_GETPPID SCM_DEFINE (scm_getppid, "getppid", 0, 0, 0, (), - "Returns an integer representing the process ID of the parent process.") + "Return an integer representing the process ID of the parent\n" + "process.") #define FUNC_NAME s_scm_getppid { - return SCM_MAKINUM (0L + getppid ()); + return scm_from_int (getppid ()); } #undef FUNC_NAME +#endif /* HAVE_GETPPID */ - +#ifndef __MINGW32__ SCM_DEFINE (scm_getuid, "getuid", 0, 0, 0, (), - "Returns an integer representing the current real user ID.") + "Return an integer representing the current real user ID.") #define FUNC_NAME s_scm_getuid { - return SCM_MAKINUM (0L + getuid ()); + return scm_from_int (getuid ()); } #undef FUNC_NAME @@ -543,10 +633,10 @@ SCM_DEFINE (scm_getuid, "getuid", 0, 0, 0, SCM_DEFINE (scm_getgid, "getgid", 0, 0, 0, (), - "Returns an integer representing the current real group ID.") + "Return an integer representing the current real group ID.") #define FUNC_NAME s_scm_getgid { - return SCM_MAKINUM (0L + getgid ()); + return scm_from_int (getgid ()); } #undef FUNC_NAME @@ -554,34 +644,33 @@ SCM_DEFINE (scm_getgid, "getgid", 0, 0, 0, SCM_DEFINE (scm_geteuid, "geteuid", 0, 0, 0, (), - "Returns an integer representing the current effective user ID.\n" + "Return an integer representing the current effective user ID.\n" "If the system does not support effective IDs, then the real ID\n" - "is returned. @code{(feature? 'EIDs)} reports whether the system\n" - "supports effective IDs.") + "is returned. @code{(provided? 'EIDs)} reports whether the\n" + "system supports effective IDs.") #define FUNC_NAME s_scm_geteuid { #ifdef HAVE_GETEUID - return SCM_MAKINUM (0L + geteuid ()); + return scm_from_int (geteuid ()); #else - return SCM_MAKINUM (0L + getuid ()); + return scm_from_int (getuid ()); #endif } #undef FUNC_NAME - SCM_DEFINE (scm_getegid, "getegid", 0, 0, 0, (), - "Returns an integer representing the current effective group ID.\n" + "Return an integer representing the current effective group ID.\n" "If the system does not support effective IDs, then the real ID\n" - "is returned. @code{(feature? 'EIDs)} reports whether the system\n" - "supports effective IDs.") + "is returned. @code{(provided? 'EIDs)} reports whether the\n" + "system supports effective IDs.") #define FUNC_NAME s_scm_getegid { #ifdef HAVE_GETEUID - return SCM_MAKINUM (0L + getegid ()); + return scm_from_int (getegid ()); #else - return SCM_MAKINUM (0L + getgid ()); + return scm_from_int (getgid ()); #endif } #undef FUNC_NAME @@ -594,8 +683,7 @@ SCM_DEFINE (scm_setuid, "setuid", 1, 0, 0, "The return value is unspecified.") #define FUNC_NAME s_scm_setuid { - SCM_VALIDATE_INUM (1,id); - if (setuid (SCM_INUM (id)) != 0) + if (setuid (scm_to_int (id)) != 0) SCM_SYSERROR; return SCM_UNSPECIFIED; } @@ -608,8 +696,7 @@ SCM_DEFINE (scm_setgid, "setgid", 1, 0, 0, "The return value is unspecified.") #define FUNC_NAME s_scm_setgid { - SCM_VALIDATE_INUM (1,id); - if (setgid (SCM_INUM (id)) != 0) + if (setgid (scm_to_int (id)) != 0) SCM_SYSERROR; return SCM_UNSPECIFIED; } @@ -619,42 +706,42 @@ SCM_DEFINE (scm_seteuid, "seteuid", 1, 0, 0, (SCM id), "Sets the effective user ID to the integer @var{id}, provided the process\n" "has appropriate privileges. If effective IDs are not supported, the\n" - "real ID is set instead -- @code{(feature? 'EIDs)} reports whether the\n" + "real ID is set instead -- @code{(provided? 'EIDs)} reports whether the\n" "system supports effective IDs.\n" "The return value is unspecified.") #define FUNC_NAME s_scm_seteuid { int rv; - SCM_VALIDATE_INUM (1,id); #ifdef HAVE_SETEUID - rv = seteuid (SCM_INUM (id)); + rv = seteuid (scm_to_int (id)); #else - rv = setuid (SCM_INUM (id)); + rv = setuid (scm_to_int (id)); #endif if (rv != 0) SCM_SYSERROR; return SCM_UNSPECIFIED; } #undef FUNC_NAME +#endif /* __MINGW32__ */ + #ifdef HAVE_SETEGID SCM_DEFINE (scm_setegid, "setegid", 1, 0, 0, (SCM id), "Sets the effective group ID to the integer @var{id}, provided the process\n" "has appropriate privileges. If effective IDs are not supported, the\n" - "real ID is set instead -- @code{(feature? 'EIDs)} reports whether the\n" + "real ID is set instead -- @code{(provided? 'EIDs)} reports whether the\n" "system supports effective IDs.\n" "The return value is unspecified.") #define FUNC_NAME s_scm_setegid { int rv; - SCM_VALIDATE_INUM (1,id); #ifdef HAVE_SETEUID - rv = setegid (SCM_INUM (id)); + rv = setegid (scm_to_int (id)); #else - rv = setgid (SCM_INUM (id)); + rv = setgid (scm_to_int (id)); #endif if (rv != 0) SCM_SYSERROR; @@ -664,17 +751,21 @@ SCM_DEFINE (scm_setegid, "setegid", 1, 0, 0, #undef FUNC_NAME #endif + +#ifdef HAVE_GETPGRP SCM_DEFINE (scm_getpgrp, "getpgrp", 0, 0, 0, (), - "Returns an integer representing the current process group ID.\n" + "Return an integer representing the current process group ID.\n" "This is the POSIX definition, not BSD.") #define FUNC_NAME s_scm_getpgrp { int (*fn)(); fn = (int (*) ()) getpgrp; - return SCM_MAKINUM (fn (0)); + return scm_from_int (fn (0)); } #undef FUNC_NAME +#endif /* HAVE_GETPGRP */ + #ifdef HAVE_SETPGID SCM_DEFINE (scm_setpgid, "setpgid", 2, 0, 0, @@ -686,10 +777,8 @@ SCM_DEFINE (scm_setpgid, "setpgid", 2, 0, 0, "The return value is unspecified.") #define FUNC_NAME s_scm_setpgid { - SCM_VALIDATE_INUM (1,pid); - SCM_VALIDATE_INUM (2,pgid); /* FIXME(?): may be known as setpgrp. */ - if (setpgid (SCM_INUM (pid), SCM_INUM (pgid)) != 0) + if (setpgid (scm_to_int (pid), scm_to_int (pgid)) != 0) SCM_SYSERROR; return SCM_UNSPECIFIED; } @@ -713,39 +802,66 @@ SCM_DEFINE (scm_setsid, "setsid", 0, 0, 0, #undef FUNC_NAME #endif /* HAVE_SETSID */ + +/* ttyname returns its result in a single static buffer, hence + scm_i_misc_mutex for thread safety. In glibc 2.3.2 two threads + continuously calling ttyname will otherwise get an overwrite quite + easily. + + ttyname_r (when available) could be used instead of scm_i_misc_mutex, but + there's probably little to be gained in either speed or parallelism. */ + +#ifdef HAVE_TTYNAME SCM_DEFINE (scm_ttyname, "ttyname", 1, 0, 0, (SCM port), - "Returns a string with the name of the serial terminal device underlying\n" - "@var{port}.") + "Return a string with the name of the serial terminal device\n" + "underlying @var{port}.") #define FUNC_NAME s_scm_ttyname { - char *ans; - int fd; + char *result; + int fd, err; + SCM ret; port = SCM_COERCE_OUTPORT (port); - SCM_VALIDATE_OPPORT (1,port); - if (scm_tc16_fport != SCM_TYP16 (port)) + SCM_VALIDATE_OPPORT (1, port); + if (!SCM_FPORTP (port)) return SCM_BOOL_F; fd = SCM_FPORT_FDES (port); - SCM_SYSCALL (ans = ttyname (fd)); - if (!ans) - SCM_SYSERROR; - /* ans could be overwritten by another call to ttyname */ - return (scm_makfrom0str (ans)); + + scm_i_scm_pthread_mutex_lock (&scm_i_misc_mutex); + SCM_SYSCALL (result = ttyname (fd)); + err = errno; + ret = scm_from_locale_string (result); + scm_i_pthread_mutex_unlock (&scm_i_misc_mutex); + + if (!result) + { + errno = err; + SCM_SYSERROR; + } + return ret; } #undef FUNC_NAME +#endif /* HAVE_TTYNAME */ + +/* For thread safety "buf" is used instead of NULL for the ctermid static + buffer. Actually it's unlikely the controlling terminal will change + during program execution, and indeed on glibc (2.3.2) it's always just + "/dev/tty", but L_ctermid on the stack is easy and fast and guarantees + safety everywhere. */ #ifdef HAVE_CTERMID SCM_DEFINE (scm_ctermid, "ctermid", 0, 0, 0, (), - "Returns a string containing the file name of the controlling terminal\n" - "for the current process.") + "Return a string containing the file name of the controlling\n" + "terminal for the current process.") #define FUNC_NAME s_scm_ctermid { - char *result = ctermid (NULL); + char buf[L_ctermid]; + char *result = ctermid (buf); if (*result == '\0') SCM_SYSERROR; - return scm_makfrom0str (result); + return scm_from_locale_string (result); } #undef FUNC_NAME #endif /* HAVE_CTERMID */ @@ -753,9 +869,10 @@ SCM_DEFINE (scm_ctermid, "ctermid", 0, 0, 0, #ifdef HAVE_TCGETPGRP SCM_DEFINE (scm_tcgetpgrp, "tcgetpgrp", 1, 0, 0, (SCM port), - "Returns the process group ID of the foreground\n" - "process group associated with the terminal open on the file descriptor\n" - "underlying @var{port}.\n\n" + "Return the process group ID of the foreground process group\n" + "associated with the terminal open on the file descriptor\n" + "underlying @var{port}.\n" + "\n" "If there is no foreground process group, the return value is a\n" "number greater than 1 that does not match the process group ID\n" "of any existing process group. This can happen if all of the\n" @@ -769,11 +886,11 @@ SCM_DEFINE (scm_tcgetpgrp, "tcgetpgrp", 1, 0, 0, port = SCM_COERCE_OUTPORT (port); - SCM_VALIDATE_OPFPORT (1,port); + SCM_VALIDATE_OPFPORT (1, port); fd = SCM_FPORT_FDES (port); if ((pgid = tcgetpgrp (fd)) == -1) SCM_SYSERROR; - return SCM_MAKINUM (pgid); + return scm_from_int (pgid); } #undef FUNC_NAME #endif /* HAVE_TCGETPGRP */ @@ -792,67 +909,56 @@ SCM_DEFINE (scm_tcsetpgrp, "tcsetpgrp", 2, 0, 0, port = SCM_COERCE_OUTPORT (port); - SCM_VALIDATE_OPFPORT (1,port); - SCM_VALIDATE_INUM (2,pgid); + SCM_VALIDATE_OPFPORT (1, port); fd = SCM_FPORT_FDES (port); - if (tcsetpgrp (fd, SCM_INUM (pgid)) == -1) + if (tcsetpgrp (fd, scm_to_int (pgid)) == -1) SCM_SYSERROR; return SCM_UNSPECIFIED; } #undef FUNC_NAME #endif /* HAVE_TCSETPGRP */ -/* Copy exec args from an SCM vector into a new C array. */ - -static char ** -scm_convert_exec_args (SCM args, int pos, const char *subr) +static void +free_string_pointers (void *data) { - char **execargv; - int num_args; - int i; - - num_args = scm_ilength (args); - SCM_ASSERT (num_args >= 0, args, pos, subr); - execargv = (char **) - scm_must_malloc ((num_args + 1) * sizeof (char *), subr); - for (i = 0; !SCM_NULLP (args); args = SCM_CDR (args), ++i) - { - scm_sizet len; - char *dst; - char *src; - SCM_ASSERT (SCM_ROSTRINGP (SCM_CAR (args)), - SCM_CAR (args), SCM_ARGn, subr); - len = 1 + SCM_ROLENGTH (SCM_CAR (args)); - dst = (char *) scm_must_malloc ((long) len, subr); - src = SCM_ROCHARS (SCM_CAR (args)); - while (len--) - dst[len] = src[len]; - execargv[i] = dst; - } - execargv[i] = 0; - return execargv; + scm_i_free_string_pointers ((char **)data); } SCM_DEFINE (scm_execl, "execl", 1, 0, 1, (SCM filename, SCM args), "Executes the file named by @var{path} as a new process image.\n" "The remaining arguments are supplied to the process; from a C program\n" - "they are accessable as the @code{argv} argument to @code{main}.\n" + "they are accessible as the @code{argv} argument to @code{main}.\n" "Conventionally the first @var{arg} is the same as @var{path}.\n" - "All arguments must be strings. \n\n" + "All arguments must be strings.\n\n" "If @var{arg} is missing, @var{path} is executed with a null\n" "argument list, which may have system-dependent side-effects.\n\n" "This procedure is currently implemented using the @code{execv} system\n" "call, but we call it @code{execl} because of its Scheme calling interface.") #define FUNC_NAME s_scm_execl { - char **execargv; - SCM_VALIDATE_ROSTRING (1,filename); - SCM_COERCE_SUBSTR (filename); - execargv = scm_convert_exec_args (args, SCM_ARG2, FUNC_NAME); - execv (SCM_ROCHARS (filename), execargv); + char *exec_file; + char **exec_argv; + + scm_dynwind_begin (0); + + exec_file = scm_to_locale_string (filename); + scm_dynwind_free (exec_file); + + exec_argv = scm_i_allocate_string_pointers (args); + scm_dynwind_unwind_handler (free_string_pointers, exec_argv, + SCM_F_WIND_EXPLICITLY); + + execv (exec_file, +#ifdef __MINGW32__ + /* extra "const" in mingw formals, provokes warning from gcc */ + (const char * const *) +#endif + exec_argv); SCM_SYSERROR; + /* not reached. */ + scm_dynwind_end (); return SCM_BOOL_F; } #undef FUNC_NAME @@ -867,50 +973,35 @@ SCM_DEFINE (scm_execlp, "execlp", 1, 0, 1, "call, but we call it @code{execlp} because of its Scheme calling interface.") #define FUNC_NAME s_scm_execlp { - char **execargv; - SCM_VALIDATE_ROSTRING (1,filename); - SCM_COERCE_SUBSTR (filename); - execargv = scm_convert_exec_args (args, SCM_ARG2, FUNC_NAME); - execvp (SCM_ROCHARS (filename), execargv); + char *exec_file; + char **exec_argv; + + scm_dynwind_begin (0); + + exec_file = scm_to_locale_string (filename); + scm_dynwind_free (exec_file); + + exec_argv = scm_i_allocate_string_pointers (args); + scm_dynwind_unwind_handler (free_string_pointers, exec_argv, + SCM_F_WIND_EXPLICITLY); + + execvp (exec_file, +#ifdef __MINGW32__ + /* extra "const" in mingw formals, provokes warning from gcc */ + (const char * const *) +#endif + exec_argv); SCM_SYSERROR; + /* not reached. */ + scm_dynwind_end (); return SCM_BOOL_F; } #undef FUNC_NAME -static char ** -environ_list_to_c (SCM envlist, int arg, const char *proc) -{ - int num_strings; - char **result; - int i = 0; - - SCM_ASSERT (SCM_NULLP (envlist) || SCM_CONSP (envlist), - envlist, arg, proc); - num_strings = scm_ilength (envlist); - result = (char **) malloc ((num_strings + 1) * sizeof (char *)); - if (result == NULL) - scm_memory_error (proc); - while (SCM_NNULLP (envlist)) - { - int len; - char *src; - - SCM_ASSERT (SCM_ROSTRINGP (SCM_CAR (envlist)), - envlist, arg, proc); - len = 1 + SCM_ROLENGTH (SCM_CAR (envlist)); - result[i] = malloc ((long) len); - if (result[i] == NULL) - scm_memory_error (proc); - src = SCM_ROCHARS (SCM_CAR (envlist)); - while (len--) - result[i][len] = src[len]; - envlist = SCM_CDR (envlist); - i++; - } - result[i] = 0; - return result; -} + +/* OPTIMIZE-ME: scm_execle doesn't need malloced copies of the environment + list strings the way environ_list_to_c gives. */ SCM_DEFINE (scm_execle, "execle", 2, 0, 1, (SCM filename, SCM env, SCM args), @@ -921,21 +1012,43 @@ SCM_DEFINE (scm_execle, "execle", 2, 0, 1, "call, but we call it @code{execle} because of its Scheme calling interface.") #define FUNC_NAME s_scm_execle { - char **execargv; + char **exec_argv; char **exec_env; + char *exec_file; - SCM_VALIDATE_ROSTRING (1,filename); - SCM_COERCE_SUBSTR (filename); - - execargv = scm_convert_exec_args (args, SCM_ARG1, FUNC_NAME); - exec_env = environ_list_to_c (env, SCM_ARG2, FUNC_NAME); - execve (SCM_ROCHARS (filename), execargv, exec_env); + scm_dynwind_begin (0); + + exec_file = scm_to_locale_string (filename); + scm_dynwind_free (exec_file); + + exec_argv = scm_i_allocate_string_pointers (args); + scm_dynwind_unwind_handler (free_string_pointers, exec_argv, + SCM_F_WIND_EXPLICITLY); + + exec_env = scm_i_allocate_string_pointers (env); + scm_dynwind_unwind_handler (free_string_pointers, exec_env, + SCM_F_WIND_EXPLICITLY); + + execve (exec_file, +#ifdef __MINGW32__ + /* extra "const" in mingw formals, provokes warning from gcc */ + (const char * const *) +#endif + exec_argv, +#ifdef __MINGW32__ + /* extra "const" in mingw formals, provokes warning from gcc */ + (const char * const *) +#endif + exec_env); SCM_SYSERROR; + /* not reached. */ + scm_dynwind_end (); return SCM_BOOL_F; } #undef FUNC_NAME +#ifdef HAVE_FORK SCM_DEFINE (scm_fork, "primitive-fork", 0, 0, 0, (), "Creates a new \"child\" process by duplicating the current \"parent\" process.\n" @@ -949,44 +1062,49 @@ SCM_DEFINE (scm_fork, "primitive-fork", 0, 0, 0, pid = fork (); if (pid == -1) SCM_SYSERROR; - return SCM_MAKINUM (0L+pid); + return scm_from_int (pid); } #undef FUNC_NAME +#endif /* HAVE_FORK */ + +#ifdef __MINGW32__ +# include "win32-uname.h" +#endif -#ifdef HAVE_UNAME +#if defined (HAVE_UNAME) || defined (__MINGW32__) SCM_DEFINE (scm_uname, "uname", 0, 0, 0, (), - "Returns an object with some information about the computer system the\n" - "program is running on.") + "Return an object with some information about the computer\n" + "system the program is running on.") #define FUNC_NAME s_scm_uname { struct utsname buf; - SCM ans = scm_make_vector (SCM_MAKINUM(5), SCM_UNSPECIFIED); - SCM *ve = SCM_VELTS (ans); + SCM result = scm_c_make_vector (5, SCM_UNSPECIFIED); if (uname (&buf) < 0) SCM_SYSERROR; - ve[0] = scm_makfrom0str (buf.sysname); - ve[1] = scm_makfrom0str (buf.nodename); - ve[2] = scm_makfrom0str (buf.release); - ve[3] = scm_makfrom0str (buf.version); - ve[4] = scm_makfrom0str (buf.machine); + SCM_SIMPLE_VECTOR_SET(result, 0, scm_from_locale_string (buf.sysname)); + SCM_SIMPLE_VECTOR_SET(result, 1, scm_from_locale_string (buf.nodename)); + SCM_SIMPLE_VECTOR_SET(result, 2, scm_from_locale_string (buf.release)); + SCM_SIMPLE_VECTOR_SET(result, 3, scm_from_locale_string (buf.version)); + SCM_SIMPLE_VECTOR_SET(result, 4, scm_from_locale_string (buf.machine)); /* a linux special? - ve[5] = scm_makfrom0str (buf.domainname); + SCM_SIMPLE_VECTOR_SET(result, 5, scm_from_locale_string (buf.domainname)); */ - return ans; + return result; } #undef FUNC_NAME #endif /* HAVE_UNAME */ SCM_DEFINE (scm_environ, "environ", 0, 1, 0, (SCM env), - "If @var{env} is omitted, returns the current environment as a list of strings.\n" - "Otherwise it sets the current environment, which is also the\n" - "default environment for child processes, to the supplied list of strings.\n" - "Each member of @var{env} should be of the form\n" - "@code{NAME=VALUE} and values of @code{NAME} should not be duplicated.\n" - "If @var{env} is supplied then the return value is unspecified.") + "If @var{env} is omitted, return the current environment (in the\n" + "Unix sense) as a list of strings. Otherwise set the current\n" + "environment, which is also the default environment for child\n" + "processes, to the supplied list of strings. Each member of\n" + "@var{env} should be of the form @code{NAME=VALUE} and values of\n" + "@code{NAME} should not be duplicated. If @var{env} is supplied\n" + "then the return value is unspecified.") #define FUNC_NAME s_scm_environ { if (SCM_UNBNDP (env)) @@ -995,19 +1113,14 @@ SCM_DEFINE (scm_environ, "environ", 0, 1, 0, { char **new_environ; - new_environ = environ_list_to_c (env, SCM_ARG1, FUNC_NAME); + new_environ = scm_i_allocate_string_pointers (env); /* Free the old environment, except when called for the first * time. */ { - char **ep; static int first = 1; if (!first) - { - for (ep = environ; *ep != NULL; ep++) - free (*ep); - free ((char *) environ); - } + scm_i_free_string_pointers (environ); first = 0; } environ = new_environ; @@ -1020,51 +1133,103 @@ SCM_DEFINE (scm_environ, "environ", 0, 1, 0, SCM_DEFINE (scm_tmpnam, "tmpnam", 0, 0, 0, (), - "Create a new file in the file system with a unique name. The return\n" - "value is the name of the new file. This function is implemented with\n" - "the @code{tmpnam} function in the system libraries.") + "Return a name in the file system that does not match any\n" + "existing file. However there is no guarantee that another\n" + "process will not create the file after @code{tmpnam} is called.\n" + "Care should be taken if opening the file, e.g., use the\n" + "@code{O_EXCL} open flag or use @code{mkstemp!} instead.") #define FUNC_NAME s_scm_tmpnam { char name[L_tmpnam]; - SCM_SYSCALL (tmpnam (name);); - return scm_makfrom0str (name); + char *rv; + + SCM_SYSCALL (rv = tmpnam (name)); + if (rv == NULL) + /* not SCM_SYSERROR since errno probably not set. */ + SCM_MISC_ERROR ("tmpnam failed", SCM_EOL); + return scm_from_locale_string (name); } #undef FUNC_NAME #endif +#ifndef HAVE_MKSTEMP +extern int mkstemp (char *); +#endif + +SCM_DEFINE (scm_mkstemp, "mkstemp!", 1, 0, 0, + (SCM tmpl), + "Create a new unique file in the file system and return a new\n" + "buffered port open for reading and writing to the file.\n" + "\n" + "@var{tmpl} is a string specifying where the file should be\n" + "created: it must end with @samp{XXXXXX} and those @samp{X}s\n" + "will be changed in the string to return the name of the file.\n" + "(@code{port-filename} on the port also gives the name.)\n" + "\n" + "POSIX doesn't specify the permissions mode of the file, on GNU\n" + "and most systems it's @code{#o600}. An application can use\n" + "@code{chmod} to relax that if desired. For example\n" + "@code{#o666} less @code{umask}, which is usual for ordinary\n" + "file creation,\n" + "\n" + "@example\n" + "(let ((port (mkstemp! (string-copy \"/tmp/myfile-XXXXXX\"))))\n" + " (chmod port (logand #o666 (lognot (umask))))\n" + " ...)\n" + "@end example") +#define FUNC_NAME s_scm_mkstemp +{ + char *c_tmpl; + int rv; + + scm_dynwind_begin (0); + + c_tmpl = scm_to_locale_string (tmpl); + scm_dynwind_free (c_tmpl); + + SCM_SYSCALL (rv = mkstemp (c_tmpl)); + if (rv == -1) + SCM_SYSERROR; + + scm_substring_move_x (scm_from_locale_string (c_tmpl), + SCM_INUM0, scm_string_length (tmpl), + tmpl, SCM_INUM0); + + scm_dynwind_end (); + return scm_fdes_to_port (rv, "w+", tmpl); +} +#undef FUNC_NAME + SCM_DEFINE (scm_utime, "utime", 1, 2, 0, (SCM pathname, SCM actime, SCM modtime), - "@code{utime} sets the access and modification times for\n" - "the file named by @var{path}. If @var{actime} or @var{modtime}\n" - "is not supplied, then the current time is used.\n" - "@var{actime} and @var{modtime}\n" - "must be integer time values as returned by the @code{current-time}\n" - "procedure.\n\n" - "E.g.,\n\n" - "@smalllisp\n" + "@code{utime} sets the access and modification times for the\n" + "file named by @var{path}. If @var{actime} or @var{modtime} is\n" + "not supplied, then the current time is used. @var{actime} and\n" + "@var{modtime} must be integer time values as returned by the\n" + "@code{current-time} procedure.\n" + "@lisp\n" "(utime \"foo\" (- (current-time) 3600))\n" - "@end smalllisp\n\n" - "will set the access time to one hour in the past and the modification\n" - "time to the current time.") + "@end lisp\n" + "will set the access time to one hour in the past and the\n" + "modification time to the current time.") #define FUNC_NAME s_scm_utime { int rv; struct utimbuf utm_tmp; - SCM_VALIDATE_ROSTRING (1,pathname); - SCM_COERCE_SUBSTR (pathname); if (SCM_UNBNDP (actime)) SCM_SYSCALL (time (&utm_tmp.actime)); else - utm_tmp.actime = SCM_NUM2ULONG (2,actime); + utm_tmp.actime = SCM_NUM2ULONG (2, actime); if (SCM_UNBNDP (modtime)) SCM_SYSCALL (time (&utm_tmp.modtime)); else - utm_tmp.modtime = SCM_NUM2ULONG (3,modtime); + utm_tmp.modtime = SCM_NUM2ULONG (3, modtime); - SCM_SYSCALL (rv = utime (SCM_ROCHARS (pathname), &utm_tmp)); + STRING_SYSCALL (pathname, c_pathname, + rv = utime (c_pathname, &utm_tmp)); if (rv != 0) SCM_SYSERROR; return SCM_UNSPECIFIED; @@ -1073,48 +1238,62 @@ SCM_DEFINE (scm_utime, "utime", 1, 2, 0, SCM_DEFINE (scm_access, "access?", 2, 0, 0, (SCM path, SCM how), - "Returns @code{#t} if @var{path} corresponds to an existing\n" - "file and the current process\n" - "has the type of access specified by @var{how}, otherwise \n" - "@code{#f}.\n" - "@var{how} should be specified\n" - "using the values of the variables listed below. Multiple values can\n" - "be combined using a bitwise or, in which case @code{#t} will only\n" - "be returned if all accesses are granted.\n\n" - "Permissions are checked using the real id of the current process,\n" - "not the effective id, although it's the effective id which determines\n" - "whether the access would actually be granted.\n\n" + "Test accessibility of a file under the real UID and GID of the\n" + "calling process. The return is @code{#t} if @var{path} exists\n" + "and the permissions requested by @var{how} are all allowed, or\n" + "@code{#f} if not.\n" + "\n" + "@var{how} is an integer which is one of the following values,\n" + "or a bitwise-OR (@code{logior}) of multiple values.\n" + "\n" "@defvar R_OK\n" - "test for read permission.\n" + "Test for read permission.\n" "@end defvar\n" "@defvar W_OK\n" - "test for write permission.\n" + "Test for write permission.\n" "@end defvar\n" "@defvar X_OK\n" - "test for execute permission.\n" + "Test for execute permission.\n" "@end defvar\n" "@defvar F_OK\n" - "test for existence of the file.\n" - "@end defvar") + "Test for existence of the file. This is implied by each of the\n" + "other tests, so there's no need to combine it with them.\n" + "@end defvar\n" + "\n" + "It's important to note that @code{access?} does not simply\n" + "indicate what will happen on attempting to read or write a\n" + "file. In normal circumstances it does, but in a set-UID or\n" + "set-GID program it doesn't because @code{access?} tests the\n" + "real ID, whereas an open or execute attempt uses the effective\n" + "ID.\n" + "\n" + "A program which will never run set-UID/GID can ignore the\n" + "difference between real and effective IDs, but for maximum\n" + "generality, especially in library functions, it's best not to\n" + "use @code{access?} to predict the result of an open or execute,\n" + "instead simply attempt that and catch any exception.\n" + "\n" + "The main use for @code{access?} is to let a set-UID/GID program\n" + "determine what the invoking user would have been allowed to do,\n" + "without the greater (or perhaps lesser) privileges afforded by\n" + "the effective ID. For more on this, see ``Testing File\n" + "Access'' in The GNU C Library Reference Manual.") #define FUNC_NAME s_scm_access { int rv; - SCM_VALIDATE_ROSTRING (1,path); - if (SCM_SUBSTRP (path)) - path = scm_makfromstr (SCM_ROCHARS (path), SCM_ROLENGTH (path), 0); - SCM_VALIDATE_INUM (2,how); - rv = access (SCM_ROCHARS (path), SCM_INUM (how)); - return SCM_NEGATE_BOOL(rv); + WITH_STRING (path, c_path, + rv = access (c_path, scm_to_int (how))); + return scm_from_bool (!rv); } #undef FUNC_NAME SCM_DEFINE (scm_getpid, "getpid", 0, 0, 0, (), - "Returns an integer representing the current process ID.") + "Return an integer representing the current process ID.") #define FUNC_NAME s_scm_getpid { - return SCM_MAKINUM ((unsigned long) getpid ()); + return scm_from_ulong (getpid ()); } #undef FUNC_NAME @@ -1132,18 +1311,71 @@ SCM_DEFINE (scm_putenv, "putenv", 1, 0, 0, #define FUNC_NAME s_scm_putenv { int rv; - char *ptr; - - SCM_VALIDATE_ROSTRING (1,str); - /* must make a new copy to be left in the environment, safe from gc. */ - ptr = malloc (SCM_LENGTH (str) + 1); - if (ptr == NULL) - SCM_MEMORY_ERROR; - strncpy (ptr, SCM_ROCHARS (str), SCM_LENGTH (str)); - ptr[SCM_LENGTH(str)] = 0; - rv = putenv (ptr); - if (rv < 0) - SCM_SYSERROR; + char *c_str = scm_to_locale_string (str); +#ifdef __MINGW32__ + size_t len = strlen (c_str); +#endif + + if (strchr (c_str, '=') == NULL) + { +#ifdef HAVE_UNSETENV + /* No '=' in argument means we should remove the variable from + the environment. Not all putenvs understand this (for instance + FreeBSD 4.8 doesn't). To be safe, we do it explicitely using + unsetenv. */ + unsetenv (c_str); + free (c_str); +#else + /* On e.g. Win32 hosts putenv() called with 'name=' removes the + environment variable 'name'. */ + int e; + char *ptr = scm_malloc (len + 2); + strcpy (ptr, c_str); + strcpy (ptr+len, "="); + rv = putenv (ptr); + e = errno; free (ptr); free (c_str); errno = e; + if (rv < 0) + SCM_SYSERROR; +#endif /* !HAVE_UNSETENV */ + } + else + { +#ifdef __MINGW32__ + /* If str is "FOO=", ie. attempting to set an empty string, then + we need to see if it's been successful. On MINGW, "FOO=" + means remove FOO from the environment. As a workaround, we + set "FOO= ", ie. a space, and then modify the string returned + by getenv. It's not enough just to modify the string we set, + because MINGW putenv copies it. */ + + if (c_str[len-1] == '=') + { + char *ptr = scm_malloc (len+2); + strcpy (ptr, c_str); + strcpy (ptr+len, " "); + rv = putenv (ptr); + if (rv < 0) + { + int eno = errno; + free (c_str); + errno = eno; + SCM_SYSERROR; + } + /* truncate to just the name */ + c_str[len-1] = '\0'; + ptr = getenv (c_str); + if (ptr) + ptr[0] = '\0'; + return SCM_UNSPECIFIED; + } +#endif /* __MINGW32__ */ + + /* Leave c_str in the environment. */ + + rv = putenv (c_str); + if (rv < 0) + SCM_SYSERROR; + } return SCM_UNSPECIFIED; } #undef FUNC_NAME @@ -1151,36 +1383,48 @@ SCM_DEFINE (scm_putenv, "putenv", 1, 0, 0, #ifdef HAVE_SETLOCALE SCM_DEFINE (scm_setlocale, "setlocale", 1, 1, 0, (SCM category, SCM locale), - "If @var{locale} is omitted, returns the current value of the specified\n" - "locale category \n" - "as a system-dependent string.\n" - "@var{category} should be specified using the values @code{LC_COLLATE},\n" - "@code{LC_ALL} etc.\n\n" - "Otherwise the specified locale category is set to\n" - "the string @var{locale}\n" - "and the new value is returned as a system-dependent string. If @var{locale}\n" - "is an empty string, the locale will be set using envirionment variables.") + "If @var{locale} is omitted, return the current value of the\n" + "specified locale category as a system-dependent string.\n" + "@var{category} should be specified using the values\n" + "@code{LC_COLLATE}, @code{LC_ALL} etc.\n" + "\n" + "Otherwise the specified locale category is set to the string\n" + "@var{locale} and the new value is returned as a\n" + "system-dependent string. If @var{locale} is an empty string,\n" + "the locale will be set using environment variables.") #define FUNC_NAME s_scm_setlocale { char *clocale; char *rv; - SCM_VALIDATE_INUM (1,category); + scm_dynwind_begin (0); + if (SCM_UNBNDP (locale)) { clocale = NULL; } else { - SCM_VALIDATE_ROSTRING (2,locale); - SCM_COERCE_SUBSTR (locale); - clocale = SCM_ROCHARS (locale); + clocale = scm_to_locale_string (locale); + scm_dynwind_free (clocale); } - rv = setlocale (SCM_INUM (category), clocale); + rv = setlocale (scm_i_to_lc_category (category, 1), clocale); if (rv == NULL) - SCM_SYSERROR; - return scm_makfrom0str (rv); + { + /* POSIX and C99 don't say anything about setlocale setting errno, so + force a sensible value here. glibc leaves ENOENT, which would be + fine, but it's not a documented feature. */ + errno = EINVAL; + SCM_SYSERROR; + } + + /* Recompute the standard SRFI-14 character sets in a locale-dependent + (actually charset-dependent) way. */ + scm_srfi_14_compute_char_sets (); + + scm_dynwind_end (); + return scm_from_locale_string (rv); } #undef FUNC_NAME #endif /* HAVE_SETLOCALE */ @@ -1197,42 +1441,46 @@ SCM_DEFINE (scm_mknod, "mknod", 4, 0, 0, "to. Its exact interpretation depends on the kind of special file\n" "being created.\n\n" "E.g.,\n" - "@example\n" + "@lisp\n" "(mknod \"/dev/fd0\" 'block-special #o660 (+ (* 2 256) 2))\n" - "@end example\n\n" + "@end lisp\n\n" "The return value is unspecified.") #define FUNC_NAME s_scm_mknod { int val; - char *p; + const char *p; int ctype = 0; - SCM_VALIDATE_ROSTRING (1,path); - SCM_VALIDATE_SYMBOL (2,type); - SCM_VALIDATE_INUM (3,perms); - SCM_VALIDATE_INUM (4,dev); - SCM_COERCE_SUBSTR (path); + SCM_VALIDATE_STRING (1, path); + SCM_VALIDATE_SYMBOL (2, type); - p = SCM_CHARS (type); + p = scm_i_symbol_chars (type); if (strcmp (p, "regular") == 0) ctype = S_IFREG; else if (strcmp (p, "directory") == 0) ctype = S_IFDIR; +#ifdef S_IFLNK + /* systems without symlinks probably don't have S_IFLNK defined */ else if (strcmp (p, "symlink") == 0) ctype = S_IFLNK; +#endif else if (strcmp (p, "block-special") == 0) ctype = S_IFBLK; else if (strcmp (p, "char-special") == 0) ctype = S_IFCHR; else if (strcmp (p, "fifo") == 0) ctype = S_IFIFO; +#ifdef S_IFSOCK else if (strcmp (p, "socket") == 0) ctype = S_IFSOCK; +#endif else - SCM_OUT_OF_RANGE (2,type); + SCM_OUT_OF_RANGE (2, type); - SCM_SYSCALL (val = mknod(SCM_ROCHARS(path), ctype | SCM_INUM (perms), - SCM_INUM (dev))); + STRING_SYSCALL (path, c_path, + val = mknod (c_path, + ctype | scm_to_int (perms), + scm_to_int (dev))); if (val != 0) SCM_SYSERROR; return SCM_UNSPECIFIED; @@ -1248,8 +1496,11 @@ SCM_DEFINE (scm_nice, "nice", 1, 0, 0, "The return value is unspecified.") #define FUNC_NAME s_scm_nice { - SCM_VALIDATE_INUM (1,incr); - if (nice(SCM_INUM(incr)) != 0) + /* nice() returns "prio-NZERO" on success or -1 on error, but -1 can arise + from "prio-NZERO", so an error must be detected from errno changed */ + errno = 0; + nice (scm_to_int (incr)); + if (errno != 0) SCM_SYSERROR; return SCM_UNSPECIFIED; } @@ -1269,6 +1520,429 @@ SCM_DEFINE (scm_sync, "sync", 0, 0, 0, #undef FUNC_NAME #endif /* HAVE_SYNC */ + +/* crypt() returns a pointer to a static buffer, so we use scm_i_misc_mutex + to avoid another thread overwriting it. A test program running crypt + continuously in two threads can be quickly seen tripping this problem. + crypt() is pretty slow normally, so a mutex shouldn't add much overhead. + + glibc has a thread-safe crypt_r, but (in version 2.3.2) it runs a lot + slower (about 5x) than plain crypt if you pass an uninitialized data + block each time. Presumably there's some one-time setups. The best way + to use crypt_r for parallel execution in multiple threads would probably + be to maintain a little pool of initialized crypt_data structures, take + one and use it, then return it to the pool. That pool could be garbage + collected so it didn't add permanently to memory use if only a few crypt + calls are made. But we expect crypt will be used rarely, and even more + rarely will there be any desire for lots of parallel execution on + multiple cpus. So for now we don't bother with anything fancy, just + ensure it works. */ + +#if HAVE_CRYPT +SCM_DEFINE (scm_crypt, "crypt", 2, 0, 0, + (SCM key, SCM salt), + "Encrypt @var{key} using @var{salt} as the salt value to the\n" + "crypt(3) library call.") +#define FUNC_NAME s_scm_crypt +{ + SCM ret; + char *c_key, *c_salt; + + scm_dynwind_begin (0); + scm_i_dynwind_pthread_mutex_lock (&scm_i_misc_mutex); + + c_key = scm_to_locale_string (key); + scm_dynwind_free (c_key); + c_salt = scm_to_locale_string (salt); + scm_dynwind_free (c_salt); + + ret = scm_from_locale_string (crypt (c_key, c_salt)); + + scm_dynwind_end (); + return ret; +} +#undef FUNC_NAME +#endif /* HAVE_CRYPT */ + +#if HAVE_CHROOT +SCM_DEFINE (scm_chroot, "chroot", 1, 0, 0, + (SCM path), + "Change the root directory to that specified in @var{path}.\n" + "This directory will be used for path names beginning with\n" + "@file{/}. The root directory is inherited by all children\n" + "of the current process. Only the superuser may change the\n" + "root directory.") +#define FUNC_NAME s_scm_chroot +{ + int rv; + + WITH_STRING (path, c_path, + rv = chroot (c_path)); + if (rv == -1) + SCM_SYSERROR; + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME +#endif /* HAVE_CHROOT */ + + +#ifdef __MINGW32__ +/* Wrapper function to supplying `getlogin()' under Windows. */ +static char * getlogin (void) +{ + static char user[256]; + static unsigned long len = 256; + + if (!GetUserName (user, &len)) + return NULL; + return user; +} +#endif /* __MINGW32__ */ + + +#if defined (HAVE_GETLOGIN) || defined (__MINGW32__) +SCM_DEFINE (scm_getlogin, "getlogin", 0, 0, 0, + (void), + "Return a string containing the name of the user logged in on\n" + "the controlling terminal of the process, or @code{#f} if this\n" + "information cannot be obtained.") +#define FUNC_NAME s_scm_getlogin +{ + char * p; + + p = getlogin (); + if (!p || !*p) + return SCM_BOOL_F; + return scm_from_locale_string (p); +} +#undef FUNC_NAME +#endif /* HAVE_GETLOGIN */ + +#if HAVE_CUSERID +SCM_DEFINE (scm_cuserid, "cuserid", 0, 0, 0, + (void), + "Return a string containing a user name associated with the\n" + "effective user id of the process. Return @code{#f} if this\n" + "information cannot be obtained.") +#define FUNC_NAME s_scm_cuserid +{ + char buf[L_cuserid]; + char * p; + + p = cuserid (buf); + if (!p || !*p) + return SCM_BOOL_F; + return scm_from_locale_string (p); +} +#undef FUNC_NAME +#endif /* HAVE_CUSERID */ + +#if HAVE_GETPRIORITY +SCM_DEFINE (scm_getpriority, "getpriority", 2, 0, 0, + (SCM which, SCM who), + "Return the scheduling priority of the process, process group\n" + "or user, as indicated by @var{which} and @var{who}. @var{which}\n" + "is one of the variables @code{PRIO_PROCESS}, @code{PRIO_PGRP}\n" + "or @code{PRIO_USER}, and @var{who} is interpreted relative to\n" + "@var{which} (a process identifier for @code{PRIO_PROCESS},\n" + "process group identifier for @code{PRIO_PGRP}, and a user\n" + "identifier for @code{PRIO_USER}. A zero value of @var{who}\n" + "denotes the current process, process group, or user. Return\n" + "the highest priority (lowest numerical value) of any of the\n" + "specified processes.") +#define FUNC_NAME s_scm_getpriority +{ + int cwhich, cwho, ret; + + cwhich = scm_to_int (which); + cwho = scm_to_int (who); + + /* We have to clear errno and examine it later, because -1 is a + legal return value for getpriority(). */ + errno = 0; + ret = getpriority (cwhich, cwho); + if (errno != 0) + SCM_SYSERROR; + return scm_from_int (ret); +} +#undef FUNC_NAME +#endif /* HAVE_GETPRIORITY */ + +#if HAVE_SETPRIORITY +SCM_DEFINE (scm_setpriority, "setpriority", 3, 0, 0, + (SCM which, SCM who, SCM prio), + "Set the scheduling priority of the process, process group\n" + "or user, as indicated by @var{which} and @var{who}. @var{which}\n" + "is one of the variables @code{PRIO_PROCESS}, @code{PRIO_PGRP}\n" + "or @code{PRIO_USER}, and @var{who} is interpreted relative to\n" + "@var{which} (a process identifier for @code{PRIO_PROCESS},\n" + "process group identifier for @code{PRIO_PGRP}, and a user\n" + "identifier for @code{PRIO_USER}. A zero value of @var{who}\n" + "denotes the current process, process group, or user.\n" + "@var{prio} is a value in the range -20 and 20, the default\n" + "priority is 0; lower priorities cause more favorable\n" + "scheduling. Sets the priority of all of the specified\n" + "processes. Only the super-user may lower priorities.\n" + "The return value is not specified.") +#define FUNC_NAME s_scm_setpriority +{ + int cwhich, cwho, cprio; + + cwhich = scm_to_int (which); + cwho = scm_to_int (who); + cprio = scm_to_int (prio); + + if (setpriority (cwhich, cwho, cprio) == -1) + SCM_SYSERROR; + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME +#endif /* HAVE_SETPRIORITY */ + +#if HAVE_GETPASS +SCM_DEFINE (scm_getpass, "getpass", 1, 0, 0, + (SCM prompt), + "Display @var{prompt} to the standard error output and read\n" + "a password from @file{/dev/tty}. If this file is not\n" + "accessible, it reads from standard input. The password may be\n" + "up to 127 characters in length. Additional characters and the\n" + "terminating newline character are discarded. While reading\n" + "the password, echoing and the generation of signals by special\n" + "characters is disabled.") +#define FUNC_NAME s_scm_getpass +{ + char * p; + SCM passwd; + + SCM_VALIDATE_STRING (1, prompt); + + WITH_STRING (prompt, c_prompt, + p = getpass(c_prompt)); + passwd = scm_from_locale_string (p); + + /* Clear out the password in the static buffer. */ + memset (p, 0, strlen (p)); + + return passwd; +} +#undef FUNC_NAME +#endif /* HAVE_GETPASS */ + +/* Wrapper function for flock() support under M$-Windows. */ +#ifdef __MINGW32__ +# include +# include +# include +# ifndef _LK_UNLCK + /* Current MinGW package fails to define this. *sigh* */ +# define _LK_UNLCK 0 +# endif +# define LOCK_EX 1 +# define LOCK_UN 2 +# define LOCK_SH 4 +# define LOCK_NB 8 + +static int flock (int fd, int operation) +{ + long pos, len; + int ret, err; + + /* Disable invalid arguments. */ + if (((operation & (LOCK_EX | LOCK_SH)) == (LOCK_EX | LOCK_SH)) || + ((operation & (LOCK_EX | LOCK_UN)) == (LOCK_EX | LOCK_UN)) || + ((operation & (LOCK_SH | LOCK_UN)) == (LOCK_SH | LOCK_UN))) + { + errno = EINVAL; + return -1; + } + + /* Determine mode of operation and discard unsupported ones. */ + if (operation == (LOCK_NB | LOCK_EX)) + operation = _LK_NBLCK; + else if (operation & LOCK_UN) + operation = _LK_UNLCK; + else if (operation == LOCK_EX) + operation = _LK_LOCK; + else + { + errno = EINVAL; + return -1; + } + + /* Save current file pointer and seek to beginning. */ + if ((pos = lseek (fd, 0, SEEK_CUR)) == -1 || (len = filelength (fd)) == -1) + return -1; + lseek (fd, 0L, SEEK_SET); + + /* Deadlock if necessary. */ + do + { + ret = _locking (fd, operation, len); + } + while (ret == -1 && errno == EDEADLOCK); + + /* Produce meaningful error message. */ + if (errno == EACCES && operation == _LK_NBLCK) + err = EDEADLOCK; + else + err = errno; + + /* Return to saved file position pointer. */ + lseek (fd, pos, SEEK_SET); + errno = err; + return ret; +} +#endif /* __MINGW32__ */ + +#if HAVE_FLOCK || defined (__MINGW32__) +SCM_DEFINE (scm_flock, "flock", 2, 0, 0, + (SCM file, SCM operation), + "Apply or remove an advisory lock on an open file.\n" + "@var{operation} specifies the action to be done:\n" + "\n" + "@defvar LOCK_SH\n" + "Shared lock. More than one process may hold a shared lock\n" + "for a given file at a given time.\n" + "@end defvar\n" + "@defvar LOCK_EX\n" + "Exclusive lock. Only one process may hold an exclusive lock\n" + "for a given file at a given time.\n" + "@end defvar\n" + "@defvar LOCK_UN\n" + "Unlock the file.\n" + "@end defvar\n" + "@defvar LOCK_NB\n" + "Don't block when locking. This is combined with one of the\n" + "other operations using @code{logior}. If @code{flock} would\n" + "block an @code{EWOULDBLOCK} error is thrown.\n" + "@end defvar\n" + "\n" + "The return value is not specified. @var{file} may be an open\n" + "file descriptor or an open file descriptor port.\n" + "\n" + "Note that @code{flock} does not lock files across NFS.") +#define FUNC_NAME s_scm_flock +{ + int fdes; + + if (scm_is_integer (file)) + fdes = scm_to_int (file); + else + { + SCM_VALIDATE_OPFPORT (2, file); + + fdes = SCM_FPORT_FDES (file); + } + if (flock (fdes, scm_to_int (operation)) == -1) + SCM_SYSERROR; + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME +#endif /* HAVE_FLOCK */ + +#if HAVE_SETHOSTNAME +SCM_DEFINE (scm_sethostname, "sethostname", 1, 0, 0, + (SCM name), + "Set the host name of the current processor to @var{name}. May\n" + "only be used by the superuser. The return value is not\n" + "specified.") +#define FUNC_NAME s_scm_sethostname +{ + int rv; + + WITH_STRING (name, c_name, + rv = sethostname (c_name, strlen(c_name))); + if (rv == -1) + SCM_SYSERROR; + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME +#endif /* HAVE_SETHOSTNAME */ + + +#if HAVE_GETHOSTNAME +SCM_DEFINE (scm_gethostname, "gethostname", 0, 0, 0, + (void), + "Return the host name of the current processor.") +#define FUNC_NAME s_scm_gethostname +{ +#ifdef MAXHOSTNAMELEN + + /* Various systems define MAXHOSTNAMELEN (including Solaris in fact). + * On GNU/Linux this doesn't include the terminating '\0', hence "+ 1". */ + const int len = MAXHOSTNAMELEN + 1; + char *const p = scm_malloc (len); + const int res = gethostname (p, len); + + scm_dynwind_begin (0); + scm_dynwind_unwind_handler (free, p, 0); + +#else + + /* Default 256 is for Solaris, under Linux ENAMETOOLONG is returned if not + * large enough. SUSv2 specifies 255 maximum too, apparently. */ + int len = 256; + int res; + char *p; + +# if HAVE_SYSCONF && defined (_SC_HOST_NAME_MAX) + + /* POSIX specifies the HOST_NAME_MAX system parameter for the max size, + * which may reflect a particular kernel configuration. + * Must watch out for this existing but giving -1, as happens for instance + * in gnu/linux glibc 2.3.2. */ + { + const long int n = sysconf (_SC_HOST_NAME_MAX); + if (n != -1L) + len = n; + } + +# endif + + p = scm_malloc (len); + + scm_dynwind_begin (0); + scm_dynwind_unwind_handler (free, p, 0); + + res = gethostname (p, len); + while (res == -1 && errno == ENAMETOOLONG) + { + len *= 2; + + /* scm_realloc may throw an exception. */ + p = scm_realloc (p, len); + res = gethostname (p, len); + } + +#endif + + if (res == -1) + { + const int save_errno = errno; + + /* No guile exceptions can occur before we have freed p's memory. */ + scm_dynwind_end (); + free (p); + + errno = save_errno; + SCM_SYSERROR; + } + else + { + /* scm_from_locale_string may throw an exception. */ + const SCM name = scm_from_locale_string (p); + + /* No guile exceptions can occur before we have freed p's memory. */ + scm_dynwind_end (); + free (p); + + return name; + } +} +#undef FUNC_NAME +#endif /* HAVE_GETHOSTNAME */ + + void scm_init_posix () { @@ -1277,47 +1951,88 @@ scm_init_posix () scm_add_feature ("EIDs"); #endif #ifdef WAIT_ANY - scm_sysintern ("WAIT_ANY", SCM_MAKINUM (WAIT_ANY)); + scm_c_define ("WAIT_ANY", scm_from_int (WAIT_ANY)); #endif #ifdef WAIT_MYPGRP - scm_sysintern ("WAIT_MYPGRP", SCM_MAKINUM (WAIT_MYPGRP)); + scm_c_define ("WAIT_MYPGRP", scm_from_int (WAIT_MYPGRP)); #endif #ifdef WNOHANG - scm_sysintern ("WNOHANG", SCM_MAKINUM (WNOHANG)); + scm_c_define ("WNOHANG", scm_from_int (WNOHANG)); #endif #ifdef WUNTRACED - scm_sysintern ("WUNTRACED", SCM_MAKINUM (WUNTRACED)); + scm_c_define ("WUNTRACED", scm_from_int (WUNTRACED)); #endif /* access() symbols. */ - scm_sysintern ("R_OK", SCM_MAKINUM (R_OK)); - scm_sysintern ("W_OK", SCM_MAKINUM (W_OK)); - scm_sysintern ("X_OK", SCM_MAKINUM (X_OK)); - scm_sysintern ("F_OK", SCM_MAKINUM (F_OK)); + scm_c_define ("R_OK", scm_from_int (R_OK)); + scm_c_define ("W_OK", scm_from_int (W_OK)); + scm_c_define ("X_OK", scm_from_int (X_OK)); + scm_c_define ("F_OK", scm_from_int (F_OK)); #ifdef LC_COLLATE - scm_sysintern ("LC_COLLATE", SCM_MAKINUM (LC_COLLATE)); + scm_c_define ("LC_COLLATE", scm_from_int (LC_COLLATE)); #endif #ifdef LC_CTYPE - scm_sysintern ("LC_CTYPE", SCM_MAKINUM (LC_CTYPE)); + scm_c_define ("LC_CTYPE", scm_from_int (LC_CTYPE)); #endif #ifdef LC_MONETARY - scm_sysintern ("LC_MONETARY", SCM_MAKINUM (LC_MONETARY)); + scm_c_define ("LC_MONETARY", scm_from_int (LC_MONETARY)); #endif #ifdef LC_NUMERIC - scm_sysintern ("LC_NUMERIC", SCM_MAKINUM (LC_NUMERIC)); + scm_c_define ("LC_NUMERIC", scm_from_int (LC_NUMERIC)); #endif #ifdef LC_TIME - scm_sysintern ("LC_TIME", SCM_MAKINUM (LC_TIME)); + scm_c_define ("LC_TIME", scm_from_int (LC_TIME)); #endif #ifdef LC_MESSAGES - scm_sysintern ("LC_MESSAGES", SCM_MAKINUM (LC_MESSAGES)); + scm_c_define ("LC_MESSAGES", scm_from_int (LC_MESSAGES)); #endif #ifdef LC_ALL - scm_sysintern ("LC_ALL", SCM_MAKINUM (LC_ALL)); + scm_c_define ("LC_ALL", scm_from_int (LC_ALL)); +#endif +#ifdef LC_PAPER + scm_c_define ("LC_PAPER", scm_from_int (LC_PAPER)); +#endif +#ifdef LC_NAME + scm_c_define ("LC_NAME", scm_from_int (LC_NAME)); +#endif +#ifdef LC_ADDRESS + scm_c_define ("LC_ADDRESS", scm_from_int (LC_ADDRESS)); +#endif +#ifdef LC_TELEPHONE + scm_c_define ("LC_TELEPHONE", scm_from_int (LC_TELEPHONE)); +#endif +#ifdef LC_MEASUREMENT + scm_c_define ("LC_MEASUREMENT", scm_from_int (LC_MEASUREMENT)); +#endif +#ifdef LC_IDENTIFICATION + scm_c_define ("LC_IDENTIFICATION", scm_from_int (LC_IDENTIFICATION)); #endif #ifdef PIPE_BUF -scm_sysintern ("PIPE_BUF", scm_long2num (PIPE_BUF)); + scm_c_define ("PIPE_BUF", scm_from_long (PIPE_BUF)); +#endif + +#ifdef PRIO_PROCESS + scm_c_define ("PRIO_PROCESS", scm_from_int (PRIO_PROCESS)); +#endif +#ifdef PRIO_PGRP + scm_c_define ("PRIO_PGRP", scm_from_int (PRIO_PGRP)); +#endif +#ifdef PRIO_USER + scm_c_define ("PRIO_USER", scm_from_int (PRIO_USER)); +#endif + +#ifdef LOCK_SH + scm_c_define ("LOCK_SH", scm_from_int (LOCK_SH)); +#endif +#ifdef LOCK_EX + scm_c_define ("LOCK_EX", scm_from_int (LOCK_EX)); +#endif +#ifdef LOCK_UN + scm_c_define ("LOCK_UN", scm_from_int (LOCK_UN)); +#endif +#ifdef LOCK_NB + scm_c_define ("LOCK_NB", scm_from_int (LOCK_NB)); #endif #include "libguile/cpp_sig_symbols.c"