diff options
Diffstat (limited to 'libguile/posix.c')
-rw-r--r-- | libguile/posix.c | 1461 |
1 files changed, 0 insertions, 1461 deletions
diff --git a/libguile/posix.c b/libguile/posix.c deleted file mode 100644 index ebdbf202c..000000000 --- a/libguile/posix.c +++ /dev/null @@ -1,1461 +0,0 @@ -/* Copyright (C) 1995, 1996 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, 675 Mass Ave, Cambridge, MA 02139, 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 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. - * - * 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. - */ - - -#include <stdio.h> -#include "_scm.h" -#include "fports.h" -#include "genio.h" -#include "scmsigs.h" -#include "read.h" -#include "unif.h" -#include "feature.h" -#include "sequences.h" - -#include "posix.h" - - -#ifdef HAVE_STRING_H -#include <string.h> -#endif -#ifdef TIME_WITH_SYS_TIME -# include <sys/time.h> -# include <time.h> -#else -# if HAVE_SYS_TIME_H -# include <sys/time.h> -# else -# include <time.h> -# endif -#endif - -#ifdef HAVE_UNISTD_H -#include <unistd.h> -#else -#ifndef ttyname -extern char *ttyname(); -#endif -#endif - -#ifdef LIBC_H_WITH_UNISTD_H -#include <libc.h> -#endif - -#ifdef HAVE_SYS_SELECT_H -#include <sys/select.h> -#endif - -#include <sys/types.h> -#include <sys/stat.h> -#include <fcntl.h> - -#include <pwd.h> - -#if HAVE_SYS_WAIT_H -# include <sys/wait.h> -#endif -#ifndef WEXITSTATUS -# define WEXITSTATUS(stat_val) ((unsigned)(stat_val) >> 8) -#endif -#ifndef WIFEXITED -# define WIFEXITED(stat_val) (((stat_val) & 255) == 0) -#endif - -#include <signal.h> - -#ifdef FD_SET - -#define SELECT_TYPE fd_set -#define SELECT_SET_SIZE FD_SETSIZE - -#else /* no FD_SET */ - -/* Define the macros to access a single-int bitmap of descriptors. */ -#define SELECT_SET_SIZE 32 -#define SELECT_TYPE int -#define FD_SET(n, p) (*(p) |= (1 << (n))) -#define FD_CLR(n, p) (*(p) &= ~(1 << (n))) -#define FD_ISSET(n, p) (*(p) & (1 << (n))) -#define FD_ZERO(p) (*(p) = 0) - -#endif /* no FD_SET */ - -extern FILE *popen (); -extern char ** environ; - -#include <grp.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 - -char *strptime (); - -#ifdef HAVE_SETLOCALE -#include <locale.h> -#endif - -/* Some Unix systems don't define these. CPP hair is dangerous, but - this seems safe enough... */ -#ifndef R_OK -#define R_OK 4 -#endif - -#ifndef W_OK -#define W_OK 2 -#endif - -#ifndef X_OK -#define X_OK 1 -#endif - -#ifndef F_OK -#define F_OK 0 -#endif - -/* On NextStep, <utime.h> doesn't define struct utime, unless we - #define _POSIX_SOURCE before #including it. I think this is less - of a kludge than defining struct utimbuf ourselves. */ -#ifdef UTIMBUF_NEEDS_POSIX -#define _POSIX_SOURCE -#endif - -#ifdef HAVE_SYS_UTIME_H -#include <sys/utime.h> -#endif - -#ifdef HAVE_UTIME_H -#include <utime.h> -#endif - -/* Please don't add any more #includes or #defines here. The hack - above means that _POSIX_SOURCE may be #defined, which will - encourage header files to do strange things. */ - - - - -SCM_PROC (s_pipe, "pipe", 0, 0, 0, scm_pipe); - -SCM -scm_pipe () -{ - int fd[2], rv; - FILE *f_rd, *f_wt; - SCM p_rd, p_wt; - struct scm_port_table * ptr; - struct scm_port_table * ptw; - - SCM_NEWCELL (p_rd); - SCM_NEWCELL (p_wt); - rv = pipe (fd); - if (rv) - scm_syserror (s_pipe); - f_rd = fdopen (fd[0], "r"); - if (!f_rd) - { - SCM_SYSCALL (close (fd[0])); - SCM_SYSCALL (close (fd[1])); - scm_syserror (s_pipe); - } - f_wt = fdopen (fd[1], "w"); - if (!f_wt) - { - int en; - en = errno; - fclose (f_rd); - SCM_SYSCALL (close (fd[1])); - errno = en; - scm_syserror (s_pipe); - } - ptr = scm_add_to_port_table (p_rd); - ptw = scm_add_to_port_table (p_wt); - SCM_SETPTAB_ENTRY (p_rd, ptr); - SCM_SETPTAB_ENTRY (p_wt, ptw); - SCM_SETCAR (p_rd, scm_tc16_fport | scm_mode_bits ("r")); - SCM_SETCAR (p_wt, scm_tc16_fport | scm_mode_bits ("w")); - SCM_SETSTREAM (p_rd, (SCM)f_rd); - SCM_SETSTREAM (p_wt, (SCM)f_wt); - - SCM_ALLOW_INTS; - return scm_cons (p_rd, p_wt); -} - - - -SCM_PROC (s_getgroups, "getgroups", 0, 0, 0, scm_getgroups); - -SCM -scm_getgroups() -{ - SCM grps, ans; - int ngroups = getgroups (0, NULL); - if (!ngroups) - scm_syserror (s_getgroups); - SCM_NEWCELL(grps); - SCM_DEFER_INTS; - { - GETGROUPS_T *groups; - int val; - - groups = (GETGROUPS_T *) scm_must_malloc(ngroups * sizeof(GETGROUPS_T), - s_getgroups); - val = getgroups(ngroups, groups); - if (val < 0) - { - scm_must_free((char *)groups); - scm_syserror (s_getgroups); - } - SCM_SETCHARS(grps, groups); /* set up grps as a GC protect */ - SCM_SETLENGTH(grps, 0L + ngroups * sizeof(GETGROUPS_T), scm_tc7_string); - SCM_ALLOW_INTS; - ans = scm_make_vector(SCM_MAKINUM(ngroups), SCM_UNDEFINED, SCM_BOOL_F); - while (--ngroups >= 0) SCM_VELTS(ans)[ngroups] = SCM_MAKINUM(groups[ngroups]); - SCM_SETCHARS(grps, groups); /* to make sure grps stays around. */ - return ans; - } -} - - - -SCM_PROC (s_getpwuid, "getpw", 0, 1, 0, scm_getpwuid); - -SCM -scm_getpwuid (user) - SCM user; -{ - SCM result; - struct passwd *entry; - SCM *ve; - - result = scm_make_vector (SCM_MAKINUM (7), SCM_UNSPECIFIED, SCM_BOOL_F); - ve = SCM_VELTS (result); - if (SCM_UNBNDP (user) || SCM_FALSEP (user)) - { - SCM_DEFER_INTS; - SCM_SYSCALL (entry = getpwent ()); - } - else if (SCM_INUMP (user)) - { - SCM_DEFER_INTS; - entry = getpwuid (SCM_INUM (user)); - } - else - { - SCM_ASSERT (SCM_NIMP (user) && SCM_ROSTRINGP (user), user, SCM_ARG1, s_getpwuid); - if (SCM_SUBSTRP (user)) - user = scm_makfromstr (SCM_ROCHARS (user), SCM_ROLENGTH (user), 0); - SCM_DEFER_INTS; - entry = getpwnam (SCM_ROCHARS (user)); - } - if (!entry) - scm_syserror (s_getpwuid); - - 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); - if (!entry->pw_dir) - ve[5] = scm_makfrom0str (""); - else - ve[5] = scm_makfrom0str (entry->pw_dir); - if (!entry->pw_shell) - ve[6] = scm_makfrom0str (""); - else - ve[6] = scm_makfrom0str (entry->pw_shell); - SCM_ALLOW_INTS; - return result; -} - - - -SCM_PROC (s_setpwent, "setpw", 0, 1, 0, scm_setpwent); - -SCM -scm_setpwent (arg) - SCM arg; -{ - if (SCM_UNBNDP (arg) || SCM_FALSEP (arg)) - endpwent (); - else - setpwent (); - return SCM_UNSPECIFIED; -} - - - -/* Combines getgrgid and getgrnam. */ -SCM_PROC (s_getgrgid, "getgr", 0, 1, 0, scm_getgrgid); - -SCM -scm_getgrgid (name) - SCM name; -{ - SCM result; - struct group *entry; - SCM *ve; - result = scm_make_vector (SCM_MAKINUM (4), SCM_UNSPECIFIED, SCM_BOOL_F); - ve = SCM_VELTS (result); - SCM_DEFER_INTS; - if (SCM_UNBNDP (name) || (name == SCM_BOOL_F)) - SCM_SYSCALL (entry = getgrent ()); - else if (SCM_INUMP (name)) - SCM_SYSCALL (entry = getgrgid (SCM_INUM (name))); - else - { - SCM_ASSERT (SCM_NIMP (name) && SCM_STRINGP (name), name, SCM_ARG1, s_getgrgid); - if (SCM_SUBSTRP (name)) - name = scm_makfromstr (SCM_ROCHARS (name), SCM_ROLENGTH (name), 0); - SCM_SYSCALL (entry = getgrnam (SCM_CHARS (name))); - } - if (!entry) - scm_syserror (s_getgrgid); - - 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_ALLOW_INTS; - return result; -} - - - -SCM_PROC (s_setgrent, "setgr", 0, 1, 0, scm_setgrent); - -SCM -scm_setgrent (arg) - SCM arg; -{ - if (SCM_UNBNDP (arg) || SCM_FALSEP (arg)) - endgrent (); - else - setgrent (); - return SCM_UNSPECIFIED; -} - - - -SCM_PROC (s_kill, "kill", 2, 0, 0, scm_kill); - -SCM -scm_kill (pid, sig) - SCM pid; - SCM sig; -{ - SCM_ASSERT (SCM_INUMP (pid), pid, SCM_ARG1, s_kill); - SCM_ASSERT (SCM_INUMP (sig), sig, SCM_ARG2, s_kill); - /* Signal values are interned in scm_init_posix(). */ - if (kill ((int) SCM_INUM (pid), (int) SCM_INUM (sig)) != 0) - scm_syserror (s_kill); - return SCM_UNSPECIFIED; -} - - - -SCM_PROC (s_waitpid, "waitpid", 1, 1, 0, scm_waitpid); - -SCM -scm_waitpid (pid, options) - SCM pid; - SCM options; -{ -#ifdef HAVE_WAITPID - int i; - int status; - int ioptions; - SCM_ASSERT (SCM_INUMP (pid), pid, SCM_ARG1, s_waitpid); - if (SCM_UNBNDP (options)) - ioptions = 0; - else - { - SCM_ASSERT (SCM_INUMP (options), options, SCM_ARG2, s_waitpid); - /* Flags are interned in scm_init_posix. */ - ioptions = SCM_INUM (options); - } - SCM_SYSCALL (i = waitpid (SCM_INUM (pid), &status, ioptions)); - if (i == -1) - scm_syserror (s_waitpid); - return scm_cons (SCM_MAKINUM (0L + i), SCM_MAKINUM (0L + status)); -#else - scm_sysmissing (s_waitpid); - /* not reached. */ - return SCM_BOOL_F; -#endif -} - - - -SCM_PROC (s_getppid, "getppid", 0, 0, 0, scm_getppid); - -SCM -scm_getppid () -{ - return SCM_MAKINUM (0L + getppid ()); -} - - - -SCM_PROC (s_getuid, "getuid", 0, 0, 0, scm_getuid); - -SCM -scm_getuid () -{ - return SCM_MAKINUM (0L + getuid ()); -} - - - -SCM_PROC (s_getgid, "getgid", 0, 0, 0, scm_getgid); - -SCM -scm_getgid () -{ - return SCM_MAKINUM (0L + getgid ()); -} - - - -SCM_PROC (s_geteuid, "geteuid", 0, 0, 0, scm_geteuid); - -SCM -scm_geteuid () -{ -#ifdef HAVE_GETEUID - return SCM_MAKINUM (0L + geteuid ()); -#else - return SCM_MAKINUM (0L + getuid ()); -#endif -} - - - -SCM_PROC (s_getegid, "getegid", 0, 0, 0, scm_getegid); - -SCM -scm_getegid () -{ -#ifdef HAVE_GETEUID - return SCM_MAKINUM (0L + getegid ()); -#else - return SCM_MAKINUM (0L + getgid ()); -#endif -} - - -SCM_PROC (s_setuid, "setuid", 1, 0, 0, scm_setuid); - -SCM -scm_setuid (id) - SCM id; -{ - SCM_ASSERT (SCM_INUMP (id), id, SCM_ARG1, s_setuid); - if (setuid (SCM_INUM (id)) != 0) - scm_syserror (s_setuid); - return SCM_UNSPECIFIED; -} - -SCM_PROC (s_setgid, "setgid", 1, 0, 0, scm_setgid); - -SCM -scm_setgid (id) - SCM id; -{ - SCM_ASSERT (SCM_INUMP (id), id, SCM_ARG1, s_setgid); - if (setgid (SCM_INUM (id)) != 0) - scm_syserror (s_setgid); - return SCM_UNSPECIFIED; -} - -SCM_PROC (s_seteuid, "seteuid", 1, 0, 0, scm_seteuid); - -SCM -scm_seteuid (id) - SCM id; -{ - int rv; - - SCM_ASSERT (SCM_INUMP (id), id, SCM_ARG1, s_seteuid); -#ifdef HAVE_SETEUID - rv = seteuid (SCM_INUM (id)); -#else - rv = setuid (SCM_INUM (id)); -#endif - if (rv != 0) - scm_syserror (s_seteuid); - return SCM_UNSPECIFIED; -} - -SCM_PROC (s_setegid, "setegid", 1, 0, 0, scm_setegid); - -SCM -scm_setegid (id) - SCM id; -{ - int rv; - - SCM_ASSERT (SCM_INUMP (id), id, SCM_ARG1, s_setegid); -#ifdef HAVE_SETEUID - rv = setegid (SCM_INUM (id)); -#else - rv = setgid (SCM_INUM (id)); -#endif - if (rv != 0) - scm_syserror (s_setegid); - return SCM_UNSPECIFIED; - -} - -SCM_PROC (s_getpgrp, "getpgrp", 0, 0, 0, scm_getpgrp); -SCM -scm_getpgrp () -{ - int (*fn)(); - fn = (int (*) ()) getpgrp; - return SCM_MAKINUM (fn (0)); -} - -SCM_PROC (s_setpgid, "setpgid", 2, 0, 0, scm_setpgid); -SCM -scm_setpgid (pid, pgid) - SCM pid, pgid; -{ -#ifdef HAVE_SETPGID - SCM_ASSERT (SCM_INUMP (pid), pid, SCM_ARG1, s_setpgid); - SCM_ASSERT (SCM_INUMP (pgid), pgid, SCM_ARG2, s_setpgid); - /* FIXME(?): may be known as setpgrp. */ - if (setpgid (SCM_INUM (pid), SCM_INUM (pgid)) != 0) - scm_syserror (s_setpgid); - return SCM_UNSPECIFIED; -#else - scm_sysmissing (s_setpgid); - /* not reached. */ - return SCM_BOOL_F; -#endif -} - -SCM_PROC (s_setsid, "setsid", 0, 0, 0, scm_setsid); -SCM -scm_setsid () -{ -#ifdef HAVE_SETSID - pid_t sid = setsid (); - if (sid == -1) - scm_syserror (s_setsid); - return SCM_UNSPECIFIED; -#else - scm_sysmissing (s_setsid); - /* not reached. */ - return SCM_BOOL_F; -#endif -} - -SCM_PROC (s_ttyname, "ttyname", 1, 0, 0, scm_ttyname); - -SCM -scm_ttyname (port) - SCM port; -{ - char *ans; - int fd; - SCM_ASSERT (SCM_NIMP (port) && SCM_OPPORTP (port), port, SCM_ARG1, s_ttyname); - if (scm_tc16_fport != SCM_TYP16 (port)) - return SCM_BOOL_F; - fd = fileno ((FILE *)SCM_STREAM (port)); - if (fd == -1) - scm_syserror (s_ttyname); - SCM_SYSCALL (ans = ttyname (fd)); - if (!ans) - scm_syserror (s_ttyname); - /* ans could be overwritten by another call to ttyname */ - return (scm_makfrom0str (ans)); -} - - -SCM_PROC (s_ctermid, "ctermid", 0, 0, 0, scm_ctermid); -SCM -scm_ctermid () -{ -#ifdef HAVE_CTERMID - char *result = ctermid (NULL); - if (*result == '\0') - scm_syserror (s_ctermid); - return scm_makfrom0str (result); -#else - scm_sysmissing (s_ctermid); - /* not reached. */ - return SCM_BOOL_F; -#endif -} - -SCM_PROC (s_tcgetpgrp, "tcgetpgrp", 1, 0, 0, scm_tcgetpgrp); -SCM -scm_tcgetpgrp (port) - SCM port; -{ -#ifdef HAVE_TCGETPGRP - int fd; - pid_t pgid; - SCM_ASSERT (SCM_NIMP (port) && SCM_OPFPORTP (port), port, SCM_ARG1, s_tcgetpgrp); - fd = fileno ((FILE *)SCM_STREAM (port)); - if (fd == -1 || (pgid = tcgetpgrp (fd)) == -1) - scm_syserror (s_tcgetpgrp); - return SCM_MAKINUM (pgid); -#else - scm_sysmissing (s_tcgetpgrp); - /* not reached. */ - return SCM_BOOL_F; -#endif -} - -SCM_PROC (s_tcsetpgrp, "tcsetpgrp", 2, 0, 0, scm_tcsetpgrp); -SCM -scm_tcsetpgrp (port, pgid) - SCM port, pgid; -{ -#ifdef HAVE_TCSETPGRP - int fd; - SCM_ASSERT (SCM_NIMP (port) && SCM_OPFPORTP (port), port, SCM_ARG1, s_tcsetpgrp); - SCM_ASSERT (SCM_INUMP (pgid), pgid, SCM_ARG2, s_tcsetpgrp); - fd = fileno ((FILE *)SCM_STREAM (port)); - if (fd == -1 || tcsetpgrp (fd, SCM_INUM (pgid)) == -1) - scm_syserror (s_tcsetpgrp); - return SCM_UNSPECIFIED; -#else - scm_sysmissing (s_tcsetpgrp); - /* not reached. */ - return SCM_BOOL_F; -#endif -} - -/* Copy exec args from an SCM vector into a new C array. */ - -static char ** scm_convert_exec_args SCM_P ((SCM args)); - -static char ** -scm_convert_exec_args (args) - SCM args; -{ - char **execargv; - int num_args; - int i; - SCM_DEFER_INTS; - num_args = scm_ilength (args); - execargv = (char **) - scm_must_malloc ((num_args + 1) * sizeof (char *), s_ttyname); - for (i = 0; SCM_NNULLP (args); args = SCM_CDR (args), ++i) - { - scm_sizet len; - char *dst; - char *src; - SCM_ASSERT (SCM_NIMP (SCM_CAR (args)) && SCM_ROSTRINGP (SCM_CAR (args)), SCM_CAR (args), - "wrong type in SCM_ARG", "exec arg"); - len = 1 + SCM_ROLENGTH (SCM_CAR (args)); - dst = (char *) scm_must_malloc ((long) len, s_ttyname); - src = SCM_ROCHARS (SCM_CAR (args)); - while (len--) - dst[len] = src[len]; - execargv[i] = dst; - } - execargv[i] = 0; - SCM_ALLOW_INTS; - return execargv; -} - -SCM_PROC (s_execl, "execl", 0, 0, 1, scm_execl); - -SCM -scm_execl (args) - SCM args; -{ - char **execargv; - SCM filename = SCM_CAR (args); - SCM_ASSERT (SCM_NIMP (filename) && SCM_ROSTRINGP (filename), filename, SCM_ARG1, s_execl); - if (SCM_SUBSTRP (filename)) - filename = scm_makfromstr (SCM_ROCHARS (filename), SCM_ROLENGTH (filename), 0); - args = SCM_CDR (args); - execargv = scm_convert_exec_args (args); - execv (SCM_ROCHARS (filename), execargv); - scm_syserror (s_execl); - /* not reached. */ - return SCM_BOOL_F; -} - -SCM_PROC (s_execlp, "execlp", 0, 0, 1, scm_execlp); - -SCM -scm_execlp (args) - SCM args; -{ - char **execargv; - SCM filename = SCM_CAR (args); - SCM_ASSERT (SCM_NIMP (filename) && SCM_ROSTRINGP (filename), filename, SCM_ARG1, s_execlp); - if (SCM_SUBSTRP (filename)) - filename = scm_makfromstr (SCM_ROCHARS (filename), SCM_ROLENGTH (filename), 0); - args = SCM_CDR (args); - execargv = scm_convert_exec_args (args); - execvp (SCM_ROCHARS (filename), execargv); - scm_syserror (s_execlp); - /* not reached. */ - return SCM_BOOL_F; -} - -/* Flushing streams etc., is not done here. */ -SCM_PROC (s_fork, "fork", 0, 0, 0, scm_fork); - -SCM -scm_fork() -{ - int pid; - pid = fork (); - if (pid == -1) - scm_syserror (s_fork); - return SCM_MAKINUM (0L+pid); -} - - -SCM_PROC (s_uname, "uname", 0, 0, 0, scm_uname); - -SCM -scm_uname () -{ -#ifdef HAVE_UNAME - struct utsname buf; - SCM ans = scm_make_vector(SCM_MAKINUM(5), SCM_UNSPECIFIED, SCM_BOOL_F); - SCM *ve = SCM_VELTS (ans); - if (uname (&buf)) - return SCM_MAKINUM (errno); - 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); -/* - a linux special? - ve[5] = scm_makfrom0str (buf.domainname); -*/ - return ans; -#else - scm_sysmissing (s_uname); - /* not reached. */ - return SCM_BOOL_F; -#endif -} - -SCM_PROC (s_environ, "environ", 0, 1, 0, scm_environ); - -SCM -scm_environ (env) - SCM env; -{ - if (SCM_UNBNDP (env)) - return scm_makfromstrs (-1, environ); - else - { - int num_strings; - char **new_environ; - int i = 0; - SCM_ASSERT (SCM_NULLP (env) || (SCM_NIMP (env) && SCM_CONSP (env)), - env, SCM_ARG1, s_environ); - num_strings = scm_ilength (env); - new_environ = (char **) scm_must_malloc ((num_strings + 1) - * sizeof (char *), - s_environ); - while (SCM_NNULLP (env)) - { - int len; - char *src; - SCM_ASSERT (SCM_NIMP (SCM_CAR (env)) && SCM_ROSTRINGP (SCM_CAR (env)), env, SCM_ARG1, - s_environ); - len = 1 + SCM_ROLENGTH (SCM_CAR (env)); - new_environ[i] = scm_must_malloc ((long) len, s_environ); - src = SCM_ROCHARS (SCM_CAR (env)); - while (len--) - new_environ[i][len] = src[len]; - env = SCM_CDR (env); - i++; - } - new_environ[i] = 0; - /* Free the old environment, except when called for the first - * time. - */ - { - char **ep; - static int first = 1; - if (!first) - { - for (ep = environ; *ep != NULL; ep++) - scm_must_free (*ep); - scm_must_free ((char *) environ); - } - first = 0; - } - environ = new_environ; - return SCM_UNSPECIFIED; - } -} - -#ifdef L_tmpnam - -SCM_PROC (s_tmpnam, "tmpnam", 0, 0, 0, scm_tmpnam); - -SCM scm_tmpnam() -{ - char name[L_tmpnam]; - SCM_SYSCALL (tmpnam (name);); - return scm_makfrom0str (name); -} -#endif - -SCM_PROC (s_open_pipe, "open-pipe", 2, 0, 0, scm_open_pipe); - -SCM -scm_open_pipe (pipestr, modes) - SCM pipestr; - SCM modes; -{ - FILE *f; - register SCM z; - struct scm_port_table * pt; - - SCM_ASSERT (SCM_NIMP (pipestr) && SCM_ROSTRINGP (pipestr), pipestr, SCM_ARG1, s_open_pipe); - if (SCM_SUBSTRP (pipestr)) - pipestr = scm_makfromstr (SCM_ROCHARS (pipestr), SCM_ROLENGTH (pipestr), 0); - SCM_ASSERT (SCM_NIMP (modes) && SCM_ROSTRINGP (modes), modes, SCM_ARG2, s_open_pipe); - if (SCM_SUBSTRP (modes)) - modes = scm_makfromstr (SCM_ROCHARS (modes), SCM_ROLENGTH (modes), 0); - SCM_NEWCELL (z); - SCM_DEFER_INTS; - scm_ignore_signals (); - SCM_SYSCALL (f = popen (SCM_ROCHARS (pipestr), SCM_ROCHARS (modes))); - scm_unignore_signals (); - if (!f) - scm_syserror (s_open_pipe); - pt = scm_add_to_port_table (z); - SCM_SETPTAB_ENTRY (z, pt); - SCM_SETCAR (z, scm_tc16_pipe | SCM_OPN - | (strchr (SCM_ROCHARS (modes), 'r') ? SCM_RDNG : SCM_WRTNG)); - SCM_SETSTREAM (z, (SCM)f); - SCM_ALLOW_INTS; - return z; -} - - -SCM_PROC (s_open_input_pipe, "open-input-pipe", 1, 0, 0, scm_open_input_pipe); - -SCM -scm_open_input_pipe(pipestr) - SCM pipestr; -{ - return scm_open_pipe(pipestr, scm_makfromstr("r", (sizeof "r")-1, 0)); -} - -SCM_PROC (s_open_output_pipe, "open-output-pipe", 1, 0, 0, scm_open_output_pipe); - -SCM -scm_open_output_pipe(pipestr) - SCM pipestr; -{ - return scm_open_pipe(pipestr, scm_makfromstr("w", (sizeof "w")-1, 0)); -} - - -SCM_PROC (s_utime, "utime", 1, 2, 0, scm_utime); - -SCM -scm_utime (pathname, actime, modtime) - SCM pathname; - SCM actime; - SCM modtime; -{ - int rv; - struct utimbuf utm_tmp; - - SCM_ASSERT (SCM_NIMP (pathname) && SCM_STRINGP (pathname), pathname, SCM_ARG1, s_utime); - - if (SCM_UNBNDP (actime)) - SCM_SYSCALL (time (&utm_tmp.actime)); - else - utm_tmp.actime = scm_num2ulong (actime, (char *) SCM_ARG2, s_utime); - - if (SCM_UNBNDP (modtime)) - SCM_SYSCALL (time (&utm_tmp.modtime)); - else - utm_tmp.modtime = scm_num2ulong (modtime, (char *) SCM_ARG3, s_utime); - - SCM_SYSCALL (rv = utime (SCM_CHARS (pathname), &utm_tmp)); - if (rv != 0) - scm_syserror (s_utime); - return SCM_UNSPECIFIED; -} - -SCM_PROC (s_access, "access?", 2, 0, 0, scm_access); - -SCM -scm_access (path, how) - SCM path; - SCM how; -{ - int rv; - - SCM_ASSERT (SCM_NIMP (path) && SCM_ROSTRINGP (path), path, SCM_ARG1, s_access); - if (SCM_SUBSTRP (path)) - path = scm_makfromstr (SCM_ROCHARS (path), SCM_ROLENGTH (path), 0); - SCM_ASSERT (SCM_INUMP (how), how, SCM_ARG2, s_access); - rv = access (SCM_ROCHARS (path), SCM_INUM (how)); - return rv ? SCM_BOOL_F : SCM_BOOL_T; -} - -SCM_PROC (s_getpid, "getpid", 0, 0, 0, scm_getpid); - -SCM -scm_getpid () -{ - return SCM_MAKINUM ((unsigned long) getpid ()); -} - -SCM_PROC (s_putenv, "putenv", 1, 0, 0, scm_putenv); - -SCM -scm_putenv (str) - SCM str; -{ -#ifdef HAVE_PUTENV - int rv; - - SCM_ASSERT (SCM_NIMP (str) && SCM_STRINGP (str), str, SCM_ARG1, s_putenv); - rv = putenv (SCM_CHARS (str)); - if (rv < 0) - scm_syserror (s_putenv); - return SCM_UNSPECIFIED; -#else - scm_sysmissing (s_putenv); - /* not reached. */ - return SCM_BOOL_F; -#endif -} - -SCM_PROC (s_read_line, "read-line", 0, 2, 0, scm_read_line); - -SCM -scm_read_line (port, include_terminator) - SCM port; - SCM include_terminator; -{ - register int c; - register int j = 0; - scm_sizet len = 30; - SCM tok_buf; - register char *p; - int include; - - tok_buf = scm_makstr ((long) len, 0); - p = SCM_CHARS (tok_buf); - if (SCM_UNBNDP (port)) - port = scm_cur_inp; - else - SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), port, SCM_ARG1, s_read_line); - - if (SCM_UNBNDP (include_terminator)) - include = 0; - else - include = SCM_NFALSEP (include_terminator); - - if (EOF == (c = scm_gen_getc (port))) - return SCM_EOF_VAL; - while (1) - { - switch (c) - { - case SCM_LINE_INCREMENTORS: - if (j >= len) - { - p = scm_grow_tok_buf (&tok_buf); - len = SCM_LENGTH (tok_buf); - } - p[j++] = c; - /* fallthrough */ - case EOF: - if (len == j) - return tok_buf; - return scm_vector_set_length_x (tok_buf, (SCM) SCM_MAKINUM (j)); - - default: - if (j >= len) - { - p = scm_grow_tok_buf (&tok_buf); - len = SCM_LENGTH (tok_buf); - } - p[j++] = c; - c = scm_gen_getc (port); - break; - } - } -} - -SCM_PROC (s_read_line_x, "read-line!", 1, 1, 0, scm_read_line_x); - -SCM -scm_read_line_x (str, port) - SCM str; - SCM port; -{ - register int c; - register int j = 0; - register char *p; - scm_sizet len; - SCM_ASSERT (SCM_NIMP (str) && SCM_STRINGP (str), str, SCM_ARG1, s_read_line_x); - p = SCM_CHARS (str); - len = SCM_LENGTH (str); - if SCM_UNBNDP - (port) port = scm_cur_inp; - else - SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), port, SCM_ARG2, s_read_line_x); - c = scm_gen_getc (port); - if (EOF == c) - return SCM_EOF_VAL; - while (1) - { - switch (c) - { - case SCM_LINE_INCREMENTORS: - case EOF: - return SCM_MAKINUM (j); - default: - if (j >= len) - { - scm_gen_ungetc (c, port); - return SCM_BOOL_F; - } - p[j++] = c; - c = scm_gen_getc (port); - } - } -} - -SCM_PROC (s_write_line, "write-line", 1, 1, 0, scm_write_line); - -SCM -scm_write_line (obj, port) - SCM obj; - SCM port; -{ - scm_display (obj, port); - return scm_newline (port); -} - -SCM_PROC (s_setlocale, "setlocale", 1, 1, 0, scm_setlocale); - -SCM -scm_setlocale (category, locale) - SCM category; - SCM locale; -{ -#ifdef HAVE_SETLOCALE - char *clocale; - char *rv; - - SCM_ASSERT (SCM_INUMP (category), category, SCM_ARG1, s_setlocale); - if (SCM_UNBNDP (locale)) - { - clocale = NULL; - } - else - { - SCM_ASSERT (SCM_NIMP (locale) && SCM_STRINGP (locale), locale, SCM_ARG2, s_setlocale); - clocale = SCM_CHARS (locale); - } - - rv = setlocale (SCM_INUM (category), clocale); - if (rv == NULL) - scm_syserror (s_setlocale); - return scm_makfrom0str (rv); -#else - scm_sysmissing (s_setlocale); - /* not reached. */ - return SCM_BOOL_F; -#endif -} - -SCM_PROC (s_strftime, "strftime", 2, 0, 0, scm_strftime); - -SCM -scm_strftime (format, stime) - SCM format; - SCM stime; -{ - struct tm t; - - char *tbuf; - int n; - int size = 50; - char *fmt; - int len; - - SCM_ASSERT (SCM_NIMP (format) && SCM_STRINGP (format), format, SCM_ARG1, s_strftime); - SCM_ASSERT (SCM_NIMP (stime) && SCM_VECTORP (stime) && scm_obj_length (stime) == 9, - stime, SCM_ARG2, s_strftime); - - fmt = SCM_ROCHARS (format); - len = SCM_ROLENGTH (format); - -#define tm_deref scm_num2long (SCM_VELTS (stime)[n++], (char *)SCM_ARG2, s_strftime) - n = 0; - t.tm_sec = tm_deref; - t.tm_min = tm_deref; - t.tm_hour = tm_deref; - t.tm_mday = tm_deref; - t.tm_mon = tm_deref; - t.tm_year = tm_deref; - /* not used by mktime. - t.tm_wday = tm_deref; - t.tm_yday = tm_deref; */ - t.tm_isdst = tm_deref; -#undef tm_deref - - /* fill in missing fields and set the timezone. */ - mktime (&t); - - tbuf = scm_must_malloc (size, s_strftime); - while ((len = strftime (tbuf, size, fmt, &t)) == size) - { - scm_must_free (tbuf); - size *= 2; - tbuf = scm_must_malloc (size, s_strftime); - } - return scm_makfromstr (tbuf, len, 0); -} - -SCM_PROC (s_strptime, "strptime", 2, 0, 0, scm_strptime); - -SCM -scm_strptime (format, string) - SCM format; - SCM string; -{ -#ifdef HAVE_STRPTIME - SCM stime; - struct tm t; - - char *fmt, *str, *rest; - int n; - - SCM_ASSERT (SCM_NIMP (format) && SCM_ROSTRINGP (format), format, SCM_ARG1, s_strptime); - if (SCM_SUBSTRP (format)) - format = scm_makfromstr (SCM_ROCHARS (format), SCM_ROLENGTH (format), 0); - SCM_ASSERT (SCM_NIMP (string) && SCM_ROSTRINGP (string), string, SCM_ARG2, s_strptime); - if (SCM_SUBSTRP (string)) - string = scm_makfromstr (SCM_ROCHARS (string), SCM_ROLENGTH (string), 0); - - fmt = SCM_CHARS (format); - str = SCM_CHARS (string); - - /* initialize the struct tm */ -#define tm_init(field) t.field = 0 - tm_init (tm_sec); - tm_init (tm_min); - tm_init (tm_hour); - tm_init (tm_mday); - tm_init (tm_mon); - tm_init (tm_year); - tm_init (tm_wday); - tm_init (tm_yday); - tm_init (tm_isdst); -#undef tm_init - - SCM_DEFER_INTS; - rest = strptime (str, fmt, &t); - SCM_ALLOW_INTS; - - if (rest == NULL) - scm_syserror (s_strptime); - - stime = scm_make_vector (SCM_MAKINUM (9), scm_long2num (0), SCM_UNDEFINED); - -#define stime_set(val) scm_vector_set_x (stime, SCM_MAKINUM (n++), scm_long2num (t.val)); - n = 0; - stime_set (tm_sec); - stime_set (tm_min); - stime_set (tm_hour); - stime_set (tm_mday); - stime_set (tm_mon); - stime_set (tm_year); - stime_set (tm_wday); - stime_set (tm_yday); - stime_set (tm_isdst); -#undef stime_set - - return scm_cons (stime, scm_makfrom0str (rest)); -#else - scm_sysmissing (s_strptime); - /* not reached. */ - return SCM_BOOL_F; -#endif -} - -SCM_PROC (s_mknod, "mknod", 3, 0, 0, scm_mknod); - -SCM -scm_mknod(path, mode, dev) - SCM path; - SCM mode; - SCM dev; -{ -#ifdef HAVE_MKNOD - int val; - SCM_ASSERT(SCM_NIMP(path) && SCM_STRINGP(path), path, SCM_ARG1, s_mknod); - SCM_ASSERT(SCM_INUMP(mode), mode, SCM_ARG2, s_mknod); - SCM_ASSERT(SCM_INUMP(dev), dev, SCM_ARG3, s_mknod); - SCM_SYSCALL(val = mknod(SCM_CHARS(path), SCM_INUM(mode), SCM_INUM(dev))); - if (val != 0) - scm_syserror (s_mknod); - return SCM_UNSPECIFIED; -#else - scm_sysmissing (s_mknod); - /* not reached. */ - return SCM_BOOL_F; -#endif -} - - -SCM_PROC (s_nice, "nice", 1, 0, 0, scm_nice); - -SCM -scm_nice(incr) - SCM incr; -{ -#ifdef HAVE_NICE - SCM_ASSERT(SCM_INUMP(incr), incr, SCM_ARG1, s_nice); - if (nice(SCM_INUM(incr)) != 0) - scm_syserror (s_nice); - return SCM_UNSPECIFIED; -#else - scm_sysmissing (s_nice); - /* not reached. */ - return SCM_BOOL_F; -#endif -} - - -SCM_PROC (s_sync, "sync", 0, 0, 0, scm_sync); - -SCM -scm_sync() -{ -#ifdef HAVE_SYNC - sync(); -#else - scm_sysmissing (s_sync); - /* not reached. */ -#endif - return SCM_BOOL_F; -} - - - - -void -scm_init_posix () -{ - scm_add_feature ("posix"); -#ifdef HAVE_GETEUID - scm_add_feature ("EIDs"); -#endif -#ifdef WAIT_ANY - scm_sysintern ("WAIT_ANY", SCM_MAKINUM (WAIT_ANY)); -#endif -#ifdef WAIT_MYPGRP - scm_sysintern ("WAIT_MYPGRP", SCM_MAKINUM (WAIT_MYPGRP)); -#endif -#ifdef WNOHANG - scm_sysintern ("WNOHANG", SCM_MAKINUM (WNOHANG)); -#endif -#ifdef WUNTRACED - scm_sysintern ("WUNTRACED", SCM_MAKINUM (WUNTRACED)); -#endif - -#ifdef EINTR - scm_sysintern ("EINTR", SCM_MAKINUM (EINTR)); -#endif - -#ifdef SIGHUP - scm_sysintern ("SIGHUP", SCM_MAKINUM (SIGHUP)); -#endif -#ifdef SIGINT - scm_sysintern ("SIGINT", SCM_MAKINUM (SIGINT)); -#endif -#ifdef SIGQUIT - scm_sysintern ("SIGQUIT", SCM_MAKINUM (SIGQUIT)); -#endif -#ifdef SIGILL - scm_sysintern ("SIGILL", SCM_MAKINUM (SIGILL)); -#endif -#ifdef SIGTRAP - scm_sysintern ("SIGTRAP", SCM_MAKINUM (SIGTRAP)); -#endif -#ifdef SIGABRT - scm_sysintern ("SIGABRT", SCM_MAKINUM (SIGABRT)); -#endif -#ifdef SIGIOT - scm_sysintern ("SIGIOT", SCM_MAKINUM (SIGIOT)); -#endif -#ifdef SIGBUS - scm_sysintern ("SIGBUS", SCM_MAKINUM (SIGBUS)); -#endif -#ifdef SIGFPE - scm_sysintern ("SIGFPE", SCM_MAKINUM (SIGFPE)); -#endif -#ifdef SIGKILL - scm_sysintern ("SIGKILL", SCM_MAKINUM (SIGKILL)); -#endif -#ifdef SIGUSR1 - scm_sysintern ("SIGUSR1", SCM_MAKINUM (SIGUSR1)); -#endif -#ifdef SIGSEGV - scm_sysintern ("SIGSEGV", SCM_MAKINUM (SIGSEGV)); -#endif -#ifdef SIGUSR2 - scm_sysintern ("SIGUSR2", SCM_MAKINUM (SIGUSR2)); -#endif -#ifdef SIGPIPE - scm_sysintern ("SIGPIPE", SCM_MAKINUM (SIGPIPE)); -#endif -#ifdef SIGALRM - scm_sysintern ("SIGALRM", SCM_MAKINUM (SIGALRM)); -#endif -#ifdef SIGTERM - scm_sysintern ("SIGTERM", SCM_MAKINUM (SIGTERM)); -#endif -#ifdef SIGSTKFLT - scm_sysintern ("SIGSTKFLT", SCM_MAKINUM (SIGSTKFLT)); -#endif -#ifdef SIGCHLD - scm_sysintern ("SIGCHLD", SCM_MAKINUM (SIGCHLD)); -#endif -#ifdef SIGCONT - scm_sysintern ("SIGCONT", SCM_MAKINUM (SIGCONT)); -#endif -#ifdef SIGSTOP - scm_sysintern ("SIGSTOP", SCM_MAKINUM (SIGSTOP)); -#endif -#ifdef SIGTSTP - scm_sysintern ("SIGTSTP", SCM_MAKINUM (SIGTSTP)); -#endif -#ifdef SIGTTIN - scm_sysintern ("SIGTTIN", SCM_MAKINUM (SIGTTIN)); -#endif -#ifdef SIGTTOU - scm_sysintern ("SIGTTOU", SCM_MAKINUM (SIGTTOU)); -#endif -#ifdef SIGIO - scm_sysintern ("SIGIO", SCM_MAKINUM (SIGIO)); -#endif -#ifdef SIGPOLL - scm_sysintern ("SIGPOLL", SCM_MAKINUM (SIGPOLL)); -#endif -#ifdef SIGURG - scm_sysintern ("SIGURG", SCM_MAKINUM (SIGURG)); -#endif -#ifdef SIGXCPU - scm_sysintern ("SIGXCPU", SCM_MAKINUM (SIGXCPU)); -#endif -#ifdef SIGXFSZ - scm_sysintern ("SIGXFSZ", SCM_MAKINUM (SIGXFSZ)); -#endif -#ifdef SIGVTALRM - scm_sysintern ("SIGVTALRM", SCM_MAKINUM (SIGVTALRM)); -#endif -#ifdef SIGPROF - scm_sysintern ("SIGPROF", SCM_MAKINUM (SIGPROF)); -#endif -#ifdef SIGWINCH - scm_sysintern ("SIGWINCH", SCM_MAKINUM (SIGWINCH)); -#endif -#ifdef SIGLOST - scm_sysintern ("SIGLOST", SCM_MAKINUM (SIGLOST)); -#endif -#ifdef SIGPWR - scm_sysintern ("SIGPWR", SCM_MAKINUM (SIGPWR)); -#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)); - -#ifdef LC_COLLATE - scm_sysintern ("LC_COLLATE", SCM_MAKINUM (LC_COLLATE)); -#endif -#ifdef LC_CTYPE - scm_sysintern ("LC_CTYPE", SCM_MAKINUM (LC_CTYPE)); -#endif -#ifdef LC_MONETARY - scm_sysintern ("LC_MONETARY", SCM_MAKINUM (LC_MONETARY)); -#endif -#ifdef LC_NUMERIC - scm_sysintern ("LC_NUMERIC", SCM_MAKINUM (LC_NUMERIC)); -#endif -#ifdef LC_TIME - scm_sysintern ("LC_TIME", SCM_MAKINUM (LC_TIME)); -#endif -#ifdef LC_MESSAGES - scm_sysintern ("LC_MESSAGES", SCM_MAKINUM (LC_MESSAGES)); -#endif -#ifdef LC_ALL - scm_sysintern ("LC_ALL", SCM_MAKINUM (LC_ALL)); -#endif -#include "posix.x" -} |