~ chicken-core (master) /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 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#ifdef __linux__53# include <sys/file.h>54#endif5556#include <sys/mman.h>57#include <poll.h>5859#ifndef O_FSYNC60# define O_FSYNC O_SYNC61#endif6263#ifndef PIPE_BUF64# ifdef __CYGWIN__65# define PIPE_BUF _POSIX_PIPE_BUF66# else67# define PIPE_BUF 102468# endif69#endif7071#ifndef O_BINARY72# define O_BINARY 073#endif74#ifndef O_TEXT75# define O_TEXT 076#endif7778#ifndef MAP_FILE79# define MAP_FILE 080#endif8182#ifndef MAP_ANON83# define MAP_ANON 084#endif8586#ifndef FILENAME_MAX87# define FILENAME_MAX 102488#endif8990static DIR *temphandle;91static struct passwd *C_user;9293/* Android doesn't provide pw_gecos in the passwd struct */94#ifdef __ANDROID__95# define C_PW_GECOS ("")96#else97# define C_PW_GECOS (C_user->pw_gecos)98#endif99100static int C_pipefds[ 2 ];101static time_t C_secs;102static struct timeval C_timeval;103static struct stat C_statbuf;104105#define C_fchdir(fd) C_fix(fchdir(C_unfix(fd)))106107#define open_binary_input_pipe(a, n, name) C_mpointer(a, popen(C_c_string(name), "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, popen(C_c_string(name), "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_fork fork114#define C_waitpid(id, o) C_fix(waitpid(C_unfix(id), &C_wait_status, C_unfix(o)))115#define C_getppid getppid116#define C_kill(id, s) C_fix(kill(C_unfix(id), C_unfix(s)))117#define C_getuid getuid118#define C_getgid getgid119#define C_geteuid geteuid120#define C_getegid getegid121#define C_chown(fn, u, g) C_fix(chown(C_c_string(fn), C_unfix(u), C_unfix(g)))122#define C_fchown(fd, u, g) C_fix(fchown(C_unfix(fd), C_unfix(u), C_unfix(g)))123#define C_chmod(fn, m) C_fix(chmod(C_c_string(fn), C_unfix(m)))124#define C_fchmod(fd, m) C_fix(fchmod(C_unfix(fd), C_unfix(m)))125#define C_setuid(id) C_fix(setuid(C_unfix(id)))126#define C_setgid(id) C_fix(setgid(C_unfix(id)))127#define C_seteuid(id) C_fix(seteuid(C_unfix(id)))128#define C_setegid(id) C_fix(setegid(C_unfix(id)))129#define C_setsid(dummy) C_fix(setsid())130#define C_setpgid(x, y) C_fix(setpgid(C_unfix(x), C_unfix(y)))131#define C_getpgid(x) C_fix(getpgid(C_unfix(x)))132#define C_symlink(o, n) C_fix(symlink(C_c_string(o), C_c_string(n)))133#define C_do_readlink(f, b) C_fix(readlink(C_c_string(f), C_c_string(b), FILENAME_MAX))134#define C_getpwnam(n) C_mk_bool((C_user = getpwnam(C_c_string(n))) != NULL)135#define C_getpwuid(u) C_mk_bool((C_user = getpwuid(C_unfix(u))) != NULL)136#define C_pipe(d) C_fix(pipe(C_pipefds))137#define C_truncate(f, n) C_fix(truncate(C_c_string(f), C_num_to_int(n)))138#define C_ftruncate(f, n) C_fix(ftruncate(C_unfix(f), C_num_to_int(n)))139#define C_alarm alarm140#define C_close(fd) C_fix(close(C_unfix(fd)))141#define C_umask(m) C_fix(umask(C_unfix(m)))142143#define C_u_i_lstat(fn) C_fix(lstat(C_c_string(fn), &C_statbuf))144145#define C_u_i_execvp(f,a) C_fix(execvp(C_c_string(f), (char *const *)C_c_pointer_vector_or_null(a)))146#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)))147148static int C_uw;149#define C_WIFEXITED(n) (C_uw = C_unfix(n), C_mk_bool(WIFEXITED(C_uw)))150#define C_WIFSIGNALED(n) (C_uw = C_unfix(n), C_mk_bool(WIFSIGNALED(C_uw)))151#define C_WIFSTOPPED(n) (C_uw = C_unfix(n), C_mk_bool(WIFSTOPPED(C_uw)))152#define C_WEXITSTATUS(n) (C_uw = C_unfix(n), C_fix(WEXITSTATUS(C_uw)))153#define C_WTERMSIG(n) (C_uw = C_unfix(n), C_fix(WTERMSIG(C_uw)))154#define C_WSTOPSIG(n) (C_uw = C_unfix(n), C_fix(WSTOPSIG(C_uw)))155156#ifdef __CYGWIN__157# define C_mkfifo(fn, m) C_fix(-1)158#else159# define C_mkfifo(fn, m) C_fix(mkfifo(C_c_string(fn), C_unfix(m)))160#endif161162static C_word C_flock(C_word n, C_word f)163{164#ifdef __HAIKU__165# define LOCK_SH 0166# define LOCK_EX 0167# define LOCK_NB 0168# define LOCK_UN 0169 return C_fix(-1);170#else171 return C_fix(flock(C_unfix(n), C_unfix(f)));172#endif173}174175static sigset_t C_sigset;176#define C_sigemptyset(d) (sigemptyset(&C_sigset), C_SCHEME_UNDEFINED)177#define C_sigaddset(s) (sigaddset(&C_sigset, C_unfix(s)), C_SCHEME_UNDEFINED)178#define C_sigdelset(s) (sigdelset(&C_sigset, C_unfix(s)), C_SCHEME_UNDEFINED)179#define C_sigismember(s) C_mk_bool(sigismember(&C_sigset, C_unfix(s)))180#define C_sigprocmask_set(d) C_fix(sigprocmask(SIG_SETMASK, &C_sigset, NULL))181#define C_sigprocmask_block(d) C_fix(sigprocmask(SIG_BLOCK, &C_sigset, NULL))182#define C_sigprocmask_unblock(d) C_fix(sigprocmask(SIG_UNBLOCK, &C_sigset, NULL))183#define C_sigprocmask_get(d) C_fix(sigprocmask(SIG_SETMASK, NULL, &C_sigset))184185#define C_open(fn, fl, m) C_fix(open(C_c_string(fn), C_unfix(fl), C_unfix(m)))186#define C_read(fd, b, n) C_fix(read(C_unfix(fd), C_c_string(b), C_unfix(n)))187#define C_write(fd, b, start, n) C_fix(write(C_unfix(fd), C_c_string(b) + C_unfix(start), C_unfix(n)))188#define C_mkstemp(t) C_fix(mkstemp(C_c_string(t)))189190#define C_ctime(n) (C_secs = (n), ctime(&C_secs))191192#if defined(__SVR4) || defined(C_MACOSX) || defined(__ANDROID__) || defined(_AIX)193/* Seen here: http://lists.samba.org/archive/samba-technical/2002-November/025571.html */194195static time_t C_timegm(struct tm *t)196{197 time_t tl, tb;198 struct tm *tg;199200 tl = mktime (t);201 if (tl == -1)202 {203 t->tm_hour--;204 tl = mktime (t);205 if (tl == -1)206 return -1; /* can't deal with output from strptime */207 tl += 3600;208 }209 tg = gmtime (&tl);210 tg->tm_isdst = 0;211 tb = mktime (tg);212 if (tb == -1)213 {214 tg->tm_hour--;215 tb = mktime (tg);216 if (tb == -1)217 return -1; /* can't deal with output from gmtime */218 tb += 3600;219 }220 return (tl - (tb - tl));221}222#else223#define C_timegm timegm224#endif225226#define C_a_timegm(ptr, c, v, tm) C_int64_to_num(ptr, C_timegm(C_tm_set((v), C_data_pointer(tm))))227228#ifdef __linux__229extern char *strptime(const char *s, const char *format, struct tm *tm);230extern pid_t getpgid(pid_t pid);231#endif232233/* tm_get could be in posix-common, but it's only used in here */234#define cpy_tmstc08_to_tmvec(v, ptm) \235 (C_set_block_item((v), 0, C_fix(((struct tm *)ptm)->tm_sec)), \236 C_set_block_item((v), 1, C_fix((ptm)->tm_min)), \237 C_set_block_item((v), 2, C_fix((ptm)->tm_hour)), \238 C_set_block_item((v), 3, C_fix((ptm)->tm_mday)), \239 C_set_block_item((v), 4, C_fix((ptm)->tm_mon)), \240 C_set_block_item((v), 5, C_fix((ptm)->tm_year)), \241 C_set_block_item((v), 6, C_fix((ptm)->tm_wday)), \242 C_set_block_item((v), 7, C_fix((ptm)->tm_yday)), \243 C_set_block_item((v), 8, ((ptm)->tm_isdst ? C_SCHEME_TRUE : C_SCHEME_FALSE)))244245#define cpy_tmstc9_to_tmvec(v, ptm) \246 (C_set_block_item((v), 9, C_fix(-(ptm)->tm_gmtoff)))247248#define C_tm_get_08(v, tm) cpy_tmstc08_to_tmvec( (v), (tm) )249#define C_tm_get_9(v, tm) cpy_tmstc9_to_tmvec( (v), (tm) )250251static C_word252C_tm_get( C_word v, void *tm )253{254 C_tm_get_08( v, (struct tm *)tm );255#if defined(C_GNU_ENV) && !defined(__CYGWIN__) && !defined(__uClinux__)256 C_tm_get_9( v, (struct tm *)tm );257#endif258 return v;259}260261#define C_strptime(s, f, v, stm) \262 (strptime(C_c_string(s), C_c_string(f), ((struct tm *)(stm))) ? C_tm_get((v), (stm)) : C_SCHEME_FALSE)263264static int set_file_mtime(C_word filename, C_word atime, C_word mtime)265{266 struct stat sb;267 struct utimbuf tb;268 C_word bv = C_block_item(filename, 0);269270 /* Only lstat if needed */271 if (atime == C_SCHEME_FALSE || mtime == C_SCHEME_FALSE) {272 if (lstat(C_c_string(bv), &sb) == -1) return -1;273 }274275 if (atime == C_SCHEME_FALSE) {276 tb.actime = sb.st_atime;277 } else {278 tb.actime = C_num_to_int64(atime);279 }280 if (mtime == C_SCHEME_FALSE) {281 tb.modtime = sb.st_mtime;282 } else {283 tb.modtime = C_num_to_int64(mtime);284 }285 return utime(C_c_string(bv), &tb);286}287288<#289290;; Faster versions of common operations291292(define ##sys#file-nonblocking!293 (foreign-lambda* bool ([int fd])294 "int val = fcntl(fd, F_GETFL, 0);"295 "if(val == -1) C_return(0);"296 "C_return(fcntl(fd, F_SETFL, val | O_NONBLOCK) != -1);" ) )297298(define ##sys#file-select-one (foreign-lambda int "C_check_fd_ready" int) )299300;;; Lo-level I/O:301302(define-foreign-variable _f_dupfd int "F_DUPFD")303(define-foreign-variable _f_getfd int "F_GETFD")304(define-foreign-variable _f_setfd int "F_SETFD")305(define-foreign-variable _f_getfl int "F_GETFL")306(define-foreign-variable _f_setfl int "F_SETFL")307308(set! chicken.file.posix#fcntl/dupfd _f_dupfd)309(set! chicken.file.posix#fcntl/getfd _f_getfd)310(set! chicken.file.posix#fcntl/setfd _f_setfd)311(set! chicken.file.posix#fcntl/getfl _f_getfl)312(set! chicken.file.posix#fcntl/setfl _f_setfl)313314(define-foreign-variable _o_nonblock int "O_NONBLOCK")315(define-foreign-variable _o_noctty int "O_NOCTTY")316(define-foreign-variable _o_fsync int "O_FSYNC")317(define-foreign-variable _o_sync int "O_SYNC")318(set! chicken.file.posix#open/nonblock _o_nonblock)319(set! chicken.file.posix#open/noctty _o_noctty)320(set! chicken.file.posix#open/fsync _o_fsync)321(set! chicken.file.posix#open/sync _o_sync)322323;; Windows-only definitions324(set! chicken.file.posix#open/noinherit 0)325326(set! chicken.process#spawn/overlay 0)327(set! chicken.process#spawn/wait 0)328(set! chicken.process#spawn/nowait 0)329(set! chicken.process#spawn/nowaito 0)330(set! chicken.process#spawn/detach 0)331332(define-foreign-variable _s_isuid int "S_ISUID")333(define-foreign-variable _s_isgid int "S_ISGID")334(define-foreign-variable _s_isvtx int "S_ISVTX")335(set! chicken.file.posix#perm/isvtx _s_isvtx)336(set! chicken.file.posix#perm/isuid _s_isuid)337(set! chicken.file.posix#perm/isgid _s_isgid)338339(set! chicken.file.posix#file-control340 (let ([fcntl (foreign-lambda int fcntl int int long)])341 (lambda (fd cmd #!optional (arg 0))342 (##sys#check-fixnum fd 'file-control)343 (##sys#check-fixnum cmd 'file-control)344 (let ([res (fcntl fd cmd arg)])345 (if (fx= res -1)346 (posix-error #:file-error 'file-control "cannot control file" fd cmd)347 res ) ) ) ) )348349(set! chicken.file.posix#file-open350 (let ((defmode (bitwise-ior _s_irusr _s_iwusr _s_irgrp _s_iwgrp _s_iroth _s_iwoth)))351 (lambda (filename flags . mode)352 (let ([mode (if (pair? mode) (car mode) defmode)])353 (##sys#check-string filename 'file-open)354 (##sys#check-fixnum flags 'file-open)355 (##sys#check-fixnum mode 'file-open)356 (let ([fd (##core#inline "C_open" (##sys#make-c-string filename 'file-open) flags mode)])357 (when (eq? -1 fd)358 (posix-error #:file-error 'file-open "cannot open file" filename flags mode) )359 fd) ) ) ) )360361(set! chicken.file.posix#file-close362 (lambda (fd)363 (##sys#check-fixnum fd 'file-close)364 (let loop ()365 (when (fx< (##core#inline "C_close" fd) 0)366 (cond367 ((fx= _errno _eintr) (##sys#dispatch-interrupt loop))368 (else369 (posix-error #:file-error 'file-close "cannot close file" fd)))))))370371(set! chicken.file.posix#file-read372 (lambda (fd size . buffer)373 (##sys#check-fixnum fd 'file-read)374 (##sys#check-fixnum size 'file-read)375 (let ([buf (if (pair? buffer) (car buffer) (##sys#make-bytevector size))])376 (unless (##core#inline "C_byteblockp" buf)377 (##sys#signal-hook #:type-error 'file-read "bad argument type - not a bytevector" buf) )378 (let ([n (##core#inline "C_read" fd buf size)])379 (when (eq? -1 n)380 (posix-error #:file-error 'file-read "cannot read from file" fd size) )381 (list buf n) ) ) ) )382383(set! chicken.file.posix#file-write384 (lambda (fd buffer . size)385 (##sys#check-fixnum fd 'file-write)386 (unless (##core#inline "C_byteblockp" buffer)387 (##sys#signal-hook #:type-error 'file-write "bad argument type - not a bytevector" buffer) )388 (let ([size (if (pair? size) (car size) (##sys#size buffer))])389 (##sys#check-fixnum size 'file-write)390 (let ([n (##core#inline "C_write" fd buffer 0 size)])391 (when (eq? -1 n)392 (posix-error #:file-error 'file-write "cannot write to file" fd size) )393 n) ) ) )394395(set! chicken.file.posix#file-mkstemp396 (lambda (template)397 (##sys#check-string template 'file-mkstemp)398 (let* ([buf (##sys#make-c-string template 'file-mkstemp)]399 [fd (##core#inline "C_mkstemp" buf)]400 [path-length (string-length buf)])401 (when (eq? -1 fd)402 (posix-error #:file-error 'file-mkstemp "cannot create temporary file" template) )403 (values fd (##sys#substring buf 0 (fx- path-length 1) ) ) ) ) )404405406;;; I/O multiplexing:407408(set! chicken.file.posix#file-select409 (lambda (fdsr fdsw . timeout)410 (let* ((tm (if (pair? timeout) (car timeout) #f))411 (fdsrl (cond ((not fdsr) '())412 ((fixnum? fdsr) (list fdsr))413 (else (##sys#check-list fdsr 'file-select)414 fdsr)))415 (fdswl (cond ((not fdsw) '())416 ((fixnum? fdsw) (list fdsw))417 (else (##sys#check-list fdsw 'file-select)418 fdsw)))419 (nfdsr (##sys#length fdsrl))420 (nfdsw (##sys#length fdswl))421 (nfds (fx+ nfdsr nfdsw))422 (fds-blob (##sys#make-bytevector423 (fx* nfds (foreign-value "sizeof(struct pollfd)" int)))))424 (do ((i 0 (fx+ i 1))425 (fdsrl fdsrl (cdr fdsrl)))426 ((null? fdsrl))427 ((foreign-lambda* void ((int i) (int fd) (scheme-pointer p))428 "struct pollfd *fds = p;"429 "fds[i].fd = fd; fds[i].events = POLLIN;") i (car fdsrl) fds-blob))430 (do ((i nfdsr (fx+ i 1))431 (fdswl fdswl (cdr fdswl)))432 ((null? fdswl))433 ((foreign-lambda* void ((int i) (int fd) (scheme-pointer p))434 "struct pollfd *fds = p;"435 "fds[i].fd = fd; fds[i].events = POLLOUT;") i (car fdswl) fds-blob))436 (let ((n ((foreign-lambda int "poll" scheme-pointer int int)437 fds-blob nfds (if tm (inexact->exact (truncate (* (max 0 tm) 1000))) -1))))438 (cond ((fx< n 0)439 (posix-error #:file-error 'file-select "failed" fdsr fdsw) )440 ((fx= n 0) (values (if (pair? fdsr) '() #f) (if (pair? fdsw) '() #f)))441 (else442 (let ((rl (let lp ((i 0) (res '()) (fds fdsrl))443 (cond ((null? fds) (##sys#fast-reverse res))444 (((foreign-lambda* bool ((int i) (scheme-pointer p))445 "struct pollfd *fds = p;"446 "C_return(fds[i].revents & (POLLIN|POLLERR|POLLHUP|POLLNVAL));")447 i fds-blob)448 (lp (fx+ i 1) (cons (car fds) res) (cdr fds)))449 (else (lp (fx+ i 1) res (cdr fds))))))450 (wl (let lp ((i nfdsr) (res '()) (fds fdswl))451 (cond ((null? fds) (##sys#fast-reverse res))452 (((foreign-lambda* bool ((int i) (scheme-pointer p))453 "struct pollfd *fds = p;"454 "C_return(fds[i].revents & (POLLOUT|POLLERR|POLLHUP|POLLNVAL));")455 i fds-blob)456 (lp (fx+ i 1) (cons (car fds) res) (cdr fds)))457 (else (lp (fx+ i 1) res (cdr fds)))))))458 (values459 (and fdsr (if (fixnum? fdsr) (and (memq fdsr rl) fdsr) rl))460 (and fdsw (if (fixnum? fdsw) (and (memq fdsw wl) fdsw) wl))))))))))461462463;;; Pipe primitive:464465(define-foreign-variable _pipefd0 int "C_pipefds[ 0 ]")466(define-foreign-variable _pipefd1 int "C_pipefds[ 1 ]")467468(set! chicken.process#create-pipe469 (lambda (#!optional mode)470 (when (fx< (##core#inline "C_pipe" #f) 0)471 (posix-error #:file-error 'create-pipe "cannot create pipe") )472 (values _pipefd0 _pipefd1)) )473474475;;; Signal processing:476477(define-foreign-variable _nsig int "NSIG")478(define-foreign-variable _sigterm int "SIGTERM")479(define-foreign-variable _sigkill int "SIGKILL")480(define-foreign-variable _sigint int "SIGINT")481(define-foreign-variable _sighup int "SIGHUP")482(define-foreign-variable _sigfpe int "SIGFPE")483(define-foreign-variable _sigill int "SIGILL")484(define-foreign-variable _sigbus int "SIGBUS")485(define-foreign-variable _sigsegv int "SIGSEGV")486(define-foreign-variable _sigabrt int "SIGABRT")487(define-foreign-variable _sigtrap int "SIGTRAP")488(define-foreign-variable _sigquit int "SIGQUIT")489(define-foreign-variable _sigalrm int "SIGALRM")490(define-foreign-variable _sigpipe int "SIGPIPE")491(define-foreign-variable _sigusr1 int "SIGUSR1")492(define-foreign-variable _sigusr2 int "SIGUSR2")493(define-foreign-variable _sigvtalrm int "SIGVTALRM")494(define-foreign-variable _sigprof int "SIGPROF")495(define-foreign-variable _sigio int "SIGIO")496(define-foreign-variable _sigurg int "SIGURG")497(define-foreign-variable _sigchld int "SIGCHLD")498(define-foreign-variable _sigcont int "SIGCONT")499(define-foreign-variable _sigstop int "SIGSTOP")500(define-foreign-variable _sigtstp int "SIGTSTP")501(define-foreign-variable _sigxcpu int "SIGXCPU")502(define-foreign-variable _sigxfsz int "SIGXFSZ")503(define-foreign-variable _sigwinch int "SIGWINCH")504505(set! chicken.process.signal#signal/term _sigterm)506(set! chicken.process.signal#signal/kill _sigkill)507(set! chicken.process.signal#signal/int _sigint)508(set! chicken.process.signal#signal/hup _sighup)509(set! chicken.process.signal#signal/fpe _sigfpe)510(set! chicken.process.signal#signal/ill _sigill)511(set! chicken.process.signal#signal/segv _sigsegv)512(set! chicken.process.signal#signal/abrt _sigabrt)513(set! chicken.process.signal#signal/trap _sigtrap)514(set! chicken.process.signal#signal/quit _sigquit)515(set! chicken.process.signal#signal/alrm _sigalrm)516(set! chicken.process.signal#signal/vtalrm _sigvtalrm)517(set! chicken.process.signal#signal/prof _sigprof)518(set! chicken.process.signal#signal/io _sigio)519(set! chicken.process.signal#signal/urg _sigurg)520(set! chicken.process.signal#signal/chld _sigchld)521(set! chicken.process.signal#signal/cont _sigcont)522(set! chicken.process.signal#signal/stop _sigstop)523(set! chicken.process.signal#signal/tstp _sigtstp)524(set! chicken.process.signal#signal/pipe _sigpipe)525(set! chicken.process.signal#signal/xcpu _sigxcpu)526(set! chicken.process.signal#signal/xfsz _sigxfsz)527(set! chicken.process.signal#signal/usr1 _sigusr1)528(set! chicken.process.signal#signal/usr2 _sigusr2)529(set! chicken.process.signal#signal/winch _sigwinch)530(set! chicken.process.signal#signal/bus _sigbus)531(set! chicken.process.signal#signal/break 0)532533(set! chicken.process.signal#signals-list534 (list535 chicken.process.signal#signal/term536 chicken.process.signal#signal/kill537 chicken.process.signal#signal/int538 chicken.process.signal#signal/hup539 chicken.process.signal#signal/fpe540 chicken.process.signal#signal/ill541 chicken.process.signal#signal/segv542 chicken.process.signal#signal/abrt543 chicken.process.signal#signal/trap544 chicken.process.signal#signal/quit545 chicken.process.signal#signal/alrm546 chicken.process.signal#signal/vtalrm547 chicken.process.signal#signal/prof548 chicken.process.signal#signal/io549 chicken.process.signal#signal/urg550 chicken.process.signal#signal/chld551 chicken.process.signal#signal/cont552 chicken.process.signal#signal/stop553 chicken.process.signal#signal/tstp554 chicken.process.signal#signal/pipe555 chicken.process.signal#signal/xcpu556 chicken.process.signal#signal/xfsz557 chicken.process.signal#signal/usr1558 chicken.process.signal#signal/usr2559 chicken.process.signal#signal/winch560 chicken.process.signal#signal/bus))561562(set! chicken.process.signal#set-signal-mask!563 (lambda (sigs)564 (##sys#check-list sigs 'set-signal-mask!)565 (##core#inline "C_sigemptyset" 0)566 (for-each567 (lambda (s)568 (##sys#check-fixnum s 'set-signal-mask!)569 (##core#inline "C_sigaddset" s) )570 sigs)571 (when (fx< (##core#inline "C_sigprocmask_set" 0) 0)572 (posix-error #:process-error 'set-signal-mask! "cannot set signal mask") )))573574(define chicken.process.signal#signal-mask575 (getter-with-setter576 (lambda ()577 (##core#inline "C_sigprocmask_get" 0)578 (let loop ((sigs chicken.process.signal#signals-list) (mask '()))579 (if (null? sigs)580 mask581 (let ([sig (car sigs)])582 (loop (cdr sigs)583 (if (##core#inline "C_sigismember" sig) (cons sig mask) mask)) ) ) ) )584 chicken.process.signal#set-signal-mask!585 "(chicken.process.signal#signal-mask)"))586587(set! chicken.process.signal#signal-masked?588 (lambda (sig)589 (##sys#check-fixnum sig 'signal-masked?)590 (##core#inline "C_sigprocmask_get" 0)591 (##core#inline "C_sigismember" sig)) )592593(set! chicken.process.signal#signal-mask!594 (lambda (sig)595 (##sys#check-fixnum sig 'signal-mask!)596 (##core#inline "C_sigemptyset" 0)597 (##core#inline "C_sigaddset" sig)598 (when (fx< (##core#inline "C_sigprocmask_block" 0) 0)599 (posix-error #:process-error 'signal-mask! "cannot block signal") )))600601(set! chicken.process.signal#signal-unmask!602 (lambda (sig)603 (##sys#check-fixnum sig 'signal-unmask!)604 (##core#inline "C_sigemptyset" 0)605 (##core#inline "C_sigaddset" sig)606 (when (fx< (##core#inline "C_sigprocmask_unblock" 0) 0)607 (posix-error #:process-error 'signal-unmask! "cannot unblock signal") )) )608609610;;; Getting group- and user-information:611612(set! chicken.process-context.posix#current-user-id613 (getter-with-setter614 (foreign-lambda int "C_getuid")615 (lambda (id)616 (##sys#check-fixnum id 'current-user-id)617 (when (fx< (##core#inline "C_setuid" id) 0)618 (##sys#error/errno (##sys#update-errno)619 'current-user-id!-setter "cannot set user ID" id)))620 "(chicken.process-context.posix#current-user-id)"))621622(set! chicken.process-context.posix#current-effective-user-id623 (getter-with-setter624 (foreign-lambda int "C_geteuid")625 (lambda (id)626 (##sys#check-fixnum id 'current-effective-user-id)627 (when (fx< (##core#inline "C_seteuid" id) 0)628 (##sys#error/errno (##sys#update-errno)629 'effective-user-id!-setter630 "cannot set effective user ID" id)))631 "(chicken.process-context.posix#current-effective-user-id)"))632633(set! chicken.process-context.posix#current-group-id634 (getter-with-setter635 (foreign-lambda int "C_getgid")636 (lambda (id)637 (##sys#check-fixnum id 'current-group-id)638 (when (fx< (##core#inline "C_setgid" id) 0)639 (##sys#error/errno (##sys#update-errno)640 'current-group-id!-setter "cannot set group ID" id)))641 "(chicken.process-context.posix#current-group-id)") )642643(set! chicken.process-context.posix#current-effective-group-id644 (getter-with-setter645 (foreign-lambda int "C_getegid")646 (lambda (id)647 (##sys#check-fixnum id 'current-effective-group-id)648 (when (fx< (##core#inline "C_setegid" id) 0)649 (##sys#error/errno (##sys#update-errno)650 'effective-group-id!-setter651 "cannot set effective group ID" id)))652 "(chicken.process-context.posix#current-effective-group-id)") )653654(define-foreign-variable _user-name nonnull-c-string "C_user->pw_name")655(define-foreign-variable _user-passwd nonnull-c-string "C_user->pw_passwd")656(define-foreign-variable _user-uid int "C_user->pw_uid")657(define-foreign-variable _user-gid int "C_user->pw_gid")658(define-foreign-variable _user-gecos nonnull-c-string "C_PW_GECOS")659(define-foreign-variable _user-dir c-string "C_user->pw_dir")660(define-foreign-variable _user-shell c-string "C_user->pw_shell")661662(set! chicken.process-context.posix#user-information663 (lambda (user #!optional as-vector)664 (let ([r (if (fixnum? user)665 (##core#inline "C_getpwuid" user)666 (begin667 (##sys#check-string user 'user-information)668 (##core#inline "C_getpwnam" (##sys#make-c-string user 'user-information)) ) ) ] )669 (and r670 ((if as-vector vector list)671 _user-name672 _user-passwd673 _user-uid674 _user-gid675 _user-gecos676 _user-dir677 _user-shell) ) )) )678679(set! chicken.process-context.posix#current-user-name680 (lambda ()681 (car (chicken.process-context.posix#user-information682 (chicken.process-context.posix#current-user-id)))) )683684(set! chicken.process-context.posix#current-effective-user-name685 (lambda ()686 (car (chicken.process-context.posix#user-information687 (chicken.process-context.posix#current-effective-user-id)))) )688689(define chown690 (lambda (loc f uid gid)691 (##sys#check-fixnum uid loc)692 (##sys#check-fixnum gid loc)693 (let ((r (cond694 ((port? f)695 (##core#inline "C_fchown" (chicken.file.posix#port->fileno f) uid gid))696 ((fixnum? f)697 (##core#inline "C_fchown" f uid gid))698 ((string? f)699 (##core#inline "C_chown"700 (##sys#make-c-string f loc) uid gid))701 (else (##sys#signal-hook702 #:type-error loc703 "bad argument type - not a fixnum, port or string" f)))))704 (when (fx< r 0)705 (posix-error #:file-error loc "cannot change file owner" f uid gid) )) ) )706707(set! chicken.process-context.posix#create-session708 (lambda ()709 (let ([a (##core#inline "C_setsid" #f)])710 (when (fx< a 0)711 (##sys#error/errno (##sys#update-errno)712 'create-session "cannot create session"))713 a)) )714715(set! chicken.process-context.posix#process-group-id716 (getter-with-setter717 (lambda (pid)718 (##sys#check-fixnum pid 'process-group-id)719 (let ([a (##core#inline "C_getpgid" pid)])720 (when (fx< a 0)721 (##sys#error/errno (##sys#update-errno)722 'process-group-id723 "cannot retrieve process group ID" pid))724 a))725 (lambda (pid pgid)726 (##sys#check-fixnum pid 'process-group)727 (##sys#check-fixnum pgid 'process-group)728 (when (fx< (##core#inline "C_setpgid" pid pgid) 0)729 (##sys#error/errno (##sys#update-errno)730 'process-group "cannot set process group ID" pid pgid)))731 "(chicken.process-context.posix#process-group-id pid)"))732733734;;; Hard and symbolic links:735736(set! chicken.file.posix#create-symbolic-link737 (lambda (old new)738 (##sys#check-string old 'create-symbolic-link)739 (##sys#check-string new 'create-symbolic-link)740 (when (fx< (##core#inline741 "C_symlink"742 (##sys#make-c-string old 'create-symbolic-link)743 (##sys#make-c-string new 'create-symbolic-link) )744 0)745 (posix-error #:file-error 'create-symbolic-link "cannot create symbolic link" old new) ) ) )746747(define-foreign-variable _filename_max int "FILENAME_MAX")748749(define ##sys#read-symbolic-link750 (let ((buf (##sys#make-bytevector (fx+ _filename_max 1) 0)))751 (lambda (fname location)752 (let ((len (##core#inline753 "C_do_readlink"754 (##sys#make-c-string fname location)755 buf)))756 (if (fx< len 0)757 (posix-error #:file-error location "cannot read symbolic link" fname)758 (##sys#buffer->string buf 0 len))))))759760(set! chicken.file.posix#read-symbolic-link761 (lambda (fname #!optional canonicalize)762 (##sys#check-string fname 'read-symbolic-link)763 (if canonicalize764 (receive (base-origin base-directory directory-components) (decompose-directory fname)765 (let loop ((components directory-components)766 (result (string-append (or base-origin "") (or base-directory ""))))767 (if (null? components)768 result769 (let ((pathname (make-pathname result (car components))))770 (if (##sys#file-exists? pathname #f #f 'read-symbolic-link)771 (loop (cdr components)772 (if (chicken.file.posix#symbolic-link? pathname)773 (let ((target (##sys#read-symbolic-link pathname 'read-symbolic-link)))774 (if (absolute-pathname? target)775 target776 (make-pathname result target)))777 pathname))778 (##sys#signal-hook #:file-error 'read-symbolic-link "could not canonicalize path with symbolic links, component does not exist" pathname))))))779 (##sys#read-symbolic-link fname 'read-symbolic-link))))780781(set! chicken.file.posix#file-link782 (let ((link (foreign-lambda int "link" nonnull-c-string nonnull-c-string)))783 (lambda (old new)784 (##sys#check-string old 'file-link)785 (##sys#check-string new 'file-link)786 (when (fx< (link old new) 0)787 (posix-error #:file-error 'hard-link "could not create hard link" old new) ) ) ) )788789(define-inline (eagain/ewouldblock? e)790 (or (fx= e _ewouldblock)791 (fx= e _eagain)))792793(define ##sys#custom-input-port794 (lambda (loc nam fd #!optional (nonblocking? #f) (bufi 1) (on-close void) (more? #f) enc)795 (when nonblocking? (##sys#file-nonblocking! fd) )796 (let ((bufsiz (if (fixnum? bufi) bufi (##sys#size bufi)))797 (buf (if (fixnum? bufi) (##sys#make-bytevector bufi) bufi))798 (buflen 0)799 (bufpos 0)800 (this-port #f))801 (let ([ready?802 (lambda ()803 (let ((res (##sys#file-select-one fd)))804 (if (fx= -1 res)805 (if (eagain/ewouldblock? _errno)806 #f807 (posix-error #:file-error loc "cannot select" fd nam))808 (fx= 1 res))))]809 [peek810 (lambda ()811 (if (fx>= bufpos buflen)812 #!eof813 (##sys#decode-buffer buf bufpos 1 (##sys#slot this-port 15)814 (lambda (buf start n)815 (##core#inline "C_utf_decode" buf start)))))]816 [fetch817 (lambda ()818 (let loop ()819 (let ([cnt (##core#inline "C_read" fd buf bufsiz)])820 (cond ((fx= cnt -1)821 (cond822 ((eagain/ewouldblock? _errno)823 (##sys#thread-block-for-i/o! ##sys#current-thread fd #:input)824 (##sys#thread-yield!)825 (loop) )826 ((fx= _errno _eintr)827 (##sys#dispatch-interrupt loop))828 (else (posix-error #:file-error loc "cannot read" fd nam) )))829 [(and more? (fx= cnt 0))830 ;; When "more" keep trying, otherwise read once more831 ;; to guard against race conditions832 (if more?833 (begin834 (##sys#thread-yield!)835 (loop) )836 (let ([cnt (##core#inline "C_read" fd buf bufsiz)])837 (when (fx= cnt -1)838 (if (eagain/ewouldblock? _errno)839 (set! cnt 0)840 (posix-error #:file-error loc "cannot read" fd nam) ) )841 (set! buflen cnt)842 (set! bufpos 0) ) )]843 [else844 (set! buflen cnt)845 (set! bufpos 0)]) ) ) )] )846 (let ([the-port847 (make-input-port848 (lambda () ; read-char849 (when (fx>= bufpos buflen)850 (fetch))851 (if (fx>= bufpos buflen)852 #!eof853 (##sys#decode-buffer buf bufpos 1 (##sys#slot this-port 15)854 (lambda (buf start n)855 (set! bufpos (fx+ bufpos n))856 (##core#inline "C_utf_decode" buf start)))))857 (lambda () ; char-ready?858 (or (fx< bufpos buflen)859 (ready?)) )860 (lambda () ; close861 (when (fx< (##core#inline "C_close" fd) 0)862 (posix-error #:file-error loc "cannot close" fd nam))863 (on-close))864 peek-char:865 (lambda () ; peek-char866 (when (fx>= bufpos buflen)867 (fetch))868 (peek) )869 read-bytevector:870 (lambda (port n dest start) ; read-bytevector!871 (let loop ([n (or n (fx- (##sys#size dest) start))]872 [m 0]873 [start start])874 (cond [(eq? 0 n) m]875 [(fx< bufpos buflen)876 (let* ([rest (fx- buflen bufpos)]877 [n2 (if (fx< n rest) n rest)])878 (##core#inline "C_copy_memory_with_offset"879 dest buf start bufpos n2)880 (set! bufpos (fx+ bufpos n2))881 (loop (fx- n n2) (fx+ m n2) (fx+ start n2)) ) ]882 [else883 (fetch)884 (if (eq? 0 buflen)885 m886 (loop n m start) ) ] ) ) )887 read-line:888 (lambda (p limit) ; read-line889 (when (fx>= bufpos buflen)890 (fetch))891 (if (fx>= bufpos buflen)892 #!eof893 (let ((limit (or limit (fx- most-positive-fixnum bufpos))))894 (receive (next line full-line?)895 (##sys#scan-buffer-line896 buf897 (fxmin buflen (fx+ bufpos limit))898 bufpos899 (lambda (pos)900 (let ((nbytes (fx- pos bufpos)))901 (cond ((fx>= nbytes limit)902 (values #f pos #f))903 (else904 (set! limit (fx- limit nbytes))905 (fetch)906 (if (fx< bufpos buflen)907 (values buf bufpos908 (fxmin buflen909 (fx+ bufpos limit)))910 (values #f bufpos #f))))))911 (##sys#slot this-port 15))912 ;; Update row & column position913 (if full-line?914 (begin915 (##sys#setislot p 4 (fx+ (##sys#slot p 4) 1))916 (##sys#setislot p 5 0))917 (##sys#setislot p 5 (fx+ (##sys#slot p 5)918 (string-length line))))919 (set! bufpos next)920 line)) ) )921 read-buffered:922 (lambda (port) ; read-buffered923 (if (fx>= bufpos buflen)924 ""925 (let* ((len (fx- buflen bufpos))926 (str (##sys#buffer->string/encoding buf bufpos len (##sys#slot this-port 15))))927 (set! bufpos buflen)928 str))))])929 (set! this-port the-port)930 (##sys#setslot this-port 3 nam)931 (##sys#setslot this-port 15 enc)932 this-port ) ) ) ) )933934(define ##sys#custom-output-port935 (lambda (loc nam fd #!optional (nonblocking? #f) (bufi 0) (on-close void)936 enc)937 (when nonblocking? (##sys#file-nonblocking! fd) )938 (letrec ((this-port #f)939 (poke940 (lambda (bv start len)941 (let loop ()942 (let ((cnt (##core#inline "C_write" fd bv start len)))943 (cond ((fx= -1 cnt)944 (cond945 ((eagain/ewouldblock? _errno)946 (##sys#thread-yield!)947 (poke bv start len) )948 ((fx= _errno _eintr)949 (##sys#dispatch-interrupt loop))950 (else951 (posix-error loc #:file-error "cannot write" fd nam) ) ) )952 ((fx< cnt len)953 (poke bv (fx+ start cnt) (fx- len cnt)) ) ) ) )))954 (store955 (let ([bufsiz (if (fixnum? bufi) bufi (##sys#size bufi))])956 (if (fx= 0 bufsiz)957 (lambda (str)958 (when str959 (let ((bv (##sys#slot str 0)))960 (poke bv 0 (fx- (##sys#size bv) 1)))))961 (let ((buf (if (fixnum? bufi) (##sys#make-bytevector bufi) bufi))962 (bufpos 0))963 (lambda (str)964 (if str965 (let ((bv (##sys#slot str 0)))966 (let loop ((rem (fx- bufsiz bufpos))967 (start 0)968 (len (fx- (##sys#size bv) 1)))969 (cond ((fx= 0 rem)970 (poke buf 0 bufsiz)971 (set! bufpos 0)972 (loop bufsiz 0 len))973 ((fx< rem len)974 (##core#inline "C_copy_memory_with_offset" buf bv bufpos 0 len)975 (loop 0 rem (fx- len rem)))976 (else977 (##core#inline "C_copy_memory_with_offset" buf bv bufpos start len)978 (set! bufpos (fx+ bufpos len))) ) )979 (when (fx< 0 bufpos)980 (poke buf bufpos) ) ) ) ) ) ))))981 (let ((the-port982 (make-output-port983 (lambda (str) (store str))984 (lambda () ; close985 (when (fx< (##core#inline "C_close" fd) 0)986 (posix-error #:file-error loc "cannot close" fd nam))987 (on-close))988 force-output:989 (lambda () ; flush990 (store #f) ) )) )991 (set! this-port the-port)992 (##sys#setslot this-port 3 nam)993 (##sys#setslot this-port 15 enc)994 this-port ) ) ) )995996997;;; Other file operations:998999(set! chicken.file.posix#file-truncate1000 (lambda (fname off)1001 (##sys#check-exact-integer off 'file-truncate)1002 (when (fx< (cond ((string? fname) (##core#inline "C_truncate" (##sys#make-c-string fname 'file-truncate) off))1003 ((port? fname) (##core#inline "C_ftruncate" (chicken.file.posix#port->fileno fname) off))1004 ((fixnum? fname) (##core#inline "C_ftruncate" fname off))1005 (else (##sys#error 'file-truncate "invalid file" fname)))1006 0)1007 (posix-error #:file-error 'file-truncate "cannot truncate file" fname off) ) ) )100810091010;;; File locking:10111012(define-foreign-variable _lock_sh int "LOCK_SH")1013(define-foreign-variable _lock_ex int "LOCK_EX")1014(define-foreign-variable _lock_un int "LOCK_UN")1015(define-foreign-variable _lock_nb int "LOCK_NB")10161017(let ()1018 (define (err msg port loc)1019 (posix-error #:file-error loc msg port) )1020 (define (fileno x loc)1021 (if (port? x)1022 (chicken.file.posix#port->fileno x)1023 (begin1024 (##sys#check-exact-integer x loc)1025 x)))1026 (set! chicken.file.posix#file-lock1027 (lambda (port #!optional shared)1028 (let loop ()1029 (let ((r (##core#inline "C_flock" (fileno port 'file-lock)1030 (##core#inline "C_fixnum_or" _lock_nb (if shared _lock_sh _lock_ex)))))1031 (cond ((eq? r 0) #t)1032 ((fx= _errno _eintr) (loop))1033 ((eagain/ewouldblock? _errno) #f)1034 (else (err "locking file failed" port 'file-lock)))))))1035 (set! chicken.file.posix#file-lock/blocking1036 (lambda (port #!optional shared)1037 (let loop ()1038 (let ((r (##core#inline "C_flock" (fileno port 'file-lock/blocking)1039 (if shared _lock_sh _lock_ex))))1040 (cond ((eq? r 0) #t)1041 ((fx= _errno _eintr) (loop))1042 (else (err "locking file failed" port 'file-lock/blocking)))))))1043 (set! chicken.file.posix#file-unlock1044 (lambda (port)1045 (let loop ()1046 (let ((r (##core#inline "C_flock" (fileno port 'file-unlock) _lock_un)))1047 (cond ((eq? r 0))1048 ((fx= _errno _eintr) (loop))1049 (else (err "unlocking file failed" port 'file-unlock))))))))105010511052;;; FIFOs:10531054(set! chicken.file.posix#create-fifo1055 (lambda (fname . mode)1056 (##sys#check-string fname 'create-fifo)1057 (let ([mode (if (pair? mode) (car mode) (fxior _s_irwxu (fxior _s_irwxg _s_irwxo)))])1058 (##sys#check-fixnum mode 'create-fifo)1059 (when (fx< (##core#inline "C_mkfifo" (##sys#make-c-string fname 'create-fifo) mode) 0)1060 (posix-error #:file-error 'create-fifo "cannot create FIFO" fname mode) ) ) ) )106110621063;;; Time related things:10641065(set! chicken.time.posix#string->time1066 (let ((strptime (foreign-lambda scheme-object "C_strptime" scheme-object scheme-object scheme-object scheme-pointer))1067 (tm-size (foreign-value "sizeof(struct tm)" int)))1068 (lambda (tim #!optional (fmt "%a %b %e %H:%M:%S %Z %Y"))1069 (##sys#check-string tim 'string->time)1070 (##sys#check-string fmt 'string->time)1071 (strptime (##sys#make-c-string tim 'string->time) (##sys#make-c-string fmt) (make-vector 10 #f) (##sys#make-string tm-size #\nul)) ) ) )10721073(set! chicken.time.posix#utc-time->seconds1074 (let ((tm-size (foreign-value "sizeof(struct tm)" int)))1075 (lambda (tm)1076 (check-time-vector 'utc-time->seconds tm)1077 (let ((t (##core#inline_allocate ("C_a_timegm" 7) tm (##sys#make-string tm-size #\nul))))1078 (if (= -1 t)1079 (##sys#error 'utc-time->seconds "cannot convert time vector to seconds" tm)1080 t)))))10811082(set! chicken.time.posix#local-timezone-abbreviation1083 (foreign-lambda* c-string ()1084 "\n#if !defined(__CYGWIN__) && !defined(__SVR4) && !defined(__uClinux__) && !defined(__hpux__) && !defined(_AIX)\n"1085 "time_t clock = time(NULL);"1086 "struct tm *ltm = C_localtime(&clock);"1087 "char *z = ltm ? (char *)ltm->tm_zone : 0;"1088 "\n#else\n"1089 "char *z = (daylight ? tzname[1] : tzname[0]);"1090 "\n#endif\n"1091 "C_return(z);") )109210931094;;; Other things:10951096(set! chicken.process.signal#set-alarm!1097 (foreign-lambda int "C_alarm" int))109810991100;;; Process handling:11011102(define c-string->allocated-pointer1103 (foreign-lambda* c-pointer ((scheme-object o))1104 "char *ptr = C_malloc(C_header_size(o)); \n"1105 "if (ptr != NULL) {\n"1106 " C_memcpy(ptr, C_data_pointer(o), C_header_size(o)); \n"1107 "}\n"1108 "C_return(ptr);"))11091110(set! chicken.process#process-fork1111 (let ((fork (foreign-lambda int "C_fork")))1112 (lambda (#!optional thunk killothers)1113 ;; flush all stdio streams before fork1114 ((foreign-lambda int "C_fflush" c-pointer) #f)1115 (let ((pid (fork)))1116 (cond ((fx= -1 pid) ; error1117 (posix-error #:process-error 'process-fork "cannot create child process"))1118 ((fx= 0 pid) ; child process1119 (set! children '())1120 (when killothers1121 (call-with-current-continuation (lambda (continue) (##sys#kill-other-threads (lambda () (continue #f))))))1122 (if thunk1123 (##sys#call-with-cthulhu1124 (lambda ()1125 (thunk)1126 ;; Make sure to run clean up tasks.1127 ;; NOTE: ##sys#call-with-cthulhu will invoke1128 ;; a more low-level runtime C_exit_runtime(0)1129 (exit 0)))1130 #f))1131 (else ; parent process1132 (register-pid pid)))))))11331134(set! chicken.process#process-execute1135 (lambda (filename #!optional (arglist '()) envlist _)1136 (call-with-exec-args1137 'process-execute filename (lambda (x) x) arglist envlist1138 (lambda (prg argbuf envbuf)1139 (let ((r (if envbuf1140 (##core#inline "C_u_i_execve" prg argbuf envbuf)1141 (##core#inline "C_u_i_execvp" prg argbuf))))1142 (when (fx= r -1)1143 (posix-error #:process-error 'process-execute "cannot execute process" filename)))))))11441145(define-foreign-variable _wnohang int "WNOHANG")1146(define-foreign-variable _wait-status int "C_wait_status")11471148(define (process-wait-impl pid nohang)1149 (let* ((res (##core#inline "C_waitpid" pid (if nohang _wnohang 0)))1150 (norm (##core#inline "C_WIFEXITED" _wait-status)) )1151 (if (and (fx= res -1) (fx= _errno _eintr))1152 (##sys#dispatch-interrupt1153 (lambda () (process-wait-impl pid nohang)))1154 (values1155 res1156 norm1157 (cond (norm (##core#inline "C_WEXITSTATUS" _wait-status))1158 ((##core#inline "C_WIFSIGNALED" _wait-status)1159 (##core#inline "C_WTERMSIG" _wait-status))1160 (else (##core#inline "C_WSTOPSIG" _wait-status)) ) )) ) )11611162(set! chicken.process-context.posix#parent-process-id (foreign-lambda int "C_getppid"))11631164(set! chicken.process#process-signal1165 (lambda (id . sig)1166 (let ((sig (if (pair? sig) (car sig) _sigterm))1167 (pid (if (process? id) (process-id id) id)))1168 (##sys#check-fixnum pid 'process-signal)1169 (##sys#check-fixnum sig 'process-signal)1170 (let ((r (##core#inline "C_kill" pid sig)))1171 (when (fx= r -1)1172 (posix-error #:process-error 'process-signal1173 "could not send signal to process" id sig) ) ) ) ) )11741175(define (shell-command loc)1176 (or (get-environment-variable "SHELL") "/bin/sh") )11771178(define (shell-command-arguments cmdlin)1179 (list "-c" cmdlin) )11801181(set! chicken.process#process-run1182 (lambda (f . args)1183 (let ((args (if (pair? args) (car args) #f))1184 (proc (chicken.process#process-fork)) )1185 (cond (proc)1186 (args (chicken.process#process-execute f args))1187 (else1188 (chicken.process#process-execute1189 (shell-command 'process-run)1190 (shell-command-arguments f)) ) ) ) ) )11911192;;; Run subprocess connected with pipes:11931194;; process-impl1195; loc caller procedure symbol1196; cmd pathname or commandline1197; args string-list or '()1198; env string-list or #f1199; stdoutf #f then share, or #t then create1200; stdinf #f then share, or #t then create1201; stderrf #f then share, or #t then create1202;1203; (values stdin-input-port? stdout-output-port? pid stderr-input-port?)1204; where stdin-input-port?, etc. is a port or #f, indicating no port created.12051206(define-constant DEFAULT-INPUT-BUFFER-SIZE 256)1207(define-constant DEFAULT-OUTPUT-BUFFER-SIZE 0)12081209;FIXME process-execute, process-fork don't show parent caller12101211(define process-impl1212 (let ((replace-fd1213 (lambda (loc fd stdfd)1214 (unless (fx= stdfd fd)1215 (chicken.file.posix#duplicate-fileno fd stdfd)1216 (chicken.file.posix#file-close fd) ) )) )1217 (let ((make-on-close1218 (lambda (loc proc clsvec idx idxa idxb)1219 (lambda ()1220 (vector-set! clsvec idx #t)1221 (when (and (vector-ref clsvec idxa) (vector-ref clsvec idxb))1222 (chicken.process#process-wait proc #f) )1223 (void)) ))1224 (needed-pipe1225 (lambda (loc port)1226 (and port1227 (receive (i o) (chicken.process#create-pipe)1228 (cons i o))) ))1229 [connect-parent1230 (lambda (loc pipe port fd)1231 (and port1232 (let ([usefd (car pipe)] [clsfd (cdr pipe)])1233 (chicken.file.posix#file-close clsfd)1234 usefd) ) )]1235 [connect-child1236 (lambda (loc pipe port stdfd)1237 (when port1238 (let ([usefd (car pipe)] [clsfd (cdr pipe)])1239 (chicken.file.posix#file-close clsfd)1240 (replace-fd loc usefd stdfd)) ) )] )1241 (let (1242 (spawn1243 (let ([swapped-ends1244 (lambda (pipe)1245 (and pipe1246 (cons (cdr pipe) (car pipe)) ) )])1247 (lambda (loc cmd args env stdoutf stdinf stderrf)1248 (let ([ipipe (needed-pipe loc stdinf)]1249 [opipe (needed-pipe loc stdoutf)]1250 [epipe (needed-pipe loc stderrf)])1251 (values1252 ipipe (swapped-ends opipe) epipe1253 (chicken.process#process-fork1254 (lambda ()1255 (connect-child loc opipe stdinf chicken.file.posix#fileno/stdin)1256 (connect-child loc (swapped-ends ipipe) stdoutf chicken.file.posix#fileno/stdout)1257 (connect-child loc (swapped-ends epipe) stderrf chicken.file.posix#fileno/stderr)1258 (chicken.process#process-execute cmd args env)))) ) ) ))1259 [input-port1260 (lambda (loc cmd pipe stdf stdfd on-close enc)1261 (and-let* ([fd (connect-parent loc pipe stdf stdfd)])1262 (##sys#custom-input-port loc cmd fd #t DEFAULT-INPUT-BUFFER-SIZE on-close #f enc) ) )]1263 [output-port1264 (lambda (loc cmd pipe stdf stdfd on-close enc)1265 (and-let* ([fd (connect-parent loc pipe stdf stdfd)])1266 (##sys#custom-output-port loc cmd fd #t DEFAULT-OUTPUT-BUFFER-SIZE on-close enc) ) )] )1267 (lambda (loc cmd args env stdoutf stdinf stderrf enc)1268 (receive [inpipe outpipe errpipe proc]1269 (spawn loc cmd args env stdoutf stdinf stderrf)1270 ;When shared assume already "closed", since only created ports1271 ;should be explicitly closed, and when one is closed we want1272 ;to wait.1273 (let ((clsvec (vector (not stdinf) (not stdoutf) (not stderrf))))1274 (process-output-port-set! proc1275 (input-port loc cmd inpipe stdinf1276 chicken.file.posix#fileno/stdin1277 (make-on-close loc proc clsvec 0 1 2)1278 enc))1279 (process-input-port-set! proc1280 (output-port loc cmd outpipe stdoutf1281 chicken.file.posix#fileno/stdout1282 (make-on-close loc proc clsvec 1 0 2)1283 enc))1284 (process-error-port-set! proc1285 (input-port loc cmd errpipe stderrf1286 chicken.file.posix#fileno/stderr1287 (make-on-close loc proc clsvec 2 0 1)1288 enc) )1289 proc) ) ) ) ) ) )12901291;;; Run subprocess connected with pipes:12921293;; TODO: See if this can be moved to posix-common1294(let ((%process1295 (lambda (loc err? cmd args env enc)1296 (let ((chkstrlst1297 (lambda (lst)1298 (##sys#check-list lst loc)1299 (for-each (cut ##sys#check-string <> loc) lst) )))1300 (##sys#check-string cmd loc)1301 (if args1302 (chkstrlst args)1303 (begin1304 (set! args (shell-command-arguments cmd))1305 (set! cmd (shell-command loc)) ) )1306 (when env (check-environment-list env loc))1307 (process-impl loc cmd args env #t #t err? enc)))))1308 (set! chicken.process#process1309 (lambda (cmd #!optional args env (enc 'utf-8) exactf)1310 (%process 'process #f cmd args env enc)))1311 (set! chicken.process#process*1312 (lambda (cmd #!optional args env (enc 'utf-8) exactf)1313 (%process 'process* #t cmd args env enc))))131413151316;;; chroot:13171318(set! chicken.process-context.posix#set-root-directory!1319 (let ((chroot (foreign-lambda int "chroot" nonnull-c-string)))1320 (lambda (dir)1321 (##sys#check-string dir 'set-root-directory!)1322 (when (fx< (chroot dir) 0)1323 (posix-error #:file-error 'set-root-directory! "unable to change root directory" dir) ) ) ) )13241325;;; unimplemented stuff:13261327(set!-unimplemented chicken.process#process-spawn)