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

Last change on this file since 15913 was 15913, checked in by Kon Lovett, 10 years ago

'local-timezone-abbreviation' wasn't using the current time so tz-name constant.

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