~ chicken-core (chicken-5) /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 C_TLS int C_pipefds[ 2 ];92static C_TLS time_t C_secs;9394/* pipe handles */95static C_TLS HANDLE C_rd0, C_wr0, C_wr0_, C_rd1, C_wr1, C_rd1_;96static C_TLS HANDLE C_save0, C_save1; /* saved I/O handles */97static C_TLS char C_rdbuf; /* one-char buffer for read */98static C_TLS int C_exstatus;99100/* platform information; initialized for cached testing */101static C_TLS char C_shlcmd[256] = "";102103/* Current user name */104static C_TLS TCHAR C_username[255 + 1] = "";105106#define open_binary_input_pipe(a, n, name) C_mpointer(a, _popen(C_c_string(name), "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, _popen(C_c_string(name), "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(chmod(C_c_string(fn), 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_u_i_execvp(f,a) C_fix(execvp(C_c_string(f), (const char *const *)C_c_pointer_vector_or_null(a)))119#define C_u_i_execve(f,a,e) C_fix(execve(C_c_string(f), (const char *const *)C_c_pointer_vector_or_null(a), (const char *const *)C_c_pointer_vector_or_null(e)))120121/* MS replacement for the fork-exec pair */122#define C_u_i_spawnvp(m,f,a) C_fix(spawnvp(C_unfix(m), C_c_string(f), (const char *const *)C_c_pointer_vector_or_null(a)))123#define C_u_i_spawnvpe(m,f,a,e) C_fix(spawnvpe(C_unfix(m), C_c_string(f), (const char *const *)C_c_pointer_vector_or_null(a), (const char *const *)C_c_pointer_vector_or_null(e)))124125#define C_open(fn, fl, m) C_fix(open(C_c_string(fn), C_unfix(fl), C_unfix(m)))126#define C_read(fd, b, n) C_fix(read(C_unfix(fd), C_data_pointer(b), C_unfix(n)))127#define C_write(fd, b, n) C_fix(write(C_unfix(fd), C_data_pointer(b), C_unfix(n)))128129#define C_flushall() C_fix(_flushall())130131#define C_umask(m) C_fix(_umask(C_unfix(m)))132133#define C_ctime(n) (C_secs = (n), ctime(&C_secs))134135#define TIME_STRING_MAXLENGTH 255136static char C_time_string [TIME_STRING_MAXLENGTH + 1];137#undef TIME_STRING_MAXLENGTH138139/*140 mapping from Win32 error codes to errno141*/142143typedef struct144{145 DWORD win32;146 int libc;147} errmap_t;148149static errmap_t errmap[] =150{151 {ERROR_INVALID_FUNCTION, EINVAL},152 {ERROR_FILE_NOT_FOUND, ENOENT},153 {ERROR_PATH_NOT_FOUND, ENOENT},154 {ERROR_TOO_MANY_OPEN_FILES, EMFILE},155 {ERROR_ACCESS_DENIED, EACCES},156 {ERROR_INVALID_HANDLE, EBADF},157 {ERROR_ARENA_TRASHED, ENOMEM},158 {ERROR_NOT_ENOUGH_MEMORY, ENOMEM},159 {ERROR_INVALID_BLOCK, ENOMEM},160 {ERROR_BAD_ENVIRONMENT, E2BIG},161 {ERROR_BAD_FORMAT, ENOEXEC},162 {ERROR_INVALID_ACCESS, EINVAL},163 {ERROR_INVALID_DATA, EINVAL},164 {ERROR_INVALID_DRIVE, ENOENT},165 {ERROR_CURRENT_DIRECTORY, EACCES},166 {ERROR_NOT_SAME_DEVICE, EXDEV},167 {ERROR_NO_MORE_FILES, ENOENT},168 {ERROR_LOCK_VIOLATION, EACCES},169 {ERROR_BAD_NETPATH, ENOENT},170 {ERROR_NETWORK_ACCESS_DENIED, EACCES},171 {ERROR_BAD_NET_NAME, ENOENT},172 {ERROR_FILE_EXISTS, EEXIST},173 {ERROR_CANNOT_MAKE, EACCES},174 {ERROR_FAIL_I24, EACCES},175 {ERROR_INVALID_PARAMETER, EINVAL},176 {ERROR_NO_PROC_SLOTS, EAGAIN},177 {ERROR_DRIVE_LOCKED, EACCES},178 {ERROR_BROKEN_PIPE, EPIPE},179 {ERROR_DISK_FULL, ENOSPC},180 {ERROR_INVALID_TARGET_HANDLE, EBADF},181 {ERROR_INVALID_HANDLE, EINVAL},182 {ERROR_WAIT_NO_CHILDREN, ECHILD},183 {ERROR_CHILD_NOT_COMPLETE, ECHILD},184 {ERROR_DIRECT_ACCESS_HANDLE, EBADF},185 {ERROR_NEGATIVE_SEEK, EINVAL},186 {ERROR_SEEK_ON_DEVICE, EACCES},187 {ERROR_DIR_NOT_EMPTY, ENOTEMPTY},188 {ERROR_NOT_LOCKED, EACCES},189 {ERROR_BAD_PATHNAME, ENOENT},190 {ERROR_MAX_THRDS_REACHED, EAGAIN},191 {ERROR_LOCK_FAILED, EACCES},192 {ERROR_ALREADY_EXISTS, EEXIST},193 {ERROR_FILENAME_EXCED_RANGE, ENOENT},194 {ERROR_NESTING_NOT_ALLOWED, EAGAIN},195 {ERROR_NOT_ENOUGH_QUOTA, ENOMEM},196 {0, 0}197};198199static void C_fcall200set_errno(DWORD w32err)201{202 errmap_t *map;203 for (map = errmap; map->win32; ++map)204 {205 if (map->win32 == w32err)206 {207 errno = map->libc;208 return;209 }210 }211 errno = ENOSYS; /* For lack of anything better */212}213214static int C_fcall215set_last_errno()216{217 set_errno(GetLastError());218 return 0;219}220221static int fd_to_path(C_word fd, TCHAR path[])222{223 DWORD result;224 HANDLE fh = (HANDLE)_get_osfhandle(C_unfix(fd));225226 if (fh == INVALID_HANDLE_VALUE) {227 set_last_errno();228 return -1;229 }230231 result = GetFinalPathNameByHandle(fh, path, MAX_PATH, VOLUME_NAME_DOS);232 if (result == 0) {233 set_last_errno();234 return -1;235 } else if (result >= MAX_PATH) { /* Shouldn't happen */236 errno = ENOMEM; /* For lack of anything better */237 return -1;238 } else {239 return 0;240 }241}242243static C_word C_fchmod(C_word fd, C_word m)244{245 TCHAR path[MAX_PATH];246 if (fd_to_path(fd, path) == -1) return C_fix(-1);247 else return C_fix(chmod(path, C_unfix(m)));248}249250static C_word C_fchdir(C_word fd)251{252 TCHAR path[MAX_PATH];253 if (fd_to_path(fd, path) == -1) return C_fix(-1);254 else return C_fix(chdir(path));255}256257static int C_fcall258process_wait(C_word h, C_word t)259{260 if (WaitForSingleObject((HANDLE)h, (t ? 0 : INFINITE)) == WAIT_OBJECT_0)261 {262 DWORD ret;263 if (GetExitCodeProcess((HANDLE)h, &ret))264 {265 CloseHandle((HANDLE)h);266 C_exstatus = ret;267 return 1;268 }269 }270 return set_last_errno();271}272273#define C_process_wait(p, t) (process_wait(C_unfix(p), C_truep(t)) ? C_SCHEME_TRUE : C_SCHEME_FALSE)274275276static C_TLS int C_isNT = 0;277278279static int C_fcall280C_windows_nt()281{282 static int has_info = 0;283284 if(!has_info) {285 OSVERSIONINFO ovf;286 ZeroMemory(&ovf, sizeof(ovf));287 ovf.dwOSVersionInfoSize = sizeof(ovf);288 has_info = 1;289290 if(GetVersionEx(&ovf)) {291 SYSTEM_INFO si;292293 switch (ovf.dwPlatformId) {294 case VER_PLATFORM_WIN32_NT:295 return C_isNT = 1;296 }297 }298 }299300 return C_isNT;301}302303304static int C_fcall305get_shlcmd()306{307 /* Do we need to build the shell command pathname? */308 if (!strlen(C_shlcmd))309 {310 char *cmdnam = C_windows_nt() ? "\\cmd.exe" : "\\command.com";311 UINT len = GetSystemDirectory(C_shlcmd, sizeof(C_shlcmd) - strlen(cmdnam));312 if (len)313 C_strlcpy(C_shlcmd + len, cmdnam, sizeof(C_shlcmd));314 else315 return set_last_errno();316 }317318 return 1;319}320321#define C_sysinfo() (sysinfo() ? C_SCHEME_TRUE : C_SCHEME_FALSE)322#define C_get_shlcmd() (get_shlcmd() ? C_SCHEME_TRUE : C_SCHEME_FALSE)323324/* GetUserName */325326static int C_fcall327get_user_name()328{329 if (!strlen(C_username))330 {331 DWORD bufCharCount = sizeof(C_username) / sizeof(C_username[0]);332 if (!GetUserName(C_username, &bufCharCount))333 return set_last_errno();334 }335 return 1;336}337338#define C_get_user_name() (get_user_name() ? C_SCHEME_TRUE : C_SCHEME_FALSE)339340/*341 Spawn a process directly.342 Params:343 app Command to execute.344 cmdlin Command line (arguments).345 env Environment for the new process (may be NULL).346 handle, stdin, stdout, stderr347 Spawned process info are returned in integers.348 When spawned process shares standard io stream with the parent349 process the respective value in handle, stdin, stdout, stderr350 is -1.351 params A bitmask controling operation.352 Bit 1: Child & parent share standard input if this bit is set.353 Bit 2: Share standard output if bit is set.354 Bit 3: Share standard error if bit is set.355356 Returns: zero return value indicates failure.357*/358static int C_fcall359C_process(const char *app, const char *cmdlin, const char **env,360 int *phandle, int *pstdin_fd, int *pstdout_fd, int *pstderr_fd,361 int params)362{363 int i;364 int success = TRUE;365 const int f_share_io[3] = { params & 1, params & 2, params & 4};366 int io_fds[3] = { -1, -1, -1 };367 HANDLE368 child_io_handles[3] = { NULL, NULL, NULL },369 standard_io_handles[3] = {370 GetStdHandle(STD_INPUT_HANDLE),371 GetStdHandle(STD_OUTPUT_HANDLE),372 GetStdHandle(STD_ERROR_HANDLE)};373 const char modes[3] = "rww";374 HANDLE cur_process = GetCurrentProcess(), child_process = NULL;375 void* envblk = NULL;376377 /****** create io handles & fds ***/378379 for (i=0; i<3 && success; ++i)380 {381 if (f_share_io[i])382 {383 success = DuplicateHandle(384 cur_process, standard_io_handles[i],385 cur_process, &child_io_handles[i],386 0, FALSE, DUPLICATE_SAME_ACCESS);387 }388 else389 {390 HANDLE a, b;391 success = CreatePipe(&a,&b,NULL,0);392 if(success)393 {394 HANDLE parent_end;395 if (modes[i]=='r') { child_io_handles[i]=a; parent_end=b; }396 else { parent_end=a; child_io_handles[i]=b; }397 success = (io_fds[i] = _open_osfhandle((C_word)parent_end,0)) >= 0;398 /* Make new handle inheritable */399 if (success)400 success = SetHandleInformation(child_io_handles[i], HANDLE_FLAG_INHERIT, -1);401 }402 }403 }404405#if 0 /* Requires a sorted list by key! */406 /****** create environment block if necessary ****/407408 if (env && success)409 {410 char** p;411 int len = 0;412413 for (p = env; *p; ++p) len += strlen(*p) + 1;414415 if (envblk = C_malloc(len + 1))416 {417 char* pb = (char*)envblk;418 for (p = env; *p; ++p)419 {420 C_strlcpy(pb, *p, len+1);421 pb += strlen(*p) + 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 = CreateProcess(448 NULL, (char*)cmdlin, NULL, NULL, TRUE, 0, envblk, NULL, &si, &pi);449450 if (success)451 {452 child_process=pi.hProcess;453 CloseHandle(pi.hThread);454 }455 else456 set_last_errno();457 }458 else459 set_last_errno();460461 /****** cleanup & return *********/462463 /* parent must close child end */464 for (i=0; i<3; ++i) {465 if (child_io_handles[i] != NULL)466 CloseHandle(child_io_handles[i]);467 }468469 if (success)470 {471 *phandle = (C_word)child_process;472 *pstdin_fd = io_fds[0];473 *pstdout_fd = io_fds[1];474 *pstderr_fd = io_fds[2];475 }476 else477 {478 for (i=0; i<3; ++i) {479 if (io_fds[i] != -1)480 _close(io_fds[i]);481 }482 }483484 return success;485}486487static int set_file_mtime(char *filename, C_word atime, C_word mtime)488{489 struct stat sb;490 struct _utimbuf tb;491492 /* Only stat if needed */493 if (atime == C_SCHEME_FALSE || mtime == C_SCHEME_FALSE) {494 if (C_stat(filename, &sb) == -1) return -1;495 }496497 if (atime == C_SCHEME_FALSE) {498 tb.actime = sb.st_atime;499 } else {500 tb.actime = C_num_to_int64(atime);501 }502 if (mtime == C_SCHEME_FALSE) {503 tb.modtime = sb.st_mtime;504 } else {505 tb.modtime = C_num_to_int64(mtime);506 }507 return _utime(filename, &tb);508}509510<#511512(import (only chicken.string string-intersperse))513514;;; Lo-level I/O:515516(define-foreign-variable _o_noinherit int "O_NOINHERIT")517(set! chicken.file.posix#open/noinherit _o_noinherit)518519(set! chicken.file.posix#file-open520 (let ((defmode (bitwise-ior _s_irusr _s_iwusr _s_irgrp _s_iwgrp _s_iroth _s_iwoth)))521 (lambda (filename flags . mode)522 (let ([mode (if (pair? mode) (car mode) defmode)])523 (##sys#check-string filename 'file-open)524 (##sys#check-fixnum flags 'file-open)525 (##sys#check-fixnum mode 'file-open)526 (let ([fd (##core#inline "C_open" (##sys#make-c-string filename 'file-open) flags mode)])527 (when (eq? -1 fd)528 (##sys#signal-hook/errno529 #:file-error (##sys#update-errno) 'file-open "cannot open file" filename flags mode))530 fd) ) ) ) )531532(set! chicken.file.posix#file-close533 (lambda (fd)534 (##sys#check-fixnum fd 'file-close)535 (let loop ()536 (when (fx< (##core#inline "C_close" fd) 0)537 (cond538 ((fx= _errno _eintr) (##sys#dispatch-interrupt loop))539 (else540 (posix-error #:file-error 'file-close "cannot close file" fd)))))))541542(set! chicken.file.posix#file-read543 (lambda (fd size . buffer)544 (##sys#check-fixnum fd 'file-read)545 (##sys#check-fixnum size 'file-read)546 (let ([buf (if (pair? buffer) (car buffer) (make-string size))])547 (unless (and (##core#inline "C_blockp" buf) (##core#inline "C_byteblockp" buf))548 (##sys#signal-hook #:type-error 'file-read "bad argument type - not a string or blob" buf) )549 (let ([n (##core#inline "C_read" fd buf size)])550 (when (eq? -1 n)551 (##sys#signal-hook/errno552 #:file-error (##sys#update-errno) 'file-read "cannot read from file" fd size))553 (list buf n) ) ) ) )554555(set! chicken.file.posix#file-write556 (lambda (fd buffer . size)557 (##sys#check-fixnum fd 'file-write)558 (unless (and (##core#inline "C_blockp" buffer) (##core#inline "C_byteblockp" buffer))559 (##sys#signal-hook #:type-error 'file-write "bad argument type - not a string or blob" buffer) )560 (let ([size (if (pair? size) (car size) (##sys#size buffer))])561 (##sys#check-fixnum size 'file-write)562 (let ([n (##core#inline "C_write" fd buffer size)])563 (when (eq? -1 n)564 (##sys#signal-hook/errno565 #:file-error (##sys#update-errno) 'file-write "cannot write to file" fd size))566 n) ) ) )567568(set! chicken.file.posix#file-mkstemp569 (lambda (template)570 (##sys#check-string template 'file-mkstemp)571 (let* ((diz "0123456789abcdefghijklmnopqrstuvwxyz")572 (diz-len (string-length diz))573 (max-attempts (* diz-len diz-len diz-len))574 (tmpl (string-copy template)) ; We'll overwrite this later575 (tmpl-len (string-length tmpl))576 (first-x (let loop ((i (fx- tmpl-len 1)))577 (if (and (fx>= i 0)578 (eq? (string-ref tmpl i) #\X))579 (loop (fx- i 1))580 (fx+ i 1)))))581 (cond ((not (##sys#file-exists? (or (pathname-directory template) ".") #f #t 'file-mkstemp))582 ;; Quit early instead of looping needlessly with C_open583 ;; failing every time. This is a race condition, but not584 ;; a security-critical one.585 (##sys#signal-hook #:file-error 'file-mkstemp "non-existent directory" template))586 ((fx= first-x tmpl-len)587 (##sys#signal-hook #:file-error 'file-mkstemp "invalid template" template)))588 (let loop ((count 1))589 (let suffix-loop ((index (fx- tmpl-len 1)))590 (when (fx>= index first-x)591 (string-set! tmpl index592 (string-ref diz (##core#inline "C_rand" diz-len)))593 (suffix-loop (fx- index 1))))594 (let ((fd (##core#inline "C_open"595 (##sys#make-c-string tmpl 'file-open)596 (bitwise-ior chicken.file.posix#open/rdwr597 chicken.file.posix#open/creat598 chicken.file.posix#open/excl)599 (fxior _s_irusr _s_iwusr))))600 (if (eq? -1 fd)601 (if (fx< count max-attempts)602 (loop (fx+ count 1))603 (posix-error #:file-error 'file-mkstemp "cannot create temporary file" template))604 (values fd tmpl)))))))605606;;; Pipe primitive:607608(define-foreign-variable _pipefd0 int "C_pipefds[ 0 ]")609(define-foreign-variable _pipefd1 int "C_pipefds[ 1 ]")610611(set! chicken.process#create-pipe612 (lambda (#!optional (mode (fxior chicken.file.posix#open/binary613 chicken.file.posix#open/noinherit)))614 (when (fx< (##core#inline "C_pipe" #f mode) 0)615 (##sys#signal-hook/errno616 #:file-error (##sys#update-errno) 'create-pipe "cannot create pipe"))617 (values _pipefd0 _pipefd1) ) )618619;;; Signal processing:620621(define-foreign-variable _nsig int "NSIG")622(define-foreign-variable _sigterm int "SIGTERM")623(define-foreign-variable _sigint int "SIGINT")624(define-foreign-variable _sigfpe int "SIGFPE")625(define-foreign-variable _sigill int "SIGILL")626(define-foreign-variable _sigsegv int "SIGSEGV")627(define-foreign-variable _sigabrt int "SIGABRT")628(define-foreign-variable _sigbreak int "SIGBREAK")629630(set! chicken.process.signal#signal/term _sigterm)631(set! chicken.process.signal#signal/int _sigint)632(set! chicken.process.signal#signal/fpe _sigfpe)633(set! chicken.process.signal#signal/ill _sigill)634(set! chicken.process.signal#signal/segv _sigsegv)635(set! chicken.process.signal#signal/abrt _sigabrt)636(set! chicken.process.signal#signal/break _sigbreak)637(set! chicken.process.signal#signal/alrm 0)638(set! chicken.process.signal#signal/bus 0)639(set! chicken.process.signal#signal/chld 0)640(set! chicken.process.signal#signal/cont 0)641(set! chicken.process.signal#signal/hup 0)642(set! chicken.process.signal#signal/io 0)643(set! chicken.process.signal#signal/kill 0)644(set! chicken.process.signal#signal/pipe 0)645(set! chicken.process.signal#signal/prof 0)646(set! chicken.process.signal#signal/quit 0)647(set! chicken.process.signal#signal/stop 0)648(set! chicken.process.signal#signal/trap 0)649(set! chicken.process.signal#signal/tstp 0)650(set! chicken.process.signal#signal/urg 0)651(set! chicken.process.signal#signal/usr1 0)652(set! chicken.process.signal#signal/usr2 0)653(set! chicken.process.signal#signal/vtalrm 0)654(set! chicken.process.signal#signal/winch 0)655(set! chicken.process.signal#signal/xcpu 0)656(set! chicken.process.signal#signal/xfsz 0)657658(set! chicken.process.signal#signals-list659 (list660 chicken.process.signal#signal/term661 chicken.process.signal#signal/int662 chicken.process.signal#signal/fpe663 chicken.process.signal#signal/ill664 chicken.process.signal#signal/segv665 chicken.process.signal#signal/abrt666 chicken.process.signal#signal/break))667668;;; Using file-descriptors:669670(define duplicate-fileno671 (lambda (old . new)672 (##sys#check-fixnum old duplicate-fileno)673 (let ([fd (if (null? new)674 (##core#inline "C_dup" old)675 (let ([n (car new)])676 (##sys#check-fixnum n 'duplicate-fileno)677 (##core#inline "C_dup2" old n) ) ) ] )678 (when (fx< fd 0)679 (##sys#signal-hook/errno680 #:file-error (##sys#update-errno) 'duplicate-fileno "cannot duplicate file descriptor" old))681 fd) ) )682683684;;; Time related things:685686(set! chicken.time.posix#local-timezone-abbreviation687 (foreign-lambda* c-string ()688 "char *z = (_daylight ? _tzname[1] : _tzname[0]);\n"689 "C_return(z);") )690691692;;; Process handling:693694(define-foreign-variable _p_overlay int "P_OVERLAY")695(define-foreign-variable _p_wait int "P_WAIT")696(define-foreign-variable _p_nowait int "P_NOWAIT")697(define-foreign-variable _p_nowaito int "P_NOWAITO")698(define-foreign-variable _p_detach int "P_DETACH")699700(set! chicken.process#spawn/overlay _p_overlay)701(set! chicken.process#spawn/wait _p_wait)702(set! chicken.process#spawn/nowait _p_nowait)703(set! chicken.process#spawn/nowaito _p_nowaito)704(set! chicken.process#spawn/detach _p_detach)705706; Windows uses a commandline style for process arguments. Thus any707; arguments with embedded whitespace will parse incorrectly. Must708; string-quote such arguments.709(define quote-arg-string710 (let ((needs-quoting?711 ;; This is essentially (string-any char-whitespace? s) but we712 ;; don't want a SRFI-13 dependency. (Do we?)713 (lambda (s)714 (let ((len (string-length s)))715 (let loop ((i 0))716 (cond717 ((fx= i len) #f)718 ((char-whitespace? (string-ref s i)) #t)719 (else (loop (fx+ i 1)))))))))720 (lambda (str)721 (if (needs-quoting? str) (string-append "\"" str "\"") str))))722723(set! chicken.process#process-execute724 (lambda (filename #!optional (arglist '()) envlist exactf)725 (let ((argconv (if exactf (lambda (x) x) quote-arg-string)))726 (call-with-exec-args727 'process-execute filename argconv arglist envlist728 (lambda (prg argbuf envbuf)729 (##core#inline "C_flushall")730 (let ((r (if envbuf731 (##core#inline "C_u_i_execve" prg argbuf envbuf)732 (##core#inline "C_u_i_execvp" prg argbuf))))733 (when (fx= r -1)734 (posix-error #:process-error 'process-execute "cannot execute process" filename))))))))735736(set! chicken.process#process-spawn737 (lambda (mode filename #!optional (arglist '()) envlist exactf)738 (let ((argconv (if exactf (lambda (x) x) quote-arg-string)))739 (##sys#check-fixnum mode 'process-spawn)740 (call-with-exec-args741 'process-spawn filename argconv arglist envlist742 (lambda (prg argbuf envbuf)743 (##core#inline "C_flushall")744 (let ((r (if envbuf745 (##core#inline "C_u_i_spawnvpe" mode prg argbuf envbuf)746 (##core#inline "C_u_i_spawnvp" mode prg argbuf))))747 (when (fx= r -1)748 (posix-error #:process-error 'process-spawn "cannot spawn process" filename))749 r))))))750751(define-foreign-variable _shlcmd c-string "C_shlcmd")752753(define (shell-command loc)754 (or (get-environment-variable "COMSPEC")755 (if (##core#inline "C_get_shlcmd")756 _shlcmd757 (##sys#error/errno758 (##sys#update-errno) loc "cannot retrieve system directory"))))759760(define (shell-command-arguments cmdlin)761 (list "/c" cmdlin) )762763(set! chicken.process#process-run764 (lambda (f . args)765 (let ((args (if (pair? args) (car args) #f)))766 (if args767 (chicken.process#process-spawn768 chicken.process#spawn/nowait f args)769 (chicken.process#process-spawn770 chicken.process#spawn/nowait771 (shell-command 'process-run)772 (shell-command-arguments f)) ) ) ) )773774;;; Run subprocess connected with pipes:775(define-foreign-variable _rdbuf char "C_rdbuf")776(define-foreign-variable _wr0 int "C_wr0_")777(define-foreign-variable _rd1 int "C_rd1_")778779; from original by Mejedi780;; process-impl781; loc caller procedure symbol782; cmd pathname or commandline783; args string-list or '()784; env string-list or #f (currently ignored)785; stdoutf #f then share, or #t then create786; stdinf #f then share, or #t then create787; stderrf #f then share, or #t then create788;789; (values stdin-input-port? stdout-output-port? pid stderr-input-port?)790; where stdin-input-port?, etc. is a port or #f, indicating no port created.791792(define process-impl793 ;; XXX TODO: When environment is implemented, check for embedded NUL bytes!794 (let ([c-process795 (foreign-lambda bool "C_process" c-string c-string c-pointer796 (c-pointer int) (c-pointer int) (c-pointer int) (c-pointer int) int)])797 ; The environment list must be sorted & include current directory798 ; information for the system drives. i.e !C:=...799 ; For now any environment is ignored.800 (lambda (loc cmd args env stdoutf stdinf stderrf #!optional exactf)801 (let* ((arglist (cons cmd args))802 (cmdlin (string-intersperse803 (if exactf804 arglist805 (map quote-arg-string arglist)))))806 (let-location ([handle int -1]807 [stdin_fd int -1] [stdout_fd int -1] [stderr_fd int -1])808 (let ([res809 (c-process cmd cmdlin #f810 (location handle)811 (location stdin_fd) (location stdout_fd) (location stderr_fd)812 (+ (if stdinf 0 1) (if stdoutf 0 2) (if stderrf 0 4)))])813 (if res814 (values815 (and stdoutf (chicken.file.posix#open-input-file*816 stdout_fd)) ;Parent stdin817 (and stdinf (chicken.file.posix#open-output-file*818 stdin_fd)) ;Parent stdout819 handle820 (and stderrf (chicken.file.posix#open-input-file*821 stderr_fd)))822 (##sys#signal-hook/errno823 #:process-error (##sys#update-errno) loc "cannot execute process" cmdlin))))))))824825;; TODO: See if this can be moved to posix-common826(let ((%process827 (lambda (loc err? cmd args env exactf)828 (let ((chkstrlst829 (lambda (lst)830 (##sys#check-list lst loc)831 (for-each (cut ##sys#check-string <> loc) lst) )))832 (##sys#check-string cmd loc)833 (if args834 (chkstrlst args)835 (begin836 (set! exactf #t)837 (set! args (shell-command-arguments cmd))838 (set! cmd (shell-command loc)) ) )839 (when env (check-environment-list env loc))840 (receive (in out pid err)841 (process-impl loc cmd args env #t #t err? exactf)842 (if err?843 (values in out pid err)844 (values in out pid) ) ) ) )) )845 (set! chicken.process#process846 (lambda (cmd #!optional args env exactf)847 (%process 'process #f cmd args env exactf) ))848 (set! chicken.process#process*849 (lambda (cmd #!optional args env exactf)850 (%process 'process* #t cmd args env exactf) )) )851852(define-foreign-variable _exstatus int "C_exstatus")853854(define (process-wait-impl pid nohang)855 (if (##core#inline "C_process_wait" pid nohang)856 (values pid #t _exstatus)857 (values -1 #f #f) ) )858859860;;; Getting group- and user-information:861862(define-foreign-variable _username c-string "C_username")863864(set! chicken.process-context.posix#current-user-name865 (lambda ()866 (if (##core#inline "C_get_user_name")867 _username868 (##sys#error/errno869 (##sys#update-errno) 'current-user-name "cannot retrieve current user-name"))))870871872;;; unimplemented stuff:873874(define-unimplemented chown) ; covers set-file-group! and set-file-owner!875(set!-unimplemented chicken.file.posix#create-fifo)876(set!-unimplemented chicken.process-context.posix#create-session)877(set!-unimplemented chicken.file.posix#create-symbolic-link)878(set!-unimplemented chicken.process-context.posix#current-effective-group-id)879(set!-unimplemented chicken.process-context.posix#current-effective-user-id)880(set!-unimplemented chicken.process-context.posix#current-effective-user-name)881(set!-unimplemented chicken.process-context.posix#current-group-id)882(set!-unimplemented chicken.process-context.posix#current-user-id)883(set!-unimplemented chicken.process-context.posix#user-information)884(set!-unimplemented chicken.file.posix#file-control)885(set!-unimplemented chicken.file.posix#file-link)886(set!-unimplemented chicken.file.posix#file-lock)887(set!-unimplemented chicken.file.posix#file-lock/blocking)888(set!-unimplemented chicken.file.posix#file-select)889(set!-unimplemented chicken.file.posix#file-test-lock)890(set!-unimplemented chicken.file.posix#file-truncate)891(set!-unimplemented chicken.file.posix#file-unlock)892(set!-unimplemented chicken.process-context.posix#parent-process-id)893(set!-unimplemented chicken.process#process-fork)894(set!-unimplemented chicken.process-context.posix#process-group-id)895(set!-unimplemented chicken.process#process-signal)896(set!-unimplemented chicken.file.posix#read-symbolic-link)897(set!-unimplemented chicken.process.signal#set-alarm!)898(set!-unimplemented chicken.process-context.posix#set-root-directory!)899(set!-unimplemented chicken.process.signal#set-signal-mask!)900(set!-unimplemented chicken.process.signal#signal-mask)901(set!-unimplemented chicken.process.signal#signal-mask!)902(set!-unimplemented chicken.process.signal#signal-masked?)903(set!-unimplemented chicken.process.signal#signal-unmask!)904(set!-unimplemented chicken.process-context.posix#user-information)905(set!-unimplemented chicken.time.posix#utc-time->seconds)906(set!-unimplemented chicken.time.posix#string->time)907908;; Unix-only definitions909(set! chicken.file.posix#fcntl/dupfd 0)910(set! chicken.file.posix#fcntl/getfd 0)911(set! chicken.file.posix#fcntl/setfd 0)912(set! chicken.file.posix#fcntl/getfl 0)913(set! chicken.file.posix#fcntl/setfl 0)914(set! chicken.file.posix#open/noctty 0)915(set! chicken.file.posix#open/nonblock 0)916(set! chicken.file.posix#open/fsync 0)917(set! chicken.file.posix#open/sync 0)918(set! chicken.file.posix#perm/isgid 0)919(set! chicken.file.posix#perm/isuid 0)920(set! chicken.file.posix#perm/isvtx 0)