source: project/chicken/trunk/posixwin.scm @ 9316

Last change on this file since 9316 was 9316, checked in by elf, 12 years ago

fixes

File size: 66.4 KB
Line 
1;;;; posixwin.scm - Miscellaneous file- and process-handling routines, available on Windows
2;
3; By Sergey Khorev
4;
5; Copyright (c) 2000-2007, Felix L. Winkelmann
6; Copyright (c) 2008, The Chicken Team
7; All rights reserved.
8;
9; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
10; conditions are met:
11;
12;   Redistributions of source code must retain the above copyright notice, this list of conditions and the following
13;     disclaimer.
14;   Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
15;     disclaimer in the documentation and/or other materials provided with the distribution.
16;   Neither the name of the author nor the names of its contributors may be used to endorse or promote
17;     products derived from this software without specific prior written permission.
18;
19; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
20; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
21; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
22; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
23; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
24; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
25; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
26; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
27; POSSIBILITY OF SUCH DAMAGE.
28
29
30; Not implemented:
31;
32; open/noctty  open/nonblock  open/fsync  open/sync
33; perm/isvtx  perm/isuid  perm/isgid
34; file-select
35; symbolic-link?
36; set-signal-mask!  signal-mask  signal-masked?  signal-mask!  signal-unmask!
37; user-information group-information  get-groups  set-groups!  initialize-groups
38; errno/wouldblock
39; change-file-owner
40; current-user-id  current-group-id  current-effective-user-id  current-effective-group-id
41; current-effective-user-name
42; set-user-id!  set-group-id!
43; create-session
44; process-group-id  set-process-group-id!
45; create-symbolic-link  read-symbolic-link
46; file-truncate
47; file-lock  file-lock/blocking  file-unlock  file-test-lock
48; create-fifo  fifo?
49; prot/...
50; map/...
51; map-file-to-memory  unmap-file-from-memory  memory-mapped-file-pointer  memory-mapped-file?
52; set-alarm!
53; terminal-port?  terminal-name
54; process-fork  process-wait
55; parent-process-id
56; process-signal
57
58
59; Issues
60;
61; - Use of a UTF8 encoded string will not work properly. Windows uses a
62; 16-bit UNICODE character string encoding and specialized system calls
63; and/or structure settings for the use of such strings.
64
65
66(declare
67  (unit posix)
68  (uses scheduler regex extras utils)
69  (disable-interrupts)
70  (usual-integrations)
71  (hide ##sys#stat close-handle posix-error
72        $quote-args-list $exec-setup $exec-teardown)
73  (foreign-declare #<<EOF
74#ifndef WIN32_LEAN_AND_MEAN
75# define WIN32_LEAN_AND_MEAN
76#endif
77
78/*
79MinGW should have winsock2.h and ws2tcpip.h as well.
80The CMake build will set HAVE_WINSOCK2_H and HAVE_WS2TCPIP_H.
81However, the _MSC_VER test is still needed for vcbuild.bat.
82./configure doesn't test for these.  It should, for MinGW.
83*/
84#if (_MSC_VER > 1300) || (defined(HAVE_WINSOCK2_H) && defined(HAVE_WS2TCPIP_H))
85# include <winsock2.h>
86# include <ws2tcpip.h>
87#else
88# include <winsock.h>
89#endif
90
91#include <signal.h>
92#include <errno.h>
93#include <io.h>
94#include <stdio.h>
95#include <process.h>
96
97static int C_not_implemented(void);
98int C_not_implemented() { return -1; }
99
100#include <sys/types.h>
101#include <sys/stat.h>
102#include <fcntl.h>
103#include <direct.h>
104
105#include <time.h>
106
107#define ARG_MAX         256
108#define PIPE_BUF        512
109#ifndef ENV_MAX
110# define ENV_MAX        1024
111#endif
112
113static C_TLS char *C_exec_args[ ARG_MAX ];
114static C_TLS char *C_exec_env[ ENV_MAX ];
115static C_TLS struct group *C_group;
116static C_TLS int C_pipefds[ 2 ];
117static C_TLS time_t C_secs;
118static C_TLS struct tm C_tm;
119static C_TLS struct stat C_statbuf;
120
121/* pipe handles */
122static C_TLS HANDLE C_rd0, C_wr0, C_wr0_, C_rd1, C_wr1, C_rd1_;
123static C_TLS HANDLE C_save0, C_save1; /* saved I/O handles */
124static C_TLS char C_rdbuf; /* one-char buffer for read */
125static C_TLS int C_exstatus;
126
127/* platform information; initialized for cached testing */
128static C_TLS char C_hostname[256] = "";
129static C_TLS char C_osver[16] = "";
130static C_TLS char C_osrel[16] = "";
131static C_TLS char C_processor[16] = "";
132static C_TLS char C_shlcmd[256] = "";
133
134/* Windows NT or better */
135static int C_isNT = 0;
136
137/* Current user name */
138static C_TLS TCHAR C_username[255 + 1] = "";
139
140/* Directory Operations */
141
142#define C_mkdir(str)        C_fix(mkdir(C_c_string(str)))
143#define C_chdir(str)        C_fix(chdir(C_c_string(str)))
144#define C_rmdir(str)        C_fix(rmdir(C_c_string(str)))
145
146#ifndef __WATCOMC__
147/* DIRENT stuff */
148struct dirent
149{
150    char *              d_name;
151};
152
153typedef struct
154{
155    struct _finddata_t  fdata;
156    int                 handle;
157    struct dirent       current;
158} DIR;
159
160static DIR * C_fcall
161opendir(const char *name)
162{
163    int name_len = strlen(name);
164    DIR *dir = (DIR *)malloc(sizeof(DIR));
165    char *what;
166    if (!dir)
167    {
168        errno = ENOMEM;
169        return NULL;
170    }
171    what = (char *)malloc(name_len + 3);
172    if (!what)
173    {
174        free(dir);
175        errno = ENOMEM;
176        return NULL;
177    }
178    strcpy(what, name);
179    if (strchr("\\/", name[name_len - 1]))
180        strcat(what, "*");
181    else
182        strcat(what, "\\*");
183
184    dir->handle = _findfirst(what, &dir->fdata);
185    if (dir->handle == -1)
186    {
187        free(what);
188        free(dir);
189        return NULL;
190    }
191    dir->current.d_name = NULL; /* as the first-time indicator */
192    free(what);
193    return dir;
194}
195
196static int C_fcall
197closedir(DIR * dir)
198{
199    if (dir)
200    {
201        int res = _findclose(dir->handle);
202        free(dir);
203        return res;
204    }
205    return -1;
206}
207
208static struct dirent * C_fcall
209readdir(DIR * dir)
210{
211    if (dir)
212    {
213        if (!dir->current.d_name /* first time after opendir */
214             || _findnext(dir->handle, &dir->fdata) != -1)
215        {
216            dir->current.d_name = dir->fdata.name;
217            return &dir->current;
218        }
219    }
220    return NULL;
221}
222#endif /* ifndef __WATCOMC__ */
223
224#ifdef __WATCOMC__
225# define mktemp _mktemp
226/* there is no P_DETACH in Watcom CRTL */
227# define P_DETACH P_NOWAIT
228#endif
229
230#define C_opendir(x,h)          C_set_block_item(h, 0, (C_word) opendir(C_c_string(x)))
231#define C_closedir(h)           (closedir((DIR *)C_block_item(h, 0)), C_SCHEME_UNDEFINED)
232#define C_readdir(h,e)          C_set_block_item(e, 0, (C_word) readdir((DIR *)C_block_item(h, 0)))
233#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)))
234
235#define C_curdir(buf)       (getcwd(C_c_string(buf), 256) ? C_fix(strlen(C_c_string(buf))) : C_SCHEME_FALSE)
236
237#define open_binary_input_pipe(a, n, name)   C_mpointer(a, _popen(C_c_string(name), "r"))
238#define open_text_input_pipe(a, n, name)     open_binary_input_pipe(a, n, name)
239#define open_binary_output_pipe(a, n, name)  C_mpointer(a, _popen(C_c_string(name), "w"))
240#define open_text_output_pipe(a, n, name)    open_binary_output_pipe(a, n, name)
241#define close_pipe(p)                        C_fix(_pclose(C_port_file(p)))
242
243#define C_set_file_ptr(port, ptr)  (C_set_block_item(port, 0, (C_block_item(ptr, 0))), C_SCHEME_UNDEFINED)
244
245#define C_getpid            getpid
246#define C_chmod(fn, m)      C_fix(chmod(C_data_pointer(fn), C_unfix(m)))
247#define C_fdopen(a, n, fd, m) C_mpointer(a, fdopen(C_unfix(fd), C_c_string(m)))
248#define C_C_fileno(p)       C_fix(fileno(C_port_file(p)))
249#define C_dup(x)            C_fix(dup(C_unfix(x)))
250#define C_dup2(x, y)        C_fix(dup2(C_unfix(x), C_unfix(y)))
251#define C_setvbuf(p, m, s)  C_fix(setvbuf(C_port_file(p), NULL, C_unfix(m), C_unfix(s)))
252#define C_access(fn, m)     C_fix(access((char *)C_data_pointer(fn), C_unfix(m)))
253#define C_pipe(d, m)        C_fix(_pipe(C_pipefds, PIPE_BUF, C_unfix(m)))
254#define C_close(fd)         C_fix(close(C_unfix(fd)))
255
256#define C_getenventry(i)   environ[ i ]
257
258#define C_putenv(s)         C_fix(putenv((char *)C_data_pointer(s)))
259#define C_stat(fn)          C_fix(stat((char *)C_data_pointer(fn), &C_statbuf))
260#define C_fstat(f)          C_fix(fstat(C_unfix(f), &C_statbuf))
261
262static C_word C_fcall
263C_setenv(C_word x, C_word y)
264{
265    char *sx = C_data_pointer(x),
266         *sy = C_data_pointer(y);
267    int n1 = C_strlen(sx),
268        n2 = C_strlen(sy);
269    char *buf = (char *)C_malloc(n1 + n2 + 2);
270    if (buf == NULL)
271        return(C_fix(0));
272    else
273    {
274        C_strcpy(buf, sx);
275        buf[ n1 ] = '=';
276        C_strcpy(buf + n1 + 1, sy);
277        return(C_fix(putenv(buf)));
278    }
279}
280
281static void C_fcall
282C_set_arg_string(char **where, int i, char *dat, int len)
283{
284    char *ptr;
285    if (dat)
286    {
287        ptr = (char *)C_malloc(len + 1);
288        C_memcpy(ptr, dat, len);
289        ptr[ len ] = '\0';
290    }
291    else
292        ptr = NULL;
293    where[ i ] = ptr;
294}
295
296static void C_fcall
297C_free_arg_string(char **where) {
298  while (*where) C_free(*(where++));
299}
300
301#define C_set_exec_arg(i, a, len)       C_set_arg_string(C_exec_args, i, a, len)
302#define C_set_exec_env(i, a, len)       C_set_arg_string(C_exec_env, i, a, len)
303
304#define C_free_exec_args()              (C_free_arg_string(C_exec_args), C_SCHEME_TRUE)
305#define C_free_exec_env()               (C_free_arg_string(C_exec_env), C_SCHEME_TRUE)
306
307#define C_execvp(f)         C_fix(execvp(C_data_pointer(f), (const char *const *)C_exec_args))
308#define C_execve(f)         C_fix(execve(C_data_pointer(f), (const char *const *)C_exec_args, (const char *const *)C_exec_env))
309
310/* MS replacement for the fork-exec pair */
311#define C_spawnvp(m, f)     C_fix(spawnvp(C_unfix(m), C_data_pointer(f), (const char *const *)C_exec_args))
312#define C_spawnvpe(m, f)    C_fix(spawnvpe(C_unfix(m), C_data_pointer(f), (const char *const *)C_exec_args, (const char *const *)C_exec_env))
313
314#define C_open(fn, fl, m)   C_fix(open(C_c_string(fn), C_unfix(fl), C_unfix(m)))
315#define C_read(fd, b, n)    C_fix(read(C_unfix(fd), C_data_pointer(b), C_unfix(n)))
316#define C_write(fd, b, n)   C_fix(write(C_unfix(fd), C_data_pointer(b), C_unfix(n)))
317#define C_mkstemp(t)        C_fix(mktemp(C_c_string(t)))
318
319#define C_ftell(p)          C_fix(ftell(C_port_file(p)))
320#define C_fseek(p, n, w)    C_mk_nbool(fseek(C_port_file(p), C_unfix(n), C_unfix(w)))
321#define C_lseek(fd, o, w)   C_fix(lseek(C_unfix(fd), C_unfix(o), C_unfix(w)))
322
323#define C_flushall()        C_fix(_flushall())
324
325#define C_ctime(n)          (C_secs = (n), ctime(&C_secs))
326
327#define C_tm_set_08(v) \
328        (memset(&C_tm, 0, sizeof(struct tm)), \
329        C_tm.tm_sec = C_unfix(C_block_item(v, 0)), \
330        C_tm.tm_min = C_unfix(C_block_item(v, 1)), \
331        C_tm.tm_hour = C_unfix(C_block_item(v, 2)), \
332        C_tm.tm_mday = C_unfix(C_block_item(v, 3)), \
333        C_tm.tm_mon = C_unfix(C_block_item(v, 4)), \
334        C_tm.tm_year = C_unfix(C_block_item(v, 5)), \
335        C_tm.tm_wday = C_unfix(C_block_item(v, 6)), \
336        C_tm.tm_yday = C_unfix(C_block_item(v, 7)), \
337        C_tm.tm_isdst = (C_block_item(v, 8) != C_SCHEME_FALSE))
338
339#define C_tm_set(v) (C_tm_set_08(v), &C_tm)
340
341#define C_asctime(v)    (asctime(C_tm_set(v)))
342#define C_mktime(v)     ((C_temporary_flonum = mktime(C_tm_set(v))) != -1)
343
344#define TIME_STRING_MAXLENGTH 255
345static char C_time_string [TIME_STRING_MAXLENGTH + 1];
346#undef TIME_STRING_MAXLENGTH
347
348#define C_strftime(v, f) \
349        (strftime(C_time_string, sizeof(C_time_string), C_c_string(f), C_tm_set(v)) ? C_time_string : NULL)
350
351/*
352  mapping from Win32 error codes to errno
353*/
354
355typedef struct
356{
357    DWORD   win32;
358    int     libc;
359} errmap_t;
360
361static errmap_t errmap[] =
362{
363    {ERROR_INVALID_FUNCTION,      EINVAL},
364    {ERROR_FILE_NOT_FOUND,        ENOENT},
365    {ERROR_PATH_NOT_FOUND,        ENOENT},
366    {ERROR_TOO_MANY_OPEN_FILES,   EMFILE},
367    {ERROR_ACCESS_DENIED,         EACCES},
368    {ERROR_INVALID_HANDLE,        EBADF},
369    {ERROR_ARENA_TRASHED,         ENOMEM},
370    {ERROR_NOT_ENOUGH_MEMORY,     ENOMEM},
371    {ERROR_INVALID_BLOCK,         ENOMEM},
372    {ERROR_BAD_ENVIRONMENT,       E2BIG},
373    {ERROR_BAD_FORMAT,            ENOEXEC},
374    {ERROR_INVALID_ACCESS,        EINVAL},
375    {ERROR_INVALID_DATA,          EINVAL},
376    {ERROR_INVALID_DRIVE,         ENOENT},
377    {ERROR_CURRENT_DIRECTORY,     EACCES},
378    {ERROR_NOT_SAME_DEVICE,       EXDEV},
379    {ERROR_NO_MORE_FILES,         ENOENT},
380    {ERROR_LOCK_VIOLATION,        EACCES},
381    {ERROR_BAD_NETPATH,           ENOENT},
382    {ERROR_NETWORK_ACCESS_DENIED, EACCES},
383    {ERROR_BAD_NET_NAME,          ENOENT},
384    {ERROR_FILE_EXISTS,           EEXIST},
385    {ERROR_CANNOT_MAKE,           EACCES},
386    {ERROR_FAIL_I24,              EACCES},
387    {ERROR_INVALID_PARAMETER,     EINVAL},
388    {ERROR_NO_PROC_SLOTS,         EAGAIN},
389    {ERROR_DRIVE_LOCKED,          EACCES},
390    {ERROR_BROKEN_PIPE,           EPIPE},
391    {ERROR_DISK_FULL,             ENOSPC},
392    {ERROR_INVALID_TARGET_HANDLE, EBADF},
393    {ERROR_INVALID_HANDLE,        EINVAL},
394    {ERROR_WAIT_NO_CHILDREN,      ECHILD},
395    {ERROR_CHILD_NOT_COMPLETE,    ECHILD},
396    {ERROR_DIRECT_ACCESS_HANDLE,  EBADF},
397    {ERROR_NEGATIVE_SEEK,         EINVAL},
398    {ERROR_SEEK_ON_DEVICE,        EACCES},
399    {ERROR_DIR_NOT_EMPTY,         ENOTEMPTY},
400    {ERROR_NOT_LOCKED,            EACCES},
401    {ERROR_BAD_PATHNAME,          ENOENT},
402    {ERROR_MAX_THRDS_REACHED,     EAGAIN},
403    {ERROR_LOCK_FAILED,           EACCES},
404    {ERROR_ALREADY_EXISTS,        EEXIST},
405    {ERROR_FILENAME_EXCED_RANGE,  ENOENT},
406    {ERROR_NESTING_NOT_ALLOWED,   EAGAIN},
407    {ERROR_NOT_ENOUGH_QUOTA,      ENOMEM},
408    {0, 0}
409};
410
411static void C_fcall
412set_errno(DWORD w32err)
413{
414    errmap_t *map = errmap;
415    for (; errmap->win32; ++map)
416    {
417        if (errmap->win32 == w32err)
418        {
419            errno = errmap->libc;
420            return;
421        }
422    }
423}
424
425static int C_fcall
426set_last_errno()
427{
428    set_errno(GetLastError());
429    return 0;
430}
431
432/* Functions for creating process with redirected I/O */
433
434static int C_fcall
435zero_handles()
436{
437    C_rd0 = C_wr0 = C_wr0_ = INVALID_HANDLE_VALUE;
438    C_rd1 = C_wr1 = C_rd1_ = INVALID_HANDLE_VALUE;
439    C_save0 = C_save1 = INVALID_HANDLE_VALUE;
440    return 1;
441}
442
443static int C_fcall
444close_handles()
445{
446    if (C_rd0 != INVALID_HANDLE_VALUE)
447        CloseHandle(C_rd0);
448    if (C_rd1 != INVALID_HANDLE_VALUE)
449        CloseHandle(C_rd1);
450    if (C_wr0 != INVALID_HANDLE_VALUE)
451        CloseHandle(C_wr0);
452    if (C_wr1 != INVALID_HANDLE_VALUE)
453        CloseHandle(C_wr1);
454    if (C_rd1_ != INVALID_HANDLE_VALUE)
455        CloseHandle(C_rd1_);
456    if (C_wr0_ != INVALID_HANDLE_VALUE)
457        CloseHandle(C_wr0_);
458    if (C_save0 != INVALID_HANDLE_VALUE)
459    {
460        SetStdHandle(STD_INPUT_HANDLE, C_save0);
461        CloseHandle(C_save0);
462    }
463    if (C_save1 != INVALID_HANDLE_VALUE)
464    {
465        SetStdHandle(STD_OUTPUT_HANDLE, C_save1);
466        CloseHandle(C_save1);
467    }
468    return zero_handles();
469}
470
471static int C_fcall
472redir_io()
473{
474    SECURITY_ATTRIBUTES sa;
475    sa.nLength = sizeof(SECURITY_ATTRIBUTES);
476    sa.bInheritHandle = TRUE;
477    sa.lpSecurityDescriptor = NULL;
478
479    zero_handles();
480
481    C_save0 = GetStdHandle(STD_INPUT_HANDLE);
482    C_save1 = GetStdHandle(STD_OUTPUT_HANDLE);
483    if (!CreatePipe(&C_rd0, &C_wr0, &sa, 0)
484            || !SetStdHandle(STD_INPUT_HANDLE, C_rd0)
485            || !DuplicateHandle(GetCurrentProcess(), C_wr0, GetCurrentProcess(),
486                &C_wr0_, 0, FALSE, DUPLICATE_SAME_ACCESS)
487            || !CreatePipe(&C_rd1, &C_wr1, &sa, 0)
488            || !SetStdHandle(STD_OUTPUT_HANDLE, C_wr1)
489            || !DuplicateHandle(GetCurrentProcess(), C_rd1, GetCurrentProcess(),
490                &C_rd1_, 0, FALSE, DUPLICATE_SAME_ACCESS))
491    {
492        set_last_errno();
493        close_handles();
494        return 0;
495    }
496
497    CloseHandle(C_wr0);
498    C_wr0 = INVALID_HANDLE_VALUE;
499    CloseHandle(C_rd1);
500    C_rd1 = INVALID_HANDLE_VALUE;
501    return 1;
502}
503
504static int C_fcall
505run_process(char *cmdline)
506{
507    PROCESS_INFORMATION pi;
508    STARTUPINFO si;
509
510    ZeroMemory(&pi, sizeof(PROCESS_INFORMATION));
511    ZeroMemory(&si, sizeof(STARTUPINFO));
512    si.cb = sizeof(STARTUPINFO);
513
514    C_wr0_ = C_rd1_ = INVALID_HANDLE_VALUE; /* these handles are saved */
515
516    if (CreateProcess(NULL, cmdline, NULL, NULL, TRUE, 0, NULL,
517                      NULL, &si, &pi))
518    {
519        CloseHandle(pi.hThread);
520
521        SetStdHandle(STD_INPUT_HANDLE, C_save0);
522        SetStdHandle(STD_OUTPUT_HANDLE, C_save1);
523        C_save0 = C_save1 = INVALID_HANDLE_VALUE;
524
525        CloseHandle(C_rd0);
526        CloseHandle(C_wr1);
527        C_rd0 = C_wr1 = INVALID_HANDLE_VALUE;
528        return (int)pi.hProcess;
529    }
530    else
531        return set_last_errno();
532}
533
534static int C_fcall
535pipe_write(int hpipe, void* buf, int count)
536{
537    DWORD done = 0;
538    if (WriteFile((HANDLE)hpipe, buf, count, &done, NULL))
539        return 1;
540    else
541        return set_last_errno();
542}
543
544static int C_fcall
545pipe_read(int hpipe)
546{
547    DWORD done = 0;
548    /* TODO:
549    if (!pipe_ready(hpipe))
550        go_to_sleep;
551    */
552    if (ReadFile((HANDLE)hpipe, &C_rdbuf, 1, &done, NULL))
553    {
554        if (done > 0) /* not EOF yet */
555            return 1;
556        else
557            return -1;
558    }
559    return set_last_errno();
560}
561
562static int C_fcall
563pipe_ready(int hpipe)
564{
565    DWORD avail = 0;
566    if (PeekNamedPipe((HANDLE)hpipe, NULL, 0, NULL, &avail, NULL) && avail)
567        return 1;
568    else
569    {
570        Sleep(0); /* give pipe a chance */
571        if (PeekNamedPipe((HANDLE)hpipe, NULL, 0, NULL, &avail, NULL))
572            return (avail > 0);
573        else
574            return 0;
575    }
576}
577
578#define C_zero_handles() C_fix(zero_handles())
579#define C_close_handles() C_fix(close_handles())
580#define C_redir_io() (redir_io() ? C_SCHEME_TRUE : C_SCHEME_FALSE)
581#define C_run_process(cmdline) C_fix(run_process(C_c_string(cmdline)))
582#define C_pipe_write(h, b, n) (pipe_write(C_unfix(h), C_c_string(b), C_unfix(n)) ? C_SCHEME_TRUE : C_SCHEME_FALSE)
583#define C_pipe_read(h) C_fix(pipe_read(C_unfix(h)))
584#define C_pipe_ready(h) (pipe_ready(C_unfix(h)) ? C_SCHEME_TRUE : C_SCHEME_FALSE)
585#define close_handle(h) CloseHandle((HANDLE)h)
586
587static int C_fcall
588process_wait(int h, int t)
589{
590    if (WaitForSingleObject((HANDLE)h, (t ? 0 : INFINITE)) == WAIT_OBJECT_0)
591    {
592        DWORD ret;
593        if (GetExitCodeProcess((HANDLE)h, &ret))
594        {
595            CloseHandle((HANDLE)h);
596            C_exstatus = ret;
597            return 1;
598        }
599    }
600    return set_last_errno();
601}
602
603#define C_process_wait(p, t) (process_wait(C_unfix(p), C_truep(t)) ? C_SCHEME_TRUE : C_SCHEME_FALSE)
604#define C_sleep(t) (Sleep(C_unfix(t) * 1000), C_SCHEME_UNDEFINED)
605
606static int C_fcall
607get_hostname()
608{
609    /* Do we already have hostname? */
610    if (strlen(C_hostname))
611    {
612        return 1;
613    }
614    else
615    {
616        WSADATA wsa;
617        if (WSAStartup(MAKEWORD(1, 1), &wsa) == 0)
618        {
619            int nok = gethostname(C_hostname, sizeof(C_hostname));
620            WSACleanup();
621            return !nok;
622        }
623        return 0;
624    }
625}
626
627static int C_fcall
628sysinfo()
629{
630    /* Do we need to build the sysinfo? */
631    if (!strlen(C_osrel))
632    {
633        OSVERSIONINFO ovf;
634        ZeroMemory(&ovf, sizeof(ovf));
635        ovf.dwOSVersionInfoSize = sizeof(ovf);
636        if (get_hostname() && GetVersionEx(&ovf))
637        {
638            SYSTEM_INFO si;
639            _snprintf(C_osver, sizeof(C_osver) - 1, "%d.%d.%d",
640                        ovf.dwMajorVersion, ovf.dwMinorVersion, ovf.dwBuildNumber);
641            strncpy(C_osrel, "Win", sizeof(C_osrel) - 1);
642            switch (ovf.dwPlatformId)
643            {
644            case VER_PLATFORM_WIN32s:
645                strncpy(C_osrel, "Win32s", sizeof(C_osrel) - 1);
646                break;
647            case VER_PLATFORM_WIN32_WINDOWS:
648                if (ovf.dwMajorVersion == 4)
649                {
650                    if (ovf.dwMinorVersion == 0)
651                        strncpy(C_osrel, "Win95", sizeof(C_osrel) - 1);
652                    else if (ovf.dwMinorVersion == 10)
653                        strncpy(C_osrel, "Win98", sizeof(C_osrel) - 1);
654                    else if (ovf.dwMinorVersion == 90)
655                        strncpy(C_osrel, "WinMe", sizeof(C_osrel) - 1);
656                }
657                break;
658            case VER_PLATFORM_WIN32_NT:
659                C_isNT = 1;
660                if (ovf.dwMajorVersion == 6)
661                    strncpy(C_osrel, "WinVista", sizeof(C_osrel) - 1);
662                else if (ovf.dwMajorVersion == 5)
663                {
664                    if (ovf.dwMinorVersion == 2)
665                        strncpy(C_osrel, "WinServer2003", sizeof(C_osrel) - 1);
666                    else if (ovf.dwMinorVersion == 1)
667                        strncpy(C_osrel, "WinXP", sizeof(C_osrel) - 1);
668                    else if ( ovf.dwMinorVersion == 0)
669                        strncpy(C_osrel, "Win2000", sizeof(C_osrel) - 1);
670                }
671                else if (ovf.dwMajorVersion <= 4)
672                   strncpy(C_osrel, "WinNT", sizeof(C_osrel) - 1);
673                break;
674            }
675            GetSystemInfo(&si);
676            strncpy(C_processor, "Unknown", sizeof(C_processor) - 1);
677            switch (si.wProcessorArchitecture)
678            {
679            case PROCESSOR_ARCHITECTURE_INTEL:
680                strncpy(C_processor, "x86", sizeof(C_processor) - 1);
681                break;
682#           ifdef PROCESSOR_ARCHITECTURE_IA64
683            case PROCESSOR_ARCHITECTURE_IA64:
684                strncpy(C_processor, "IA64", sizeof(C_processor) - 1);
685                break;
686#           endif
687#           ifdef PROCESSOR_ARCHITECTURE_AMD64
688            case PROCESSOR_ARCHITECTURE_AMD64:
689                strncpy(C_processor, "x64", sizeof(C_processor) - 1);
690                break;
691#           endif
692#           ifdef PROCESSOR_ARCHITECTURE_IA32_ON_WIN64
693            case PROCESSOR_ARCHITECTURE_IA32_ON_WIN64:
694                strncpy(C_processor, "WOW64", sizeof(C_processor) - 1);
695                break;
696#           endif
697            }
698        }
699        else
700            return set_last_errno();
701    }
702    return 1;
703}
704
705static int C_fcall
706get_shlcmd()
707{
708    /* Do we need to build the shell command pathname? */
709    if (!strlen(C_shlcmd))
710    {
711        if (sysinfo())
712        {
713            char *cmdnam = C_isNT ? "\\cmd.exe" : "\\command.com";
714            UINT len = GetSystemDirectory(C_shlcmd, sizeof(C_shlcmd) - strlen(cmdnam));
715            if (len)
716                strcpy(C_shlcmd + len, cmdnam);
717            else
718                return set_last_errno();
719        }
720        else
721            return 0;
722    }
723    return 1;
724}
725
726#define C_get_hostname() (get_hostname() ? C_SCHEME_TRUE : C_SCHEME_FALSE)
727#define C_sysinfo() (sysinfo() ? C_SCHEME_TRUE : C_SCHEME_FALSE)
728#define C_get_shlcmd() (get_shlcmd() ? C_SCHEME_TRUE : C_SCHEME_FALSE)
729
730/* GetUserName */
731
732static int C_fcall
733get_user_name()
734{
735    if (!strlen(C_username))
736    {
737        DWORD bufCharCount = sizeof(C_username) / sizeof(C_username[0]);
738        if (!GetUserName(C_username, &bufCharCount))
739            return set_last_errno();
740    }
741    return 1;
742}
743
744#define C_get_user_name() (get_user_name() ? C_SCHEME_TRUE : C_SCHEME_FALSE)
745
746/* User Information */
747
748#if 0
749static int C_fcall
750get_netinfo()
751{
752    HINSTANCE hNet = 0,
753              hLoc = 0;
754
755    if (isNT)
756        hNet = LoadLibrary("netapi32.dll");
757    else
758    {
759        hLoc = LoadLibrary("rlocal32.dll");
760        hNet = LoadLibrary("radmin32.dll");
761        //hNet = LoadLibrary("netapi.dll");
762    }
763
764    if (!hNet)
765        return 0;
766
767   
768}
769#endif
770
771/*
772    Spawn a process directly.
773    Params:
774    app         Command to execute.
775    cmdlin      Command line (arguments).
776    env         Environment for the new process (may be NULL).
777    handle, stdin, stdout, stderr
778                Spawned process info are returned in integers.
779                When spawned process shares standard io stream with the parent
780                process the respective value in handle, stdin, stdout, stderr
781                is -1.
782    params      A bitmask controling operation.
783                Bit 1: Child & parent share standard input if this bit is set.
784                Bit 2: Share standard output if bit is set.
785                Bit 3: Share standard error if bit is set.
786
787    Returns: zero return value indicates failure.
788*/
789static int C_fcall
790C_process(const char * app, const char * cmdlin, const char ** env,
791          int * phandle,
792          int * pstdin_fd, int * pstdout_fd, int * pstderr_fd,
793          int params)
794{
795    int i;
796    int success = TRUE;
797    const int f_share_io[3] = { params & 1, params & 2, params & 4};
798    int io_fds[3] = { -1, -1, -1 };
799    HANDLE
800        child_io_handles[3] = { NULL, NULL, NULL },
801        standard_io_handles[3] = {
802            GetStdHandle(STD_INPUT_HANDLE),
803            GetStdHandle(STD_OUTPUT_HANDLE),
804            GetStdHandle(STD_ERROR_HANDLE)};
805    const char modes[3] = "rww";
806    HANDLE cur_process = GetCurrentProcess(), child_process = NULL;
807    void* envblk = NULL;
808
809    /****** create io handles & fds ***/
810
811    for (i=0; i<3 && success; ++i)
812    {
813        if (f_share_io[i])
814        {
815            success = DuplicateHandle(
816                cur_process, standard_io_handles[i],
817                cur_process, &child_io_handles[i],
818                0, FALSE, DUPLICATE_SAME_ACCESS);
819        }
820        else
821        {
822            HANDLE a, b;
823            success = CreatePipe(&a,&b,NULL,0);
824            if(success)
825            {
826                HANDLE parent_end;
827                if (modes[i]=='r') { child_io_handles[i]=a; parent_end=b; }
828                else               { parent_end=a; child_io_handles[i]=b; }
829                success = (io_fds[i] = _open_osfhandle((long)parent_end,0)) >= 0;
830            }
831        }
832    }
833
834    /****** make handles inheritable */
835
836    for (i=0; i<3 && success; ++i)
837        success = SetHandleInformation(child_io_handles[i], HANDLE_FLAG_INHERIT, -1);
838
839#if 0 /* Requires a sorted list by key! */
840    /****** create environment block if necessary ****/
841
842    if (env && success)
843    {
844        char** p;
845        int len = 0;
846
847        for (p = env; *p; ++p) len += strlen(*p) + 1;
848
849        if (envblk = C_malloc(len + 1))
850        {
851            char* pb = (char*)envblk;
852            for (p = env; *p; ++p)
853            {
854                strcpy(pb, *p);
855                pb += strlen(*p) + 1;
856            }
857            *pb = '\0';
858        }
859        else
860            success = FALSE;
861    }
862#endif
863
864    /****** finally spawn process ****/
865
866    if (success)
867    {
868        PROCESS_INFORMATION pi;
869        STARTUPINFO si;
870
871        ZeroMemory(&pi,sizeof pi);
872        ZeroMemory(&si,sizeof si);
873        si.cb = sizeof si;
874        si.dwFlags = STARTF_USESTDHANDLES;
875        si.hStdInput = child_io_handles[0];
876        si.hStdOutput = child_io_handles[1];
877        si.hStdError = child_io_handles[2];
878
879        /* FIXME passing 'app' param causes failure & possible stack corruption */
880        success = CreateProcess(
881            NULL, (char*)cmdlin, NULL, NULL, TRUE, 0, envblk, NULL, &si, &pi);
882
883        if (success)
884        {
885            child_process=pi.hProcess;
886            CloseHandle(pi.hThread);
887        }
888        else
889            set_last_errno();
890    }
891    else
892        set_last_errno();
893
894    /****** cleanup & return *********/
895
896    /* parent must close child end */
897    for (i=0; i<3; ++i) CloseHandle(child_io_handles[i]);
898
899    if (success)
900    {
901        *phandle = (int)child_process;
902        *pstdin_fd = io_fds[0];
903        *pstdout_fd = io_fds[1];
904        *pstderr_fd = io_fds[2];
905    }
906    else
907    {
908        for (i=0; i<3; ++i) _close(io_fds[i]);
909    }
910
911    return success;
912}
913EOF
914) )
915
916(cond-expand
917 [paranoia]
918 [else
919  (declare
920    (no-bound-checks)
921    (no-procedure-checks-for-usual-bindings)
922    (bound-to-procedure
923     ##sys#make-port ##sys#file-info ##sys#update-errno ##sys#fudge ##sys#make-c-string ##sys#check-port
924     ##sys#error ##sys#signal-hook ##sys#peek-unsigned-integer ##sys#process
925     ##sys#peek-fixnum ##sys#make-structure ##sys#check-structure ##sys#enable-interrupts) ) ] )
926
927(cond-expand
928 [unsafe
929  (eval-when (compile)
930    (define-macro (##sys#check-structure . _) '(##core#undefined))
931    (define-macro (##sys#check-range . _) '(##core#undefined))
932    (define-macro (##sys#check-pair . _) '(##core#undefined))
933    (define-macro (##sys#check-list . _) '(##core#undefined))
934    (define-macro (##sys#check-symbol . _) '(##core#undefined))
935    (define-macro (##sys#check-string . _) '(##core#undefined))
936    (define-macro (##sys#check-char . _) '(##core#undefined))
937    (define-macro (##sys#check-exact . _) '(##core#undefined))
938    (define-macro (##sys#check-port . _) '(##core#undefined))
939    (define-macro (##sys#check-number . _) '(##core#undefined))
940    (define-macro (##sys#check-byte-vector . _) '(##core#undefined)) ) ]
941 [else
942  (declare (emit-exports "posix.exports"))] )
943
944(register-feature! 'posix)
945
946(define posix-error
947  (let ([strerror (foreign-lambda c-string "strerror" int)]
948        [string-append string-append] )
949    (lambda (type loc msg . args)
950      (let ([rn (##sys#update-errno)])
951        (apply ##sys#signal-hook type loc (string-append msg " - " (strerror rn)) args) ) ) ) )
952
953(define ##sys#posix-error posix-error)
954
955
956;;; Lo-level I/O:
957
958(define-foreign-variable _pipe_buf int "PIPE_BUF")
959
960(define pipe/buf _pipe_buf)
961
962(define-foreign-variable _o_rdonly int "O_RDONLY")
963(define-foreign-variable _o_wronly int "O_WRONLY")
964(define-foreign-variable _o_rdwr int "O_RDWR")
965(define-foreign-variable _o_creat int "O_CREAT")
966(define-foreign-variable _o_append int "O_APPEND")
967(define-foreign-variable _o_excl int "O_EXCL")
968(define-foreign-variable _o_trunc int "O_TRUNC")
969(define-foreign-variable _o_binary int "O_BINARY")
970(define-foreign-variable _o_text int "O_TEXT")
971(define-foreign-variable _o_noinherit int "O_NOINHERIT")
972
973(define open/rdonly _o_rdonly)
974(define open/wronly _o_wronly)
975(define open/rdwr _o_rdwr)
976(define open/read _o_rdwr)
977(define open/write _o_wronly)
978(define open/creat _o_creat)
979(define open/append _o_append)
980(define open/excl _o_excl)
981(define open/trunc _o_trunc)
982(define open/binary _o_binary)
983(define open/text _o_text)
984(define open/noinherit _o_noinherit)
985
986(define-foreign-variable _s_irusr int "S_IREAD")
987(define-foreign-variable _s_iwusr int "S_IWRITE")
988(define-foreign-variable _s_ixusr int "S_IEXEC")
989(define-foreign-variable _s_irgrp int "S_IREAD")
990(define-foreign-variable _s_iwgrp int "S_IWRITE")
991(define-foreign-variable _s_ixgrp int "S_IEXEC")
992(define-foreign-variable _s_iroth int "S_IREAD")
993(define-foreign-variable _s_iwoth int "S_IWRITE")
994(define-foreign-variable _s_ixoth int "S_IEXEC")
995(define-foreign-variable _s_irwxu int "S_IREAD | S_IWRITE | S_IEXEC")
996(define-foreign-variable _s_irwxg int "S_IREAD | S_IWRITE | S_IEXEC")
997(define-foreign-variable _s_irwxo int "S_IREAD | S_IWRITE | S_IEXEC")
998
999(define perm/irusr _s_irusr)
1000(define perm/iwusr _s_iwusr)
1001(define perm/ixusr _s_ixusr)
1002(define perm/irgrp _s_irgrp)
1003(define perm/iwgrp _s_iwgrp)
1004(define perm/ixgrp _s_ixgrp)
1005(define perm/iroth _s_iroth)
1006(define perm/iwoth _s_iwoth)
1007(define perm/ixoth _s_ixoth)
1008(define perm/irwxu _s_irwxu)
1009(define perm/irwxg _s_irwxg)
1010(define perm/irwxo _s_irwxo)
1011
1012(define file-open
1013  (let ([defmode (bitwise-ior _s_irwxu (fxior _s_irgrp _s_iroth))] )
1014    (lambda (filename flags . mode)
1015      (let ([mode (if (pair? mode) (car mode) defmode)])
1016        (##sys#check-string filename 'file-open)
1017        (##sys#check-exact flags 'file-open)
1018        (##sys#check-exact mode 'file-open)
1019        (let ([fd (##core#inline "C_open" (##sys#make-c-string (##sys#expand-home-path filename)) flags mode)])
1020          (when (eq? -1 fd)
1021            (##sys#update-errno)
1022            (##sys#signal-hook #:file-error 'file-open "cannot open file" filename flags mode) )
1023          fd) ) ) ) )
1024
1025(define file-close
1026  (lambda (fd)
1027    (##sys#check-exact fd 'file-close)
1028    (when (fx< (##core#inline "C_close" fd) 0)
1029      (##sys#update-errno)
1030      (##sys#signal-hook #:file-error 'file-close "cannot close file" fd) ) ) )
1031
1032(define file-read
1033  (let ([make-string make-string] )
1034    (lambda (fd size . buffer)
1035      (##sys#check-exact fd 'file-read)
1036      (##sys#check-exact size 'file-read)
1037      (let ([buf (if (pair? buffer) (car buffer) (make-string size))])
1038        (unless (and (##core#inline "C_blockp" buf) (##core#inline "C_byteblockp" buf))
1039          (##sys#signal-hook #:type-error 'file-read "bad argument type - not a string or blob" buf) )
1040        (let ([n (##core#inline "C_read" fd buf size)])
1041          (when (eq? -1 n)
1042            (##sys#update-errno)
1043            (##sys#signal-hook #:file-error 'file-read "cannot read from file" fd size) )
1044          (list buf n) ) ) ) ) )
1045
1046(define file-write
1047  (lambda (fd buffer . size)
1048    (##sys#check-exact fd 'file-write)
1049    (unless (and (##core#inline "C_blockp" buffer) (##core#inline "C_byteblockp" buffer))
1050      (##sys#signal-hook #:type-error 'file-write "bad argument type - not a string or blob" buffer) )
1051    (let ([size (if (pair? size) (car size) (##sys#size buffer))])
1052      (##sys#check-exact size 'file-write)
1053      (let ([n (##core#inline "C_write" fd buffer size)])
1054        (when (eq? -1 n)
1055          (##sys#update-errno)
1056          (##sys#signal-hook #:file-error 'file-write "cannot write to file" fd size) )
1057        n) ) ) )
1058
1059(define file-mkstemp
1060  (let ([string-length string-length])
1061    (lambda (template)
1062      (##sys#check-string template 'file-mkstemp)
1063      (let* ([buf (##sys#make-c-string template)]
1064             [fd (##core#inline "C_mkstemp" buf)]
1065             [path-length (string-length buf)])
1066        (when (eq? -1 fd)
1067          (##sys#update-errno)
1068          (##sys#signal-hook #:file-error 'file-mkstemp "cannot create temporary file" template) )
1069        (values fd (##sys#substring buf 0 (fx- path-length 1) ) ) ) ) ) )
1070
1071
1072;;; File attribute access:
1073
1074(define-foreign-variable _seek_set int "SEEK_SET")
1075(define-foreign-variable _seek_cur int "SEEK_CUR")
1076(define-foreign-variable _seek_end int "SEEK_END")
1077
1078(define seek/set _seek_set)
1079(define seek/end _seek_end)
1080(define seek/cur _seek_cur)
1081
1082(define-foreign-variable _stat_st_ino unsigned-int "C_statbuf.st_ino")
1083(define-foreign-variable _stat_st_nlink unsigned-int "C_statbuf.st_nlink")
1084(define-foreign-variable _stat_st_gid unsigned-int "C_statbuf.st_gid")
1085(define-foreign-variable _stat_st_size unsigned-int "C_statbuf.st_size")
1086(define-foreign-variable _stat_st_mtime double "C_statbuf.st_mtime")
1087(define-foreign-variable _stat_st_atime double "C_statbuf.st_atime")
1088(define-foreign-variable _stat_st_ctime double "C_statbuf.st_ctime")
1089(define-foreign-variable _stat_st_uid unsigned-int "C_statbuf.st_uid")
1090(define-foreign-variable _stat_st_mode unsigned-int "C_statbuf.st_mode")
1091
1092(define (##sys#stat file)
1093  (let ([r (cond [(fixnum? file) (##core#inline "C_fstat" file)]
1094                 [(string? file) (##core#inline "C_stat" (##sys#make-c-string (##sys#expand-home-path file)))]
1095                 [else (##sys#signal-hook #:type-error "bad argument type - not a fixnum or string" file)] ) ] )
1096    (when (fx< r 0)
1097      (##sys#update-errno)
1098      (##sys#signal-hook #:file-error "cannot access file" file) ) ) )
1099
1100(define (file-stat f #!optional link)
1101  (##sys#stat f)
1102  (vector _stat_st_ino _stat_st_mode _stat_st_nlink
1103          _stat_st_uid _stat_st_gid _stat_st_size
1104          _stat_st_atime _stat_st_ctime _stat_st_mtime
1105          0 0 0 0) )
1106
1107(define (file-size f) (##sys#stat f) _stat_st_size)
1108(define (file-modification-time f) (##sys#stat f) _stat_st_mtime)
1109(define (file-access-time f) (##sys#stat f) _stat_st_atime)
1110(define (file-change-time f) (##sys#stat f) _stat_st_ctime)
1111(define (file-owner f) (##sys#stat f) _stat_st_uid)
1112(define (file-permissions f) (##sys#stat f) _stat_st_mode)
1113
1114(define (regular-file? fname)
1115  (##sys#check-string fname 'regular-file?)
1116  (let ((info (##sys#file-info (##sys#expand-home-path fname))))
1117    (and info (fx= 0 (##sys#slot info 4))) ) )
1118
1119(define (symbolic-link? fname)
1120  (##sys#check-string fname 'symbolic-link?)
1121  #f)
1122
1123(define file-position
1124  (lambda (port)
1125    (let ([pos (cond [(port? port)
1126                      (if (eq? (##sys#slot port 7) 'stream)
1127                          (##core#inline "C_ftell" port)
1128                          -1) ]
1129                     [(fixnum? port) (##core#inline "C_lseek" port 0 _seek_cur)]
1130                     [else (##sys#signal-hook #:type-error 'file-position "invalid file" port)] ) ] )
1131      (when (fx< pos 0)
1132        (##sys#update-errno)
1133        (##sys#signal-hook #:file-error 'file-position "cannot retrieve file position of port" port) )
1134      pos) ) )
1135
1136(define set-file-position!
1137  (lambda (port pos . whence)
1138    (let ([whence (if (pair? whence) (car whence) _seek_set)])
1139      (##sys#check-exact pos 'set-file-position!)
1140      (##sys#check-exact whence 'set-file-position!)
1141      (when (fx< pos 0) (##sys#signal-hook #:bounds-error 'set-file-position! "invalid negative port position" pos port))
1142      (unless (cond [(port? port)
1143                     (and (eq? (##sys#slot port 7) 'stream)
1144                          (##core#inline "C_fseek" port pos whence) ) ]
1145                    [(fixnum? port) (##core#inline "C_lseek" port pos whence)]
1146                    [else (##sys#signal-hook #:type-error 'set-file-position! "invalid file" port)] )
1147        (##sys#update-errno)
1148        (##sys#signal-hook #:file-error 'set-file-position! "cannot set file position" port pos) ) ) ) )
1149
1150
1151;;; Directory stuff:
1152
1153(define create-directory
1154  (lambda (name)
1155    (##sys#check-string name 'create-directory)
1156    (unless (zero? (##core#inline "C_mkdir" (##sys#make-c-string (##sys#expand-home-path name))))
1157      (##sys#update-errno)
1158      (##sys#signal-hook #:file-error 'create-directory "cannot create directory" name) ) ) )
1159
1160(define change-directory
1161  (lambda (name)
1162    (##sys#check-string name 'change-directory)
1163    (unless (zero? (##core#inline "C_chdir" (##sys#make-c-string (##sys#expand-home-path name))))
1164      (##sys#update-errno)
1165      (##sys#signal-hook #:file-error 'change-directory "cannot change current directory" name) ) ) )
1166
1167(define delete-directory
1168  (lambda (name)
1169    (##sys#check-string name 'delete-directory)
1170    (unless (zero? (##core#inline "C_rmdir" (##sys#make-c-string (##sys#expand-home-path name))))
1171      (##sys#update-errno)
1172      (##sys#signal-hook #:file-error 'delete-directory "cannot delete directory" name) ) ) )
1173
1174(define directory
1175  (let ([string-append string-append]
1176        [make-string make-string]
1177        [string string])
1178    (lambda (#!optional (spec (current-directory)) show-dotfiles?)
1179      (##sys#check-string spec 'directory)
1180      (let ([buffer (make-string 256)]
1181            [handle (##sys#make-pointer)]
1182            [entry (##sys#make-pointer)] )
1183        (##core#inline "C_opendir" (##sys#make-c-string (##sys#expand-home-path spec)) handle)
1184        (if (##sys#null-pointer? handle)
1185            (begin
1186              (##sys#update-errno)
1187              (##sys#signal-hook #:file-error 'directory "cannot open directory" spec) )
1188            (let loop ()
1189              (##core#inline "C_readdir" handle entry)
1190              (if (##sys#null-pointer? entry)
1191                  (begin
1192                    (##core#inline "C_closedir" handle)
1193                    '() )
1194                  (let* ([flen (##core#inline "C_foundfile" entry buffer)]
1195                         [file (##sys#substring buffer 0 flen)]
1196                         [char1 (string-ref file 0)]
1197                         [char2 (and (> flen 1) (string-ref file 1))] )
1198                    (if (and (eq? char1 #\.)
1199                             (or (not char2)
1200                                 (and (eq? char2 #\.) (eq? flen 2))
1201                                 (not show-dotfiles?) ) )
1202                        (loop)
1203                        (cons file (loop)) ) ) ) ) ) ) ) ) )
1204
1205(define (directory? fname)
1206  (##sys#check-string fname 'directory?)
1207  (let ((info (##sys#file-info
1208                (##sys#platform-fixup-pathname (##sys#expand-home-path fname)))))
1209    (and info (fx= 1 (##sys#slot info 4))) ) )
1210
1211(define current-directory
1212  (let ([make-string make-string])
1213    (lambda (#!optional dir)
1214      (if dir
1215          (change-directory dir)
1216          (let* ([buffer (make-string 256)]
1217                 [len (##core#inline "C_curdir" buffer)] )
1218            (##sys#update-errno)
1219            (if len
1220                (##sys#substring buffer 0 len)
1221                (##sys#signal-hook #:file-error 'current-directory "cannot retrieve current directory") ) ) ) ) ) )
1222
1223
1224(define canonical-path
1225    (let ((null?      null?)
1226          (char=?     char=?)
1227          (string=?   string=?)
1228          (alpha?     char-alphabetic?)
1229          (sref       string-ref)
1230          (ssplit     (cut string-split <> "/\\"))
1231          (sappend    string-append)
1232          (isperse    (cut string-intersperse <> "\\"))
1233          (sep?       (lambda (c) (or (char=? #\/ c) (char=? #\\ c))))
1234          (user       current-user-name)
1235          (cwd        current-directory))
1236        (lambda (path)
1237            (##sys#check-string path 'canonical-path)
1238            (let ((p   (cond ((fx= 0 (##sys#size path))
1239                                 (sappend (cwd) "\\"))
1240                             ((and (fx< (##sys#size path) 3)
1241                                   (sep? (sref path 0)))
1242                                 (sappend
1243                                     (##sys#substring (cwd) 0 2)
1244                                     path))
1245                             ((fx= 1 (##sys#size path))
1246                                 (sappend (cwd) "\\" path))
1247                             ((and (char=? #\~ (sref path 0))
1248                                   (sep? (sref path 1)))
1249                                 (sappend
1250                                     (##sys#substring (cwd) 0 3)
1251                                     "Documents and Settings\\"
1252                                     (user)
1253                                     (##sys#substring path 1
1254                                         (##sys#size path))))
1255                             ((fx= 2 (##sys#size path))
1256                                 (sappend (cwd) "\\" path))
1257                             ((and (alpha? (sref path 0))
1258                                   (char=? #\: (sref path 1))
1259                                   (sep? (sref path 2)))
1260                                 path)
1261                             ((and (char=? #\/ (sref path 0))
1262                                   (alpha? (sref path 1))
1263                                   (char=? #\: (sref path 2)))
1264                                 (sappend
1265                                     (##sys#substring path 1 3)
1266                                     "\\"
1267                                     (##sys#substring path 3
1268                                         (##sys#size path))))
1269                             ((sep? (sref path 0))
1270                                 (sappend
1271                                     (##sys#substring (cwd) 0 2)
1272                                     path))
1273                             (else
1274                                 (sappend (cwd) "\\" path)))))
1275                (let loop ((l   (ssplit (##sys#substring p 3 (##sys#size p))))
1276                           (r   '()))
1277                    (if (null? l)
1278                        (if (null? r)
1279                            (##sys#substring p 0 3)
1280                            (if (sep? (sref p (- (##sys#size p) 1)))
1281                                (sappend
1282                                    (##sys#substring p 0 3)
1283                                    (isperse (reverse (cons "" r))))
1284                                (sappend
1285                                    (##sys#substring p 0 3)
1286                                    (isperse (reverse r)))))
1287                        (loop
1288                            (cdr l)
1289                            (if (string=? ".." (car l))
1290                                (cdr r)
1291                                (if (string=? "." (car l))
1292                                    r
1293                                    (cons (car l) r))))))))))
1294                           
1295
1296;;; Pipes:
1297
1298(let ()
1299  (define (mode arg) (if (pair? arg) (##sys#slot arg 0) '###text))
1300  (define (badmode m) (##sys#error "illegal input/output mode specifier" m))
1301  (define (check cmd inp r)
1302    (##sys#update-errno)
1303    (if (##sys#null-pointer? r)
1304        (##sys#signal-hook #:file-error "cannot open pipe" cmd)
1305        (let ([port (##sys#make-port inp ##sys#stream-port-class "(pipe)" 'stream)])
1306          (##core#inline "C_set_file_ptr" port r)
1307          port) ) )
1308  (set! open-input-pipe
1309    (lambda (cmd . m)
1310      (##sys#check-string cmd 'open-input-pipe)
1311      (let ([m (mode m)])
1312        (check
1313         cmd #t
1314         (case m
1315           ((###text) (##core#inline_allocate ("open_text_input_pipe" 2) (##sys#make-c-string cmd)))
1316           ((###binary) (##core#inline_allocate ("open_binary_input_pipe" 2) (##sys#make-c-string cmd)))
1317           (else (badmode m)) ) ) ) ) )
1318  (set! open-output-pipe
1319    (lambda (cmd . m)
1320      (##sys#check-string cmd 'open-output-pipe)
1321      (let ((m (mode m)))
1322        (check
1323         cmd #f
1324         (case m
1325           ((###text) (##core#inline_allocate ("open_text_output_pipe" 2) (##sys#make-c-string cmd)))
1326           ((###binary) (##core#inline_allocate ("open_binary_output_pipe" 2) (##sys#make-c-string cmd)))
1327           (else (badmode m)) ) ) ) ) )
1328  (set! close-input-pipe
1329    (lambda (port)
1330      (##sys#check-port port 'close-input-pipe)
1331      (let ((r (##core#inline "close_pipe" port)))
1332        (##sys#update-errno)
1333        (when (eq? -1 r) (##sys#signal-hook #:file-error 'close-input-pipe "error while closing pipe" port)) ) ) )
1334  (set! close-output-pipe close-input-pipe) )
1335
1336(let ([open-input-pipe open-input-pipe]
1337      [open-output-pipe open-output-pipe]
1338      [close-input-pipe close-input-pipe]
1339      [close-output-pipe close-output-pipe] )
1340  (set! call-with-input-pipe
1341    (lambda (cmd proc . mode)
1342      (let ([p (apply open-input-pipe cmd mode)])
1343        (##sys#call-with-values
1344         (lambda () (proc p))
1345         (lambda results
1346           (close-input-pipe p)
1347           (apply values results) ) ) ) ) )
1348  (set! call-with-output-pipe
1349    (lambda (cmd proc . mode)
1350      (let ([p (apply open-output-pipe cmd mode)])
1351        (##sys#call-with-values
1352         (lambda () (proc p))
1353         (lambda results
1354           (close-output-pipe p)
1355           (apply values results) ) ) ) ) )
1356  (set! with-input-from-pipe
1357    (lambda (cmd thunk . mode)
1358      (let ([old ##sys#standard-input]
1359            [p (apply open-input-pipe cmd mode)] )
1360        (set! ##sys#standard-input p)
1361        (##sys#call-with-values thunk
1362          (lambda results
1363            (close-input-pipe p)
1364            (set! ##sys#standard-input old)
1365            (apply values results) ) ) ) ) )
1366  (set! with-output-to-pipe
1367    (lambda (cmd thunk . mode)
1368      (let ([old ##sys#standard-output]
1369            [p (apply open-output-pipe cmd mode)] )
1370        (set! ##sys#standard-output p)
1371        (##sys#call-with-values thunk
1372          (lambda results
1373            (close-output-pipe p)
1374            (set! ##sys#standard-output old)
1375            (apply values results) ) ) ) ) ) )
1376
1377
1378;;; Pipe primitive:
1379
1380(define-foreign-variable _pipefd0 int "C_pipefds[ 0 ]")
1381(define-foreign-variable _pipefd1 int "C_pipefds[ 1 ]")
1382
1383(define create-pipe
1384    (lambda (#!optional (mode (fxior open/binary open/noinherit)))
1385      (when (fx< (##core#inline "C_pipe" #f mode) 0)
1386        (##sys#update-errno)
1387        (##sys#signal-hook #:file-error 'create-pipe "cannot create pipe") )
1388      (values _pipefd0 _pipefd1) ) )
1389
1390;;; Signal processing:
1391
1392(define-foreign-variable _nsig int "NSIG")
1393(define-foreign-variable _sigterm int "SIGTERM")
1394(define-foreign-variable _sigint int "SIGINT")
1395(define-foreign-variable _sigfpe int "SIGFPE")
1396(define-foreign-variable _sigill int "SIGILL")
1397(define-foreign-variable _sigsegv int "SIGSEGV")
1398(define-foreign-variable _sigabrt int "SIGABRT")
1399(define-foreign-variable _sigbreak int "SIGBREAK")
1400
1401(define signal/term _sigterm)
1402(define signal/int _sigint)
1403(define signal/fpe _sigfpe)
1404(define signal/ill _sigill)
1405(define signal/segv _sigsegv)
1406(define signal/abrt _sigabrt)
1407(define signal/break _sigbreak)
1408(define signal/alrm 0)
1409(define signal/chld 0)
1410(define signal/cont 0)
1411(define signal/hup 0)
1412(define signal/io 0)
1413(define signal/kill 0)
1414(define signal/pipe 0)
1415(define signal/prof 0)
1416(define signal/quit 0)
1417(define signal/stop 0)
1418(define signal/trap 0)
1419(define signal/tstp 0)
1420(define signal/urg 0)
1421(define signal/usr1 0)
1422(define signal/usr2 0)
1423(define signal/vtalrm 0)
1424(define signal/winch 0)
1425(define signal/xcpu 0)
1426(define signal/xfsz 0)
1427
1428(define signals-list
1429  (list
1430    signal/term signal/int signal/fpe signal/ill
1431    signal/segv signal/abrt signal/break))
1432
1433(let ([oldhook ##sys#interrupt-hook]
1434      [sigvector (make-vector 256 #f)] )
1435  (set! signal-handler
1436    (lambda (sig)
1437      (##sys#check-exact sig 'signal-handler)
1438      (##sys#slot sigvector sig) ) )
1439  (set! set-signal-handler!
1440    (lambda (sig proc)
1441      (##sys#check-exact sig 'set-signal-handler!)
1442      (##core#inline "C_establish_signal_handler" sig (and proc sig))
1443      (vector-set! sigvector sig proc) ) )
1444  (set! ##sys#interrupt-hook
1445    (lambda (reason state)
1446      (let ([h (##sys#slot sigvector reason)])
1447        (if h
1448            (begin
1449              (h reason)
1450              (##sys#context-switch state) )
1451            (oldhook reason state) ) ) ) ) )
1452
1453;;; More errno codes:
1454
1455(define-foreign-variable _errno int "errno")
1456
1457(define-foreign-variable _eperm int "EPERM")
1458(define-foreign-variable _enoent int "ENOENT")
1459(define-foreign-variable _esrch int "ESRCH")
1460(define-foreign-variable _eintr int "EINTR")
1461(define-foreign-variable _eio int "EIO")
1462(define-foreign-variable _enoexec int "ENOEXEC")
1463(define-foreign-variable _ebadf int "EBADF")
1464(define-foreign-variable _echild int "ECHILD")
1465(define-foreign-variable _enomem int "ENOMEM")
1466(define-foreign-variable _eacces int "EACCES")
1467(define-foreign-variable _efault int "EFAULT")
1468(define-foreign-variable _ebusy int "EBUSY")
1469(define-foreign-variable _eexist int "EEXIST")
1470(define-foreign-variable _enotdir int "ENOTDIR")
1471(define-foreign-variable _eisdir int "EISDIR")
1472(define-foreign-variable _einval int "EINVAL")
1473(define-foreign-variable _emfile int "EMFILE")
1474(define-foreign-variable _enospc int "ENOSPC")
1475(define-foreign-variable _espipe int "ESPIPE")
1476(define-foreign-variable _epipe int "EPIPE")
1477(define-foreign-variable _eagain int "EAGAIN")
1478(define-foreign-variable _erofs int "EROFS")
1479(define-foreign-variable _enxio int "ENXIO")
1480(define-foreign-variable _e2big int "E2BIG")
1481(define-foreign-variable _exdev int "EXDEV")
1482(define-foreign-variable _enodev int "ENODEV")
1483(define-foreign-variable _enfile int "ENFILE")
1484(define-foreign-variable _enotty int "ENOTTY")
1485(define-foreign-variable _efbig int "EFBIG")
1486(define-foreign-variable _emlink int "EMLINK")
1487(define-foreign-variable _edom int "EDOM")
1488(define-foreign-variable _erange int "ERANGE")
1489(define-foreign-variable _edeadlk int "EDEADLK")
1490(define-foreign-variable _enametoolong int "ENAMETOOLONG")
1491(define-foreign-variable _enolck int "ENOLCK")
1492(define-foreign-variable _enosys int "ENOSYS")
1493(define-foreign-variable _enotempty int "ENOTEMPTY")
1494(define-foreign-variable _eilseq int "EILSEQ")
1495
1496(define errno/perm _eperm)
1497(define errno/noent _enoent)
1498(define errno/srch _esrch)
1499(define errno/intr _eintr)
1500(define errno/io _eio)
1501(define errno/noexec _enoexec)
1502(define errno/badf _ebadf)
1503(define errno/child _echild)
1504(define errno/nomem _enomem)
1505(define errno/acces _eacces)
1506(define errno/fault _efault)
1507(define errno/busy _ebusy)
1508(define errno/exist _eexist)
1509(define errno/notdir _enotdir)
1510(define errno/isdir _eisdir)
1511(define errno/inval _einval)
1512(define errno/mfile _emfile)
1513(define errno/nospc _enospc)
1514(define errno/spipe _espipe)
1515(define errno/pipe _epipe)
1516(define errno/again _eagain)
1517(define errno/rofs _erofs)
1518(define errno/nxio _enxio)
1519(define errno/2big _e2big)
1520(define errno/xdev _exdev)
1521(define errno/nodev _enodev)
1522(define errno/nfile _enfile)
1523(define errno/notty _enotty)
1524(define errno/fbig _efbig)
1525(define errno/mlink _emlink)
1526(define errno/dom _edom)
1527(define errno/range _erange)
1528(define errno/deadlk _edeadlk)
1529(define errno/nametoolong _enametoolong)
1530(define errno/nolck _enolck)
1531(define errno/nosys _enosys)
1532(define errno/notempty _enotempty)
1533(define errno/ilseq _eilseq)
1534
1535;;; Permissions and owners:
1536
1537(define change-file-mode
1538  (lambda (fname m)
1539    (##sys#check-string fname 'change-file-mode)
1540    (##sys#check-exact m 'change-file-mode)
1541    (when (fx< (##core#inline "C_chmod" (##sys#make-c-string (##sys#expand-home-path fname)) m) 0)
1542      (##sys#update-errno)
1543      (##sys#signal-hook #:file-error 'change-file-mode "cannot change file mode" fname m) ) ) )
1544
1545(define-foreign-variable _r_ok int "2")
1546(define-foreign-variable _w_ok int "4")
1547(define-foreign-variable _x_ok int "2")
1548
1549(let ()
1550  (define (check filename acc loc)
1551    (##sys#check-string filename loc)
1552    (let ([r (fx= 0 (##core#inline "C_access" (##sys#make-c-string (##sys#expand-home-path filename)) acc))])
1553      (unless r (##sys#update-errno))
1554      r) )
1555  (set! file-read-access? (lambda (filename) (check filename _r_ok 'file-read-access?)))
1556  (set! file-write-access? (lambda (filename) (check filename _w_ok 'file-write-access?)))
1557  (set! file-execute-access? (lambda (filename) (check filename _x_ok 'file-execute-access?))) )
1558
1559(define-foreign-variable _filename_max int "FILENAME_MAX")
1560
1561;;; Using file-descriptors:
1562
1563(define-foreign-variable _stdin_fileno int "0")
1564(define-foreign-variable _stdout_fileno int "1")
1565(define-foreign-variable _stderr_fileno int "2")
1566
1567(define fileno/stdin _stdin_fileno)
1568(define fileno/stdout _stdout_fileno)
1569(define fileno/stderr _stderr_fileno)
1570
1571(let ()
1572  (define (mode inp m)
1573    (##sys#make-c-string
1574     (cond [(pair? m)
1575            (let ([m (car m)])
1576              (case m
1577                [(###append) (if (not inp) "a" (##sys#error "invalid mode for input file" m))]
1578                [else (##sys#error "invalid mode argument" m)] ) ) ]
1579           [inp "r"]
1580           [else "w"] ) ) )
1581  (define (check fd inp r)
1582    (##sys#update-errno)
1583    (if (##sys#null-pointer? r)
1584        (##sys#signal-hook #:file-error "cannot open file" fd)
1585        (let ([port (##sys#make-port inp ##sys#stream-port-class "(fdport)" 'stream)])
1586          (##core#inline "C_set_file_ptr" port r)
1587          port) ) )
1588  (set! open-input-file*
1589    (lambda (fd . m)
1590      (##sys#check-exact fd 'open-input-file*)
1591      (check fd #t (##core#inline_allocate ("C_fdopen" 2) fd (mode #t m))) ) )
1592  (set! open-output-file*
1593    (lambda (fd . m)
1594      (##sys#check-exact fd 'open-output-file*)
1595      (check fd #f (##core#inline_allocate ("C_fdopen" 2) fd (mode #f m)) ) ) ) )
1596
1597(define port->fileno
1598  (lambda (port)
1599    (##sys#check-port port 'port->fileno)
1600    (if (not (zero? (##sys#peek-unsigned-integer port 0)))
1601        (let ([fd (##core#inline "C_C_fileno" port)])
1602          (when (fx< fd 0)
1603            (##sys#update-errno)
1604            (##sys#signal-hook #:file-error 'port->fileno "cannot access file-descriptor of port" port) )
1605          fd)
1606        (##sys#signal-hook #:type-error 'port->fileno "port has no attached file" port) ) ) )
1607
1608(define duplicate-fileno
1609  (lambda (old . new)
1610    (##sys#check-exact old duplicate-fileno)
1611    (let ([fd (if (null? new)
1612                  (##core#inline "C_dup" old)
1613                  (let ([n (car new)])
1614                    (##sys#check-exact n 'duplicate-fileno)
1615                    (##core#inline "C_dup2" old n) ) ) ] )
1616      (when (fx< fd 0)
1617        (##sys#update-errno)
1618        (##sys#signal-hook #:file-error 'duplicate-fileno "cannot duplicate file descriptor" old) )
1619      fd) ) )
1620
1621;;; Environment access:
1622
1623(define setenv
1624  (lambda (var val)
1625    (##sys#check-string var 'setenv)
1626    (##sys#check-string val 'setenv)
1627    (##core#inline "C_setenv" (##sys#make-c-string var) (##sys#make-c-string val))
1628    (##core#undefined) ) )
1629
1630(define (unsetenv var)
1631  (##sys#check-string var 'unsetenv)
1632  (##core#inline "C_putenv" (##sys#make-c-string var))
1633  (##core#undefined) )
1634
1635(define current-environment
1636  (let ([get (foreign-lambda c-string "C_getenventry" int)]
1637        [substring substring] )
1638    (lambda ()
1639      (let loop ([i 0])
1640        (let ([entry (get i)])
1641          (if entry
1642              (let scan ([j 0])
1643                (if (char=? #\= (##core#inline "C_subchar" entry j))
1644                    (cons (cons (substring entry 0 j) (substring entry (fx+ j 1) (##sys#size entry))) (loop (fx+ i 1)))
1645                    (scan (fx+ j 1)) ) )
1646              '() ) ) ) ) ) )
1647
1648;;; Time related things:
1649
1650(define (seconds->local-time secs)
1651  (##sys#check-number secs 'seconds->local-time)
1652  (##sys#decode-seconds secs #f) )
1653
1654(define (seconds->utc-time secs)
1655  (##sys#check-number secs 'seconds->utc-time)
1656  (##sys#decode-seconds secs #t) )
1657
1658(define seconds->string
1659  (let ([ctime (foreign-lambda c-string "C_ctime" integer)])
1660    (lambda (secs)
1661      (let ([str (ctime secs)])
1662        (if str
1663            (##sys#substring str 0 (fx- (##sys#size str) 1))
1664            (##sys#error 'seconds->string "cannot convert seconds to string" secs) ) ) ) ) )
1665
1666(define time->string
1667  (let ([asctime (foreign-lambda c-string "C_asctime" scheme-object)]
1668        [strftime (foreign-lambda c-string "C_strftime" scheme-object scheme-object)])
1669    (lambda (tm #!optional fmt)
1670      (##sys#check-vector tm 'time->string)
1671      (when (fx< (##sys#size tm) 10) (##sys#error 'time->string "time vector too short" tm))
1672      (if fmt
1673          (begin
1674            (##sys#check-string fmt 'time->string)
1675            (or (strftime tm (##sys#make-c-string fmt))
1676                (##sys#error 'time->string "time formatting overflows buffer" tm)) )
1677          (let ([str (asctime tm)])
1678            (if str
1679                (##sys#substring str 0 (fx- (##sys#size str) 1))
1680                (##sys#error 'time->string "cannot convert time vector to string" tm) ) ) ) ) ) )
1681
1682(define (local-time->seconds tm)
1683  (##sys#check-vector tm 'local-time->seconds)
1684  (when (fx< (##sys#size tm) 10) (##sys#error 'local-time->seconds "time vector too short" tm))
1685  (if (##core#inline "C_mktime" tm)
1686      (##sys#cons-flonum)
1687      (##sys#error 'local-time->seconds "cannot convert time vector to seconds" tm) ) )
1688
1689(define local-timezone-abbreviation
1690  (foreign-lambda* c-string ()
1691   "char *z = (daylight ? _tzname[1] : _tzname[0]);"
1692   "return(z);") )
1693
1694;;; Other things:
1695
1696(define _exit
1697  (let ([ex0 (foreign-lambda void "_exit" int)])
1698    (lambda code
1699      (ex0 (if (pair? code) (car code) 0)) ) ) )
1700
1701(define-foreign-variable _iofbf int "_IOFBF")
1702(define-foreign-variable _iolbf int "_IOLBF")
1703(define-foreign-variable _ionbf int "_IONBF")
1704(define-foreign-variable _bufsiz int "BUFSIZ")
1705
1706(define set-buffering-mode!
1707    (lambda (port mode . size)
1708      (##sys#check-port port 'set-buffering-mode!)
1709      (let ([size (if (pair? size) (car size) _bufsiz)]
1710            [mode (case mode
1711                    [(###full) _iofbf]
1712                    [(###line) _iolbf]
1713                    [(###none) _ionbf]
1714                    [else (##sys#error 'set-buffering-mode! "invalid buffering-mode" mode port)] ) ] )
1715        (##sys#check-exact size 'set-buffering-mode!)
1716        (when (fx< (if (eq? 'stream (##sys#slot port 7))
1717                       (##core#inline "C_setvbuf" port mode size)
1718                       -1)
1719                   0)
1720          (##sys#error 'set-buffering-mode! "cannot set buffering mode" port mode size) ) ) ) )
1721
1722;;; Filename globbing:
1723
1724(define glob
1725  (let ([regexp regexp]
1726        [make-anchored-pattern make-anchored-pattern]
1727        [string-match string-match]
1728        [glob->regexp glob->regexp]
1729        [directory directory]
1730        [make-pathname make-pathname]
1731        [decompose-pathname decompose-pathname] )
1732    (lambda paths
1733      (let conc-loop ([paths paths])
1734        (if (null? paths)
1735            '()
1736            (let ([path (car paths)])
1737              (let-values ([(dir fil ext) (decompose-pathname path)])
1738                (let* ([fnpatt (glob->regexp (make-pathname #f (or fil "*") ext))]
1739                       [patt (make-anchored-pattern fnpatt)]
1740                       [rx (regexp patt)])
1741                  (let loop ([fns (directory (or dir ".") #t)])
1742                    (cond [(null? fns) (conc-loop (cdr paths))]
1743                          [(string-match rx (car fns))
1744                           => (lambda (m) (cons (make-pathname dir (car m)) (loop (cdr fns)))) ]
1745                          [else (loop (cdr fns))] ) ) ) ) ) ) ) ) ) )
1746
1747
1748;;; Process handling:
1749
1750(define-foreign-variable _p_overlay int "P_OVERLAY")
1751(define-foreign-variable _p_wait int "P_WAIT")
1752(define-foreign-variable _p_nowait int "P_NOWAIT")
1753(define-foreign-variable _p_nowaito int "P_NOWAITO")
1754(define-foreign-variable _p_detach int "P_DETACH")
1755
1756(define spawn/overlay _p_overlay)
1757(define spawn/wait _p_wait)
1758(define spawn/nowait _p_nowait)
1759(define spawn/nowaito _p_nowaito)
1760(define spawn/detach _p_detach)
1761
1762; Windows uses a commandline style for process arguments. Thus any
1763; arguments with embedded whitespace will parse incorrectly. Must
1764; string-quote such arguments.
1765(define $quote-args-list
1766  (let ([char-whitespace? char-whitespace?]
1767        [string-length string-length]
1768        [string-ref string-ref]
1769        [string-append string-append])
1770    (lambda (lst exactf)
1771      (if exactf
1772        lst
1773        (let ([needs-quoting?
1774                ; This is essentially (string-any char-whitespace? s) but we don't
1775                ; want a SRFI-13 dependency. (Do we?)
1776                (lambda (s)
1777                  (let ([len (string-length s)])
1778                    (let loop ([i 0])
1779                      (cond
1780                        [(fx= i len) #f]
1781                        [(char-whitespace? (string-ref s i)) #t]
1782                        [else (loop (fx+ i 1))]))))])
1783            (let loop ([ilst lst] [olst '()])
1784              (if (null? ilst)
1785                (reverse olst)
1786                (let ([str (car ilst)])
1787                  (loop
1788                    (cdr ilst)
1789                    (cons
1790                      (if (needs-quoting? str) (string-append "\"" str "\"") str)
1791                      olst)) ) ) ) ) ) ) ) )
1792
1793(define $exec-setup
1794  (let ([setarg (foreign-lambda void "C_set_exec_arg" int scheme-pointer int)]
1795        [setenv (foreign-lambda void "C_set_exec_env" int scheme-pointer int)]
1796        [pathname-strip-directory pathname-strip-directory]
1797        [build-exec-argvec
1798          (lambda (loc lst argvec-setter idx)
1799            (if lst
1800              (begin
1801                (##sys#check-list lst loc)
1802                (do ([l lst (cdr l)]
1803                     [i idx (fx+ i 1)] )
1804                    ((null? l) (argvec-setter i #f 0))
1805                  (let ([s (car l)])
1806                    (##sys#check-string s loc)
1807                    (argvec-setter i s (##sys#size s)) ) ) )
1808              (argvec-setter idx #f 0) ) )])
1809    (lambda (loc filename arglst envlst exactf)
1810      (##sys#check-string filename loc)
1811      (let ([s (pathname-strip-directory filename)])
1812        (setarg 0 s (##sys#size s)) )
1813      (build-exec-argvec loc ($quote-args-list arglst exactf) setarg 1)
1814      (build-exec-argvec loc envlst setenv 0)
1815      (##core#inline "C_flushall")
1816      (##sys#make-c-string (##sys#expand-home-path filename)) ) ) )
1817
1818(define ($exec-teardown loc msg filename res)
1819  (##sys#update-errno)
1820  (##core#inline "C_free_exec_args")
1821  (##core#inline "C_free_exec_env")
1822  (if (fx= res -1)
1823      (##sys#error loc msg filename)
1824      res ) )
1825
1826(define (process-execute filename #!optional arglst envlst exactf)
1827  (let ([prg ($exec-setup 'process-execute filename arglst envlst exactf)])
1828    ($exec-teardown 'process-execute "cannot execute process" filename
1829      (if envlst (##core#inline "C_execve" prg) (##core#inline "C_execvp" prg))) ) )
1830
1831(define (process-spawn mode filename #!optional arglst envlst exactf)
1832  (let ([prg ($exec-setup 'process-spawn filename arglst envlst exactf)])
1833    ($exec-teardown 'process-spawn "cannot spawn process" filename
1834      (if envlst (##core#inline "C_spawnvpe" mode prg) (##core#inline "C_spawnvp" mode prg))) ) )
1835
1836(define current-process-id (foreign-lambda int "C_getpid"))
1837
1838(define-foreign-variable _shlcmd c-string "C_shlcmd")
1839
1840(define (##sys#shell-command)
1841  (or (getenv "COMSPEC")
1842      (if (##core#inline "C_get_shlcmd")
1843          _shlcmd
1844          (begin
1845            (##sys#update-errno)
1846            (##sys#error '##sys#shell-command "cannot retrieve system directory") ) ) ) )
1847
1848(define (##sys#shell-command-arguments cmdlin)
1849  (list "/c" cmdlin) )
1850
1851(define process-run
1852  (let ([process-spawn process-spawn]
1853        [getenv getenv] )
1854    (lambda (f . args)
1855      (let ([args (if (pair? args) (car args) #f)])
1856        (if args
1857            (process-spawn spawn/nowait f args)
1858            (process-spawn spawn/nowait (##sys#shell-command) (##sys#shell-command-arguments f)) ) ) ) ) )
1859
1860;;; Run subprocess connected with pipes:
1861(define-foreign-variable _rdbuf char "C_rdbuf")
1862(define-foreign-variable _wr0 int "C_wr0_")
1863(define-foreign-variable _rd1 int "C_rd1_")
1864
1865(define close-handle
1866  (foreign-lambda int "close_handle" bool))
1867
1868; from original by Mejedi
1869;; ##sys#process
1870; loc            caller procedure symbol
1871; cmd            pathname or commandline
1872; args           string-list or '()
1873; env            string-list or #f (currently ignored)
1874; stdoutf        #f then share, or #t then create
1875; stdinf         #f then share, or #t then create
1876; stderrf        #f then share, or #t then create
1877;
1878; (values stdin-input-port? stdout-output-port? pid stderr-input-port?)
1879; where stdin-input-port?, etc. is a port or #f, indicating no port created.
1880
1881(define ##sys#process
1882  (let ([c-process
1883          (foreign-lambda bool "C_process" c-string c-string c-pointer
1884            (pointer int) (pointer int) (pointer int) (pointer int) int)])
1885    ; The environment list must be sorted & include current directory
1886    ; information for the system drives. i.e !C:=...
1887    ; For now any environment is ignored.
1888    (lambda (loc cmd args env stdoutf stdinf stderrf #!optional exactf)
1889      (let ([cmdlin (string-intersperse ($quote-args-list (cons cmd args) exactf))])
1890        (let-location ([handle int -1]
1891                       [stdin_fd int -1] [stdout_fd int -1] [stderr_fd int -1])
1892          (let ([res
1893                  (c-process cmd cmdlin #f
1894                    (location handle)
1895                    (location stdin_fd) (location stdout_fd) (location stderr_fd)
1896                    (+ (if stdinf 0 1) (if stdoutf 0 2) (if stderrf 0 4)))])
1897            (if res
1898              (values
1899                (and stdoutf (open-input-file* stdout_fd)) ;Parent stdin
1900                (and stdinf (open-output-file* stdin_fd))  ;Parent stdout
1901                handle
1902                (and stderrf (open-input-file* stderr_fd)))
1903              (begin
1904                (##sys#update-errno)
1905                (##sys#signal-hook #:process-error loc "cannot execute process" cmdlin))) ) ) ) ) ) )
1906
1907#;(define process (void))
1908#;(define process* (void))
1909(let ([%process
1910        (lambda (loc err? cmd args env exactf)
1911          (let ([chkstrlst
1912                 (lambda (lst)
1913                   (##sys#check-list lst loc)
1914                   (for-each (cut ##sys#check-string <> loc) lst) )])
1915            (##sys#check-string cmd loc)
1916            (if args
1917              (chkstrlst args)
1918              (begin
1919                (set! exactf #t)
1920                (set! args (##sys#shell-command-arguments cmd))
1921                (set! cmd (##sys#shell-command)) ) )
1922            (when env (chkstrlst env))
1923            (receive [in out pid err] (##sys#process loc cmd args env #t #t err? exactf)
1924              (if err?
1925                (values in out pid err)
1926                (values in out pid) ) ) ) )] )
1927  (set! process
1928    (lambda (cmd #!optional args env exactf)
1929      (%process 'process #f cmd args env exactf) ))
1930  (set! process*
1931    (lambda (cmd #!optional args env exactf)
1932      (%process 'process* #t cmd args env exactf) )) )
1933
1934(define-foreign-variable _exstatus int "C_exstatus")
1935
1936(define (##sys#process-wait pid nohang)
1937  (if (##core#inline "C_process_wait" pid nohang)
1938    (values pid #t _exstatus)
1939    (values -1 #f #f) ) )
1940
1941(define process-wait
1942  (lambda (pid . args)
1943    (let-optionals* args ([nohang #f])
1944      (##sys#check-exact pid 'process-wait)
1945      (receive [epid enorm ecode] (##sys#process-wait pid nohang)
1946        (if (fx= epid -1)
1947          (begin
1948            (##sys#update-errno)
1949            (##sys#signal-hook #:process-error 'process-wait "waiting for child process failed" pid) )
1950          (values epid enorm ecode) ) ) ) ) )
1951
1952(define sleep
1953  (lambda (t)
1954    (##core#inline "C_sleep" t)
1955    0) )
1956
1957(define-foreign-variable _hostname c-string "C_hostname")
1958(define-foreign-variable _osver c-string "C_osver")
1959(define-foreign-variable _osrel c-string "C_osrel")
1960(define-foreign-variable _processor c-string "C_processor")
1961
1962(define get-host-name
1963  (lambda ()
1964    (if (##core#inline "C_get_hostname")
1965      _hostname
1966      (##sys#error 'get-host-name "cannot retrieve host-name") ) ) )
1967
1968
1969;;; Getting system-, group- and user-information:
1970
1971(define system-information
1972  (lambda ()
1973    (if (##core#inline "C_sysinfo")
1974      (list "windows" _hostname _osrel _osver _processor)
1975      (begin
1976        (##sys#update-errno)
1977        (##sys#error 'system-information "cannot retrieve system-information") ) ) ) )
1978
1979(define-foreign-variable _username c-string "C_username")
1980
1981(define (current-user-name)
1982  (if (##core#inline "C_get_user_name")
1983      _username
1984      (begin
1985        (##sys#update-errno)
1986        (##sys#error 'current-user-name "cannot retrieve current user-name") ) ) )
1987
1988
1989;;; Find matching files:
1990
1991(define find-files
1992  (let ([glob glob]
1993        [string-match string-match]
1994        [make-pathname make-pathname]
1995        [directory? directory?] )
1996    (lambda (dir pred . action-id-limit)
1997      (let-optionals action-id-limit
1998          ([action (lambda (x y) (cons x y))] ; no eta reduction here - we want cons inlined.
1999           [id '()]
2000           [limit #f] )
2001        (##sys#check-string dir 'find-files)
2002        (let* ([depth 0]
2003               [lproc
2004                (cond [(not limit) (lambda _ #t)]
2005                      [(fixnum? limit) (lambda _ (fx< depth limit))]
2006                      [else limit] ) ]
2007               [pproc
2008                (if (string? pred)
2009                    (lambda (x) (string-match pred x))
2010                    pred) ] )
2011          (let loop ([fs (glob (make-pathname dir "*"))]
2012                     [r id] )
2013            (if (null? fs)
2014                r
2015                (let ([f (##sys#slot fs 0)]
2016                      [rest (##sys#slot fs 1)] )
2017                  (cond [(directory? f)
2018                         (cond [(member (pathname-file f) '("." "..")) (loop rest r)]
2019                               [(lproc f)
2020                                (loop rest
2021                                      (fluid-let ([depth (fx+ depth 1)])
2022                                        (loop (glob (make-pathname f "*")) r) ) ) ]
2023                               [else (loop rest r)] ) ]
2024                        [(pproc f) (loop rest (action f r))]
2025                        [else (loop rest r)] ) ) ) ) ) ) ) ) )
2026
2027;;; unimplemented stuff:
2028
2029(define-macro (define-unimplemented name)
2030  `(define (,name . _)
2031     (error ',name (##core#immutable '"this function is not available on this platform")) ) )
2032
2033(define-unimplemented change-file-owner)
2034(define-unimplemented create-fifo)
2035(define-unimplemented create-session)
2036(define-unimplemented create-symbolic-link)
2037(define-unimplemented current-effective-group-id)
2038(define-unimplemented current-effective-user-id)
2039(define-unimplemented current-effective-user-name)
2040(define-unimplemented current-group-id)
2041(define-unimplemented current-user-id)
2042(define-unimplemented map-file-to-memory)
2043(define-unimplemented file-link)
2044(define-unimplemented file-lock)
2045(define-unimplemented file-lock/blocking)
2046(define-unimplemented file-select)
2047(define-unimplemented file-test-lock)
2048(define-unimplemented file-truncate)
2049(define-unimplemented file-unlock)
2050(define-unimplemented get-groups)
2051(define-unimplemented group-information)
2052(define-unimplemented initialize-groups)
2053(define-unimplemented memory-mapped-file-pointer)
2054(define-unimplemented parent-process-id)
2055(define-unimplemented process-fork)
2056(define-unimplemented process-group-id)
2057(define-unimplemented process-signal)
2058(define-unimplemented read-symbolic-link)
2059(define-unimplemented set-alarm!)
2060(define-unimplemented set-group-id!)
2061(define-unimplemented set-groups!)
2062(define-unimplemented set-process-group-id!)
2063(define-unimplemented set-root-directory!)
2064(define-unimplemented set-signal-mask!)
2065(define-unimplemented set-user-id!)
2066(define-unimplemented signal-mask)
2067(define-unimplemented signal-mask!)
2068(define-unimplemented signal-masked?)
2069(define-unimplemented signal-unmask!)
2070(define-unimplemented terminal-name)
2071(define-unimplemented terminal-port?)
2072(define-unimplemented terminal-size)
2073(define-unimplemented unmap-file-from-memory)
2074(define-unimplemented user-information)
2075(define-unimplemented utc-time->seconds)
2076(define-unimplemented string->time)
2077
2078(define errno/wouldblock 0)
2079
2080(define (fifo? _) #f)
2081(define (memory-mapped-file? _) #f)
2082
2083(define map/anonymous 0)
2084(define map/file 0)
2085(define map/fixed 0)
2086(define map/private 0)
2087(define map/shared 0)
2088(define open/fsync 0)
2089(define open/noctty 0)
2090(define open/nonblock 0)
2091(define open/sync 0)
2092(define perm/isgid 0)
2093(define perm/isuid 0)
2094(define perm/isvtx 0)
2095(define prot/exec 0)
2096(define prot/none 0)
2097(define prot/read 0)
2098(define prot/write 0)
Note: See TracBrowser for help on using the repository browser.