-/* Copyright (C) 1995, 96, 97, 98, 99, 2000 Free Software Foundation, Inc.
+/* 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
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice. */
-/* 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
+
#include <stdio.h>
+#include <errno.h>
+
#include "libguile/_scm.h"
#include "libguile/fports.h"
#include "libguile/scmsigs.h"
#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/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>
#include <signal.h>
-extern FILE *popen ();
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
+# include <crypt.h>
+#endif
+
+#if HAVE_SYS_RESOURCE_H
+# include <sys/resource.h>
+#endif
+
+#if HAVE_SYS_FILE_H
+# include <sys/file.h>
+#endif
+
/* Some Unix systems don't define these. CPP hair is dangerous, but
this seems safe enough... */
#ifndef R_OK
SCM_DEFINE (scm_pipe, "pipe", 0, 0, 0,
(),
- "Returns a newly created pipe: a pair of ports which are linked\n"
- "together on the local machine. The CAR is the input port and\n"
- "the CDR is the output port. Data written (and flushed) to the\n"
- "output port can be read from the input port.\n"
- "Pipes are commonly used for communication with a newly\n"
- "forked child process. The need to flush the output port\n"
- "can be avoided by making it unbuffered using @code{setvbuf}.\n\n"
- "Writes occur atomically provided the size of the data in\n"
- "bytes is not greater than the value of @code{PIPE_BUF}\n"
- "Note that the output port is likely to block if too much data\n"
- "(typically equal to @code{PIPE_BUF}) has been written but not\n"
- "yet read from the input port\n"
- )
+ "Return a newly created pipe: a pair of ports which are linked\n"
+ "together on the local machine. The @emph{car} is the input\n"
+ "port and the @emph{cdr} is the output port. Data written (and\n"
+ "flushed) to the output port can be read from the input port.\n"
+ "Pipes are commonly used for communication with a newly forked\n"
+ "child process. The need to flush the output port can be\n"
+ "avoided by making it unbuffered using @code{setvbuf}.\n"
+ "\n"
+ "Writes occur atomically provided the size of the data in bytes\n"
+ "is not greater than the value of @code{PIPE_BUF}. Note that\n"
+ "the output port is likely to block if too much data (typically\n"
+ "equal to @code{PIPE_BUF}) has been written but not yet read\n"
+ "from the input port.")
#define FUNC_NAME s_scm_pipe
{
int fd[2], rv;
#ifdef HAVE_GETGROUPS
SCM_DEFINE (scm_getgroups, "getgroups", 0, 0, 0,
(),
- "Returns a vector of integers representing the current supplimentary group IDs.")
+ "Return a vector of integers representing the current\n"
+ "supplementary group IDs.")
#define FUNC_NAME s_scm_getgroups
{
- SCM grps, ans;
- int ngroups = getgroups (0, NULL);
- if (!ngroups)
+ SCM ans;
+ int ngroups;
+ size_t size;
+ GETGROUPS_T *groups;
+
+ ngroups = getgroups (0, NULL);
+ if (ngroups <= 0)
SCM_SYSERROR;
- SCM_NEWCELL(grps);
- SCM_DEFER_INTS;
- {
- GETGROUPS_T *groups;
- int val;
- groups = SCM_MUST_MALLOC_TYPE_NUM(GETGROUPS_T,ngroups);
- val = getgroups(ngroups, groups);
- if (val < 0)
- {
- int en = errno;
- scm_must_free((char *)groups);
- errno = en;
- SCM_SYSERROR;
- }
- SCM_SETCHARS(grps, groups); /* set up grps as a GC protect */
- SCM_SETLENGTH(grps, 0L + ngroups * sizeof(GETGROUPS_T), scm_tc7_string);
- ans = scm_make_vector (SCM_MAKINUM(ngroups), SCM_UNDEFINED);
- while (--ngroups >= 0) SCM_VELTS(ans)[ngroups] = SCM_MAKINUM(groups[ngroups]);
- SCM_SETCHARS(grps, groups); /* to make sure grps stays around. */
- SCM_ALLOW_INTS;
- return ans;
+ size = ngroups * sizeof (GETGROUPS_T);
+ groups = scm_malloc (size);
+ getgroups (ngroups, groups);
+
+ ans = scm_c_make_vector (ngroups, SCM_UNDEFINED);
+
+ {
+ SCM * ve = SCM_WRITABLE_VELTS(ans);
+
+ while (--ngroups >= 0)
+ ve[ngroups] = SCM_MAKINUM (groups [ngroups]);
}
+ free (groups);
+ return ans;
}
#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_make_vector (SCM_MAKINUM (7), SCM_UNSPECIFIED);
- ve = SCM_VELTS (result);
+ SCM ans = scm_c_make_vector (7, SCM_UNSPECIFIED);
if (SCM_UNBNDP (user) || SCM_FALSEP (user))
{
SCM_SYSCALL (entry = getpwent ());
}
else
{
- SCM_VALIDATE_ROSTRING (1,user);
- if (SCM_SUBSTRP (user))
- user = scm_makfromstr (SCM_ROCHARS (user), SCM_STRING_LENGTH (user), 0);
- entry = getpwnam (SCM_ROCHARS (user));
+ SCM_VALIDATE_STRING (1, user);
+ entry = getpwnam (SCM_STRING_CHARS (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_VECTOR_SET(ans, 0, scm_makfrom0str (entry->pw_name));
+ SCM_VECTOR_SET(ans, 1, scm_makfrom0str (entry->pw_passwd));
+ SCM_VECTOR_SET(ans, 2, scm_ulong2num ((unsigned long) entry->pw_uid));
+ SCM_VECTOR_SET(ans, 3, scm_ulong2num ((unsigned long) entry->pw_gid));
+ SCM_VECTOR_SET(ans, 4, scm_makfrom0str (entry->pw_gecos));
if (!entry->pw_dir)
- ve[5] = scm_makfrom0str ("");
+ SCM_VECTOR_SET(ans, 5, scm_makfrom0str (""));
else
- ve[5] = scm_makfrom0str (entry->pw_dir);
+ SCM_VECTOR_SET(ans, 5, scm_makfrom0str (entry->pw_dir));
if (!entry->pw_shell)
- ve[6] = scm_makfrom0str ("");
+ SCM_VECTOR_SET(ans, 6, scm_makfrom0str (""));
else
- ve[6] = scm_makfrom0str (entry->pw_shell);
- return result;
+ SCM_VECTOR_SET(ans, 6, scm_makfrom0str (entry->pw_shell));
+ return ans;
}
#undef FUNC_NAME
+#endif /* HAVE_GETPWENT */
#ifdef HAVE_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_make_vector (SCM_MAKINUM (4), SCM_UNSPECIFIED);
- ve = SCM_VELTS (result);
+ SCM ans = scm_c_make_vector (4, SCM_UNSPECIFIED);
+
if (SCM_UNBNDP (name) || SCM_FALSEP (name))
{
SCM_SYSCALL (entry = getgrent ());
SCM_SYSCALL (entry = getgrgid (SCM_INUM (name)));
else
{
- SCM_VALIDATE_ROSTRING (1,name);
- SCM_COERCE_SUBSTR (name);
- SCM_SYSCALL (entry = getgrnam (SCM_ROCHARS (name)));
+ SCM_VALIDATE_STRING (1, name);
+ SCM_SYSCALL (entry = getgrnam (SCM_STRING_CHARS (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);
- return result;
+ SCM_VECTOR_SET(ans, 0, scm_makfrom0str (entry->gr_name));
+ SCM_VECTOR_SET(ans, 1, scm_makfrom0str (entry->gr_passwd));
+ SCM_VECTOR_SET(ans, 2, scm_ulong2num ((unsigned long) entry->gr_gid));
+ SCM_VECTOR_SET(ans, 3, scm_makfromstrs (-1, entry->gr_mem));
+ return ans;
}
#undef FUNC_NAME
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
-
+#endif /* HAVE_GETGRENT */
SCM_DEFINE (scm_kill, "kill", 2, 0, 0,
"@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)
- SCM_SYSERROR;
+#else
+ if ((int) SCM_INUM (pid) == getpid ())
+ if (raise ((int) SCM_INUM (sig)) != 0)
+#endif
+ SCM_SYSERROR;
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
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);
}
#undef FUNC_NAME
#endif /* HAVE_WAITPID */
+#ifndef __MINGW32__
SCM_DEFINE (scm_status_exit_val, "status:exit-val", 1, 0, 0,
(SCM status),
- "Returns the exit status value, as would be\n"
- "set if a process ended normally through a\n"
- "call to @code{exit} or @code{_exit}, if any, otherwise @code{#f}.")
+ "Return the exit status value, as would be set if a process\n"
+ "ended normally through a call to @code{exit} or @code{_exit},\n"
+ "if any, otherwise @code{#f}.")
#define FUNC_NAME s_scm_status_exit_val
{
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. */
SCM_DEFINE (scm_status_term_sig, "status:term-sig", 1, 0, 0,
(SCM status),
- "Returns the signal number which terminated the\n"
- "process, if any, otherwise @code{#f}.")
+ "Return the signal number which terminated the process, if any,\n"
+ "otherwise @code{#f}.")
#define FUNC_NAME s_scm_status_term_sig
{
int lstatus;
- SCM_VALIDATE_INUM (1,status);
+ SCM_VALIDATE_INUM (1, status);
lstatus = SCM_INUM (status);
if (WIFSIGNALED (lstatus))
SCM_DEFINE (scm_status_stop_sig, "status:stop-sig", 1, 0, 0,
(SCM status),
- "Returns the signal number which stopped the\n"
- "process, if any, otherwise @code{#f}.")
+ "Return the signal number which stopped the process, if any,\n"
+ "otherwise @code{#f}.")
#define FUNC_NAME s_scm_status_stop_sig
{
int lstatus;
- SCM_VALIDATE_INUM (1,status);
+ SCM_VALIDATE_INUM (1, status);
lstatus = SCM_INUM (status);
if (WIFSTOPPED (lstatus))
return SCM_BOOL_F;
}
#undef FUNC_NAME
+#endif /* __MINGW32__ */
+#ifdef HAVE_GETPPID
SCM_DEFINE (scm_getppid, "getppid", 0, 0, 0,
(),
- "Returns an integer representing the process ID of the parent process.")
+ "Return an integer representing the process ID of the parent\n"
+ "process.")
#define FUNC_NAME s_scm_getppid
{
return SCM_MAKINUM (0L + getppid ());
}
#undef FUNC_NAME
+#endif /* HAVE_GETPPID */
-
+#ifndef __MINGW32__
SCM_DEFINE (scm_getuid, "getuid", 0, 0, 0,
(),
- "Returns an integer representing the current real user ID.")
+ "Return an integer representing the current real user ID.")
#define FUNC_NAME s_scm_getuid
{
return SCM_MAKINUM (0L + getuid ());
SCM_DEFINE (scm_getgid, "getgid", 0, 0, 0,
(),
- "Returns an integer representing the current real group ID.")
+ "Return an integer representing the current real group ID.")
#define FUNC_NAME s_scm_getgid
{
return SCM_MAKINUM (0L + getgid ());
SCM_DEFINE (scm_geteuid, "geteuid", 0, 0, 0,
(),
- "Returns an integer representing the current effective user ID.\n"
+ "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 system\n"
- "supports effective IDs.")
+ "is returned. @code{(feature? 'EIDs)} reports whether the\n"
+ "system supports effective IDs.")
#define FUNC_NAME s_scm_geteuid
{
#ifdef HAVE_GETEUID
#undef FUNC_NAME
-
SCM_DEFINE (scm_getegid, "getegid", 0, 0, 0,
(),
- "Returns an integer representing the current effective group ID.\n"
+ "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 system\n"
- "supports effective IDs.")
+ "is returned. @code{(feature? 'EIDs)} reports whether the\n"
+ "system supports effective IDs.")
#define FUNC_NAME s_scm_getegid
{
#ifdef HAVE_GETEUID
"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;
{
int rv;
- SCM_VALIDATE_INUM (1,id);
+ SCM_VALIDATE_INUM (1, id);
#ifdef HAVE_SETEUID
rv = seteuid (SCM_INUM (id));
#else
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
+#endif /* __MINGW32__ */
+
#ifdef HAVE_SETEGID
SCM_DEFINE (scm_setegid, "setegid", 1, 0, 0,
{
int rv;
- SCM_VALIDATE_INUM (1,id);
+ SCM_VALIDATE_INUM (1, id);
#ifdef HAVE_SETEUID
rv = setegid (SCM_INUM (id));
#else
#undef FUNC_NAME
#endif
+
+#ifdef HAVE_GETPGRP
SCM_DEFINE (scm_getpgrp, "getpgrp", 0, 0, 0,
(),
- "Returns an integer representing the current process group ID.\n"
+ "Return an integer representing the current process group ID.\n"
"This is the POSIX definition, not BSD.")
#define FUNC_NAME s_scm_getpgrp
{
return SCM_MAKINUM (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);
+ 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;
#undef FUNC_NAME
#endif /* HAVE_SETSID */
+#ifdef HAVE_TTYNAME
SCM_DEFINE (scm_ttyname, "ttyname", 1, 0, 0,
(SCM port),
- "Returns a string with the name of the serial terminal device underlying\n"
- "@var{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;
port = SCM_COERCE_OUTPORT (port);
- SCM_VALIDATE_OPPORT (1,port);
- if (scm_tc16_fport != SCM_TYP16 (port))
+ SCM_VALIDATE_OPPORT (1, port);
+ if (!SCM_FPORTP (port))
return SCM_BOOL_F;
fd = SCM_FPORT_FDES (port);
SCM_SYSCALL (ans = ttyname (fd));
return (scm_makfrom0str (ans));
}
#undef FUNC_NAME
+#endif /* HAVE_TTYNAME */
#ifdef HAVE_CTERMID
SCM_DEFINE (scm_ctermid, "ctermid", 0, 0, 0,
(),
- "Returns a string containing the file name of the controlling terminal\n"
- "for the current process.")
+ "Return a string containing the file name of the controlling\n"
+ "terminal for the current process.")
#define FUNC_NAME s_scm_ctermid
{
char *result = ctermid (NULL);
#ifdef HAVE_TCGETPGRP
SCM_DEFINE (scm_tcgetpgrp, "tcgetpgrp", 1, 0, 0,
(SCM port),
- "Returns the process group ID of the foreground\n"
- "process group associated with the terminal open on the file descriptor\n"
- "underlying @var{port}.\n\n"
+ "Return the process group ID of the foreground process group\n"
+ "associated with the terminal open on the file descriptor\n"
+ "underlying @var{port}.\n"
+ "\n"
"If there is no foreground process group, the return value is a\n"
"number greater than 1 that does not match the process group ID\n"
"of any existing process group. This can happen if all of the\n"
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 */
-/* Copy exec args from an SCM vector into a new C array. */
-
-static char **
-scm_convert_exec_args (SCM args, int pos, 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 **execargv;
- int num_args;
+ char **result;
+ int n_args = scm_ilength (args);
int i;
- num_args = scm_ilength (args);
- SCM_ASSERT (num_args >= 0, args, pos, subr);
- execargv = (char **)
- scm_must_malloc ((num_args + 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_sizet len;
- char *dst;
- char *src;
- SCM_ASSERT (SCM_ROSTRINGP (SCM_CAR (args)),
- SCM_CAR (args), SCM_ARGn, subr);
- len = 1 + SCM_ROLENGTH (SCM_CAR (args));
- dst = (char *) scm_must_malloc ((long) len, subr);
- src = SCM_ROCHARS (SCM_CAR (args));
- while (len--)
- dst[len] = src[len];
- execargv[i] = dst;
+ 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);
}
- execargv[i] = 0;
- return execargv;
+ 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"
#define FUNC_NAME s_scm_execl
{
char **execargv;
- SCM_VALIDATE_ROSTRING (1,filename);
- SCM_COERCE_SUBSTR (filename);
- execargv = scm_convert_exec_args (args, SCM_ARG2, FUNC_NAME);
- execv (SCM_ROCHARS (filename), execargv);
+ SCM_VALIDATE_STRING (1, filename);
+ execargv = allocate_string_pointers (args);
+ execv (SCM_STRING_CHARS (filename), execargv);
SCM_SYSERROR;
/* not reached. */
return SCM_BOOL_F;
#define FUNC_NAME s_scm_execlp
{
char **execargv;
- SCM_VALIDATE_ROSTRING (1,filename);
- SCM_COERCE_SUBSTR (filename);
- execargv = scm_convert_exec_args (args, SCM_ARG2, FUNC_NAME);
- execvp (SCM_ROCHARS (filename), execargv);
+ SCM_VALIDATE_STRING (1, filename);
+ execargv = allocate_string_pointers (args);
+ execvp (SCM_STRING_CHARS (filename), execargv);
SCM_SYSERROR;
/* not reached. */
return SCM_BOOL_F;
{
int num_strings;
char **result;
- int i = 0;
+ int i;
- SCM_ASSERT (SCM_NULLP (envlist) || SCM_CONSP (envlist),
- envlist, arg, proc);
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);
- while (SCM_NNULLP (envlist))
+ 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_ROSTRINGP (SCM_CAR (envlist)),
- envlist, arg, proc);
- len = 1 + SCM_ROLENGTH (SCM_CAR (envlist));
- result[i] = malloc ((long) len);
+ 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);
- src = SCM_ROCHARS (SCM_CAR (envlist));
- while (len--)
- result[i][len] = src[len];
- envlist = SCM_CDR (envlist);
- i++;
+ memcpy (result[i], src, len);
+ result[i][len] = 0;
}
result[i] = 0;
return result;
char **execargv;
char **exec_env;
- SCM_VALIDATE_ROSTRING (1,filename);
- SCM_COERCE_SUBSTR (filename);
+ 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_ROCHARS (filename), execargv, exec_env);
+ execve (SCM_STRING_CHARS (filename), execargv, exec_env);
SCM_SYSERROR;
/* not reached. */
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"
return SCM_MAKINUM (0L+pid);
}
#undef FUNC_NAME
+#endif /* HAVE_FORK */
+
+#ifdef __MINGW32__
+# include "win32-uname.h"
+#endif
-#ifdef HAVE_UNAME
+#if defined (HAVE_UNAME) || defined (__MINGW32__)
SCM_DEFINE (scm_uname, "uname", 0, 0, 0,
(),
- "Returns an object with some information about the computer system the\n"
- "program is running on.")
+ "Return an object with some information about the computer\n"
+ "system the program is running on.")
#define FUNC_NAME s_scm_uname
{
struct utsname buf;
- SCM ans = scm_make_vector (SCM_MAKINUM(5), SCM_UNSPECIFIED);
- SCM *ve = SCM_VELTS (ans);
+ SCM ans = 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(ans, 0, scm_makfrom0str (buf.sysname));
+ SCM_VECTOR_SET(ans, 1, scm_makfrom0str (buf.nodename));
+ SCM_VECTOR_SET(ans, 2, scm_makfrom0str (buf.release));
+ SCM_VECTOR_SET(ans, 3, scm_makfrom0str (buf.version));
+ SCM_VECTOR_SET(ans, 4, scm_makfrom0str (buf.machine));
/*
a linux special?
- ve[5] = scm_makfrom0str (buf.domainname);
+ SCM_VECTOR_SET(ans, 5, scm_makfrom0str (buf.domainname));
*/
return ans;
}
SCM_DEFINE (scm_environ, "environ", 0, 1, 0,
(SCM env),
- "If @var{env} is omitted, returns the current environment as a list of strings.\n"
- "Otherwise it sets the current environment, which is also the\n"
- "default environment for child processes, to the supplied list of strings.\n"
- "Each member of @var{env} should be of the form\n"
- "@code{NAME=VALUE} and values of @code{NAME} should not be duplicated.\n"
- "If @var{env} is supplied then the return value is unspecified.")
+ "If @var{env} is omitted, return the current environment (in the\n"
+ "Unix sense) as a list of strings. Otherwise set the current\n"
+ "environment, which is also the default environment for child\n"
+ "processes, to the supplied list of strings. Each member of\n"
+ "@var{env} should be of the form @code{NAME=VALUE} and values of\n"
+ "@code{NAME} should not be duplicated. If @var{env} is supplied\n"
+ "then the return value is unspecified.")
#define FUNC_NAME s_scm_environ
{
if (SCM_UNBNDP (env))
SCM_DEFINE (scm_tmpnam, "tmpnam", 0, 0, 0,
(),
- "Create a new file in the file system with a unique name. The return\n"
- "value is the name of the new file. This function is implemented with\n"
- "the @code{tmpnam} function in the system libraries.")
+ "Return a name in the file system that does not match any\n"
+ "existing file. However there is no guarantee that another\n"
+ "process will not create the file after @code{tmpnam} is called.\n"
+ "Care should be taken if opening the file, e.g., use the\n"
+ "@code{O_EXCL} open flag or use @code{mkstemp!} instead.")
#define FUNC_NAME s_scm_tmpnam
{
char name[L_tmpnam];
- SCM_SYSCALL (tmpnam (name););
+ char *rv;
+
+ SCM_SYSCALL (rv = tmpnam (name));
+ if (rv == NULL)
+ /* not SCM_SYSERROR since errno probably not set. */
+ SCM_MISC_ERROR ("tmpnam failed", SCM_EOL);
return scm_makfrom0str (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"
+ "buffered port open for reading and writing to the file.\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.")
+#define FUNC_NAME s_scm_mkstemp
+{
+ char *c_tmpl;
+ int rv;
+
+ SCM_VALIDATE_STRING_COPY (1, tmpl, c_tmpl);
+ SCM_SYSCALL (rv = mkstemp (c_tmpl));
+ if (rv == -1)
+ SCM_SYSERROR;
+ return scm_fdes_to_port (rv, "w+", tmpl);
+}
+#undef FUNC_NAME
+
SCM_DEFINE (scm_utime, "utime", 1, 2, 0,
(SCM pathname, SCM actime, SCM modtime),
- "@code{utime} sets the access and modification times for\n"
- "the file named by @var{path}. If @var{actime} or @var{modtime}\n"
- "is not supplied, then the current time is used.\n"
- "@var{actime} and @var{modtime}\n"
- "must be integer time values as returned by the @code{current-time}\n"
- "procedure.\n\n"
- "E.g.,\n\n"
- "@smalllisp\n"
+ "@code{utime} sets the access and modification times for the\n"
+ "file named by @var{path}. If @var{actime} or @var{modtime} is\n"
+ "not supplied, then the current time is used. @var{actime} and\n"
+ "@var{modtime} must be integer time values as returned by the\n"
+ "@code{current-time} procedure.\n"
+ "@lisp\n"
"(utime \"foo\" (- (current-time) 3600))\n"
- "@end smalllisp\n\n"
- "will set the access time to one hour in the past and the modification\n"
- "time to the current time.")
+ "@end lisp\n"
+ "will set the access time to one hour in the past and the\n"
+ "modification time to the current time.")
#define FUNC_NAME s_scm_utime
{
int rv;
struct utimbuf utm_tmp;
- SCM_VALIDATE_ROSTRING (1,pathname);
- SCM_COERCE_SUBSTR (pathname);
+ SCM_VALIDATE_STRING (1, pathname);
if (SCM_UNBNDP (actime))
SCM_SYSCALL (time (&utm_tmp.actime));
else
- utm_tmp.actime = SCM_NUM2ULONG (2,actime);
+ utm_tmp.actime = SCM_NUM2ULONG (2, actime);
if (SCM_UNBNDP (modtime))
SCM_SYSCALL (time (&utm_tmp.modtime));
else
- utm_tmp.modtime = SCM_NUM2ULONG (3,modtime);
+ utm_tmp.modtime = SCM_NUM2ULONG (3, modtime);
- SCM_SYSCALL (rv = utime (SCM_ROCHARS (pathname), &utm_tmp));
+ SCM_SYSCALL (rv = utime (SCM_STRING_CHARS (pathname), &utm_tmp));
if (rv != 0)
SCM_SYSERROR;
return SCM_UNSPECIFIED;
SCM_DEFINE (scm_access, "access?", 2, 0, 0,
(SCM path, SCM how),
- "Returns @code{#t} if @var{path} corresponds to an existing\n"
- "file and the current process\n"
- "has the type of access specified by @var{how}, otherwise \n"
- "@code{#f}.\n"
- "@var{how} should be specified\n"
- "using the values of the variables listed below. Multiple values can\n"
- "be combined using a bitwise or, in which case @code{#t} will only\n"
- "be returned if all accesses are granted.\n\n"
- "Permissions are checked using the real id of the current process,\n"
- "not the effective id, although it's the effective id which determines\n"
- "whether the access would actually be granted.\n\n"
+ "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"
+ "\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"
+ "\n"
"@defvar R_OK\n"
"test for read permission.\n"
"@end defvar\n"
{
int rv;
- SCM_VALIDATE_ROSTRING (1,path);
- if (SCM_SUBSTRP (path))
- path = scm_makfromstr (SCM_ROCHARS (path), SCM_ROLENGTH (path), 0);
- SCM_VALIDATE_INUM (2,how);
- rv = access (SCM_ROCHARS (path), SCM_INUM (how));
+ SCM_VALIDATE_STRING (1, path);
+ SCM_VALIDATE_INUM (2, how);
+ rv = access (SCM_STRING_CHARS (path), SCM_INUM (how));
return SCM_NEGATE_BOOL(rv);
}
#undef FUNC_NAME
SCM_DEFINE (scm_getpid, "getpid", 0, 0, 0,
(),
- "Returns an integer representing the current process ID.")
+ "Return an integer representing the current process ID.")
#define FUNC_NAME s_scm_getpid
{
return SCM_MAKINUM ((unsigned long) getpid ());
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_ROCHARS (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)
+ {
+ /* 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
+ {
+ /* 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;
+ }
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
#ifdef HAVE_SETLOCALE
SCM_DEFINE (scm_setlocale, "setlocale", 1, 1, 0,
(SCM category, SCM locale),
- "If @var{locale} is omitted, returns the current value of the specified\n"
- "locale category \n"
- "as a system-dependent string.\n"
- "@var{category} should be specified using the values @code{LC_COLLATE},\n"
- "@code{LC_ALL} etc.\n\n"
- "Otherwise the specified locale category is set to\n"
- "the string @var{locale}\n"
- "and the new value is returned as a system-dependent string. If @var{locale}\n"
- "is an empty string, the locale will be set using envirionment variables.")
+ "If @var{locale} is omitted, return the current value of the\n"
+ "specified locale category as a system-dependent string.\n"
+ "@var{category} should be specified using the values\n"
+ "@code{LC_COLLATE}, @code{LC_ALL} etc.\n"
+ "\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 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;
}
else
{
- SCM_VALIDATE_ROSTRING (2,locale);
- SCM_COERCE_SUBSTR (locale);
- clocale = SCM_ROCHARS (locale);
+ SCM_VALIDATE_STRING (2, locale);
+ clocale = SCM_STRING_CHARS (locale);
}
rv = setlocale (SCM_INUM (category), clocale);
"to. Its exact interpretation depends on the kind of special file\n"
"being created.\n\n"
"E.g.,\n"
- "@example\n"
+ "@lisp\n"
"(mknod \"/dev/fd0\" 'block-special #o660 (+ (* 2 256) 2))\n"
- "@end example\n\n"
+ "@end lisp\n\n"
"The return value is unspecified.")
#define FUNC_NAME s_scm_mknod
{
char *p;
int ctype = 0;
- SCM_VALIDATE_ROSTRING (1,path);
- SCM_VALIDATE_SYMBOL (2,type);
- SCM_VALIDATE_INUM (3,perms);
- SCM_VALIDATE_INUM (4,dev);
- SCM_COERCE_SUBSTR (path);
+ SCM_VALIDATE_STRING (1, path);
+ 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_ROCHARS(path), ctype | SCM_INUM (perms),
- SCM_INUM (dev)));
+ SCM_SYSCALL (val = mknod (SCM_STRING_CHARS (path), ctype | SCM_INUM (perms),
+ SCM_INUM (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);
+ SCM_VALIDATE_INUM (1, incr);
if (nice(SCM_INUM(incr)) != 0)
SCM_SYSERROR;
return SCM_UNSPECIFIED;
#undef FUNC_NAME
#endif /* HAVE_SYNC */
+#if HAVE_LIBCRYPT && HAVE_CRYPT_H
+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.")
+#define FUNC_NAME s_scm_crypt
+{
+ char * p;
+
+ SCM_VALIDATE_STRING (1, key);
+ SCM_VALIDATE_STRING (2, salt);
+
+ p = crypt (SCM_STRING_CHARS (key), SCM_STRING_CHARS (salt));
+ return scm_makfrom0str (p);
+}
+#undef FUNC_NAME
+#endif /* HAVE_LIBCRYPT && HAVE_CRYPT_H */
+
+#if HAVE_CHROOT
+SCM_DEFINE (scm_chroot, "chroot", 1, 0, 0,
+ (SCM path),
+ "Change the root directory to that specified in @var{path}.\n"
+ "This directory will be used for path names beginning with\n"
+ "@file{/}. The root directory is inherited by all children\n"
+ "of the current process. Only the superuser may change the\n"
+ "root directory.")
+#define FUNC_NAME s_scm_chroot
+{
+ SCM_VALIDATE_STRING (1, path);
+
+ if (chroot (SCM_STRING_CHARS (path)) == -1)
+ SCM_SYSERROR;
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+#endif /* HAVE_CHROOT */
+
+
+#ifdef __MINGW32__
+/* Wrapper function to supplying `getlogin()' under Windows. */
+static char * getlogin (void)
+{
+ static char user[256];
+ static unsigned long len = 256;
+
+ if (!GetUserName (user, &len))
+ return NULL;
+ return user;
+}
+#endif /* __MINGW32__ */
+
+
+#if defined (HAVE_GETLOGIN) || defined (__MINGW32__)
+SCM_DEFINE (scm_getlogin, "getlogin", 0, 0, 0,
+ (void),
+ "Return a string containing the name of the user logged in on\n"
+ "the controlling terminal of the process, or @code{#f} if this\n"
+ "information cannot be obtained.")
+#define FUNC_NAME s_scm_getlogin
+{
+ char * p;
+
+ p = getlogin ();
+ if (!p || !*p)
+ return SCM_BOOL_F;
+ return scm_makfrom0str (p);
+}
+#undef FUNC_NAME
+#endif /* HAVE_GETLOGIN */
+
+#if HAVE_CUSERID
+SCM_DEFINE (scm_cuserid, "cuserid", 0, 0, 0,
+ (void),
+ "Return a string containing a user name associated with the\n"
+ "effective user id of the process. Return @code{#f} if this\n"
+ "information cannot be obtained.")
+#define FUNC_NAME s_scm_cuserid
+{
+ char * p;
+
+ p = cuserid (NULL);
+ if (!p || !*p)
+ return SCM_BOOL_F;
+ return scm_makfrom0str (p);
+}
+#undef FUNC_NAME
+#endif /* HAVE_CUSERID */
+
+#if HAVE_GETPRIORITY
+SCM_DEFINE (scm_getpriority, "getpriority", 2, 0, 0,
+ (SCM which, SCM who),
+ "Return the scheduling priority of the process, process group\n"
+ "or user, as indicated by @var{which} and @var{who}. @var{which}\n"
+ "is one of the variables @code{PRIO_PROCESS}, @code{PRIO_PGRP}\n"
+ "or @code{PRIO_USER}, and @var{who} is interpreted relative to\n"
+ "@var{which} (a process identifier for @code{PRIO_PROCESS},\n"
+ "process group identifier for @code{PRIO_PGRP}, and a user\n"
+ "identifier for @code{PRIO_USER}. A zero value of @var{who}\n"
+ "denotes the current process, process group, or user. Return\n"
+ "the highest priority (lowest numerical value) of any of the\n"
+ "specified processes.")
+#define FUNC_NAME s_scm_getpriority
+{
+ int cwhich, cwho, ret;
+
+ SCM_VALIDATE_INUM_COPY (1, which, cwhich);
+ SCM_VALIDATE_INUM_COPY (2, who, cwho);
+
+ /* We have to clear errno and examine it later, because -1 is a
+ legal return value for getpriority(). */
+ errno = 0;
+ ret = getpriority (cwhich, cwho);
+ if (errno != 0)
+ SCM_SYSERROR;
+ return SCM_MAKINUM (ret);
+}
+#undef FUNC_NAME
+#endif /* HAVE_GETPRIORITY */
+
+#if HAVE_SETPRIORITY
+SCM_DEFINE (scm_setpriority, "setpriority", 3, 0, 0,
+ (SCM which, SCM who, SCM prio),
+ "Set the scheduling priority of the process, process group\n"
+ "or user, as indicated by @var{which} and @var{who}. @var{which}\n"
+ "is one of the variables @code{PRIO_PROCESS}, @code{PRIO_PGRP}\n"
+ "or @code{PRIO_USER}, and @var{who} is interpreted relative to\n"
+ "@var{which} (a process identifier for @code{PRIO_PROCESS},\n"
+ "process group identifier for @code{PRIO_PGRP}, and a user\n"
+ "identifier for @code{PRIO_USER}. A zero value of @var{who}\n"
+ "denotes the current process, process group, or user.\n"
+ "@var{prio} is a value in the range -20 and 20, the default\n"
+ "priority is 0; lower priorities cause more favorable\n"
+ "scheduling. Sets the priority of all of the specified\n"
+ "processes. Only the super-user may lower priorities.\n"
+ "The return value is not specified.")
+#define FUNC_NAME s_scm_setpriority
+{
+ 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);
+
+ if (setpriority (cwhich, cwho, cprio) == -1)
+ SCM_SYSERROR;
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+#endif /* HAVE_SETPRIORITY */
+
+#if HAVE_GETPASS
+SCM_DEFINE (scm_getpass, "getpass", 1, 0, 0,
+ (SCM prompt),
+ "Display @var{prompt} to the standard error output and read\n"
+ "a password from @file{/dev/tty}. If this file is not\n"
+ "accessible, it reads from standard input. The password may be\n"
+ "up to 127 characters in length. Additional characters and the\n"
+ "terminating newline character are discarded. While reading\n"
+ "the password, echoing and the generation of signals by special\n"
+ "characters is disabled.")
+#define FUNC_NAME s_scm_getpass
+{
+ char * p;
+ SCM passwd;
+
+ SCM_VALIDATE_STRING (1, prompt);
+
+ p = getpass(SCM_STRING_CHARS (prompt));
+ passwd = scm_makfrom0str (p);
+
+ /* Clear out the password in the static buffer. */
+ memset (p, 0, strlen (p));
+
+ return passwd;
+}
+#undef FUNC_NAME
+#endif /* HAVE_GETPASS */
+
+/* Wrapper function for flock() support under M$-Windows. */
+#ifdef __MINGW32__
+# include <io.h>
+# include <sys/locking.h>
+# include <errno.h>
+# ifndef _LK_UNLCK
+ /* Current MinGW package fails to define this. *sigh* */
+# define _LK_UNLCK 0
+# endif
+# define LOCK_EX 1
+# define LOCK_UN 2
+# define LOCK_SH 4
+# define LOCK_NB 8
+
+static int flock (int fd, int operation)
+{
+ long pos, len;
+ int ret, err;
+
+ /* Disable invalid arguments. */
+ if (((operation & (LOCK_EX | LOCK_SH)) == (LOCK_EX | LOCK_SH)) ||
+ ((operation & (LOCK_EX | LOCK_UN)) == (LOCK_EX | LOCK_UN)) ||
+ ((operation & (LOCK_SH | LOCK_UN)) == (LOCK_SH | LOCK_UN)))
+ {
+ errno = EINVAL;
+ return -1;
+ }
+
+ /* Determine mode of operation and discard unsupported ones. */
+ if (operation == (LOCK_NB | LOCK_EX))
+ operation = _LK_NBLCK;
+ else if (operation & LOCK_UN)
+ operation = _LK_UNLCK;
+ else if (operation == LOCK_EX)
+ operation = _LK_LOCK;
+ else
+ {
+ errno = EINVAL;
+ return -1;
+ }
+
+ /* Save current file pointer and seek to beginning. */
+ if ((pos = lseek (fd, 0, SEEK_CUR)) == -1 || (len = filelength (fd)) == -1)
+ return -1;
+ lseek (fd, 0L, SEEK_SET);
+
+ /* Deadlock if necessary. */
+ do
+ {
+ ret = _locking (fd, operation, len);
+ }
+ while (ret == -1 && errno == EDEADLOCK);
+
+ /* Produce meaningful error message. */
+ if (errno == EACCES && operation == _LK_NBLCK)
+ err = EDEADLOCK;
+ else
+ err = errno;
+
+ /* Return to saved file position pointer. */
+ lseek (fd, pos, SEEK_SET);
+ errno = err;
+ return ret;
+}
+#endif /* __MINGW32__ */
+
+#if HAVE_FLOCK || defined (__MINGW32__)
+SCM_DEFINE (scm_flock, "flock", 2, 0, 0,
+ (SCM file, SCM operation),
+ "Apply or remove an advisory lock on an open file.\n"
+ "@var{operation} specifies the action to be done:\n"
+ "@table @code\n"
+ "@item 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"
+ "Exclusive lock. Only one process may hold an exclusive lock\n"
+ "for a given file at a given time.\n"
+ "@item 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"
+ "The return value is not specified. @var{file} may be an open\n"
+ "file descriptor or an open file descriptor port.")
+#define FUNC_NAME s_scm_flock
+{
+ int coperation, fdes;
+
+ if (SCM_INUMP (file))
+ fdes = SCM_INUM (file);
+ else
+ {
+ SCM_VALIDATE_OPFPORT (2, file);
+
+ fdes = SCM_FPORT_FDES (file);
+ }
+ SCM_VALIDATE_INUM_COPY (2, operation, coperation);
+ if (flock (fdes, coperation) == -1)
+ SCM_SYSERROR;
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+#endif /* HAVE_FLOCK */
+
+#if HAVE_SETHOSTNAME
+SCM_DEFINE (scm_sethostname, "sethostname", 1, 0, 0,
+ (SCM name),
+ "Set the host name of the current processor to @var{name}. May\n"
+ "only be used by the superuser. The return value is not\n"
+ "specified.")
+#define FUNC_NAME s_scm_sethostname
+{
+ SCM_VALIDATE_STRING (1, name);
+
+ if (sethostname (SCM_STRING_CHARS (name), SCM_STRING_LENGTH (name)) == -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_malloc (len);
+ SCM name;
+
+ res = gethostname (p, len);
+ while (res == -1 && errno == ENAMETOOLONG)
+ {
+ p = scm_realloc (p, len * 2);
+ len *= 2;
+ res = gethostname (p, len);
+ }
+ if (res == -1)
+ {
+ free (p);
+ SCM_SYSERROR;
+ }
+ name = scm_makfrom0str (p);
+ free (p);
+ return name;
+}
+#undef FUNC_NAME
+#endif /* HAVE_GETHOSTNAME */
+
void
scm_init_posix ()
{
scm_add_feature ("EIDs");
#endif
#ifdef WAIT_ANY
- scm_sysintern ("WAIT_ANY", SCM_MAKINUM (WAIT_ANY));
+ scm_c_define ("WAIT_ANY", SCM_MAKINUM (WAIT_ANY));
#endif
#ifdef WAIT_MYPGRP
- scm_sysintern ("WAIT_MYPGRP", SCM_MAKINUM (WAIT_MYPGRP));
+ scm_c_define ("WAIT_MYPGRP", SCM_MAKINUM (WAIT_MYPGRP));
#endif
#ifdef WNOHANG
- scm_sysintern ("WNOHANG", SCM_MAKINUM (WNOHANG));
+ scm_c_define ("WNOHANG", SCM_MAKINUM (WNOHANG));
#endif
#ifdef WUNTRACED
- scm_sysintern ("WUNTRACED", SCM_MAKINUM (WUNTRACED));
+ scm_c_define ("WUNTRACED", SCM_MAKINUM (WUNTRACED));
#endif
/* access() symbols. */
- scm_sysintern ("R_OK", SCM_MAKINUM (R_OK));
- scm_sysintern ("W_OK", SCM_MAKINUM (W_OK));
- scm_sysintern ("X_OK", SCM_MAKINUM (X_OK));
- scm_sysintern ("F_OK", SCM_MAKINUM (F_OK));
+ 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));
#ifdef LC_COLLATE
- scm_sysintern ("LC_COLLATE", SCM_MAKINUM (LC_COLLATE));
+ scm_c_define ("LC_COLLATE", SCM_MAKINUM (LC_COLLATE));
#endif
#ifdef LC_CTYPE
- scm_sysintern ("LC_CTYPE", SCM_MAKINUM (LC_CTYPE));
+ scm_c_define ("LC_CTYPE", SCM_MAKINUM (LC_CTYPE));
#endif
#ifdef LC_MONETARY
- scm_sysintern ("LC_MONETARY", SCM_MAKINUM (LC_MONETARY));
+ scm_c_define ("LC_MONETARY", SCM_MAKINUM (LC_MONETARY));
#endif
#ifdef LC_NUMERIC
- scm_sysintern ("LC_NUMERIC", SCM_MAKINUM (LC_NUMERIC));
+ scm_c_define ("LC_NUMERIC", SCM_MAKINUM (LC_NUMERIC));
#endif
#ifdef LC_TIME
- scm_sysintern ("LC_TIME", SCM_MAKINUM (LC_TIME));
+ scm_c_define ("LC_TIME", SCM_MAKINUM (LC_TIME));
#endif
#ifdef LC_MESSAGES
- scm_sysintern ("LC_MESSAGES", SCM_MAKINUM (LC_MESSAGES));
+ scm_c_define ("LC_MESSAGES", SCM_MAKINUM (LC_MESSAGES));
#endif
#ifdef LC_ALL
- scm_sysintern ("LC_ALL", SCM_MAKINUM (LC_ALL));
+ scm_c_define ("LC_ALL", SCM_MAKINUM (LC_ALL));
#endif
#ifdef PIPE_BUF
-scm_sysintern ("PIPE_BUF", scm_long2num (PIPE_BUF));
+ scm_c_define ("PIPE_BUF", scm_long2num (PIPE_BUF));
+#endif
+
+#ifdef PRIO_PROCESS
+ scm_c_define ("PRIO_PROCESS", SCM_MAKINUM (PRIO_PROCESS));
+#endif
+#ifdef PRIO_PGRP
+ scm_c_define ("PRIO_PGRP", SCM_MAKINUM (PRIO_PGRP));
+#endif
+#ifdef PRIO_USER
+ scm_c_define ("PRIO_USER", SCM_MAKINUM (PRIO_USER));
+#endif
+
+#ifdef LOCK_SH
+ scm_c_define ("LOCK_SH", SCM_MAKINUM (LOCK_SH));
+#endif
+#ifdef LOCK_EX
+ scm_c_define ("LOCK_EX", SCM_MAKINUM (LOCK_EX));
+#endif
+#ifdef LOCK_UN
+ scm_c_define ("LOCK_UN", SCM_MAKINUM (LOCK_UN));
+#endif
+#ifdef LOCK_NB
+ scm_c_define ("LOCK_NB", SCM_MAKINUM (LOCK_NB));
#endif
#include "libguile/cpp_sig_symbols.c"