X-Git-Url: https://git.hcoop.net/bpt/guile.git/blobdiff_plain/e6e2e95aa53f876e25bee2b0f867350c4a2ddf7a..4ea9429edc9c95d521b68b9880b646a328650079:/libguile/posix.c diff --git a/libguile/posix.c b/libguile/posix.c index efc3f4635..78fd295b5 100644 --- a/libguile/posix.c +++ b/libguile/posix.c @@ -1,64 +1,45 @@ -/* Copyright (C) 1995, 96, 97, 98, 99, 2000, 2001 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 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 */ - -/* Make GNU/Linux libc declare everything it has. */ -#define _GNU_SOURCE +#ifdef HAVE_CONFIG_H +# include +#endif #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/values.h" +#include "libguile/lang.h" #include "libguile/validate.h" #include "libguile/posix.h" +#include "libguile/gettext.h" +#include "libguile/threads.h" #ifdef HAVE_STRING_H @@ -91,7 +72,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 @@ -107,34 +102,37 @@ extern char *ttyname(); 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_LIBCRYPT && HAVE_CRYPT_H +#if (defined HAVE_NEWLOCALE) && (defined HAVE_STRCOLL_L) +# define USE_GNU_LOCALE_API +#endif + +#if (defined USE_GNU_LOCALE_API) && (defined HAVE_XLOCALE_H) +# 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 @@ -143,6 +141,10 @@ extern char ** environ; # 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 @@ -161,6 +163,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. */ @@ -178,7 +186,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"); @@ -186,19 +231,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; @@ -218,12 +263,13 @@ 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 ans; + SCM result; int ngroups; - scm_sizet size; + size_t size; GETGROUPS_T *groups; ngroups = getgroups (0, NULL); @@ -231,22 +277,71 @@ SCM_DEFINE (scm_getgroups, "getgroups", 0, 0, 0, SCM_SYSERROR; size = ngroups * sizeof (GETGROUPS_T); - groups = scm_must_malloc (size, FUNC_NAME); - getgroups (ngroups, groups); + groups = scm_malloc (size); + ngroups = getgroups (ngroups, groups); - ans = scm_c_make_vector (ngroups, SCM_UNDEFINED); + result = scm_c_make_vector (ngroups, SCM_BOOL_F); while (--ngroups >= 0) - SCM_VELTS (ans) [ngroups] = SCM_MAKINUM (groups [ngroups]); - - scm_must_free (groups); - scm_done_free (size); + SCM_SIMPLE_VECTOR_SET (result, ngroups, scm_from_ulong (groups[ngroups])); - return ans; + 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" @@ -254,13 +349,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_c_make_vector (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) @@ -268,35 +360,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_STRING (1, user); - SCM_STRING_COERCE_0TERMINATION_X (user); - entry = getpwnam (SCM_STRING_CHARS (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 @@ -307,7 +399,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 (); @@ -317,7 +409,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), @@ -326,12 +418,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_c_make_vector (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) @@ -339,21 +429,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_STRING (1, name); - SCM_STRING_COERCE_0TERMINATION_X (name); - SCM_SYSCALL (entry = getgrnam (SCM_STRING_CHARS (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 @@ -367,15 +454,188 @@ 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 */ +#ifdef HAVE_GETRLIMIT +#ifdef RLIMIT_AS +SCM_SYMBOL (sym_as, "as"); +#endif +#ifdef RLIMIT_CORE +SCM_SYMBOL (sym_core, "core"); +#endif +#ifdef RLIMIT_CPU +SCM_SYMBOL (sym_cpu, "cpu"); +#endif +#ifdef RLIMIT_DATA +SCM_SYMBOL (sym_data, "data"); +#endif +#ifdef RLIMIT_FSIZE +SCM_SYMBOL (sym_fsize, "fsize"); +#endif +#ifdef RLIMIT_MEMLOCK +SCM_SYMBOL (sym_memlock, "memlock"); +#endif +#ifdef RLIMIT_MSGQUEUE +SCM_SYMBOL (sym_msgqueue, "msgqueue"); +#endif +#ifdef RLIMIT_NICE +SCM_SYMBOL (sym_nice, "nice"); +#endif +#ifdef RLIMIT_NOFILE +SCM_SYMBOL (sym_nofile, "nofile"); +#endif +#ifdef RLIMIT_NPROC +SCM_SYMBOL (sym_nproc, "nproc"); +#endif +#ifdef RLIMIT_RSS +SCM_SYMBOL (sym_rss, "rss"); +#endif +#ifdef RLIMIT_RTPRIO +SCM_SYMBOL (sym_rtprio, "rtprio"); +#endif +#ifdef RLIMIT_RTPRIO +SCM_SYMBOL (sym_rttime, "rttime"); +#endif +#ifdef RLIMIT_SIGPENDING +SCM_SYMBOL (sym_sigpending, "sigpending"); +#endif +#ifdef RLIMIT_STACK +SCM_SYMBOL (sym_stack, "stack"); +#endif + +static int +scm_to_resource (SCM s, const char *func, int pos) +{ + if (scm_is_number (s)) + return scm_to_int (s); + + SCM_ASSERT_TYPE (scm_is_symbol (s), s, pos, func, "symbol"); + +#ifdef RLIMIT_AS + if (s == sym_as) + return RLIMIT_AS; +#endif +#ifdef RLIMIT_CORE + if (s == sym_core) + return RLIMIT_CORE; +#endif +#ifdef RLIMIT_CPU + if (s == sym_cpu) + return RLIMIT_CPU; +#endif +#ifdef RLIMIT_DATA + if (s == sym_data) + return RLIMIT_DATA; +#endif +#ifdef RLIMIT_FSIZE + if (s == sym_fsize) + return RLIMIT_FSIZE; +#endif +#ifdef RLIMIT_MEMLOCK + if (s == sym_memlock) + return RLIMIT_MEMLOCK; +#endif +#ifdef RLIMIT_MSGQUEUE + if (s == sym_msgqueue) + return RLIMIT_MSGQUEUE; +#endif +#ifdef RLIMIT_NICE + if (s == sym_nice) + return RLIMIT_NICE; +#endif +#ifdef RLIMIT_NOFILE + if (s == sym_nofile) + return RLIMIT_NOFILE; +#endif +#ifdef RLIMIT_NPROC + if (s == sym_nproc) + return RLIMIT_NPROC; +#endif +#ifdef RLIMIT_RSS + if (s == sym_rss) + return RLIMIT_RSS; +#endif +#ifdef RLIMIT_RTPRIO + if (s == sym_rtprio) + return RLIMIT_RTPRIO; +#endif +#ifdef RLIMIT_RTPRIO + if (s == sym_rttime) + return RLIMIT_RTPRIO; +#endif +#ifdef RLIMIT_SIGPENDING + if (s == sym_sigpending) + return RLIMIT_SIGPENDING; +#endif +#ifdef RLIMIT_STACK + if (s == sym_stack) + return RLIMIT_STACK; +#endif + + scm_misc_error (func, "invalid rlimit resource ~A", scm_list_1 (s)); + return 0; +} + +SCM_DEFINE (scm_getrlimit, "getrlimit", 1, 0, 0, + (SCM resource), + "Get a resource limit for this process. @var{resource} identifies the resource,\n" + "either as an integer or as a symbol. For example, @code{(getrlimit 'stack)}\n" + "gets the limits associated with @code{RLIMIT_STACK}.\n\n" + "@code{getrlimit} returns two values, the soft and the hard limit. If no\n" + "limit is set for the resource in question, the returned limit will be @code{#f}.") +#define FUNC_NAME s_scm_getrlimit +{ + int iresource; + struct rlimit lim = { 0, 0 }; + + iresource = scm_to_resource (resource, FUNC_NAME, 1); + + if (getrlimit (iresource, &lim) != 0) + scm_syserror (FUNC_NAME); + + return scm_values (scm_list_2 ((lim.rlim_cur == RLIM_INFINITY) ? SCM_BOOL_F + : scm_from_long (lim.rlim_cur), + (lim.rlim_max == RLIM_INFINITY) ? SCM_BOOL_F + : scm_from_long (lim.rlim_max))); +} +#undef FUNC_NAME + + +#ifdef HAVE_SETRLIMIT +SCM_DEFINE (scm_setrlimit, "setrlimit", 3, 0, 0, + (SCM resource, SCM soft, SCM hard), + "Set a resource limit for this process. @var{resource} identifies the resource,\n" + "either as an integer or as a symbol. @var{soft} and @var{hard} should be integers,\n" + "or @code{#f} to indicate no limit (i.e., @code{RLIM_INFINITY}).\n\n" + "For example, @code{(setrlimit 'stack 150000 300000)} sets the @code{RLIMIT_STACK}\n" + "limit to 150 kilobytes, with a hard limit of 300 kB.") +#define FUNC_NAME s_scm_setrlimit +{ + int iresource; + struct rlimit lim = { 0, 0 }; + + iresource = scm_to_resource (resource, FUNC_NAME, 1); + + lim.rlim_cur = (soft == SCM_BOOL_F) ? RLIM_INFINITY : scm_to_long (soft); + lim.rlim_max = (hard == SCM_BOOL_F) ? RLIM_INFINITY : scm_to_long (hard); + + if (setrlimit (iresource, &lim) != 0) + scm_syserror (FUNC_NAME); + + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME +#endif /* HAVE_SETRLIMIT */ +#endif /* HAVE_GETRLIMIT */ + SCM_DEFINE (scm_kill, "kill", 2, 0, 0, (SCM pid, SCM sig), @@ -403,11 +663,28 @@ 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) +#ifdef HAVE_KILL + if (kill (scm_to_int (pid), scm_to_int (sig)) != 0) SCM_SYSERROR; +#else + /* Mingw has raise(), but not kill(). (Other raw DOS environments might + be similar.) Use raise() when the requested pid is our own process, + otherwise bomb. */ + if (scm_to_int (pid) == getpid ()) + { + if (raise (scm_to_int (sig)) != 0) + { + err: + SCM_SYSERROR; + } + else + { + errno = ENOSYS; + goto err; + } + } +#endif return SCM_UNSPECIFIED; } #undef FUNC_NAME @@ -454,39 +731,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; } @@ -494,17 +768,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; } @@ -512,39 +784,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 @@ -552,10 +826,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 @@ -563,34 +837,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 @@ -603,8 +876,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; } @@ -617,8 +889,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; } @@ -628,42 +899,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; @@ -673,17 +944,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, @@ -695,10 +970,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; } @@ -722,39 +995,72 @@ 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 = SCM_BOOL_F; port = SCM_COERCE_OUTPORT (port); - SCM_VALIDATE_OPPORT (1,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; + if (result != NULL) + result = strdup (result); + + scm_i_pthread_mutex_unlock (&scm_i_misc_mutex); + + if (!result) + { + errno = err; + SCM_SYSERROR; + } + else + ret = scm_take_locale_string (result); + + 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 */ @@ -762,9 +1068,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" @@ -778,11 +1085,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 */ @@ -801,69 +1108,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 */ -/* Create a new C argv array from a scheme list of strings. */ -/* Dirk:FIXME:: A quite similar function is implemented in dynl.c */ -/* Dirk:FIXME:: In case of assertion errors, we get memory leaks */ - -static char ** -scm_convert_exec_args (SCM args, int argn, const char *subr) +static void +free_string_pointers (void *data) { - char **argv; - int argc; - int i; - - argc = scm_ilength (args); - SCM_ASSERT (argc >= 0, args, argn, subr); - argv = (char **) scm_must_malloc ((argc + 1) * sizeof (char *), subr); - for (i = 0; !SCM_NULLP (args); args = SCM_CDR (args), ++i) - { - SCM arg = SCM_CAR (args); - scm_sizet len; - char *dst; - char *src; - - SCM_ASSERT (SCM_STRINGP (arg), args, argn, subr); - len = SCM_STRING_LENGTH (arg); - src = SCM_STRING_CHARS (arg); - dst = (char *) scm_must_malloc (len + 1, subr); - memcpy (dst, src, len); - dst[len] = 0; - argv[i] = dst; - } - argv[i] = 0; - return argv; + 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_STRING (1, filename); - SCM_STRING_COERCE_0TERMINATION_X (filename); - execargv = scm_convert_exec_args (args, SCM_ARG2, FUNC_NAME); - execv (SCM_STRING_CHARS (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 @@ -878,47 +1172,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_STRING (1, filename); - SCM_STRING_COERCE_0TERMINATION_X (filename); - execargv = scm_convert_exec_args (args, SCM_ARG2, FUNC_NAME); - execvp (SCM_STRING_CHARS (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; - num_strings = scm_ilength (envlist); - SCM_ASSERT (num_strings >= 0, envlist, arg, proc); - result = (char **) malloc ((num_strings + 1) * sizeof (char *)); - if (result == NULL) - scm_memory_error (proc); - for (i = 0; !SCM_NULLP (envlist); ++i, envlist = SCM_CDR (envlist)) - { - SCM str = SCM_CAR (envlist); - int len; - char *src; - - SCM_ASSERT (SCM_STRINGP (str), envlist, arg, proc); - len = SCM_STRING_LENGTH (str); - src = SCM_STRING_CHARS (str); - result[i] = malloc (len + 1); - if (result[i] == NULL) - scm_memory_error (proc); - memcpy (result[i], src, len); - result[i][len] = 0; - } - 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), @@ -929,21 +1211,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_STRING (1, filename); - SCM_STRING_COERCE_0TERMINATION_X (filename); - - execargv = scm_convert_exec_args (args, SCM_ARG1, FUNC_NAME); - exec_env = environ_list_to_c (env, SCM_ARG2, FUNC_NAME); - execve (SCM_STRING_CHARS (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" @@ -957,44 +1261,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 HAVE_UNAME +#ifdef __MINGW32__ +# include "win32-uname.h" +#endif + +#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_c_make_vector (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)) @@ -1003,19 +1312,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; @@ -1028,51 +1332,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_STRING (1, pathname); - SCM_STRING_COERCE_0TERMINATION_X (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_STRING_CHARS (pathname), &utm_tmp)); + STRING_SYSCALL (pathname, c_pathname, + rv = utime (c_pathname, &utm_tmp)); if (rv != 0) SCM_SYSERROR; return SCM_UNSPECIFIED; @@ -1081,47 +1437,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_STRING (1, path); - SCM_STRING_COERCE_0TERMINATION_X (path); - SCM_VALIDATE_INUM (2, how); - rv = access (SCM_STRING_CHARS (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 @@ -1139,55 +1510,162 @@ SCM_DEFINE (scm_putenv, "putenv", 1, 0, 0, #define FUNC_NAME s_scm_putenv { int rv; - char *ptr; - - SCM_VALIDATE_STRING (1, str); - /* must make a new copy to be left in the environment, safe from gc. */ - ptr = malloc (SCM_STRING_LENGTH (str) + 1); - if (ptr == NULL) - SCM_MEMORY_ERROR; - strncpy (ptr, SCM_STRING_CHARS (str), SCM_STRING_LENGTH (str)); - ptr[SCM_STRING_LENGTH (str)] = 0; - rv = putenv (ptr); - if (rv < 0) - SCM_SYSERROR; + char *c_str = scm_to_locale_string (str); + + if (strchr (c_str, '=') == NULL) + { + /* We want no "=" in the argument to mean remove the variable from the + environment, but not all putenv()s understand this, for example + FreeBSD 4.8 doesn't. Getting it happening everywhere is a bit + painful. What unsetenv() exists, we use that, of course. + + Traditionally putenv("NAME") removes a variable, for example that's + what we have to do on Solaris 9 (it doesn't have an unsetenv). + + But on DOS and on that DOS overlay manager thing called W-whatever, + putenv("NAME=") must be used (it too doesn't have an unsetenv). + + Supposedly on AIX a putenv("NAME") could cause a segfault, but also + supposedly AIX 5.3 and up has unsetenv() available so should be ok + with the latter there. + + For the moment we hard code the DOS putenv("NAME=") style under + __MINGW32__ and do the traditional everywhere else. Such + system-name tests are bad, of course. It'd be possible to use a + configure test when doing a a native build. For example GNU R has + such a test (see R_PUTENV_AS_UNSETENV in + https://svn.r-project.org/R/trunk/m4/R.m4). But when cross + compiling there'd want to be a guess, one probably based on the + system name (ie. mingw or not), thus landing back in basically the + present hard-coded situation. Another possibility for a cross + build would be to try "NAME" then "NAME=" at runtime, if that's not + too much like overkill. */ + +#if HAVE_UNSETENV + /* when unsetenv() exists then we use it */ + unsetenv (c_str); + free (c_str); +#elif defined (__MINGW32__) + /* otherwise putenv("NAME=") on DOS */ + int e; + size_t len = strlen (c_str); + 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; +#else + /* otherwise traditional putenv("NAME") */ + rv = putenv (c_str); + if (rv < 0) + SCM_SYSERROR; +#endif + } + 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. */ + + { + size_t len = strlen (c_str); + 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 +/* This mutex is used to serialize invocations of `setlocale ()' on non-GNU + systems (i.e., systems where a reentrant locale API is not available). It + is also acquired before calls to `nl_langinfo ()'. See `i18n.c' for + details. */ +scm_i_pthread_mutex_t scm_i_locale_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER; + #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 { + int c_category; char *clocale; char *rv; - SCM_VALIDATE_INUM (1,category); + scm_dynwind_begin (0); + if (SCM_UNBNDP (locale)) { clocale = NULL; } else { - SCM_VALIDATE_STRING (2, locale); - SCM_STRING_COERCE_0TERMINATION_X (locale); - clocale = SCM_STRING_CHARS (locale); + clocale = scm_to_locale_string (locale); + scm_dynwind_free (clocale); } - rv = setlocale (SCM_INUM (category), clocale); + c_category = scm_i_to_lc_category (category, 1); + + scm_i_pthread_mutex_lock (&scm_i_locale_mutex); + rv = setlocale (c_category, clocale); + scm_i_pthread_mutex_unlock (&scm_i_locale_mutex); + 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 */ @@ -1204,29 +1682,29 @@ 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_STRING (1, path); - SCM_VALIDATE_SYMBOL (2,type); - SCM_VALIDATE_INUM (3,perms); - SCM_VALIDATE_INUM (4,dev); - SCM_STRING_COERCE_0TERMINATION_X (path); + SCM_VALIDATE_SYMBOL (2, type); - p = SCM_SYMBOL_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) @@ -1238,10 +1716,12 @@ SCM_DEFINE (scm_mknod, "mknod", 4, 0, 0, ctype = S_IFSOCK; #endif else - SCM_OUT_OF_RANGE (2,type); + SCM_OUT_OF_RANGE (2, type); - SCM_SYSCALL (val = mknod (SCM_STRING_CHARS (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; @@ -1257,9 +1737,15 @@ 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) + int nice_value; + + /* 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_value = nice (scm_to_int (incr)); + if (errno != 0) SCM_SYSERROR; + return SCM_UNSPECIFIED; } #undef FUNC_NAME @@ -1278,25 +1764,55 @@ SCM_DEFINE (scm_sync, "sync", 0, 0, 0, #undef FUNC_NAME #endif /* HAVE_SYNC */ -#if HAVE_LIBCRYPT && HAVE_CRYPT_H -SCM_DEFINE (scm_crypt, "crypt", 2, 0, 0, + +/* 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\n") + "crypt(3) library call.") #define FUNC_NAME s_scm_crypt { - char * p; - - SCM_VALIDATE_STRING (1, key); - SCM_VALIDATE_STRING (2, salt); - SCM_STRING_COERCE_0TERMINATION_X (key); - SCM_STRING_COERCE_0TERMINATION_X (salt); + SCM ret; + char *c_key, *c_salt, *c_ret; + + 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); + + /* The Linux crypt(3) man page says crypt will return NULL and set errno + on error. (Eg. ENOSYS if legal restrictions mean it cannot be + implemented). */ + c_ret = crypt (c_key, c_salt); + if (c_ret == NULL) + SCM_SYSERROR; - p = crypt (SCM_STRING_CHARS (key), SCM_STRING_CHARS (salt)); - return scm_makfrom0str (p); + ret = scm_from_locale_string (c_ret); + scm_dynwind_end (); + return ret; } #undef FUNC_NAME -#endif /* HAVE_LIBCRYPT && HAVE_CRYPT_H */ +#endif /* HAVE_CRYPT */ #if HAVE_CHROOT SCM_DEFINE (scm_chroot, "chroot", 1, 0, 0, @@ -1308,17 +1824,33 @@ SCM_DEFINE (scm_chroot, "chroot", 1, 0, 0, "root directory.") #define FUNC_NAME s_scm_chroot { - SCM_VALIDATE_STRING (1, path); - SCM_STRING_COERCE_0TERMINATION_X (path); + int rv; - if (chroot (SCM_STRING_CHARS (path)) == -1) + WITH_STRING (path, c_path, + rv = chroot (c_path)); + if (rv == -1) SCM_SYSERROR; return SCM_UNSPECIFIED; } #undef FUNC_NAME #endif /* HAVE_CHROOT */ -#if HAVE_GETLOGIN + +#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" @@ -1331,7 +1863,7 @@ SCM_DEFINE (scm_getlogin, "getlogin", 0, 0, 0, p = getlogin (); if (!p || !*p) return SCM_BOOL_F; - return scm_makfrom0str (p); + return scm_from_locale_string (p); } #undef FUNC_NAME #endif /* HAVE_GETLOGIN */ @@ -1344,12 +1876,13 @@ SCM_DEFINE (scm_cuserid, "cuserid", 0, 0, 0, "information cannot be obtained.") #define FUNC_NAME s_scm_cuserid { + char buf[L_cuserid]; char * p; - p = cuserid (NULL); + p = cuserid (buf); if (!p || !*p) return SCM_BOOL_F; - return scm_makfrom0str (p); + return scm_from_locale_string (p); } #undef FUNC_NAME #endif /* HAVE_CUSERID */ @@ -1371,8 +1904,8 @@ SCM_DEFINE (scm_getpriority, "getpriority", 2, 0, 0, { int cwhich, cwho, ret; - SCM_VALIDATE_INUM_COPY (1, which, cwhich); - SCM_VALIDATE_INUM_COPY (2, who, cwho); + 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(). */ @@ -1380,7 +1913,7 @@ SCM_DEFINE (scm_getpriority, "getpriority", 2, 0, 0, ret = getpriority (cwhich, cwho); if (errno != 0) SCM_SYSERROR; - return SCM_MAKINUM (ret); + return scm_from_int (ret); } #undef FUNC_NAME #endif /* HAVE_GETPRIORITY */ @@ -1405,9 +1938,9 @@ SCM_DEFINE (scm_setpriority, "setpriority", 3, 0, 0, { int cwhich, cwho, cprio; - SCM_VALIDATE_INUM_COPY (1, which, cwhich); - SCM_VALIDATE_INUM_COPY (2, who, cwho); - SCM_VALIDATE_INUM_COPY (3, prio, cprio); + cwhich = scm_to_int (which); + cwho = scm_to_int (who); + cprio = scm_to_int (prio); if (setpriority (cwhich, cwho, cprio) == -1) SCM_SYSERROR; @@ -1432,10 +1965,10 @@ SCM_DEFINE (scm_getpass, "getpass", 1, 0, 0, SCM passwd; SCM_VALIDATE_STRING (1, prompt); - SCM_STRING_COERCE_0TERMINATION_X (prompt); - p = getpass(SCM_STRING_CHARS (prompt)); - passwd = scm_makfrom0str (p); + 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)); @@ -1445,40 +1978,112 @@ SCM_DEFINE (scm_getpass, "getpass", 1, 0, 0, #undef FUNC_NAME #endif /* HAVE_GETPASS */ -#if HAVE_FLOCK +/* 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" - "@table @code\n" - "@item LOCK_SH\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" - "@item LOCK_EX\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" - "@item LOCK_UN\n" + "@end defvar\n" + "@defvar LOCK_UN\n" "Unlock the file.\n" - "@item LOCK_NB\n" - "Don't block when locking. May be specified by bitwise OR'ing\n" - "it to one of the other operations.\n" - "@end table\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 descriptior port.") + "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 coperation, fdes; + int fdes; - if (SCM_INUMP (file)) - fdes = SCM_INUM (file); + if (scm_is_integer (file)) + fdes = scm_to_int (file); else { SCM_VALIDATE_OPFPORT (2, file); fdes = SCM_FPORT_FDES (file); } - SCM_VALIDATE_INUM_COPY (2, operation, coperation); - if (flock (fdes, coperation) == -1) + if (flock (fdes, scm_to_int (operation)) == -1) SCM_SYSERROR; return SCM_UNSPECIFIED; } @@ -1493,48 +2098,102 @@ SCM_DEFINE (scm_sethostname, "sethostname", 1, 0, 0, "specified.") #define FUNC_NAME s_scm_sethostname { - SCM_VALIDATE_STRING (1, name); - SCM_STRING_COERCE_0TERMINATION_X (name); + int rv; - if (sethostname (SCM_STRING_CHARS (name), SCM_STRING_LENGTH (name)) == -1) + 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 { - /* 256 is for Solaris, under Linux ENAMETOOLONG is returned if not - large enough. */ - int len = 256, res; - char *p = scm_must_malloc (len, "gethostname"); - SCM name; +#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) { - p = scm_must_realloc (p, len, len * 2, "gethostname"); len *= 2; + + /* scm_realloc may throw an exception. */ + p = scm_realloc (p, len); res = gethostname (p, len); } + +#endif + if (res == -1) { - scm_must_free (p); + 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; } - name = scm_makfrom0str (p); - scm_must_free (p); - return name; + 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 + +void scm_init_posix () { scm_add_feature ("posix"); @@ -1542,76 +2201,92 @@ 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_sysintern ("PRIO_PROCESS", SCM_MAKINUM (PRIO_PROCESS)); + scm_c_define ("PRIO_PROCESS", scm_from_int (PRIO_PROCESS)); #endif #ifdef PRIO_PGRP - scm_sysintern ("PRIO_PGRP", SCM_MAKINUM (PRIO_PGRP)); + scm_c_define ("PRIO_PGRP", scm_from_int (PRIO_PGRP)); #endif #ifdef PRIO_USER - scm_sysintern ("PRIO_USER", SCM_MAKINUM (PRIO_USER)); + scm_c_define ("PRIO_USER", scm_from_int (PRIO_USER)); #endif #ifdef LOCK_SH - scm_sysintern ("LOCK_SH", SCM_MAKINUM (LOCK_SH)); + scm_c_define ("LOCK_SH", scm_from_int (LOCK_SH)); #endif #ifdef LOCK_EX - scm_sysintern ("LOCK_EX", SCM_MAKINUM (LOCK_EX)); + scm_c_define ("LOCK_EX", scm_from_int (LOCK_EX)); #endif #ifdef LOCK_UN - scm_sysintern ("LOCK_UN", SCM_MAKINUM (LOCK_UN)); + scm_c_define ("LOCK_UN", scm_from_int (LOCK_UN)); #endif #ifdef LOCK_NB - scm_sysintern ("LOCK_NB", SCM_MAKINUM (LOCK_NB)); + scm_c_define ("LOCK_NB", scm_from_int (LOCK_NB)); #endif #include "libguile/cpp_sig_symbols.c" -#ifndef SCM_MAGIC_SNARFER #include "libguile/posix.x" -#endif } /*