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

Last change on this file since 15728 was 15728, checked in by Kon Lovett, 11 years ago

Use of '##sys#expand-home-path' in unix & win posix 'create-directory'. Use of posix 'create-directory' in setup-api for 'create-directory/parents'.

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