/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+ */
\f
+#if HAVE_CONFIG_H
+# include <config.h>
+#endif
/* Make GNU/Linux libc declare everything it has. */
#define _GNU_SOURCE
#include "libguile/feature.h"
#include "libguile/strings.h"
#include "libguile/vectors.h"
+#include "libguile/lang.h"
#include "libguile/validate.h"
#include "libguile/posix.h"
#include <sys/utsname.h>
#endif
-#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
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;
size_t size;
GETGROUPS_T *groups;
SCM_SYSERROR;
size = ngroups * sizeof (GETGROUPS_T);
- groups = scm_must_malloc (size, FUNC_NAME);
+ groups = scm_malloc (size);
getgroups (ngroups, groups);
- ans = scm_c_make_vector (ngroups, SCM_UNDEFINED);
- while (--ngroups >= 0)
- SCM_VELTS (ans) [ngroups] = SCM_MAKINUM (groups [ngroups]);
+ result = scm_c_make_vector (ngroups, SCM_UNDEFINED);
- scm_must_free (groups);
- scm_done_free (size);
-
- return ans;
+ {
+ SCM * ve = SCM_WRITABLE_VELTS(result);
+
+ while (--ngroups >= 0)
+ ve[ngroups] = SCM_MAKINUM (groups [ngroups]);
+ }
+ free (groups);
+ return result;
}
#undef FUNC_NAME
#endif
"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);
+ SCM result = scm_c_make_vector (7, SCM_UNSPECIFIED);
if (SCM_UNBNDP (user) || SCM_FALSEP (user))
{
SCM_SYSCALL (entry = getpwent ());
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_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));
if (!entry->pw_dir)
- ve[5] = scm_makfrom0str ("");
+ SCM_VECTOR_SET(result, 5, scm_makfrom0str (""));
else
- ve[5] = scm_makfrom0str (entry->pw_dir);
+ SCM_VECTOR_SET(result, 5, scm_makfrom0str (entry->pw_dir));
if (!entry->pw_shell)
- ve[6] = scm_makfrom0str ("");
+ SCM_VECTOR_SET(result, 6, scm_makfrom0str (""));
else
- ve[6] = scm_makfrom0str (entry->pw_shell);
+ SCM_VECTOR_SET(result, 6, scm_makfrom0str (entry->pw_shell));
return result;
}
#undef FUNC_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);
+ SCM result = scm_c_make_vector (4, SCM_UNSPECIFIED);
+
if (SCM_UNBNDP (name) || SCM_FALSEP (name))
{
SCM_SYSCALL (entry = getgrent ());
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_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));
return result;
}
#undef FUNC_NAME
"@end defvar")
#define FUNC_NAME s_scm_kill
{
- SCM_VALIDATE_INUM (1,pid);
- SCM_VALIDATE_INUM (2,sig);
+ SCM_VALIDATE_INUM (1, pid);
+ SCM_VALIDATE_INUM (2, sig);
/* Signal values are interned in scm_init_posix(). */
#ifdef HAVE_KILL
if (kill ((int) SCM_INUM (pid), (int) SCM_INUM (sig)) != 0)
int i;
int status;
int ioptions;
- SCM_VALIDATE_INUM (1,pid);
+ SCM_VALIDATE_INUM (1, pid);
if (SCM_UNBNDP (options))
ioptions = 0;
else
{
- SCM_VALIDATE_INUM (2,options);
+ SCM_VALIDATE_INUM (2, options);
/* Flags are interned in scm_init_posix. */
ioptions = SCM_INUM (options);
}
{
int lstatus;
- SCM_VALIDATE_INUM (1,status);
+ 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. */
{
int lstatus;
- SCM_VALIDATE_INUM (1,status);
+ SCM_VALIDATE_INUM (1, status);
lstatus = SCM_INUM (status);
if (WIFSIGNALED (lstatus))
{
int lstatus;
- SCM_VALIDATE_INUM (1,status);
+ SCM_VALIDATE_INUM (1, status);
lstatus = SCM_INUM (status);
if (WIFSTOPPED (lstatus))
(),
"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
{
(),
"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
{
"The return value is unspecified.")
#define FUNC_NAME s_scm_setuid
{
- SCM_VALIDATE_INUM (1,id);
+ SCM_VALIDATE_INUM (1, id);
if (setuid (SCM_INUM (id)) != 0)
SCM_SYSERROR;
return SCM_UNSPECIFIED;
"The return value is unspecified.")
#define FUNC_NAME s_scm_setgid
{
- SCM_VALIDATE_INUM (1,id);
+ SCM_VALIDATE_INUM (1, id);
if (setgid (SCM_INUM (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);
+ SCM_VALIDATE_INUM (1, id);
#ifdef HAVE_SETEUID
rv = seteuid (SCM_INUM (id));
#else
(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);
+ SCM_VALIDATE_INUM (1, id);
#ifdef HAVE_SETEUID
rv = setegid (SCM_INUM (id));
#else
"The return value is unspecified.")
#define FUNC_NAME s_scm_setpgid
{
- SCM_VALIDATE_INUM (1,pid);
- SCM_VALIDATE_INUM (2,pgid);
+ 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)
SCM_SYSERROR;
"underlying @var{port}.")
#define FUNC_NAME s_scm_ttyname
{
- char *ans;
+ char *result;
int fd;
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_SYSCALL (result = ttyname (fd));
+ if (!result)
SCM_SYSERROR;
- /* ans could be overwritten by another call to ttyname */
- return (scm_makfrom0str (ans));
+ /* result could be overwritten by another call to ttyname */
+ return (scm_makfrom0str (result));
}
#undef FUNC_NAME
#endif /* HAVE_TTYNAME */
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;
port = SCM_COERCE_OUTPORT (port);
- SCM_VALIDATE_OPFPORT (1,port);
- SCM_VALIDATE_INUM (2,pgid);
+ SCM_VALIDATE_OPFPORT (1, port);
+ SCM_VALIDATE_INUM (2, pgid);
fd = SCM_FPORT_FDES (port);
if (tcsetpgrp (fd, SCM_INUM (pgid)) == -1)
SCM_SYSERROR;
#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)
+/* 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)
{
- char **argv;
- int argc;
+ char **result;
+ int n_args = scm_ilength (args);
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_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 arg = SCM_CAR (args);
- size_t len;
- char *dst;
- char *src;
+ SCM car = SCM_CAR (args);
- 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;
+ 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);
}
- argv[i] = 0;
- return argv;
+ return result;
}
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"
{
char **execargv;
SCM_VALIDATE_STRING (1, filename);
- execargv = scm_convert_exec_args (args, SCM_ARG2, FUNC_NAME);
+ execargv = allocate_string_pointers (args);
execv (SCM_STRING_CHARS (filename), execargv);
SCM_SYSERROR;
/* not reached. */
{
char **execargv;
SCM_VALIDATE_STRING (1, filename);
- execargv = scm_convert_exec_args (args, SCM_ARG2, FUNC_NAME);
+ execargv = allocate_string_pointers (args);
execvp (SCM_STRING_CHARS (filename), execargv);
SCM_SYSERROR;
/* not reached. */
num_strings = scm_ilength (envlist);
SCM_ASSERT (num_strings >= 0, envlist, arg, proc);
- result = (char **) malloc ((num_strings + 1) * sizeof (char *));
+ result = (char **) scm_malloc ((num_strings + 1) * sizeof (char *));
if (result == NULL)
scm_memory_error (proc);
- for (i = 0; !SCM_NULLP (envlist); ++i, envlist = SCM_CDR (envlist))
+ for (i = 0; !SCM_NULL_OR_NIL_P (envlist); ++i, envlist = SCM_CDR (envlist))
{
SCM str = SCM_CAR (envlist);
int len;
SCM_ASSERT (SCM_STRINGP (str), envlist, arg, proc);
len = SCM_STRING_LENGTH (str);
src = SCM_STRING_CHARS (str);
- result[i] = malloc (len + 1);
+ result[i] = scm_malloc (len + 1);
if (result[i] == NULL)
scm_memory_error (proc);
memcpy (result[i], src, len);
SCM_VALIDATE_STRING (1, filename);
- execargv = scm_convert_exec_args (args, SCM_ARG1, FUNC_NAME);
+ execargv = allocate_string_pointers (args);
exec_env = environ_list_to_c (env, SCM_ARG2, FUNC_NAME);
execve (SCM_STRING_CHARS (filename), execargv, exec_env);
SCM_SYSERROR;
#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_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));
/*
a linux special?
- ve[5] = scm_makfrom0str (buf.domainname);
+ SCM_VECTOR_SET(result, 5, scm_makfrom0str (buf.domainname));
*/
- return ans;
+ return result;
}
#undef FUNC_NAME
#endif /* HAVE_UNAME */
#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"
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;
+
+ if (strchr (SCM_STRING_CHARS (str), '=') == NULL)
+ {
+#ifdef HAVE_UNSETENV
+ /* No '=' in argument means we should remove the variable from
+ the environment. Not all putenvs understand this. To be
+ safe, we do it explicitely using unsetenv. */
+ unsetenv (SCM_STRING_CHARS (str));
+#else
+ /* On e.g. Win32 hosts putenv() called with 'name=' removes the
+ environment variable 'name'. */
+ ptr = scm_malloc (SCM_STRING_LENGTH (str) + 2);
+ strncpy (ptr, SCM_STRING_CHARS (str), SCM_STRING_LENGTH (str));
+ ptr[SCM_STRING_LENGTH (str)] = '=';
+ ptr[SCM_STRING_LENGTH (str) + 1] = 0;
+ rv = putenv (ptr);
+ if (rv < 0)
+ SCM_SYSERROR;
+#endif
+ }
+ 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));
+ ptr[SCM_STRING_LENGTH (str)] = 0;
+ rv = putenv (ptr);
+ if (rv < 0)
+ SCM_SYSERROR;
+ }
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
"Otherwise the specified locale category is set to the string\n"
"@var{locale} and the new value is returned as a\n"
"system-dependent string. If @var{locale} is an empty string,\n"
- "the locale will be set using envirionment variables.")
+ "the locale will be set using environment variables.")
#define FUNC_NAME s_scm_setlocale
{
char *clocale;
char *rv;
- SCM_VALIDATE_INUM (1,category);
+ SCM_VALIDATE_INUM (1, category);
if (SCM_UNBNDP (locale))
{
clocale = NULL;
int ctype = 0;
SCM_VALIDATE_STRING (1, path);
- SCM_VALIDATE_SYMBOL (2,type);
- SCM_VALIDATE_INUM (3,perms);
- SCM_VALIDATE_INUM (4,dev);
+ SCM_VALIDATE_SYMBOL (2, type);
+ SCM_VALIDATE_INUM (3, perms);
+ SCM_VALIDATE_INUM (4, dev);
p = SCM_SYMBOL_CHARS (type);
if (strcmp (p, "regular") == 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)));
"The return value is unspecified.")
#define FUNC_NAME s_scm_nice
{
- SCM_VALIDATE_INUM (1,incr);
+ SCM_VALIDATE_INUM (1, incr);
if (nice(SCM_INUM(incr)) != 0)
SCM_SYSERROR;
return SCM_UNSPECIFIED;
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;
#endif /* __MINGW32__ */
-#if HAVE_GETLOGIN
+#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"
#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"
"it to one of the other operations.\n"
"@end table\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.")
#define FUNC_NAME s_scm_flock
{
int coperation, fdes;
/* 256 is for Solaris, under Linux ENAMETOOLONG is returned if not
large enough. */
int len = 256, res;
- char *p = scm_must_malloc (len, "gethostname");
+ char *p = scm_malloc (len);
SCM name;
res = gethostname (p, len);
while (res == -1 && errno == ENAMETOOLONG)
{
- p = scm_must_realloc (p, len, len * 2, "gethostname");
+ p = scm_realloc (p, len * 2);
len *= 2;
res = gethostname (p, len);
}
if (res == -1)
{
- scm_must_free (p);
+ free (p);
SCM_SYSERROR;
}
name = scm_makfrom0str (p);
- scm_must_free (p);
+ free (p);
return name;
}
#undef FUNC_NAME
#endif
#include "libguile/cpp_sig_symbols.c"
-#ifndef SCM_MAGIC_SNARFER
#include "libguile/posix.x"
-#endif
}
/*
HCoop / bpt / guile.git / blobdiff