-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2004 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
*/
#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/i18n.h"
+#include "libguile/threads.h"
\f
#ifdef HAVE_STRING_H
#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. */
#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_SYMBOL (sym_write_pipe, "write pipe");
result = scm_c_make_vector (ngroups, SCM_BOOL_F);
while (--ngroups >= 0)
- SCM_VECTOR_SET (result, ngroups, scm_ulong2num (groups[ngroups]));
+ SCM_SIMPLE_VECTOR_SET (result, ngroups, scm_from_ulong (groups[ngroups]));
free (groups);
return result;
#ifdef HAVE_SETGROUPS
SCM_DEFINE (scm_setgroups, "setgroups", 1, 0, 0,
(SCM group_vec),
- "Set the supplementary group IDs to those found in the vector argument.")
+ "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;
SCM_VALIDATE_VECTOR (SCM_ARG1, group_vec);
- ngroups = SCM_VECTOR_LENGTH (group_vec);
+ ngroups = SCM_SIMPLE_VECTOR_LENGTH (group_vec);
/* validate before allocating, so we don't have to worry about leaks */
for (i = 0; i < ngroups; i++)
{
unsigned long ulong_gid;
GETGROUPS_T gid;
- SCM_VALIDATE_ULONG_COPY (1, SCM_VECTOR_REF (group_vec, i), ulong_gid);
+ SCM_VALIDATE_ULONG_COPY (1, SCM_SIMPLE_VECTOR_REF (group_vec, i),
+ ulong_gid);
gid = ulong_gid;
if (gid != ulong_gid)
- SCM_OUT_OF_RANGE (1, SCM_VECTOR_REF (group_vec, i));
+ SCM_OUT_OF_RANGE (1, SCM_SIMPLE_VECTOR_REF (group_vec, i));
}
size = ngroups * sizeof (GETGROUPS_T);
SCM_OUT_OF_RANGE (SCM_ARG1, scm_from_int (ngroups));
groups = scm_malloc (size);
for(i = 0; i < ngroups; i++)
- groups [i] = SCM_NUM2ULONG (1, SCM_VECTOR_REF (group_vec, i));
+ groups [i] = SCM_NUM2ULONG (1, SCM_SIMPLE_VECTOR_REF (group_vec, i));
result = setgroups (ngroups, groups);
save_errno = errno; /* don't let free() touch errno */
}
else
{
- SCM_VALIDATE_STRING (1, 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);
- SCM_VECTOR_SET(result, 0, scm_makfrom0str (entry->pw_name));
- SCM_VECTOR_SET(result, 1, scm_makfrom0str (entry->pw_passwd));
- SCM_VECTOR_SET(result, 2, scm_ulong2num ((unsigned long) entry->pw_uid));
- SCM_VECTOR_SET(result, 3, scm_ulong2num ((unsigned long) entry->pw_gid));
- SCM_VECTOR_SET(result, 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)
- SCM_VECTOR_SET(result, 5, scm_makfrom0str (""));
+ SCM_SIMPLE_VECTOR_SET(result, 5, scm_from_locale_string (""));
else
- SCM_VECTOR_SET(result, 5, scm_makfrom0str (entry->pw_dir));
+ SCM_SIMPLE_VECTOR_SET(result, 5, scm_from_locale_string (entry->pw_dir));
if (!entry->pw_shell)
- SCM_VECTOR_SET(result, 6, scm_makfrom0str (""));
+ SCM_SIMPLE_VECTOR_SET(result, 6, scm_from_locale_string (""));
else
- SCM_VECTOR_SET(result, 6, scm_makfrom0str (entry->pw_shell));
+ SCM_SIMPLE_VECTOR_SET(result, 6, scm_from_locale_string (entry->pw_shell));
return result;
}
#undef FUNC_NAME
else if (scm_is_integer (name))
SCM_SYSCALL (entry = getgrgid (scm_to_int (name)));
else
- {
- SCM_VALIDATE_STRING (1, name);
- SCM_SYSCALL (entry = getgrnam (SCM_STRING_CHARS (name)));
- }
+ STRING_SYSCALL (name, c_name,
+ entry = getgrnam (c_name));
if (!entry)
SCM_SYSERROR;
- SCM_VECTOR_SET(result, 0, scm_makfrom0str (entry->gr_name));
- SCM_VECTOR_SET(result, 1, scm_makfrom0str (entry->gr_passwd));
- SCM_VECTOR_SET(result, 2, scm_ulong2num ((unsigned long) entry->gr_gid));
- SCM_VECTOR_SET(result, 3, scm_makfromstrs (-1, entry->gr_mem));
+ SCM_SIMPLE_VECTOR_SET(result, 0, scm_from_locale_string (entry->gr_name));
+ SCM_SIMPLE_VECTOR_SET(result, 1, scm_from_locale_string (entry->gr_passwd));
+ SCM_SIMPLE_VECTOR_SET(result, 2, scm_from_ulong (entry->gr_gid));
+ SCM_SIMPLE_VECTOR_SET(result, 3, scm_makfromstrs (-1, entry->gr_mem));
return result;
}
#undef FUNC_NAME
#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),
#define FUNC_NAME s_scm_ttyname
{
char *result;
- int fd;
+ int fd, err;
+ SCM ret;
port = SCM_COERCE_OUTPORT (port);
SCM_VALIDATE_OPPORT (1, port);
if (!SCM_FPORTP (port))
return SCM_BOOL_F;
fd = SCM_FPORT_FDES (port);
+
+ scm_i_scm_pthread_mutex_lock (&scm_i_misc_mutex);
SCM_SYSCALL (result = ttyname (fd));
+ err = errno;
+ ret = scm_from_locale_string (result);
+ scm_i_pthread_mutex_unlock (&scm_i_misc_mutex);
+
if (!result)
- SCM_SYSERROR;
- /* result could be overwritten by another call to ttyname */
- return (scm_makfrom0str (result));
+ {
+ errno = err;
+ SCM_SYSERROR;
+ }
+ 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
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 */
#undef FUNC_NAME
#endif /* HAVE_TCSETPGRP */
-/* return a newly allocated array of char pointers to each of the strings
- in args, with a terminating NULL pointer. */
-/* Note: a similar function is defined in dynl.c, but we don't necessarily
- want to export it. */
-static char **allocate_string_pointers (SCM args)
+static void
+free_string_pointers (void *data)
{
- char **result;
- int n_args = scm_ilength (args);
- int i;
-
- SCM_ASSERT (n_args >= 0, args, SCM_ARGn, "allocate_string_pointers");
- result = (char **) scm_malloc ((n_args + 1) * sizeof (char *));
- result[n_args] = NULL;
- for (i = 0; i < n_args; i++)
- {
- SCM car = SCM_CAR (args);
-
- if (!SCM_STRINGP (car))
- {
- free (result);
- scm_wrong_type_arg ("allocate_string_pointers", SCM_ARGn, car);
- }
- result[i] = SCM_STRING_CHARS (SCM_CAR (args));
- args = SCM_CDR (args);
- }
- return result;
+ scm_i_free_string_pointers ((char **)data);
}
SCM_DEFINE (scm_execl, "execl", 1, 0, 1,
"call, but we call it @code{execl} because of its Scheme calling interface.")
#define FUNC_NAME s_scm_execl
{
- char **execargv;
- int save_errno;
- SCM_VALIDATE_STRING (1, filename);
- execargv = allocate_string_pointers (args);
- execv (SCM_STRING_CHARS (filename), execargv);
- save_errno = errno;
- free (execargv);
- errno = save_errno;
+ 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;
- int save_errno;
- SCM_VALIDATE_STRING (1, filename);
- execargv = allocate_string_pointers (args);
- execvp (SCM_STRING_CHARS (filename), execargv);
- save_errno = errno;
- free (execargv);
- errno = save_errno;
+ 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 **) scm_malloc ((num_strings + 1) * sizeof (char *));
- if (result == NULL)
- scm_memory_error (proc);
- for (i = 0; !SCM_NULL_OR_NIL_P (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] = scm_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. */
"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;
- int save_errno, i;
+ char *exec_file;
- SCM_VALIDATE_STRING (1, filename);
-
- execargv = allocate_string_pointers (args);
- exec_env = environ_list_to_c (env, SCM_ARG2, FUNC_NAME);
- execve (SCM_STRING_CHARS (filename), execargv, exec_env);
- save_errno = errno;
- free (execargv);
- for (i = 0; exec_env[i] != NULL; i++)
- free (exec_env[i]);
- free (exec_env);
- errno = save_errno;
+ 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
SCM result = scm_c_make_vector (5, SCM_UNSPECIFIED);
if (uname (&buf) < 0)
SCM_SYSERROR;
- SCM_VECTOR_SET(result, 0, scm_makfrom0str (buf.sysname));
- SCM_VECTOR_SET(result, 1, scm_makfrom0str (buf.nodename));
- SCM_VECTOR_SET(result, 2, scm_makfrom0str (buf.release));
- SCM_VECTOR_SET(result, 3, scm_makfrom0str (buf.version));
- SCM_VECTOR_SET(result, 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?
- SCM_VECTOR_SET(result, 5, scm_makfrom0str (buf.domainname));
+ SCM_SIMPLE_VECTOR_SET(result, 5, scm_from_locale_string (buf.domainname));
*/
return result;
}
{
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
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_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);
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);
- rv = access (SCM_STRING_CHARS (path), scm_to_int (how));
+ WITH_STRING (path, c_path,
+ rv = access (c_path, scm_to_int (how)));
return scm_from_bool (!rv);
}
#undef FUNC_NAME
#define FUNC_NAME s_scm_putenv
{
int rv;
- char *ptr;
-
- SCM_VALIDATE_STRING (1, str);
+ char *c_str = scm_to_locale_string (str);
+#ifdef __MINGW32__
+ size_t len = strlen (c_str);
+#endif
- if (strchr (SCM_STRING_CHARS (str), '=') == NULL)
+ if (strchr (c_str, '=') == NULL)
{
#ifdef HAVE_UNSETENV
/* No '=' in argument means we should remove the variable from
the environment. Not all putenvs understand this (for instance
FreeBSD 4.8 doesn't). To be safe, we do it explicitely using
unsetenv. */
- unsetenv (SCM_STRING_CHARS (str));
+ unsetenv (c_str);
+ free (c_str);
#else
/* On e.g. Win32 hosts putenv() called with 'name=' removes the
environment variable 'name'. */
int e;
- ptr = scm_malloc (SCM_STRING_LENGTH (str) + 2);
- if (ptr == NULL)
- SCM_MEMORY_ERROR;
- strncpy (ptr, SCM_STRING_CHARS (str), SCM_STRING_LENGTH (str));
- ptr[SCM_STRING_LENGTH (str)] = '=';
- ptr[SCM_STRING_LENGTH (str) + 1] = 0;
+ char *ptr = scm_malloc (len + 2);
+ strcpy (ptr, c_str);
+ strcpy (ptr+len, "=");
rv = putenv (ptr);
- e = errno; free (ptr); errno = e;
+ e = errno; free (ptr); free (c_str); errno = e;
if (rv < 0)
SCM_SYSERROR;
#endif /* !HAVE_UNSETENV */
}
else
{
- /* must make a new copy to be left in the environment, safe from gc. */
- ptr = scm_malloc (SCM_STRING_LENGTH (str) + 1);
- if (ptr == NULL)
- SCM_MEMORY_ERROR;
- strncpy (ptr, SCM_STRING_CHARS (str), SCM_STRING_LENGTH (str));
-
#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="
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. */
- if (ptr[SCM_STRING_LENGTH (str) - 1] == '=')
+
+ if (c_str[len-1] == '=')
{
- char *alt;
- SCM name = scm_substring (str, scm_from_int (0),
- scm_from_int (SCM_STRING_LENGTH (str)-1));
- if (getenv (SCM_STRING_CHARS (name)) == NULL)
- {
- alt = scm_malloc (SCM_STRING_LENGTH (str) + 2);
- if (alt == NULL)
- {
- free (ptr);
- SCM_MEMORY_ERROR;
- }
- memcpy (alt, SCM_STRING_CHARS (str), SCM_STRING_LENGTH (str));
- alt[SCM_STRING_LENGTH (str)] = ' ';
- alt[SCM_STRING_LENGTH (str) + 1] = '\0';
- rv = putenv (alt);
- if (rv < 0)
- SCM_SYSERROR;
- free (ptr); /* don't need the old string we gave to putenv */
+ 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;
}
- alt = getenv (SCM_STRING_CHARS (name));
- alt[0] = '\0';
+ /* truncate to just the name */
+ c_str[len-1] = '\0';
+ ptr = getenv (c_str);
+ if (ptr)
+ ptr[0] = '\0';
return SCM_UNSPECIFIED;
}
#endif /* __MINGW32__ */
- ptr[SCM_STRING_LENGTH (str)] = 0;
- rv = putenv (ptr);
+ /* Leave c_str in the environment. */
+
+ rv = putenv (c_str);
if (rv < 0)
SCM_SYSERROR;
}
char *clocale;
char *rv;
+ scm_dynwind_begin (0);
+
if (SCM_UNBNDP (locale))
{
clocale = NULL;
}
else
{
- SCM_VALIDATE_STRING (2, locale);
- clocale = SCM_STRING_CHARS (locale);
+ clocale = scm_to_locale_string (locale);
+ scm_dynwind_free (clocale);
}
- rv = setlocale (scm_to_int (category), clocale);
+ rv = setlocale (scm_i_to_lc_category (category, 1), clocale);
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);
- 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)
else
SCM_OUT_OF_RANGE (2, type);
- SCM_SYSCALL (val = mknod (SCM_STRING_CHARS (path),
- ctype | scm_to_int (perms),
- scm_to_int (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
{
- if (nice (scm_to_int (incr)) != 0)
+ /* nice() returns "prio-NZERO" on success or -1 on error, but -1 can arise
+ from "prio-NZERO", so an error must be detected from errno changed */
+ errno = 0;
+ nice (scm_to_int (incr));
+ if (errno != 0)
SCM_SYSERROR;
return SCM_UNSPECIFIED;
}
#define FUNC_NAME s_scm_crypt
{
SCM ret;
- SCM_VALIDATE_STRING (1, key);
- SCM_VALIDATE_STRING (2, salt);
+ char *c_key, *c_salt;
+
+ scm_dynwind_begin (0);
+ scm_i_dynwind_pthread_mutex_lock (&scm_i_misc_mutex);
- scm_frame_begin (0);
- scm_frame_unwind_handler ((void(*)(void*)) scm_mutex_unlock,
- &scm_i_misc_mutex,
- SCM_F_WIND_EXPLICITLY);
- scm_mutex_lock (&scm_i_misc_mutex);
+ c_key = scm_to_locale_string (key);
+ scm_dynwind_free (c_key);
+ c_salt = scm_to_locale_string (salt);
+ scm_dynwind_free (c_salt);
- ret = scm_makfrom0str (crypt (SCM_STRING_CHARS (key),
- SCM_STRING_CHARS (salt)));
+ ret = scm_from_locale_string (crypt (c_key, c_salt));
- scm_frame_end ();
+ scm_dynwind_end ();
return ret;
}
#undef FUNC_NAME
"root directory.")
#define FUNC_NAME s_scm_chroot
{
- SCM_VALIDATE_STRING (1, 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;
}
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 */
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 */
SCM_VALIDATE_STRING (1, 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));
(SCM file, SCM operation),
"Apply or remove an advisory lock on an open file.\n"
"@var{operation} specifies the action to be done:\n"
- "@table @code\n"
- "@item LOCK_SH\n"
+ "\n"
+ "@defvar LOCK_SH\n"
"Shared lock. More than one process may hold a shared lock\n"
"for a given file at a given time.\n"
- "@item LOCK_EX\n"
+ "@end defvar\n"
+ "@defvar LOCK_EX\n"
"Exclusive lock. Only one process may hold an exclusive lock\n"
"for a given file at a given time.\n"
- "@item LOCK_UN\n"
+ "@end defvar\n"
+ "@defvar LOCK_UN\n"
"Unlock the file.\n"
- "@item LOCK_NB\n"
- "Don't block when locking. May be specified by bitwise OR'ing\n"
- "it to one of the other operations.\n"
- "@end table\n"
+ "@end defvar\n"
+ "@defvar LOCK_NB\n"
+ "Don't block when locking. This is combined with one of the\n"
+ "other operations using @code{logior}. If @code{flock} would\n"
+ "block an @code{EWOULDBLOCK} error is thrown.\n"
+ "@end defvar\n"
+ "\n"
"The return value is not specified. @var{file} may be an open\n"
- "file descriptor or an open file descriptor port.")
+ "file descriptor or an open file descriptor port.\n"
+ "\n"
+ "Note that @code{flock} does not lock files across NFS.")
#define FUNC_NAME s_scm_flock
{
int fdes;
"specified.")
#define FUNC_NAME s_scm_sethostname
{
- SCM_VALIDATE_STRING (1, 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;
}
char *const p = scm_malloc (len);
const int res = gethostname (p, len);
- scm_frame_begin (0);
- scm_frame_unwind_handler (free, p, 0);
+ scm_dynwind_begin (0);
+ scm_dynwind_unwind_handler (free, p, 0);
#else
p = scm_malloc (len);
- scm_frame_begin (0);
- scm_frame_unwind_handler (free, p, 0);
+ scm_dynwind_begin (0);
+ scm_dynwind_unwind_handler (free, p, 0);
res = gethostname (p, len);
while (res == -1 && errno == ENAMETOOLONG)
{
const int save_errno = errno;
- // No guile exceptions can occur before we have freed p's memory.
- scm_frame_end ();
+ /* No guile exceptions can occur before we have freed p's memory. */
+ scm_dynwind_end ();
free (p);
errno = save_errno;
}
else
{
- /* scm_makfrom0str may throw an exception. */
- const SCM name = scm_makfrom0str (p);
+ /* scm_from_locale_string may throw an exception. */
+ const SCM name = scm_from_locale_string (p);
- // No guile exceptions can occur before we have freed p's memory.
- scm_frame_end ();
+ /* No guile exceptions can occur before we have freed p's memory. */
+ scm_dynwind_end ();
free (p);
return name;
#ifdef LC_ALL
scm_c_define ("LC_ALL", scm_from_int (LC_ALL));
#endif
+#ifdef LC_PAPER
+ scm_c_define ("LC_PAPER", scm_from_int (LC_PAPER));
+#endif
+#ifdef LC_NAME
+ scm_c_define ("LC_NAME", scm_from_int (LC_NAME));
+#endif
+#ifdef LC_ADDRESS
+ scm_c_define ("LC_ADDRESS", scm_from_int (LC_ADDRESS));
+#endif
+#ifdef LC_TELEPHONE
+ scm_c_define ("LC_TELEPHONE", scm_from_int (LC_TELEPHONE));
+#endif
+#ifdef LC_MEASUREMENT
+ scm_c_define ("LC_MEASUREMENT", scm_from_int (LC_MEASUREMENT));
+#endif
+#ifdef LC_IDENTIFICATION
+ scm_c_define ("LC_IDENTIFICATION", scm_from_int (LC_IDENTIFICATION));
+#endif
#ifdef PIPE_BUF
- scm_c_define ("PIPE_BUF", scm_long2num (PIPE_BUF));
+ scm_c_define ("PIPE_BUF", scm_from_long (PIPE_BUF));
#endif
#ifdef PRIO_PROCESS
HCoop / bpt / guile.git / blobdiff