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