-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2004, 2005, 2006, 2007 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 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
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * 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.
*
* 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
+ * 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
+#include <stdlib.h>
#include <stdio.h>
#include <errno.h>
+#include <uniconv.h>
#include "libguile/_scm.h"
#include "libguile/dynwind.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 <signal.h>
-extern char ** environ;
-
#ifdef HAVE_GRP_H
#include <grp.h>
#endif
# include <sys/resource.h>
#endif
-#if HAVE_SYS_FILE_H
-# include <sys/file.h>
-#endif
-
-#if HAVE_CRT_EXTERNS_H
-#include <crt_externs.h> /* for Darwin _NSGetEnviron */
-#endif
+#include <sys/file.h> /* from Gnulib */
/* Some Unix systems don't define these. CPP hair is dangerous, but
this seems safe enough... */
-/* 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
-
\f
/* Two often used patterns
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)
#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"
#undef FUNC_NAME
#endif /* HAVE_TCSETPGRP */
-static void
-free_string_pointers (void *data)
-{
- 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"
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__
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__
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__
return scm_makfromstrs (-1, environ);
else
{
- char **new_environ;
-
- new_environ = scm_i_allocate_string_pointers (env);
- /* Free the old environment, except when called for the first
- * time.
- */
- {
- static int first = 1;
- if (!first)
- scm_i_free_string_pointers (environ);
- first = 0;
- }
- environ = new_environ;
+ environ = scm_i_allocate_string_pointers (env);
return SCM_UNSPECIFIED;
}
}
int rv;
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);
- free (c_str);
+ /* Leave C_STR in the environment. */
- 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);
- free (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';
- free (c_str);
-
- return SCM_UNSPECIFIED;
- }
- }
-#endif /* __MINGW32__ */
-
- /* Leave c_str in the environment. */
-
- rv = putenv (c_str);
- free (c_str);
+ /* Gnulib's `putenv' module honors the semantics described above. */
+ rv = putenv (c_str);
+ if (rv < 0)
+ SCM_SYSERROR;
- if (rv < 0)
- SCM_SYSERROR;
- }
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
"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.")
+ "the locale will be set using environment variables.\n"
+ "\n"
+ "When the locale is changed, the character encoding of the new\n"
+ "locale (UTF-8, ISO-8859-1, etc.) is used for the current\n"
+ "input, output, and error ports\n")
#define FUNC_NAME s_scm_setlocale
{
int c_category;
char *clocale;
char *rv;
+ const char *enc;
scm_dynwind_begin (0);
SCM_SYSERROR;
}
- /* Recompute the standard SRFI-14 character sets in a locale-dependent
- (actually charset-dependent) way. */
- scm_srfi_14_compute_char_sets ();
+ enc = locale_charset ();
+ /* Set the default encoding for new ports. */
+ scm_i_set_port_encoding_x (SCM_BOOL_F, enc);
+ /* Set the encoding for the stdio ports. */
+ scm_i_set_port_encoding_x (scm_current_input_port (), enc);
+ scm_i_set_port_encoding_x (scm_current_output_port (), enc);
+ scm_i_set_port_encoding_x (scm_current_error_port (), enc);
scm_dynwind_end ();
return scm_from_locale_string (rv);
"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
#endif /* HAVE_GETLOGIN */
#if HAVE_CUSERID
+
+# if !HAVE_DECL_CUSERID
+extern char *cuserid (char *);
+# endif
+
SCM_DEFINE (scm_cuserid, "cuserid", 0, 0, 0,
(void),
"Return a string containing a user name associated with the\n"
#undef FUNC_NAME
#endif /* HAVE_GETPASS */
-/* Wrapper function for flock() support under M$-Windows. */
-#ifdef __MINGW32__
-# include <io.h>
-# include <sys/locking.h>
-# include <errno.h>
-# 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"
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
-#endif /* HAVE_FLOCK */
#if HAVE_SETHOSTNAME
SCM_DEFINE (scm_sethostname, "sethostname", 1, 0, 0,
HCoop / bpt / guile.git / blobdiff