-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
*
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
- * Boston, MA 02111-1307 USA
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
*
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
*
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice. */
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
-/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
- gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
\f
-
-/* Make GNU/Linux libc declare everything it has. */
-#define _GNU_SOURCE
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
#include <stdio.h>
#include <errno.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/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 <sys/stat.h>
#include <fcntl.h>
+#ifdef HAVE_PWD_H
#include <pwd.h>
+#endif
+#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__ */
#if HAVE_SYS_WAIT_H
# include <sys/wait.h>
extern char ** environ;
+#ifdef HAVE_GRP_H
#include <grp.h>
+#endif
+#ifdef HAVE_SYS_UTSNAME_H
#include <sys/utsname.h>
-
-#if HAVE_DIRENT_H
-# include <dirent.h>
-# define NAMLEN(dirent) strlen((dirent)->d_name)
-#else
-# define dirent direct
-# define NAMLEN(dirent) (dirent)->d_namlen
-# if HAVE_SYS_NDIR_H
-# include <sys/ndir.h>
-# endif
-# if HAVE_SYS_DIR_H
-# include <sys/dir.h>
-# endif
-# if HAVE_NDIR_H
-# include <ndir.h>
-# endif
#endif
#ifdef HAVE_SETLOCALE
#include <locale.h>
#endif
-#if HAVE_LIBCRYPT && HAVE_CRYPT_H
+#if (defined HAVE_NEWLOCALE) && (defined HAVE_STRCOLL_L)
+# define USE_GNU_LOCALE_API
+#endif
+
+#if (defined USE_GNU_LOCALE_API) && (defined HAVE_XLOCALE_H)
+# include <xlocale.h>
+#endif
+
+#if HAVE_CRYPT_H
# include <crypt.h>
#endif
+#ifdef HAVE_NETDB_H
+#include <netdb.h> /* for MAXHOSTNAMELEN on Solaris */
+#endif
+
+#ifdef HAVE_SYS_PARAM_H
+#include <sys/param.h> /* for MAXHOSTNAMELEN */
+#endif
+
#if HAVE_SYS_RESOURCE_H
# include <sys/resource.h>
#endif
# include <sys/file.h>
#endif
+#if HAVE_CRT_EXTERNS_H
+#include <crt_externs.h> /* for Darwin _NSGetEnviron */
+#endif
+
/* Some Unix systems don't define these. CPP hair is dangerous, but
this seems safe enough... */
#ifndef R_OK
#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. */
/* Please don't add any more #includes or #defines here. The hack
above means that _POSIX_SOURCE may be #defined, which will
- encourage header files to do strange things. */
+ encourage header files to do strange things.
+
+ FIXME: Maybe should undef _POSIX_SOURCE after it's done its job.
+
+ FIXME: Probably should do all the includes first, then all the fallback
+ declarations and defines, in case things are not in the header we
+ imagine. */
+
+
+
+
+/* On Apple Darwin in a shared library there's no "environ" to access
+ directly, instead the address of that variable must be obtained with
+ _NSGetEnviron(). */
+#if HAVE__NSGETENVIRON && defined (PIC)
+#define environ (*_NSGetEnviron())
+#endif
+
+\f
+
+/* Two often used patterns
+ */
+
+#define WITH_STRING(str,cstr,code) \
+ do { \
+ char *cstr = scm_to_locale_string (str); \
+ code; \
+ free (cstr); \
+ } while (0)
+
+#define STRING_SYSCALL(str,cstr,code) \
+ do { \
+ int eno; \
+ char *cstr = scm_to_locale_string (str); \
+ SCM_SYSCALL (code); \
+ eno = errno; free (cstr); errno = eno; \
+ } while (0)
+
\f
SCM_SYMBOL (sym_read_pipe, "read pipe");
SCM_DEFINE (scm_getgroups, "getgroups", 0, 0, 0,
(),
"Return a vector of integers representing the current\n"
- "supplimentary group IDs.")
+ "supplementary group IDs.")
#define FUNC_NAME s_scm_getgroups
{
- SCM ans;
+ SCM result;
int ngroups;
- scm_sizet size;
+ size_t size;
GETGROUPS_T *groups;
ngroups = getgroups (0, NULL);
SCM_SYSERROR;
size = ngroups * sizeof (GETGROUPS_T);
- groups = scm_must_malloc (size, FUNC_NAME);
- getgroups (ngroups, groups);
+ groups = scm_malloc (size);
+ ngroups = getgroups (ngroups, groups);
- ans = scm_c_make_vector (ngroups, SCM_UNDEFINED);
+ result = scm_c_make_vector (ngroups, SCM_BOOL_F);
while (--ngroups >= 0)
- SCM_VELTS (ans) [ngroups] = SCM_MAKINUM (groups [ngroups]);
-
- scm_must_free (groups);
- scm_done_free (size);
+ SCM_SIMPLE_VECTOR_SET (result, ngroups, scm_from_ulong (groups[ngroups]));
- return ans;
+ free (groups);
+ return result;
}
#undef FUNC_NAME
#endif
+#ifdef HAVE_SETGROUPS
+SCM_DEFINE (scm_setgroups, "setgroups", 1, 0, 0,
+ (SCM group_vec),
+ "Set the current set of supplementary group IDs to the integers\n"
+ "in the given vector @var{vec}. The return value is\n"
+ "unspecified.\n"
+ "\n"
+ "Generally only the superuser can set the process group IDs.")
+#define FUNC_NAME s_scm_setgroups
+{
+ size_t ngroups;
+ size_t size;
+ size_t i;
+ int result;
+ int save_errno;
+ GETGROUPS_T *groups;
+
+ SCM_VALIDATE_VECTOR (SCM_ARG1, group_vec);
+
+ ngroups = SCM_SIMPLE_VECTOR_LENGTH (group_vec);
+
+ /* validate before allocating, so we don't have to worry about leaks */
+ for (i = 0; i < ngroups; i++)
+ {
+ unsigned long ulong_gid;
+ GETGROUPS_T gid;
+ SCM_VALIDATE_ULONG_COPY (1, SCM_SIMPLE_VECTOR_REF (group_vec, i),
+ ulong_gid);
+ gid = ulong_gid;
+ if (gid != ulong_gid)
+ SCM_OUT_OF_RANGE (1, SCM_SIMPLE_VECTOR_REF (group_vec, i));
+ }
+
+ size = ngroups * sizeof (GETGROUPS_T);
+ if (size / sizeof (GETGROUPS_T) != ngroups)
+ SCM_OUT_OF_RANGE (SCM_ARG1, scm_from_int (ngroups));
+ groups = scm_malloc (size);
+ for(i = 0; i < ngroups; i++)
+ groups [i] = SCM_NUM2ULONG (1, SCM_SIMPLE_VECTOR_REF (group_vec, i));
+
+ result = setgroups (ngroups, groups);
+ save_errno = errno; /* don't let free() touch errno */
+ free (groups);
+ errno = save_errno;
+ if (result < 0)
+ SCM_SYSERROR;
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+#endif
+#ifdef HAVE_GETPWENT
SCM_DEFINE (scm_getpwuid, "getpw", 0, 1, 0,
(SCM user),
"Look up an entry in the user database. @var{obj} can be an integer,\n"
"or getpwent respectively.")
#define FUNC_NAME s_scm_getpwuid
{
- SCM result;
struct passwd *entry;
- SCM *ve;
- result = scm_c_make_vector (7, SCM_UNSPECIFIED);
- ve = SCM_VELTS (result);
- if (SCM_UNBNDP (user) || SCM_FALSEP (user))
+ SCM result = scm_c_make_vector (7, SCM_UNSPECIFIED);
+ if (SCM_UNBNDP (user) || scm_is_false (user))
{
SCM_SYSCALL (entry = getpwent ());
if (! entry)
return SCM_BOOL_F;
}
}
- else if (SCM_INUMP (user))
+ else if (scm_is_integer (user))
{
- entry = getpwuid (SCM_INUM (user));
+ entry = getpwuid (scm_to_int (user));
}
else
{
- SCM_VALIDATE_STRING (1, user);
- SCM_STRING_COERCE_0TERMINATION_X (user);
- entry = getpwnam (SCM_STRING_CHARS (user));
+ WITH_STRING (user, c_user,
+ entry = getpwnam (c_user));
}
if (!entry)
SCM_MISC_ERROR ("entry not found", SCM_EOL);
- ve[0] = scm_makfrom0str (entry->pw_name);
- ve[1] = scm_makfrom0str (entry->pw_passwd);
- ve[2] = scm_ulong2num ((unsigned long) entry->pw_uid);
- ve[3] = scm_ulong2num ((unsigned long) entry->pw_gid);
- ve[4] = scm_makfrom0str (entry->pw_gecos);
+ SCM_SIMPLE_VECTOR_SET(result, 0, scm_from_locale_string (entry->pw_name));
+ SCM_SIMPLE_VECTOR_SET(result, 1, scm_from_locale_string (entry->pw_passwd));
+ SCM_SIMPLE_VECTOR_SET(result, 2, scm_from_ulong (entry->pw_uid));
+ SCM_SIMPLE_VECTOR_SET(result, 3, scm_from_ulong (entry->pw_gid));
+ SCM_SIMPLE_VECTOR_SET(result, 4, scm_from_locale_string (entry->pw_gecos));
if (!entry->pw_dir)
- ve[5] = scm_makfrom0str ("");
+ SCM_SIMPLE_VECTOR_SET(result, 5, scm_from_locale_string (""));
else
- ve[5] = scm_makfrom0str (entry->pw_dir);
+ SCM_SIMPLE_VECTOR_SET(result, 5, scm_from_locale_string (entry->pw_dir));
if (!entry->pw_shell)
- ve[6] = scm_makfrom0str ("");
+ SCM_SIMPLE_VECTOR_SET(result, 6, scm_from_locale_string (""));
else
- ve[6] = scm_makfrom0str (entry->pw_shell);
+ SCM_SIMPLE_VECTOR_SET(result, 6, scm_from_locale_string (entry->pw_shell));
return result;
}
#undef FUNC_NAME
+#endif /* HAVE_GETPWENT */
#ifdef HAVE_SETPWENT
"@code{endpwent} procedures are implemented on top of this.")
#define FUNC_NAME s_scm_setpwent
{
- if (SCM_UNBNDP (arg) || SCM_FALSEP (arg))
+ if (SCM_UNBNDP (arg) || scm_is_false (arg))
endpwent ();
else
setpwent ();
#endif
-
+#ifdef HAVE_GETGRENT
/* Combines getgrgid and getgrnam. */
SCM_DEFINE (scm_getgrgid, "getgr", 0, 1, 0,
(SCM name),
"or getgrent respectively.")
#define FUNC_NAME s_scm_getgrgid
{
- SCM result;
struct group *entry;
- SCM *ve;
- result = scm_c_make_vector (4, SCM_UNSPECIFIED);
- ve = SCM_VELTS (result);
- if (SCM_UNBNDP (name) || SCM_FALSEP (name))
+ SCM result = scm_c_make_vector (4, SCM_UNSPECIFIED);
+
+ if (SCM_UNBNDP (name) || scm_is_false (name))
{
SCM_SYSCALL (entry = getgrent ());
if (! entry)
return SCM_BOOL_F;
}
}
- else if (SCM_INUMP (name))
- SCM_SYSCALL (entry = getgrgid (SCM_INUM (name)));
+ else if (scm_is_integer (name))
+ SCM_SYSCALL (entry = getgrgid (scm_to_int (name)));
else
- {
- SCM_VALIDATE_STRING (1, name);
- SCM_STRING_COERCE_0TERMINATION_X (name);
- SCM_SYSCALL (entry = getgrnam (SCM_STRING_CHARS (name)));
- }
+ STRING_SYSCALL (name, c_name,
+ entry = getgrnam (c_name));
if (!entry)
SCM_SYSERROR;
- ve[0] = scm_makfrom0str (entry->gr_name);
- ve[1] = scm_makfrom0str (entry->gr_passwd);
- ve[2] = scm_ulong2num ((unsigned long) entry->gr_gid);
- ve[3] = scm_makfromstrs (-1, entry->gr_mem);
+ SCM_SIMPLE_VECTOR_SET(result, 0, scm_from_locale_string (entry->gr_name));
+ SCM_SIMPLE_VECTOR_SET(result, 1, scm_from_locale_string (entry->gr_passwd));
+ SCM_SIMPLE_VECTOR_SET(result, 2, scm_from_ulong (entry->gr_gid));
+ SCM_SIMPLE_VECTOR_SET(result, 3, scm_makfromstrs (-1, entry->gr_mem));
return result;
}
#undef FUNC_NAME
"@code{endgrent} procedures are implemented on top of this.")
#define FUNC_NAME s_scm_setgrent
{
- if (SCM_UNBNDP (arg) || SCM_FALSEP (arg))
+ if (SCM_UNBNDP (arg) || scm_is_false (arg))
endgrent ();
else
setgrent ();
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
+#endif /* HAVE_GETGRENT */
+#ifdef HAVE_GETRLIMIT
+#ifdef RLIMIT_AS
+SCM_SYMBOL (sym_as, "as");
+#endif
+#ifdef RLIMIT_CORE
+SCM_SYMBOL (sym_core, "core");
+#endif
+#ifdef RLIMIT_CPU
+SCM_SYMBOL (sym_cpu, "cpu");
+#endif
+#ifdef RLIMIT_DATA
+SCM_SYMBOL (sym_data, "data");
+#endif
+#ifdef RLIMIT_FSIZE
+SCM_SYMBOL (sym_fsize, "fsize");
+#endif
+#ifdef RLIMIT_MEMLOCK
+SCM_SYMBOL (sym_memlock, "memlock");
+#endif
+#ifdef RLIMIT_MSGQUEUE
+SCM_SYMBOL (sym_msgqueue, "msgqueue");
+#endif
+#ifdef RLIMIT_NICE
+SCM_SYMBOL (sym_nice, "nice");
+#endif
+#ifdef RLIMIT_NOFILE
+SCM_SYMBOL (sym_nofile, "nofile");
+#endif
+#ifdef RLIMIT_NPROC
+SCM_SYMBOL (sym_nproc, "nproc");
+#endif
+#ifdef RLIMIT_RSS
+SCM_SYMBOL (sym_rss, "rss");
+#endif
+#ifdef RLIMIT_RTPRIO
+SCM_SYMBOL (sym_rtprio, "rtprio");
+#endif
+#ifdef RLIMIT_RTPRIO
+SCM_SYMBOL (sym_rttime, "rttime");
+#endif
+#ifdef RLIMIT_SIGPENDING
+SCM_SYMBOL (sym_sigpending, "sigpending");
+#endif
+#ifdef RLIMIT_STACK
+SCM_SYMBOL (sym_stack, "stack");
+#endif
+
+static int
+scm_to_resource (SCM s, const char *func, int pos)
+{
+ if (scm_is_number (s))
+ return scm_to_int (s);
+
+ SCM_ASSERT_TYPE (scm_is_symbol (s), s, pos, func, "symbol");
+
+#ifdef RLIMIT_AS
+ if (s == sym_as)
+ return RLIMIT_AS;
+#endif
+#ifdef RLIMIT_CORE
+ if (s == sym_core)
+ return RLIMIT_CORE;
+#endif
+#ifdef RLIMIT_CPU
+ if (s == sym_cpu)
+ return RLIMIT_CPU;
+#endif
+#ifdef RLIMIT_DATA
+ if (s == sym_data)
+ return RLIMIT_DATA;
+#endif
+#ifdef RLIMIT_FSIZE
+ if (s == sym_fsize)
+ return RLIMIT_FSIZE;
+#endif
+#ifdef RLIMIT_MEMLOCK
+ if (s == sym_memlock)
+ return RLIMIT_MEMLOCK;
+#endif
+#ifdef RLIMIT_MSGQUEUE
+ if (s == sym_msgqueue)
+ return RLIMIT_MSGQUEUE;
+#endif
+#ifdef RLIMIT_NICE
+ if (s == sym_nice)
+ return RLIMIT_NICE;
+#endif
+#ifdef RLIMIT_NOFILE
+ if (s == sym_nofile)
+ return RLIMIT_NOFILE;
+#endif
+#ifdef RLIMIT_NPROC
+ if (s == sym_nproc)
+ return RLIMIT_NPROC;
+#endif
+#ifdef RLIMIT_RSS
+ if (s == sym_rss)
+ return RLIMIT_RSS;
+#endif
+#ifdef RLIMIT_RTPRIO
+ if (s == sym_rtprio)
+ return RLIMIT_RTPRIO;
+#endif
+#ifdef RLIMIT_RTPRIO
+ if (s == sym_rttime)
+ return RLIMIT_RTPRIO;
+#endif
+#ifdef RLIMIT_SIGPENDING
+ if (s == sym_sigpending)
+ return RLIMIT_SIGPENDING;
+#endif
+#ifdef RLIMIT_STACK
+ if (s == sym_stack)
+ return RLIMIT_STACK;
+#endif
+
+ scm_misc_error (func, "invalid rlimit resource ~A", scm_list_1 (s));
+ return 0;
+}
+
+SCM_DEFINE (scm_getrlimit, "getrlimit", 1, 0, 0,
+ (SCM resource),
+ "Get a resource limit for this process. @var{resource} identifies the resource,\n"
+ "either as an integer or as a symbol. For example, @code{(getrlimit 'stack)}\n"
+ "gets the limits associated with @code{RLIMIT_STACK}.\n\n"
+ "@code{getrlimit} returns two values, the soft and the hard limit. If no\n"
+ "limit is set for the resource in question, the returned limit will be @code{#f}.")
+#define FUNC_NAME s_scm_getrlimit
+{
+ int iresource;
+ struct rlimit lim = { 0, 0 };
+
+ iresource = scm_to_resource (resource, FUNC_NAME, 1);
+
+ if (getrlimit (iresource, &lim) != 0)
+ scm_syserror (FUNC_NAME);
+
+ return scm_values (scm_list_2 ((lim.rlim_cur == RLIM_INFINITY) ? SCM_BOOL_F
+ : scm_from_long (lim.rlim_cur),
+ (lim.rlim_max == RLIM_INFINITY) ? SCM_BOOL_F
+ : scm_from_long (lim.rlim_max)));
+}
+#undef FUNC_NAME
+
+
+#ifdef HAVE_SETRLIMIT
+SCM_DEFINE (scm_setrlimit, "setrlimit", 3, 0, 0,
+ (SCM resource, SCM soft, SCM hard),
+ "Set a resource limit for this process. @var{resource} identifies the resource,\n"
+ "either as an integer or as a symbol. @var{soft} and @var{hard} should be integers,\n"
+ "or @code{#f} to indicate no limit (i.e., @code{RLIM_INFINITY}).\n\n"
+ "For example, @code{(setrlimit 'stack 150000 300000)} sets the @code{RLIMIT_STACK}\n"
+ "limit to 150 kilobytes, with a hard limit of 300 kB.")
+#define FUNC_NAME s_scm_setrlimit
+{
+ int iresource;
+ struct rlimit lim = { 0, 0 };
+
+ iresource = scm_to_resource (resource, FUNC_NAME, 1);
+
+ lim.rlim_cur = (soft == SCM_BOOL_F) ? RLIM_INFINITY : scm_to_long (soft);
+ lim.rlim_max = (hard == SCM_BOOL_F) ? RLIM_INFINITY : scm_to_long (hard);
+
+ if (setrlimit (iresource, &lim) != 0)
+ scm_syserror (FUNC_NAME);
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+#endif /* HAVE_SETRLIMIT */
+#endif /* HAVE_GETRLIMIT */
+
SCM_DEFINE (scm_kill, "kill", 2, 0, 0,
(SCM pid, SCM sig),
"@end defvar")
#define FUNC_NAME s_scm_kill
{
- SCM_VALIDATE_INUM (1,pid);
- SCM_VALIDATE_INUM (2,sig);
/* Signal values are interned in scm_init_posix(). */
- if (kill ((int) SCM_INUM (pid), (int) SCM_INUM (sig)) != 0)
+#ifdef HAVE_KILL
+ if (kill (scm_to_int (pid), scm_to_int (sig)) != 0)
SCM_SYSERROR;
+#else
+ /* Mingw has raise(), but not kill(). (Other raw DOS environments might
+ be similar.) Use raise() when the requested pid is our own process,
+ otherwise bomb. */
+ if (scm_to_int (pid) == getpid ())
+ {
+ if (raise (scm_to_int (sig)) != 0)
+ {
+ err:
+ SCM_SYSERROR;
+ }
+ else
+ {
+ errno = ENOSYS;
+ goto err;
+ }
+ }
+#endif
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
int i;
int status;
int ioptions;
- SCM_VALIDATE_INUM (1,pid);
if (SCM_UNBNDP (options))
ioptions = 0;
else
{
- SCM_VALIDATE_INUM (2,options);
/* Flags are interned in scm_init_posix. */
- ioptions = SCM_INUM (options);
+ ioptions = scm_to_int (options);
}
- SCM_SYSCALL (i = waitpid (SCM_INUM (pid), &status, ioptions));
+ SCM_SYSCALL (i = waitpid (scm_to_int (pid), &status, ioptions));
if (i == -1)
SCM_SYSERROR;
- return scm_cons (SCM_MAKINUM (0L + i), SCM_MAKINUM (0L + status));
+ return scm_cons (scm_from_int (i), scm_from_int (status));
}
#undef FUNC_NAME
#endif /* HAVE_WAITPID */
+#ifndef __MINGW32__
SCM_DEFINE (scm_status_exit_val, "status:exit-val", 1, 0, 0,
(SCM status),
"Return the exit status value, as would be set if a process\n"
{
int lstatus;
- SCM_VALIDATE_INUM (1,status);
-
/* On Ultrix, the WIF... macros assume their argument is an lvalue;
- go figure. SCM_INUM does not yield an lvalue. */
- lstatus = SCM_INUM (status);
+ go figure. */
+ lstatus = scm_to_int (status);
if (WIFEXITED (lstatus))
- return (SCM_MAKINUM (WEXITSTATUS (lstatus)));
+ return (scm_from_int (WEXITSTATUS (lstatus)));
else
return SCM_BOOL_F;
}
{
int lstatus;
- SCM_VALIDATE_INUM (1,status);
-
- lstatus = SCM_INUM (status);
+ lstatus = scm_to_int (status);
if (WIFSIGNALED (lstatus))
- return SCM_MAKINUM (WTERMSIG (lstatus));
+ return scm_from_int (WTERMSIG (lstatus));
else
return SCM_BOOL_F;
}
{
int lstatus;
- SCM_VALIDATE_INUM (1,status);
-
- lstatus = SCM_INUM (status);
+ lstatus = scm_to_int (status);
if (WIFSTOPPED (lstatus))
- return SCM_MAKINUM (WSTOPSIG (lstatus));
+ return scm_from_int (WSTOPSIG (lstatus));
else
return SCM_BOOL_F;
}
#undef FUNC_NAME
+#endif /* __MINGW32__ */
+#ifdef HAVE_GETPPID
SCM_DEFINE (scm_getppid, "getppid", 0, 0, 0,
(),
"Return an integer representing the process ID of the parent\n"
"process.")
#define FUNC_NAME s_scm_getppid
{
- return SCM_MAKINUM (0L + getppid ());
+ return scm_from_int (getppid ());
}
#undef FUNC_NAME
+#endif /* HAVE_GETPPID */
-
+#ifndef __MINGW32__
SCM_DEFINE (scm_getuid, "getuid", 0, 0, 0,
(),
"Return an integer representing the current real user ID.")
#define FUNC_NAME s_scm_getuid
{
- return SCM_MAKINUM (0L + getuid ());
+ return scm_from_int (getuid ());
}
#undef FUNC_NAME
"Return an integer representing the current real group ID.")
#define FUNC_NAME s_scm_getgid
{
- return SCM_MAKINUM (0L + getgid ());
+ return scm_from_int (getgid ());
}
#undef FUNC_NAME
(),
"Return an integer representing the current effective user ID.\n"
"If the system does not support effective IDs, then the real ID\n"
- "is returned. @code{(feature? 'EIDs)} reports whether the\n"
+ "is returned. @code{(provided? 'EIDs)} reports whether the\n"
"system supports effective IDs.")
#define FUNC_NAME s_scm_geteuid
{
#ifdef HAVE_GETEUID
- return SCM_MAKINUM (0L + geteuid ());
+ return scm_from_int (geteuid ());
#else
- return SCM_MAKINUM (0L + getuid ());
+ return scm_from_int (getuid ());
#endif
}
#undef FUNC_NAME
-
SCM_DEFINE (scm_getegid, "getegid", 0, 0, 0,
(),
"Return an integer representing the current effective group ID.\n"
"If the system does not support effective IDs, then the real ID\n"
- "is returned. @code{(feature? 'EIDs)} reports whether the\n"
+ "is returned. @code{(provided? 'EIDs)} reports whether the\n"
"system supports effective IDs.")
#define FUNC_NAME s_scm_getegid
{
#ifdef HAVE_GETEUID
- return SCM_MAKINUM (0L + getegid ());
+ return scm_from_int (getegid ());
#else
- return SCM_MAKINUM (0L + getgid ());
+ return scm_from_int (getgid ());
#endif
}
#undef FUNC_NAME
"The return value is unspecified.")
#define FUNC_NAME s_scm_setuid
{
- SCM_VALIDATE_INUM (1,id);
- if (setuid (SCM_INUM (id)) != 0)
+ if (setuid (scm_to_int (id)) != 0)
SCM_SYSERROR;
return SCM_UNSPECIFIED;
}
"The return value is unspecified.")
#define FUNC_NAME s_scm_setgid
{
- SCM_VALIDATE_INUM (1,id);
- if (setgid (SCM_INUM (id)) != 0)
+ if (setgid (scm_to_int (id)) != 0)
SCM_SYSERROR;
return SCM_UNSPECIFIED;
}
(SCM id),
"Sets the effective user ID to the integer @var{id}, provided the process\n"
"has appropriate privileges. If effective IDs are not supported, the\n"
- "real ID is set instead -- @code{(feature? 'EIDs)} reports whether the\n"
+ "real ID is set instead -- @code{(provided? 'EIDs)} reports whether the\n"
"system supports effective IDs.\n"
"The return value is unspecified.")
#define FUNC_NAME s_scm_seteuid
{
int rv;
- SCM_VALIDATE_INUM (1,id);
#ifdef HAVE_SETEUID
- rv = seteuid (SCM_INUM (id));
+ rv = seteuid (scm_to_int (id));
#else
- rv = setuid (SCM_INUM (id));
+ rv = setuid (scm_to_int (id));
#endif
if (rv != 0)
SCM_SYSERROR;
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
+#endif /* __MINGW32__ */
+
#ifdef HAVE_SETEGID
SCM_DEFINE (scm_setegid, "setegid", 1, 0, 0,
(SCM id),
"Sets the effective group ID to the integer @var{id}, provided the process\n"
"has appropriate privileges. If effective IDs are not supported, the\n"
- "real ID is set instead -- @code{(feature? 'EIDs)} reports whether the\n"
+ "real ID is set instead -- @code{(provided? 'EIDs)} reports whether the\n"
"system supports effective IDs.\n"
"The return value is unspecified.")
#define FUNC_NAME s_scm_setegid
{
int rv;
- SCM_VALIDATE_INUM (1,id);
#ifdef HAVE_SETEUID
- rv = setegid (SCM_INUM (id));
+ rv = setegid (scm_to_int (id));
#else
- rv = setgid (SCM_INUM (id));
+ rv = setgid (scm_to_int (id));
#endif
if (rv != 0)
SCM_SYSERROR;
#undef FUNC_NAME
#endif
+
+#ifdef HAVE_GETPGRP
SCM_DEFINE (scm_getpgrp, "getpgrp", 0, 0, 0,
(),
"Return an integer representing the current process group ID.\n"
{
int (*fn)();
fn = (int (*) ()) getpgrp;
- return SCM_MAKINUM (fn (0));
+ return scm_from_int (fn (0));
}
#undef FUNC_NAME
+#endif /* HAVE_GETPGRP */
+
#ifdef HAVE_SETPGID
SCM_DEFINE (scm_setpgid, "setpgid", 2, 0, 0,
"The return value is unspecified.")
#define FUNC_NAME s_scm_setpgid
{
- SCM_VALIDATE_INUM (1,pid);
- SCM_VALIDATE_INUM (2,pgid);
/* FIXME(?): may be known as setpgrp. */
- if (setpgid (SCM_INUM (pid), SCM_INUM (pgid)) != 0)
+ if (setpgid (scm_to_int (pid), scm_to_int (pgid)) != 0)
SCM_SYSERROR;
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
#endif /* HAVE_SETSID */
+
+/* ttyname returns its result in a single static buffer, hence
+ scm_i_misc_mutex for thread safety. In glibc 2.3.2 two threads
+ continuously calling ttyname will otherwise get an overwrite quite
+ easily.
+
+ ttyname_r (when available) could be used instead of scm_i_misc_mutex, but
+ there's probably little to be gained in either speed or parallelism. */
+
+#ifdef HAVE_TTYNAME
SCM_DEFINE (scm_ttyname, "ttyname", 1, 0, 0,
(SCM port),
"Return a string with the name of the serial terminal device\n"
"underlying @var{port}.")
#define FUNC_NAME s_scm_ttyname
{
- char *ans;
- int fd;
+ char *result;
+ int fd, err;
+ SCM ret = SCM_BOOL_F;
port = SCM_COERCE_OUTPORT (port);
- SCM_VALIDATE_OPPORT (1,port);
+ SCM_VALIDATE_OPPORT (1, port);
if (!SCM_FPORTP (port))
return SCM_BOOL_F;
fd = SCM_FPORT_FDES (port);
- SCM_SYSCALL (ans = ttyname (fd));
- if (!ans)
- SCM_SYSERROR;
- /* ans could be overwritten by another call to ttyname */
- return (scm_makfrom0str (ans));
+
+ scm_i_scm_pthread_mutex_lock (&scm_i_misc_mutex);
+
+ SCM_SYSCALL (result = ttyname (fd));
+ err = errno;
+ if (result != NULL)
+ result = strdup (result);
+
+ scm_i_pthread_mutex_unlock (&scm_i_misc_mutex);
+
+ if (!result)
+ {
+ errno = err;
+ SCM_SYSERROR;
+ }
+ else
+ ret = scm_take_locale_string (result);
+
+ return ret;
}
#undef FUNC_NAME
+#endif /* HAVE_TTYNAME */
+
+/* For thread safety "buf" is used instead of NULL for the ctermid static
+ buffer. Actually it's unlikely the controlling terminal will change
+ during program execution, and indeed on glibc (2.3.2) it's always just
+ "/dev/tty", but L_ctermid on the stack is easy and fast and guarantees
+ safety everywhere. */
#ifdef HAVE_CTERMID
SCM_DEFINE (scm_ctermid, "ctermid", 0, 0, 0,
(),
"terminal for the current process.")
#define FUNC_NAME s_scm_ctermid
{
- char *result = ctermid (NULL);
+ char buf[L_ctermid];
+ char *result = ctermid (buf);
if (*result == '\0')
SCM_SYSERROR;
- return scm_makfrom0str (result);
+ return scm_from_locale_string (result);
}
#undef FUNC_NAME
#endif /* HAVE_CTERMID */
port = SCM_COERCE_OUTPORT (port);
- SCM_VALIDATE_OPFPORT (1,port);
+ SCM_VALIDATE_OPFPORT (1, port);
fd = SCM_FPORT_FDES (port);
if ((pgid = tcgetpgrp (fd)) == -1)
SCM_SYSERROR;
- return SCM_MAKINUM (pgid);
+ return scm_from_int (pgid);
}
#undef FUNC_NAME
#endif /* HAVE_TCGETPGRP */
port = SCM_COERCE_OUTPORT (port);
- SCM_VALIDATE_OPFPORT (1,port);
- SCM_VALIDATE_INUM (2,pgid);
+ SCM_VALIDATE_OPFPORT (1, port);
fd = SCM_FPORT_FDES (port);
- if (tcsetpgrp (fd, SCM_INUM (pgid)) == -1)
+ if (tcsetpgrp (fd, scm_to_int (pgid)) == -1)
SCM_SYSERROR;
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
#endif /* HAVE_TCSETPGRP */
-/* Create a new C argv array from a scheme list of strings. */
-/* Dirk:FIXME:: A quite similar function is implemented in dynl.c */
-/* Dirk:FIXME:: In case of assertion errors, we get memory leaks */
-
-static char **
-scm_convert_exec_args (SCM args, int argn, const char *subr)
+static void
+free_string_pointers (void *data)
{
- char **argv;
- int argc;
- int i;
-
- argc = scm_ilength (args);
- SCM_ASSERT (argc >= 0, args, argn, subr);
- argv = (char **) scm_must_malloc ((argc + 1) * sizeof (char *), subr);
- for (i = 0; !SCM_NULLP (args); args = SCM_CDR (args), ++i)
- {
- SCM arg = SCM_CAR (args);
- scm_sizet len;
- char *dst;
- char *src;
-
- SCM_ASSERT (SCM_STRINGP (arg), args, argn, subr);
- len = SCM_STRING_LENGTH (arg);
- src = SCM_STRING_CHARS (arg);
- dst = (char *) scm_must_malloc (len + 1, subr);
- memcpy (dst, src, len);
- dst[len] = 0;
- argv[i] = dst;
- }
- argv[i] = 0;
- return argv;
+ scm_i_free_string_pointers ((char **)data);
}
SCM_DEFINE (scm_execl, "execl", 1, 0, 1,
(SCM filename, SCM args),
"Executes the file named by @var{path} as a new process image.\n"
"The remaining arguments are supplied to the process; from a C program\n"
- "they are accessable as the @code{argv} argument to @code{main}.\n"
+ "they are accessible as the @code{argv} argument to @code{main}.\n"
"Conventionally the first @var{arg} is the same as @var{path}.\n"
- "All arguments must be strings. \n\n"
+ "All arguments must be strings.\n\n"
"If @var{arg} is missing, @var{path} is executed with a null\n"
"argument list, which may have system-dependent side-effects.\n\n"
"This procedure is currently implemented using the @code{execv} system\n"
"call, but we call it @code{execl} because of its Scheme calling interface.")
#define FUNC_NAME s_scm_execl
{
- char **execargv;
- SCM_VALIDATE_STRING (1, filename);
- SCM_STRING_COERCE_0TERMINATION_X (filename);
- execargv = scm_convert_exec_args (args, SCM_ARG2, FUNC_NAME);
- execv (SCM_STRING_CHARS (filename), execargv);
+ char *exec_file;
+ char **exec_argv;
+
+ scm_dynwind_begin (0);
+
+ exec_file = scm_to_locale_string (filename);
+ scm_dynwind_free (exec_file);
+
+ exec_argv = scm_i_allocate_string_pointers (args);
+ scm_dynwind_unwind_handler (free_string_pointers, exec_argv,
+ SCM_F_WIND_EXPLICITLY);
+
+ execv (exec_file,
+#ifdef __MINGW32__
+ /* extra "const" in mingw formals, provokes warning from gcc */
+ (const char * const *)
+#endif
+ exec_argv);
SCM_SYSERROR;
+
/* not reached. */
+ scm_dynwind_end ();
return SCM_BOOL_F;
}
#undef FUNC_NAME
"call, but we call it @code{execlp} because of its Scheme calling interface.")
#define FUNC_NAME s_scm_execlp
{
- char **execargv;
- SCM_VALIDATE_STRING (1, filename);
- SCM_STRING_COERCE_0TERMINATION_X (filename);
- execargv = scm_convert_exec_args (args, SCM_ARG2, FUNC_NAME);
- execvp (SCM_STRING_CHARS (filename), execargv);
+ char *exec_file;
+ char **exec_argv;
+
+ scm_dynwind_begin (0);
+
+ exec_file = scm_to_locale_string (filename);
+ scm_dynwind_free (exec_file);
+
+ exec_argv = scm_i_allocate_string_pointers (args);
+ scm_dynwind_unwind_handler (free_string_pointers, exec_argv,
+ SCM_F_WIND_EXPLICITLY);
+
+ execvp (exec_file,
+#ifdef __MINGW32__
+ /* extra "const" in mingw formals, provokes warning from gcc */
+ (const char * const *)
+#endif
+ exec_argv);
SCM_SYSERROR;
+
/* not reached. */
+ scm_dynwind_end ();
return SCM_BOOL_F;
}
#undef FUNC_NAME
-static char **
-environ_list_to_c (SCM envlist, int arg, const char *proc)
-{
- int num_strings;
- char **result;
- int i;
- num_strings = scm_ilength (envlist);
- SCM_ASSERT (num_strings >= 0, envlist, arg, proc);
- result = (char **) malloc ((num_strings + 1) * sizeof (char *));
- if (result == NULL)
- scm_memory_error (proc);
- for (i = 0; !SCM_NULLP (envlist); ++i, envlist = SCM_CDR (envlist))
- {
- SCM str = SCM_CAR (envlist);
- int len;
- char *src;
-
- SCM_ASSERT (SCM_STRINGP (str), envlist, arg, proc);
- len = SCM_STRING_LENGTH (str);
- src = SCM_STRING_CHARS (str);
- result[i] = malloc (len + 1);
- if (result[i] == NULL)
- scm_memory_error (proc);
- memcpy (result[i], src, len);
- result[i][len] = 0;
- }
- result[i] = 0;
- return result;
-}
+/* OPTIMIZE-ME: scm_execle doesn't need malloced copies of the environment
+ list strings the way environ_list_to_c gives. */
SCM_DEFINE (scm_execle, "execle", 2, 0, 1,
(SCM filename, SCM env, SCM args),
"call, but we call it @code{execle} because of its Scheme calling interface.")
#define FUNC_NAME s_scm_execle
{
- char **execargv;
+ char **exec_argv;
char **exec_env;
+ char *exec_file;
- SCM_VALIDATE_STRING (1, filename);
- SCM_STRING_COERCE_0TERMINATION_X (filename);
-
- execargv = scm_convert_exec_args (args, SCM_ARG1, FUNC_NAME);
- exec_env = environ_list_to_c (env, SCM_ARG2, FUNC_NAME);
- execve (SCM_STRING_CHARS (filename), execargv, exec_env);
+ scm_dynwind_begin (0);
+
+ exec_file = scm_to_locale_string (filename);
+ scm_dynwind_free (exec_file);
+
+ exec_argv = scm_i_allocate_string_pointers (args);
+ scm_dynwind_unwind_handler (free_string_pointers, exec_argv,
+ SCM_F_WIND_EXPLICITLY);
+
+ exec_env = scm_i_allocate_string_pointers (env);
+ scm_dynwind_unwind_handler (free_string_pointers, exec_env,
+ SCM_F_WIND_EXPLICITLY);
+
+ execve (exec_file,
+#ifdef __MINGW32__
+ /* extra "const" in mingw formals, provokes warning from gcc */
+ (const char * const *)
+#endif
+ exec_argv,
+#ifdef __MINGW32__
+ /* extra "const" in mingw formals, provokes warning from gcc */
+ (const char * const *)
+#endif
+ exec_env);
SCM_SYSERROR;
+
/* not reached. */
+ scm_dynwind_end ();
return SCM_BOOL_F;
}
#undef FUNC_NAME
+#ifdef HAVE_FORK
SCM_DEFINE (scm_fork, "primitive-fork", 0, 0, 0,
(),
"Creates a new \"child\" process by duplicating the current \"parent\" process.\n"
pid = fork ();
if (pid == -1)
SCM_SYSERROR;
- return SCM_MAKINUM (0L+pid);
+ return scm_from_int (pid);
}
#undef FUNC_NAME
+#endif /* HAVE_FORK */
-#ifdef HAVE_UNAME
+#ifdef __MINGW32__
+# include "win32-uname.h"
+#endif
+
+#if defined (HAVE_UNAME) || defined (__MINGW32__)
SCM_DEFINE (scm_uname, "uname", 0, 0, 0,
(),
"Return an object with some information about the computer\n"
#define FUNC_NAME s_scm_uname
{
struct utsname buf;
- SCM ans = scm_c_make_vector (5, SCM_UNSPECIFIED);
- SCM *ve = SCM_VELTS (ans);
+ SCM result = scm_c_make_vector (5, SCM_UNSPECIFIED);
if (uname (&buf) < 0)
SCM_SYSERROR;
- ve[0] = scm_makfrom0str (buf.sysname);
- ve[1] = scm_makfrom0str (buf.nodename);
- ve[2] = scm_makfrom0str (buf.release);
- ve[3] = scm_makfrom0str (buf.version);
- ve[4] = scm_makfrom0str (buf.machine);
+ SCM_SIMPLE_VECTOR_SET(result, 0, scm_from_locale_string (buf.sysname));
+ SCM_SIMPLE_VECTOR_SET(result, 1, scm_from_locale_string (buf.nodename));
+ SCM_SIMPLE_VECTOR_SET(result, 2, scm_from_locale_string (buf.release));
+ SCM_SIMPLE_VECTOR_SET(result, 3, scm_from_locale_string (buf.version));
+ SCM_SIMPLE_VECTOR_SET(result, 4, scm_from_locale_string (buf.machine));
/*
a linux special?
- ve[5] = scm_makfrom0str (buf.domainname);
+ SCM_SIMPLE_VECTOR_SET(result, 5, scm_from_locale_string (buf.domainname));
*/
- return ans;
+ return result;
}
#undef FUNC_NAME
#endif /* HAVE_UNAME */
{
char **new_environ;
- new_environ = environ_list_to_c (env, SCM_ARG1, FUNC_NAME);
+ new_environ = scm_i_allocate_string_pointers (env);
/* Free the old environment, except when called for the first
* time.
*/
{
- char **ep;
static int first = 1;
if (!first)
- {
- for (ep = environ; *ep != NULL; ep++)
- free (*ep);
- free ((char *) environ);
- }
+ scm_i_free_string_pointers (environ);
first = 0;
}
environ = new_environ;
if (rv == NULL)
/* not SCM_SYSERROR since errno probably not set. */
SCM_MISC_ERROR ("tmpnam failed", SCM_EOL);
- return scm_makfrom0str (name);
+ return scm_from_locale_string (name);
}
#undef FUNC_NAME
#endif
+#ifndef HAVE_MKSTEMP
+extern int mkstemp (char *);
+#endif
+
SCM_DEFINE (scm_mkstemp, "mkstemp!", 1, 0, 0,
(SCM tmpl),
- "Create a new unique file in the file system and 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_STRING_COERCE_0TERMINATION_X (tmpl);
- SCM_VALIDATE_STRING_COPY (1, tmpl, c_tmpl);
+ 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
int rv;
struct utimbuf utm_tmp;
- SCM_VALIDATE_STRING (1, pathname);
- SCM_STRING_COERCE_0TERMINATION_X (pathname);
if (SCM_UNBNDP (actime))
SCM_SYSCALL (time (&utm_tmp.actime));
else
else
utm_tmp.modtime = SCM_NUM2ULONG (3, modtime);
- SCM_SYSCALL (rv = utime (SCM_STRING_CHARS (pathname), &utm_tmp));
+ STRING_SYSCALL (pathname, c_pathname,
+ rv = utime (c_pathname, &utm_tmp));
if (rv != 0)
SCM_SYSERROR;
return SCM_UNSPECIFIED;
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;
- SCM_VALIDATE_STRING (1, path);
- SCM_STRING_COERCE_0TERMINATION_X (path);
- SCM_VALIDATE_INUM (2, how);
- rv = access (SCM_STRING_CHARS (path), SCM_INUM (how));
- return SCM_NEGATE_BOOL(rv);
+ WITH_STRING (path, c_path,
+ rv = access (c_path, scm_to_int (how)));
+ return scm_from_bool (!rv);
}
#undef FUNC_NAME
"Return an integer representing the current process ID.")
#define FUNC_NAME s_scm_getpid
{
- return SCM_MAKINUM ((unsigned long) getpid ());
+ return scm_from_ulong (getpid ());
}
#undef FUNC_NAME
#define FUNC_NAME s_scm_putenv
{
int rv;
- char *ptr;
-
- SCM_VALIDATE_STRING (1, str);
- /* must make a new copy to be left in the environment, safe from gc. */
- ptr = malloc (SCM_STRING_LENGTH (str) + 1);
- if (ptr == NULL)
- SCM_MEMORY_ERROR;
- strncpy (ptr, SCM_STRING_CHARS (str), SCM_STRING_LENGTH (str));
- ptr[SCM_STRING_LENGTH (str)] = 0;
- rv = putenv (ptr);
- if (rv < 0)
- SCM_SYSERROR;
+ char *c_str = scm_to_locale_string (str);
+
+ if (strchr (c_str, '=') == NULL)
+ {
+ /* We want no "=" in the argument to mean remove the variable from the
+ environment, but not all putenv()s understand this, for example
+ FreeBSD 4.8 doesn't. Getting it happening everywhere is a bit
+ painful. What unsetenv() exists, we use that, of course.
+
+ Traditionally putenv("NAME") removes a variable, for example that's
+ what we have to do on Solaris 9 (it doesn't have an unsetenv).
+
+ But on DOS and on that DOS overlay manager thing called W-whatever,
+ putenv("NAME=") must be used (it too doesn't have an unsetenv).
+
+ Supposedly on AIX a putenv("NAME") could cause a segfault, but also
+ supposedly AIX 5.3 and up has unsetenv() available so should be ok
+ with the latter there.
+
+ For the moment we hard code the DOS putenv("NAME=") style under
+ __MINGW32__ and do the traditional everywhere else. Such
+ system-name tests are bad, of course. It'd be possible to use a
+ configure test when doing a a native build. For example GNU R has
+ such a test (see R_PUTENV_AS_UNSETENV in
+ https://svn.r-project.org/R/trunk/m4/R.m4). But when cross
+ compiling there'd want to be a guess, one probably based on the
+ system name (ie. mingw or not), thus landing back in basically the
+ present hard-coded situation. Another possibility for a cross
+ build would be to try "NAME" then "NAME=" at runtime, if that's not
+ too much like overkill. */
+
+#if HAVE_UNSETENV
+ /* when unsetenv() exists then we use it */
+ unsetenv (c_str);
+ free (c_str);
+#elif defined (__MINGW32__)
+ /* otherwise putenv("NAME=") on DOS */
+ int e;
+ size_t len = strlen (c_str);
+ char *ptr = scm_malloc (len + 2);
+ strcpy (ptr, c_str);
+ strcpy (ptr+len, "=");
+ rv = putenv (ptr);
+ e = errno; free (ptr); free (c_str); errno = e;
+ if (rv < 0)
+ SCM_SYSERROR;
+#else
+ /* otherwise traditional putenv("NAME") */
+ rv = putenv (c_str);
+ if (rv < 0)
+ SCM_SYSERROR;
+#endif
+ }
+ else
+ {
+#ifdef __MINGW32__
+ /* If str is "FOO=", ie. attempting to set an empty string, then
+ we need to see if it's been successful. On MINGW, "FOO="
+ means remove FOO from the environment. As a workaround, we
+ set "FOO= ", ie. a space, and then modify the string returned
+ by getenv. It's not enough just to modify the string we set,
+ because MINGW putenv copies it. */
+
+ {
+ size_t len = strlen (c_str);
+ if (c_str[len-1] == '=')
+ {
+ char *ptr = scm_malloc (len+2);
+ strcpy (ptr, c_str);
+ strcpy (ptr+len, " ");
+ rv = putenv (ptr);
+ if (rv < 0)
+ {
+ int eno = errno;
+ free (c_str);
+ errno = eno;
+ SCM_SYSERROR;
+ }
+ /* truncate to just the name */
+ c_str[len-1] = '\0';
+ ptr = getenv (c_str);
+ if (ptr)
+ ptr[0] = '\0';
+ return SCM_UNSPECIFIED;
+ }
+ }
+#endif /* __MINGW32__ */
+
+ /* Leave c_str in the environment. */
+
+ rv = putenv (c_str);
+ if (rv < 0)
+ SCM_SYSERROR;
+ }
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
+/* This mutex is used to serialize invocations of `setlocale ()' on non-GNU
+ systems (i.e., systems where a reentrant locale API is not available). It
+ is also acquired before calls to `nl_langinfo ()'. See `i18n.c' for
+ details. */
+scm_i_pthread_mutex_t scm_i_locale_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;
+
#ifdef HAVE_SETLOCALE
+
SCM_DEFINE (scm_setlocale, "setlocale", 1, 1, 0,
(SCM category, SCM locale),
"If @var{locale} is omitted, return the current value of the\n"
"Otherwise the specified locale category is set to the string\n"
"@var{locale} and the new value is returned as a\n"
"system-dependent string. If @var{locale} is an empty string,\n"
- "the locale will be set using envirionment variables.")
+ "the locale will be set using environment variables.")
#define FUNC_NAME s_scm_setlocale
{
+ int c_category;
char *clocale;
char *rv;
- SCM_VALIDATE_INUM (1,category);
+ scm_dynwind_begin (0);
+
if (SCM_UNBNDP (locale))
{
clocale = NULL;
}
else
{
- SCM_VALIDATE_STRING (2, locale);
- SCM_STRING_COERCE_0TERMINATION_X (locale);
- clocale = SCM_STRING_CHARS (locale);
+ clocale = scm_to_locale_string (locale);
+ scm_dynwind_free (clocale);
}
- rv = setlocale (SCM_INUM (category), clocale);
+ c_category = scm_i_to_lc_category (category, 1);
+
+ scm_i_pthread_mutex_lock (&scm_i_locale_mutex);
+ rv = setlocale (c_category, clocale);
+ scm_i_pthread_mutex_unlock (&scm_i_locale_mutex);
+
if (rv == NULL)
- SCM_SYSERROR;
- return scm_makfrom0str (rv);
+ {
+ /* POSIX and C99 don't say anything about setlocale setting errno, so
+ force a sensible value here. glibc leaves ENOENT, which would be
+ fine, but it's not a documented feature. */
+ errno = EINVAL;
+ SCM_SYSERROR;
+ }
+
+ /* Recompute the standard SRFI-14 character sets in a locale-dependent
+ (actually charset-dependent) way. */
+ scm_srfi_14_compute_char_sets ();
+
+ scm_dynwind_end ();
+ return scm_from_locale_string (rv);
}
#undef FUNC_NAME
#endif /* HAVE_SETLOCALE */
#define FUNC_NAME s_scm_mknod
{
int val;
- char *p;
+ const char *p;
int ctype = 0;
SCM_VALIDATE_STRING (1, path);
- SCM_VALIDATE_SYMBOL (2,type);
- SCM_VALIDATE_INUM (3,perms);
- SCM_VALIDATE_INUM (4,dev);
- SCM_STRING_COERCE_0TERMINATION_X (path);
+ SCM_VALIDATE_SYMBOL (2, type);
- p = SCM_SYMBOL_CHARS (type);
+ p = scm_i_symbol_chars (type);
if (strcmp (p, "regular") == 0)
ctype = S_IFREG;
else if (strcmp (p, "directory") == 0)
ctype = S_IFDIR;
+#ifdef S_IFLNK
+ /* systems without symlinks probably don't have S_IFLNK defined */
else if (strcmp (p, "symlink") == 0)
ctype = S_IFLNK;
+#endif
else if (strcmp (p, "block-special") == 0)
ctype = S_IFBLK;
else if (strcmp (p, "char-special") == 0)
ctype = S_IFSOCK;
#endif
else
- SCM_OUT_OF_RANGE (2,type);
+ SCM_OUT_OF_RANGE (2, type);
- SCM_SYSCALL (val = mknod (SCM_STRING_CHARS (path), ctype | SCM_INUM (perms),
- SCM_INUM (dev)));
+ STRING_SYSCALL (path, c_path,
+ val = mknod (c_path,
+ ctype | scm_to_int (perms),
+ scm_to_int (dev)));
if (val != 0)
SCM_SYSERROR;
return SCM_UNSPECIFIED;
"The return value is unspecified.")
#define FUNC_NAME s_scm_nice
{
- SCM_VALIDATE_INUM (1,incr);
- if (nice(SCM_INUM(incr)) != 0)
+ int nice_value;
+
+ /* nice() returns "prio-NZERO" on success or -1 on error, but -1 can arise
+ from "prio-NZERO", so an error must be detected from errno changed */
+ errno = 0;
+ nice_value = nice (scm_to_int (incr));
+ if (errno != 0)
SCM_SYSERROR;
+
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
#undef FUNC_NAME
#endif /* HAVE_SYNC */
-#if HAVE_LIBCRYPT && HAVE_CRYPT_H
-SCM_DEFINE (scm_crypt, "crypt", 2, 0, 0,
+
+/* crypt() returns a pointer to a static buffer, so we use scm_i_misc_mutex
+ to avoid another thread overwriting it. A test program running crypt
+ continuously in two threads can be quickly seen tripping this problem.
+ crypt() is pretty slow normally, so a mutex shouldn't add much overhead.
+
+ glibc has a thread-safe crypt_r, but (in version 2.3.2) it runs a lot
+ slower (about 5x) than plain crypt if you pass an uninitialized data
+ block each time. Presumably there's some one-time setups. The best way
+ to use crypt_r for parallel execution in multiple threads would probably
+ be to maintain a little pool of initialized crypt_data structures, take
+ one and use it, then return it to the pool. That pool could be garbage
+ collected so it didn't add permanently to memory use if only a few crypt
+ calls are made. But we expect crypt will be used rarely, and even more
+ rarely will there be any desire for lots of parallel execution on
+ multiple cpus. So for now we don't bother with anything fancy, just
+ ensure it works. */
+
+#if HAVE_CRYPT
+SCM_DEFINE (scm_crypt, "crypt", 2, 0, 0,
(SCM key, SCM salt),
"Encrypt @var{key} using @var{salt} as the salt value to the\n"
- "crypt(3) library call\n")
+ "crypt(3) library call.")
#define FUNC_NAME s_scm_crypt
{
- char * p;
-
- SCM_VALIDATE_STRING (1, key);
- SCM_VALIDATE_STRING (2, salt);
- SCM_STRING_COERCE_0TERMINATION_X (key);
- SCM_STRING_COERCE_0TERMINATION_X (salt);
+ SCM ret;
+ char *c_key, *c_salt, *c_ret;
+
+ scm_dynwind_begin (0);
+ scm_i_dynwind_pthread_mutex_lock (&scm_i_misc_mutex);
+
+ c_key = scm_to_locale_string (key);
+ scm_dynwind_free (c_key);
+ c_salt = scm_to_locale_string (salt);
+ scm_dynwind_free (c_salt);
+
+ /* The Linux crypt(3) man page says crypt will return NULL and set errno
+ on error. (Eg. ENOSYS if legal restrictions mean it cannot be
+ implemented). */
+ c_ret = crypt (c_key, c_salt);
+ if (c_ret == NULL)
+ SCM_SYSERROR;
- p = crypt (SCM_STRING_CHARS (key), SCM_STRING_CHARS (salt));
- return scm_makfrom0str (p);
+ ret = scm_from_locale_string (c_ret);
+ scm_dynwind_end ();
+ return ret;
}
#undef FUNC_NAME
-#endif /* HAVE_LIBCRYPT && HAVE_CRYPT_H */
+#endif /* HAVE_CRYPT */
#if HAVE_CHROOT
SCM_DEFINE (scm_chroot, "chroot", 1, 0, 0,
"root directory.")
#define FUNC_NAME s_scm_chroot
{
- SCM_VALIDATE_STRING (1, path);
- SCM_STRING_COERCE_0TERMINATION_X (path);
+ int rv;
- if (chroot (SCM_STRING_CHARS (path)) == -1)
+ WITH_STRING (path, c_path,
+ rv = chroot (c_path));
+ if (rv == -1)
SCM_SYSERROR;
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
#endif /* HAVE_CHROOT */
-#if HAVE_GETLOGIN
+
+#ifdef __MINGW32__
+/* Wrapper function to supplying `getlogin()' under Windows. */
+static char * getlogin (void)
+{
+ static char user[256];
+ static unsigned long len = 256;
+
+ if (!GetUserName (user, &len))
+ return NULL;
+ return user;
+}
+#endif /* __MINGW32__ */
+
+
+#if defined (HAVE_GETLOGIN) || defined (__MINGW32__)
SCM_DEFINE (scm_getlogin, "getlogin", 0, 0, 0,
(void),
"Return a string containing the name of the user logged in on\n"
p = getlogin ();
if (!p || !*p)
return SCM_BOOL_F;
- return scm_makfrom0str (p);
+ return scm_from_locale_string (p);
}
#undef FUNC_NAME
#endif /* HAVE_GETLOGIN */
"information cannot be obtained.")
#define FUNC_NAME s_scm_cuserid
{
+ char buf[L_cuserid];
char * p;
- p = cuserid (NULL);
+ p = cuserid (buf);
if (!p || !*p)
return SCM_BOOL_F;
- return scm_makfrom0str (p);
+ return scm_from_locale_string (p);
}
#undef FUNC_NAME
#endif /* HAVE_CUSERID */
{
int cwhich, cwho, ret;
- SCM_VALIDATE_INUM_COPY (1, which, cwhich);
- SCM_VALIDATE_INUM_COPY (2, who, cwho);
+ cwhich = scm_to_int (which);
+ cwho = scm_to_int (who);
/* We have to clear errno and examine it later, because -1 is a
legal return value for getpriority(). */
ret = getpriority (cwhich, cwho);
if (errno != 0)
SCM_SYSERROR;
- return SCM_MAKINUM (ret);
+ return scm_from_int (ret);
}
#undef FUNC_NAME
#endif /* HAVE_GETPRIORITY */
{
int cwhich, cwho, cprio;
- SCM_VALIDATE_INUM_COPY (1, which, cwhich);
- SCM_VALIDATE_INUM_COPY (2, who, cwho);
- SCM_VALIDATE_INUM_COPY (3, prio, cprio);
+ cwhich = scm_to_int (which);
+ cwho = scm_to_int (who);
+ cprio = scm_to_int (prio);
if (setpriority (cwhich, cwho, cprio) == -1)
SCM_SYSERROR;
SCM passwd;
SCM_VALIDATE_STRING (1, prompt);
- SCM_STRING_COERCE_0TERMINATION_X (prompt);
- p = getpass(SCM_STRING_CHARS (prompt));
- passwd = scm_makfrom0str (p);
+ WITH_STRING (prompt, c_prompt,
+ p = getpass(c_prompt));
+ passwd = scm_from_locale_string (p);
/* Clear out the password in the static buffer. */
memset (p, 0, strlen (p));
#undef FUNC_NAME
#endif /* HAVE_GETPASS */
-#if HAVE_FLOCK
+/* 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"
"@var{operation} specifies the action to be done:\n"
- "@table @code\n"
- "@item LOCK_SH\n"
+ "\n"
+ "@defvar LOCK_SH\n"
"Shared lock. More than one process may hold a shared lock\n"
"for a given file at a given time.\n"
- "@item LOCK_EX\n"
+ "@end defvar\n"
+ "@defvar LOCK_EX\n"
"Exclusive lock. Only one process may hold an exclusive lock\n"
"for a given file at a given time.\n"
- "@item LOCK_UN\n"
+ "@end defvar\n"
+ "@defvar LOCK_UN\n"
"Unlock the file.\n"
- "@item LOCK_NB\n"
- "Don't block when locking. May be specified by bitwise OR'ing\n"
- "it to one of the other operations.\n"
- "@end table\n"
+ "@end defvar\n"
+ "@defvar LOCK_NB\n"
+ "Don't block when locking. This is combined with one of the\n"
+ "other operations using @code{logior}. If @code{flock} would\n"
+ "block an @code{EWOULDBLOCK} error is thrown.\n"
+ "@end defvar\n"
+ "\n"
"The return value is not specified. @var{file} may be an open\n"
- "file descriptor or an open file descriptior port.")
+ "file descriptor or an open file descriptor port.\n"
+ "\n"
+ "Note that @code{flock} does not lock files across NFS.")
#define FUNC_NAME s_scm_flock
{
- int coperation, fdes;
+ int fdes;
- if (SCM_INUMP (file))
- fdes = SCM_INUM (file);
+ if (scm_is_integer (file))
+ fdes = scm_to_int (file);
else
{
SCM_VALIDATE_OPFPORT (2, file);
fdes = SCM_FPORT_FDES (file);
}
- SCM_VALIDATE_INUM_COPY (2, operation, coperation);
- if (flock (fdes, coperation) == -1)
+ if (flock (fdes, scm_to_int (operation)) == -1)
SCM_SYSERROR;
return SCM_UNSPECIFIED;
}
"specified.")
#define FUNC_NAME s_scm_sethostname
{
- SCM_VALIDATE_STRING (1, name);
- SCM_STRING_COERCE_0TERMINATION_X (name);
+ int rv;
- if (sethostname (SCM_STRING_CHARS (name), SCM_STRING_LENGTH (name)) == -1)
+ WITH_STRING (name, c_name,
+ rv = sethostname (c_name, strlen(c_name)));
+ if (rv == -1)
SCM_SYSERROR;
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
#endif /* HAVE_SETHOSTNAME */
+
#if HAVE_GETHOSTNAME
SCM_DEFINE (scm_gethostname, "gethostname", 0, 0, 0,
(void),
"Return the host name of the current processor.")
#define FUNC_NAME s_scm_gethostname
{
- /* 256 is for Solaris, under Linux ENAMETOOLONG is returned if not
- large enough. */
- int len = 256, res;
- char *p = scm_must_malloc (len, "gethostname");
- SCM name;
+#ifdef MAXHOSTNAMELEN
+
+ /* Various systems define MAXHOSTNAMELEN (including Solaris in fact).
+ * On GNU/Linux this doesn't include the terminating '\0', hence "+ 1". */
+ const int len = MAXHOSTNAMELEN + 1;
+ char *const p = scm_malloc (len);
+ const int res = gethostname (p, len);
+
+ scm_dynwind_begin (0);
+ scm_dynwind_unwind_handler (free, p, 0);
+
+#else
+
+ /* Default 256 is for Solaris, under Linux ENAMETOOLONG is returned if not
+ * large enough. SUSv2 specifies 255 maximum too, apparently. */
+ int len = 256;
+ int res;
+ char *p;
+
+# if HAVE_SYSCONF && defined (_SC_HOST_NAME_MAX)
+
+ /* POSIX specifies the HOST_NAME_MAX system parameter for the max size,
+ * which may reflect a particular kernel configuration.
+ * Must watch out for this existing but giving -1, as happens for instance
+ * in gnu/linux glibc 2.3.2. */
+ {
+ const long int n = sysconf (_SC_HOST_NAME_MAX);
+ if (n != -1L)
+ len = n;
+ }
+
+# endif
+
+ p = scm_malloc (len);
+
+ scm_dynwind_begin (0);
+ scm_dynwind_unwind_handler (free, p, 0);
res = gethostname (p, len);
while (res == -1 && errno == ENAMETOOLONG)
{
- p = scm_must_realloc (p, len, len * 2, "gethostname");
len *= 2;
+
+ /* scm_realloc may throw an exception. */
+ p = scm_realloc (p, len);
res = gethostname (p, len);
}
+
+#endif
+
if (res == -1)
{
- scm_must_free (p);
+ const int save_errno = errno;
+
+ /* No guile exceptions can occur before we have freed p's memory. */
+ scm_dynwind_end ();
+ free (p);
+
+ errno = save_errno;
SCM_SYSERROR;
}
- name = scm_makfrom0str (p);
- scm_must_free (p);
- return name;
+ else
+ {
+ /* scm_from_locale_string may throw an exception. */
+ const SCM name = scm_from_locale_string (p);
+
+ /* No guile exceptions can occur before we have freed p's memory. */
+ scm_dynwind_end ();
+ free (p);
+
+ return name;
+ }
}
#undef FUNC_NAME
#endif /* HAVE_GETHOSTNAME */
-void
+
+void
scm_init_posix ()
{
scm_add_feature ("posix");
scm_add_feature ("EIDs");
#endif
#ifdef WAIT_ANY
- scm_c_define ("WAIT_ANY", SCM_MAKINUM (WAIT_ANY));
+ scm_c_define ("WAIT_ANY", scm_from_int (WAIT_ANY));
#endif
#ifdef WAIT_MYPGRP
- scm_c_define ("WAIT_MYPGRP", SCM_MAKINUM (WAIT_MYPGRP));
+ scm_c_define ("WAIT_MYPGRP", scm_from_int (WAIT_MYPGRP));
#endif
#ifdef WNOHANG
- scm_c_define ("WNOHANG", SCM_MAKINUM (WNOHANG));
+ scm_c_define ("WNOHANG", scm_from_int (WNOHANG));
#endif
#ifdef WUNTRACED
- scm_c_define ("WUNTRACED", SCM_MAKINUM (WUNTRACED));
+ scm_c_define ("WUNTRACED", scm_from_int (WUNTRACED));
#endif
/* access() symbols. */
- scm_c_define ("R_OK", SCM_MAKINUM (R_OK));
- scm_c_define ("W_OK", SCM_MAKINUM (W_OK));
- scm_c_define ("X_OK", SCM_MAKINUM (X_OK));
- scm_c_define ("F_OK", SCM_MAKINUM (F_OK));
+ scm_c_define ("R_OK", scm_from_int (R_OK));
+ scm_c_define ("W_OK", scm_from_int (W_OK));
+ scm_c_define ("X_OK", scm_from_int (X_OK));
+ scm_c_define ("F_OK", scm_from_int (F_OK));
#ifdef LC_COLLATE
- scm_c_define ("LC_COLLATE", SCM_MAKINUM (LC_COLLATE));
+ scm_c_define ("LC_COLLATE", scm_from_int (LC_COLLATE));
#endif
#ifdef LC_CTYPE
- scm_c_define ("LC_CTYPE", SCM_MAKINUM (LC_CTYPE));
+ scm_c_define ("LC_CTYPE", scm_from_int (LC_CTYPE));
#endif
#ifdef LC_MONETARY
- scm_c_define ("LC_MONETARY", SCM_MAKINUM (LC_MONETARY));
+ scm_c_define ("LC_MONETARY", scm_from_int (LC_MONETARY));
#endif
#ifdef LC_NUMERIC
- scm_c_define ("LC_NUMERIC", SCM_MAKINUM (LC_NUMERIC));
+ scm_c_define ("LC_NUMERIC", scm_from_int (LC_NUMERIC));
#endif
#ifdef LC_TIME
- scm_c_define ("LC_TIME", SCM_MAKINUM (LC_TIME));
+ scm_c_define ("LC_TIME", scm_from_int (LC_TIME));
#endif
#ifdef LC_MESSAGES
- scm_c_define ("LC_MESSAGES", SCM_MAKINUM (LC_MESSAGES));
+ scm_c_define ("LC_MESSAGES", scm_from_int (LC_MESSAGES));
#endif
#ifdef LC_ALL
- scm_c_define ("LC_ALL", SCM_MAKINUM (LC_ALL));
+ scm_c_define ("LC_ALL", scm_from_int (LC_ALL));
+#endif
+#ifdef LC_PAPER
+ scm_c_define ("LC_PAPER", scm_from_int (LC_PAPER));
+#endif
+#ifdef LC_NAME
+ scm_c_define ("LC_NAME", scm_from_int (LC_NAME));
+#endif
+#ifdef LC_ADDRESS
+ scm_c_define ("LC_ADDRESS", scm_from_int (LC_ADDRESS));
+#endif
+#ifdef LC_TELEPHONE
+ scm_c_define ("LC_TELEPHONE", scm_from_int (LC_TELEPHONE));
+#endif
+#ifdef LC_MEASUREMENT
+ scm_c_define ("LC_MEASUREMENT", scm_from_int (LC_MEASUREMENT));
+#endif
+#ifdef LC_IDENTIFICATION
+ scm_c_define ("LC_IDENTIFICATION", scm_from_int (LC_IDENTIFICATION));
#endif
#ifdef PIPE_BUF
- scm_c_define ("PIPE_BUF", scm_long2num (PIPE_BUF));
+ scm_c_define ("PIPE_BUF", scm_from_long (PIPE_BUF));
#endif
#ifdef PRIO_PROCESS
- scm_c_define ("PRIO_PROCESS", SCM_MAKINUM (PRIO_PROCESS));
+ scm_c_define ("PRIO_PROCESS", scm_from_int (PRIO_PROCESS));
#endif
#ifdef PRIO_PGRP
- scm_c_define ("PRIO_PGRP", SCM_MAKINUM (PRIO_PGRP));
+ scm_c_define ("PRIO_PGRP", scm_from_int (PRIO_PGRP));
#endif
#ifdef PRIO_USER
- scm_c_define ("PRIO_USER", SCM_MAKINUM (PRIO_USER));
+ scm_c_define ("PRIO_USER", scm_from_int (PRIO_USER));
#endif
#ifdef LOCK_SH
- scm_c_define ("LOCK_SH", SCM_MAKINUM (LOCK_SH));
+ scm_c_define ("LOCK_SH", scm_from_int (LOCK_SH));
#endif
#ifdef LOCK_EX
- scm_c_define ("LOCK_EX", SCM_MAKINUM (LOCK_EX));
+ scm_c_define ("LOCK_EX", scm_from_int (LOCK_EX));
#endif
#ifdef LOCK_UN
- scm_c_define ("LOCK_UN", SCM_MAKINUM (LOCK_UN));
+ scm_c_define ("LOCK_UN", scm_from_int (LOCK_UN));
#endif
#ifdef LOCK_NB
- scm_c_define ("LOCK_NB", SCM_MAKINUM (LOCK_NB));
+ scm_c_define ("LOCK_NB", scm_from_int (LOCK_NB));
#endif
#include "libguile/cpp_sig_symbols.c"
-#ifndef SCM_MAGIC_SNARFER
#include "libguile/posix.x"
-#endif
}
/*
HCoop / bpt / guile.git / blobdiff