~ chicken-core (master) /posixwin.scm
Trap1;;;; posixwin.scm - Miscellaneous file- and process-handling routines, available on Windows2;3; Copyright (c) 2008-2022, The CHICKEN Team4; Copyright (c) 2000-2007, Felix L. Winkelmann5; All rights reserved.6;7; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following8; conditions are met:9;10; Redistributions of source code must retain the above copyright notice, this list of conditions and the following11; disclaimer.12; Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following13; disclaimer in the documentation and/or other materials provided with the distribution.14; Neither the name of the author nor the names of its contributors may be used to endorse or promote15; products derived from this software without specific prior written permission.16;17; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS18; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY19; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR20; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR21; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR22; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY23; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR24; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE25; POSSIBILITY OF SUCH DAMAGE.262728; Not implemented:29;30; open/noctty open/nonblock open/fsync open/sync31; perm/isvtx perm/isuid perm/isgid32; file-select33; set-signal-mask! signal-mask signal-masked? signal-mask! signal-unmask!34; user-information35; change-file-owner36; current-user-id current-group-id current-effective-user-id current-effective-group-id37; current-effective-user-name38; set-user-id! set-group-id!39; create-session40; process-group-id set-process-group-id!41; create-symbolic-link read-symbolic-link42; file-truncate43; file-lock file-lock/blocking file-unlock file-test-lock44; create-fifo45; prot/...46; map/...47; set-alarm!48; process-fork process-wait49; parent-process-id50; process-signal515253; Issues54;55; - Use of a UTF8 encoded string will not work properly. Windows uses a56; 16-bit UNICODE character string encoding and specialized system calls57; and/or structure settings for the use of such strings.585960(declare61 (uses data-structures))6263(define-foreign-variable _stat_st_blksize scheme-object "C_SCHEME_UNDEFINED")64(define-foreign-variable _stat_st_blocks scheme-object "C_SCHEME_UNDEFINED")6566(include "posix-common.scm")6768#>6970#ifndef WIN32_LEAN_AND_MEAN71# define WIN32_LEAN_AND_MEAN72#endif7374#include <direct.h>75#include <errno.h>76#include <fcntl.h>77#include <io.h>78#include <process.h>79#include <signal.h>80#include <stdio.h>81#include <utime.h>82#include <windows.h>83#include <winsock2.h>8485#define PIPE_BUF 5128687#ifndef EWOULDBLOCK88# define EWOULDBLOCK 089#endif9091static int C_pipefds[ 2 ];92static time_t C_secs;9394/* pipe handles */95static HANDLE C_rd0, C_wr0, C_wr0_, C_rd1, C_wr1, C_rd1_;96static HANDLE C_save0, C_save1; /* saved I/O handles */97static char C_rdbuf; /* one-char buffer for read */98static int C_exstatus;99100/* platform information; initialized for cached testing */101static char C_shlcmd[255 + 1] = "";102103/* Current user name */104static C_char C_username[255 + 1] = "";105106#define open_binary_input_pipe(a, n, name) C_mpointer(a, _wpopen(C_OS_FILENAME(name, 0), L"r"))107#define open_text_input_pipe(a, n, name) open_binary_input_pipe(a, n, name)108#define open_binary_output_pipe(a, n, name) C_mpointer(a, _wpopen(C_OS_FILENAME(name, 0), L"w"))109#define open_text_output_pipe(a, n, name) open_binary_output_pipe(a, n, name)110#define close_pipe(p) C_fix(_pclose(C_port_file(p)))111112#define C_chmod(fn, m) C_fix(_wchmod(C_OS_FILENAME(fn, 0), C_unfix(m)))113#define C_pipe(d, m) C_fix(_pipe(C_pipefds, PIPE_BUF, C_unfix(m)))114#define C_close(fd) C_fix(close(C_unfix(fd)))115116#define C_u_i_lstat(fn) C_u_i_stat(fn)117118#define C_open(fn, fl, m) C_fix(_wopen(C_OS_FILENAME(fn, 0), C_unfix(fl), C_unfix(m)))119#define C_read(fd, b, n) C_fix(read(C_unfix(fd), C_data_pointer(b), C_unfix(n)))120#define C_write(fd, b, n) C_fix(write(C_unfix(fd), C_data_pointer(b), C_unfix(n)))121122#define C_flushall() C_fix(_flushall())123124#define C_umask(m) C_fix(_umask(C_unfix(m)))125126#define C_ctime(n) (C_secs = (n), ctime(&C_secs))127128#define TIME_STRING_MAXLENGTH 255129static char C_time_string [TIME_STRING_MAXLENGTH + 1];130#undef TIME_STRING_MAXLENGTH131132/*133 mapping from Win32 error codes to errno134*/135136typedef struct137{138 DWORD win32;139 int libc;140} errmap_t;141142static errmap_t errmap[] =143{144 {ERROR_INVALID_FUNCTION, EINVAL},145 {ERROR_FILE_NOT_FOUND, ENOENT},146 {ERROR_PATH_NOT_FOUND, ENOENT},147 {ERROR_TOO_MANY_OPEN_FILES, EMFILE},148 {ERROR_ACCESS_DENIED, EACCES},149 {ERROR_INVALID_HANDLE, EBADF},150 {ERROR_ARENA_TRASHED, ENOMEM},151 {ERROR_NOT_ENOUGH_MEMORY, ENOMEM},152 {ERROR_INVALID_BLOCK, ENOMEM},153 {ERROR_BAD_ENVIRONMENT, E2BIG},154 {ERROR_BAD_FORMAT, ENOEXEC},155 {ERROR_INVALID_ACCESS, EINVAL},156 {ERROR_INVALID_DATA, EINVAL},157 {ERROR_INVALID_DRIVE, ENOENT},158 {ERROR_CURRENT_DIRECTORY, EACCES},159 {ERROR_NOT_SAME_DEVICE, EXDEV},160 {ERROR_NO_MORE_FILES, ENOENT},161 {ERROR_LOCK_VIOLATION, EACCES},162 {ERROR_BAD_NETPATH, ENOENT},163 {ERROR_NETWORK_ACCESS_DENIED, EACCES},164 {ERROR_BAD_NET_NAME, ENOENT},165 {ERROR_FILE_EXISTS, EEXIST},166 {ERROR_CANNOT_MAKE, EACCES},167 {ERROR_FAIL_I24, EACCES},168 {ERROR_INVALID_PARAMETER, EINVAL},169 {ERROR_NO_PROC_SLOTS, EAGAIN},170 {ERROR_DRIVE_LOCKED, EACCES},171 {ERROR_BROKEN_PIPE, EPIPE},172 {ERROR_DISK_FULL, ENOSPC},173 {ERROR_INVALID_TARGET_HANDLE, EBADF},174 {ERROR_INVALID_HANDLE, EINVAL},175 {ERROR_WAIT_NO_CHILDREN, ECHILD},176 {ERROR_CHILD_NOT_COMPLETE, ECHILD},177 {ERROR_DIRECT_ACCESS_HANDLE, EBADF},178 {ERROR_NEGATIVE_SEEK, EINVAL},179 {ERROR_SEEK_ON_DEVICE, EACCES},180 {ERROR_DIR_NOT_EMPTY, ENOTEMPTY},181 {ERROR_NOT_LOCKED, EACCES},182 {ERROR_BAD_PATHNAME, ENOENT},183 {ERROR_MAX_THRDS_REACHED, EAGAIN},184 {ERROR_LOCK_FAILED, EACCES},185 {ERROR_ALREADY_EXISTS, EEXIST},186 {ERROR_FILENAME_EXCED_RANGE, ENOENT},187 {ERROR_NESTING_NOT_ALLOWED, EAGAIN},188 {ERROR_NOT_ENOUGH_QUOTA, ENOMEM},189 {0, 0}190};191192static void193set_errno(DWORD w32err)194{195 errmap_t *map;196 for (map = errmap; map->win32; ++map)197 {198 if (map->win32 == w32err)199 {200 errno = map->libc;201 return;202 }203 }204 errno = ENOSYS; /* For lack of anything better */205}206207static int208set_last_errno()209{210 set_errno(GetLastError());211 return 0;212}213214static int fd_to_path(C_word fd, C_WCHAR path[])215{216 DWORD result;217 HANDLE fh = (HANDLE)_get_osfhandle(C_unfix(fd));218219 if (fh == INVALID_HANDLE_VALUE) {220 set_last_errno();221 return -1;222 }223224 /* XXX wchar_t */225 result = GetFinalPathNameByHandleW(fh, path, MAX_PATH, VOLUME_NAME_DOS);226 if (result == 0) {227 set_last_errno();228 return -1;229 } else if (result >= MAX_PATH) { /* Shouldn't happen */230 errno = ENOMEM; /* For lack of anything better */231 return -1;232 } else {233 return 0;234 }235}236237static C_word C_fchmod(C_word fd, C_word m)238{239 C_WCHAR path[MAX_PATH];240 if (fd_to_path(fd, path) == -1) return C_fix(-1);241 else return C_fix(_wchmod(path, C_unfix(m)));242}243244static C_word C_fchdir(C_word fd)245{246 C_WCHAR path[MAX_PATH];247 if (fd_to_path(fd, path) == -1) return C_fix(-1);248 else return C_fix(_wchdir(path));249}250251static int252process_wait(C_word h, C_word t)253{254 if (WaitForSingleObject((HANDLE)h, (t ? 0 : INFINITE)) == WAIT_OBJECT_0)255 {256 DWORD ret;257 if (GetExitCodeProcess((HANDLE)h, &ret))258 {259 CloseHandle((HANDLE)h);260 C_exstatus = ret;261 return 1;262 }263 }264 return set_last_errno();265}266267#define C_process_wait(p, t) (process_wait(C_unfix(p), C_truep(t)) ? C_SCHEME_TRUE : C_SCHEME_FALSE)268269270static int C_isNT = 0;271272273static int274C_windows_nt()275{276 static int has_info = 0;277278 if(!has_info) {279 OSVERSIONINFO ovf;280 ZeroMemory(&ovf, sizeof(ovf));281 ovf.dwOSVersionInfoSize = sizeof(ovf);282 has_info = 1;283284 if(GetVersionEx(&ovf)) {285 SYSTEM_INFO si;286287 switch (ovf.dwPlatformId) {288 case VER_PLATFORM_WIN32_NT:289 return C_isNT = 1;290 }291 }292 }293294 return C_isNT;295}296297298static int299get_shlcmd()300{301 static wchar_t buf[ 255 ];302 /* Do we need to build the shell command pathname? */303 if (!strlen(C_shlcmd))304 {305 char *cmdnam = C_windows_nt() ? "\\cmd.exe" : "\\command.com";306 UINT len = GetSystemDirectoryW(buf, sizeof(buf));307 if (len)308 C_strlcpy(C_shlcmd + len, C_utf8(buf), sizeof(C_shlcmd));309 else310 return set_last_errno();311 }312313 return 1;314}315316#define C_sysinfo() (sysinfo() ? C_SCHEME_TRUE : C_SCHEME_FALSE)317#define C_get_shlcmd() (get_shlcmd() ? C_SCHEME_TRUE : C_SCHEME_FALSE)318319/* GetUserName */320321static int322get_user_name()323{324 static wchar_t buf[ 255 ];325 if (!C_strlen(C_username))326 {327 DWORD bufCharCount = sizeof(buf) / sizeof(buf[0]);328 if (!GetUserNameW(buf, &bufCharCount))329 return set_last_errno();330 C_strlcpy(C_username, C_utf8(buf), sizeof(C_username));331 }332 return 1;333}334335#define C_get_user_name() (get_user_name() ? C_SCHEME_TRUE : C_SCHEME_FALSE)336337/*338 Spawn a process directly.339 Params:340 app Command to execute.341 cmdlin Command line (arguments).342 env Environment for the new process (may be NULL).343 handle, stdin, stdout, stderr344 Spawned process info are returned in integers.345 When spawned process shares standard io stream with the parent346 process the respective value in handle, stdin, stdout, stderr347 is -1.348 params A bitmask controling operation.349 Bit 1: Child & parent share standard input if this bit is set.350 Bit 2: Share standard output if bit is set.351 Bit 3: Share standard error if bit is set.352353 Returns: pid, zero return value indicates failure.354*/355static DWORD356C_process(const char *app, const char *cmdlin, const char **env,357 int *phandle, int *pstdin_fd, int *pstdout_fd, int *pstderr_fd,358 int params)359{360 int i;361 int success = TRUE;362 DWORD pid;363 const int f_share_io[3] = { params & 1, params & 2, params & 4};364 int io_fds[3] = { -1, -1, -1 };365 HANDLE366 child_io_handles[3] = { NULL, NULL, NULL },367 standard_io_handles[3] = {368 GetStdHandle(STD_INPUT_HANDLE),369 GetStdHandle(STD_OUTPUT_HANDLE),370 GetStdHandle(STD_ERROR_HANDLE)};371 const char modes[3] = "rww";372 HANDLE cur_process = GetCurrentProcess(), child_process = NULL;373 void* envblk = NULL;374375 /****** create io handles & fds ***/376377 for (i=0; i<3 && success; ++i)378 {379 if (f_share_io[i])380 {381 success = DuplicateHandle(382 cur_process, standard_io_handles[i],383 cur_process, &child_io_handles[i],384 0, FALSE, DUPLICATE_SAME_ACCESS);385 }386 else387 {388 HANDLE a, b;389 success = CreatePipe(&a,&b,NULL,0);390 if(success)391 {392 HANDLE parent_end;393 if (modes[i]=='r') { child_io_handles[i]=a; parent_end=b; }394 else { parent_end=a; child_io_handles[i]=b; }395 success = (io_fds[i] = _open_osfhandle((C_word)parent_end,0)) >= 0;396 /* Make new handle inheritable */397 if (success)398 success = SetHandleInformation(child_io_handles[i], HANDLE_FLAG_INHERIT, -1);399 }400 }401 }402403#if 0 /* Requires a sorted list by key! */404 /****** create environment block if necessary ****/405406 if (env && success)407 {408 char** p;409 int len = 0;410411 for (p = env; *p; ++p) len += strlen(*p) + 1;412413 if (envblk = C_malloc((len + 1) * sizeof(wchar_t));414 {415 wchar_t* pb = (wchar_t*)envblk;416 for (p = env; *p; ++p)417 {418 wchar_t *u = C_utf16(*p, 0);419 int n = wcslen(*u);420 C_memcpy(pb, *u, n + 1);421 pb += n + 1;422 }423 *pb = '\0';424 /* This _should_ already have been checked for embedded NUL bytes */425 }426 else427 success = FALSE;428 }429#endif430431 /****** finally spawn process ****/432433 if (success)434 {435 PROCESS_INFORMATION pi;436 STARTUPINFO si;437438 ZeroMemory(&pi,sizeof pi);439 ZeroMemory(&si,sizeof si);440 si.cb = sizeof si;441 si.dwFlags = STARTF_USESTDHANDLES;442 si.hStdInput = child_io_handles[0];443 si.hStdOutput = child_io_handles[1];444 si.hStdError = child_io_handles[2];445446 /* FIXME passing 'app' param causes failure & possible stack corruption */447 success = CreateProcessW(448 NULL, C_utf16(cmdlin, 0), NULL, NULL, TRUE, 0, envblk, NULL, &si, &pi);449450 if (success)451 {452 child_process=pi.hProcess;453 CloseHandle(pi.hThread);454 pid = pi.dwProcessId;455 }456 else457 set_last_errno();458 }459 else460 set_last_errno();461462 /****** cleanup & return *********/463464 /* parent must close child end */465 for (i=0; i<3; ++i) {466 if (child_io_handles[i] != NULL)467 CloseHandle(child_io_handles[i]);468 }469470 if (success)471 {472 *phandle = (C_word)child_process;473 *pstdin_fd = io_fds[0];474 *pstdout_fd = io_fds[1];475 *pstderr_fd = io_fds[2];476 }477 else478 {479 for (i=0; i<3; ++i) {480 if (io_fds[i] != -1)481 _close(io_fds[i]);482 }483 }484485 return success;486}487488static int set_file_mtime(C_word filename, C_word atime, C_word mtime)489{490 struct _stat64i32 sb;491 struct _utimbuf tb;492 C_word bv = C_block_item(filename, 0);493 C_WCHAR *fn = C_OS_FILENAME(bv, 0);494495 /* Only stat if needed */496 if (atime == C_SCHEME_FALSE || mtime == C_SCHEME_FALSE) {497 if (C_stat(fn, &sb) == -1) return -1;498 }499500 if (atime == C_SCHEME_FALSE) {501 tb.actime = sb.st_atime;502 } else {503 tb.actime = C_num_to_int64(atime);504 }505 if (mtime == C_SCHEME_FALSE) {506 tb.modtime = sb.st_mtime;507 } else {508 tb.modtime = C_num_to_int64(mtime);509 }510 return _wutime(fn, &tb);511}512513#define C_u_i_execvp(f, a) C_fix(_wexecvp(C_c_string(f), (void *)C_c_pointer_vector_or_null(a)))514#define C_u_i_execve(f,a,e) C_fix(_wexecve(C_c_string(f), (void *)C_c_pointer_vector_or_null(a), (void *)C_c_pointer_vector_or_null(e)))515516/* MS replacement for the fork-exec pair */517#define C_u_i_spawnvp(m,f,a) C_fix(_wspawnvp(C_unfix(m), C_c_string(f), (void *)C_c_pointer_vector_or_null(a)))518#define C_u_i_spawnvpe(m,f,a,e) C_fix(_wspawnvpe(C_unfix(m), C_c_string(f), (void *)C_c_pointer_vector_or_null(a), (void *)C_c_pointer_vector_or_null(e)))519520<#521522(import (only chicken.string string-intersperse))523524;;; Lo-level I/O:525526(define-foreign-variable _o_noinherit int "O_NOINHERIT")527(set! chicken.file.posix#open/noinherit _o_noinherit)528529(set! chicken.file.posix#file-open530 (let ((defmode (bitwise-ior _s_irusr _s_iwusr _s_irgrp _s_iwgrp _s_iroth _s_iwoth)))531 (lambda (filename flags . mode)532 (let ([mode (if (pair? mode) (car mode) defmode)])533 (##sys#check-string filename 'file-open)534 (##sys#check-fixnum flags 'file-open)535 (##sys#check-fixnum mode 'file-open)536 (let ([fd (##core#inline "C_open" (##sys#make-c-string filename 'file-open) flags mode)])537 (when (eq? -1 fd)538 (##sys#signal-hook/errno539 #:file-error (##sys#update-errno) 'file-open "cannot open file" filename flags mode))540 fd) ) ) ) )541542(set! chicken.file.posix#file-close543 (lambda (fd)544 (##sys#check-fixnum fd 'file-close)545 (let loop ()546 (when (fx< (##core#inline "C_close" fd) 0)547 (cond548 ((fx= _errno _eintr) (##sys#dispatch-interrupt loop))549 (else550 (posix-error #:file-error 'file-close "cannot close file" fd)))))))551552(set! chicken.file.posix#file-read553 (lambda (fd size . buffer)554 (##sys#check-fixnum fd 'file-read)555 (##sys#check-fixnum size 'file-read)556 (let ([buf (if (pair? buffer) (car buffer) (make-string size))])557 (unless (and (##core#inline "C_blockp" buf) (##core#inline "C_byteblockp" buf))558 (##sys#signal-hook #:type-error 'file-read "bad argument type - not a string or bytevector" buf) )559 (let ([n (##core#inline "C_read" fd buf size)])560 (when (eq? -1 n)561 (##sys#signal-hook/errno562 #:file-error (##sys#update-errno) 'file-read "cannot read from file" fd size))563 (list buf n) ) ) ) )564565(set! chicken.file.posix#file-write566 (lambda (fd buffer #!optional size)567 (##sys#check-fixnum fd 'file-write)568 (when (string? buffer)569 (set! buffer (##sys#slot buffer 0))570 (unless size (set! size (fx- (##sys#size buffer) 1))))571 (unless (##core#inline "C_byteblockp" buffer)572 (##sys#signal-hook #:type-error 'file-write "bad argument type - not a string or bytevector" buffer) )573 (let ((size (or size (##sys#size buffer))))574 (##sys#check-fixnum size 'file-write)575 (let ([n (##core#inline "C_write" fd buffer size)])576 (when (eq? -1 n)577 (##sys#signal-hook/errno578 #:file-error (##sys#update-errno) 'file-write "cannot write to file" fd size))579 n) ) ) )580581(set! chicken.file.posix#file-mkstemp582 (lambda (template)583 (##sys#check-string template 'file-mkstemp)584 (let* ((diz "0123456789abcdefghijklmnopqrstuvwxyz")585 (diz-len (string-length diz))586 (max-attempts (* diz-len diz-len diz-len))587 (tmpl (string-copy template)) ; We'll overwrite this later588 (tmpl-len (string-length tmpl))589 (first-x (let loop ((i (fx- tmpl-len 1)))590 (if (and (fx>= i 0)591 (eq? (string-ref tmpl i) #\X))592 (loop (fx- i 1))593 (fx+ i 1)))))594 (cond ((not (##sys#file-exists? (or (pathname-directory template) ".") #f #t 'file-mkstemp))595 ;; Quit early instead of looping needlessly with C_open596 ;; failing every time. This is a race condition, but not597 ;; a security-critical one.598 (##sys#signal-hook #:file-error 'file-mkstemp "non-existent directory" template))599 ((fx= first-x tmpl-len)600 (##sys#signal-hook #:file-error 'file-mkstemp "invalid template" template)))601 (let loop ((count 1))602 (let suffix-loop ((index (fx- tmpl-len 1)))603 (when (fx>= index first-x)604 (string-set! tmpl index605 (string-ref diz (##core#inline "C_rand" diz-len)))606 (suffix-loop (fx- index 1))))607 (let ((fd (##core#inline "C_open"608 (##sys#make-c-string tmpl 'file-open)609 (bitwise-ior chicken.file.posix#open/rdwr610 chicken.file.posix#open/creat611 chicken.file.posix#open/excl)612 (fxior _s_irusr _s_iwusr))))613 (if (eq? -1 fd)614 (if (fx< count max-attempts)615 (loop (fx+ count 1))616 (posix-error #:file-error 'file-mkstemp "cannot create temporary file" template))617 (values fd tmpl)))))))618619;;; Pipe primitive:620621(define-foreign-variable _pipefd0 int "C_pipefds[ 0 ]")622(define-foreign-variable _pipefd1 int "C_pipefds[ 1 ]")623624(set! chicken.process#create-pipe625 (lambda (#!optional (mode (fxior chicken.file.posix#open/binary626 chicken.file.posix#open/noinherit)))627 (when (fx< (##core#inline "C_pipe" #f mode) 0)628 (##sys#signal-hook/errno629 #:file-error (##sys#update-errno) 'create-pipe "cannot create pipe"))630 (values _pipefd0 _pipefd1) ) )631632;;; Signal processing:633634(define-foreign-variable _nsig int "NSIG")635(define-foreign-variable _sigterm int "SIGTERM")636(define-foreign-variable _sigint int "SIGINT")637(define-foreign-variable _sigfpe int "SIGFPE")638(define-foreign-variable _sigill int "SIGILL")639(define-foreign-variable _sigsegv int "SIGSEGV")640(define-foreign-variable _sigabrt int "SIGABRT")641(define-foreign-variable _sigbreak int "SIGBREAK")642643(set! chicken.process.signal#signal/term _sigterm)644(set! chicken.process.signal#signal/int _sigint)645(set! chicken.process.signal#signal/fpe _sigfpe)646(set! chicken.process.signal#signal/ill _sigill)647(set! chicken.process.signal#signal/segv _sigsegv)648(set! chicken.process.signal#signal/abrt _sigabrt)649(set! chicken.process.signal#signal/break _sigbreak)650(set! chicken.process.signal#signal/alrm 0)651(set! chicken.process.signal#signal/bus 0)652(set! chicken.process.signal#signal/chld 0)653(set! chicken.process.signal#signal/cont 0)654(set! chicken.process.signal#signal/hup 0)655(set! chicken.process.signal#signal/io 0)656(set! chicken.process.signal#signal/kill 0)657(set! chicken.process.signal#signal/pipe 0)658(set! chicken.process.signal#signal/prof 0)659(set! chicken.process.signal#signal/quit 0)660(set! chicken.process.signal#signal/stop 0)661(set! chicken.process.signal#signal/trap 0)662(set! chicken.process.signal#signal/tstp 0)663(set! chicken.process.signal#signal/urg 0)664(set! chicken.process.signal#signal/usr1 0)665(set! chicken.process.signal#signal/usr2 0)666(set! chicken.process.signal#signal/vtalrm 0)667(set! chicken.process.signal#signal/winch 0)668(set! chicken.process.signal#signal/xcpu 0)669(set! chicken.process.signal#signal/xfsz 0)670671(set! chicken.process.signal#signals-list672 (list673 chicken.process.signal#signal/term674 chicken.process.signal#signal/int675 chicken.process.signal#signal/fpe676 chicken.process.signal#signal/ill677 chicken.process.signal#signal/segv678 chicken.process.signal#signal/abrt679 chicken.process.signal#signal/break))680681;;; Using file-descriptors:682683(define duplicate-fileno684 (lambda (old . new)685 (##sys#check-fixnum old duplicate-fileno)686 (let ([fd (if (null? new)687 (##core#inline "C_dup" old)688 (let ([n (car new)])689 (##sys#check-fixnum n 'duplicate-fileno)690 (##core#inline "C_dup2" old n) ) ) ] )691 (when (fx< fd 0)692 (##sys#signal-hook/errno693 #:file-error (##sys#update-errno) 'duplicate-fileno "cannot duplicate file descriptor" old))694 fd) ) )695696697;;; Time related things:698699(set! chicken.time.posix#local-timezone-abbreviation700 (foreign-lambda* c-string ()701 "char *z = (_daylight ? _tzname[1] : _tzname[0]);\n"702 "C_return(z);") )703704705;;; Process handling:706707(define-foreign-variable _p_overlay int "P_OVERLAY")708(define-foreign-variable _p_wait int "P_WAIT")709(define-foreign-variable _p_nowait int "P_NOWAIT")710(define-foreign-variable _p_nowaito int "P_NOWAITO")711(define-foreign-variable _p_detach int "P_DETACH")712713(set! chicken.process#spawn/overlay _p_overlay)714(set! chicken.process#spawn/wait _p_wait)715(set! chicken.process#spawn/nowait _p_nowait)716(set! chicken.process#spawn/nowaito _p_nowaito)717(set! chicken.process#spawn/detach _p_detach)718719; Windows uses a commandline style for process arguments. Thus any720; arguments with embedded whitespace will parse incorrectly. Must721; string-quote such arguments.722(define quote-arg-string723 (let ((needs-quoting?724 ;; This is essentially (string-any char-whitespace? s) but we725 ;; don't want a SRFI-13 dependency. (Do we?)726 (lambda (s)727 (let ((len (string-length s)))728 (let loop ((i 0))729 (cond730 ((fx= i len) #f)731 ((char-whitespace? (string-ref s i)) #t)732 (else (loop (fx+ i 1)))))))))733 (lambda (str)734 (if (needs-quoting? str) (string-append "\"" str "\"") str))))735736(define c-string->allocated-pointer737 (foreign-lambda* c-pointer ((scheme-object o))738 "char *ptr = C_malloc(C_header_size(o) * sizeof(wchar_t)); \n"739 "if (ptr != NULL) {\n"740 " wchar_t *u = C_utf16(C_data_pointer(o), 0); \n"741 " C_memcpy(ptr, u, wcslen(u) + 1); \n"742 "}\n"743 "C_return(ptr);"))744745(set! chicken.process#process-execute746 (lambda (filename #!optional (arglist '()) envlist exactf)747 (let ((argconv (if exactf (lambda (x) x) quote-arg-string)))748 (call-with-exec-args749 'process-execute filename argconv arglist envlist750 (lambda (prg argbuf envbuf)751 (##core#inline "C_flushall")752 (let ((r (if envbuf753 (##core#inline "C_u_i_execve" prg argbuf envbuf)754 (##core#inline "C_u_i_execvp" prg argbuf))))755 (when (fx= r -1)756 (posix-error #:process-error 'process-execute "cannot execute process" filename))))))))757758(set! chicken.process#process-spawn759 (lambda (mode filename #!optional (arglist '()) envlist exactf)760 (let ((argconv (if exactf (lambda (x) x) quote-arg-string)))761 (##sys#check-fixnum mode 'process-spawn)762 (call-with-exec-args763 'process-spawn filename argconv arglist envlist764 (lambda (prg argbuf envbuf)765 (##core#inline "C_flushall")766 (let ((r (if envbuf767 (##core#inline "C_u_i_spawnvpe" mode prg argbuf envbuf)768 (##core#inline "C_u_i_spawnvp" mode prg argbuf))))769 (if (fx= r -1)770 (posix-error #:process-error 'process-spawn771 "cannot spawn process" filename)772 (register-pid r))))))))773774(define-foreign-variable _shlcmd c-string "C_shlcmd")775776(define (shell-command loc)777 (or (get-environment-variable "COMSPEC")778 (if (##core#inline "C_get_shlcmd")779 _shlcmd780 (##sys#error/errno781 (##sys#update-errno) loc "cannot retrieve system directory"))))782783(define (shell-command-arguments cmdlin)784 (list "/c" cmdlin) )785786(set! chicken.process#process-run787 (lambda (f . args)788 (let ((args (if (pair? args) (car args) #f)))789 (if args790 (chicken.process#process-spawn791 chicken.process#spawn/nowait f args)792 (chicken.process#process-spawn793 chicken.process#spawn/nowait794 (shell-command 'process-run)795 (shell-command-arguments f)) ) ) ) )796797;;; Run subprocess connected with pipes:798(define-foreign-variable _rdbuf char "C_rdbuf")799(define-foreign-variable _wr0 int "C_wr0_")800(define-foreign-variable _rd1 int "C_rd1_")801802; from original by Mejedi803;; process-impl804; loc caller procedure symbol805; cmd pathname or commandline806; args string-list or '()807; env string-list or #f (currently ignored)808; stdoutf #f then share, or #t then create809; stdinf #f then share, or #t then create810; stderrf #f then share, or #t then create811;812; (values stdin-input-port? stdout-output-port? pid stderr-input-port?)813; where stdin-input-port?, etc. is a port or #f, indicating no port created.814815(define process-impl816 ;; XXX TODO: When environment is implemented, check for embedded NUL bytes!817 (let ([c-process818 (foreign-lambda bool "C_process" c-string c-string c-pointer819 (c-pointer int) (c-pointer int) (c-pointer int) (c-pointer int) int)])820 ; The environment list must be sorted & include current directory821 ; information for the system drives. i.e !C:=...822 ; For now any environment is ignored.823 (lambda (loc cmd args env stdoutf stdinf stderrf exactf enc)824 (let* ((arglist (cons cmd args))825 (cmdlin (string-intersperse826 (if exactf827 arglist828 (map quote-arg-string arglist)))))829 (let-location ([handle int -1]830 [stdin_fd int -1] [stdout_fd int -1] [stderr_fd int -1])831 (let ([res832 (c-process cmd cmdlin #f833 (location handle)834 (location stdin_fd) (location stdout_fd) (location stderr_fd)835 (+ (if stdinf 0 1) (if stdoutf 0 2) (if stderrf 0 4)))])836 (if (integer? res)837 (make-process838 res #f839 (and stdoutf (chicken.file.posix#open-input-file*840 stdout_fd)) ;Parent stdin841 (and stdinf (chicken.file.posix#open-output-file*842 stdin_fd)) ;Parent stdout843 handle844 (and stderrf (chicken.file.posix#open-input-file*845 stderr_fd)846 #f))847 (##sys#signal-hook/errno848 #:process-error (##sys#update-errno) loc "cannot execute process" cmdlin))))))))849850;; TODO: See if this can be moved to posix-common851(let ((%process852 (lambda (loc cmd args env exactf enc)853 (let ((chkstrlst854 (lambda (lst)855 (##sys#check-list lst loc)856 (for-each (cut ##sys#check-string <> loc) lst) )))857 (##sys#check-string cmd loc)858 (if args859 (chkstrlst args)860 (begin861 (set! exactf #t)862 (set! args (shell-command-arguments cmd))863 (set! cmd (shell-command loc)) ) )864 (when env (check-environment-list env loc))865 (process-impl loc cmd args env #t #t err? exactf enc)))))866 (set! chicken.process#process867 (lambda (cmd #!optional args env (enc 'utf-8) exactf)868 (%process 'process cmd args env exactf enc) ))869 (set! chicken.process#process*870 (lambda (cmd #!optional args env (enc 'utf-8) exactf)871 (%process 'process* cmd args env exactf enc) )) )872873(define-foreign-variable _exstatus int "C_exstatus")874875(define (process-wait-impl pid nohang)876 (cond ((##core#inline "C_process_wait" pid nohang)877 (values pid #t _exstatus))878 (else (values -1 #f #f) ) ))879880881;;; Getting group- and user-information:882883(define-foreign-variable _username c-string "C_username")884885(set! chicken.process-context.posix#current-user-name886 (lambda ()887 (if (##core#inline "C_get_user_name")888 _username889 (##sys#error/errno890 (##sys#update-errno) 'current-user-name "cannot retrieve current user-name"))))891892893;;; unimplemented stuff:894895(define-unimplemented chown) ; covers set-file-group! and set-file-owner!896(set!-unimplemented chicken.file.posix#create-fifo)897(set!-unimplemented chicken.process-context.posix#create-session)898(set!-unimplemented chicken.file.posix#create-symbolic-link)899(set!-unimplemented chicken.process-context.posix#current-effective-group-id)900(set!-unimplemented chicken.process-context.posix#current-effective-user-id)901(set!-unimplemented chicken.process-context.posix#current-effective-user-name)902(set!-unimplemented chicken.process-context.posix#current-group-id)903(set!-unimplemented chicken.process-context.posix#current-user-id)904(set!-unimplemented chicken.process-context.posix#user-information)905(set!-unimplemented chicken.file.posix#file-control)906(set!-unimplemented chicken.file.posix#file-link)907(set!-unimplemented chicken.file.posix#file-lock)908(set!-unimplemented chicken.file.posix#file-lock/blocking)909(set!-unimplemented chicken.file.posix#file-select)910(set!-unimplemented chicken.file.posix#file-test-lock)911(set!-unimplemented chicken.file.posix#file-truncate)912(set!-unimplemented chicken.file.posix#file-unlock)913(set!-unimplemented chicken.process-context.posix#parent-process-id)914(set!-unimplemented chicken.process#process-fork)915(set!-unimplemented chicken.process-context.posix#process-group-id)916(set!-unimplemented chicken.process#process-signal)917(set!-unimplemented chicken.file.posix#read-symbolic-link)918(set!-unimplemented chicken.process.signal#set-alarm!)919(set!-unimplemented chicken.process-context.posix#set-root-directory!)920(set!-unimplemented chicken.process.signal#set-signal-mask!)921(set!-unimplemented chicken.process.signal#signal-mask)922(set!-unimplemented chicken.process.signal#signal-mask!)923(set!-unimplemented chicken.process.signal#signal-masked?)924(set!-unimplemented chicken.process.signal#signal-unmask!)925(set!-unimplemented chicken.process-context.posix#user-information)926(set!-unimplemented chicken.time.posix#utc-time->seconds)927(set!-unimplemented chicken.time.posix#string->time)928929;; Unix-only definitions930(set! chicken.file.posix#fcntl/dupfd 0)931(set! chicken.file.posix#fcntl/getfd 0)932(set! chicken.file.posix#fcntl/setfd 0)933(set! chicken.file.posix#fcntl/getfl 0)934(set! chicken.file.posix#fcntl/setfl 0)935(set! chicken.file.posix#open/noctty 0)936(set! chicken.file.posix#open/nonblock 0)937(set! chicken.file.posix#open/fsync 0)938(set! chicken.file.posix#open/sync 0)939(set! chicken.file.posix#perm/isgid 0)940(set! chicken.file.posix#perm/isuid 0)941(set! chicken.file.posix#perm/isvtx 0)