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

Last change on this file since 16117 was 16117, checked in by Kon Lovett, 10 years ago

Fix for file position wider than a fixnum.

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