X-Git-Url: https://git.hcoop.net/bpt/guile.git/blobdiff_plain/34f0f2b8af3585c4057cf076739151accde02147..1e498fbd0fffc1b9434ef0f5b1de75491a91883e:/libguile/posix.c diff --git a/libguile/posix.c b/libguile/posix.c index a8e88fc31..4ae59a746 100644 --- a/libguile/posix.c +++ b/libguile/posix.c @@ -1,56 +1,39 @@ -/* 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 - * 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 exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. + * 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 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 + */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ +#if HAVE_CONFIG_H +# include +#endif + +/* Make GNU/Linux libc declare everything it has. */ +#define _GNU_SOURCE #include +#include + #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" @@ -86,7 +69,21 @@ extern char *ttyname(); #include #include +#ifdef HAVE_PWD_H #include +#endif +#ifdef HAVE_IO_H +#include +#endif +#ifdef HAVE_WINSOCK2_H +#include +#endif + +#ifdef __MINGW32__ +/* Some defines for Windows here. */ +# include +# define pipe(fd) _pipe (fd, 256, O_BINARY) +#endif /* __MINGW32__ */ #if HAVE_SYS_WAIT_H # include @@ -100,33 +97,31 @@ extern char *ttyname(); #include -extern FILE *popen (); extern char ** environ; +#ifdef HAVE_GRP_H #include +#endif +#ifdef HAVE_SYS_UTSNAME_H #include - -#if HAVE_DIRENT_H -# include -# define NAMLEN(dirent) strlen((dirent)->d_name) -#else -# define dirent direct -# define NAMLEN(dirent) (dirent)->d_namlen -# if HAVE_SYS_NDIR_H -# include -# endif -# if HAVE_SYS_DIR_H -# include -# endif -# if HAVE_NDIR_H -# include -# endif #endif #ifdef HAVE_SETLOCALE #include #endif +#if HAVE_LIBCRYPT && HAVE_CRYPT_H +# include +#endif + +#if HAVE_SYS_RESOURCE_H +# include +#endif + +#if HAVE_SYS_FILE_H +# include +#endif + /* Some Unix systems don't define these. CPP hair is dangerous, but this seems safe enough... */ #ifndef R_OK @@ -170,19 +165,19 @@ SCM_SYMBOL (sym_write_pipe, "write pipe"); 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; @@ -202,12 +197,13 @@ SCM_DEFINE (scm_pipe, "pipe", 0, 0, 0, #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 ans; + SCM result; int ngroups; - scm_sizet size; + size_t size; GETGROUPS_T *groups; ngroups = getgroups (0, NULL); @@ -215,22 +211,24 @@ SCM_DEFINE (scm_getgroups, "getgroups", 0, 0, 0, SCM_SYSERROR; size = ngroups * sizeof (GETGROUPS_T); - groups = scm_must_malloc (size, FUNC_NAME); + groups = scm_malloc (size); getgroups (ngroups, groups); - ans = scm_make_vector (SCM_MAKINUM (ngroups), SCM_UNDEFINED); - while (--ngroups >= 0) - SCM_VELTS (ans) [ngroups] = SCM_MAKINUM (groups [ngroups]); - - scm_must_free (groups); - scm_done_free (size); + result = scm_c_make_vector (ngroups, SCM_UNDEFINED); - 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 - +#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" @@ -238,12 +236,9 @@ SCM_DEFINE (scm_getpwuid, "getpw", 0, 1, 0, "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 result = scm_c_make_vector (7, SCM_UNSPECIFIED); if (SCM_UNBNDP (user) || SCM_FALSEP (user)) { SCM_SYSCALL (entry = getpwent ()); @@ -259,28 +254,28 @@ SCM_DEFINE (scm_getpwuid, "getpw", 0, 1, 0, else { SCM_VALIDATE_STRING (1, user); - SCM_STRING_COERCE_0TERMINATION_X (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(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 +#endif /* HAVE_GETPWENT */ #ifdef HAVE_SETPWENT @@ -301,7 +296,7 @@ SCM_DEFINE (scm_setpwent, "setpw", 0, 1, 0, #endif - +#ifdef HAVE_GETGRENT /* Combines getgrgid and getgrnam. */ SCM_DEFINE (scm_getgrgid, "getgr", 0, 1, 0, (SCM name), @@ -310,11 +305,9 @@ SCM_DEFINE (scm_getgrgid, "getgr", 0, 1, 0, "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 result = scm_c_make_vector (4, SCM_UNSPECIFIED); + if (SCM_UNBNDP (name) || SCM_FALSEP (name)) { SCM_SYSCALL (entry = getgrent ()); @@ -328,16 +321,15 @@ SCM_DEFINE (scm_getgrgid, "getgr", 0, 1, 0, else { SCM_VALIDATE_STRING (1, name); - SCM_STRING_COERCE_0TERMINATION_X (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); + 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 @@ -358,7 +350,7 @@ SCM_DEFINE (scm_setgrent, "setgr", 0, 1, 0, return SCM_UNSPECIFIED; } #undef FUNC_NAME - +#endif /* HAVE_GETGRENT */ SCM_DEFINE (scm_kill, "kill", 2, 0, 0, @@ -387,11 +379,16 @@ 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 @@ -438,12 +435,12 @@ SCM_DEFINE (scm_waitpid, "waitpid", 1, 1, 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); } @@ -455,16 +452,17 @@ SCM_DEFINE (scm_waitpid, "waitpid", 1, 1, 0, #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. */ @@ -478,13 +476,13 @@ SCM_DEFINE (scm_status_exit_val, "status:exit-val", 1, 0, 0, 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)) @@ -496,13 +494,13 @@ SCM_DEFINE (scm_status_term_sig, "status:term-sig", 1, 0, 0, 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)) @@ -511,21 +509,25 @@ SCM_DEFINE (scm_status_stop_sig, "status:stop-sig", 1, 0, 0, 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 ()); @@ -536,7 +538,7 @@ SCM_DEFINE (scm_getuid, "getuid", 0, 0, 0, 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 ()); @@ -547,10 +549,10 @@ SCM_DEFINE (scm_getgid, "getgid", 0, 0, 0, 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{(provided? 'EIDs)} reports whether the\n" + "system supports effective IDs.") #define FUNC_NAME s_scm_geteuid { #ifdef HAVE_GETEUID @@ -562,13 +564,12 @@ SCM_DEFINE (scm_geteuid, "geteuid", 0, 0, 0, #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{(provided? 'EIDs)} reports whether the\n" + "system supports effective IDs.") #define FUNC_NAME s_scm_getegid { #ifdef HAVE_GETEUID @@ -587,7 +588,7 @@ SCM_DEFINE (scm_setuid, "setuid", 1, 0, 0, "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; @@ -601,7 +602,7 @@ SCM_DEFINE (scm_setgid, "setgid", 1, 0, 0, "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; @@ -612,14 +613,14 @@ SCM_DEFINE (scm_seteuid, "seteuid", 1, 0, 0, (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 @@ -630,20 +631,22 @@ SCM_DEFINE (scm_seteuid, "seteuid", 1, 0, 0, return SCM_UNSPECIFIED; } #undef FUNC_NAME +#endif /* __MINGW32__ */ + #ifdef HAVE_SETEGID SCM_DEFINE (scm_setegid, "setegid", 1, 0, 0, (SCM id), "Sets the effective group ID to the integer @var{id}, provided the process\n" "has appropriate privileges. If effective IDs are not supported, the\n" - "real ID is set instead -- @code{(feature? 'EIDs)} reports whether the\n" + "real ID is set instead -- @code{(provided? 'EIDs)} reports whether the\n" "system supports effective IDs.\n" "The return value is unspecified.") #define FUNC_NAME s_scm_setegid { int rv; - SCM_VALIDATE_INUM (1,id); + SCM_VALIDATE_INUM (1, id); #ifdef HAVE_SETEUID rv = setegid (SCM_INUM (id)); #else @@ -657,9 +660,11 @@ SCM_DEFINE (scm_setegid, "setegid", 1, 0, 0, #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 { @@ -668,6 +673,8 @@ SCM_DEFINE (scm_getpgrp, "getpgrp", 0, 0, 0, return SCM_MAKINUM (fn (0)); } #undef FUNC_NAME +#endif /* HAVE_GETPGRP */ + #ifdef HAVE_SETPGID SCM_DEFINE (scm_setpgid, "setpgid", 2, 0, 0, @@ -679,8 +686,8 @@ 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; @@ -706,33 +713,35 @@ SCM_DEFINE (scm_setsid, "setsid", 0, 0, 0, #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; + char *result; 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)); - 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 */ #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); @@ -746,9 +755,10 @@ SCM_DEFINE (scm_ctermid, "ctermid", 0, 0, 0, #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" @@ -762,7 +772,7 @@ SCM_DEFINE (scm_tcgetpgrp, "tcgetpgrp", 1, 0, 0, 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; @@ -785,8 +795,8 @@ SCM_DEFINE (scm_tcsetpgrp, "tcsetpgrp", 2, 0, 0, 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; @@ -795,46 +805,41 @@ SCM_DEFINE (scm_tcsetpgrp, "tcsetpgrp", 2, 0, 0, #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); - scm_sizet 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" @@ -843,8 +848,7 @@ SCM_DEFINE (scm_execl, "execl", 1, 0, 1, { char **execargv; SCM_VALIDATE_STRING (1, filename); - SCM_STRING_COERCE_0TERMINATION_X (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. */ @@ -864,8 +868,7 @@ SCM_DEFINE (scm_execlp, "execlp", 1, 0, 1, { char **execargv; SCM_VALIDATE_STRING (1, filename); - SCM_STRING_COERCE_0TERMINATION_X (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. */ @@ -882,10 +885,10 @@ environ_list_to_c (SCM envlist, int arg, const char *proc) 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; @@ -894,7 +897,7 @@ environ_list_to_c (SCM envlist, int arg, const char *proc) 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); @@ -917,9 +920,8 @@ SCM_DEFINE (scm_execle, "execle", 2, 0, 1, char **exec_env; SCM_VALIDATE_STRING (1, filename); - SCM_STRING_COERCE_0TERMINATION_X (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; @@ -928,6 +930,7 @@ SCM_DEFINE (scm_execle, "execle", 2, 0, 1, } #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" @@ -944,41 +947,46 @@ SCM_DEFINE (scm_fork, "primitive-fork", 0, 0, 0, return SCM_MAKINUM (0L+pid); } #undef FUNC_NAME +#endif /* HAVE_FORK */ -#ifdef HAVE_UNAME +#ifdef __MINGW32__ +# include "win32-uname.h" +#endif + +#if defined (HAVE_UNAME) || defined (__MINGW32__) SCM_DEFINE (scm_uname, "uname", 0, 0, 0, (), - "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 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 */ 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)) @@ -1012,49 +1020,77 @@ SCM_DEFINE (scm_environ, "environ", 0, 1, 0, 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_STRING (1, pathname); - SCM_STRING_COERCE_0TERMINATION_X (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_STRING_CHARS (pathname), &utm_tmp)); if (rv != 0) @@ -1065,17 +1101,17 @@ SCM_DEFINE (scm_utime, "utime", 1, 2, 0, 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" @@ -1093,7 +1129,6 @@ SCM_DEFINE (scm_access, "access?", 2, 0, 0, int rv; SCM_VALIDATE_STRING (1, path); - SCM_STRING_COERCE_0TERMINATION_X (path); SCM_VALIDATE_INUM (2, how); rv = access (SCM_STRING_CHARS (path), SCM_INUM (how)); return SCM_NEGATE_BOOL(rv); @@ -1102,7 +1137,7 @@ SCM_DEFINE (scm_access, "access?", 2, 0, 0, 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 ()); @@ -1126,15 +1161,38 @@ SCM_DEFINE (scm_putenv, "putenv", 1, 0, 0, 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 @@ -1142,21 +1200,21 @@ SCM_DEFINE (scm_putenv, "putenv", 1, 0, 0, #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; @@ -1164,7 +1222,6 @@ SCM_DEFINE (scm_setlocale, "setlocale", 1, 1, 0, else { SCM_VALIDATE_STRING (2, locale); - SCM_STRING_COERCE_0TERMINATION_X (locale); clocale = SCM_STRING_CHARS (locale); } @@ -1188,9 +1245,9 @@ SCM_DEFINE (scm_mknod, "mknod", 4, 0, 0, "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 { @@ -1199,10 +1256,9 @@ SCM_DEFINE (scm_mknod, "mknod", 4, 0, 0, int ctype = 0; SCM_VALIDATE_STRING (1, path); - SCM_VALIDATE_SYMBOL (2,type); - SCM_VALIDATE_INUM (3,perms); - SCM_VALIDATE_INUM (4,dev); - SCM_STRING_COERCE_0TERMINATION_X (path); + SCM_VALIDATE_SYMBOL (2, type); + SCM_VALIDATE_INUM (3, perms); + SCM_VALIDATE_INUM (4, dev); p = SCM_SYMBOL_CHARS (type); if (strcmp (p, "regular") == 0) @@ -1222,7 +1278,7 @@ SCM_DEFINE (scm_mknod, "mknod", 4, 0, 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))); @@ -1241,7 +1297,7 @@ SCM_DEFINE (scm_nice, "nice", 1, 0, 0, "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; @@ -1262,6 +1318,338 @@ SCM_DEFINE (scm_sync, "sync", 0, 0, 0, #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 +# include +# include +# 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 () { @@ -1270,53 +1658,74 @@ 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" -#ifndef SCM_MAGIC_SNARFER #include "libguile/posix.x" -#endif } /*