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

Last change on this file since 12342 was 12342, checked in by felix winkelmann, 13 years ago

removed some dead code

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