Context Navigation

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

Last change on this file since 6376 was 6376, checked in by Kon Lovett, 13 years ago
Forgot new files must be in manifest. Added 'current-user-name' function to windows & unix posix.
File size: 87.3 KB

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

Note: See TracBrowser for help on using the repository browser.

Download in other formats: