-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 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 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 3 of
#include <errno.h>
#include <uniconv.h>
+#ifdef HAVE_SCHED_H
+# include <sched.h>
+#endif
+
#include "libguile/_scm.h"
#include "libguile/dynwind.h"
#include "libguile/fports.h"
#endif
#include <sys/file.h> /* from Gnulib */
-#include <nproc.h>
/* Some Unix systems don't define these. CPP hair is dangerous, but
this seems safe enough... */
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);
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;
SCM_ASSERT_TYPE (scm_is_symbol (s), s, pos, func, "symbol");
#ifdef RLIMIT_AS
- if (s == sym_as)
+ if (scm_is_eq (s, sym_as))
return RLIMIT_AS;
#endif
#ifdef RLIMIT_CORE
- if (s == sym_core)
+ if (scm_is_eq (s, sym_core))
return RLIMIT_CORE;
#endif
#ifdef RLIMIT_CPU
- if (s == sym_cpu)
+ if (scm_is_eq (s, sym_cpu))
return RLIMIT_CPU;
#endif
#ifdef RLIMIT_DATA
- if (s == sym_data)
+ if (scm_is_eq (s, sym_data))
return RLIMIT_DATA;
#endif
#ifdef RLIMIT_FSIZE
- if (s == sym_fsize)
+ if (scm_is_eq (s, sym_fsize))
return RLIMIT_FSIZE;
#endif
#ifdef RLIMIT_MEMLOCK
- if (s == sym_memlock)
+ if (scm_is_eq (s, sym_memlock))
return RLIMIT_MEMLOCK;
#endif
#ifdef RLIMIT_MSGQUEUE
- if (s == sym_msgqueue)
+ if (scm_is_eq (s, sym_msgqueue))
return RLIMIT_MSGQUEUE;
#endif
#ifdef RLIMIT_NICE
- if (s == sym_nice)
+ if (scm_is_eq (s, sym_nice))
return RLIMIT_NICE;
#endif
#ifdef RLIMIT_NOFILE
- if (s == sym_nofile)
+ if (scm_is_eq (s, sym_nofile))
return RLIMIT_NOFILE;
#endif
#ifdef RLIMIT_NPROC
- if (s == sym_nproc)
+ if (scm_is_eq (s, sym_nproc))
return RLIMIT_NPROC;
#endif
#ifdef RLIMIT_RSS
- if (s == sym_rss)
+ if (scm_is_eq (s, sym_rss))
return RLIMIT_RSS;
#endif
#ifdef RLIMIT_RTPRIO
- if (s == sym_rtprio)
+ if (scm_is_eq (s, sym_rtprio))
return RLIMIT_RTPRIO;
#endif
#ifdef RLIMIT_RTPRIO
- if (s == sym_rttime)
+ if (scm_is_eq (s, sym_rttime))
return RLIMIT_RTPRIO;
#endif
#ifdef RLIMIT_SIGPENDING
- if (s == sym_sigpending)
+ if (scm_is_eq (s, sym_sigpending))
return RLIMIT_SIGPENDING;
#endif
#ifdef RLIMIT_STACK
- if (s == sym_stack)
+ if (scm_is_eq (s, sym_stack))
return RLIMIT_STACK;
#endif
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);
+ 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);
"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"
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"
#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], "r", sym_read_pipe);
+ scm_setvbuf (read_port, scm_from_int (_IONBF), SCM_UNDEFINED);
+ }
+ if (writing)
+ {
+ close (p2c[0]);
+ write_port = scm_fdes_to_port (p2c[1], "w", sym_write_pipe);
+ scm_setvbuf (write_port, scm_from_int (_IONBF), SCM_UNDEFINED);
+ }
+
+ 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,
+#ifdef __MINGW32__
+ /* extra "const" in mingw formals, provokes warning from gcc */
+ (const char * const *)
+#endif
+ 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__
#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_tmpfile, "tmpfile", 0, 0, 0,
(void),
"Return an input/output port to a unique temporary file\n"
#define FUNC_NAME s_scm_tmpfile
{
FILE *rv;
+ int fd;
if (! (rv = tmpfile ()))
SCM_SYSERROR;
- return scm_fdes_to_port (fileno (rv), "w+", SCM_BOOL_F);
+
+#ifndef __MINGW32__
+ fd = dup (fileno (rv));
+ fclose (rv);
+#else
+ fd = fileno (rv);
+ /* FIXME: leaking the file, it will never be closed! */
+#endif
+
+ return scm_fdes_to_port (fd, "w+", SCM_BOOL_F);
}
#undef FUNC_NAME
(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\n"
}
#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
{
#endif /* HAVE_SCHED_SETAFFINITY */
-SCM_DEFINE (scm_total_processor_count, "total-processor-count", 0, 0, 0,
- (void),
- "Return the total number of processors of the machine, which\n"
- "is guaranteed to be at least 1. A ``processor'' here is a\n"
- "thread execution unit, which can be either:\n\n"
- "@itemize\n"
- "@item an execution core in a (possibly multi-core) chip, in a\n"
- " (possibly multi- chip) module, in a single computer, or\n"
- "@item a thread execution unit inside a core in the case of\n"
- " @dfn{hyper-threaded} CPUs.\n"
- "@end itemize\n\n"
- "Which of the two definitions is used, is unspecified.\n")
-#define FUNC_NAME s_scm_total_processor_count
-{
- return scm_from_ulong (num_processors (NPROC_ALL));
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_current_processor_count, "current-processor-count", 0, 0, 0,
- (void),
- "Like @code{total-processor-count}, but return the number of\n"
- "processors available to the current process. See\n"
- "@code{setaffinity} and @code{getaffinity} for more\n"
- "information.\n")
-#define FUNC_NAME s_scm_current_processor_count
-{
- return scm_from_ulong (num_processors (NPROC_CURRENT));
-}
-#undef FUNC_NAME
-
\f
#if HAVE_GETPASS
SCM_DEFINE (scm_getpass, "getpass", 1, 0, 0,
#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_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
#include "libguile/cpp-SIG.c"
#include "libguile/posix.x"
+
+#ifdef HAVE_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