source: project/chicken/trunk/posixunix.scm @ 8361

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

probably fixed 64-bit literal bug and changed copyrights

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