~ 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;99static HANDLE C_pid;100101/* platform information; initialized for cached testing */102static char C_shlcmd[255 + 1] = "";103104/* Current user name */105static C_char C_username[255 + 1] = "";106107#define open_binary_input_pipe(a, n, name) C_mpointer(a, _wpopen(C_OS_FILENAME(name, 0), L"r"))108#define open_text_input_pipe(a, n, name) open_binary_input_pipe(a, n, name)109#define open_binary_output_pipe(a, n, name) C_mpointer(a, _wpopen(C_OS_FILENAME(name, 0), L"w"))110#define open_text_output_pipe(a, n, name) open_binary_output_pipe(a, n, name)111#define close_pipe(p) C_fix(_pclose(C_port_file(p)))112113#define C_chmod(fn, m) C_fix(_wchmod(C_OS_FILENAME(fn, 0), C_unfix(m)))114#define C_pipe(d, m) C_fix(_pipe(C_pipefds, PIPE_BUF, C_unfix(m)))115#define C_close(fd) C_fix(close(C_unfix(fd)))116117#define C_u_i_lstat(fn) C_u_i_stat(fn)118119#define C_open(fn, fl, m) C_fix(_wopen(C_OS_FILENAME(fn, 0), C_unfix(fl), C_unfix(m)))120#define C_read(fd, b, n) C_fix(read(C_unfix(fd), C_data_pointer(b), C_unfix(n)))121#define C_write(fd, b, n) C_fix(write(C_unfix(fd), C_data_pointer(b), C_unfix(n)))122123#define C_flushall() C_fix(_flushall())124125#define C_umask(m) C_fix(_umask(C_unfix(m)))126127#define C_ctime(n) (C_secs = (n), ctime(&C_secs))128129#define TIME_STRING_MAXLENGTH 255130static char C_time_string [TIME_STRING_MAXLENGTH + 1];131#undef TIME_STRING_MAXLENGTH132133/*134 mapping from Win32 error codes to errno135*/136137typedef struct138{139 DWORD win32;140 int libc;141} errmap_t;142143static errmap_t errmap[] =144{145 {ERROR_INVALID_FUNCTION, EINVAL},146 {ERROR_FILE_NOT_FOUND, ENOENT},147 {ERROR_PATH_NOT_FOUND, ENOENT},148 {ERROR_TOO_MANY_OPEN_FILES, EMFILE},149 {ERROR_ACCESS_DENIED, EACCES},150 {ERROR_INVALID_HANDLE, EBADF},151 {ERROR_ARENA_TRASHED, ENOMEM},152 {ERROR_NOT_ENOUGH_MEMORY, ENOMEM},153 {ERROR_INVALID_BLOCK, ENOMEM},154 {ERROR_BAD_ENVIRONMENT, E2BIG},155 {ERROR_BAD_FORMAT, ENOEXEC},156 {ERROR_INVALID_ACCESS, EINVAL},157 {ERROR_INVALID_DATA, EINVAL},158 {ERROR_INVALID_DRIVE, ENOENT},159 {ERROR_CURRENT_DIRECTORY, EACCES},160 {ERROR_NOT_SAME_DEVICE, EXDEV},161 {ERROR_NO_MORE_FILES, ENOENT},162 {ERROR_LOCK_VIOLATION, EACCES},163 {ERROR_BAD_NETPATH, ENOENT},164 {ERROR_NETWORK_ACCESS_DENIED, EACCES},165 {ERROR_BAD_NET_NAME, ENOENT},166 {ERROR_FILE_EXISTS, EEXIST},167 {ERROR_CANNOT_MAKE, EACCES},168 {ERROR_FAIL_I24, EACCES},169 {ERROR_INVALID_PARAMETER, EINVAL},170 {ERROR_NO_PROC_SLOTS, EAGAIN},171 {ERROR_DRIVE_LOCKED, EACCES},172 {ERROR_BROKEN_PIPE, EPIPE},173 {ERROR_DISK_FULL, ENOSPC},174 {ERROR_INVALID_TARGET_HANDLE, EBADF},175 {ERROR_INVALID_HANDLE, EINVAL},176 {ERROR_WAIT_NO_CHILDREN, ECHILD},177 {ERROR_CHILD_NOT_COMPLETE, ECHILD},178 {ERROR_DIRECT_ACCESS_HANDLE, EBADF},179 {ERROR_NEGATIVE_SEEK, EINVAL},180 {ERROR_SEEK_ON_DEVICE, EACCES},181 {ERROR_DIR_NOT_EMPTY, ENOTEMPTY},182 {ERROR_NOT_LOCKED, EACCES},183 {ERROR_BAD_PATHNAME, ENOENT},184 {ERROR_MAX_THRDS_REACHED, EAGAIN},185 {ERROR_LOCK_FAILED, EACCES},186 {ERROR_ALREADY_EXISTS, EEXIST},187 {ERROR_FILENAME_EXCED_RANGE, ENOENT},188 {ERROR_NESTING_NOT_ALLOWED, EAGAIN},189 {ERROR_NOT_ENOUGH_QUOTA, ENOMEM},190 {0, 0}191};192193static void194set_errno(DWORD w32err)195{196 errmap_t *map;197 for (map = errmap; map->win32; ++map)198 {199 if (map->win32 == w32err)200 {201 errno = map->libc;202 return;203 }204 }205 errno = ENOSYS; /* For lack of anything better */206}207208static int209set_last_errno()210{211 set_errno(GetLastError());212 return 0;213}214215static int fd_to_path(C_word fd, C_WCHAR path[])216{217 DWORD result;218 HANDLE fh = (HANDLE)_get_osfhandle(C_unfix(fd));219220 if (fh == INVALID_HANDLE_VALUE) {221 set_last_errno();222 return -1;223 }224225 /* XXX wchar_t */226 result = GetFinalPathNameByHandleW(fh, path, MAX_PATH, VOLUME_NAME_DOS);227 if (result == 0) {228 set_last_errno();229 return -1;230 } else if (result >= MAX_PATH) { /* Shouldn't happen */231 errno = ENOMEM; /* For lack of anything better */232 return -1;233 } else {234 return 0;235 }236}237238static C_word C_fchmod(C_word fd, C_word m)239{240 C_WCHAR path[MAX_PATH];241 if (fd_to_path(fd, path) == -1) return C_fix(-1);242 else return C_fix(_wchmod(path, C_unfix(m)));243}244245static C_word C_fchdir(C_word fd)246{247 C_WCHAR path[MAX_PATH];248 if (fd_to_path(fd, path) == -1) return C_fix(-1);249 else return C_fix(_wchdir(path));250}251252static int253process_wait(C_word h, C_word t)254{255 DWORD wait_result = WaitForSingleObject((HANDLE)h, (t ? 0 : INFINITE));256 DWORD ret;257 switch (wait_result)258 {259 case WAIT_OBJECT_0:260 if (GetExitCodeProcess((HANDLE)h, &ret))261 {262 CloseHandle((HANDLE)h);263 C_exstatus = ret;264 C_pid = (HANDLE)h;265 return 1;266 }267 break;268 case WAIT_TIMEOUT:269 C_pid = 0;270 return 1;271 }272 return set_last_errno();273}274275#define C_process_wait(p, t) (process_wait(C_unfix(p), C_truep(t)) ? C_SCHEME_TRUE : C_SCHEME_FALSE)276277278static int C_isNT = 0;279280281static int282C_windows_nt()283{284 static int has_info = 0;285286 if(!has_info) {287 OSVERSIONINFO ovf;288 ZeroMemory(&ovf, sizeof(ovf));289 ovf.dwOSVersionInfoSize = sizeof(ovf);290 has_info = 1;291292 if(GetVersionEx(&ovf)) {293 SYSTEM_INFO si;294295 switch (ovf.dwPlatformId) {296 case VER_PLATFORM_WIN32_NT:297 return C_isNT = 1;298 }299 }300 }301302 return C_isNT;303}304305306static int307get_shlcmd()308{309 static wchar_t buf[ 255 ];310 /* Do we need to build the shell command pathname? */311 if (!strlen(C_shlcmd))312 {313 char *cmdnam = C_windows_nt() ? "\\cmd.exe" : "\\command.com";314 UINT len = GetSystemDirectoryW(buf, sizeof(buf));315 if (len)316 C_strlcpy(C_shlcmd + len, C_utf8(buf), sizeof(C_shlcmd));317 else318 return set_last_errno();319 }320321 return 1;322}323324#define C_sysinfo() (sysinfo() ? C_SCHEME_TRUE : C_SCHEME_FALSE)325#define C_get_shlcmd() (get_shlcmd() ? C_SCHEME_TRUE : C_SCHEME_FALSE)326327/* GetUserName */328329static int330get_user_name()331{332 static wchar_t buf[ 255 ];333 if (!C_strlen(C_username))334 {335 DWORD bufCharCount = sizeof(buf) / sizeof(buf[0]);336 if (!GetUserNameW(buf, &bufCharCount))337 return set_last_errno();338 C_strlcpy(C_username, C_utf8(buf), sizeof(C_username));339 }340 return 1;341}342343#define C_get_user_name() (get_user_name() ? C_SCHEME_TRUE : C_SCHEME_FALSE)344345/*346 Spawn a process directly.347 Params:348 app Command to execute.349 cmdlin Command line (arguments).350 env Environment for the new process (may be NULL).351 handle, stdin, stdout, stderr352 Spawned process info are returned in integers.353 When spawned process shares standard io stream with the parent354 process the respective value in handle, stdin, stdout, stderr355 is -1.356 params A bitmask controling operation.357 Bit 1: Child & parent share standard input if this bit is set.358 Bit 2: Share standard output if bit is set.359 Bit 3: Share standard error if bit is set.360361 Returns: pid, zero return value indicates failure.362*/363static DWORD364C_process(const char *app, C_word cmdlin, const char **env,365 int *phandle, int *pstdin_fd, int *pstdout_fd, int *pstderr_fd,366 int params)367{368 int i;369 int success = TRUE;370 DWORD pid;371 const int f_share_io[3] = { params & 1, params & 2, params & 4};372 int io_fds[3] = { -1, -1, -1 };373 HANDLE374 child_io_handles[3] = { NULL, NULL, NULL },375 standard_io_handles[3] = {376 GetStdHandle(STD_INPUT_HANDLE),377 GetStdHandle(STD_OUTPUT_HANDLE),378 GetStdHandle(STD_ERROR_HANDLE)};379 const char modes[3] = "rww";380 HANDLE cur_process = GetCurrentProcess(), child_process = NULL;381 void* envblk = NULL;382383 /****** create io handles & fds ***/384385 for (i=0; i<3 && success; ++i)386 {387 if (f_share_io[i])388 {389 success = DuplicateHandle(390 cur_process, standard_io_handles[i],391 cur_process, &child_io_handles[i],392 0, FALSE, DUPLICATE_SAME_ACCESS);393 }394 else395 {396 HANDLE a, b;397 success = CreatePipe(&a,&b,NULL,0);398 if(success)399 {400 HANDLE parent_end;401 if (modes[i]=='r') { child_io_handles[i]=a; parent_end=b; }402 else { parent_end=a; child_io_handles[i]=b; }403 success = (io_fds[i] = _open_osfhandle((C_word)parent_end,0)) >= 0;404 /* Make new handle inheritable */405 if (success)406 success = SetHandleInformation(child_io_handles[i], HANDLE_FLAG_INHERIT, -1);407 }408 }409 }410411#if 0 /* Requires a sorted list by key! */412 /****** create environment block if necessary ****/413414 if (env && success)415 {416 char** p;417 int len = 0;418419 for (p = env; *p; ++p) len += strlen(*p) + 1;420421 if (envblk = C_malloc((len + 1) * sizeof(wchar_t));422 {423 wchar_t* pb = (wchar_t*)envblk;424 for (p = env; *p; ++p)425 {426 wchar_t *u = C_utf16(*p, 0); /* BOGUS! */427 int n = wcslen(*u);428 C_memcpy(pb, *u, n + 1);429 pb += n + 1;430 }431 *pb = '\0';432 /* This _should_ already have been checked for embedded NUL bytes */433 }434 else435 success = FALSE;436 }437#endif438439 /****** finally spawn process ****/440441 if (success)442 {443 PROCESS_INFORMATION pi;444 STARTUPINFOW si;445446 ZeroMemory(&pi,sizeof pi);447 ZeroMemory(&si,sizeof si);448 si.cb = sizeof si;449 si.dwFlags = STARTF_USESTDHANDLES;450 si.hStdInput = child_io_handles[0];451 si.hStdOutput = child_io_handles[1];452 si.hStdError = child_io_handles[2];453454 /* FIXME passing 'app' param causes failure & possible stack corruption */455 success = CreateProcessW(456 NULL, C_utf16(cmdlin, 0), NULL, NULL, TRUE, 0, envblk, NULL, &si, &pi);457458 if (success)459 {460 child_process=pi.hProcess;461 CloseHandle(pi.hThread);462 pid = pi.dwProcessId;463 }464 else465 set_last_errno();466 }467 else468 set_last_errno();469470 /****** cleanup & return *********/471472 /* parent must close child end */473 for (i=0; i<3; ++i) {474 if (child_io_handles[i] != NULL)475 CloseHandle(child_io_handles[i]);476 }477478 if (success)479 {480 *phandle = (C_word)child_process;481 *pstdin_fd = io_fds[0];482 *pstdout_fd = io_fds[1];483 *pstderr_fd = io_fds[2];484 }485 else486 {487 for (i=0; i<3; ++i) {488 if (io_fds[i] != -1)489 _close(io_fds[i]);490 }491 }492493 return success;494}495496static int set_file_mtime(C_word filename, C_word atime, C_word mtime)497{498 struct _stat64i32 sb;499 struct _utimbuf tb;500 C_word bv = C_block_item(filename, 0);501 C_WCHAR *fn = C_OS_FILENAME(bv, 0);502503 /* Only stat if needed */504 if (atime == C_SCHEME_FALSE || mtime == C_SCHEME_FALSE) {505 if (C_stat(fn, &sb) == -1) return -1;506 }507508 if (atime == C_SCHEME_FALSE) {509 tb.actime = sb.st_atime;510 } else {511 tb.actime = C_num_to_int64(atime);512 }513 if (mtime == C_SCHEME_FALSE) {514 tb.modtime = sb.st_mtime;515 } else {516 tb.modtime = C_num_to_int64(mtime);517 }518 return _wutime(fn, &tb);519}520521#define C_u_i_execvp(f, a) C_fix(_wexecvp(C_utf16(f, 0), (void *)C_c_pointer_vector_or_null(a)))522#define C_u_i_execve(f,a,e) C_fix(_wexecve(C_utf16(f, 0), (void *)C_c_pointer_vector_or_null(a), (void *)C_c_pointer_vector_or_null(e)))523524/* MS replacement for the fork-exec pair */525#define C_u_i_spawnvp(m,f,a) C_fix(_wspawnvp(C_unfix(m), C_utf16(f, 0), (void *)C_c_pointer_vector_or_null(a)))526#define C_u_i_spawnvpe(m,f,a,e) C_fix(_wspawnvpe(C_unfix(m), C_utf16(f, 0), (void *)C_c_pointer_vector_or_null(a), (void *)C_c_pointer_vector_or_null(e)))527528<#529530(import (only chicken.string string-intersperse))531532;;; Lo-level I/O:533534(define-foreign-variable _o_noinherit int "O_NOINHERIT")535(set! chicken.file.posix#open/noinherit _o_noinherit)536537(set! chicken.file.posix#file-open538 (let ((defmode (bitwise-ior _s_irusr _s_iwusr _s_irgrp _s_iwgrp _s_iroth _s_iwoth)))539 (lambda (filename flags . mode)540 (let ([mode (if (pair? mode) (car mode) defmode)])541 (##sys#check-string filename 'file-open)542 (##sys#check-fixnum flags 'file-open)543 (##sys#check-fixnum mode 'file-open)544 (let ([fd (##core#inline "C_open" (##sys#make-c-string filename 'file-open) flags mode)])545 (when (eq? -1 fd)546 (##sys#signal-hook/errno547 #:file-error (##sys#update-errno) 'file-open "cannot open file" filename flags mode))548 fd) ) ) ) )549550(set! chicken.file.posix#file-close551 (lambda (fd)552 (##sys#check-fixnum fd 'file-close)553 (let loop ()554 (when (fx< (##core#inline "C_close" fd) 0)555 (cond556 ((fx= _errno _eintr) (##sys#dispatch-interrupt loop))557 (else558 (posix-error #:file-error 'file-close "cannot close file" fd)))))))559560(set! chicken.file.posix#file-read561 (lambda (fd size . buffer)562 (##sys#check-fixnum fd 'file-read)563 (##sys#check-fixnum size 'file-read)564 (let ([buf (if (pair? buffer) (car buffer) (##sys#make-bytevector size))])565 (unless (##core#inline "C_byteblockp" buf)566 (##sys#signal-hook #:type-error 'file-read "bad argument type - not a bytevector" buf) )567 (let ([n (##core#inline "C_read" fd buf size)])568 (when (eq? -1 n)569 (##sys#signal-hook/errno570 #:file-error (##sys#update-errno) 'file-read "cannot read from file" fd size))571 (list buf n) ) ) ) )572573(set! chicken.file.posix#file-write574 (lambda (fd buffer #!optional size)575 (##sys#check-fixnum fd 'file-write)576 (when (string? buffer)577 (set! buffer (##sys#slot buffer 0))578 (unless size (set! size (fx- (##sys#size buffer) 1))))579 (unless (##core#inline "C_byteblockp" buffer)580 (##sys#signal-hook #:type-error 'file-write "bad argument type - not a string or bytevector" buffer) )581 (let ((size (or size (##sys#size buffer))))582 (##sys#check-fixnum size 'file-write)583 (let ([n (##core#inline "C_write" fd buffer size)])584 (when (eq? -1 n)585 (##sys#signal-hook/errno586 #:file-error (##sys#update-errno) 'file-write "cannot write to file" fd size))587 n) ) ) )588589(set! chicken.file.posix#file-mkstemp590 (lambda (template)591 (##sys#check-string template 'file-mkstemp)592 (let* ((diz "0123456789abcdefghijklmnopqrstuvwxyz")593 (diz-len (string-length diz))594 (max-attempts (* diz-len diz-len diz-len))595 (tmpl (string-copy template)) ; We'll overwrite this later596 (tmpl-len (string-length tmpl))597 (first-x (let loop ((i (fx- tmpl-len 1)))598 (if (and (fx>= i 0)599 (eq? (string-ref tmpl i) #\X))600 (loop (fx- i 1))601 (fx+ i 1)))))602 (cond ((not (##sys#file-exists? (or (pathname-directory template) ".") #f #t 'file-mkstemp))603 ;; Quit early instead of looping needlessly with C_open604 ;; failing every time. This is a race condition, but not605 ;; a security-critical one.606 (##sys#signal-hook #:file-error 'file-mkstemp "non-existent directory" template))607 ((fx= first-x tmpl-len)608 (##sys#signal-hook #:file-error 'file-mkstemp "invalid template" template)))609 (let loop ((count 1))610 (let suffix-loop ((index (fx- tmpl-len 1)))611 (when (fx>= index first-x)612 (string-set! tmpl index613 (string-ref diz (##core#inline "C_rand" diz-len)))614 (suffix-loop (fx- index 1))))615 (let ((fd (##core#inline "C_open"616 (##sys#make-c-string tmpl 'file-open)617 (bitwise-ior chicken.file.posix#open/rdwr618 chicken.file.posix#open/creat619 chicken.file.posix#open/excl)620 (fxior _s_irusr _s_iwusr))))621 (if (eq? -1 fd)622 (if (fx< count max-attempts)623 (loop (fx+ count 1))624 (posix-error #:file-error 'file-mkstemp "cannot create temporary file" template))625 (values fd tmpl)))))))626627;;; Pipe primitive:628629(define-foreign-variable _pipefd0 int "C_pipefds[ 0 ]")630(define-foreign-variable _pipefd1 int "C_pipefds[ 1 ]")631632(set! chicken.process#create-pipe633 (lambda (#!optional (mode (fxior chicken.file.posix#open/binary634 chicken.file.posix#open/noinherit)))635 (when (fx< (##core#inline "C_pipe" #f mode) 0)636 (##sys#signal-hook/errno637 #:file-error (##sys#update-errno) 'create-pipe "cannot create pipe"))638 (values _pipefd0 _pipefd1) ) )639640;;; Signal processing:641642(define-foreign-variable _nsig int "NSIG")643(define-foreign-variable _sigterm int "SIGTERM")644(define-foreign-variable _sigint int "SIGINT")645(define-foreign-variable _sigfpe int "SIGFPE")646(define-foreign-variable _sigill int "SIGILL")647(define-foreign-variable _sigsegv int "SIGSEGV")648(define-foreign-variable _sigabrt int "SIGABRT")649(define-foreign-variable _sigbreak int "SIGBREAK")650651(set! chicken.process.signal#signal/term _sigterm)652(set! chicken.process.signal#signal/int _sigint)653(set! chicken.process.signal#signal/fpe _sigfpe)654(set! chicken.process.signal#signal/ill _sigill)655(set! chicken.process.signal#signal/segv _sigsegv)656(set! chicken.process.signal#signal/abrt _sigabrt)657(set! chicken.process.signal#signal/break _sigbreak)658(set! chicken.process.signal#signal/alrm 0)659(set! chicken.process.signal#signal/bus 0)660(set! chicken.process.signal#signal/chld 0)661(set! chicken.process.signal#signal/cont 0)662(set! chicken.process.signal#signal/hup 0)663(set! chicken.process.signal#signal/io 0)664(set! chicken.process.signal#signal/kill 0)665(set! chicken.process.signal#signal/pipe 0)666(set! chicken.process.signal#signal/prof 0)667(set! chicken.process.signal#signal/quit 0)668(set! chicken.process.signal#signal/stop 0)669(set! chicken.process.signal#signal/trap 0)670(set! chicken.process.signal#signal/tstp 0)671(set! chicken.process.signal#signal/urg 0)672(set! chicken.process.signal#signal/usr1 0)673(set! chicken.process.signal#signal/usr2 0)674(set! chicken.process.signal#signal/vtalrm 0)675(set! chicken.process.signal#signal/winch 0)676(set! chicken.process.signal#signal/xcpu 0)677(set! chicken.process.signal#signal/xfsz 0)678679(set! chicken.process.signal#signals-list680 (list681 chicken.process.signal#signal/term682 chicken.process.signal#signal/int683 chicken.process.signal#signal/fpe684 chicken.process.signal#signal/ill685 chicken.process.signal#signal/segv686 chicken.process.signal#signal/abrt687 chicken.process.signal#signal/break))688689;;; Using file-descriptors:690691(define duplicate-fileno692 (lambda (old . new)693 (##sys#check-fixnum old duplicate-fileno)694 (let ([fd (if (null? new)695 (##core#inline "C_dup" old)696 (let ([n (car new)])697 (##sys#check-fixnum n 'duplicate-fileno)698 (##core#inline "C_dup2" old n) ) ) ] )699 (when (fx< fd 0)700 (##sys#signal-hook/errno701 #:file-error (##sys#update-errno) 'duplicate-fileno "cannot duplicate file descriptor" old))702 fd) ) )703704705;;; Time related things:706707(set! chicken.time.posix#local-timezone-abbreviation708 (foreign-lambda* c-string ()709 "char *z = (_daylight ? _tzname[1] : _tzname[0]);\n"710 "C_return(z);") )711712713;;; Process handling:714715(define-foreign-variable _p_overlay int "P_OVERLAY")716(define-foreign-variable _p_wait int "P_WAIT")717(define-foreign-variable _p_nowait int "P_NOWAIT")718(define-foreign-variable _p_nowaito int "P_NOWAITO")719(define-foreign-variable _p_detach int "P_DETACH")720721(set! chicken.process#spawn/overlay _p_overlay)722(set! chicken.process#spawn/wait _p_wait)723(set! chicken.process#spawn/nowait _p_nowait)724(set! chicken.process#spawn/nowaito _p_nowaito)725(set! chicken.process#spawn/detach _p_detach)726727; Windows uses a commandline style for process arguments. Thus any728; arguments with embedded whitespace will parse incorrectly. Must729; string-quote such arguments.730(define quote-arg-string731 (let ((needs-quoting?732 ;; This is essentially (string-any char-whitespace? s) but we733 ;; don't want a SRFI-13 dependency. (Do we?)734 (lambda (s)735 (let ((len (string-length s)))736 (let loop ((i 0))737 (cond738 ((fx= i len) #f)739 ((char-whitespace? (string-ref s i)))740 ((char=? #\' (string-ref s i)))741 (else (loop (fx+ i 1)))))))))742 (lambda (str)743 (if (needs-quoting? str) (string-append "\"" str "\"") str))))744745(define c-string->allocated-pointer746 (foreign-lambda* c-pointer ((scheme-object o))747 ;; includes 0 byte at end748 "int len = C_header_size(o) * sizeof(C_WCHAR); \n"749 "char *ptr = C_malloc(len); \n"750 "if (ptr != NULL) {\n"751 " C_WCHAR *u = C_utf16(o, 0); \n"752 " C_memcpy(ptr, u, len); \n"753 "}\n"754 "C_return(ptr);"))755756(set! chicken.process#process-execute757 (lambda (filename #!optional (arglist '()) envlist exactf)758 (let ((conv (if exactf (lambda (x) x) quote-arg-string)))759 (call-with-exec-args760 'process-execute filename conv arglist envlist761 (lambda (prg argbuf envbuf)762 (##core#inline "C_flushall")763 (let ((r (if envbuf764 (##core#inline "C_u_i_execve" prg argbuf envbuf)765 (##core#inline "C_u_i_execvp" prg argbuf))))766 (when (fx= r -1)767 (posix-error #:process-error 'process-execute "cannot execute process" filename))))))))768769(set! chicken.process#process-spawn770 (lambda (mode filename #!optional (arglist '()) envlist exactf)771 (let ((conv (if exactf (lambda (x) x) quote-arg-string)))772 (##sys#check-fixnum mode 'process-spawn)773 (call-with-exec-args774 'process-spawn filename conv arglist envlist775 (lambda (prg argbuf envbuf)776 (##core#inline "C_flushall")777 (let ((r (if envbuf778 (##core#inline "C_u_i_spawnvpe" mode prg argbuf envbuf)779 (##core#inline "C_u_i_spawnvp" mode prg argbuf))))780 (if (fx= r -1)781 (posix-error #:process-error 'process-spawn782 "cannot spawn process" filename)783 (register-pid r))))))))784785(define-foreign-variable _shlcmd c-string "C_shlcmd")786787(define (shell-command loc)788 (or (get-environment-variable "COMSPEC")789 (if (##core#inline "C_get_shlcmd")790 _shlcmd791 (##sys#error/errno792 (##sys#update-errno) loc "cannot retrieve system directory"))))793794(define (shell-command-arguments cmdlin)795 (list "/c" cmdlin) )796797(set! chicken.process#process-run798 (lambda (f . args)799 (let ((args (if (pair? args) (car args) #f)))800 (if args801 (chicken.process#process-spawn802 chicken.process#spawn/nowait f args)803 (chicken.process#process-spawn804 chicken.process#spawn/nowait805 (shell-command 'process-run)806 (shell-command-arguments f)) ) ) ) )807808;;; Run subprocess connected with pipes:809(define-foreign-variable _rdbuf char "C_rdbuf")810(define-foreign-variable _wr0 int "C_wr0_")811(define-foreign-variable _rd1 int "C_rd1_")812813; from original by Mejedi814;; process-impl815; loc caller procedure symbol816; cmd pathname or commandline817; args string-list or '()818; env string-list or #f (currently ignored)819; stdoutf #f then share, or #t then create820; stdinf #f then share, or #t then create821; stderrf #f then share, or #t then create822;823; (values stdin-input-port? stdout-output-port? pid stderr-input-port?)824; where stdin-input-port?, etc. is a port or #f, indicating no port created.825826(define process-impl827 ;; XXX TODO: When environment is implemented, check for embedded NUL bytes!828 (let ([c-process829 (foreign-lambda bool "C_process" c-string scheme-object c-pointer830 (c-pointer int) (c-pointer int) (c-pointer int) (c-pointer int) int)])831 ; The environment list must be sorted & include current directory832 ; information for the system drives. i.e !C:=...833 ; For now any environment is ignored.834 (lambda (loc cmd args env stdoutf stdinf stderrf exactf enc)835 (let* ((arglist (cons cmd args))836 (cmdlin (string-intersperse837 (if exactf838 arglist839 (map quote-arg-string arglist)))))840 (let-location ([handle int -1]841 [stdin_fd int -1] [stdout_fd int -1] [stderr_fd int -1])842 (let ([res843 (c-process cmd (##sys#slot cmdlin 0) #f844 (location handle)845 (location stdin_fd) (location stdout_fd) (location stderr_fd)846 (+ (if stdinf 0 1) (if stdoutf 0 2) (if stderrf 0 4)))])847 (if res848 (make-process849 handle #f850 (and stdinf (chicken.file.posix#open-output-file*851 stdin_fd)) ;Parent stdout852 (and stdoutf (chicken.file.posix#open-input-file*853 stdout_fd)) ;Parent stdin854 (and stderrf (chicken.file.posix#open-input-file*855 stderr_fd))856 #f)857 (##sys#signal-hook/errno858 #:process-error (##sys#update-errno) loc "cannot execute process" cmdlin))))))))859860;; TODO: See if this can be moved to posix-common861(let ((%process862 (lambda (loc err? cmd args env exactf enc)863 (let ((chkstrlst864 (lambda (lst)865 (##sys#check-list lst loc)866 (for-each (cut ##sys#check-string <> loc) lst) )))867 (##sys#check-string cmd loc)868 (if args869 (chkstrlst args)870 (begin871 (set! exactf #t)872 (set! args (shell-command-arguments cmd))873 (set! cmd (shell-command loc)) ) )874 (when env (check-environment-list env loc))875 (process-impl loc cmd args env #t #t err? exactf enc)))))876 (set! chicken.process#process877 (lambda (cmd #!optional args env (enc 'utf-8) exactf)878 (%process 'process #f cmd args env exactf enc) ))879 (set! chicken.process#process*880 (lambda (cmd #!optional args env (enc 'utf-8) exactf)881 (%process 'process* #t cmd args env exactf enc) )) )882883(define-foreign-variable _exstatus int "C_exstatus")884(define-foreign-variable _pid int "C_pid")885886(define (process-wait-impl pid nohang)887 (cond ((##core#inline "C_process_wait" pid nohang)888 (values _pid #t _exstatus))889 (else (values -1 #f #f) ) ))890891892;;; Getting group- and user-information:893894(define-foreign-variable _username c-string "C_username")895896(set! chicken.process-context.posix#current-user-name897 (lambda ()898 (if (##core#inline "C_get_user_name")899 _username900 (##sys#error/errno901 (##sys#update-errno) 'current-user-name "cannot retrieve current user-name"))))902903904;;; unimplemented stuff:905906(define-unimplemented chown) ; covers set-file-group! and set-file-owner!907(set!-unimplemented chicken.file.posix#create-fifo)908(set!-unimplemented chicken.process-context.posix#create-session)909(set!-unimplemented chicken.file.posix#create-symbolic-link)910(set!-unimplemented chicken.process-context.posix#current-effective-group-id)911(set!-unimplemented chicken.process-context.posix#current-effective-user-id)912(set!-unimplemented chicken.process-context.posix#current-effective-user-name)913(set!-unimplemented chicken.process-context.posix#current-group-id)914(set!-unimplemented chicken.process-context.posix#current-user-id)915(set!-unimplemented chicken.process-context.posix#user-information)916(set!-unimplemented chicken.file.posix#file-control)917(set!-unimplemented chicken.file.posix#file-link)918(set!-unimplemented chicken.file.posix#file-lock)919(set!-unimplemented chicken.file.posix#file-lock/blocking)920(set!-unimplemented chicken.file.posix#file-select)921(set!-unimplemented chicken.file.posix#file-test-lock)922(set!-unimplemented chicken.file.posix#file-truncate)923(set!-unimplemented chicken.file.posix#file-unlock)924(set!-unimplemented chicken.process-context.posix#parent-process-id)925(set!-unimplemented chicken.process#process-fork)926(set!-unimplemented chicken.process-context.posix#process-group-id)927(set!-unimplemented chicken.process#process-signal)928(set!-unimplemented chicken.file.posix#read-symbolic-link)929(set!-unimplemented chicken.process.signal#set-alarm!)930(set!-unimplemented chicken.process-context.posix#set-root-directory!)931(set!-unimplemented chicken.process.signal#set-signal-mask!)932(set!-unimplemented chicken.process.signal#signal-mask)933(set!-unimplemented chicken.process.signal#signal-mask!)934(set!-unimplemented chicken.process.signal#signal-masked?)935(set!-unimplemented chicken.process.signal#signal-unmask!)936(set!-unimplemented chicken.process-context.posix#user-information)937(set!-unimplemented chicken.time.posix#utc-time->seconds)938(set!-unimplemented chicken.time.posix#string->time)939940;; Unix-only definitions941(set! chicken.file.posix#fcntl/dupfd 0)942(set! chicken.file.posix#fcntl/getfd 0)943(set! chicken.file.posix#fcntl/setfd 0)944(set! chicken.file.posix#fcntl/getfl 0)945(set! chicken.file.posix#fcntl/setfl 0)946(set! chicken.file.posix#open/noctty 0)947(set! chicken.file.posix#open/nonblock 0)948(set! chicken.file.posix#open/fsync 0)949(set! chicken.file.posix#open/sync 0)950(set! chicken.file.posix#perm/isgid 0)951(set! chicken.file.posix#perm/isuid 0)952(set! chicken.file.posix#perm/isvtx 0)