~ chicken-core (chicken-5) /posixunix.scm
Trap1;;;; posixunix.scm - Miscellaneous file- and process-handling routines2;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;; these are not available on Windows2930(define-foreign-variable _stat_st_blksize unsigned-int "C_statbuf.st_blksize")31(define-foreign-variable _stat_st_blocks unsigned-int "C_statbuf.st_blocks")3233(include "posix-common.scm")3435#>3637static C_TLS int C_wait_status;3839#include <sys/time.h>40#include <sys/wait.h>41#include <sys/ioctl.h>42#include <fcntl.h>43#include <dirent.h>44#include <pwd.h>45#include <utime.h>4647#if defined(__sun) && defined(__SVR4)48# include <sys/tty.h>49# include <termios.h>50#endif5152#include <sys/mman.h>53#include <poll.h>5455#ifndef O_FSYNC56# define O_FSYNC O_SYNC57#endif5859#ifndef PIPE_BUF60# ifdef __CYGWIN__61# define PIPE_BUF _POSIX_PIPE_BUF62# else63# define PIPE_BUF 102464# endif65#endif6667#ifndef O_BINARY68# define O_BINARY 069#endif70#ifndef O_TEXT71# define O_TEXT 072#endif7374#ifndef MAP_FILE75# define MAP_FILE 076#endif7778#ifndef MAP_ANON79# define MAP_ANON 080#endif8182#ifndef FILENAME_MAX83# define FILENAME_MAX 102484#endif8586static C_TLS struct flock C_flock;87static C_TLS DIR *temphandle;88static C_TLS struct passwd *C_user;8990/* Android doesn't provide pw_gecos in the passwd struct */91#ifdef __ANDROID__92# define C_PW_GECOS ("")93#else94# define C_PW_GECOS (C_user->pw_gecos)95#endif9697static C_TLS int C_pipefds[ 2 ];98static C_TLS time_t C_secs;99static C_TLS struct timeval C_timeval;100static C_TLS struct stat C_statbuf;101102#define C_fchdir(fd) C_fix(fchdir(C_unfix(fd)))103104#define open_binary_input_pipe(a, n, name) C_mpointer(a, popen(C_c_string(name), "r"))105#define open_text_input_pipe(a, n, name) open_binary_input_pipe(a, n, name)106#define open_binary_output_pipe(a, n, name) C_mpointer(a, popen(C_c_string(name), "w"))107#define open_text_output_pipe(a, n, name) open_binary_output_pipe(a, n, name)108#define close_pipe(p) C_fix(pclose(C_port_file(p)))109110#define C_fork fork111#define C_waitpid(id, o) C_fix(waitpid(C_unfix(id), &C_wait_status, C_unfix(o)))112#define C_getppid getppid113#define C_kill(id, s) C_fix(kill(C_unfix(id), C_unfix(s)))114#define C_getuid getuid115#define C_getgid getgid116#define C_geteuid geteuid117#define C_getegid getegid118#define C_chown(fn, u, g) C_fix(chown(C_c_string(fn), C_unfix(u), C_unfix(g)))119#define C_fchown(fd, u, g) C_fix(fchown(C_unfix(fd), C_unfix(u), C_unfix(g)))120#define C_chmod(fn, m) C_fix(chmod(C_c_string(fn), C_unfix(m)))121#define C_fchmod(fd, m) C_fix(fchmod(C_unfix(fd), C_unfix(m)))122#define C_setuid(id) C_fix(setuid(C_unfix(id)))123#define C_setgid(id) C_fix(setgid(C_unfix(id)))124#define C_seteuid(id) C_fix(seteuid(C_unfix(id)))125#define C_setegid(id) C_fix(setegid(C_unfix(id)))126#define C_setsid(dummy) C_fix(setsid())127#define C_setpgid(x, y) C_fix(setpgid(C_unfix(x), C_unfix(y)))128#define C_getpgid(x) C_fix(getpgid(C_unfix(x)))129#define C_symlink(o, n) C_fix(symlink(C_c_string(o), C_c_string(n)))130#define C_do_readlink(f, b) C_fix(readlink(C_c_string(f), C_c_string(b), FILENAME_MAX))131#define C_getpwnam(n) C_mk_bool((C_user = getpwnam(C_c_string(n))) != NULL)132#define C_getpwuid(u) C_mk_bool((C_user = getpwuid(C_unfix(u))) != NULL)133#define C_pipe(d) C_fix(pipe(C_pipefds))134#define C_truncate(f, n) C_fix(truncate(C_c_string(f), C_num_to_int(n)))135#define C_ftruncate(f, n) C_fix(ftruncate(C_unfix(f), C_num_to_int(n)))136#define C_alarm alarm137#define C_close(fd) C_fix(close(C_unfix(fd)))138#define C_umask(m) C_fix(umask(C_unfix(m)))139140#define C_u_i_lstat(fn) C_fix(lstat(C_c_string(fn), &C_statbuf))141142#define C_u_i_execvp(f,a) C_fix(execvp(C_c_string(f), (char *const *)C_c_pointer_vector_or_null(a)))143#define C_u_i_execve(f,a,e) C_fix(execve(C_c_string(f), (char *const *)C_c_pointer_vector_or_null(a), (char *const *)C_c_pointer_vector_or_null(e)))144145static C_TLS int C_uw;146#define C_WIFEXITED(n) (C_uw = C_unfix(n), C_mk_bool(WIFEXITED(C_uw)))147#define C_WIFSIGNALED(n) (C_uw = C_unfix(n), C_mk_bool(WIFSIGNALED(C_uw)))148#define C_WIFSTOPPED(n) (C_uw = C_unfix(n), C_mk_bool(WIFSTOPPED(C_uw)))149#define C_WEXITSTATUS(n) (C_uw = C_unfix(n), C_fix(WEXITSTATUS(C_uw)))150#define C_WTERMSIG(n) (C_uw = C_unfix(n), C_fix(WTERMSIG(C_uw)))151#define C_WSTOPSIG(n) (C_uw = C_unfix(n), C_fix(WSTOPSIG(C_uw)))152153#ifdef __CYGWIN__154# define C_mkfifo(fn, m) C_fix(-1)155#else156# define C_mkfifo(fn, m) C_fix(mkfifo(C_c_string(fn), C_unfix(m)))157#endif158159#define C_flock_setup(t, s, n) (C_flock.l_type = C_unfix(t), C_flock.l_start = C_num_to_int(s), C_flock.l_whence = SEEK_SET, C_flock.l_len = C_num_to_int(n), C_SCHEME_UNDEFINED)160#define C_flock_test(p) (fcntl(fileno(C_port_file(p)), F_GETLK, &C_flock) >= 0 ? (C_flock.l_type == F_UNLCK ? C_fix(0) : C_fix(C_flock.l_pid)) : C_SCHEME_FALSE)161#define C_flock_lock(p) C_fix(fcntl(fileno(C_port_file(p)), F_SETLK, &C_flock))162#define C_flock_lockw(p) C_fix(fcntl(fileno(C_port_file(p)), F_SETLKW, &C_flock))163164static C_TLS sigset_t C_sigset;165#define C_sigemptyset(d) (sigemptyset(&C_sigset), C_SCHEME_UNDEFINED)166#define C_sigaddset(s) (sigaddset(&C_sigset, C_unfix(s)), C_SCHEME_UNDEFINED)167#define C_sigdelset(s) (sigdelset(&C_sigset, C_unfix(s)), C_SCHEME_UNDEFINED)168#define C_sigismember(s) C_mk_bool(sigismember(&C_sigset, C_unfix(s)))169#define C_sigprocmask_set(d) C_fix(sigprocmask(SIG_SETMASK, &C_sigset, NULL))170#define C_sigprocmask_block(d) C_fix(sigprocmask(SIG_BLOCK, &C_sigset, NULL))171#define C_sigprocmask_unblock(d) C_fix(sigprocmask(SIG_UNBLOCK, &C_sigset, NULL))172#define C_sigprocmask_get(d) C_fix(sigprocmask(SIG_SETMASK, NULL, &C_sigset))173174#define C_open(fn, fl, m) C_fix(open(C_c_string(fn), C_unfix(fl), C_unfix(m)))175#define C_read(fd, b, n) C_fix(read(C_unfix(fd), C_data_pointer(b), C_unfix(n)))176#define C_write(fd, b, n) C_fix(write(C_unfix(fd), C_data_pointer(b), C_unfix(n)))177#define C_mkstemp(t) C_fix(mkstemp(C_c_string(t)))178179#define C_ctime(n) (C_secs = (n), ctime(&C_secs))180181#if defined(__SVR4) || defined(C_MACOSX) || defined(__ANDROID__) || defined(_AIX)182/* Seen here: http://lists.samba.org/archive/samba-technical/2002-November/025571.html */183184static time_t C_timegm(struct tm *t)185{186 time_t tl, tb;187 struct tm *tg;188189 tl = mktime (t);190 if (tl == -1)191 {192 t->tm_hour--;193 tl = mktime (t);194 if (tl == -1)195 return -1; /* can't deal with output from strptime */196 tl += 3600;197 }198 tg = gmtime (&tl);199 tg->tm_isdst = 0;200 tb = mktime (tg);201 if (tb == -1)202 {203 tg->tm_hour--;204 tb = mktime (tg);205 if (tb == -1)206 return -1; /* can't deal with output from gmtime */207 tb += 3600;208 }209 return (tl - (tb - tl));210}211#else212#define C_timegm timegm213#endif214215#define C_a_timegm(ptr, c, v, tm) C_int64_to_num(ptr, C_timegm(C_tm_set((v), C_data_pointer(tm))))216217#ifdef __linux__218extern char *strptime(const char *s, const char *format, struct tm *tm);219extern pid_t getpgid(pid_t pid);220#endif221222/* tm_get could be in posix-common, but it's only used in here */223#define cpy_tmstc08_to_tmvec(v, ptm) \224 (C_set_block_item((v), 0, C_fix(((struct tm *)ptm)->tm_sec)), \225 C_set_block_item((v), 1, C_fix((ptm)->tm_min)), \226 C_set_block_item((v), 2, C_fix((ptm)->tm_hour)), \227 C_set_block_item((v), 3, C_fix((ptm)->tm_mday)), \228 C_set_block_item((v), 4, C_fix((ptm)->tm_mon)), \229 C_set_block_item((v), 5, C_fix((ptm)->tm_year)), \230 C_set_block_item((v), 6, C_fix((ptm)->tm_wday)), \231 C_set_block_item((v), 7, C_fix((ptm)->tm_yday)), \232 C_set_block_item((v), 8, ((ptm)->tm_isdst ? C_SCHEME_TRUE : C_SCHEME_FALSE)))233234#define cpy_tmstc9_to_tmvec(v, ptm) \235 (C_set_block_item((v), 9, C_fix(-(ptm)->tm_gmtoff)))236237#define C_tm_get_08(v, tm) cpy_tmstc08_to_tmvec( (v), (tm) )238#define C_tm_get_9(v, tm) cpy_tmstc9_to_tmvec( (v), (tm) )239240static C_word241C_tm_get( C_word v, void *tm )242{243 C_tm_get_08( v, (struct tm *)tm );244#if defined(C_GNU_ENV) && !defined(__CYGWIN__) && !defined(__uClinux__)245 C_tm_get_9( v, (struct tm *)tm );246#endif247 return v;248}249250#define C_strptime(s, f, v, stm) \251 (strptime(C_c_string(s), C_c_string(f), ((struct tm *)(stm))) ? C_tm_get((v), (stm)) : C_SCHEME_FALSE)252253static int set_file_mtime(char *filename, C_word atime, C_word mtime)254{255 struct stat sb;256 struct utimbuf tb;257258 /* Only lstat if needed */259 if (atime == C_SCHEME_FALSE || mtime == C_SCHEME_FALSE) {260 if (lstat(filename, &sb) == -1) return -1;261 }262263 if (atime == C_SCHEME_FALSE) {264 tb.actime = sb.st_atime;265 } else {266 tb.actime = C_num_to_int64(atime);267 }268 if (mtime == C_SCHEME_FALSE) {269 tb.modtime = sb.st_mtime;270 } else {271 tb.modtime = C_num_to_int64(mtime);272 }273 return utime(filename, &tb);274}275276<#277278;; Faster versions of common operations279280(define ##sys#file-nonblocking!281 (foreign-lambda* bool ([int fd])282 "int val = fcntl(fd, F_GETFL, 0);"283 "if(val == -1) C_return(0);"284 "C_return(fcntl(fd, F_SETFL, val | O_NONBLOCK) != -1);" ) )285286(define ##sys#file-select-one (foreign-lambda int "C_check_fd_ready" int) )287288;;; Lo-level I/O:289290(define-foreign-variable _f_dupfd int "F_DUPFD")291(define-foreign-variable _f_getfd int "F_GETFD")292(define-foreign-variable _f_setfd int "F_SETFD")293(define-foreign-variable _f_getfl int "F_GETFL")294(define-foreign-variable _f_setfl int "F_SETFL")295296(set! chicken.file.posix#fcntl/dupfd _f_dupfd)297(set! chicken.file.posix#fcntl/getfd _f_getfd)298(set! chicken.file.posix#fcntl/setfd _f_setfd)299(set! chicken.file.posix#fcntl/getfl _f_getfl)300(set! chicken.file.posix#fcntl/setfl _f_setfl)301302(define-foreign-variable _o_nonblock int "O_NONBLOCK")303(define-foreign-variable _o_noctty int "O_NOCTTY")304(define-foreign-variable _o_fsync int "O_FSYNC")305(define-foreign-variable _o_sync int "O_SYNC")306(set! chicken.file.posix#open/nonblock _o_nonblock)307(set! chicken.file.posix#open/noctty _o_noctty)308(set! chicken.file.posix#open/fsync _o_fsync)309(set! chicken.file.posix#open/sync _o_sync)310311;; Windows-only definitions312(set! chicken.file.posix#open/noinherit 0)313314(set! chicken.process#spawn/overlay 0)315(set! chicken.process#spawn/wait 0)316(set! chicken.process#spawn/nowait 0)317(set! chicken.process#spawn/nowaito 0)318(set! chicken.process#spawn/detach 0)319320(define-foreign-variable _s_isuid int "S_ISUID")321(define-foreign-variable _s_isgid int "S_ISGID")322(define-foreign-variable _s_isvtx int "S_ISVTX")323(set! chicken.file.posix#perm/isvtx _s_isvtx)324(set! chicken.file.posix#perm/isuid _s_isuid)325(set! chicken.file.posix#perm/isgid _s_isgid)326327(set! chicken.file.posix#file-control328 (let ([fcntl (foreign-lambda int fcntl int int long)])329 (lambda (fd cmd #!optional (arg 0))330 (##sys#check-fixnum fd 'file-control)331 (##sys#check-fixnum cmd 'file-control)332 (let ([res (fcntl fd cmd arg)])333 (if (fx= res -1)334 (posix-error #:file-error 'file-control "cannot control file" fd cmd)335 res ) ) ) ) )336337(set! chicken.file.posix#file-open338 (let ((defmode (bitwise-ior _s_irusr _s_iwusr _s_irgrp _s_iwgrp _s_iroth _s_iwoth)))339 (lambda (filename flags . mode)340 (let ([mode (if (pair? mode) (car mode) defmode)])341 (##sys#check-string filename 'file-open)342 (##sys#check-fixnum flags 'file-open)343 (##sys#check-fixnum mode 'file-open)344 (let ([fd (##core#inline "C_open" (##sys#make-c-string filename 'file-open) flags mode)])345 (when (eq? -1 fd)346 (posix-error #:file-error 'file-open "cannot open file" filename flags mode) )347 fd) ) ) ) )348349(set! chicken.file.posix#file-close350 (lambda (fd)351 (##sys#check-fixnum fd 'file-close)352 (let loop ()353 (when (fx< (##core#inline "C_close" fd) 0)354 (cond355 ((fx= _errno _eintr) (##sys#dispatch-interrupt loop))356 (else357 (posix-error #:file-error 'file-close "cannot close file" fd)))))))358359(set! chicken.file.posix#file-read360 (lambda (fd size . buffer)361 (##sys#check-fixnum fd 'file-read)362 (##sys#check-fixnum size 'file-read)363 (let ([buf (if (pair? buffer) (car buffer) (make-string size))])364 (unless (and (##core#inline "C_blockp" buf) (##core#inline "C_byteblockp" buf))365 (##sys#signal-hook #:type-error 'file-read "bad argument type - not a string or blob" buf) )366 (let ([n (##core#inline "C_read" fd buf size)])367 (when (eq? -1 n)368 (posix-error #:file-error 'file-read "cannot read from file" fd size) )369 (list buf n) ) ) ) )370371(set! chicken.file.posix#file-write372 (lambda (fd buffer . size)373 (##sys#check-fixnum fd 'file-write)374 (unless (and (##core#inline "C_blockp" buffer) (##core#inline "C_byteblockp" buffer))375 (##sys#signal-hook #:type-error 'file-write "bad argument type - not a string or blob" buffer) )376 (let ([size (if (pair? size) (car size) (##sys#size buffer))])377 (##sys#check-fixnum size 'file-write)378 (let ([n (##core#inline "C_write" fd buffer size)])379 (when (eq? -1 n)380 (posix-error #:file-error 'file-write "cannot write to file" fd size) )381 n) ) ) )382383(set! chicken.file.posix#file-mkstemp384 (lambda (template)385 (##sys#check-string template 'file-mkstemp)386 (let* ([buf (##sys#make-c-string template 'file-mkstemp)]387 [fd (##core#inline "C_mkstemp" buf)]388 [path-length (##sys#size buf)])389 (when (eq? -1 fd)390 (posix-error #:file-error 'file-mkstemp "cannot create temporary file" template) )391 (values fd (##sys#substring buf 0 (fx- path-length 1) ) ) ) ) )392393394;;; I/O multiplexing:395396(set! chicken.file.posix#file-select397 (lambda (fdsr fdsw . timeout)398 (let* ((tm (if (pair? timeout) (car timeout) #f))399 (fdsrl (cond ((not fdsr) '())400 ((fixnum? fdsr) (list fdsr))401 (else (##sys#check-list fdsr 'file-select)402 fdsr)))403 (fdswl (cond ((not fdsw) '())404 ((fixnum? fdsw) (list fdsw))405 (else (##sys#check-list fdsw 'file-select)406 fdsw)))407 (nfdsr (##sys#length fdsrl))408 (nfdsw (##sys#length fdswl))409 (nfds (fx+ nfdsr nfdsw))410 (fds-blob (##sys#make-blob411 (fx* nfds (foreign-value "sizeof(struct pollfd)" int)))))412 (do ((i 0 (fx+ i 1))413 (fdsrl fdsrl (cdr fdsrl)))414 ((null? fdsrl))415 ((foreign-lambda* void ((int i) (int fd) (scheme-pointer p))416 "struct pollfd *fds = p;"417 "fds[i].fd = fd; fds[i].events = POLLIN;") i (car fdsrl) fds-blob))418 (do ((i nfdsr (fx+ i 1))419 (fdswl fdswl (cdr fdswl)))420 ((null? fdswl))421 ((foreign-lambda* void ((int i) (int fd) (scheme-pointer p))422 "struct pollfd *fds = p;"423 "fds[i].fd = fd; fds[i].events = POLLOUT;") i (car fdswl) fds-blob))424 (let ((n ((foreign-lambda int "poll" scheme-pointer int int)425 fds-blob nfds (if tm (inexact->exact (truncate (* (max 0 tm) 1000))) -1))))426 (cond ((fx< n 0)427 (posix-error #:file-error 'file-select "failed" fdsr fdsw) )428 ((fx= n 0) (values (if (pair? fdsr) '() #f) (if (pair? fdsw) '() #f)))429 (else430 (let ((rl (let lp ((i 0) (res '()) (fds fdsrl))431 (cond ((null? fds) (##sys#fast-reverse res))432 (((foreign-lambda* bool ((int i) (scheme-pointer p))433 "struct pollfd *fds = p;"434 "C_return(fds[i].revents & (POLLIN|POLLERR|POLLHUP|POLLNVAL));")435 i fds-blob)436 (lp (fx+ i 1) (cons (car fds) res) (cdr fds)))437 (else (lp (fx+ i 1) res (cdr fds))))))438 (wl (let lp ((i nfdsr) (res '()) (fds fdswl))439 (cond ((null? fds) (##sys#fast-reverse res))440 (((foreign-lambda* bool ((int i) (scheme-pointer p))441 "struct pollfd *fds = p;"442 "C_return(fds[i].revents & (POLLOUT|POLLERR|POLLHUP|POLLNVAL));")443 i fds-blob)444 (lp (fx+ i 1) (cons (car fds) res) (cdr fds)))445 (else (lp (fx+ i 1) res (cdr fds)))))))446 (values447 (and fdsr (if (fixnum? fdsr) (and (memq fdsr rl) fdsr) rl))448 (and fdsw (if (fixnum? fdsw) (and (memq fdsw wl) fdsw) wl))))))))))449450451;;; Pipe primitive:452453(define-foreign-variable _pipefd0 int "C_pipefds[ 0 ]")454(define-foreign-variable _pipefd1 int "C_pipefds[ 1 ]")455456(set! chicken.process#create-pipe457 (lambda (#!optional mode)458 (when (fx< (##core#inline "C_pipe" #f) 0)459 (posix-error #:file-error 'create-pipe "cannot create pipe") )460 (values _pipefd0 _pipefd1)) )461462463;;; Signal processing:464465(define-foreign-variable _nsig int "NSIG")466(define-foreign-variable _sigterm int "SIGTERM")467(define-foreign-variable _sigkill int "SIGKILL")468(define-foreign-variable _sigint int "SIGINT")469(define-foreign-variable _sighup int "SIGHUP")470(define-foreign-variable _sigfpe int "SIGFPE")471(define-foreign-variable _sigill int "SIGILL")472(define-foreign-variable _sigbus int "SIGBUS")473(define-foreign-variable _sigsegv int "SIGSEGV")474(define-foreign-variable _sigabrt int "SIGABRT")475(define-foreign-variable _sigtrap int "SIGTRAP")476(define-foreign-variable _sigquit int "SIGQUIT")477(define-foreign-variable _sigalrm int "SIGALRM")478(define-foreign-variable _sigpipe int "SIGPIPE")479(define-foreign-variable _sigusr1 int "SIGUSR1")480(define-foreign-variable _sigusr2 int "SIGUSR2")481(define-foreign-variable _sigvtalrm int "SIGVTALRM")482(define-foreign-variable _sigprof int "SIGPROF")483(define-foreign-variable _sigio int "SIGIO")484(define-foreign-variable _sigurg int "SIGURG")485(define-foreign-variable _sigchld int "SIGCHLD")486(define-foreign-variable _sigcont int "SIGCONT")487(define-foreign-variable _sigstop int "SIGSTOP")488(define-foreign-variable _sigtstp int "SIGTSTP")489(define-foreign-variable _sigxcpu int "SIGXCPU")490(define-foreign-variable _sigxfsz int "SIGXFSZ")491(define-foreign-variable _sigwinch int "SIGWINCH")492493(set! chicken.process.signal#signal/term _sigterm)494(set! chicken.process.signal#signal/kill _sigkill)495(set! chicken.process.signal#signal/int _sigint)496(set! chicken.process.signal#signal/hup _sighup)497(set! chicken.process.signal#signal/fpe _sigfpe)498(set! chicken.process.signal#signal/ill _sigill)499(set! chicken.process.signal#signal/segv _sigsegv)500(set! chicken.process.signal#signal/abrt _sigabrt)501(set! chicken.process.signal#signal/trap _sigtrap)502(set! chicken.process.signal#signal/quit _sigquit)503(set! chicken.process.signal#signal/alrm _sigalrm)504(set! chicken.process.signal#signal/vtalrm _sigvtalrm)505(set! chicken.process.signal#signal/prof _sigprof)506(set! chicken.process.signal#signal/io _sigio)507(set! chicken.process.signal#signal/urg _sigurg)508(set! chicken.process.signal#signal/chld _sigchld)509(set! chicken.process.signal#signal/cont _sigcont)510(set! chicken.process.signal#signal/stop _sigstop)511(set! chicken.process.signal#signal/tstp _sigtstp)512(set! chicken.process.signal#signal/pipe _sigpipe)513(set! chicken.process.signal#signal/xcpu _sigxcpu)514(set! chicken.process.signal#signal/xfsz _sigxfsz)515(set! chicken.process.signal#signal/usr1 _sigusr1)516(set! chicken.process.signal#signal/usr2 _sigusr2)517(set! chicken.process.signal#signal/winch _sigwinch)518(set! chicken.process.signal#signal/bus _sigbus)519(set! chicken.process.signal#signal/break 0)520521(set! chicken.process.signal#signals-list522 (list523 chicken.process.signal#signal/term524 chicken.process.signal#signal/kill525 chicken.process.signal#signal/int526 chicken.process.signal#signal/hup527 chicken.process.signal#signal/fpe528 chicken.process.signal#signal/ill529 chicken.process.signal#signal/segv530 chicken.process.signal#signal/abrt531 chicken.process.signal#signal/trap532 chicken.process.signal#signal/quit533 chicken.process.signal#signal/alrm534 chicken.process.signal#signal/vtalrm535 chicken.process.signal#signal/prof536 chicken.process.signal#signal/io537 chicken.process.signal#signal/urg538 chicken.process.signal#signal/chld539 chicken.process.signal#signal/cont540 chicken.process.signal#signal/stop541 chicken.process.signal#signal/tstp542 chicken.process.signal#signal/pipe543 chicken.process.signal#signal/xcpu544 chicken.process.signal#signal/xfsz545 chicken.process.signal#signal/usr1546 chicken.process.signal#signal/usr2547 chicken.process.signal#signal/winch548 chicken.process.signal#signal/bus))549550(set! chicken.process.signal#set-signal-mask!551 (lambda (sigs)552 (##sys#check-list sigs 'set-signal-mask!)553 (##core#inline "C_sigemptyset" 0)554 (for-each555 (lambda (s)556 (##sys#check-fixnum s 'set-signal-mask!)557 (##core#inline "C_sigaddset" s) )558 sigs)559 (when (fx< (##core#inline "C_sigprocmask_set" 0) 0)560 (posix-error #:process-error 'set-signal-mask! "cannot set signal mask") )))561562(define chicken.process.signal#signal-mask563 (getter-with-setter564 (lambda ()565 (##core#inline "C_sigprocmask_get" 0)566 (let loop ((sigs chicken.process.signal#signals-list) (mask '()))567 (if (null? sigs)568 mask569 (let ([sig (car sigs)])570 (loop (cdr sigs)571 (if (##core#inline "C_sigismember" sig) (cons sig mask) mask)) ) ) ) )572 chicken.process.signal#set-signal-mask!573 "(chicken.process.signal#signal-mask)"))574575(set! chicken.process.signal#signal-masked?576 (lambda (sig)577 (##sys#check-fixnum sig 'signal-masked?)578 (##core#inline "C_sigprocmask_get" 0)579 (##core#inline "C_sigismember" sig)) )580581(set! chicken.process.signal#signal-mask!582 (lambda (sig)583 (##sys#check-fixnum sig 'signal-mask!)584 (##core#inline "C_sigemptyset" 0)585 (##core#inline "C_sigaddset" sig)586 (when (fx< (##core#inline "C_sigprocmask_block" 0) 0)587 (posix-error #:process-error 'signal-mask! "cannot block signal") )))588589(set! chicken.process.signal#signal-unmask!590 (lambda (sig)591 (##sys#check-fixnum sig 'signal-unmask!)592 (##core#inline "C_sigemptyset" 0)593 (##core#inline "C_sigaddset" sig)594 (when (fx< (##core#inline "C_sigprocmask_unblock" 0) 0)595 (posix-error #:process-error 'signal-unmask! "cannot unblock signal") )) )596597598;;; Getting group- and user-information:599600(set! chicken.process-context.posix#current-user-id601 (getter-with-setter602 (foreign-lambda int "C_getuid")603 (lambda (id)604 (##sys#check-fixnum id 'current-user-id)605 (when (fx< (##core#inline "C_setuid" id) 0)606 (##sys#error/errno (##sys#update-errno)607 'current-user-id!-setter "cannot set user ID" id)))608 "(chicken.process-context.posix#current-user-id)"))609610(set! chicken.process-context.posix#current-effective-user-id611 (getter-with-setter612 (foreign-lambda int "C_geteuid")613 (lambda (id)614 (##sys#check-fixnum id 'current-effective-user-id)615 (when (fx< (##core#inline "C_seteuid" id) 0)616 (##sys#error/errno (##sys#update-errno)617 'effective-user-id!-setter618 "cannot set effective user ID" id)))619 "(chicken.process-context.posix#current-effective-user-id)"))620621(set! chicken.process-context.posix#current-group-id622 (getter-with-setter623 (foreign-lambda int "C_getgid")624 (lambda (id)625 (##sys#check-fixnum id 'current-group-id)626 (when (fx< (##core#inline "C_setgid" id) 0)627 (##sys#error/errno (##sys#update-errno)628 'current-group-id!-setter "cannot set group ID" id)))629 "(chicken.process-context.posix#current-group-id)") )630631(set! chicken.process-context.posix#current-effective-group-id632 (getter-with-setter633 (foreign-lambda int "C_getegid")634 (lambda (id)635 (##sys#check-fixnum id 'current-effective-group-id)636 (when (fx< (##core#inline "C_setegid" id) 0)637 (##sys#error/errno (##sys#update-errno)638 'effective-group-id!-setter639 "cannot set effective group ID" id)))640 "(chicken.process-context.posix#current-effective-group-id)") )641642(define-foreign-variable _user-name nonnull-c-string "C_user->pw_name")643(define-foreign-variable _user-passwd nonnull-c-string "C_user->pw_passwd")644(define-foreign-variable _user-uid int "C_user->pw_uid")645(define-foreign-variable _user-gid int "C_user->pw_gid")646(define-foreign-variable _user-gecos nonnull-c-string "C_PW_GECOS")647(define-foreign-variable _user-dir c-string "C_user->pw_dir")648(define-foreign-variable _user-shell c-string "C_user->pw_shell")649650(set! chicken.process-context.posix#user-information651 (lambda (user #!optional as-vector)652 (let ([r (if (fixnum? user)653 (##core#inline "C_getpwuid" user)654 (begin655 (##sys#check-string user 'user-information)656 (##core#inline "C_getpwnam" (##sys#make-c-string user 'user-information)) ) ) ] )657 (and r658 ((if as-vector vector list)659 _user-name660 _user-passwd661 _user-uid662 _user-gid663 _user-gecos664 _user-dir665 _user-shell) ) )) )666667(set! chicken.process-context.posix#current-user-name668 (lambda ()669 (car (chicken.process-context.posix#user-information670 (chicken.process-context.posix#current-user-id)))) )671672(set! chicken.process-context.posix#current-effective-user-name673 (lambda ()674 (car (chicken.process-context.posix#user-information675 (chicken.process-context.posix#current-effective-user-id)))) )676677(define chown678 (lambda (loc f uid gid)679 (##sys#check-fixnum uid loc)680 (##sys#check-fixnum gid loc)681 (let ((r (cond682 ((port? f)683 (##core#inline "C_fchown" (chicken.file.posix#port->fileno f) uid gid))684 ((fixnum? f)685 (##core#inline "C_fchown" f uid gid))686 ((string? f)687 (##core#inline "C_chown"688 (##sys#make-c-string f loc) uid gid))689 (else (##sys#signal-hook690 #:type-error loc691 "bad argument type - not a fixnum, port or string" f)))))692 (when (fx< r 0)693 (posix-error #:file-error loc "cannot change file owner" f uid gid) )) ) )694695(set! chicken.process-context.posix#create-session696 (lambda ()697 (let ([a (##core#inline "C_setsid" #f)])698 (when (fx< a 0)699 (##sys#error/errno (##sys#update-errno)700 'create-session "cannot create session"))701 a)) )702703(set! chicken.process-context.posix#process-group-id704 (getter-with-setter705 (lambda (pid)706 (##sys#check-fixnum pid 'process-group-id)707 (let ([a (##core#inline "C_getpgid" pid)])708 (when (fx< a 0)709 (##sys#error/errno (##sys#update-errno)710 'process-group-id711 "cannot retrieve process group ID" pid))712 a))713 (lambda (pid pgid)714 (##sys#check-fixnum pid 'process-group)715 (##sys#check-fixnum pgid 'process-group)716 (when (fx< (##core#inline "C_setpgid" pid pgid) 0)717 (##sys#error/errno (##sys#update-errno)718 'process-group "cannot set process group ID" pid pgid)))719 "(chicken.process-context.posix#process-group-id pid)"))720721722;;; Hard and symbolic links:723724(set! chicken.file.posix#create-symbolic-link725 (lambda (old new)726 (##sys#check-string old 'create-symbolic-link)727 (##sys#check-string new 'create-symbolic-link)728 (when (fx< (##core#inline729 "C_symlink"730 (##sys#make-c-string old 'create-symbolic-link)731 (##sys#make-c-string new 'create-symbolic-link) )732 0)733 (posix-error #:file-error 'create-symbolic-link "cannot create symbolic link" old new) ) ) )734735(define-foreign-variable _filename_max int "FILENAME_MAX")736737(define ##sys#read-symbolic-link738 (let ((buf (make-string (fx+ _filename_max 1))))739 (lambda (fname location)740 (let ((len (##core#inline741 "C_do_readlink"742 (##sys#make-c-string fname location) buf)))743 (if (fx< len 0)744 (posix-error #:file-error location "cannot read symbolic link" fname)745 (substring buf 0 len))))))746747(set! chicken.file.posix#read-symbolic-link748 (lambda (fname #!optional canonicalize)749 (##sys#check-string fname 'read-symbolic-link)750 (if canonicalize751 (receive (base-origin base-directory directory-components) (decompose-directory fname)752 (let loop ((components directory-components)753 (result (string-append (or base-origin "") (or base-directory ""))))754 (if (null? components)755 result756 (let ((pathname (make-pathname result (car components))))757 (if (##sys#file-exists? pathname #f #f 'read-symbolic-link)758 (loop (cdr components)759 (if (chicken.file.posix#symbolic-link? pathname)760 (let ((target (##sys#read-symbolic-link pathname 'read-symbolic-link)))761 (if (absolute-pathname? target)762 target763 (make-pathname result target)))764 pathname))765 (##sys#signal-hook #:file-error 'read-symbolic-link "could not canonicalize path with symbolic links, component does not exist" pathname))))))766 (##sys#read-symbolic-link fname 'read-symbolic-link))))767768(set! chicken.file.posix#file-link769 (let ((link (foreign-lambda int "link" nonnull-c-string nonnull-c-string)))770 (lambda (old new)771 (##sys#check-string old 'file-link)772 (##sys#check-string new 'file-link)773 (when (fx< (link old new) 0)774 (posix-error #:file-error 'hard-link "could not create hard link" old new) ) ) ) )775776777(define ##sys#custom-input-port778 (lambda (loc nam fd #!optional (nonblocking? #f) (bufi 1) (on-close void) (more? #f))779 (when nonblocking? (##sys#file-nonblocking! fd) )780 (let ([bufsiz (if (fixnum? bufi) bufi (##sys#size bufi))]781 [buf (if (fixnum? bufi) (##sys#make-string bufi) bufi)]782 [buflen 0]783 [bufpos 0] )784 (let ([ready?785 (lambda ()786 (let ((res (##sys#file-select-one fd)))787 (if (fx= -1 res)788 (if (or (fx= _errno _ewouldblock)789 (fx= _errno _eagain))790 #f791 (posix-error #:file-error loc "cannot select" fd nam))792 (fx= 1 res))))]793 [peek794 (lambda ()795 (if (fx>= bufpos buflen)796 #!eof797 (##core#inline "C_subchar" buf bufpos)) )]798 [fetch799 (lambda ()800 (let loop ()801 (let ([cnt (##core#inline "C_read" fd buf bufsiz)])802 (cond ((fx= cnt -1)803 (cond804 ((or (fx= _errno _ewouldblock)805 (fx= _errno _eagain))806 (##sys#thread-block-for-i/o! ##sys#current-thread fd #:input)807 (##sys#thread-yield!)808 (loop) )809 ((fx= _errno _eintr)810 (##sys#dispatch-interrupt loop))811 (else (posix-error #:file-error loc "cannot read" fd nam) )))812 [(and more? (fx= cnt 0))813 ;; When "more" keep trying, otherwise read once more814 ;; to guard against race conditions815 (if (more?)816 (begin817 (##sys#thread-yield!)818 (loop) )819 (let ([cnt (##core#inline "C_read" fd buf bufsiz)])820 (when (fx= cnt -1)821 (if (or (fx= _errno _ewouldblock)822 (fx= _errno _eagain))823 (set! cnt 0)824 (posix-error #:file-error loc "cannot read" fd nam) ) )825 (set! buflen cnt)826 (set! bufpos 0) ) )]827 [else828 (set! buflen cnt)829 (set! bufpos 0)]) ) ) )] )830 (letrec ([this-port831 (make-input-port832 (lambda () ; read-char833 (when (fx>= bufpos buflen)834 (fetch))835 (let ([ch (peek)])836 (unless (eof-object? ch) (set! bufpos (fx+ bufpos 1)))837 ch ) )838 (lambda () ; char-ready?839 (or (fx< bufpos buflen)840 (ready?)) )841 (lambda () ; close842 (when (fx< (##core#inline "C_close" fd) 0)843 (posix-error #:file-error loc "cannot close" fd nam))844 (on-close))845 (lambda () ; peek-char846 (when (fx>= bufpos buflen)847 (fetch))848 (peek) )849 (lambda (port n dest start) ; read-string!850 (let loop ([n (or n (fx- (##sys#size dest) start))] [m 0] [start start])851 (cond [(eq? 0 n) m]852 [(fx< bufpos buflen)853 (let* ([rest (fx- buflen bufpos)]854 [n2 (if (fx< n rest) n rest)])855 (##core#inline "C_substring_copy" buf dest bufpos (fx+ bufpos n2) start)856 (set! bufpos (fx+ bufpos n2))857 (loop (fx- n n2) (fx+ m n2) (fx+ start n2)) ) ]858 [else859 (fetch)860 (if (eq? 0 buflen)861 m862 (loop n m start) ) ] ) ) )863 (lambda (p limit) ; read-line864 (when (fx>= bufpos buflen)865 (fetch))866 (if (fx>= bufpos buflen)867 #!eof868 (let ((limit (or limit (fx- most-positive-fixnum bufpos))))869 (receive (next line full-line?)870 (##sys#scan-buffer-line871 buf872 (fxmin buflen (fx+ bufpos limit))873 bufpos874 (lambda (pos)875 (let ((nbytes (fx- pos bufpos)))876 (cond ((fx>= nbytes limit)877 (values #f pos #f))878 (else879 (set! limit (fx- limit nbytes))880 (fetch)881 (if (fx< bufpos buflen)882 (values buf bufpos883 (fxmin buflen884 (fx+ bufpos limit)))885 (values #f bufpos #f)))))))886 ;; Update row & column position887 (if full-line?888 (begin889 (##sys#setislot p 4 (fx+ (##sys#slot p 4) 1))890 (##sys#setislot p 5 0))891 (##sys#setislot p 5 (fx+ (##sys#slot p 5)892 (##sys#size line))))893 (set! bufpos next)894 line)) ) )895 (lambda (port) ; read-buffered896 (if (fx>= bufpos buflen)897 ""898 (let ((str (##sys#substring buf bufpos buflen)))899 (set! bufpos buflen)900 str)))901 ) ] )902 (##sys#setslot this-port 3 nam)903 this-port ) ) ) ) )904905(define ##sys#custom-output-port906 (lambda (loc nam fd #!optional (nonblocking? #f) (bufi 0) (on-close void))907 (when nonblocking? (##sys#file-nonblocking! fd) )908 (letrec ([poke909 (lambda (str len)910 (let loop ()911 (let ((cnt (##core#inline "C_write" fd str len)))912 (cond ((fx= -1 cnt)913 (cond914 ((or (fx= _errno _ewouldblock)915 (fx= _errno _eagain))916 (##sys#thread-yield!)917 (poke str len) )918 ((fx= _errno _eintr)919 (##sys#dispatch-interrupt loop))920 (else921 (posix-error loc #:file-error "cannot write" fd nam) ) ) )922 ((fx< cnt len)923 (poke (##sys#substring str cnt len) (fx- len cnt)) ) ) ) ))]924 [store925 (let ([bufsiz (if (fixnum? bufi) bufi (##sys#size bufi))])926 (if (fx= 0 bufsiz)927 (lambda (str)928 (when str929 (poke str (##sys#size str)) ) )930 (let ([buf (if (fixnum? bufi) (##sys#make-string bufi) bufi)]931 [bufpos 0])932 (lambda (str)933 (if str934 (let loop ([rem (fx- bufsiz bufpos)] [start 0] [len (##sys#size str)])935 (cond [(fx= 0 rem)936 (poke buf bufsiz)937 (set! bufpos 0)938 (loop bufsiz 0 len)]939 [(fx< rem len)940 (##core#inline "C_substring_copy" str buf start rem bufpos)941 (loop 0 rem (fx- len rem))]942 [else943 (##core#inline "C_substring_copy" str buf start len bufpos)944 (set! bufpos (fx+ bufpos len))] ) )945 (when (fx< 0 bufpos)946 (poke buf bufpos) ) ) ) ) ) )])947 (letrec ([this-port948 (make-output-port949 (lambda (str) ; write-string950 (store str) )951 (lambda () ; close952 (when (fx< (##core#inline "C_close" fd) 0)953 (posix-error #:file-error loc "cannot close" fd nam))954 (on-close))955 (lambda () ; flush956 (store #f) ) )] )957 (##sys#setslot this-port 3 nam)958 this-port ) ) ) )959960961;;; Other file operations:962963(set! chicken.file.posix#file-truncate964 (lambda (fname off)965 (##sys#check-exact-integer off 'file-truncate)966 (when (fx< (cond ((string? fname) (##core#inline "C_truncate" (##sys#make-c-string fname 'file-truncate) off))967 ((port? fname) (##core#inline "C_ftruncate" (chicken.file.posix#port->fileno fname) off))968 ((fixnum? fname) (##core#inline "C_ftruncate" fname off))969 (else (##sys#error 'file-truncate "invalid file" fname)))970 0)971 (posix-error #:file-error 'file-truncate "cannot truncate file" fname off) ) ) )972973974;;; Record locking:975976(define-foreign-variable _f_wrlck int "F_WRLCK")977(define-foreign-variable _f_rdlck int "F_RDLCK")978(define-foreign-variable _f_unlck int "F_UNLCK")979980(let ()981 (define (setup port args loc)982 (let-optionals* args ([start 0]983 [len #t] )984 (##sys#check-open-port port loc)985 (##sys#check-exact-integer start loc)986 (if (eq? #t len)987 (set! len 0)988 (##sys#check-exact-integer len loc) )989 (##core#inline "C_flock_setup" (if (= (##sys#slot port 1) 1) _f_rdlck _f_wrlck) start len)990 (##sys#make-structure 'lock port start len) ) )991 (define (err msg lock loc)992 (posix-error #:file-error loc msg (##sys#slot lock 1) (##sys#slot lock 2) (##sys#slot lock 3)) )993 (set! chicken.file.posix#file-lock994 (lambda (port . args)995 (let loop ()996 (let ((lock (setup port args 'file-lock)))997 (if (fx< (##core#inline "C_flock_lock" port) 0)998 (cond999 ((fx= _errno _eintr) (##sys#dispatch-interrupt loop))1000 (else (err "cannot lock file" lock 'file-lock)))1001 lock)))))1002 (set! chicken.file.posix#file-lock/blocking1003 (lambda (port . args)1004 (let loop ()1005 (let ((lock (setup port args 'file-lock/blocking)))1006 (if (fx< (##core#inline "C_flock_lockw" port) 0)1007 (cond1008 ((fx= _errno _eintr) (##sys#dispatch-interrupt loop))1009 (else (err "cannot lock file" lock 'file-lock/blocking)))1010 lock)))))1011 (set! chicken.file.posix#file-test-lock1012 (lambda (port . args)1013 (let ([lock (setup port args 'file-test-lock)])1014 (cond [(##core#inline "C_flock_test" port) => (lambda (c) (and (not (fx= c 0)) c))]1015 [else (err "cannot unlock file" lock 'file-test-lock)] ) ) ) ) )10161017(set! chicken.file.posix#file-unlock1018 (lambda (lock)1019 (##sys#check-structure lock 'lock 'file-unlock)1020 (##core#inline "C_flock_setup" _f_unlck (##sys#slot lock 2) (##sys#slot lock 3))1021 (when (fx< (##core#inline "C_flock_lock" (##sys#slot lock 1)) 0)1022 (cond1023 ((fx= _errno _eintr)1024 (##sys#dispatch-interrupt1025 (lambda () (chicken.file.posix#file-unlock lock))))1026 (else (posix-error #:file-error 'file-unlock "cannot unlock file" lock))))))102710281029;;; FIFOs:10301031(set! chicken.file.posix#create-fifo1032 (lambda (fname . mode)1033 (##sys#check-string fname 'create-fifo)1034 (let ([mode (if (pair? mode) (car mode) (fxior _s_irwxu (fxior _s_irwxg _s_irwxo)))])1035 (##sys#check-fixnum mode 'create-fifo)1036 (when (fx< (##core#inline "C_mkfifo" (##sys#make-c-string fname 'create-fifo) mode) 0)1037 (posix-error #:file-error 'create-fifo "cannot create FIFO" fname mode) ) ) ) )103810391040;;; Time related things:10411042(set! chicken.time.posix#string->time1043 (let ((strptime (foreign-lambda scheme-object "C_strptime" scheme-object scheme-object scheme-object scheme-pointer))1044 (tm-size (foreign-value "sizeof(struct tm)" int)))1045 (lambda (tim #!optional (fmt "%a %b %e %H:%M:%S %Z %Y"))1046 (##sys#check-string tim 'string->time)1047 (##sys#check-string fmt 'string->time)1048 (strptime (##sys#make-c-string tim 'string->time) (##sys#make-c-string fmt) (make-vector 10 #f) (##sys#make-string tm-size #\nul)) ) ) )10491050(set! chicken.time.posix#utc-time->seconds1051 (let ((tm-size (foreign-value "sizeof(struct tm)" int)))1052 (lambda (tm)1053 (check-time-vector 'utc-time->seconds tm)1054 (let ((t (##core#inline_allocate ("C_a_timegm" 7) tm (##sys#make-string tm-size #\nul))))1055 (if (= -1 t)1056 (##sys#error 'utc-time->seconds "cannot convert time vector to seconds" tm)1057 t)))))10581059(set! chicken.time.posix#local-timezone-abbreviation1060 (foreign-lambda* c-string ()1061 "\n#if !defined(__CYGWIN__) && !defined(__SVR4) && !defined(__uClinux__) && !defined(__hpux__) && !defined(_AIX)\n"1062 "time_t clock = time(NULL);"1063 "struct tm *ltm = C_localtime(&clock);"1064 "char *z = ltm ? (char *)ltm->tm_zone : 0;"1065 "\n#else\n"1066 "char *z = (daylight ? tzname[1] : tzname[0]);"1067 "\n#endif\n"1068 "C_return(z);") )106910701071;;; Other things:10721073(set! chicken.process.signal#set-alarm!1074 (foreign-lambda int "C_alarm" int))107510761077;;; Process handling:10781079(set! chicken.process#process-fork1080 (let ((fork (foreign-lambda int "C_fork")))1081 (lambda (#!optional thunk killothers)1082 ;; flush all stdio streams before fork1083 ((foreign-lambda int "C_fflush" c-pointer) #f)1084 (let ((pid (fork)))1085 (when (fx= -1 pid)1086 (posix-error #:process-error 'process-fork "cannot create child process"))1087 (if (and thunk (zero? pid))1088 ((if killothers1089 ##sys#kill-other-threads1090 (lambda (thunk) (thunk)))1091 (lambda ()1092 (##sys#call-with-cthulhu1093 (lambda ()1094 (thunk)1095 (exit 0)))))1096 pid)))))10971098(set! chicken.process#process-execute1099 (lambda (filename #!optional (arglist '()) envlist exactf)1100 (call-with-exec-args1101 'process-execute filename (lambda (x) x) arglist envlist1102 (lambda (prg argbuf envbuf)1103 (let ((r (if envbuf1104 (##core#inline "C_u_i_execve" prg argbuf envbuf)1105 (##core#inline "C_u_i_execvp" prg argbuf))))1106 (when (fx= r -1)1107 (posix-error #:process-error 'process-execute "cannot execute process" filename)))))))11081109(define-foreign-variable _wnohang int "WNOHANG")1110(define-foreign-variable _wait-status int "C_wait_status")11111112(define (process-wait-impl pid nohang)1113 (let* ((res (##core#inline "C_waitpid" pid (if nohang _wnohang 0)))1114 (norm (##core#inline "C_WIFEXITED" _wait-status)) )1115 (if (and (fx= res -1) (fx= _errno _eintr))1116 (##sys#dispatch-interrupt1117 (lambda () (process-wait-impl pid nohang)))1118 (values1119 res1120 norm1121 (cond (norm (##core#inline "C_WEXITSTATUS" _wait-status))1122 ((##core#inline "C_WIFSIGNALED" _wait-status)1123 (##core#inline "C_WTERMSIG" _wait-status))1124 (else (##core#inline "C_WSTOPSIG" _wait-status)) ) )) ) )11251126(set! chicken.process-context.posix#parent-process-id (foreign-lambda int "C_getppid"))11271128(set! chicken.process#process-signal1129 (lambda (id . sig)1130 (let ((sig (if (pair? sig) (car sig) _sigterm)))1131 (##sys#check-fixnum id 'process-signal)1132 (##sys#check-fixnum sig 'process-signal)1133 (let ((r (##core#inline "C_kill" id sig)))1134 (when (fx= r -1) (posix-error #:process-error 'process-signal "could not send signal to process" id sig) ) ) ) ) )11351136(define (shell-command loc)1137 (or (get-environment-variable "SHELL") "/bin/sh") )11381139(define (shell-command-arguments cmdlin)1140 (list "-c" cmdlin) )11411142(set! chicken.process#process-run1143 (lambda (f . args)1144 (let ((args (if (pair? args) (car args) #f))1145 (pid (chicken.process#process-fork)) )1146 (cond ((not (eq? 0 pid)) pid)1147 (args (chicken.process#process-execute f args))1148 (else1149 (chicken.process#process-execute1150 (shell-command 'process-run)1151 (shell-command-arguments f)) ) ) ) ) )11521153;;; Run subprocess connected with pipes:11541155;; process-impl1156; loc caller procedure symbol1157; cmd pathname or commandline1158; args string-list or '()1159; env string-list or #f1160; stdoutf #f then share, or #t then create1161; stdinf #f then share, or #t then create1162; stderrf #f then share, or #t then create1163;1164; (values stdin-input-port? stdout-output-port? pid stderr-input-port?)1165; where stdin-input-port?, etc. is a port or #f, indicating no port created.11661167(define-constant DEFAULT-INPUT-BUFFER-SIZE 256)1168(define-constant DEFAULT-OUTPUT-BUFFER-SIZE 0)11691170;FIXME process-execute, process-fork don't show parent caller11711172(define process-impl1173 (let ((replace-fd1174 (lambda (loc fd stdfd)1175 (unless (fx= stdfd fd)1176 (chicken.file.posix#duplicate-fileno fd stdfd)1177 (chicken.file.posix#file-close fd) ) )) )1178 (let ((make-on-close1179 (lambda (loc pid clsvec idx idxa idxb)1180 (lambda ()1181 (vector-set! clsvec idx #t)1182 (when (and (vector-ref clsvec idxa) (vector-ref clsvec idxb))1183 (receive (_ flg cod) (process-wait-impl pid #f)1184 (unless flg1185 (##sys#signal-hook #:process-error loc1186 "abnormal process exit" pid cod)) ) ) ) ))1187 (needed-pipe1188 (lambda (loc port)1189 (and port1190 (receive (i o) (chicken.process#create-pipe)1191 (cons i o))) ))1192 [connect-parent1193 (lambda (loc pipe port fd)1194 (and port1195 (let ([usefd (car pipe)] [clsfd (cdr pipe)])1196 (chicken.file.posix#file-close clsfd)1197 usefd) ) )]1198 [connect-child1199 (lambda (loc pipe port stdfd)1200 (when port1201 (let ([usefd (car pipe)] [clsfd (cdr pipe)])1202 (chicken.file.posix#file-close clsfd)1203 (replace-fd loc usefd stdfd)) ) )] )1204 (let (1205 (spawn1206 (let ([swapped-ends1207 (lambda (pipe)1208 (and pipe1209 (cons (cdr pipe) (car pipe)) ) )])1210 (lambda (loc cmd args env stdoutf stdinf stderrf)1211 (let ([ipipe (needed-pipe loc stdinf)]1212 [opipe (needed-pipe loc stdoutf)]1213 [epipe (needed-pipe loc stderrf)])1214 (values1215 ipipe (swapped-ends opipe) epipe1216 (chicken.process#process-fork1217 (lambda ()1218 (connect-child loc opipe stdinf chicken.file.posix#fileno/stdin)1219 (connect-child loc (swapped-ends ipipe) stdoutf chicken.file.posix#fileno/stdout)1220 (connect-child loc (swapped-ends epipe) stderrf chicken.file.posix#fileno/stderr)1221 (chicken.process#process-execute cmd args env)))) ) ) ))1222 [input-port1223 (lambda (loc pid cmd pipe stdf stdfd on-close)1224 (and-let* ([fd (connect-parent loc pipe stdf stdfd)])1225 (##sys#custom-input-port loc cmd fd #t DEFAULT-INPUT-BUFFER-SIZE on-close) ) )]1226 [output-port1227 (lambda (loc pid cmd pipe stdf stdfd on-close)1228 (and-let* ([fd (connect-parent loc pipe stdf stdfd)])1229 (##sys#custom-output-port loc cmd fd #t DEFAULT-OUTPUT-BUFFER-SIZE on-close) ) )] )1230 (lambda (loc cmd args env stdoutf stdinf stderrf)1231 (receive [inpipe outpipe errpipe pid]1232 (spawn loc cmd args env stdoutf stdinf stderrf)1233 ;When shared assume already "closed", since only created ports1234 ;should be explicitly closed, and when one is closed we want1235 ;to wait.1236 (let ((clsvec (vector (not stdinf) (not stdoutf) (not stderrf))))1237 (values1238 (input-port loc pid cmd inpipe stdinf1239 chicken.file.posix#fileno/stdin1240 (make-on-close loc pid clsvec 0 1 2))1241 (output-port loc pid cmd outpipe stdoutf1242 chicken.file.posix#fileno/stdout1243 (make-on-close loc pid clsvec 1 0 2))1244 pid1245 (input-port loc pid cmd errpipe stderrf1246 chicken.file.posix#fileno/stderr1247 (make-on-close loc pid clsvec 2 0 1)) ) ) ) ) ) ) ) )12481249;;; Run subprocess connected with pipes:12501251;; TODO: See if this can be moved to posix-common1252(let ((%process1253 (lambda (loc err? cmd args env k)1254 (let ((chkstrlst1255 (lambda (lst)1256 (##sys#check-list lst loc)1257 (for-each (cut ##sys#check-string <> loc) lst) )))1258 (##sys#check-string cmd loc)1259 (if args1260 (chkstrlst args)1261 (begin1262 (set! args (shell-command-arguments cmd))1263 (set! cmd (shell-command loc)) ) )1264 (when env (check-environment-list env loc))1265 (##sys#call-with-values1266 (lambda () (process-impl loc cmd args env #t #t err?))1267 k)))))1268 (set! chicken.process#process1269 (lambda (cmd #!optional args env exactf)1270 (%process1271 'process #f cmd args env1272 (lambda (i o p e) (values i o p)))))1273 (set! chicken.process#process*1274 (lambda (cmd #!optional args env exactf)1275 (%process1276 'process* #t cmd args env1277 values))))127812791280;;; chroot:12811282(set! chicken.process-context.posix#set-root-directory!1283 (let ((chroot (foreign-lambda int "chroot" nonnull-c-string)))1284 (lambda (dir)1285 (##sys#check-string dir 'set-root-directory!)1286 (when (fx< (chroot dir) 0)1287 (posix-error #:file-error 'set-root-directory! "unable to change root directory" dir) ) ) ) )12881289;;; unimplemented stuff:12901291(set!-unimplemented chicken.process#process-spawn)