-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
- *
+/* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
+ * 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013,
+ * 2014 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/fports.h"
-#include "libguile/scmsigs.h"
-#include "libguile/feature.h"
-#include "libguile/strings.h"
-#include "libguile/srfi-13.h"
-#include "libguile/srfi-14.h"
-#include "libguile/vectors.h"
-#include "libguile/lang.h"
-
-#include "libguile/validate.h"
-#include "libguile/posix.h"
-#include "libguile/gettext.h"
-#include "libguile/threads.h"
-\f
+#ifdef HAVE_SCHED_H
+# include <sched.h>
+#endif
#ifdef HAVE_STRING_H
#include <string.h>
# endif
#endif
-#ifdef HAVE_UNISTD_H
#include <unistd.h>
-#else
-#ifndef ttyname
-extern char *ttyname();
-#endif
-#endif
#ifdef LIBC_H_WITH_UNISTD_H
#include <libc.h>
#ifdef HAVE_IO_H
#include <io.h>
#endif
-#ifdef HAVE_WINSOCK2_H
-#include <winsock2.h>
-#endif
-#ifdef __MINGW32__
-/* Some defines for Windows here. */
-# include <process.h>
-# define pipe(fd) _pipe (fd, 256, O_BINARY)
-#endif /* __MINGW32__ */
+#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/validate.h"
+#include "libguile/posix.h"
+#include "libguile/gettext.h"
+#include "libguile/threads.h"
+\f
#if HAVE_SYS_WAIT_H
# include <sys/wait.h>
#include <signal.h>
-extern char ** environ;
-
#ifdef HAVE_GRP_H
#include <grp.h>
#endif
# include <xlocale.h>
#endif
-#if HAVE_CRYPT_H
+#ifdef HAVE_CRYPT_H
# include <crypt.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... */
int sethostname (char *name, size_t namelen);
#endif
+#if defined HAVE_GETLOGIN && !HAVE_DECL_GETLOGIN
+/* MinGW doesn't supply this decl; see
+ http://lists.gnu.org/archive/html/bug-gnulib/2013-03/msg00030.html for more
+ details. */
+char *getlogin (void);
+#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. */
-/* 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
GETGROUPS_T *groups;
ngroups = getgroups (0, NULL);
- if (ngroups <= 0)
+ if (ngroups < 0)
SCM_SYSERROR;
+ else if (ngroups == 0)
+ return scm_c_make_vector (0, SCM_BOOL_F);
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_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"
+ "in the given vector @var{group_vec}. The return value is\n"
"unspecified.\n"
"\n"
"Generally only the superuser can set the process group IDs.")
#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"
- "a string, or omitted, giving the behaviour of getpwuid, getpwnam\n"
- "or getpwent respectively.")
+ "Look up an entry in the user database. @var{user} can be an\n"
+ "integer, a string, or omitted, giving the behaviour of\n"
+ "@code{getpwuid}, @code{getpwnam} or @code{getpwent}\n"
+ "respectively.")
#define FUNC_NAME s_scm_getpwuid
{
struct passwd *entry;
/* Combines getgrgid and getgrnam. */
SCM_DEFINE (scm_getgrgid, "getgr", 0, 1, 0,
(SCM name),
- "Look up an entry in the group database. @var{obj} can be an integer,\n"
- "a string, or omitted, giving the behaviour of getgrgid, getgrnam\n"
- "or getgrent respectively.")
+ "Look up an entry in the group database. @var{name} can be an\n"
+ "integer, a string, or omitted, giving the behaviour of\n"
+ "@code{getgrgid}, @code{getgrnam} or @code{getgrent}\n"
+ "respectively.")
#define FUNC_NAME s_scm_getgrgid
{
struct group *entry;
#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 (scm_is_eq (s, sym_as))
+ return RLIMIT_AS;
+#endif
+#ifdef RLIMIT_CORE
+ if (scm_is_eq (s, sym_core))
+ return RLIMIT_CORE;
+#endif
+#ifdef RLIMIT_CPU
+ if (scm_is_eq (s, sym_cpu))
+ return RLIMIT_CPU;
+#endif
+#ifdef RLIMIT_DATA
+ if (scm_is_eq (s, sym_data))
+ return RLIMIT_DATA;
+#endif
+#ifdef RLIMIT_FSIZE
+ if (scm_is_eq (s, sym_fsize))
+ return RLIMIT_FSIZE;
+#endif
+#ifdef RLIMIT_MEMLOCK
+ if (scm_is_eq (s, sym_memlock))
+ return RLIMIT_MEMLOCK;
+#endif
+#ifdef RLIMIT_MSGQUEUE
+ if (scm_is_eq (s, sym_msgqueue))
+ return RLIMIT_MSGQUEUE;
+#endif
+#ifdef RLIMIT_NICE
+ if (scm_is_eq (s, sym_nice))
+ return RLIMIT_NICE;
+#endif
+#ifdef RLIMIT_NOFILE
+ if (scm_is_eq (s, sym_nofile))
+ return RLIMIT_NOFILE;
+#endif
+#ifdef RLIMIT_NPROC
+ if (scm_is_eq (s, sym_nproc))
+ return RLIMIT_NPROC;
+#endif
+#ifdef RLIMIT_RSS
+ if (scm_is_eq (s, sym_rss))
+ return RLIMIT_RSS;
+#endif
+#ifdef RLIMIT_RTPRIO
+ if (scm_is_eq (s, sym_rtprio))
+ return RLIMIT_RTPRIO;
+#endif
+#ifdef RLIMIT_RTPRIO
+ if (scm_is_eq (s, sym_rttime))
+ return RLIMIT_RTPRIO;
+#endif
+#ifdef RLIMIT_SIGPENDING
+ if (scm_is_eq (s, sym_sigpending))
+ return RLIMIT_SIGPENDING;
+#endif
+#ifdef RLIMIT_STACK
+ if (scm_is_eq (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 = scm_is_false (soft) ? RLIM_INFINITY : scm_to_long (soft);
+ lim.rlim_max = scm_is_false (hard) ? 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"
"group.\n"
"@item @var{pid} less than -1\n"
"Request status information for any child process whose process group ID\n"
- "is -@var{PID}.\n"
+ "is -@var{pid}.\n"
"@end table\n\n"
"The @var{options} argument, if supplied, should be the bitwise OR of the\n"
"values of zero or more of the following variables:\n\n"
#ifdef HAVE_SETEGID
-SCM_DEFINE (scm_setegid, "setegid", 1, 0, 0,
+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"
{
int rv;
-#ifdef HAVE_SETEUID
+#ifdef HAVE_SETEGID
rv = setegid (scm_to_int (id));
#else
rv = setgid (scm_to_int (id));
#undef FUNC_NAME
#endif /* HAVE_SETSID */
+#ifdef HAVE_GETSID
+SCM_DEFINE (scm_getsid, "getsid", 1, 0, 0,
+ (SCM pid),
+ "Returns the session ID of process @var{pid}. (The session\n"
+ "ID of a process is the process group ID of its session leader.)")
+#define FUNC_NAME s_scm_getsid
+{
+ return scm_from_int (getsid (scm_to_int (pid)));
+}
+#undef FUNC_NAME
+#endif /* HAVE_GETSID */
+
/* ttyname returns its result in a single static buffer, hence
scm_i_misc_mutex for thread safety. In glibc 2.3.2 two threads
#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"
+ "Executes the file named by @var{filename} as a new process image.\n"
"The remaining arguments are supplied to the process; from a C program\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"
+ "Conventionally the first @var{arg} is the same as @var{filename}.\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"
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);
+ execv (exec_file, exec_argv);
SCM_SYSERROR;
/* not reached. */
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);
+ execvp (exec_file, exec_argv);
SCM_SYSERROR;
/* not reached. */
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);
+ execve (exec_file, exec_argv, exec_env);
SCM_SYSERROR;
/* not reached. */
#define FUNC_NAME s_scm_fork
{
int pid;
+ if (scm_ilength (scm_all_threads ()) != 1)
+ /* Other threads may be holding on to resources that Guile needs --
+ it is not safe to permit one thread to fork while others are
+ running.
+
+ In addition, POSIX clearly specifies that if a multi-threaded
+ program forks, the child must only call functions that are
+ async-signal-safe. We can't guarantee that in general. The best
+ we can do is to allow forking only very early, before any call to
+ sigaction spawns the signal-handling thread. */
+ scm_display
+ (scm_from_latin1_string
+ ("warning: call to primitive-fork while multiple threads are running;\n"
+ " further behavior unspecified. See \"Processes\" in the\n"
+ " manual, for more information.\n"),
+ scm_current_warning_port ());
pid = fork ();
if (pid == -1)
SCM_SYSERROR;
return scm_from_int (pid);
}
#undef FUNC_NAME
+
+/* Since Guile uses threads, we have to be very careful to avoid calling
+ functions that are not async-signal-safe in the child. That's why
+ this function is implemented in C. */
+static SCM
+scm_open_process (SCM mode, SCM prog, SCM args)
+#define FUNC_NAME "open-process"
+{
+ long mode_bits;
+ int reading, writing;
+ int c2p[2]; /* Child to parent. */
+ int p2c[2]; /* Parent to child. */
+ int in = -1, out = -1, err = -1;
+ int pid;
+ char *exec_file;
+ char **exec_argv;
+ int max_fd = 1024;
+
+ exec_file = scm_to_locale_string (prog);
+ exec_argv = scm_i_allocate_string_pointers (scm_cons (prog, args));
+
+ mode_bits = scm_i_mode_bits (mode);
+ reading = mode_bits & SCM_RDNG;
+ writing = mode_bits & SCM_WRTNG;
+
+ if (reading)
+ {
+ if (pipe (c2p))
+ {
+ int errno_save = errno;
+ free (exec_file);
+ errno = errno_save;
+ SCM_SYSERROR;
+ }
+ out = c2p[1];
+ }
+
+ if (writing)
+ {
+ if (pipe (p2c))
+ {
+ int errno_save = errno;
+ free (exec_file);
+ if (reading)
+ {
+ close (c2p[0]);
+ close (c2p[1]);
+ }
+ errno = errno_save;
+ SCM_SYSERROR;
+ }
+ in = p2c[0];
+ }
+
+ {
+ SCM port;
+
+ if (SCM_OPOUTFPORTP ((port = scm_current_error_port ())))
+ err = SCM_FPORT_FDES (port);
+ if (out == -1 && SCM_OPOUTFPORTP ((port = scm_current_output_port ())))
+ out = SCM_FPORT_FDES (port);
+ if (in == -1 && SCM_OPINFPORTP ((port = scm_current_input_port ())))
+ in = SCM_FPORT_FDES (port);
+ }
+
+#if defined (HAVE_GETRLIMIT) && defined (RLIMIT_NOFILE)
+ {
+ struct rlimit lim = { 0, 0 };
+ if (getrlimit (RLIMIT_NOFILE, &lim) == 0)
+ max_fd = lim.rlim_cur;
+ }
+#endif
+
+ pid = fork ();
+
+ if (pid == -1)
+ {
+ int errno_save = errno;
+ free (exec_file);
+ if (reading)
+ {
+ close (c2p[0]);
+ close (c2p[1]);
+ }
+ if (writing)
+ {
+ close (p2c[0]);
+ close (p2c[1]);
+ }
+ errno = errno_save;
+ SCM_SYSERROR;
+ }
+
+ if (pid)
+ /* Parent. */
+ {
+ SCM read_port = SCM_BOOL_F, write_port = SCM_BOOL_F;
+
+ /* There is no sense in catching errors on close(). */
+ if (reading)
+ {
+ close (c2p[1]);
+ read_port = scm_fdes_to_port (c2p[0], "r0", sym_read_pipe);
+ }
+ if (writing)
+ {
+ close (p2c[0]);
+ write_port = scm_fdes_to_port (p2c[1], "w0", sym_write_pipe);
+ }
+
+ return scm_values
+ (scm_list_3 (read_port, write_port, scm_from_int (pid)));
+ }
+
+ /* The child. */
+ if (reading)
+ close (c2p[0]);
+ if (writing)
+ close (p2c[1]);
+
+ /* Close all file descriptors in ports inherited from the parent
+ except for in, out, and err. Heavy-handed, but robust. */
+ while (max_fd--)
+ if (max_fd != in && max_fd != out && max_fd != err)
+ close (max_fd);
+
+ /* Ignore errors on these open() calls. */
+ if (in == -1)
+ in = open ("/dev/null", O_RDONLY);
+ if (out == -1)
+ out = open ("/dev/null", O_WRONLY);
+ if (err == -1)
+ err = open ("/dev/null", O_WRONLY);
+
+ if (in > 0)
+ {
+ if (out == 0)
+ do out = dup (out); while (errno == EINTR);
+ if (err == 0)
+ do err = dup (err); while (errno == EINTR);
+ do dup2 (in, 0); while (errno == EINTR);
+ close (in);
+ }
+ if (out > 1)
+ {
+ if (err == 1)
+ do err = dup (err); while (errno == EINTR);
+ do dup2 (out, 1); while (errno == EINTR);
+ close (out);
+ }
+ if (err > 2)
+ {
+ do dup2 (err, 2); while (errno == EINTR);
+ close (err);
+ }
+
+ execvp (exec_file, exec_argv);
+
+ /* The exec failed! There is nothing sensible to do. */
+ if (err > 0)
+ {
+ char *msg = strerror (errno);
+ fprintf (fdopen (err, "a"), "In execlp of %s: %s\n",
+ exec_file, msg);
+ }
+
+ _exit (EXIT_FAILURE);
+ /* Not reached. */
+ return SCM_BOOL_F;
+}
+#undef FUNC_NAME
#endif /* HAVE_FORK */
#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;
}
}
#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
+SCM_DEFINE (scm_tmpfile, "tmpfile", 0, 0, 0,
+ (void),
+ "Return an input/output port to a unique temporary file\n"
+ "named using the path prefix @code{P_tmpdir} defined in\n"
+ "@file{stdio.h}.\n"
+ "The file is automatically deleted when the port is closed\n"
+ "or the program terminates.")
+#define FUNC_NAME s_scm_tmpfile
{
- char *c_tmpl;
- int rv;
-
- scm_dynwind_begin (0);
-
- c_tmpl = scm_to_locale_string (tmpl);
- scm_dynwind_free (c_tmpl);
+ FILE *rv;
+ int fd;
- SCM_SYSCALL (rv = mkstemp (c_tmpl));
- if (rv == -1)
+ if (! (rv = tmpfile ()))
SCM_SYSERROR;
- scm_substring_move_x (scm_from_locale_string (c_tmpl),
- SCM_INUM0, scm_string_length (tmpl),
- tmpl, SCM_INUM0);
+#ifndef __MINGW32__
+ fd = dup (fileno (rv));
+ fclose (rv);
+#else
+ fd = fileno (rv);
+ /* FIXME: leaking the file, it will never be closed! */
+#endif
- scm_dynwind_end ();
- return scm_fdes_to_port (rv, "w+", tmpl);
+ return scm_fdes_to_port (fd, "w+", SCM_BOOL_F);
}
#undef FUNC_NAME
-SCM_DEFINE (scm_utime, "utime", 1, 2, 0,
- (SCM pathname, SCM actime, SCM modtime),
+SCM_DEFINE (scm_utime, "utime", 1, 5, 0,
+ (SCM pathname, SCM actime, SCM modtime, SCM actimens, SCM modtimens,
+ SCM flags),
"@code{utime} sets the access and modification times for the\n"
- "file named by @var{path}. If @var{actime} or @var{modtime} is\n"
+ "file named by @var{pathname}. 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"
+ "@code{current-time} procedure.\n\n"
+ "The optional @var{actimens} and @var{modtimens} are nanoseconds\n"
+ "to add @var{actime} and @var{modtime}. Nanosecond precision is\n"
+ "only supported on some combinations of file systems and operating\n"
+ "systems.\n"
"@lisp\n"
"(utime \"foo\" (- (current-time) 3600))\n"
"@end lisp\n"
#define FUNC_NAME s_scm_utime
{
int rv;
- struct utimbuf utm_tmp;
-
+ time_t atim_sec, mtim_sec;
+ long atim_nsec, mtim_nsec;
+ int f;
+
if (SCM_UNBNDP (actime))
- SCM_SYSCALL (time (&utm_tmp.actime));
+ {
+#ifdef HAVE_UTIMENSAT
+ atim_sec = 0;
+ atim_nsec = UTIME_NOW;
+#else
+ SCM_SYSCALL (time (&atim_sec));
+ atim_nsec = 0;
+#endif
+ }
else
- utm_tmp.actime = SCM_NUM2ULONG (2, actime);
-
+ {
+ atim_sec = SCM_NUM2ULONG (2, actime);
+ if (SCM_UNBNDP (actimens))
+ atim_nsec = 0;
+ else
+ atim_nsec = SCM_NUM2LONG (4, actimens);
+ }
+
if (SCM_UNBNDP (modtime))
- SCM_SYSCALL (time (&utm_tmp.modtime));
+ {
+#ifdef HAVE_UTIMENSAT
+ mtim_sec = 0;
+ mtim_nsec = UTIME_NOW;
+#else
+ SCM_SYSCALL (time (&mtim_sec));
+ mtim_nsec = 0;
+#endif
+ }
+ else
+ {
+ mtim_sec = SCM_NUM2ULONG (3, modtime);
+ if (SCM_UNBNDP (modtimens))
+ mtim_nsec = 0;
+ else
+ mtim_nsec = SCM_NUM2LONG (5, modtimens);
+ }
+
+ if (SCM_UNBNDP (flags))
+ f = 0;
else
- utm_tmp.modtime = SCM_NUM2ULONG (3, modtime);
+ f = SCM_NUM2INT (6, flags);
+
+#ifdef HAVE_UTIMENSAT
+ {
+ struct timespec times[2];
+ times[0].tv_sec = atim_sec;
+ times[0].tv_nsec = atim_nsec;
+ times[1].tv_sec = mtim_sec;
+ times[1].tv_nsec = mtim_nsec;
+
+ STRING_SYSCALL (pathname, c_pathname,
+ rv = utimensat (AT_FDCWD, c_pathname, times, f));
+ }
+#else
+ {
+ struct utimbuf utm;
+ utm.actime = atim_sec;
+ utm.modtime = mtim_sec;
+ /* Silence warnings. */
+ (void) atim_nsec;
+ (void) mtim_nsec;
+
+ if (f != 0)
+ scm_out_of_range(FUNC_NAME, flags);
+
+ STRING_SYSCALL (pathname, c_pathname,
+ rv = utime (c_pathname, &utm));
+ }
+#endif
- STRING_SYSCALL (pathname, c_pathname,
- rv = utime (c_pathname, &utm_tmp));
if (rv != 0)
SCM_SYSERROR;
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
-SCM_DEFINE (scm_access, "access?", 2, 0, 0,
- (SCM path, SCM how),
- "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"
- "@end defvar\n"
- "@defvar W_OK\n"
- "Test for write permission.\n"
- "@end defvar\n"
- "@defvar X_OK\n"
- "Test for execute permission.\n"
- "@end defvar\n"
- "@defvar F_OK\n"
- "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;
-
- 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,
(),
"Return an integer representing the current process ID.")
SCM_DEFINE (scm_putenv, "putenv", 1, 0, 0,
(SCM str),
- "Modifies the environment of the current process, which is\n"
- "also the default environment inherited by child processes.\n\n"
- "If @var{string} is of the form @code{NAME=VALUE} then it will be written\n"
- "directly into the environment, replacing any existing environment string\n"
- "with\n"
- "name matching @code{NAME}. If @var{string} does not contain an equal\n"
- "sign, then any existing string with name matching @var{string} will\n"
- "be removed.\n\n"
+ "Modifies the environment of the current process, which is also\n"
+ "the default environment inherited by child processes. If\n"
+ "@var{str} is of the form @code{NAME=VALUE} then it will be\n"
+ "written directly into the environment, replacing any existing\n"
+ "environment string with name matching @code{NAME}. If\n"
+ "@var{str} does not contain an equal sign, then any existing\n"
+ "string with name matching @var{str} will be removed.\n"
+ "\n"
"The return value is unspecified.")
#define FUNC_NAME s_scm_putenv
{
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);
- 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. */
- /* Leave c_str in the environment. */
+ /* Gnulib's `putenv' module honors the semantics described above. */
+ rv = putenv (c_str);
+ if (rv < 0)
+ SCM_SYSERROR;
- rv = putenv (c_str);
- 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_default_port_encoding (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);
nice (scm_to_int (incr));
if (errno != 0)
SCM_SYSERROR;
+
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
multiple cpus. So for now we don't bother with anything fancy, just
ensure it works. */
-#if HAVE_CRYPT
+#ifdef 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"
#undef FUNC_NAME
#endif /* HAVE_CHROOT */
-
-#ifdef __MINGW32__
-/* Wrapper function to supplying `getlogin()' under Windows. */
-static char * getlogin (void)
-{
- static char user[256];
- static unsigned long len = 256;
-
- if (!GetUserName (user, &len))
- return NULL;
- return user;
-}
-#endif /* __MINGW32__ */
-
-
-#if defined (HAVE_GETLOGIN) || defined (__MINGW32__)
SCM_DEFINE (scm_getlogin, "getlogin", 0, 0, 0,
(void),
"Return a string containing the name of the user logged in on\n"
return scm_from_locale_string (p);
}
#undef FUNC_NAME
-#endif /* HAVE_GETLOGIN */
-
-#if HAVE_CUSERID
-SCM_DEFINE (scm_cuserid, "cuserid", 0, 0, 0,
- (void),
- "Return a string containing a user name associated with the\n"
- "effective user id of the process. Return @code{#f} if this\n"
- "information cannot be obtained.")
-#define FUNC_NAME s_scm_cuserid
-{
- char buf[L_cuserid];
- char * p;
-
- p = cuserid (buf);
- if (!p || !*p)
- return SCM_BOOL_F;
- return scm_from_locale_string (p);
-}
-#undef FUNC_NAME
-#endif /* HAVE_CUSERID */
#if HAVE_GETPRIORITY
SCM_DEFINE (scm_getpriority, "getpriority", 2, 0, 0,
#undef FUNC_NAME
#endif /* HAVE_SETPRIORITY */
+#ifdef HAVE_SCHED_GETAFFINITY
+
+static SCM
+cpu_set_to_bitvector (const cpu_set_t *cs)
+{
+ SCM bv;
+ size_t cpu;
+
+ bv = scm_c_make_bitvector (CPU_SETSIZE, SCM_BOOL_F);
+
+ for (cpu = 0; cpu < CPU_SETSIZE; cpu++)
+ {
+ if (CPU_ISSET (cpu, cs))
+ /* XXX: This is inefficient but avoids code duplication. */
+ scm_c_bitvector_set_x (bv, cpu, SCM_BOOL_T);
+ }
+
+ return bv;
+}
+
+SCM_DEFINE (scm_getaffinity, "getaffinity", 1, 0, 0,
+ (SCM pid),
+ "Return a bitvector representing the CPU affinity mask for\n"
+ "process @var{pid}. Each CPU the process has affinity with\n"
+ "has its corresponding bit set in the returned bitvector.\n"
+ "The number of bits set is a good estimate of how many CPUs\n"
+ "Guile can use without stepping on other processes' toes.\n\n"
+ "Currently this procedure is only defined on GNU variants\n"
+ "(@pxref{CPU Affinity, @code{sched_getaffinity},, libc, The\n"
+ "GNU C Library Reference Manual}).\n")
+#define FUNC_NAME s_scm_getaffinity
+{
+ int err;
+ cpu_set_t cs;
+
+ CPU_ZERO (&cs);
+ err = sched_getaffinity (scm_to_int (pid), sizeof (cs), &cs);
+ if (err)
+ SCM_SYSERROR;
+
+ return cpu_set_to_bitvector (&cs);
+}
+#undef FUNC_NAME
+
+#endif /* HAVE_SCHED_GETAFFINITY */
+
+#ifdef HAVE_SCHED_SETAFFINITY
+
+SCM_DEFINE (scm_setaffinity, "setaffinity", 2, 0, 0,
+ (SCM pid, SCM mask),
+ "Install the CPU affinity mask @var{mask}, a bitvector, for\n"
+ "the process or thread with ID @var{pid}. The return value\n"
+ "is unspecified.\n\n"
+ "Currently this procedure is only defined on GNU variants\n"
+ "(@pxref{CPU Affinity, @code{sched_setaffinity},, libc, The\n"
+ "GNU C Library Reference Manual}).\n")
+#define FUNC_NAME s_scm_setaffinity
+{
+ cpu_set_t cs;
+ scm_t_array_handle handle;
+ const scm_t_uint32 *c_mask;
+ size_t len, off, cpu;
+ ssize_t inc;
+ int err;
+
+ c_mask = scm_bitvector_elements (mask, &handle, &off, &len, &inc);
+
+ CPU_ZERO (&cs);
+ for (cpu = 0; cpu < len; cpu++)
+ {
+ size_t idx;
+
+ idx = cpu * inc + off;
+ if (c_mask[idx / 32] & (1UL << (idx % 32)))
+ CPU_SET (cpu, &cs);
+ }
+
+ err = sched_setaffinity (scm_to_int (pid), sizeof (cs), &cs);
+ if (err)
+ SCM_SYSERROR;
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+#endif /* HAVE_SCHED_SETAFFINITY */
+
+\f
#if HAVE_GETPASS
SCM_DEFINE (scm_getpass, "getpass", 1, 0, 0,
(SCM prompt),
#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,
#undef FUNC_NAME
#endif /* HAVE_GETHOSTNAME */
+\f
+#ifdef HAVE_FORK
+static void
+scm_init_popen (void)
+{
+ scm_c_define_gsubr ("open-process", 2, 0, 1, scm_open_process);
+}
+#endif
void
scm_init_posix ()
{
scm_add_feature ("posix");
+#ifdef EXIT_SUCCESS
+ scm_c_define ("EXIT_SUCCESS", scm_from_int (EXIT_SUCCESS));
+#endif
+#ifdef EXIT_FAILURE
+ scm_c_define ("EXIT_FAILURE", scm_from_int (EXIT_FAILURE));
+#endif
#ifdef HAVE_GETEUID
scm_add_feature ("EIDs");
#endif
scm_c_define ("WUNTRACED", scm_from_int (WUNTRACED));
#endif
- /* access() symbols. */
- 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_c_define ("LC_COLLATE", scm_from_int (LC_COLLATE));
#endif
scm_c_define ("LOCK_NB", scm_from_int (LOCK_NB));
#endif
-#include "libguile/cpp_sig_symbols.c"
+#include "libguile/cpp-SIG.c"
#include "libguile/posix.x"
+
+#ifdef HAVE_FORK
+ scm_add_feature ("fork");
+ scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
+ "scm_init_popen",
+ (scm_t_extension_init_func) scm_init_popen,
+ NULL);
+#endif /* HAVE_FORK */
}
/*
HCoop / bpt / guile.git / blobdiff