source: project/chicken/branches/release/posixwin.scm @ 7276

Last change on this file since 7276 was 7276, checked in by felix winkelmann, 12 years ago

merged trunk

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