source: project/chicken/branches/release/posixunix.scm @ 7931

Last change on this file since 7931 was 7931, checked in by felix winkelmann, 12 years ago

merged from prerelease branch rev. 7930 - release version 3.0.0; fixed wrong version numbers in some files

File size: 85.3 KB
Line 
1;;;; posixunix.scm - Miscellaneous file- and process-handling routines
2;
3; Copyright (c) 2000-2007, Felix L. Winkelmann
4; All rights reserved.
5;
6; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
7; conditions are met:
8;
9;   Redistributions of source code must retain the above copyright notice, this list of conditions and the following
10;     disclaimer.
11;   Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
12;     disclaimer in the documentation and/or other materials provided with the distribution.
13;   Neither the name of the author nor the names of its contributors may be used to endorse or promote
14;     products derived from this software without specific prior written permission.
15;
16; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
17; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
18; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
19; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
20; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
21; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
22; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
23; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
24; POSSIBILITY OF SUCH DAMAGE.
25;
26; Send bugs, suggestions and ideas to:
27;
28; felix@call-with-current-continuation.org
29;
30; Felix L. Winkelmann
31; Unter den Gleichen 1
32; 37130 Gleichen
33; Germany
34
35
36(declare
37  (unit posix)
38  (uses scheduler regex extras utils)
39  (disable-interrupts)
40  (usual-integrations)
41  (hide ##sys#stat group-member _get-groups _ensure-groups posix-error
42        ##sys#terminal-check)
43  (foreign-declare #<<EOF
44#include <signal.h>
45#include <errno.h>
46#include <math.h>
47
48static int C_not_implemented(void);
49int C_not_implemented() { return -1; }
50
51static C_TLS int C_wait_status;
52
53#include <unistd.h>
54#include <sys/types.h>
55#include <sys/time.h>
56#include <sys/wait.h>
57#include <sys/utsname.h>
58#include <sys/stat.h>
59#include <sys/ioctl.h>
60#include <fcntl.h>
61#include <dirent.h>
62#include <pwd.h>
63
64#if defined(__sun__) && defined(__svr4__)
65# include <sys/tty.h>
66#endif
67
68#ifdef HAVE_GRP_H
69#include <grp.h>
70#endif
71
72#include <sys/mman.h>
73#include <time.h>
74
75#ifndef O_FSYNC
76# define O_FSYNC O_SYNC
77#endif
78
79#ifndef PIPE_BUF
80# ifdef __CYGWIN__
81#  define PIPE_BUF       _POSIX_PIPE_BUF
82# else
83#  define PIPE_BUF 1024
84# endif
85#endif
86
87#ifndef O_BINARY
88# define O_BINARY        0
89#endif
90#ifndef O_TEXT
91# define O_TEXT          0
92#endif
93
94#ifndef ARG_MAX
95# define ARG_MAX 256
96#endif
97
98#ifndef MAP_FILE
99# define MAP_FILE    0
100#endif
101
102#ifndef MAP_ANON
103# define MAP_ANON    0
104#endif
105
106#if defined(HAVE_CRT_EXTERNS_H)
107# include <crt_externs.h>
108# define C_getenventry(i)       ((*_NSGetEnviron())[ i ])
109#elif defined(C_MACOSX)
110# define C_getenventry(i)       NULL
111#else
112extern char **environ;
113# define C_getenventry(i)       (environ[ i ])
114#endif
115
116#ifndef ENV_MAX
117# define ENV_MAX        1024
118#endif
119
120static C_TLS char *C_exec_args[ ARG_MAX ];
121static C_TLS char *C_exec_env[ ENV_MAX ];
122static C_TLS struct utsname C_utsname;
123static C_TLS struct flock C_flock;
124static C_TLS DIR *temphandle;
125static C_TLS struct passwd *C_user;
126#ifdef HAVE_GRP_H
127static C_TLS struct group *C_group;
128static C_TLS int C_pipefds[ 2 ];
129#endif
130static C_TLS time_t C_secs;
131static C_TLS struct tm C_tm;
132static C_TLS fd_set C_fd_sets[ 2 ];
133static C_TLS struct timeval C_timeval;
134static C_TLS char C_hostbuf[ 256 ];
135static C_TLS struct stat C_statbuf;
136
137#define C_mkdir(str)        C_fix(mkdir(C_c_string(str), S_IRWXU | S_IRWXG | S_IRWXO))
138#define C_chdir(str)        C_fix(chdir(C_c_string(str)))
139#define C_rmdir(str)        C_fix(rmdir(C_c_string(str)))
140
141#define C_opendir(x,h)          C_set_block_item(h, 0, (C_word) opendir(C_c_string(x)))
142#define C_closedir(h)           (closedir((DIR *)C_block_item(h, 0)), C_SCHEME_UNDEFINED)
143#define C_readdir(h,e)          C_set_block_item(e, 0, (C_word) readdir((DIR *)C_block_item(h, 0)))
144#define C_foundfile(e,b)        (strcpy(C_c_string(b), ((struct dirent *) C_block_item(e, 0))->d_name), C_fix(strlen(((struct dirent *) C_block_item(e, 0))->d_name)))
145
146#define C_curdir(buf)       (getcwd(C_c_string(buf), 256) ? C_fix(strlen(C_c_string(buf))) : C_SCHEME_FALSE)
147
148#define open_binary_input_pipe(a, n, name)   C_mpointer(a, popen(C_c_string(name), "r"))
149#define open_text_input_pipe(a, n, name)     open_binary_input_pipe(a, n, name)
150#define open_binary_output_pipe(a, n, name)  C_mpointer(a, popen(C_c_string(name), "w"))
151#define open_text_output_pipe(a, n, name)    open_binary_output_pipe(a, n, name)
152#define close_pipe(p)                        C_fix(pclose(C_port_file(p)))
153
154#define C_set_file_ptr(port, ptr)  (C_set_block_item(port, 0, (C_block_item(ptr, 0))), C_SCHEME_UNDEFINED)
155
156#define C_fork              fork
157#define C_waitpid(id, o)    C_fix(waitpid(C_unfix(id), &C_wait_status, C_unfix(o)))
158#define C_getpid            getpid
159#define C_getppid           getppid
160#define C_kill(id, s)       C_fix(kill(C_unfix(id), C_unfix(s)))
161#define C_getuid            getuid
162#define C_getgid            getgid
163#define C_geteuid           geteuid
164#define C_getegid           getegid
165#define C_chown(fn, u, g)   C_fix(chown(C_data_pointer(fn), C_unfix(u), C_unfix(g)))
166#define C_chmod(fn, m)      C_fix(chmod(C_data_pointer(fn), C_unfix(m)))
167#define C_setuid(id)        C_fix(setuid(C_unfix(id)))
168#define C_setgid(id)        C_fix(setgid(C_unfix(id)))
169#define C_seteuid(id)       C_fix(seteuid(C_unfix(id)))
170#define C_setegid(id)       C_fix(setegid(C_unfix(id)))
171#define C_setsid(dummy)     C_fix(setsid())
172#define C_setpgid(x, y)     C_fix(setpgid(C_unfix(x), C_unfix(y)))
173#define C_getpgid(x)        C_fix(getpgid(C_unfix(x)))
174#define C_symlink(o, n)     C_fix(symlink(C_data_pointer(o), C_data_pointer(n)))
175#define C_readlink(f, b)    C_fix(readlink(C_data_pointer(f), C_data_pointer(b), FILENAME_MAX))
176#define C_getpwnam(n)       C_mk_bool((C_user = getpwnam((char *)C_data_pointer(n))) != NULL)
177#define C_getpwuid(u)       C_mk_bool((C_user = getpwuid(C_unfix(u))) != NULL)
178#ifdef HAVE_GRP_H
179#define C_getgrnam(n)       C_mk_bool((C_group = getgrnam((char *)C_data_pointer(n))) != NULL)
180#define C_getgrgid(u)       C_mk_bool((C_group = getgrgid(C_unfix(u))) != NULL)
181#else
182#define C_getgrnam(n)       C_SCHEME_FALSE
183#define C_getgrgid(n)       C_SCHEME_FALSE
184#endif
185#define C_pipe(d)           C_fix(pipe(C_pipefds))
186#define C_truncate(f, n)    C_fix(truncate((char *)C_data_pointer(f), C_num_to_int(n)))
187#define C_ftruncate(f, n)   C_fix(ftruncate(C_unfix(f), C_num_to_int(n)))
188#define C_uname             C_fix(uname(&C_utsname))
189#define C_fdopen(a, n, fd, m) C_mpointer(a, fdopen(C_unfix(fd), C_c_string(m)))
190#define C_C_fileno(p)       C_fix(fileno(C_port_file(p)))
191#define C_dup(x)            C_fix(dup(C_unfix(x)))
192#define C_dup2(x, y)        C_fix(dup2(C_unfix(x), C_unfix(y)))
193#define C_alarm             alarm
194#define C_setvbuf(p, m, s)  C_fix(setvbuf(C_port_file(p), NULL, C_unfix(m), C_unfix(s)))
195#define C_access(fn, m)     C_fix(access((char *)C_data_pointer(fn), C_unfix(m)))
196#define C_close(fd)         C_fix(close(C_unfix(fd)))
197#define C_sleep             sleep
198
199#define C_putenv(s)         C_fix(putenv((char *)C_data_pointer(s)))
200#define C_stat(fn)          C_fix(stat((char *)C_data_pointer(fn), &C_statbuf))
201#define C_lstat(fn)         C_fix(lstat((char *)C_data_pointer(fn), &C_statbuf))
202#define C_fstat(f)          C_fix(fstat(C_unfix(f), &C_statbuf))
203
204#define C_islink            ((C_statbuf.st_mode & S_IFMT) == S_IFLNK)
205#define C_isreg             ((C_statbuf.st_mode & S_IFMT) == S_IFREG)
206
207#ifdef C_GNU_ENV
208# define C_setenv(x, y)     C_fix(setenv((char *)C_data_pointer(x), (char *)C_data_pointer(y), 1))
209#else
210static C_word C_fcall C_setenv(C_word x, C_word y);
211C_word C_fcall C_setenv(C_word x, C_word y) {
212  char *sx = C_data_pointer(x),
213       *sy = C_data_pointer(y);
214  int n1 = C_strlen(sx), n2 = C_strlen(sy);
215  char *buf = (char *)C_malloc(n1 + n2 + 2);
216  if(buf == NULL) return(C_fix(0));
217  else {
218    C_strcpy(buf, sx);
219    buf[ n1 ] = '=';
220    C_strcpy(buf + n1 + 1, sy);
221    return(C_fix(putenv(buf)));
222  }
223}
224#endif
225
226static void C_fcall C_set_arg_string(char **where, int i, char *a, int len) {
227  char *ptr;
228  if(a != NULL) {
229    ptr = (char *)C_malloc(len + 1);
230    C_memcpy(ptr, a, len);
231    ptr[ len ] = '\0';
232  }
233  else ptr = NULL;
234  where[ i ] = ptr;
235}
236
237static void C_fcall C_free_arg_string(char **where) {
238  while((*where) != NULL) C_free(*(where++));
239}
240
241static void C_set_timeval(C_word num, struct timeval *tm)
242{
243  if((num & C_FIXNUM_BIT) != 0) {
244    tm->tv_sec = C_unfix(num);
245    tm->tv_usec = 0;
246  }
247  else {
248    double i;
249    tm->tv_usec = (int)(modf(C_flonum_magnitude(num), &i) * 1000000);
250    tm->tv_sec = (int)i;
251  }
252}
253
254#define C_set_exec_arg(i, a, len)       C_set_arg_string(C_exec_args, i, a, len)
255#define C_free_exec_args()              C_free_arg_string(C_exec_args)
256#define C_set_exec_env(i, a, len)       C_set_arg_string(C_exec_env, i, a, len)
257#define C_free_exec_env()               C_free_arg_string(C_exec_env)
258
259#define C_execvp(f)         C_fix(execvp(C_data_pointer(f), C_exec_args))
260#define C_execve(f)         C_fix(execve(C_data_pointer(f), C_exec_args, C_exec_env))
261
262#if defined(__FreeBSD__) || defined(C_MACOSX) || defined(__NetBSD__) || defined(__OpenBSD__) || defined(__sgi__) || defined(sgi) || defined(__DragonFly__) || defined(__SUNPRO_C)
263static C_TLS int C_uw;
264# define C_WIFEXITED(n)      (C_uw = C_unfix(n), C_mk_bool(WIFEXITED(C_uw)))
265# define C_WIFSIGNALED(n)    (C_uw = C_unfix(n), C_mk_bool(WIFSIGNALED(C_uw)))
266# define C_WIFSTOPPED(n)     (C_uw = C_unfix(n), C_mk_bool(WIFSTOPPED(C_uw)))
267# define C_WEXITSTATUS(n)    (C_uw = C_unfix(n), C_fix(WEXITSTATUS(C_uw)))
268# define C_WTERMSIG(n)       (C_uw = C_unfix(n), C_fix(WTERMSIG(C_uw)))
269# define C_WSTOPSIG(n)       (C_uw = C_unfix(n), C_fix(WSTOPSIG(C_uw)))
270#else
271# define C_WIFEXITED(n)      C_mk_bool(WIFEXITED(C_unfix(n)))
272# define C_WIFSIGNALED(n)    C_mk_bool(WIFSIGNALED(C_unfix(n)))
273# define C_WIFSTOPPED(n)     C_mk_bool(WIFSTOPPED(C_unfix(n)))
274# define C_WEXITSTATUS(n)    C_fix(WEXITSTATUS(C_unfix(n)))
275# define C_WTERMSIG(n)       C_fix(WTERMSIG(C_unfix(n)))
276# define C_WSTOPSIG(n)       C_fix(WSTOPSIG(C_unfix(n)))
277#endif
278
279#ifdef __CYGWIN__
280# define C_mkfifo(fn, m)    C_fix(-1);
281#else
282# define C_mkfifo(fn, m)    C_fix(mkfifo((char *)C_data_pointer(fn), C_unfix(m)))
283#endif
284
285#define C_flock_setup(t, s, n) (C_flock.l_type = C_unfix(t), C_flock.l_start = C_num_to_int(s), C_flock.l_whence = SEEK_SET, C_flock.l_len = C_num_to_int(n), C_SCHEME_UNDEFINED)
286#define C_flock_test(p)     (fcntl(fileno(C_port_file(p)), F_GETLK, &C_flock) >= 0 ? (C_flock.l_type == F_UNLCK ? C_fix(0) : C_fix(C_flock.l_pid)) : C_SCHEME_FALSE)
287#define C_flock_lock(p)     C_fix(fcntl(fileno(C_port_file(p)), F_SETLK, &C_flock))
288#define C_flock_lockw(p)    C_fix(fcntl(fileno(C_port_file(p)), F_SETLKW, &C_flock))
289
290#ifndef FILENAME_MAX
291# define FILENAME_MAX          1024
292#endif
293
294static C_TLS sigset_t C_sigset;
295#define C_sigemptyset(d)    (sigemptyset(&C_sigset), C_SCHEME_UNDEFINED)
296#define C_sigaddset(s)      (sigaddset(&C_sigset, C_unfix(s)), C_SCHEME_UNDEFINED)
297#define C_sigdelset(s)      (sigdelset(&C_sigset, C_unfix(s)), C_SCHEME_UNDEFINED)
298#define C_sigismember(s)    C_mk_bool(sigismember(&C_sigset, C_unfix(s)))
299#define C_sigprocmask_set(d)        C_fix(sigprocmask(SIG_SETMASK, &C_sigset, NULL))
300#define C_sigprocmask_block(d)      C_fix(sigprocmask(SIG_BLOCK, &C_sigset, NULL))
301#define C_sigprocmask_unblock(d)    C_fix(sigprocmask(SIG_UNBLOCK, &C_sigset, NULL))
302
303#define C_open(fn, fl, m)   C_fix(open(C_c_string(fn), C_unfix(fl), C_unfix(m)))
304#define C_read(fd, b, n)    C_fix(read(C_unfix(fd), C_data_pointer(b), C_unfix(n)))
305#define C_write(fd, b, n)   C_fix(write(C_unfix(fd), C_data_pointer(b), C_unfix(n)))
306#define C_mkstemp(t)        C_fix(mkstemp(C_c_string(t)))
307
308#define C_ftell(p)            C_fix(ftell(C_port_file(p)))
309#define C_fseek(p, n, w)      C_mk_nbool(fseek(C_port_file(p), C_unfix(n), C_unfix(w)))
310#define C_lseek(fd, o, w)     C_fix(lseek(C_unfix(fd), C_unfix(o), C_unfix(w)))
311
312#define C_zero_fd_set(i)      FD_ZERO(&C_fd_sets[ i ])
313#define C_set_fd_set(i, fd)   FD_SET(fd, &C_fd_sets[ i ])
314#define C_test_fd_set(i, fd)  FD_ISSET(fd, &C_fd_sets[ i ])
315#define C_C_select(m)         C_fix(select(C_unfix(m), &C_fd_sets[ 0 ], &C_fd_sets[ 1 ], NULL, NULL))
316#define C_C_select_t(m, t)    (C_set_timeval(t, &C_timeval), \
317                               C_fix(select(C_unfix(m), &C_fd_sets[ 0 ], &C_fd_sets[ 1 ], NULL, &C_timeval)))
318
319#define C_ctime(n)          (C_secs = (n), ctime(&C_secs))
320
321#if defined(__CYGWIN__) || defined(__SVR4)
322/* Seen here: http://lists.samba.org/archive/samba-technical/2002-November/025571.html */
323
324time_t timegm(struct tm *t)
325{
326  time_t tl, tb;
327  struct tm *tg;
328
329  tl = mktime (t);
330  if (tl == -1)
331    {
332      t->tm_hour--;
333      tl = mktime (t);
334      if (tl == -1)
335        return -1; /* can't deal with output from strptime */
336      tl += 3600;
337    }
338  tg = gmtime (&tl);
339  tg->tm_isdst = 0;
340  tb = mktime (tg);
341  if (tb == -1)
342    {
343      tg->tm_hour--;
344      tb = mktime (tg);
345      if (tb == -1)
346        return -1; /* can't deal with output from gmtime */
347      tb += 3600;
348    }
349  return (tl - (tb - tl));
350}
351#endif
352
353#if !defined(C_GNU_ENV) || defined(__CYGWIN__) || defined(__uClinux__)
354# define C_asctime(v)        (memset(&C_tm, 0, sizeof(struct tm)), C_tm.tm_sec = C_unfix(C_block_item(v, 0)), C_tm.tm_min = C_unfix(C_block_item(v, 1)), C_tm.tm_hour = C_unfix(C_block_item(v, 2)), C_tm.tm_mday = C_unfix(C_block_item(v, 3)), C_tm.tm_mon = C_unfix(C_block_item(v, 4)), C_tm.tm_year = C_unfix(C_block_item(v, 5)), C_tm.tm_wday = C_unfix(C_block_item(v, 6)), C_tm.tm_yday = C_unfix(C_block_item(v, 7)), C_tm.tm_isdst = (C_block_item(v, 8) != C_SCHEME_FALSE), asctime(&C_tm) )
355# define C_mktime(v)        (memset(&C_tm, 0, sizeof(struct tm)), C_tm.tm_sec = C_unfix(C_block_item(v, 0)), C_tm.tm_min = C_unfix(C_block_item(v, 1)), C_tm.tm_hour = C_unfix(C_block_item(v, 2)), C_tm.tm_mday = C_unfix(C_block_item(v, 3)), C_tm.tm_mon = C_unfix(C_block_item(v, 4)), C_tm.tm_year = C_unfix(C_block_item(v, 5)), C_tm.tm_wday = C_unfix(C_block_item(v, 6)), C_tm.tm_yday = C_unfix(C_block_item(v, 7)), C_tm.tm_isdst = (C_block_item(v, 8) != C_SCHEME_FALSE), (C_temporary_flonum = mktime(&C_tm)) != -1)
356# define C_timegm(v)        (memset(&C_tm, 0, sizeof(struct tm)), C_tm.tm_sec = C_unfix(C_block_item(v, 0)), C_tm.tm_min = C_unfix(C_block_item(v, 1)), C_tm.tm_hour = C_unfix(C_block_item(v, 2)), C_tm.tm_mday = C_unfix(C_block_item(v, 3)), C_tm.tm_mon = C_unfix(C_block_item(v, 4)), C_tm.tm_year = C_unfix(C_block_item(v, 5)), C_tm.tm_wday = C_unfix(C_block_item(v, 6)), C_tm.tm_yday = C_unfix(C_block_item(v, 7)), C_tm.tm_isdst = (C_block_item(v, 8) != C_SCHEME_FALSE), (C_temporary_flonum = timegm(&C_tm)) != -1)
357#else
358# define C_asctime(v)        (memset(&C_tm, 0, sizeof(struct tm)), C_tm.tm_sec = C_unfix(C_block_item(v, 0)), C_tm.tm_min = C_unfix(C_block_item(v, 1)), C_tm.tm_hour = C_unfix(C_block_item(v, 2)), C_tm.tm_mday = C_unfix(C_block_item(v, 3)), C_tm.tm_mon = C_unfix(C_block_item(v, 4)), C_tm.tm_year = C_unfix(C_block_item(v, 5)), C_tm.tm_wday = C_unfix(C_block_item(v, 6)), C_tm.tm_yday = C_unfix(C_block_item(v, 7)), C_tm.tm_isdst = (C_block_item(v, 8) != C_SCHEME_FALSE), C_tm.tm_gmtoff = C_unfix(C_block_item(v, 9)), asctime(&C_tm) )
359# define C_mktime(v)        (memset(&C_tm, 0, sizeof(struct tm)), C_tm.tm_sec = C_unfix(C_block_item(v, 0)), C_tm.tm_min = C_unfix(C_block_item(v, 1)), C_tm.tm_hour = C_unfix(C_block_item(v, 2)), C_tm.tm_mday = C_unfix(C_block_item(v, 3)), C_tm.tm_mon = C_unfix(C_block_item(v, 4)), C_tm.tm_year = C_unfix(C_block_item(v, 5)), C_tm.tm_wday = C_unfix(C_block_item(v, 6)), C_tm.tm_yday = C_unfix(C_block_item(v, 7)), C_tm.tm_isdst = (C_block_item(v, 8) != C_SCHEME_FALSE), C_tm.tm_gmtoff = C_unfix(C_block_item(v, 9)), (C_temporary_flonum = mktime(&C_tm)) != -1)
360# define C_timegm(v)        (memset(&C_tm, 0, sizeof(struct tm)), C_tm.tm_sec = C_unfix(C_block_item(v, 0)), C_tm.tm_min = C_unfix(C_block_item(v, 1)), C_tm.tm_hour = C_unfix(C_block_item(v, 2)), C_tm.tm_mday = C_unfix(C_block_item(v, 3)), C_tm.tm_mon = C_unfix(C_block_item(v, 4)), C_tm.tm_year = C_unfix(C_block_item(v, 5)), C_tm.tm_wday = C_unfix(C_block_item(v, 6)), C_tm.tm_yday = C_unfix(C_block_item(v, 7)), C_tm.tm_isdst = (C_block_item(v, 8) != C_SCHEME_FALSE), C_tm.tm_gmtoff = C_unfix(C_block_item(v, 9)), (C_temporary_flonum = timegm(&C_tm)) != -1)
361#endif
362
363static gid_t *C_groups = NULL;
364
365#define C_get_gid(n)      C_fix(C_groups[ C_unfix(n) ])
366#define C_set_gid(n, id)  (C_groups[ C_unfix(n) ] = C_unfix(id), C_SCHEME_UNDEFINED)
367#define C_set_groups(n)   C_fix(setgroups(C_unfix(n), C_groups))
368
369#ifdef TIOCGWINSZ
370static int get_tty_size(int p, int *rows, int *cols)
371{
372 struct winsize tty_size;
373 int r;
374
375 memset(&tty_size, 0, sizeof tty_size);
376
377 r = ioctl(p, TIOCGWINSZ, &tty_size);
378 if (r == 0) {
379    *rows = tty_size.ws_row;
380    *cols = tty_size.ws_col;
381 }
382 return r;
383}
384#else
385static int get_tty_size(int p, int *rows, int *cols)
386{
387 *rows = *cols = 0;
388 return -1;
389}
390#endif
391
392EOF
393) )
394
395(cond-expand
396 [paranoia]
397 [else
398  (declare
399    (no-bound-checks)
400    (no-procedure-checks-for-usual-bindings)
401    (bound-to-procedure
402     string-match glob->regexp regexp make-anchored-pattern
403     ##sys#thread-yield! ##sys#make-string
404     ##sys#make-port ##sys#file-info ##sys#update-errno ##sys#fudge ##sys#make-c-string ##sys#check-port
405     ##sys#error ##sys#signal-hook ##sys#peek-unsigned-integer make-pathname glob directory?
406     pathname-file process-fork file-close duplicate-fileno process-execute getenv
407     make-string make-input-port make-output-port ##sys#thread-block-for-i/o create-pipe
408     process-wait pathname-strip-directory ##sys#expand-home-path directory
409     decompose-pathname ##sys#cons-flonum ##sys#decode-seconds ##sys#null-pointer ##sys#pointer->address
410     ##sys#substring ##sys#context-switch close-input-pipe close-output-pipe change-directory
411     current-directory ##sys#make-pointer port? ##sys#schedule ##sys#process
412     ##sys#peek-fixnum ##sys#make-structure ##sys#check-structure ##sys#enable-interrupts) ) ] )
413
414(cond-expand
415 [unsafe
416  (eval-when (compile)
417    (define-macro (##sys#check-structure . _) '(##core#undefined))
418    (define-macro (##sys#check-range . _) '(##core#undefined))
419    (define-macro (##sys#check-pair . _) '(##core#undefined))
420    (define-macro (##sys#check-list . _) '(##core#undefined))
421    (define-macro (##sys#check-symbol . _) '(##core#undefined))
422    (define-macro (##sys#check-string . _) '(##core#undefined))
423    (define-macro (##sys#check-char . _) '(##core#undefined))
424    (define-macro (##sys#check-exact . _) '(##core#undefined))
425    (define-macro (##sys#check-port . _) '(##core#undefined))
426    (define-macro (##sys#check-number . _) '(##core#undefined))
427    (define-macro (##sys#check-byte-vector . _) '(##core#undefined)) ) ]
428 [else
429  (declare (emit-exports "posix.exports")) ] )
430
431(register-feature! 'posix)
432
433(define posix-error
434  (let ([strerror (foreign-lambda c-string "strerror" int)]
435        [string-append string-append] )
436    (lambda (type loc msg . args)
437      (let ([rn (##sys#update-errno)])
438        (apply ##sys#signal-hook type loc (string-append msg " - " (strerror rn)) args) ) ) ) )
439
440;; Faster versions of common operations
441
442(define ##sys#posix-error posix-error)
443
444(define ##sys#file-nonblocking!
445  (foreign-lambda* bool ([int fd])
446    "int val = fcntl(fd, F_GETFL, 0);"
447    "if(val == -1) return(0);"
448    "return(fcntl(fd, F_SETFL, val | O_NONBLOCK) != -1);" ) )
449
450(define ##sys#file-select-one
451  (foreign-lambda* int ([int fd])
452    "fd_set in;"
453    "struct timeval tm;"
454    "FD_ZERO(&in);"
455    "FD_SET(fd, &in);"
456    "tm.tv_sec = tm.tv_usec = 0;"
457    "if(select(fd + 1, &in, NULL, NULL, &tm) == -1) return(-1);"
458    "else return(FD_ISSET(fd, &in) ? 1 : 0);" ) )
459
460
461;;; Lo-level I/O:
462
463(define-foreign-variable _pipe_buf int "PIPE_BUF")
464
465(define pipe/buf _pipe_buf)
466
467(define-foreign-variable _f_dupfd int "F_DUPFD")
468(define-foreign-variable _f_getfd int "F_GETFD")
469(define-foreign-variable _f_setfd int "F_SETFD")
470(define-foreign-variable _f_getfl int "F_GETFL")
471(define-foreign-variable _f_setfl int "F_SETFL")
472
473(define fcntl/dupfd _f_dupfd)
474(define fcntl/getfd _f_getfd)
475(define fcntl/setfd _f_setfd)
476(define fcntl/getfl _f_getfl)
477(define fcntl/setfl _f_setfl)
478
479(define-foreign-variable _o_rdonly int "O_RDONLY")
480(define-foreign-variable _o_wronly int "O_WRONLY")
481(define-foreign-variable _o_rdwr int "O_RDWR")
482(define-foreign-variable _o_creat int "O_CREAT")
483(define-foreign-variable _o_append int "O_APPEND")
484(define-foreign-variable _o_excl int "O_EXCL")
485(define-foreign-variable _o_noctty int "O_NOCTTY")
486(define-foreign-variable _o_nonblock int "O_NONBLOCK")
487(define-foreign-variable _o_trunc int "O_TRUNC")
488(define-foreign-variable _o_fsync int "O_FSYNC")
489(define-foreign-variable _o_binary int "O_BINARY")
490(define-foreign-variable _o_text int "O_TEXT")
491
492(define open/rdonly _o_rdonly)
493(define open/wronly _o_wronly)
494(define open/rdwr _o_rdwr)
495(define open/read _o_rdonly)
496(define open/write _o_wronly)
497(define open/creat _o_creat)
498(define open/append _o_append)
499(define open/excl _o_excl)
500(define open/noctty _o_noctty)
501(define open/nonblock _o_nonblock)
502(define open/trunc _o_trunc)
503(define open/sync _o_fsync)
504(define open/fsync _o_fsync)
505(define open/binary _o_binary)
506(define open/text _o_text)
507
508(define-foreign-variable _s_irusr int "S_IRUSR")
509(define-foreign-variable _s_iwusr int "S_IWUSR")
510(define-foreign-variable _s_ixusr int "S_IXUSR")
511(define-foreign-variable _s_irgrp int "S_IRGRP")
512(define-foreign-variable _s_iwgrp int "S_IWGRP")
513(define-foreign-variable _s_ixgrp int "S_IXGRP")
514(define-foreign-variable _s_iroth int "S_IROTH")
515(define-foreign-variable _s_iwoth int "S_IWOTH")
516(define-foreign-variable _s_ixoth int "S_IXOTH")
517(define-foreign-variable _s_irwxu int "S_IRWXU")
518(define-foreign-variable _s_irwxg int "S_IRWXG")
519(define-foreign-variable _s_irwxo int "S_IRWXO")
520(define-foreign-variable _s_isuid int "S_ISUID")
521(define-foreign-variable _s_isgid int "S_ISGID")
522(define-foreign-variable _s_isvtx int "S_ISVTX")
523
524(define perm/irusr _s_irusr)
525(define perm/iwusr _s_iwusr)
526(define perm/ixusr _s_ixusr)
527(define perm/irgrp _s_irgrp)
528(define perm/iwgrp _s_iwgrp)
529(define perm/ixgrp _s_ixgrp)
530(define perm/iroth _s_iroth)
531(define perm/iwoth _s_iwoth)
532(define perm/ixoth _s_ixoth)
533(define perm/irwxu _s_irwxu)
534(define perm/irwxg _s_irwxg)
535(define perm/irwxo _s_irwxo)
536(define perm/isvtx _s_isvtx)
537(define perm/isuid _s_isuid)
538(define perm/isgid _s_isgid)
539
540(define file-control
541  (let ([fcntl (foreign-lambda int fcntl int int long)])
542    (lambda (fd cmd #!optional (arg 0))
543      (##sys#check-exact fd 'file-control)
544      (##sys#check-exact cmd 'file-control)
545      (let ([res (fcntl fd cmd arg)])
546        (if (fx= res -1)
547            (posix-error #:file-error 'file-control "cannot control file" fd cmd)
548            res ) ) ) ) )
549
550(define file-open
551  (let ([defmode (bitwise-ior _s_irwxu (bitwise-ior _s_irgrp _s_iroth))] )
552    (lambda (filename flags . mode)
553      (let ([mode (if (pair? mode) (car mode) defmode)])
554        (##sys#check-string filename 'file-open)
555        (##sys#check-exact flags 'file-open)
556        (##sys#check-exact mode 'file-open)
557        (let ([fd (##core#inline "C_open" (##sys#make-c-string (##sys#expand-home-path filename)) flags mode)])
558          (when (eq? -1 fd)
559            (posix-error #:file-error 'file-open "cannot open file" filename flags mode) )
560          fd) ) ) ) )
561
562(define file-close
563  (lambda (fd)
564    (##sys#check-exact fd 'file-close)
565    (when (fx< (##core#inline "C_close" fd) 0)
566      (posix-error #:file-error 'file-close "cannot close file" fd) ) ) )
567
568(define file-read
569  (let ([make-string make-string] )
570    (lambda (fd size . buffer)
571      (##sys#check-exact fd 'file-read)
572      (##sys#check-exact size 'file-read)
573      (let ([buf (if (pair? buffer) (car buffer) (make-string size))])
574        (unless (and (##core#inline "C_blockp" buf) (##core#inline "C_byteblockp" buf))
575          (##sys#signal-hook #:type-error 'file-read "bad argument type - not a string or blob" buf) )
576        (let ([n (##core#inline "C_read" fd buf size)])
577          (when (eq? -1 n)
578            (posix-error #:file-error 'file-read "cannot read from file" fd size) )
579          (list buf n) ) ) ) ) )
580
581(define file-write
582  (lambda (fd buffer . size)
583    (##sys#check-exact fd 'file-write)
584    (unless (and (##core#inline "C_blockp" buffer) (##core#inline "C_byteblockp" buffer))
585      (##sys#signal-hook #:type-error 'file-write "bad argument type - not a string or blob" buffer) )
586    (let ([size (if (pair? size) (car size) (##sys#size buffer))])
587      (##sys#check-exact size 'file-write)
588      (let ([n (##core#inline "C_write" fd buffer size)])
589        (when (eq? -1 n)
590          (posix-error #:file-error 'file-write "cannot write to file" fd size) )
591        n) ) ) )
592
593(define file-mkstemp
594  (lambda (template)
595    (##sys#check-string template 'file-mkstemp)
596    (let* ([buf (##sys#make-c-string template)]
597           [fd (##core#inline "C_mkstemp" buf)]
598           [path-length (##sys#size buf)])
599      (when (eq? -1 fd)
600        (posix-error #:file-error 'file-mkstemp "cannot create temporary file" template) )
601      (values fd (##sys#substring buf 0 (fx- path-length 1) ) ) ) ) )
602
603
604;;; I/O multiplexing:
605
606(define file-select
607  (let ([fd_zero (foreign-lambda void "C_zero_fd_set" int)]
608        [fd_set (foreign-lambda void "C_set_fd_set" int int)]
609        [fd_test (foreign-lambda bool "C_test_fd_set" int int)] )
610    (lambda (fdsr fdsw . timeout)
611      (let ([fdmax 0]
612            [tm (if (pair? timeout) (car timeout) #f)] )
613        (fd_zero 0)
614        (fd_zero 1)
615        (cond [(not fdsr)]
616              [(fixnum? fdsr)
617               (set! fdmax fdsr)
618               (fd_set 0 fdsr) ]
619              [else
620               (##sys#check-list fdsr 'file-select)
621               (for-each
622                (lambda (fd)
623                  (##sys#check-exact fd 'file-select)
624                  (set! fdmax (##core#inline "C_i_fixnum_max" fdmax fd))
625                  (fd_set 0 fd) )
626                fdsr) ] )
627        (cond [(not fdsw)]
628              [(fixnum? fdsw)
629               (set! fdmax fdsw)
630               (fd_set 1 fdsw) ]
631              [else
632               (##sys#check-list fdsw 'file-select)
633               (for-each
634                (lambda (fd)
635                  (##sys#check-exact fd 'file-select)
636                  (set! fdmax (##core#inline "C_i_fixnum_max" fdmax fd))
637                  (fd_set 1 fd) )
638                fdsw) ] )
639        (let ([n (cond [tm
640                        (##sys#check-number tm 'file-select)
641                        (##core#inline "C_C_select_t" (fx+ fdmax 1) tm) ]
642                       [else (##core#inline "C_C_select" (fx+ fdmax 1))] ) ] )
643          (cond [(fx< n 0)
644                 (posix-error #:file-error 'file-select "failed" fdsr fdsw) ]
645                [(fx= n 0) (values (if (pair? fdsr) '() #f) (if (pair? fdsw) '() #f))]
646                [else
647                 (values
648                  (and fdsr
649                       (if (fixnum? fdsr)
650                           (fd_test 0 fdsr)
651                           (let ([lstr '()])
652                             (for-each (lambda (fd) (when (fd_test 0 fd) (set! lstr (cons fd lstr)))) fdsr)
653                             lstr) ) )
654                  (and fdsw
655                       (if (fixnum? fdsw)
656                           (fd_test 1 fdsw)
657                           (let ([lstw '()])
658                             (for-each (lambda (fd) (when (fd_test 1 fd) (set! lstw (cons fd lstw)))) fdsw)
659                             lstw) ) ) ) ] ) ) ) ) ) )
660
661
662;;; File attribute access:
663
664(define-foreign-variable _seek_set int "SEEK_SET")
665(define-foreign-variable _seek_cur int "SEEK_CUR")
666(define-foreign-variable _seek_end int "SEEK_END")
667
668(define seek/set _seek_set)
669(define seek/end _seek_end)
670(define seek/cur _seek_cur)
671
672(define-foreign-variable _stat_st_ino unsigned-int "C_statbuf.st_ino")
673(define-foreign-variable _stat_st_nlink unsigned-int "C_statbuf.st_nlink")
674(define-foreign-variable _stat_st_gid unsigned-int "C_statbuf.st_gid")
675(define-foreign-variable _stat_st_size integer64 "C_statbuf.st_size")
676(define-foreign-variable _stat_st_mtime double "C_statbuf.st_mtime")
677(define-foreign-variable _stat_st_atime double "C_statbuf.st_atime")
678(define-foreign-variable _stat_st_ctime double "C_statbuf.st_ctime")
679(define-foreign-variable _stat_st_uid unsigned-int "C_statbuf.st_uid")
680(define-foreign-variable _stat_st_mode unsigned-int "C_statbuf.st_mode")
681(define-foreign-variable _stat_st_dev unsigned-int "C_statbuf.st_dev")
682(define-foreign-variable _stat_st_rdev unsigned-int "C_statbuf.st_rdev")
683(define-foreign-variable _stat_st_blksize unsigned-int "C_statbuf.st_blksize")
684(define-foreign-variable _stat_st_blocks unsigned-int "C_statbuf.st_blocks")
685
686(define (##sys#stat file link loc)
687  (let ([r (cond [(fixnum? file) (##core#inline "C_fstat" file)]
688                 [(string? file)
689                  (let ([path (##sys#make-c-string (##sys#expand-home-path file))])
690                    (if link
691                        (##core#inline "C_lstat" path)
692                        (##core#inline "C_stat" path) ) ) ]
693                 [else (##sys#signal-hook #:type-error "bad argument type - not a fixnum or string" file)] ) ] )
694    (when (fx< r 0)
695      (posix-error #:file-error loc "cannot access file" file) ) ) )
696
697(define (file-stat f . link)
698  (##sys#stat f (:optional link #f) 'file-stat)
699  (vector _stat_st_ino _stat_st_mode _stat_st_nlink
700          _stat_st_uid _stat_st_gid _stat_st_size
701          _stat_st_atime _stat_st_ctime _stat_st_mtime
702          _stat_st_dev _stat_st_rdev
703          _stat_st_blksize _stat_st_blocks) )
704
705(define (file-size f) (##sys#stat f #f 'file-size) _stat_st_size)
706(define (file-modification-time f) (##sys#stat f #f 'file-modification-time) _stat_st_mtime)
707(define (file-access-time f) (##sys#stat f #f 'file-access-time) _stat_st_atime)
708(define (file-change-time f) (##sys#stat f #f 'file-change-time) _stat_st_ctime)
709(define (file-owner f) (##sys#stat f #f 'file-owner) _stat_st_uid)
710(define (file-permissions f) (##sys#stat f #f 'file-permissions) _stat_st_mode)
711
712(define (regular-file? fname)
713  (##sys#check-string fname 'regular-file?)
714  (##sys#stat fname #t 'regular-file?)
715  (foreign-value "C_isreg" bool) )
716
717(define (symbolic-link? fname)
718  (##sys#check-string fname 'symbolic-link?)
719  (##sys#stat fname #t 'symbolic-link?)
720  (foreign-value "C_islink" bool) )
721
722(define set-file-position!              ; DEPRECATED
723  (lambda (port pos . whence)
724    (let ([whence (if (pair? whence) (car whence) _seek_set)])
725      (##sys#check-exact pos 'set-file-position!)
726      (##sys#check-exact whence 'set-file-position!)
727      (when (fx< pos 0) (##sys#signal-hook #:bounds-error 'set-file-position! "invalid negative port position" pos port))
728      (unless (cond [(port? port)
729                     (and (eq? (##sys#slot port 7) 'stream)
730                          (##core#inline "C_fseek" port pos whence) ) ]
731                    [(fixnum? port) (##core#inline "C_lseek" port pos whence)]
732                    [else (##sys#signal-hook #:type-error 'set-file-position! "invalid file" port)] )
733        (posix-error #:file-error 'set-file-position! "cannot set file position" port pos) ) ) ) )
734
735(define file-position
736  (getter-with-setter
737   (lambda (port)
738    (let ([pos (cond [(port? port)
739                      (if (eq? (##sys#slot port 7) 'stream)
740                          (##core#inline "C_ftell" port)
741                          -1) ]
742                     [(fixnum? port) (##core#inline "C_lseek" port 0 _seek_cur)]
743                     [else (##sys#signal-hook #:type-error 'file-position "invalid file" port)] ) ] )
744      (when (fx< pos 0)
745        (posix-error #:file-error 'file-position "cannot retrieve file position of port" port) )
746      pos) )
747   set-file-position!) )
748
749
750;;; Directory stuff:
751
752(define create-directory
753  (lambda (name)
754    (##sys#check-string name 'create-directory)
755    (unless (zero? (##core#inline "C_mkdir" (##sys#make-c-string (##sys#expand-home-path name))))
756      (posix-error #:file-error 'create-directory "cannot create directory" name) ) ) )
757
758(define change-directory
759  (lambda (name)
760    (##sys#check-string name 'change-directory)
761    (unless (zero? (##core#inline "C_chdir" (##sys#make-c-string (##sys#expand-home-path name))))
762      (posix-error #:file-error 'change-directory "cannot change current directory" name) ) ) )
763
764(define delete-directory
765  (lambda (name)
766    (##sys#check-string name 'delete-directory)
767    (unless (zero? (##core#inline "C_rmdir" (##sys#make-c-string (##sys#expand-home-path name))))
768      (posix-error #:file-error 'delete-directory "cannot delete directory" name) ) ) )
769
770(define directory
771  (let ([string-ref string-ref]
772        [make-string make-string]
773        [string string] )
774    (lambda (#!optional (spec (current-directory)) show-dotfiles?)
775      (##sys#check-string spec 'directory)
776      (let ([buffer (make-string 256)]
777            [handle (##sys#make-pointer)]
778            [entry (##sys#make-pointer)] )
779        (##core#inline "C_opendir" (##sys#make-c-string (##sys#expand-home-path spec)) handle)
780        (if (##sys#null-pointer? handle)
781            (posix-error #:file-error 'directory "cannot open directory" spec)
782            (let loop ()
783              (##core#inline "C_readdir" handle entry)
784              (if (##sys#null-pointer? entry)
785                  (begin
786                    (##core#inline "C_closedir" handle)
787                    '() )
788                  (let* ([flen (##core#inline "C_foundfile" entry buffer)]
789                         [file (##sys#substring buffer 0 flen)]
790                         [char1 (string-ref file 0)]
791                         [char2 (and (fx> flen 1) (string-ref file 1))] )
792                    (if (and (eq? char1 #\.)
793                             (or (not char2)
794                                 (and (eq? char2 #\.) (eq? flen 2))
795                                 (not show-dotfiles?) ) )
796                        (loop)
797                        (cons file (loop)) ) ) ) ) ) ) ) ) )
798
799(define (directory? fname)
800  (##sys#check-string fname 'directory?)
801  (let ((info (##sys#file-info (##sys#expand-home-path fname))))
802    (and info (fx= 1 (##sys#slot info 4))) ) )
803
804(define current-directory
805  (let ([make-string make-string])
806    (lambda (#!optional dir)
807      (if dir
808          (change-directory dir)
809          (let* ([buffer (make-string 256)]
810                 [len (##core#inline "C_curdir" buffer)] )
811            (if len
812                (##sys#substring buffer 0 len)
813                (posix-error #:file-error 'current-directory "cannot retrieve current directory") ) ) ) ) ) )
814
815
816;;; Pipes:
817
818(let ()
819  (define (mode arg) (if (pair? arg) (##sys#slot arg 0) '###text))
820  (define (badmode m) (##sys#error "illegal input/output mode specifier" m))
821  (define (check loc cmd inp r)
822    (if (##sys#null-pointer? r)
823        (posix-error #:file-error loc "cannot open pipe" cmd)
824        (let ([port (##sys#make-port inp ##sys#stream-port-class "(pipe)" 'stream)])
825          (##core#inline "C_set_file_ptr" port r)
826          port) ) )
827  (set! open-input-pipe
828    (lambda (cmd . m)
829      (##sys#check-string cmd 'open-input-pipe)
830      (let ([m (mode m)])
831        (check
832         'open-input-pipe
833         cmd #t
834         (case m
835           ((#:text) (##core#inline_allocate ("open_text_input_pipe" 2) (##sys#make-c-string cmd)))
836           ((#:binary) (##core#inline_allocate ("open_binary_input_pipe" 2) (##sys#make-c-string cmd)))
837           (else (badmode m)) ) ) ) ) )
838  (set! open-output-pipe
839    (lambda (cmd . m)
840      (##sys#check-string cmd 'open-output-pipe)
841      (let ((m (mode m)))
842        (check
843         'open-output-pipe
844         cmd #f
845         (case m
846           ((#:text) (##core#inline_allocate ("open_text_output_pipe" 2) (##sys#make-c-string cmd)))
847           ((#:binary) (##core#inline_allocate ("open_binary_output_pipe" 2) (##sys#make-c-string cmd)))
848           (else (badmode m)) ) ) ) ) )
849  (set! close-input-pipe
850    (lambda (port)
851      (##sys#check-port port 'close-input-pipe)
852      (let ((r (##core#inline "close_pipe" port)))
853        (when (eq? -1 r) (posix-error #:file-error 'close-input/output-pipe "error while closing pipe" port))
854        r) ) )
855  (set! close-output-pipe close-input-pipe) )
856
857(let ([open-input-pipe open-input-pipe]
858      [open-output-pipe open-output-pipe]
859      [close-input-pipe close-input-pipe]
860      [close-output-pipe close-output-pipe] )
861  (set! call-with-input-pipe
862    (lambda (cmd proc . mode)
863      (let ([p (apply open-input-pipe cmd mode)])
864        (##sys#call-with-values
865         (lambda () (proc p))
866         (lambda results
867           (close-input-pipe p)
868           (apply values results) ) ) ) ) )
869  (set! call-with-output-pipe
870    (lambda (cmd proc . mode)
871      (let ([p (apply open-output-pipe cmd mode)])
872        (##sys#call-with-values
873         (lambda () (proc p))
874         (lambda results
875           (close-output-pipe p)
876           (apply values results) ) ) ) ) )
877  (set! with-input-from-pipe
878    (lambda (cmd thunk . mode)
879      (let ([old ##sys#standard-input]
880            [p (apply open-input-pipe cmd mode)] )
881        (set! ##sys#standard-input p)
882        (##sys#call-with-values thunk
883                                (lambda results
884                                  (close-input-pipe p)
885                                  (set! ##sys#standard-input old)
886                                  (apply values results) ) ) ) ) )
887  (set! with-output-to-pipe
888    (lambda (cmd thunk . mode)
889      (let ([old ##sys#standard-output]
890            [p (apply open-output-pipe cmd mode)] )
891        (set! ##sys#standard-output p)
892        (##sys#call-with-values thunk
893                                (lambda results
894                                  (close-output-pipe p)
895                                  (set! ##sys#standard-output old)
896                                  (apply values results) ) ) ) ) ) )
897
898(define-foreign-variable _pipefd0 int "C_pipefds[ 0 ]")
899(define-foreign-variable _pipefd1 int "C_pipefds[ 1 ]")
900
901(define create-pipe
902  (lambda ()
903    (when (fx< (##core#inline "C_pipe" #f) 0)
904      (posix-error #:file-error 'create-pipe "cannot create pipe") )
905    (values _pipefd0 _pipefd1) ) )
906
907
908;;; Signal processing:
909
910(define-foreign-variable _nsig int "NSIG")
911(define-foreign-variable _sigterm int "SIGTERM")
912(define-foreign-variable _sigkill int "SIGKILL")
913(define-foreign-variable _sigint int "SIGINT")
914(define-foreign-variable _sighup int "SIGHUP")
915(define-foreign-variable _sigfpe int "SIGFPE")
916(define-foreign-variable _sigill int "SIGILL")
917(define-foreign-variable _sigsegv int "SIGSEGV")
918(define-foreign-variable _sigabrt int "SIGABRT")
919(define-foreign-variable _sigtrap int "SIGTRAP")
920(define-foreign-variable _sigquit int "SIGQUIT")
921(define-foreign-variable _sigalrm int "SIGALRM")
922(define-foreign-variable _sigpipe int "SIGPIPE")
923(define-foreign-variable _sigusr1 int "SIGUSR1")
924(define-foreign-variable _sigusr2 int "SIGUSR2")
925(define-foreign-variable _sigvtalrm int "SIGVTALRM")
926(define-foreign-variable _sigprof int "SIGPROF")
927(define-foreign-variable _sigio int "SIGIO")
928(define-foreign-variable _sigurg int "SIGURG")
929(define-foreign-variable _sigchld int "SIGCHLD")
930(define-foreign-variable _sigcont int "SIGCONT")
931(define-foreign-variable _sigstop int "SIGSTOP")
932(define-foreign-variable _sigtstp int "SIGTSTP")
933(define-foreign-variable _sigxcpu int "SIGXCPU")
934(define-foreign-variable _sigxfsz int "SIGXFSZ")
935(define-foreign-variable _sigwinch int "SIGWINCH")
936
937(define signal/term _sigterm)
938(define signal/kill _sigkill)
939(define signal/int _sigint)
940(define signal/hup _sighup)
941(define signal/fpe _sigfpe)
942(define signal/ill _sigill)
943(define signal/segv _sigsegv)
944(define signal/abrt _sigabrt)
945(define signal/trap _sigtrap)
946(define signal/quit _sigquit)
947(define signal/alrm _sigalrm)
948(define signal/vtalrm _sigvtalrm)
949(define signal/prof _sigprof)
950(define signal/io _sigio)
951(define signal/urg _sigurg)
952(define signal/chld _sigchld)
953(define signal/cont _sigcont)
954(define signal/stop _sigstop)
955(define signal/tstp _sigtstp)
956(define signal/pipe _sigpipe)
957(define signal/xcpu _sigxcpu)
958(define signal/xfsz _sigxfsz)
959(define signal/usr1 _sigusr1)
960(define signal/usr2 _sigusr2)
961(define signal/winch _sigwinch)
962
963(define signals-list
964  (list
965    signal/term signal/kill signal/int signal/hup signal/fpe signal/ill
966    signal/segv signal/abrt signal/trap signal/quit signal/alrm signal/vtalrm
967    signal/prof signal/io signal/urg signal/chld signal/cont signal/stop
968    signal/tstp signal/pipe signal/xcpu signal/xfsz signal/usr1 signal/usr2
969    signal/winch))
970
971(let ([oldhook ##sys#interrupt-hook]
972      [sigvector (make-vector 256 #f)] )
973  (set! signal-handler
974    (lambda (sig)
975      (##sys#check-exact sig 'signal-handler)
976      (##sys#slot sigvector sig) ) )
977  (set! set-signal-handler!
978    (lambda (sig proc)
979      (##sys#check-exact sig 'set-signal-handler!)
980      (##core#inline "C_establish_signal_handler" sig (and proc sig))
981      (vector-set! sigvector sig proc) ) )
982  (set! ##sys#interrupt-hook
983    (lambda (reason state)
984      (let ([h (##sys#slot sigvector reason)])
985        (if h
986            (begin
987              (h reason)
988              (##sys#context-switch state) )
989            (oldhook reason state) ) ) ) ) )
990
991(define set-signal-mask!
992  (lambda (sigs)
993    (##sys#check-list sigs 'set-signal-mask!)
994    (##core#inline "C_sigemptyset" 0)
995    (for-each
996      (lambda (s)
997        (##sys#check-exact s 'set-signal-mask!)
998        (##core#inline "C_sigaddset" s) )
999      sigs)
1000    (when (fx< (##core#inline "C_sigprocmask_set" 0) 0)
1001      (posix-error #:process-error 'set-signal-mask! "cannot set signal mask") ) ) )
1002
1003(define (signal-mask)
1004  (let loop ([sigs signals-list] [mask '()])
1005    (if (null? sigs)
1006        mask
1007        (let ([sig (car sigs)])
1008          (loop (cdr sigs) (if (##core#inline "C_sigismember" sig) (cons sig mask) mask)) ) ) ) )
1009
1010(define (signal-masked? sig)
1011  (##sys#check-exact sig 'signal-masked?)
1012  (##core#inline "C_sigismember" sig) )
1013
1014(define (signal-mask! sig)
1015  (##sys#check-exact sig 'signal-mask!)
1016  (##core#inline "C_sigaddset" sig)
1017  (when (fx< (##core#inline "C_sigprocmask_block" 0) 0)
1018      (posix-error #:process-error 'signal-mask! "cannot block signal") )  )
1019
1020(define (signal-unmask! sig)
1021  (##sys#check-exact sig 'signal-unmask!)
1022  (##core#inline "C_sigdelset" sig)
1023  (when (fx< (##core#inline "C_sigprocmask_unblock" 0) 0)
1024      (posix-error #:process-error 'signal-unmask! "cannot unblock signal") )  )
1025
1026;;; Set SIGINT handler:
1027
1028(set-signal-handler!
1029 signal/int
1030 (lambda (n) (##sys#user-interrupt-hook)) )
1031
1032
1033;;; Getting system-, group- and user-information:
1034
1035(define-foreign-variable _uname int "C_uname")
1036(define-foreign-variable _uname-sysname nonnull-c-string "C_utsname.sysname")
1037(define-foreign-variable _uname-nodename nonnull-c-string "C_utsname.nodename")
1038(define-foreign-variable _uname-release nonnull-c-string "C_utsname.release")
1039(define-foreign-variable _uname-version nonnull-c-string "C_utsname.version")
1040(define-foreign-variable _uname-machine nonnull-c-string "C_utsname.machine")
1041
1042(define system-information
1043  (lambda ()
1044    (when (fx< _uname 0)
1045      (##sys#update-errno)
1046      (##sys#error 'system-information "cannot retrieve system information") )
1047    (list _uname-sysname
1048          _uname-nodename
1049          _uname-release
1050          _uname-version
1051          _uname-machine) ) )
1052
1053(define set-user-id!                  ; DEPRECATED
1054  (lambda (id)
1055    (when (fx< (##core#inline "C_setuid" id) 0)
1056      (##sys#update-errno)
1057      (##sys#error 'set-user-id! "cannot set user ID" id) ) ) )
1058
1059(define current-user-id
1060  (getter-with-setter
1061   (foreign-lambda int "C_getuid")
1062   set-user-id!) )
1063
1064(define current-effective-user-id
1065  (getter-with-setter
1066   (foreign-lambda int "C_geteuid")
1067   (lambda (id)
1068    (when (fx< (##core#inline "C_seteuid" id) 0)
1069      (##sys#update-errno)
1070      (##sys#error 
1071         'effective-user-id!-setter "cannot set effective user ID" id) ) ) ) )
1072
1073(define set-group-id!                 ; DEPRECATED
1074  (lambda (id)
1075    (when (fx< (##core#inline "C_setgid" id) 0)
1076      (##sys#update-errno)
1077      (##sys#error 'set-user-id! "cannot set group ID" id) ) ) )
1078
1079(define current-group-id
1080  (getter-with-setter
1081   (foreign-lambda int "C_getgid")
1082   set-group-id!) )
1083
1084(define current-effective-group-id
1085  (getter-with-setter 
1086   (foreign-lambda int "C_getegid")
1087   (lambda (id)
1088    (when (fx< (##core#inline "C_setegid" id) 0)
1089      (##sys#update-errno)
1090      (##sys#error 
1091         'effective-group-id!-setter "cannot set effective group ID" id) ) ) ) )
1092
1093(define-foreign-variable _user-name nonnull-c-string "C_user->pw_name")
1094(define-foreign-variable _user-passwd nonnull-c-string "C_user->pw_passwd")
1095(define-foreign-variable _user-uid int "C_user->pw_uid")
1096(define-foreign-variable _user-gid int "C_user->pw_gid")
1097(define-foreign-variable _user-gecos nonnull-c-string "C_user->pw_gecos")
1098(define-foreign-variable _user-dir c-string "C_user->pw_dir")
1099(define-foreign-variable _user-shell c-string "C_user->pw_shell")
1100
1101(define (user-information user #!optional as-vector)
1102  (let ([r (if (fixnum? user)
1103               (##core#inline "C_getpwuid" user)
1104               (begin
1105                 (##sys#check-string user 'user-information)
1106                 (##core#inline "C_getpwnam" (##sys#make-c-string user)) ) ) ] )
1107    (and r
1108         ((if as-vector vector list)
1109          _user-name
1110          _user-passwd
1111          _user-uid
1112          _user-gid
1113          _user-gecos
1114          _user-dir
1115          _user-shell) ) ) )
1116
1117(define (current-user-name)
1118  (list-ref (user-information (current-user-id)) 0) )
1119
1120(define (current-effective-user-name)
1121  (list-ref (user-information (current-effective-user-id)) 0) )
1122
1123(define-foreign-variable _group-name nonnull-c-string "C_group->gr_name")
1124(define-foreign-variable _group-passwd nonnull-c-string "C_group->gr_passwd")
1125(define-foreign-variable _group-gid int "C_group->gr_gid")
1126
1127(define group-member
1128  (foreign-lambda* c-string ([int i])
1129    "return(C_group->gr_mem[ i ]);") )
1130
1131(define (group-information group #!optional as-vector)
1132  (let ([r (if (fixnum? group)
1133               (##core#inline "C_getgrgid" group)
1134               (begin
1135                 (##sys#check-string group 'group-information)
1136                 (##core#inline "C_getgrnam" (##sys#make-c-string group)) ) ) ] )
1137    (and r
1138         ((if as-vector vector list)
1139          _group-name
1140          _group-passwd
1141          _group-gid
1142          (let loop ([i 0])
1143            (let ([n (group-member i)])
1144              (if n
1145                  (cons n (loop (fx+ i 1)))
1146                  '() ) ) ) ) ) ) )
1147
1148(define _get-groups
1149  (foreign-lambda* int ([int n])
1150    "return(getgroups(n, C_groups));") )
1151
1152(define _ensure-groups
1153  (foreign-lambda* bool ([int n])
1154    "if(C_groups != NULL) C_free(C_groups);"
1155    "C_groups = (gid_t *)C_malloc(sizeof(gid_t) * n);"
1156    "if(C_groups == NULL) return(0);"
1157    "else return(1);") )
1158
1159(define (get-groups)
1160  (let ([n (foreign-value "getgroups(0, C_groups)" int)])
1161    (when (fx< n 0)
1162      (##sys#update-errno)
1163      (##sys#error 'get-groups "cannot retrieve supplementary group ids") )
1164    (unless (_ensure-groups n)
1165      (##sys#error 'get-groups "out of memory") )
1166    (when (fx< (_get-groups n) 0)
1167      (##sys#update-errno)
1168      (##sys#error 'get-groups "cannot retrieve supplementary group ids") )
1169    (let loop ([i 0])
1170      (if (fx>= i n)
1171          '()
1172          (cons (##core#inline "C_get_gid" i) (loop (fx+ i 1))) ) ) ) )
1173
1174(define (set-groups! lst0)
1175  (unless (_ensure-groups (length lst0))
1176    (##sys#error 'set-groups! "out of memory") )
1177  (do ([lst lst0 (##sys#slot lst 1)]
1178       [i 0 (fx+ i 1)] )
1179      ((null? lst)
1180       (when (fx< (##core#inline "C_set_groups" i) 0)
1181       (##sys#update-errno)
1182       (##sys#error 'set-groups! "cannot set supplementary group ids" lst0) ) )
1183    (let ([n (##sys#slot lst 0)])
1184      (##sys#check-exact n 'set-groups!)
1185      (##core#inline "C_set_gid" i n) ) ) )
1186
1187(define initialize-groups
1188  (let ([init (foreign-lambda int "initgroups" c-string int)])
1189    (lambda (user id)
1190      (##sys#check-string user 'initialize-groups)
1191      (##sys#check-exact id 'initialize-groups)
1192      (when (fx< (init user id) 0)
1193      (##sys#update-errno)
1194      (##sys#error 'initialize-groups "cannot initialize supplementary group ids" user id) ) ) ) )
1195
1196
1197;;; More errno codes:
1198
1199(define-foreign-variable _errno int "errno")
1200
1201(define-foreign-variable _eperm int "EPERM")
1202(define-foreign-variable _enoent int "ENOENT")
1203(define-foreign-variable _esrch int "ESRCH")
1204(define-foreign-variable _eintr int "EINTR")
1205(define-foreign-variable _eio int "EIO")
1206(define-foreign-variable _efault int "EFAULT")
1207(define-foreign-variable _echild int "ECHILD")
1208(define-foreign-variable _enoexec int "ENOEXEC")
1209(define-foreign-variable _ebadf int "EBADF")
1210(define-foreign-variable _enomem int "ENOMEM")
1211(define-foreign-variable _eacces int "EACCES")
1212(define-foreign-variable _ebusy int "EBUSY")
1213(define-foreign-variable _eexist int "EEXIST")
1214(define-foreign-variable _enotdir int "ENOTDIR")
1215(define-foreign-variable _eisdir int "EISDIR")
1216(define-foreign-variable _einval int "EINVAL")
1217(define-foreign-variable _emfile int "EMFILE")
1218(define-foreign-variable _enospc int "ENOSPC")
1219(define-foreign-variable _espipe int "ESPIPE")
1220(define-foreign-variable _epipe int "EPIPE")
1221(define-foreign-variable _eagain int "EAGAIN")
1222(define-foreign-variable _erofs int "EROFS")
1223(define-foreign-variable _ewouldblock int "EWOULDBLOCK")
1224
1225(define errno/perm _eperm)
1226(define errno/noent _enoent)
1227(define errno/srch _esrch)
1228(define errno/intr _eintr)
1229(define errno/io _eio)
1230(define errno/noexec _enoexec)
1231(define errno/badf _ebadf)
1232(define errno/child _echild)
1233(define errno/nomem _enomem)
1234(define errno/acces _eacces)
1235(define errno/fault _efault)
1236(define errno/busy _ebusy)
1237(define errno/notdir _enotdir)
1238(define errno/isdir _eisdir)
1239(define errno/inval _einval)
1240(define errno/mfile _emfile)
1241(define errno/nospc _enospc)
1242(define errno/spipe _espipe)
1243(define errno/pipe _epipe)
1244(define errno/again _eagain)
1245(define errno/rofs _erofs)
1246(define errno/exist _eexist)
1247(define errno/wouldblock _ewouldblock)
1248
1249(define errno/2big 0)
1250(define errno/deadlk 0)
1251(define errno/dom 0)
1252(define errno/fbig 0)
1253(define errno/ilseq 0)
1254(define errno/mlink 0)
1255(define errno/nametoolong 0)
1256(define errno/nfile 0)
1257(define errno/nodev 0)
1258(define errno/nolck 0)
1259(define errno/nosys 0)
1260(define errno/notempty 0)
1261(define errno/notty 0)
1262(define errno/nxio 0)
1263(define errno/range 0)
1264(define errno/xdev 0)
1265
1266;;; Permissions and owners:
1267
1268(define change-file-mode
1269  (lambda (fname m)
1270    (##sys#check-string fname 'change-file-mode)
1271    (##sys#check-exact m 'change-file-mode)
1272    (when (fx< (##core#inline "C_chmod" (##sys#make-c-string (##sys#expand-home-path fname)) m) 0)
1273      (posix-error #:file-error 'change-file-mode "cannot change file mode" fname m) ) ) )
1274
1275(define change-file-owner
1276  (lambda (fn uid gid)
1277    (##sys#check-string fn 'change-file-owner)
1278    (##sys#check-exact uid 'change-file-owner)
1279    (##sys#check-exact gid 'change-file-owner)
1280    (when (fx< (##core#inline "C_chown" (##sys#make-c-string (##sys#expand-home-path fn)) uid gid) 0)
1281      (posix-error #:file-error 'change-file-owner "cannot change file owner" fn uid gid) ) ) )
1282
1283(define-foreign-variable _r_ok int "R_OK")
1284(define-foreign-variable _w_ok int "W_OK")
1285(define-foreign-variable _x_ok int "X_OK")
1286
1287(let ()
1288  (define (check filename acc loc)
1289    (##sys#check-string filename loc)
1290    (let ([r (fx= 0 (##core#inline "C_access" (##sys#make-c-string (##sys#expand-home-path filename)) acc))])
1291      (unless r (##sys#update-errno))
1292      r) )
1293  (set! file-read-access? (lambda (filename) (check filename _r_ok 'file-read-access?)))
1294  (set! file-write-access? (lambda (filename) (check filename _w_ok 'file-write-access?)))
1295  (set! file-execute-access? (lambda (filename) (check filename _x_ok 'file-execute-access?))) )
1296
1297(define (create-session)
1298  (let ([a (##core#inline "C_setsid" #f)])
1299    (when (fx< a 0)
1300      (##sys#update-errno)
1301      (##sys#error 'create-session "cannot create session") )
1302    a) )
1303
1304(define (set-process-group-id! pid pgid) ; DEPRECATED
1305  (##sys#check-exact pid 'set-process-group-id!)
1306  (##sys#check-exact pgid 'set-process-group-id!)
1307  (when (fx< (##core#inline "C_setpgid" pid pgid) 0)
1308    (##sys#update-errno)
1309    (##sys#error 'set-process-group-id! "cannot set process group ID" pid pgid) ) )
1310
1311(define process-group-id
1312  (getter-with-setter
1313   (lambda (pid)
1314     (##sys#check-exact pid 'process-group-id)
1315     (let ([a (##core#inline "C_getpgid" pid)])
1316       (when (fx< a 0)
1317         (##sys#update-errno)
1318         (##sys#error 'process-group-id "cannot retrieve process group ID" pid) )
1319    a) )
1320   set-process-group-id!) )
1321
1322;;; Hard and symbolic links:
1323
1324(define create-symbolic-link
1325  (lambda (old new)
1326    (##sys#check-string old 'create-symbolic-link)
1327    (##sys#check-string new 'create-symbolic-link)
1328    (when (fx< (##core#inline
1329              "C_symlink"
1330              (##sys#make-c-string (##sys#expand-home-path old))
1331              (##sys#make-c-string (##sys#expand-home-path new)) )
1332             0)
1333      (posix-error #:file-error 'create-symbol-link "cannot create symbolic link" old new) ) ) )
1334
1335(define-foreign-variable _filename_max int "FILENAME_MAX")
1336
1337(define read-symbolic-link
1338  (let ([substring substring]
1339      [buf (make-string (fx+ _filename_max 1))] )
1340    (lambda (fname)
1341      (##sys#check-string fname 'read-symbolic-link)
1342      (let ([len (##core#inline "C_readlink" (##sys#make-c-string (##sys#expand-home-path fname)) buf)])
1343      (when (fx< len 0)
1344        (posix-error #:file-error 'read-symbolic-link "cannot read symbolic link" fname) )
1345      (substring buf 0 len) ) ) ) )
1346
1347(define file-link
1348  (let ([link (foreign-lambda int "link" c-string c-string)])
1349    (lambda (old new)
1350      (##sys#check-string old 'file-link)
1351      (##sys#check-string new 'file-link)
1352      (when (fx< (link old new) 0)
1353      (posix-error #:file-error 'hard-link "could not create hard link" old new) ) ) ) )
1354
1355
1356;;; Using file-descriptors:
1357
1358(define-foreign-variable _stdin_fileno int "STDIN_FILENO")
1359(define-foreign-variable _stdout_fileno int "STDOUT_FILENO")
1360(define-foreign-variable _stderr_fileno int "STDERR_FILENO")
1361
1362(define fileno/stdin _stdin_fileno)
1363(define fileno/stdout _stdout_fileno)
1364(define fileno/stderr _stderr_fileno)
1365
1366(let ()
1367  (define (mode inp m)
1368    (##sys#make-c-string
1369     (cond [(pair? m)
1370            (let ([m (car m)])
1371              (case m
1372                [(###append) (if (not inp) "a" (##sys#error "invalid mode for input file" m))]
1373                [else (##sys#error "invalid mode argument" m)] ) ) ]
1374           [inp "r"]
1375           [else "w"] ) ) )
1376  (define (check loc fd inp r)
1377    (if (##sys#null-pointer? r)
1378        (posix-error #:file-error loc "cannot open file" fd)
1379        (let ([port (##sys#make-port inp ##sys#stream-port-class "(fdport)" 'stream)])
1380          (##core#inline "C_set_file_ptr" port r)
1381          port) ) )
1382  (set! open-input-file*
1383    (lambda (fd . m)
1384      (##sys#check-exact fd 'open-input-file*)
1385      (check 'open-input-file* fd #t (##core#inline_allocate ("C_fdopen" 2) fd (mode #t m))) ) )
1386  (set! open-output-file*
1387    (lambda (fd . m)
1388      (##sys#check-exact fd 'open-output-file*)
1389      (check 'open-output-file* fd #f (##core#inline_allocate ("C_fdopen" 2) fd (mode #f m)) ) ) ) )
1390
1391(define port->fileno
1392  (lambda (port)
1393    (##sys#check-port port 'port->fileno)
1394    (cond [(eq? 'socket (##sys#slot port 7)) (##sys#tcp-port->fileno port)]
1395          [(not (zero? (##sys#peek-unsigned-integer port 0)))
1396           (let ([fd (##core#inline "C_C_fileno" port)])
1397             (when (fx< fd 0)
1398               (posix-error #:file-error 'port->fileno "cannot access file-descriptor of port" port) )
1399             fd) ]
1400          [else (posix-error #:type-error 'port->fileno "port has no attached file" port)] ) ) )
1401
1402(define duplicate-fileno
1403  (lambda (old . new)
1404    (##sys#check-exact old duplicate-fileno)
1405    (let ([fd (if (null? new)
1406                  (##core#inline "C_dup" old)
1407                  (let ([n (car new)])
1408                    (##sys#check-exact n 'duplicate-fileno)
1409                    (##core#inline "C_dup2" old n) ) ) ] )
1410      (when (fx< fd 0)
1411        (posix-error #:file-error 'duplicate-fileno "cannot duplicate file-descriptor" old) )
1412      fd) ) )
1413
1414(define ##sys#custom-input-port
1415  (let ([make-input-port make-input-port]
1416        [set-port-name! set-port-name!] )
1417    (lambda (loc nam fd
1418               #!optional
1419               (nonblocking? #f) (bufi 1) (on-close noop) (more? #f))
1420      (when nonblocking? (##sys#file-nonblocking! fd) )
1421      (let ([bufsiz (if (fixnum? bufi) bufi (##sys#size bufi))]
1422            [buf (if (fixnum? bufi) (##sys#make-string bufi) bufi)]
1423            [buflen 0]
1424            [bufpos 0] )
1425        (let (
1426            [ready?
1427              (lambda ()
1428                (when (fx= -1 (##sys#file-select-one fd))
1429                  (posix-error #:file-error loc "cannot select" fd nam) ) )]
1430            [peek
1431              (lambda ()
1432                (if (fx>= bufpos buflen)
1433                    #!eof
1434                    (##core#inline "C_subchar" buf bufpos)) )]
1435            [fetch
1436              (lambda ()
1437                (when (fx>= bufpos buflen)
1438                  (let loop ()
1439                    (let ([cnt (##core#inline "C_read" fd buf bufsiz)])
1440                      (cond [(fx= cnt -1)
1441                              (if (fx= _errno _ewouldblock)
1442                                  (begin
1443                                    (##sys#thread-block-for-i/o! ##sys#current-thread fd #t)
1444                                    (##sys#thread-yield!)
1445                                    (loop) )
1446                                  (posix-error #:file-error loc "cannot read" fd nam) )]
1447                            [(and more? (fx= cnt 0))
1448                              ; When "more" keep trying, otherwise read once more
1449                              ; to guard against race conditions
1450                              (if (more?)
1451                                  (begin
1452                                    (##sys#thread-yield!)
1453                                    (loop) )
1454                                  (let ([cnt (##core#inline "C_read" fd buf bufsiz)])
1455                                    (when (fx= cnt -1)
1456                                      (if (fx= _errno _ewouldblock)
1457                                          (set! cnt 0)
1458                                          (posix-error #:file-error loc "cannot read" fd nam) ) )
1459                                    (set! buflen cnt)
1460                                    (set! bufpos 0) ) )]
1461                            [else
1462                              (set! buflen cnt)
1463                              (set! bufpos 0)]) ) ) ) )] )
1464          (letrec (
1465              [this-port
1466                (make-input-port
1467                  (lambda ()                    ; Read-Char
1468                    (fetch)
1469                    (let ([ch (peek)])
1470                      #; ; Allow increment since overflow is far, far away
1471                      (unless (eof-object? ch) (set! bufpos (fx+ bufpos 1)))
1472                      (set! bufpos (fx+ bufpos 1))
1473                      ch ) )
1474                  (lambda () ; Ready?
1475                    (or (fx< bufpos buflen)
1476                        (ready?)) )
1477                  (lambda ()                    ; Close
1478                    ; Do nothing when closed already
1479                    (unless (##sys#slot this-port 8)
1480                      (when (fx< (##core#inline "C_close" fd) 0)
1481                        (posix-error #:file-error loc "cannot close" fd nam) )
1482                      (on-close) ) )
1483                  (lambda ()                    ; Peek
1484                    (fetch)
1485                    (peek) )
1486                  (lambda (port n dest start)   ; Read-String!
1487                    (let loop ([n n] [m 0] [start start])
1488                      (cond [(eq? n 0) m]
1489                            [(fx< bufpos buflen)
1490                              (let* ([rest (fx- buflen bufpos)]
1491                                     [n2 (if (fx< n rest) n rest)])
1492                                (##core#inline "C_substring_copy" buf dest bufpos (fx+ bufpos n2) start)
1493                                (set! bufpos (fx+ bufpos n2))
1494                                (loop (fx- n n2) (fx+ m n2) (fx+ start n2)) ) ]
1495                            [else
1496                              (fetch)
1497                              (if (eq? buflen 0) 
1498                                  m
1499                                  (loop n m start) ) ] ) ) )
1500                  (lambda (port limit)          ; Read-Line
1501                    (let loop ([str #f])
1502                      (cond [(fx< bufpos buflen)
1503                              (##sys#scan-buffer-line
1504                                buf buflen bufpos
1505                                (lambda (cur ptr)
1506                                  (let ([dest (##sys#make-string (fx- cur bufpos))])
1507                                    (##core#inline "C_substring_copy" buf dest bufpos cur 0)
1508                                    (set! bufpos ptr)
1509                                    (cond [(eq? cur ptr) ; no line-terminator encountered
1510                                            (fetch)
1511                                            (if (fx>= bufpos buflen)
1512                                                (or str "")
1513                                                (loop (if str (##sys#string-append str dest) dest)) ) ]
1514                                          [else
1515                                            (##sys#setislot port 4 (fx+ (##sys#slot port 4) 1))
1516                                            (if str (##sys#string-append str dest) dest) ] ) ) ) ) ]
1517                            [else
1518                              (fetch)
1519                              (if (fx< bufpos buflen)
1520                                 (loop str)
1521                                 #!eof) ] ) ) ) )] )
1522            (set-port-name! this-port nam)
1523            this-port ) ) ) ) ) )
1524
1525(define ##sys#custom-output-port
1526  (let ([make-output-port make-output-port]
1527        [set-port-name! set-port-name!] )
1528    (lambda (loc nam fd
1529               #!optional
1530               (nonblocking? #f) (bufi 0) (on-close noop))
1531      (when nonblocking? (##sys#file-nonblocking! fd) )
1532      (letrec (
1533          [poke
1534            (lambda (str len)
1535              (let ([cnt (##core#inline "C_write" fd str len)])
1536                (cond [(fx= -1 cnt)
1537                        (if (fx= _errno _ewouldblock)
1538                            (begin
1539                              (##sys#thread-yield!)
1540                              (poke str len) )
1541                            (posix-error loc #:file-error "cannot write" fd nam) ) ]
1542                      [(fx< cnt len)
1543                        (poke (##sys#substring str cnt len) (fx- len cnt)) ] ) ) )]
1544          [store
1545            (let ([bufsiz (if (fixnum? bufi) bufi (##sys#size bufi))])
1546              (if (fx= 0 bufsiz)
1547                  (lambda (str)
1548                    (when str
1549                      (poke str (##sys#size str)) ) )
1550                  (let ([buf (if (fixnum? bufi) (##sys#make-string bufi) bufi)]
1551                        [bufpos 0])
1552                    (lambda (str)
1553                      (if str
1554                          (let loop ([rem (fx- bufsiz bufpos)] [start 0] [len (##sys#size str)])
1555                            (cond [(fx= 0 rem)
1556                                    (poke buf bufsiz)
1557                                    (set! bufpos 0)
1558                                    (loop bufsiz 0 len)]
1559                                  [(fx< rem len)
1560                                    (##core#inline "C_substring_copy" str buf start rem bufpos)
1561                                    (loop 0 rem (fx- len rem))]
1562                                  [else
1563                                    (##core#inline "C_substring_copy" str buf start len bufpos)
1564                                    (set! bufpos (fx+ bufpos len))] ) )
1565                          (when (fx< 0 bufpos)
1566                            (poke buf bufpos) ) ) ) ) ) )])
1567        (letrec (
1568            [this-port
1569              (make-output-port
1570                (lambda (str)           ; Write-String
1571                  (store str) )
1572                (lambda ()              ; Close
1573                  ; Do nothing when closed already
1574                  (unless (##sys#slot this-port 8)
1575                    (when (fx< (##core#inline "C_close" fd) 0)
1576                      (posix-error #:file-error loc "cannot close" fd nam) )
1577                    (on-close) ) )
1578                (lambda ()              ; Flush
1579                  (store #f) ) )] )
1580          (set-port-name! this-port nam)
1581          this-port ) ) ) ) )
1582
1583
1584;;; Other file operations:
1585
1586(define file-truncate
1587  (lambda (fname off)
1588    (##sys#check-number off 'file-truncate)
1589    (when (fx< (cond [(string? fname) (##core#inline "C_truncate" (##sys#make-c-string (##sys#expand-home-path fname)) off)]
1590                     [(fixnum? fname) (##core#inline "C_ftruncate" fname off)]
1591                     [else (##sys#error 'file-truncate "invalid file" fname)] )
1592               0)
1593      (posix-error #:file-error 'file-truncate "cannot truncate file" fname off) ) ) )
1594
1595
1596;;; Record locking:
1597
1598(define-foreign-variable _f_wrlck int "F_WRLCK")
1599(define-foreign-variable _f_rdlck int "F_RDLCK")
1600(define-foreign-variable _f_unlck int "F_UNLCK")
1601
1602(let ()
1603  (define (setup port args loc)
1604    (let-optionals* args ([start 0]
1605                          [len #t] )
1606      (##sys#check-port port loc)
1607      (##sys#check-number start loc)
1608      (if (eq? #t len)
1609          (set! len 0)
1610          (##sys#check-number len loc) )
1611      (##core#inline "C_flock_setup" (if (##sys#slot port 1) _f_rdlck _f_wrlck) start len)
1612      (##sys#make-structure 'lock port start len) ) )
1613  (define (err msg lock loc)
1614    (posix-error #:file-error loc msg (##sys#slot lock 1) (##sys#slot lock 2) (##sys#slot lock 3)) )
1615  (set! file-lock
1616    (lambda (port . args)
1617      (let ([lock (setup port args 'file-lock)])
1618        (if (fx< (##core#inline "C_flock_lock" port) 0)
1619            (err "cannot lock file" lock 'file-lock)
1620            lock) ) ) )
1621  (set! file-lock/blocking
1622    (lambda (port . args)
1623      (let ([lock (setup port args 'file-lock/blocking)])
1624        (if (fx< (##core#inline "C_flock_lockw" port) 0)
1625            (err "cannot lock file" lock 'file-lock/blocking)
1626            lock) ) ) )
1627  (set! file-test-lock
1628    (lambda (port . args)
1629      (let ([lock (setup port args 'file-test-lock)])
1630        (cond [(##core#inline "C_flock_test" port) => (lambda (c) (and (not (fx= c 0)) c))]
1631              [else (err "cannot unlock file" lock 'file-test-lock)] ) ) ) ) )
1632
1633(define file-unlock
1634  (lambda (lock)
1635    (##sys#check-structure lock 'lock 'file-unlock)
1636    (##core#inline "C_flock_setup" _f_unlck (##sys#slot lock 2) (##sys#slot lock 3))
1637    (when (fx< (##core#inline "C_flock_lock" (##sys#slot lock 1)) 0)
1638      (posix-error #:file-error 'file-unlock "cannot unlock file" lock) ) ) )
1639
1640
1641;;; FIFOs:
1642
1643(define create-fifo
1644  (lambda (fname . mode)
1645    (##sys#check-string fname 'create-fifo)
1646    (let ([mode (if (pair? mode) (car mode) (fxior _s_irwxu (fxior _s_irwxg _s_irwxo)))])
1647      (##sys#check-exact mode 'create-fifo)
1648      (when (fx< (##core#inline "C_mkfifo" (##sys#make-c-string (##sys#expand-home-path fname)) mode) 0)
1649      (posix-error #:file-error 'create-fifo "cannot create FIFO" fname mode) ) ) ) )
1650
1651(define fifo?
1652  (lambda (filename)
1653    (##sys#check-string filename 'fifo?)
1654    (let ([v (##sys#file-info (##sys#expand-home-path filename))])
1655      (if v
1656          (fx= 3 (##sys#slot v 4))
1657          (posix-error #:file-error 'fifo? "file does not exist" filename) ) ) ) )
1658
1659;;; Environment access:
1660
1661(define setenv
1662  (lambda (var val)
1663    (##sys#check-string var 'setenv)
1664    (##sys#check-string val 'setenv)
1665    (##core#inline "C_setenv" (##sys#make-c-string var) (##sys#make-c-string val))
1666    (##core#undefined) ) )
1667
1668(define (unsetenv var)
1669  (##sys#check-string var 'unsetenv)
1670  (##core#inline "C_putenv" (##sys#make-c-string var))
1671  (##core#undefined) )
1672
1673(define current-environment
1674  (let ([get (foreign-lambda c-string "C_getenventry" int)])
1675    (lambda ()
1676      (let loop ([i 0])
1677        (let ([entry (get i)])
1678          (if entry
1679              (let scan ([j 0])
1680                (if (char=? #\= (##core#inline "C_subchar" entry j))
1681                    (cons (cons (##sys#substring entry 0 j)
1682                                (##sys#substring entry (fx+ j 1) (##sys#size entry)))
1683                          (loop (fx+ i 1)))
1684                    (scan (fx+ j 1)) ) )
1685              '() ) ) ) ) ) )
1686
1687;;; Memory mapped I/O:
1688
1689(define-foreign-variable _prot_read int "PROT_READ")
1690(define-foreign-variable _prot_write int "PROT_WRITE")
1691(define-foreign-variable _prot_exec int "PROT_EXEC")
1692(define-foreign-variable _prot_none int "PROT_NONE")
1693
1694(define prot/read _prot_read)
1695(define prot/write _prot_write)
1696(define prot/exec _prot_exec)
1697(define prot/none _prot_none)
1698
1699(define-foreign-variable _map_fixed int "MAP_FIXED")
1700(define-foreign-variable _map_shared int "MAP_SHARED")
1701(define-foreign-variable _map_private int "MAP_PRIVATE")
1702(define-foreign-variable _map_anonymous int "MAP_ANON")
1703(define-foreign-variable _map_file int "MAP_FILE")
1704
1705(define map/fixed _map_fixed)
1706(define map/shared _map_shared)
1707(define map/private _map_private)
1708(define map/anonymous _map_anonymous)
1709(define map/file _map_file)
1710
1711(define map-file-to-memory
1712  (let ([mmap (foreign-lambda c-pointer "mmap" c-pointer integer int int int integer)] )
1713    (lambda (addr len prot flag fd . off)
1714      (let ([addr (if (not addr) (##sys#null-pointer) addr)]
1715            [off (if (pair? off) (car off) 0)] )
1716        (unless (and (##core#inline "C_blockp" addr) (##core#inline "C_specialp" addr))
1717                (##sys#signal-hook #:type-error 'map-file-to-memory "bad argument type - not a foreign pointer" addr) )
1718        (let ([addr2 (mmap addr len prot flag fd off)])
1719          (when (eq? -1 (##sys#pointer->address addr2))
1720                (posix-error #:file-error 'map-file-to-memory "cannot map file to memory" addr len prot flag fd off) )
1721          (##sys#make-structure 'mmap addr2 len) ) ) ) ) )
1722
1723(define unmap-file-from-memory
1724  (let ([munmap (foreign-lambda int "munmap" c-pointer integer)] )
1725    (lambda (mmap . len)
1726      (##sys#check-structure mmap 'mmap 'unmap-file-from-memory)
1727      (let ([len (if (pair? len) (car len) (##sys#slot mmap 2))])
1728        (unless (eq? 0 (munmap (##sys#slot mmap 1) len))
1729                (posix-error #:file-error 'unmap-file-from-memory "cannot unmap file from memory" mmap len) ) ) ) ) )
1730
1731(define (memory-mapped-file-pointer mmap)
1732  (##sys#check-structure mmap 'mmap 'memory-mapped-file-pointer)
1733  (##sys#slot mmap 1) )
1734
1735(define (memory-mapped-file? x)
1736  (##sys#structure? x 'mmap) )
1737
1738;;; Time related things:
1739
1740(define (seconds->local-time secs)
1741  (##sys#check-number secs 'seconds->local-time)
1742  (##sys#decode-seconds secs #f) )
1743
1744(define (seconds->utc-time secs)
1745  (##sys#check-number secs 'seconds->utc-time)
1746  (##sys#decode-seconds secs #t) )
1747
1748(define seconds->string
1749  (let ([ctime (foreign-lambda c-string "C_ctime" integer)])
1750    (lambda (secs)
1751      (let ([str (ctime secs)])
1752        (unless str (##sys#error 'seconds->string "cannot convert seconds to string" secs))
1753        (##sys#substring str 0 (fx- (##sys#size str) 1))))))
1754
1755(define time->string
1756  (let ([asctime (foreign-lambda c-string "C_asctime" scheme-object)])
1757    (lambda (tm)
1758      (##sys#check-vector tm 'time->string)
1759      (when (fx< (##sys#size tm) 10) (##sys#error 'time->string "time vector too short" tm))
1760      (let ([str (asctime tm)])
1761        (unless str (##sys#error 'time->string "cannot convert time vector to string" tm))
1762        (##sys#substring str 0 (fx- (##sys#size str) 1))))))
1763
1764(define (local-time->seconds tm)
1765  (##sys#check-vector tm 'local-time->seconds)
1766  (when (fx< (##sys#size tm) 10) (##sys#error 'local-time->seconds "time vector too short" tm))
1767  (if (##core#inline "C_mktime" tm)
1768      (##sys#cons-flonum)
1769      (##sys#error 'local-time->seconds "cannot convert time vector to seconds" tm) ) )
1770
1771(define (utc-time->seconds tm)
1772  (##sys#check-vector tm 'utc-time->seconds)
1773  (when (fx< (##sys#size tm) 10) (##sys#error 'utc-time->seconds "time vector too short" tm))
1774  (if (##core#inline "C_timegm" tm)
1775      (##sys#cons-flonum)
1776      (##sys#error 'utc-time->seconds "cannot convert time vector to seconds" tm) ) )
1777
1778(define local-timezone-abbreviation
1779  (foreign-lambda* c-string ()
1780   "\n#if !defined(__CYGWIN__) && !defined(__SVR4) && !defined(__uClinux__) && !defined(__hpux__)\n"
1781   "time_t clock = (time_t)0;"
1782   "struct tm *ltm = C_localtime(&clock);"
1783   "char *z = ltm ? (char *)ltm->tm_zone : 0;"
1784   "\n#else\n"
1785   "char *z = (daylight ? tzname[1] : tzname[0]);"
1786   "\n#endif\n"
1787   "return(z);") )
1788
1789
1790;;; Other things:
1791
1792(define _exit
1793  (let ([ex0 (foreign-lambda void "_exit" int)])
1794    (lambda code
1795      (ex0 (if (pair? code) (car code) 0)) ) ) )
1796
1797(define set-alarm! (foreign-lambda int "C_alarm" int))
1798
1799(define-foreign-variable _iofbf int "_IOFBF")
1800(define-foreign-variable _iolbf int "_IOLBF")
1801(define-foreign-variable _ionbf int "_IONBF")
1802(define-foreign-variable _bufsiz int "BUFSIZ")
1803
1804(define set-buffering-mode!
1805    (lambda (port mode . size)
1806      (##sys#check-port port 'set-buffering-mode!)
1807      (let ([size (if (pair? size) (car size) _bufsiz)]
1808            [mode (case mode
1809                    [(###full) _iofbf]
1810                    [(###line) _iolbf]
1811                    [(###none) _ionbf]
1812                    [else (##sys#error 'set-buffering-mode! "invalid buffering-mode" mode port)] ) ] )
1813        (##sys#check-exact size 'set-buffering-mode!)
1814        (when (fx< (if (eq? 'stream (##sys#slot port 7))
1815                       (##core#inline "C_setvbuf" port mode size)
1816                       -1)
1817                   0)
1818          (##sys#error 'set-buffering-mode! "cannot set buffering mode" port mode size) ) ) ) )
1819
1820(define (terminal-port? port)
1821  (##sys#check-port port 'terminal-port?)
1822  (let ([fp (##sys#peek-unsigned-integer port 0)])
1823    (and (not (eq? fp 0)) (##core#inline "C_tty_portp" port) ) ) )
1824
1825(define (##sys#terminal-check caller port)
1826  (##sys#check-port port caller)
1827  (unless (and (eq? 'stream (##sys#slot port 7))
1828               (##core#inline "C_tty_portp" port))
1829          (##sys#error caller "port is not connected to a terminal" port)))
1830
1831(define terminal-name
1832  (let ([ttyname (foreign-lambda nonnull-c-string "ttyname" int)] )
1833    (lambda (port)
1834      (##sys#terminal-check 'terminal-name port)
1835      (ttyname (##core#inline "C_C_fileno" port) ) ) ) )
1836
1837(define terminal-size
1838  (let ((ttysize (foreign-lambda int "get_tty_size" int
1839                                 (nonnull-c-pointer int)
1840                                 (nonnull-c-pointer int))))
1841    (lambda (port)
1842      (##sys#terminal-check 'terminal-size port)
1843      (let-location ((columns int)
1844                     (rows int))
1845                    (if (fx= 0
1846                             (ttysize (##core#inline "C_C_fileno" port)
1847                                      (location columns)
1848                                      (location rows)))
1849                        (values columns rows)
1850                        (posix-error #:error 'terminal-size
1851                                     "Unable to get size of terminal" port))))))
1852 
1853(define get-host-name
1854  (let ([getit
1855       (foreign-lambda* c-string ()
1856         "if(gethostname(C_hostbuf, 256) == -1) return(NULL);"
1857         "else return(C_hostbuf);") ] )
1858    (lambda ()
1859      (let ([host (getit)])
1860        (unless host
1861          (posix-error #:error 'get-host-name "cannot retrieve host-name") )
1862        host) ) ) )
1863
1864
1865;;; Filename globbing:
1866
1867(define glob
1868  (let ([regexp regexp]
1869        [make-anchored-pattern make-anchored-pattern]
1870        [string-match string-match]
1871        [glob->regexp glob->regexp]
1872        [directory directory]
1873        [make-pathname make-pathname]
1874        [decompose-pathname decompose-pathname] )
1875    (lambda paths
1876      (let conc-loop ([paths paths])
1877        (if (null? paths)
1878            '()
1879            (let ([path (car paths)])
1880              (let-values ([(dir fil ext) (decompose-pathname path)])
1881                (let* ([fnpatt (glob->regexp (make-pathname #f (or fil "*") ext))]
1882                       [patt (make-anchored-pattern fnpatt)]
1883                       [rx (regexp patt)])
1884                  (let loop ([fns (directory (or dir ".") #t)])
1885                    (cond [(null? fns) (conc-loop (cdr paths))]
1886                          [(string-match rx (car fns))
1887                           => (lambda (m) (cons (make-pathname dir (car m)) (loop (cdr fns)))) ]
1888                          [else (loop (cdr fns))] ) ) ) ) ) ) ) ) ) )
1889
1890
1891;;; Process handling:
1892
1893(define process-fork
1894  (let ([fork (foreign-lambda int "C_fork")])
1895    (lambda thunk
1896      (let ([pid (fork)])
1897      (cond [(fx= -1 pid) (posix-error #:process-error 'process-fork "cannot create child process")]
1898            [(and (pair? thunk) (fx= pid 0))
1899             ((car thunk))
1900             ((foreign-lambda void "_exit" int) 0) ]
1901            [else pid] ) ) ) ) )
1902
1903(define process-execute
1904  (let ([setarg (foreign-lambda void "C_set_exec_arg" int scheme-pointer int)]
1905        [freeargs (foreign-lambda void "C_free_exec_args")]
1906        [setenv (foreign-lambda void "C_set_exec_env" int scheme-pointer int)]
1907        [freeenv (foreign-lambda void "C_free_exec_env")]
1908        [pathname-strip-directory pathname-strip-directory] )
1909    (lambda (filename #!optional (arglist '()) envlist)
1910      (##sys#check-string filename 'process-execute)
1911      (##sys#check-list arglist 'process-execute)
1912      (let ([s (pathname-strip-directory filename)])
1913        (setarg 0 s (##sys#size s)) )
1914      (do ([al arglist (cdr al)]
1915           [i 1 (fx+ i 1)] )
1916          ((null? al)
1917           (setarg i #f 0)
1918           (when envlist
1919             (##sys#check-list envlist 'process-execute)
1920             (do ([el envlist (cdr el)]
1921                  [i 0 (fx+ i 1)] )
1922                 ((null? el) (setenv i #f 0))
1923               (let ([s (car el)])
1924                 (##sys#check-string s 'process-execute)
1925                 (setenv i s (##sys#size s)) ) ) )
1926           (let* ([prg (##sys#make-c-string (##sys#expand-home-path filename))]
1927                  [r (if envlist
1928                         (##core#inline "C_execve" prg)
1929                         (##core#inline "C_execvp" prg) )] )
1930             (when (fx= r -1)
1931               (freeargs)
1932               (freeenv)
1933               (posix-error #:process-error 'process-execute "cannot execute process" filename) ) ) )
1934        (let ([s (car al)])
1935          (##sys#check-string s 'process-execute)
1936          (setarg i s (##sys#size s)) ) ) ) ) )
1937
1938(define-foreign-variable _wnohang int "WNOHANG")
1939(define-foreign-variable _wait-status int "C_wait_status")
1940
1941(define (##sys#process-wait pid nohang)
1942  (let* ([res (##core#inline "C_waitpid" pid (if nohang _wnohang 0))]
1943         [norm (##core#inline "C_WIFEXITED" _wait-status)] )
1944    (values
1945      res
1946      norm
1947      (cond [norm (##core#inline "C_WEXITSTATUS" _wait-status)]
1948            [(##core#inline "C_WIFSIGNALED" _wait-status)
1949              (##core#inline "C_WTERMSIG" _wait-status)]
1950            [else (##core#inline "C_WSTOPSIG" _wait-status)] ) ) ) )
1951
1952(define process-wait
1953  (lambda args
1954    (let-optionals* args ([pid #f] [nohang #f])
1955      (let ([pid (or pid -1)])
1956        (##sys#check-exact pid 'process-wait)
1957        (receive [epid enorm ecode] (##sys#process-wait pid nohang)
1958          (if (fx= epid -1)
1959              (posix-error #:process-error 'process-wait "waiting for child process failed" pid)
1960              (values epid enorm ecode) ) ) ) ) ) )
1961
1962(define current-process-id (foreign-lambda int "C_getpid"))
1963(define parent-process-id (foreign-lambda int "C_getppid"))
1964
1965(define sleep (foreign-lambda int "C_sleep" int))
1966
1967(define process-signal
1968  (lambda (id . sig)
1969    (let ([sig (if (pair? sig) (car sig) _sigterm)])
1970      (##sys#check-exact id 'process-signal)
1971      (##sys#check-exact sig 'process-signal)
1972      (let ([r (##core#inline "C_kill" id sig)])
1973      (when (fx= r -1) (posix-error #:process-error 'process-signal "could not send signal to process" id sig) ) ) ) ) )
1974
1975(define (##sys#shell-command)
1976  (or (getenv "SHELL") "/bin/sh") )
1977
1978(define (##sys#shell-command-arguments cmdlin)
1979  (list "-c" cmdlin) )
1980
1981(define process-run
1982  (let ([process-fork process-fork]
1983        [process-execute process-execute]
1984        [getenv getenv] )
1985    (lambda (f . args)
1986      (let ([args (if (pair? args) (car args) #f)]
1987            [pid (process-fork)] )
1988        (cond [(not (eq? pid 0)) pid]
1989              [args (process-execute f args)]
1990              [else
1991               (process-execute (##sys#shell-command) (##sys#shell-command-arguments f)) ] ) ) ) ) )
1992
1993;;; Run subprocess connected with pipes:
1994
1995;; ##sys#process
1996; loc            caller procedure symbol
1997; cmd            pathname or commandline
1998; args           string-list or '()
1999; env            string-list or #f
2000; stdoutf        #f then share, or #t then create
2001; stdinf         #f then share, or #t then create
2002; stderrf        #f then share, or #t then create
2003;
2004; (values stdin-input-port? stdout-output-port? pid stderr-input-port?)
2005; where stdin-input-port?, etc. is a port or #f, indicating no port created.
2006
2007(define-constant DEFAULT-INPUT-BUFFER-SIZE 256)
2008(define-constant DEFAULT-OUTPUT-BUFFER-SIZE 0)
2009
2010;FIXME process-execute, process-fork don't show parent caller
2011
2012(define ##sys#process
2013  (let (
2014      [create-pipe create-pipe]
2015      [process-wait process-wait]
2016      [process-fork process-fork]
2017      [process-execute process-execute]
2018      [duplicate-fileno duplicate-fileno]
2019      [file-close file-close]
2020      [replace-fd
2021        (lambda (loc fd stdfd)
2022          (unless (fx= stdfd fd)
2023            (duplicate-fileno fd stdfd)
2024            (file-close fd) ) )] )
2025    (let (
2026        [make-on-close
2027          (lambda (loc pid clsvec idx idxa idxb)
2028            (lambda ()
2029              (vector-set! clsvec idx #t)
2030              (when (and (vector-ref clsvec idxa) (vector-ref clsvec idxb))
2031                (receive [_ flg cod] (process-wait pid)
2032                  (unless flg
2033                    (##sys#signal-hook #:process-error loc
2034                      "abnormal process exit" pid cod)) ) ) ) )]
2035        [needed-pipe
2036          (lambda (loc port)
2037            (and port
2038                 (receive [i o] (create-pipe) (cons i o))) )]
2039        [connect-parent
2040          (lambda (loc pipe port fd)
2041            (and port
2042                 (let ([usefd (car pipe)] [clsfd (cdr pipe)])
2043                   (file-close clsfd)
2044                   usefd) ) )]
2045        [connect-child
2046          (lambda (loc pipe port stdfd)
2047            (when port
2048              (let ([usefd (car pipe)] [clsfd (cdr pipe)])
2049                (file-close clsfd)
2050                (replace-fd loc usefd stdfd)) ) )] )
2051      (let (
2052          [spawn
2053            (let ([swapped-ends
2054                    (lambda (pipe)
2055                      (and pipe
2056                           (cons (cdr pipe) (car pipe)) ) )])
2057              (lambda (loc cmd args env stdoutf stdinf stderrf)
2058                (let ([ipipe (needed-pipe loc stdinf)]
2059                      [opipe (needed-pipe loc stdoutf)]
2060                      [epipe (needed-pipe loc stderrf)])
2061                  (values
2062                    ipipe (swapped-ends opipe) epipe
2063                    (process-fork
2064                      (lambda ()
2065                        (connect-child loc opipe stdinf fileno/stdin)
2066                        (connect-child loc (swapped-ends ipipe) stdoutf fileno/stdout)
2067                        (connect-child loc (swapped-ends epipe) stderrf fileno/stderr)
2068                        (process-execute cmd args env)))) ) ) )]
2069          [input-port
2070            (lambda (loc pid cmd pipe stdf stdfd on-close)
2071              (and-let* ([fd (connect-parent loc pipe stdf stdfd)])
2072                (##sys#custom-input-port loc cmd fd #t DEFAULT-INPUT-BUFFER-SIZE on-close) ) )]
2073          [output-port
2074            (lambda (loc pid cmd pipe stdf stdfd on-close)
2075              (and-let* ([fd (connect-parent loc pipe stdf stdfd)])
2076                (##sys#custom-output-port loc cmd fd #t DEFAULT-OUTPUT-BUFFER-SIZE on-close) ) )] )
2077        (lambda (loc cmd args env stdoutf stdinf stderrf)
2078          (receive [inpipe outpipe errpipe pid]
2079                     (spawn loc cmd args env stdoutf stdinf stderrf)
2080            ;When shared assume already "closed", since only created ports
2081            ;should be explicitly closed, and when one is closed we want
2082            ;to wait.
2083            (let ([clsvec (vector (not stdinf) (not stdoutf) (not stderrf))])
2084              (values
2085                (input-port loc pid cmd inpipe stdinf fileno/stdin
2086                  (make-on-close loc pid clsvec 0 1 2))
2087                (output-port loc pid cmd outpipe stdoutf fileno/stdout
2088                  (make-on-close loc pid clsvec 1 0 2))
2089                pid
2090                (input-port loc pid cmd errpipe stderrf fileno/stderr
2091                  (make-on-close loc pid clsvec 2 0 1)) ) ) ) ) ) ) ) )
2092
2093;;; Run subprocess connected with pipes:
2094
2095(define process)
2096(define process*)
2097(let ([%process
2098        (lambda (loc err? cmd args env)
2099          (let ([chkstrlst
2100                 (lambda (lst)
2101                   (##sys#check-list lst loc)
2102                   (for-each (cut ##sys#check-string <> loc) lst) )])
2103            (##sys#check-string cmd loc)
2104            (if args
2105                (chkstrlst args)
2106                (begin
2107                  (set! args (##sys#shell-command-arguments cmd))
2108                  (set! cmd (##sys#shell-command)) ) )
2109            (when env (chkstrlst env))
2110            (receive [in out pid err] (##sys#process loc cmd args env #t #t err?)
2111              (if err?
2112                  (values in out pid err)
2113                  (values in out pid) ) ) ) )] )
2114  (set! process
2115    (lambda (cmd #!optional args env)
2116      (%process 'process #f cmd args env) ))
2117  (set! process*
2118    (lambda (cmd #!optional args env)
2119      (%process 'process* #t cmd args env) )) )
2120
2121;;; Find matching files:
2122
2123(define find-files
2124  (let ([glob glob]
2125        [string-match string-match]
2126        [make-pathname make-pathname]
2127        [directory? directory?] )
2128    (lambda (dir pred . action-id-limit)
2129      (let-optionals
2130          action-id-limit
2131          ([action (lambda (x y) (cons x y))] ; we want cons inlined
2132           [id '()]
2133           [limit #f] )
2134        (##sys#check-string dir 'find-files)
2135        (let* ([depth 0]
2136               [lproc
2137                (cond [(not limit) (lambda _ #t)]
2138                      [(fixnum? limit) (lambda _ (fx< depth limit))]
2139                      [else limit] ) ]
2140               [pproc
2141                (if (or (string? pred) (regexp? pred))
2142                    (lambda (x) (string-match pred x))
2143                    pred) ] )
2144          (let loop ([fs (glob (make-pathname dir "*"))]
2145                     [r id] )
2146            (if (null? fs)
2147                r
2148                (let ([f (##sys#slot fs 0)]
2149                      [rest (##sys#slot fs 1)] )
2150                  (cond [(directory? f)
2151                         (cond [(member (pathname-file f) '("." "..")) (loop rest r)]
2152                               [(lproc f)
2153                                (loop rest
2154                                      (fluid-let ([depth (fx+ depth 1)])
2155                                        (loop (glob (make-pathname f "*"))
2156                                              (if (pproc f) (action f r) r)) ) ) ]
2157                               [else (loop rest (if (pproc f) (action f r) r))] ) ]
2158                        [(pproc f) (loop rest (action f r))]
2159                        [else (loop rest r)] ) ) ) ) ) ) ) ) )
2160
2161
2162;;; chroot:
2163
2164(define set-root-directory!
2165  (let ([chroot (foreign-lambda int "chroot" c-string)])
2166    (lambda (dir)
2167      (##sys#check-string dir 'set-root-directory!)
2168      (when (fx< (chroot dir) 0)
2169        (posix-error #:file-error 'set-root-directory! "unable to change root directory" dir) ) ) ) )
Note: See TracBrowser for help on using the repository browser.