Context Navigation

source: project/chicken/branches/hygienic/posixunix.scm @ 10712

Last change on this file since 10712 was 10712, checked in by felix winkelmann, 13 years ago
various tests and improvements
File size: 91.0 KB

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