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) ) ) ) ) ] ) |
---|