-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2004 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 library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public
*
* 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
*/
\f
-#if HAVE_CONFIG_H
+#ifdef HAVE_CONFIG_H
# include <config.h>
#endif
-/* Make GNU/Linux libc declare everything it has. */
-#define _GNU_SOURCE
-
#include <stdio.h>
#include <errno.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"
\f
#ifdef HAVE_STRING_H
#include <locale.h>
#endif
+#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 <xlocale.h>
+#endif
+
#if HAVE_CRYPT_H
# include <crypt.h>
#endif
#define F_OK 0
#endif
+/* No prototype for this on Solaris 10. The man page says it's in
+ <unistd.h> ... but it lies. */
+#if ! HAVE_DECL_SETHOSTNAME
+int sethostname (char *name, size_t namelen);
+#endif
+
/* On NextStep, <utime.h> 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. */
size = ngroups * sizeof (GETGROUPS_T);
groups = scm_malloc (size);
- getgroups (ngroups, groups);
+ ngroups = getgroups (ngroups, groups);
result = scm_c_make_vector (ngroups, SCM_BOOL_F);
while (--ngroups >= 0)
- SCM_VECTOR_SET (result, ngroups, scm_from_ulong (groups[ngroups]));
+ SCM_SIMPLE_VECTOR_SET (result, ngroups, scm_from_ulong (groups[ngroups]));
free (groups);
return result;
SCM_VALIDATE_VECTOR (SCM_ARG1, group_vec);
- ngroups = SCM_VECTOR_LENGTH (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_VECTOR_REF (group_vec, i), ulong_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_VECTOR_REF (group_vec, i));
+ SCM_OUT_OF_RANGE (1, SCM_SIMPLE_VECTOR_REF (group_vec, i));
}
size = ngroups * sizeof (GETGROUPS_T);
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_VECTOR_REF (group_vec, 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 */
if (!entry)
SCM_MISC_ERROR ("entry not found", SCM_EOL);
- SCM_VECTOR_SET(result, 0, scm_from_locale_string (entry->pw_name));
- SCM_VECTOR_SET(result, 1, scm_from_locale_string (entry->pw_passwd));
- SCM_VECTOR_SET(result, 2, scm_from_ulong (entry->pw_uid));
- SCM_VECTOR_SET(result, 3, scm_from_ulong (entry->pw_gid));
- SCM_VECTOR_SET(result, 4, scm_from_locale_string (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)
- SCM_VECTOR_SET(result, 5, scm_from_locale_string (""));
+ SCM_SIMPLE_VECTOR_SET(result, 5, scm_from_locale_string (""));
else
- SCM_VECTOR_SET(result, 5, scm_from_locale_string (entry->pw_dir));
+ SCM_SIMPLE_VECTOR_SET(result, 5, scm_from_locale_string (entry->pw_dir));
if (!entry->pw_shell)
- SCM_VECTOR_SET(result, 6, scm_from_locale_string (""));
+ SCM_SIMPLE_VECTOR_SET(result, 6, scm_from_locale_string (""));
else
- SCM_VECTOR_SET(result, 6, scm_from_locale_string (entry->pw_shell));
+ SCM_SIMPLE_VECTOR_SET(result, 6, scm_from_locale_string (entry->pw_shell));
return result;
}
#undef FUNC_NAME
if (!entry)
SCM_SYSERROR;
- SCM_VECTOR_SET(result, 0, scm_from_locale_string (entry->gr_name));
- SCM_VECTOR_SET(result, 1, scm_from_locale_string (entry->gr_passwd));
- SCM_VECTOR_SET(result, 2, scm_from_ulong (entry->gr_gid));
- SCM_VECTOR_SET(result, 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
#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),
"Sends a signal to the specified process or group of processes.\n\n"
/* Signal values are interned in scm_init_posix(). */
#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)
+ {
+ if (raise (scm_to_int (sig)) != 0)
+ {
+ err:
+ SCM_SYSERROR;
+ }
+ else
+ {
+ errno = ENOSYS;
+ goto err;
+ }
+ }
#endif
- SCM_SYSERROR;
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
{
char *result;
int fd, err;
- SCM ret;
+ SCM ret = SCM_BOOL_F;
port = SCM_COERCE_OUTPORT (port);
SCM_VALIDATE_OPPORT (1, port);
return SCM_BOOL_F;
fd = SCM_FPORT_FDES (port);
- scm_mutex_lock (&scm_i_misc_mutex);
+ scm_i_scm_pthread_mutex_lock (&scm_i_misc_mutex);
+
SCM_SYSCALL (result = ttyname (fd));
err = errno;
- ret = scm_from_locale_string (result);
- scm_mutex_unlock (&scm_i_misc_mutex);
+ 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
char *exec_file;
char **exec_argv;
- scm_frame_begin (0);
+ scm_dynwind_begin (0);
exec_file = scm_to_locale_string (filename);
- scm_frame_free (exec_file);
+ scm_dynwind_free (exec_file);
exec_argv = scm_i_allocate_string_pointers (args);
- scm_frame_unwind_handler (free_string_pointers, exec_argv,
+ scm_dynwind_unwind_handler (free_string_pointers, exec_argv,
SCM_F_WIND_EXPLICITLY);
- execv (exec_file, exec_argv);
+ 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_frame_end ();
+ scm_dynwind_end ();
return SCM_BOOL_F;
}
#undef FUNC_NAME
char *exec_file;
char **exec_argv;
- scm_frame_begin (0);
+ scm_dynwind_begin (0);
exec_file = scm_to_locale_string (filename);
- scm_frame_free (exec_file);
+ scm_dynwind_free (exec_file);
exec_argv = scm_i_allocate_string_pointers (args);
- scm_frame_unwind_handler (free_string_pointers, exec_argv,
+ scm_dynwind_unwind_handler (free_string_pointers, exec_argv,
SCM_F_WIND_EXPLICITLY);
- execvp (exec_file, exec_argv);
+ 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_frame_end ();
+ scm_dynwind_end ();
return SCM_BOOL_F;
}
#undef FUNC_NAME
char **exec_env;
char *exec_file;
- scm_frame_begin (0);
+ scm_dynwind_begin (0);
exec_file = scm_to_locale_string (filename);
- scm_frame_free (exec_file);
+ scm_dynwind_free (exec_file);
exec_argv = scm_i_allocate_string_pointers (args);
- scm_frame_unwind_handler (free_string_pointers, exec_argv,
+ scm_dynwind_unwind_handler (free_string_pointers, exec_argv,
SCM_F_WIND_EXPLICITLY);
exec_env = scm_i_allocate_string_pointers (env);
- scm_frame_unwind_handler (free_string_pointers, exec_env,
+ scm_dynwind_unwind_handler (free_string_pointers, exec_env,
SCM_F_WIND_EXPLICITLY);
- execve (exec_file, exec_argv, exec_env);
+ 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_frame_end ();
+ scm_dynwind_end ();
return SCM_BOOL_F;
}
#undef FUNC_NAME
SCM result = scm_c_make_vector (5, SCM_UNSPECIFIED);
if (uname (&buf) < 0)
SCM_SYSERROR;
- SCM_VECTOR_SET(result, 0, scm_from_locale_string (buf.sysname));
- SCM_VECTOR_SET(result, 1, scm_from_locale_string (buf.nodename));
- SCM_VECTOR_SET(result, 2, scm_from_locale_string (buf.release));
- SCM_VECTOR_SET(result, 3, scm_from_locale_string (buf.version));
- SCM_VECTOR_SET(result, 4, scm_from_locale_string (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?
- SCM_VECTOR_SET(result, 5, scm_from_locale_string (buf.domainname));
+ SCM_SIMPLE_VECTOR_SET(result, 5, scm_from_locale_string (buf.domainname));
*/
return result;
}
SCM_DEFINE (scm_mkstemp, "mkstemp!", 1, 0, 0,
(SCM tmpl),
- "Create a new unique file in the file system and returns a new\n"
+ "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 @code{XXXXXX} and will be changed in\n"
- "place to return the name of the temporary file.")
+ "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_frame_begin (0);
+ scm_dynwind_begin (0);
c_tmpl = scm_to_locale_string (tmpl);
- scm_frame_free (c_tmpl);
+ scm_dynwind_free (c_tmpl);
SCM_SYSCALL (rv = mkstemp (c_tmpl));
if (rv == -1)
SCM_INUM0, scm_string_length (tmpl),
tmpl, SCM_INUM0);
- scm_frame_end ();
+ scm_dynwind_end ();
return scm_fdes_to_port (rv, "w+", tmpl);
}
#undef FUNC_NAME
SCM_DEFINE (scm_access, "access?", 2, 0, 0,
(SCM path, SCM how),
- "Return @code{#t} if @var{path} corresponds to an existing file\n"
- "and the current process has the type of access specified by\n"
- "@var{how}, otherwise @code{#f}. @var{how} should be specified\n"
- "using the values of the variables listed below. Multiple\n"
- "values can be combined using a bitwise or, in which case\n"
- "@code{#t} will only be returned if all accesses are granted.\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"
- "Permissions are checked using the real id of the current\n"
- "process, not the effective id, although it's the effective id\n"
- "which determines whether the access would actually be granted.\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;
{
int rv;
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. */
+ /* 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);
-#else
- /* On e.g. Win32 hosts putenv() called with 'name=' removes the
- environment variable 'name'. */
+#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, "=");
e = errno; free (ptr); free (c_str); errno = e;
if (rv < 0)
SCM_SYSERROR;
-#endif /* !HAVE_UNSETENV */
+#else
+ /* otherwise traditional putenv("NAME") */
+ rv = putenv (c_str);
+ if (rv < 0)
+ SCM_SYSERROR;
+#endif
}
else
{
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;
- }
+ {
+ 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. */
}
#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, return the current value of the\n"
"the locale will be set using environment variables.")
#define FUNC_NAME s_scm_setlocale
{
+ int c_category;
char *clocale;
char *rv;
- scm_frame_begin (0);
+ scm_dynwind_begin (0);
if (SCM_UNBNDP (locale))
{
else
{
clocale = scm_to_locale_string (locale);
- scm_frame_free (clocale);
+ scm_dynwind_free (clocale);
}
- rv = setlocale (scm_to_int (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;
+ {
+ /* 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;
+ }
- scm_frame_end ();
+ /* 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
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)
"The return value is unspecified.")
#define FUNC_NAME s_scm_nice
{
+ 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 (scm_to_int (incr));
+ nice_value = nice (scm_to_int (incr));
if (errno != 0)
SCM_SYSERROR;
+
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
#define FUNC_NAME s_scm_crypt
{
SCM ret;
- char *c_key, *c_salt;
+ char *c_key, *c_salt, *c_ret;
- scm_frame_begin (0);
- scm_frame_unwind_handler ((void(*)(void*)) scm_mutex_unlock,
- &scm_i_misc_mutex,
- SCM_F_WIND_EXPLICITLY);
- scm_mutex_lock (&scm_i_misc_mutex);
+ scm_dynwind_begin (0);
+ scm_i_dynwind_pthread_mutex_lock (&scm_i_misc_mutex);
c_key = scm_to_locale_string (key);
- scm_frame_free (c_key);
+ scm_dynwind_free (c_key);
c_salt = scm_to_locale_string (salt);
- scm_frame_free (c_key);
+ scm_dynwind_free (c_salt);
- ret = scm_from_locale_string (crypt (c_key, 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;
- scm_frame_end ();
+ ret = scm_from_locale_string (c_ret);
+ scm_dynwind_end ();
return ret;
}
#undef FUNC_NAME
(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 descriptor 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 fdes;
char *const p = scm_malloc (len);
const int res = gethostname (p, len);
- scm_frame_begin (0);
- scm_frame_unwind_handler (free, p, 0);
+ scm_dynwind_begin (0);
+ scm_dynwind_unwind_handler (free, p, 0);
#else
p = scm_malloc (len);
- scm_frame_begin (0);
- scm_frame_unwind_handler (free, p, 0);
+ scm_dynwind_begin (0);
+ scm_dynwind_unwind_handler (free, p, 0);
res = gethostname (p, len);
while (res == -1 && errno == ENAMETOOLONG)
{
const int save_errno = errno;
- // No guile exceptions can occur before we have freed p's memory.
- scm_frame_end ();
+ /* No guile exceptions can occur before we have freed p's memory. */
+ scm_dynwind_end ();
free (p);
errno = save_errno;
/* 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_frame_end ();
+ /* No guile exceptions can occur before we have freed p's memory. */
+ scm_dynwind_end ();
free (p);
return name;
#endif /* HAVE_GETHOSTNAME */
-void
+void
scm_init_posix ()
{
scm_add_feature ("posix");
#ifdef 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_c_define ("PIPE_BUF", scm_from_long (PIPE_BUF));
#endif