source: project/trunk/posixunix.scm @ 5360

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