~ 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#if defined(__linux__) || defined(__GLIBC__) || (defined(__sun) && defined(__SVR4))53# include <sys/file.h>54#endif5556#ifdef __HAIKU__57# include <posix/sys/file.h>58#endif5960#include <sys/mman.h>61#include <poll.h>6263#ifndef O_FSYNC64# define O_FSYNC O_SYNC65#endif6667#ifndef PIPE_BUF68# ifdef __CYGWIN__69# define PIPE_BUF _POSIX_PIPE_BUF70# else71# define PIPE_BUF 102472# endif73#endif7475#ifndef O_BINARY76# define O_BINARY 077#endif78#ifndef O_TEXT79# define O_TEXT 080#endif8182#ifndef MAP_FILE83# define MAP_FILE 084#endif8586#ifndef MAP_ANON87# define MAP_ANON 088#endif8990#ifndef FILENAME_MAX91# define FILENAME_MAX 102492#endif9394static DIR *temphandle;95static struct passwd *C_user;9697/* Android doesn't provide pw_gecos in the passwd struct */98#ifdef __ANDROID__99# define C_PW_GECOS ("")100#else101# define C_PW_GECOS (C_user->pw_gecos)102#endif103104static int C_pipefds[ 2 ];105static time_t C_secs;106static struct timeval C_timeval;107static struct stat C_statbuf;108109#define C_fchdir(fd) C_fix(fchdir(C_unfix(fd)))110111#define open_binary_input_pipe(a, n, name) C_mpointer(a, popen(C_c_string(name), "r"))112#define open_text_input_pipe(a, n, name) open_binary_input_pipe(a, n, name)113#define open_binary_output_pipe(a, n, name) C_mpointer(a, popen(C_c_string(name), "w"))114#define open_text_output_pipe(a, n, name) open_binary_output_pipe(a, n, name)115#define close_pipe(p) C_fix(pclose(C_port_file(p)))116117#define C_fork fork118#define C_waitpid(id, o) C_fix(waitpid(C_unfix(id), &C_wait_status, C_unfix(o)))119#define C_getppid getppid120#define C_kill(id, s) C_fix(kill(C_unfix(id), C_unfix(s)))121#define C_getuid getuid122#define C_getgid getgid123#define C_geteuid geteuid124#define C_getegid getegid125#define C_chown(fn, u, g) C_fix(chown(C_c_string(fn), C_unfix(u), C_unfix(g)))126#define C_fchown(fd, u, g) C_fix(fchown(C_unfix(fd), C_unfix(u), C_unfix(g)))127#define C_chmod(fn, m) C_fix(chmod(C_c_string(fn), C_unfix(m)))128#define C_fchmod(fd, m) C_fix(fchmod(C_unfix(fd), C_unfix(m)))129#define C_setuid(id) C_fix(setuid(C_unfix(id)))130#define C_setgid(id) C_fix(setgid(C_unfix(id)))131#define C_seteuid(id) C_fix(seteuid(C_unfix(id)))132#define C_setegid(id) C_fix(setegid(C_unfix(id)))133#define C_setsid(dummy) C_fix(setsid())134#define C_setpgid(x, y) C_fix(setpgid(C_unfix(x), C_unfix(y)))135#define C_getpgid(x) C_fix(getpgid(C_unfix(x)))136#define C_symlink(o, n) C_fix(symlink(C_c_string(o), C_c_string(n)))137#define C_do_readlink(f, b) C_fix(readlink(C_c_string(f), C_c_string(b), FILENAME_MAX))138#define C_getpwnam(n) C_mk_bool((C_user = getpwnam(C_c_string(n))) != NULL)139#define C_getpwuid(u) C_mk_bool((C_user = getpwuid(C_unfix(u))) != NULL)140#define C_pipe(d) C_fix(pipe(C_pipefds))141#define C_truncate(f, n) C_fix(truncate(C_c_string(f), C_num_to_int(n)))142#define C_ftruncate(f, n) C_fix(ftruncate(C_unfix(f), C_num_to_int(n)))143#define C_alarm alarm144#define C_close(fd) C_fix(close(C_unfix(fd)))145#define C_umask(m) C_fix(umask(C_unfix(m)))146147#define C_u_i_lstat(fn) C_fix(lstat(C_c_string(fn), &C_statbuf))148149#define C_u_i_execvp(f,a) C_fix(execvp(C_c_string(f), (char *const *)C_c_pointer_vector_or_null(a)))150#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)))151152static int C_uw;153#define C_WIFEXITED(n) (C_uw = C_unfix(n), C_mk_bool(WIFEXITED(C_uw)))154#define C_WIFSIGNALED(n) (C_uw = C_unfix(n), C_mk_bool(WIFSIGNALED(C_uw)))155#define C_WIFSTOPPED(n) (C_uw = C_unfix(n), C_mk_bool(WIFSTOPPED(C_uw)))156#define C_WEXITSTATUS(n) (C_uw = C_unfix(n), C_fix(WEXITSTATUS(C_uw)))157#define C_WTERMSIG(n) (C_uw = C_unfix(n), C_fix(WTERMSIG(C_uw)))158#define C_WSTOPSIG(n) (C_uw = C_unfix(n), C_fix(WSTOPSIG(C_uw)))159160#ifdef __CYGWIN__161# define C_mkfifo(fn, m) C_fix(-1)162#else163# define C_mkfifo(fn, m) C_fix(mkfifo(C_c_string(fn), C_unfix(m)))164#endif165166static C_word C_flock(C_word n, C_word f)167{168 return C_fix(flock(C_unfix(n), C_unfix(f)));169}170171static sigset_t C_sigset;172#define C_sigemptyset(d) (sigemptyset(&C_sigset), C_SCHEME_UNDEFINED)173#define C_sigaddset(s) (sigaddset(&C_sigset, C_unfix(s)), C_SCHEME_UNDEFINED)174#define C_sigdelset(s) (sigdelset(&C_sigset, C_unfix(s)), C_SCHEME_UNDEFINED)175#define C_sigismember(s) C_mk_bool(sigismember(&C_sigset, C_unfix(s)))176#define C_sigprocmask_set(d) C_fix(sigprocmask(SIG_SETMASK, &C_sigset, NULL))177#define C_sigprocmask_block(d) C_fix(sigprocmask(SIG_BLOCK, &C_sigset, NULL))178#define C_sigprocmask_unblock(d) C_fix(sigprocmask(SIG_UNBLOCK, &C_sigset, NULL))179#define C_sigprocmask_get(d) C_fix(sigprocmask(SIG_SETMASK, NULL, &C_sigset))180181#define C_open(fn, fl, m) C_fix(open(C_c_string(fn), C_unfix(fl), C_unfix(m)))182#define C_read(fd, b, n) C_fix(read(C_unfix(fd), C_c_string(b), C_unfix(n)))183#define C_write(fd, b, start, n) C_fix(write(C_unfix(fd), C_c_string(b) + C_unfix(start), C_unfix(n)))184#define C_mkstemp(t) C_fix(mkstemp(C_c_string(t)))185186#define C_ctime(n) (C_secs = (n), ctime(&C_secs))187188#if defined(__SVR4) || defined(C_MACOSX) || defined(__ANDROID__) || defined(_AIX)189/* Seen here: http://lists.samba.org/archive/samba-technical/2002-November/025571.html */190191static time_t C_timegm(struct tm *t)192{193 time_t tl, tb;194 struct tm *tg;195196 tl = mktime (t);197 if (tl == -1)198 {199 t->tm_hour--;200 tl = mktime (t);201 if (tl == -1)202 return -1; /* can't deal with output from strptime */203 tl += 3600;204 }205 tg = gmtime (&tl);206 tg->tm_isdst = 0;207 tb = mktime (tg);208 if (tb == -1)209 {210 tg->tm_hour--;211 tb = mktime (tg);212 if (tb == -1)213 return -1; /* can't deal with output from gmtime */214 tb += 3600;215 }216 return (tl - (tb - tl));217}218#else219#define C_timegm timegm220#endif221222#define C_a_timegm(ptr, c, v, tm) C_int64_to_num(ptr, C_timegm(C_tm_set((v), C_data_pointer(tm))))223224#ifdef __linux__225extern char *strptime(const char *s, const char *format, struct tm *tm);226extern pid_t getpgid(pid_t pid);227#endif228229/* tm_get could be in posix-common, but it's only used in here */230#define cpy_tmstc08_to_tmvec(v, ptm) \231 (C_set_block_item((v), 0, C_fix(((struct tm *)ptm)->tm_sec)), \232 C_set_block_item((v), 1, C_fix((ptm)->tm_min)), \233 C_set_block_item((v), 2, C_fix((ptm)->tm_hour)), \234 C_set_block_item((v), 3, C_fix((ptm)->tm_mday)), \235 C_set_block_item((v), 4, C_fix((ptm)->tm_mon)), \236 C_set_block_item((v), 5, C_fix((ptm)->tm_year)), \237 C_set_block_item((v), 6, C_fix((ptm)->tm_wday)), \238 C_set_block_item((v), 7, C_fix((ptm)->tm_yday)), \239 C_set_block_item((v), 8, ((ptm)->tm_isdst ? C_SCHEME_TRUE : C_SCHEME_FALSE)))240241#define cpy_tmstc9_to_tmvec(v, ptm) \242 (C_set_block_item((v), 9, C_fix(-(ptm)->tm_gmtoff)))243244#define C_tm_get_08(v, tm) cpy_tmstc08_to_tmvec( (v), (tm) )245#define C_tm_get_9(v, tm) cpy_tmstc9_to_tmvec( (v), (tm) )246247static C_word248C_tm_get( C_word v, void *tm )249{250 C_tm_get_08( v, (struct tm *)tm );251#if defined(C_GNU_ENV) && !defined(__CYGWIN__) && !defined(__uClinux__)252 C_tm_get_9( v, (struct tm *)tm );253#endif254 return v;255}256257#define C_strptime(s, f, v, stm) \258 (strptime(C_c_string(s), C_c_string(f), ((struct tm *)(stm))) ? C_tm_get((v), (stm)) : C_SCHEME_FALSE)259260static int set_file_mtime(C_word filename, C_word atime, C_word mtime)261{262 struct stat sb;263 struct utimbuf tb;264 C_word bv = C_block_item(filename, 0);265266 /* Only lstat if needed */267 if (atime == C_SCHEME_FALSE || mtime == C_SCHEME_FALSE) {268 if (lstat(C_c_string(bv), &sb) == -1) return -1;269 }270271 if (atime == C_SCHEME_FALSE) {272 tb.actime = sb.st_atime;273 } else {274 tb.actime = C_num_to_int64(atime);275 }276 if (mtime == C_SCHEME_FALSE) {277 tb.modtime = sb.st_mtime;278 } else {279 tb.modtime = C_num_to_int64(mtime);280 }281 return utime(C_c_string(bv), &tb);282}283284<#285286;; Faster versions of common operations287288(define ##sys#file-nonblocking!289 (foreign-lambda* bool ([int fd])290 "int val = fcntl(fd, F_GETFL, 0);"291 "if(val == -1) C_return(0);"292 "C_return(fcntl(fd, F_SETFL, val | O_NONBLOCK) != -1);" ) )293294(define ##sys#file-select-one (foreign-lambda int "C_check_fd_ready" int) )295296;;; Lo-level I/O:297298(define-foreign-variable _f_dupfd int "F_DUPFD")299(define-foreign-variable _f_getfd int "F_GETFD")300(define-foreign-variable _f_setfd int "F_SETFD")301(define-foreign-variable _f_getfl int "F_GETFL")302(define-foreign-variable _f_setfl int "F_SETFL")303304(set! chicken.file.posix#fcntl/dupfd _f_dupfd)305(set! chicken.file.posix#fcntl/getfd _f_getfd)306(set! chicken.file.posix#fcntl/setfd _f_setfd)307(set! chicken.file.posix#fcntl/getfl _f_getfl)308(set! chicken.file.posix#fcntl/setfl _f_setfl)309310(define-foreign-variable _o_nonblock int "O_NONBLOCK")311(define-foreign-variable _o_noctty int "O_NOCTTY")312(define-foreign-variable _o_fsync int "O_FSYNC")313(define-foreign-variable _o_sync int "O_SYNC")314(set! chicken.file.posix#open/nonblock _o_nonblock)315(set! chicken.file.posix#open/noctty _o_noctty)316(set! chicken.file.posix#open/fsync _o_fsync)317(set! chicken.file.posix#open/sync _o_sync)318319;; Windows-only definitions320(set! chicken.file.posix#open/noinherit 0)321322(set! chicken.process#spawn/overlay 0)323(set! chicken.process#spawn/wait 0)324(set! chicken.process#spawn/nowait 0)325(set! chicken.process#spawn/nowaito 0)326(set! chicken.process#spawn/detach 0)327328(define-foreign-variable _s_isuid int "S_ISUID")329(define-foreign-variable _s_isgid int "S_ISGID")330(define-foreign-variable _s_isvtx int "S_ISVTX")331(set! chicken.file.posix#perm/isvtx _s_isvtx)332(set! chicken.file.posix#perm/isuid _s_isuid)333(set! chicken.file.posix#perm/isgid _s_isgid)334335(set! chicken.file.posix#file-control336 (let ([fcntl (foreign-lambda int fcntl int int long)])337 (lambda (fd cmd #!optional (arg 0))338 (##sys#check-fixnum fd 'file-control)339 (##sys#check-fixnum cmd 'file-control)340 (let ([res (fcntl fd cmd arg)])341 (if (fx= res -1)342 (posix-error #:file-error 'file-control "cannot control file" fd cmd)343 res ) ) ) ) )344345(set! chicken.file.posix#file-open346 (let ((defmode (bitwise-ior _s_irusr _s_iwusr _s_irgrp _s_iwgrp _s_iroth _s_iwoth)))347 (lambda (filename flags . mode)348 (let ([mode (if (pair? mode) (car mode) defmode)])349 (##sys#check-string filename 'file-open)350 (##sys#check-fixnum flags 'file-open)351 (##sys#check-fixnum mode 'file-open)352 (let ([fd (##core#inline "C_open" (##sys#make-c-string filename 'file-open) flags mode)])353 (when (eq? -1 fd)354 (posix-error #:file-error 'file-open "cannot open file" filename flags mode) )355 fd) ) ) ) )356357(set! chicken.file.posix#file-close358 (lambda (fd)359 (##sys#check-fixnum fd 'file-close)360 (let loop ()361 (when (fx< (##core#inline "C_close" fd) 0)362 (cond363 ((fx= _errno _eintr) (##sys#dispatch-interrupt loop))364 (else365 (posix-error #:file-error 'file-close "cannot close file" fd)))))))366367(set! chicken.file.posix#file-read368 (lambda (fd size . buffer)369 (##sys#check-fixnum fd 'file-read)370 (##sys#check-fixnum size 'file-read)371 (let ([buf (if (pair? buffer) (car buffer) (##sys#make-bytevector size))])372 (unless (##core#inline "C_byteblockp" buf)373 (##sys#signal-hook #:type-error 'file-read "bad argument type - not a bytevector" buf) )374 (let ([n (##core#inline "C_read" fd buf size)])375 (when (eq? -1 n)376 (posix-error #:file-error 'file-read "cannot read from file" fd size) )377 (list buf n) ) ) ) )378379(set! chicken.file.posix#file-write380 (lambda (fd buffer . size)381 (##sys#check-fixnum fd 'file-write)382 (unless (##core#inline "C_byteblockp" buffer)383 (##sys#signal-hook #:type-error 'file-write "bad argument type - not a bytevector" buffer) )384 (let ([size (if (pair? size) (car size) (##sys#size buffer))])385 (##sys#check-fixnum size 'file-write)386 (let ([n (##core#inline "C_write" fd buffer 0 size)])387 (when (eq? -1 n)388 (posix-error #:file-error 'file-write "cannot write to file" fd size) )389 n) ) ) )390391(set! chicken.file.posix#file-mkstemp392 (lambda (template)393 (##sys#check-string template 'file-mkstemp)394 (let* ([buf (##sys#make-c-string template 'file-mkstemp)]395 [fd (##core#inline "C_mkstemp" buf)]396 [path-length (string-length buf)])397 (when (eq? -1 fd)398 (posix-error #:file-error 'file-mkstemp "cannot create temporary file" template) )399 (values fd (##sys#substring buf 0 (fx- path-length 1) ) ) ) ) )400401402;;; I/O multiplexing:403404(set! chicken.file.posix#file-select405 (lambda (fdsr fdsw . timeout)406 (let* ((tm (if (pair? timeout) (car timeout) #f))407 (fdsrl (cond ((not fdsr) '())408 ((fixnum? fdsr) (list fdsr))409 (else (##sys#check-list fdsr 'file-select)410 fdsr)))411 (fdswl (cond ((not fdsw) '())412 ((fixnum? fdsw) (list fdsw))413 (else (##sys#check-list fdsw 'file-select)414 fdsw)))415 (nfdsr (##sys#length fdsrl))416 (nfdsw (##sys#length fdswl))417 (nfds (fx+ nfdsr nfdsw))418 (fds-blob (##sys#make-bytevector419 (fx* nfds (foreign-value "sizeof(struct pollfd)" int)))))420 (do ((i 0 (fx+ i 1))421 (fdsrl fdsrl (cdr fdsrl)))422 ((null? fdsrl))423 ((foreign-lambda* void ((int i) (int fd) (scheme-pointer p))424 "struct pollfd *fds = p;"425 "fds[i].fd = fd; fds[i].events = POLLIN;") i (car fdsrl) fds-blob))426 (do ((i nfdsr (fx+ i 1))427 (fdswl fdswl (cdr fdswl)))428 ((null? fdswl))429 ((foreign-lambda* void ((int i) (int fd) (scheme-pointer p))430 "struct pollfd *fds = p;"431 "fds[i].fd = fd; fds[i].events = POLLOUT;") i (car fdswl) fds-blob))432 (let ((n ((foreign-lambda int "poll" scheme-pointer int int)433 fds-blob nfds (if tm (inexact->exact (truncate (* (max 0 tm) 1000))) -1))))434 (cond ((fx< n 0)435 (posix-error #:file-error 'file-select "failed" fdsr fdsw) )436 ((fx= n 0) (values (if (pair? fdsr) '() #f) (if (pair? fdsw) '() #f)))437 (else438 (let ((rl (let lp ((i 0) (res '()) (fds fdsrl))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 & (POLLIN|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 (wl (let lp ((i nfdsr) (res '()) (fds fdswl))447 (cond ((null? fds) (##sys#fast-reverse res))448 (((foreign-lambda* bool ((int i) (scheme-pointer p))449 "struct pollfd *fds = p;"450 "C_return(fds[i].revents & (POLLOUT|POLLERR|POLLHUP|POLLNVAL));")451 i fds-blob)452 (lp (fx+ i 1) (cons (car fds) res) (cdr fds)))453 (else (lp (fx+ i 1) res (cdr fds)))))))454 (values455 (and fdsr (if (fixnum? fdsr) (and (memq fdsr rl) fdsr) rl))456 (and fdsw (if (fixnum? fdsw) (and (memq fdsw wl) fdsw) wl))))))))))457458459;;; Pipe primitive:460461(define-foreign-variable _pipefd0 int "C_pipefds[ 0 ]")462(define-foreign-variable _pipefd1 int "C_pipefds[ 1 ]")463464(set! chicken.process#create-pipe465 (lambda (#!optional mode)466 (when (fx< (##core#inline "C_pipe" #f) 0)467 (posix-error #:file-error 'create-pipe "cannot create pipe") )468 (values _pipefd0 _pipefd1)) )469470471;;; Signal processing:472473(define-foreign-variable _nsig int "NSIG")474(define-foreign-variable _sigterm int "SIGTERM")475(define-foreign-variable _sigkill int "SIGKILL")476(define-foreign-variable _sigint int "SIGINT")477(define-foreign-variable _sighup int "SIGHUP")478(define-foreign-variable _sigfpe int "SIGFPE")479(define-foreign-variable _sigill int "SIGILL")480(define-foreign-variable _sigbus int "SIGBUS")481(define-foreign-variable _sigsegv int "SIGSEGV")482(define-foreign-variable _sigabrt int "SIGABRT")483(define-foreign-variable _sigtrap int "SIGTRAP")484(define-foreign-variable _sigquit int "SIGQUIT")485(define-foreign-variable _sigalrm int "SIGALRM")486(define-foreign-variable _sigpipe int "SIGPIPE")487(define-foreign-variable _sigusr1 int "SIGUSR1")488(define-foreign-variable _sigusr2 int "SIGUSR2")489(define-foreign-variable _sigvtalrm int "SIGVTALRM")490(define-foreign-variable _sigprof int "SIGPROF")491(define-foreign-variable _sigio int "SIGIO")492(define-foreign-variable _sigurg int "SIGURG")493(define-foreign-variable _sigchld int "SIGCHLD")494(define-foreign-variable _sigcont int "SIGCONT")495(define-foreign-variable _sigstop int "SIGSTOP")496(define-foreign-variable _sigtstp int "SIGTSTP")497(define-foreign-variable _sigxcpu int "SIGXCPU")498(define-foreign-variable _sigxfsz int "SIGXFSZ")499(define-foreign-variable _sigwinch int "SIGWINCH")500501(set! chicken.process.signal#signal/term _sigterm)502(set! chicken.process.signal#signal/kill _sigkill)503(set! chicken.process.signal#signal/int _sigint)504(set! chicken.process.signal#signal/hup _sighup)505(set! chicken.process.signal#signal/fpe _sigfpe)506(set! chicken.process.signal#signal/ill _sigill)507(set! chicken.process.signal#signal/segv _sigsegv)508(set! chicken.process.signal#signal/abrt _sigabrt)509(set! chicken.process.signal#signal/trap _sigtrap)510(set! chicken.process.signal#signal/quit _sigquit)511(set! chicken.process.signal#signal/alrm _sigalrm)512(set! chicken.process.signal#signal/vtalrm _sigvtalrm)513(set! chicken.process.signal#signal/prof _sigprof)514(set! chicken.process.signal#signal/io _sigio)515(set! chicken.process.signal#signal/urg _sigurg)516(set! chicken.process.signal#signal/chld _sigchld)517(set! chicken.process.signal#signal/cont _sigcont)518(set! chicken.process.signal#signal/stop _sigstop)519(set! chicken.process.signal#signal/tstp _sigtstp)520(set! chicken.process.signal#signal/pipe _sigpipe)521(set! chicken.process.signal#signal/xcpu _sigxcpu)522(set! chicken.process.signal#signal/xfsz _sigxfsz)523(set! chicken.process.signal#signal/usr1 _sigusr1)524(set! chicken.process.signal#signal/usr2 _sigusr2)525(set! chicken.process.signal#signal/winch _sigwinch)526(set! chicken.process.signal#signal/bus _sigbus)527(set! chicken.process.signal#signal/break 0)528529(set! chicken.process.signal#signals-list530 (list531 chicken.process.signal#signal/term532 chicken.process.signal#signal/kill533 chicken.process.signal#signal/int534 chicken.process.signal#signal/hup535 chicken.process.signal#signal/fpe536 chicken.process.signal#signal/ill537 chicken.process.signal#signal/segv538 chicken.process.signal#signal/abrt539 chicken.process.signal#signal/trap540 chicken.process.signal#signal/quit541 chicken.process.signal#signal/alrm542 chicken.process.signal#signal/vtalrm543 chicken.process.signal#signal/prof544 chicken.process.signal#signal/io545 chicken.process.signal#signal/urg546 chicken.process.signal#signal/chld547 chicken.process.signal#signal/cont548 chicken.process.signal#signal/stop549 chicken.process.signal#signal/tstp550 chicken.process.signal#signal/pipe551 chicken.process.signal#signal/xcpu552 chicken.process.signal#signal/xfsz553 chicken.process.signal#signal/usr1554 chicken.process.signal#signal/usr2555 chicken.process.signal#signal/winch556 chicken.process.signal#signal/bus))557558(set! chicken.process.signal#set-signal-mask!559 (lambda (sigs)560 (##sys#check-list sigs 'set-signal-mask!)561 (##core#inline "C_sigemptyset" 0)562 (for-each563 (lambda (s)564 (##sys#check-fixnum s 'set-signal-mask!)565 (##core#inline "C_sigaddset" s) )566 sigs)567 (when (fx< (##core#inline "C_sigprocmask_set" 0) 0)568 (posix-error #:process-error 'set-signal-mask! "cannot set signal mask") )))569570(define chicken.process.signal#signal-mask571 (getter-with-setter572 (lambda ()573 (##core#inline "C_sigprocmask_get" 0)574 (let loop ((sigs chicken.process.signal#signals-list) (mask '()))575 (if (null? sigs)576 mask577 (let ([sig (car sigs)])578 (loop (cdr sigs)579 (if (##core#inline "C_sigismember" sig) (cons sig mask) mask)) ) ) ) )580 chicken.process.signal#set-signal-mask!581 "(chicken.process.signal#signal-mask)"))582583(set! chicken.process.signal#signal-masked?584 (lambda (sig)585 (##sys#check-fixnum sig 'signal-masked?)586 (##core#inline "C_sigprocmask_get" 0)587 (##core#inline "C_sigismember" sig)) )588589(set! chicken.process.signal#signal-mask!590 (lambda (sig)591 (##sys#check-fixnum sig 'signal-mask!)592 (##core#inline "C_sigemptyset" 0)593 (##core#inline "C_sigaddset" sig)594 (when (fx< (##core#inline "C_sigprocmask_block" 0) 0)595 (posix-error #:process-error 'signal-mask! "cannot block signal") )))596597(set! chicken.process.signal#signal-unmask!598 (lambda (sig)599 (##sys#check-fixnum sig 'signal-unmask!)600 (##core#inline "C_sigemptyset" 0)601 (##core#inline "C_sigaddset" sig)602 (when (fx< (##core#inline "C_sigprocmask_unblock" 0) 0)603 (posix-error #:process-error 'signal-unmask! "cannot unblock signal") )) )604605606;;; Getting group- and user-information:607608(set! chicken.process-context.posix#current-user-id609 (getter-with-setter610 (foreign-lambda int "C_getuid")611 (lambda (id)612 (##sys#check-fixnum id 'current-user-id)613 (when (fx< (##core#inline "C_setuid" id) 0)614 (##sys#error/errno (##sys#update-errno)615 'current-user-id!-setter "cannot set user ID" id)))616 "(chicken.process-context.posix#current-user-id)"))617618(set! chicken.process-context.posix#current-effective-user-id619 (getter-with-setter620 (foreign-lambda int "C_geteuid")621 (lambda (id)622 (##sys#check-fixnum id 'current-effective-user-id)623 (when (fx< (##core#inline "C_seteuid" id) 0)624 (##sys#error/errno (##sys#update-errno)625 'effective-user-id!-setter626 "cannot set effective user ID" id)))627 "(chicken.process-context.posix#current-effective-user-id)"))628629(set! chicken.process-context.posix#current-group-id630 (getter-with-setter631 (foreign-lambda int "C_getgid")632 (lambda (id)633 (##sys#check-fixnum id 'current-group-id)634 (when (fx< (##core#inline "C_setgid" id) 0)635 (##sys#error/errno (##sys#update-errno)636 'current-group-id!-setter "cannot set group ID" id)))637 "(chicken.process-context.posix#current-group-id)") )638639(set! chicken.process-context.posix#current-effective-group-id640 (getter-with-setter641 (foreign-lambda int "C_getegid")642 (lambda (id)643 (##sys#check-fixnum id 'current-effective-group-id)644 (when (fx< (##core#inline "C_setegid" id) 0)645 (##sys#error/errno (##sys#update-errno)646 'effective-group-id!-setter647 "cannot set effective group ID" id)))648 "(chicken.process-context.posix#current-effective-group-id)") )649650(define-foreign-variable _user-name nonnull-c-string "C_user->pw_name")651(define-foreign-variable _user-passwd nonnull-c-string "C_user->pw_passwd")652(define-foreign-variable _user-uid int "C_user->pw_uid")653(define-foreign-variable _user-gid int "C_user->pw_gid")654(define-foreign-variable _user-gecos nonnull-c-string "C_PW_GECOS")655(define-foreign-variable _user-dir c-string "C_user->pw_dir")656(define-foreign-variable _user-shell c-string "C_user->pw_shell")657658(set! chicken.process-context.posix#user-information659 (lambda (user #!optional as-vector)660 (let ([r (if (fixnum? user)661 (##core#inline "C_getpwuid" user)662 (begin663 (##sys#check-string user 'user-information)664 (##core#inline "C_getpwnam" (##sys#make-c-string user 'user-information)) ) ) ] )665 (and r666 ((if as-vector vector list)667 _user-name668 _user-passwd669 _user-uid670 _user-gid671 _user-gecos672 _user-dir673 _user-shell) ) )) )674675(set! chicken.process-context.posix#current-user-name676 (lambda ()677 (car (chicken.process-context.posix#user-information678 (chicken.process-context.posix#current-user-id)))) )679680(set! chicken.process-context.posix#current-effective-user-name681 (lambda ()682 (car (chicken.process-context.posix#user-information683 (chicken.process-context.posix#current-effective-user-id)))) )684685(define chown686 (lambda (loc f uid gid)687 (##sys#check-fixnum uid loc)688 (##sys#check-fixnum gid loc)689 (let ((r (cond690 ((port? f)691 (##core#inline "C_fchown" (chicken.file.posix#port->fileno f) uid gid))692 ((fixnum? f)693 (##core#inline "C_fchown" f uid gid))694 ((string? f)695 (##core#inline "C_chown"696 (##sys#make-c-string f loc) uid gid))697 (else (##sys#signal-hook698 #:type-error loc699 "bad argument type - not a fixnum, port or string" f)))))700 (when (fx< r 0)701 (posix-error #:file-error loc "cannot change file owner" f uid gid) )) ) )702703(set! chicken.process-context.posix#create-session704 (lambda ()705 (let ([a (##core#inline "C_setsid" #f)])706 (when (fx< a 0)707 (##sys#error/errno (##sys#update-errno)708 'create-session "cannot create session"))709 a)) )710711(set! chicken.process-context.posix#process-group-id712 (getter-with-setter713 (lambda (pid)714 (##sys#check-fixnum pid 'process-group-id)715 (let ([a (##core#inline "C_getpgid" pid)])716 (when (fx< a 0)717 (##sys#error/errno (##sys#update-errno)718 'process-group-id719 "cannot retrieve process group ID" pid))720 a))721 (lambda (pid pgid)722 (##sys#check-fixnum pid 'process-group)723 (##sys#check-fixnum pgid 'process-group)724 (when (fx< (##core#inline "C_setpgid" pid pgid) 0)725 (##sys#error/errno (##sys#update-errno)726 'process-group "cannot set process group ID" pid pgid)))727 "(chicken.process-context.posix#process-group-id pid)"))728729730;;; Hard and symbolic links:731732(set! chicken.file.posix#create-symbolic-link733 (lambda (old new)734 (##sys#check-string old 'create-symbolic-link)735 (##sys#check-string new 'create-symbolic-link)736 (when (fx< (##core#inline737 "C_symlink"738 (##sys#make-c-string old 'create-symbolic-link)739 (##sys#make-c-string new 'create-symbolic-link) )740 0)741 (posix-error #:file-error 'create-symbolic-link "cannot create symbolic link" old new) ) ) )742743(define-foreign-variable _filename_max int "FILENAME_MAX")744745(define ##sys#read-symbolic-link746 (let ((buf (##sys#make-bytevector (fx+ _filename_max 1) 0)))747 (lambda (fname location)748 (let ((len (##core#inline749 "C_do_readlink"750 (##sys#make-c-string fname location)751 buf)))752 (if (fx< len 0)753 (posix-error #:file-error location "cannot read symbolic link" fname)754 (##sys#buffer->string buf 0 len))))))755756(set! chicken.file.posix#read-symbolic-link757 (lambda (fname #!optional canonicalize)758 (##sys#check-string fname 'read-symbolic-link)759 (if canonicalize760 (receive (base-origin base-directory directory-components) (decompose-directory fname)761 (let loop ((components directory-components)762 (result (string-append (or base-origin "") (or base-directory ""))))763 (if (null? components)764 result765 (let ((pathname (make-pathname result (car components))))766 (if (##sys#file-exists? pathname #f #f 'read-symbolic-link)767 (loop (cdr components)768 (if (chicken.file.posix#symbolic-link? pathname)769 (let ((target (##sys#read-symbolic-link pathname 'read-symbolic-link)))770 (if (absolute-pathname? target)771 target772 (make-pathname result target)))773 pathname))774 (##sys#signal-hook #:file-error 'read-symbolic-link "could not canonicalize path with symbolic links, component does not exist" pathname))))))775 (##sys#read-symbolic-link fname 'read-symbolic-link))))776777(set! chicken.file.posix#file-link778 (let ((link (foreign-lambda int "link" nonnull-c-string nonnull-c-string)))779 (lambda (old new)780 (##sys#check-string old 'file-link)781 (##sys#check-string new 'file-link)782 (when (fx< (link old new) 0)783 (posix-error #:file-error 'hard-link "could not create hard link" old new) ) ) ) )784785(define-inline (eagain/ewouldblock? e)786 (or (fx= e _ewouldblock)787 (fx= e _eagain)))788789(define ##sys#custom-input-port790 (lambda (loc nam fd #!optional (nonblocking? #f) (bufi 1) (on-close void) (more? #f) enc)791 (when nonblocking? (##sys#file-nonblocking! fd) )792 (let ((bufsiz (if (fixnum? bufi) bufi (##sys#size bufi)))793 (buf (if (fixnum? bufi) (##sys#make-bytevector bufi) bufi))794 (buflen 0)795 (bufpos 0)796 (this-port #f))797 (let ([ready?798 (lambda ()799 (let ((res (##sys#file-select-one fd)))800 (if (fx= -1 res)801 (if (eagain/ewouldblock? _errno)802 #f803 (posix-error #:file-error loc "cannot select" fd nam))804 (fx= 1 res))))]805 [peek806 (lambda ()807 (if (fx>= bufpos buflen)808 #!eof809 (##sys#decode-buffer buf bufpos 1 (##sys#slot this-port 15)810 (lambda (buf start n)811 (##core#inline "C_utf_decode" buf start)))))]812 [fetch813 (lambda ()814 (let loop ()815 (let ([cnt (##core#inline "C_read" fd buf bufsiz)])816 (cond ((fx= cnt -1)817 (cond818 ((eagain/ewouldblock? _errno)819 (##sys#thread-block-for-i/o! ##sys#current-thread fd #:input)820 (##sys#thread-yield!)821 (loop) )822 ((fx= _errno _eintr)823 (##sys#dispatch-interrupt loop))824 (else (posix-error #:file-error loc "cannot read" fd nam) )))825 [(and more? (fx= cnt 0))826 ;; When "more" keep trying, otherwise read once more827 ;; to guard against race conditions828 (if more?829 (begin830 (##sys#thread-yield!)831 (loop) )832 (let ([cnt (##core#inline "C_read" fd buf bufsiz)])833 (when (fx= cnt -1)834 (if (eagain/ewouldblock? _errno)835 (set! cnt 0)836 (posix-error #:file-error loc "cannot read" fd nam) ) )837 (set! buflen cnt)838 (set! bufpos 0) ) )]839 [else840 (set! buflen cnt)841 (set! bufpos 0)]) ) ) )] )842 (let ([the-port843 (make-input-port844 (lambda () ; read-char845 (when (fx>= bufpos buflen)846 (fetch))847 (if (fx>= bufpos buflen)848 #!eof849 (##sys#decode-buffer buf bufpos 1 (##sys#slot this-port 15)850 (lambda (buf start n)851 (set! bufpos (fx+ bufpos n))852 (##core#inline "C_utf_decode" buf start)))))853 (lambda () ; char-ready?854 (or (fx< bufpos buflen)855 (ready?)) )856 (lambda () ; close857 (when (fx< (##core#inline "C_close" fd) 0)858 (posix-error #:file-error loc "cannot close" fd nam))859 (on-close))860 peek-char:861 (lambda () ; peek-char862 (when (fx>= bufpos buflen)863 (fetch))864 (peek) )865 read-bytevector:866 (lambda (port n dest start) ; read-bytevector!867 (let loop ([n (or n (fx- (##sys#size dest) start))]868 [m 0]869 [start start])870 (cond [(eq? 0 n) m]871 [(fx< bufpos buflen)872 (let* ([rest (fx- buflen bufpos)]873 [n2 (if (fx< n rest) n rest)])874 (##core#inline "C_copy_memory_with_offset"875 dest buf start bufpos n2)876 (set! bufpos (fx+ bufpos n2))877 (loop (fx- n n2) (fx+ m n2) (fx+ start n2)) ) ]878 [else879 (fetch)880 (if (eq? 0 buflen)881 m882 (loop n m start) ) ] ) ) )883 read-line:884 (lambda (p limit) ; read-line885 (when (fx>= bufpos buflen)886 (fetch))887 (if (fx>= bufpos buflen)888 #!eof889 (let ((limit (or limit (fx- most-positive-fixnum bufpos))))890 (receive (next line full-line?)891 (##sys#scan-buffer-line892 buf893 (fxmin buflen (fx+ bufpos limit))894 bufpos895 (lambda (pos)896 (let ((nbytes (fx- pos bufpos)))897 (cond ((fx>= nbytes limit)898 (values #f pos #f))899 (else900 (set! limit (fx- limit nbytes))901 (fetch)902 (if (fx< bufpos buflen)903 (values buf bufpos904 (fxmin buflen905 (fx+ bufpos limit)))906 (values #f bufpos #f))))))907 (##sys#slot this-port 15))908 ;; Update row & column position909 (if full-line?910 (begin911 (##sys#setislot p 4 (fx+ (##sys#slot p 4) 1))912 (##sys#setislot p 5 0))913 (##sys#setislot p 5 (fx+ (##sys#slot p 5)914 (string-length line))))915 (set! bufpos next)916 line)) ) )917 read-buffered:918 (lambda (port) ; read-buffered919 (if (fx>= bufpos buflen)920 ""921 (let* ((len (fx- buflen bufpos))922 (str (##sys#buffer->string/encoding buf bufpos len (##sys#slot this-port 15))))923 (set! bufpos buflen)924 str))))])925 (set! this-port the-port)926 (##sys#setslot this-port 3 nam)927 (##sys#setslot this-port 15 enc)928 this-port ) ) ) ) )929930(define ##sys#custom-output-port931 (lambda (loc nam fd #!optional (nonblocking? #f) (bufi 0) (on-close void)932 enc)933 (when nonblocking? (##sys#file-nonblocking! fd) )934 (letrec ((this-port #f)935 (poke936 (lambda (bv start len)937 (let loop ()938 (let ((cnt (##core#inline "C_write" fd bv start len)))939 (cond ((fx= -1 cnt)940 (cond941 ((eagain/ewouldblock? _errno)942 (##sys#thread-yield!)943 (poke bv start len) )944 ((fx= _errno _eintr)945 (##sys#dispatch-interrupt loop))946 (else947 (posix-error loc #:file-error "cannot write" fd nam) ) ) )948 ((fx< cnt len)949 (poke bv (fx+ start cnt) (fx- len cnt)) ) ) ) )))950 (store951 (let ([bufsiz (if (fixnum? bufi) bufi (##sys#size bufi))])952 (if (fx= 0 bufsiz)953 (lambda (str)954 (when str955 (let ((bv (##sys#slot str 0)))956 (poke bv 0 (fx- (##sys#size bv) 1)))))957 (let ((buf (if (fixnum? bufi) (##sys#make-bytevector bufi) bufi))958 (bufpos 0))959 (lambda (str)960 (if str961 (let ((bv (##sys#slot str 0)))962 (let loop ((rem (fx- bufsiz bufpos))963 (start 0)964 (len (fx- (##sys#size bv) 1)))965 (cond ((fx= 0 rem)966 (poke buf 0 bufsiz)967 (set! bufpos 0)968 (loop bufsiz 0 len))969 ((fx< rem len)970 (##core#inline "C_copy_memory_with_offset" buf bv bufpos 0 len)971 (loop 0 rem (fx- len rem)))972 (else973 (##core#inline "C_copy_memory_with_offset" buf bv bufpos start len)974 (set! bufpos (fx+ bufpos len))) ) )975 (when (fx< 0 bufpos)976 (poke buf bufpos) ) ) ) ) ) ))))977 (let ((the-port978 (make-output-port979 (lambda (str) (store str))980 (lambda () ; close981 (when (fx< (##core#inline "C_close" fd) 0)982 (posix-error #:file-error loc "cannot close" fd nam))983 (on-close))984 force-output:985 (lambda () ; flush986 (store #f) ) )) )987 (set! this-port the-port)988 (##sys#setslot this-port 3 nam)989 (##sys#setslot this-port 15 enc)990 this-port ) ) ) )991992993;;; Other file operations:994995(set! chicken.file.posix#file-truncate996 (lambda (fname off)997 (##sys#check-exact-integer off 'file-truncate)998 (when (fx< (cond ((string? fname) (##core#inline "C_truncate" (##sys#make-c-string fname 'file-truncate) off))999 ((port? fname) (##core#inline "C_ftruncate" (chicken.file.posix#port->fileno fname) off))1000 ((fixnum? fname) (##core#inline "C_ftruncate" fname off))1001 (else (##sys#error 'file-truncate "invalid file" fname)))1002 0)1003 (posix-error #:file-error 'file-truncate "cannot truncate file" fname off) ) ) )100410051006;;; File locking:10071008(define-foreign-variable _lock_sh int "LOCK_SH")1009(define-foreign-variable _lock_ex int "LOCK_EX")1010(define-foreign-variable _lock_un int "LOCK_UN")1011(define-foreign-variable _lock_nb int "LOCK_NB")10121013(let ()1014 (define (err msg port loc)1015 (posix-error #:file-error loc msg port) )1016 (define (fileno x loc)1017 (if (port? x)1018 (chicken.file.posix#port->fileno x)1019 (begin1020 (##sys#check-exact-integer x loc)1021 x)))1022 (set! chicken.file.posix#file-lock1023 (lambda (port #!optional shared)1024 (let loop ()1025 (let ((r (##core#inline "C_flock" (fileno port 'file-lock)1026 (##core#inline "C_fixnum_or" _lock_nb (if shared _lock_sh _lock_ex)))))1027 (cond ((eq? r 0) #t)1028 ((fx= _errno _eintr) (loop))1029 ((eagain/ewouldblock? _errno) #f)1030 (else (err "locking file failed" port 'file-lock)))))))1031 (set! chicken.file.posix#file-lock/blocking1032 (lambda (port #!optional shared)1033 (let loop ()1034 (let ((r (##core#inline "C_flock" (fileno port 'file-lock/blocking)1035 (if shared _lock_sh _lock_ex))))1036 (cond ((eq? r 0) #t)1037 ((fx= _errno _eintr) (loop))1038 (else (err "locking file failed" port 'file-lock/blocking)))))))1039 (set! chicken.file.posix#file-unlock1040 (lambda (port)1041 (let loop ()1042 (let ((r (##core#inline "C_flock" (fileno port 'file-unlock) _lock_un)))1043 (cond ((eq? r 0))1044 ((fx= _errno _eintr) (loop))1045 (else (err "unlocking file failed" port 'file-unlock))))))))104610471048;;; FIFOs:10491050(set! chicken.file.posix#create-fifo1051 (lambda (fname . mode)1052 (##sys#check-string fname 'create-fifo)1053 (let ([mode (if (pair? mode) (car mode) (fxior _s_irwxu (fxior _s_irwxg _s_irwxo)))])1054 (##sys#check-fixnum mode 'create-fifo)1055 (when (fx< (##core#inline "C_mkfifo" (##sys#make-c-string fname 'create-fifo) mode) 0)1056 (posix-error #:file-error 'create-fifo "cannot create FIFO" fname mode) ) ) ) )105710581059;;; Time related things:10601061(set! chicken.time.posix#string->time1062 (let ((strptime (foreign-lambda scheme-object "C_strptime" scheme-object scheme-object scheme-object scheme-pointer))1063 (tm-size (foreign-value "sizeof(struct tm)" int)))1064 (lambda (tim #!optional (fmt "%a %b %e %H:%M:%S %Z %Y"))1065 (##sys#check-string tim 'string->time)1066 (##sys#check-string fmt 'string->time)1067 (strptime (##sys#make-c-string tim 'string->time) (##sys#make-c-string fmt) (make-vector 10 #f) (##sys#make-bytevector tm-size 0)) ) ) )10681069(set! chicken.time.posix#utc-time->seconds1070 (let ((tm-size (foreign-value "sizeof(struct tm)" int)))1071 (lambda (tm)1072 (check-time-vector 'utc-time->seconds tm)1073 (let ((t (##core#inline_allocate ("C_a_timegm" 7) tm (##sys#make-bytevector tm-size 0))))1074 (if (= -1 t)1075 (##sys#error 'utc-time->seconds "cannot convert time vector to seconds" tm)1076 t)))))10771078(set! chicken.time.posix#local-timezone-abbreviation1079 (foreign-lambda* c-string ()1080 "\n#if !defined(__CYGWIN__) && !defined(__SVR4) && !defined(__uClinux__) && !defined(__hpux__) && !defined(_AIX)\n"1081 "time_t clock = time(NULL);"1082 "struct tm *ltm = C_localtime(&clock);"1083 "char *z = ltm ? (char *)ltm->tm_zone : 0;"1084 "\n#else\n"1085 "char *z = (daylight ? tzname[1] : tzname[0]);"1086 "\n#endif\n"1087 "C_return(z);") )108810891090;;; Other things:10911092(set! chicken.process.signal#set-alarm!1093 (foreign-lambda int "C_alarm" int))109410951096;;; Process handling:10971098(define c-string->allocated-pointer1099 (foreign-lambda* c-pointer ((scheme-object o))1100 "char *ptr = C_malloc(C_header_size(o)); \n"1101 "if (ptr != NULL) {\n"1102 " C_memcpy(ptr, C_data_pointer(o), C_header_size(o)); \n"1103 "}\n"1104 "C_return(ptr);"))11051106(set! chicken.process#process-fork1107 (let ((fork (foreign-lambda int "C_fork")))1108 (lambda (#!optional thunk killothers)1109 ;; flush all stdio streams before fork1110 ((foreign-lambda int "C_fflush" c-pointer) #f)1111 (let ((pid (fork)))1112 (cond ((fx= -1 pid) ; error1113 (posix-error #:process-error 'process-fork "cannot create child process"))1114 ((fx= 0 pid) ; child process1115 (set! children '())1116 (when killothers1117 (call-with-current-continuation1118 (lambda (continue) (##sys#kill-other-threads (lambda () (continue #f))))))1119 (if thunk1120 (##sys#call-with-cthulhu1121 (lambda ()1122 (thunk)1123 ;; Make sure to run clean up tasks.1124 ;; NOTE: ##sys#call-with-cthulhu will invoke1125 ;; a more low-level runtime C_exit_runtime(0)1126 (exit 0)))1127 #f))1128 (else ; parent process1129 (register-pid pid)))))))11301131(set! chicken.process#process-execute1132 (lambda (filename #!optional (arglist '()) envlist _)1133 (call-with-exec-args1134 'process-execute filename (lambda (x) x) arglist envlist1135 (lambda (prg argbuf envbuf)1136 (let ((r (if envbuf1137 (##core#inline "C_u_i_execve" prg argbuf envbuf)1138 (##core#inline "C_u_i_execvp" prg argbuf))))1139 (when (fx= r -1)1140 (posix-error #:process-error 'process-execute "cannot execute process" filename)))))))11411142(define-foreign-variable _wnohang int "WNOHANG")1143(define-foreign-variable _wait-status int "C_wait_status")11441145(define (process-wait-impl pid nohang)1146 (let* ((res (##core#inline "C_waitpid" pid (if nohang _wnohang 0)))1147 (norm (##core#inline "C_WIFEXITED" _wait-status)) )1148 (if (and (fx= res -1) (fx= _errno _eintr))1149 (##sys#dispatch-interrupt1150 (lambda () (process-wait-impl pid nohang)))1151 (values1152 res1153 norm1154 (cond (norm (##core#inline "C_WEXITSTATUS" _wait-status))1155 ((##core#inline "C_WIFSIGNALED" _wait-status)1156 (##core#inline "C_WTERMSIG" _wait-status))1157 (else (##core#inline "C_WSTOPSIG" _wait-status)) ) )) ) )11581159(set! chicken.process-context.posix#parent-process-id (foreign-lambda int "C_getppid"))11601161(set! chicken.process#process-signal1162 (lambda (id . sig)1163 (let ((sig (if (pair? sig) (car sig) _sigterm))1164 (pid (if (process? id) (process-id id) id)))1165 (##sys#check-fixnum pid 'process-signal)1166 (##sys#check-fixnum sig 'process-signal)1167 (let ((r (##core#inline "C_kill" pid sig)))1168 (when (fx= r -1)1169 (posix-error #:process-error 'process-signal1170 "could not send signal to process" id sig) ) ) ) ) )11711172(define (shell-command loc)1173 (or (get-environment-variable "SHELL") "/bin/sh") )11741175(define (shell-command-arguments cmdlin)1176 (list "-c" cmdlin) )11771178(set! chicken.process#process-run1179 (lambda (f . args)1180 (let ((args (if (pair? args) (car args) #f))1181 (proc (chicken.process#process-fork)) )1182 (cond (proc)1183 (args (chicken.process#process-execute f args))1184 (else1185 (chicken.process#process-execute1186 (shell-command 'process-run)1187 (shell-command-arguments f)) ) ) ) ) )11881189;;; Run subprocess connected with pipes:11901191;; process-impl1192; loc caller procedure symbol1193; cmd pathname or commandline1194; args string-list or '()1195; env string-list or #f1196; stdoutf #f then share, or #t then create1197; stdinf #f then share, or #t then create1198; stderrf #f then share, or #t then create1199;1200; (values stdin-input-port? stdout-output-port? pid stderr-input-port?)1201; where stdin-input-port?, etc. is a port or #f, indicating no port created.12021203(define-constant DEFAULT-INPUT-BUFFER-SIZE 256)1204(define-constant DEFAULT-OUTPUT-BUFFER-SIZE 0)12051206;FIXME process-execute, process-fork don't show parent caller12071208(define process-impl1209 (let ((replace-fd1210 (lambda (loc fd stdfd)1211 (unless (fx= stdfd fd)1212 (chicken.file.posix#duplicate-fileno fd stdfd)1213 (chicken.file.posix#file-close fd) ) )) )1214 (let ((make-on-close1215 (lambda (loc proc clsvec idx idxa idxb)1216 (lambda ()1217 (vector-set! clsvec idx #t)1218 (when (and (vector-ref clsvec idxa) (vector-ref clsvec idxb))1219 (chicken.process#process-wait proc #f) )1220 (void)) ))1221 (needed-pipe1222 (lambda (loc port)1223 (and port1224 (receive (i o) (chicken.process#create-pipe)1225 (cons i o))) ))1226 [connect-parent1227 (lambda (loc pipe port fd)1228 (and port1229 (let ([usefd (car pipe)] [clsfd (cdr pipe)])1230 (chicken.file.posix#file-close clsfd)1231 usefd) ) )]1232 [connect-child1233 (lambda (loc pipe port stdfd)1234 (when port1235 (let ([usefd (car pipe)] [clsfd (cdr pipe)])1236 (chicken.file.posix#file-close clsfd)1237 (replace-fd loc usefd stdfd)) ) )] )1238 (let (1239 (spawn1240 (let ([swapped-ends1241 (lambda (pipe)1242 (and pipe1243 (cons (cdr pipe) (car pipe)) ) )])1244 (lambda (loc cmd args env stdoutf stdinf stderrf)1245 (let ([ipipe (needed-pipe loc stdinf)]1246 [opipe (needed-pipe loc stdoutf)]1247 [epipe (needed-pipe loc stderrf)])1248 (values1249 ipipe (swapped-ends opipe) epipe1250 (chicken.process#process-fork1251 (lambda ()1252 (connect-child loc opipe stdinf chicken.file.posix#fileno/stdin)1253 (connect-child loc (swapped-ends ipipe) stdoutf chicken.file.posix#fileno/stdout)1254 (connect-child loc (swapped-ends epipe) stderrf chicken.file.posix#fileno/stderr)1255 (handle-exceptions ex1256 (begin1257 (print-error-message ex ##sys#standard-error)1258 (##core#inline "C_exit_runtime" 126))1259 (chicken.process#process-execute cmd args env)))) ) ) )))1260 [input-port1261 (lambda (loc cmd pipe stdf stdfd on-close enc)1262 (and-let* ([fd (connect-parent loc pipe stdf stdfd)])1263 (##sys#custom-input-port loc cmd fd #t DEFAULT-INPUT-BUFFER-SIZE on-close #f enc) ) )]1264 [output-port1265 (lambda (loc cmd pipe stdf stdfd on-close enc)1266 (and-let* ([fd (connect-parent loc pipe stdf stdfd)])1267 (##sys#custom-output-port loc cmd fd #t DEFAULT-OUTPUT-BUFFER-SIZE on-close enc) ) )] )1268 (lambda (loc cmd args env stdoutf stdinf stderrf enc)1269 (receive [inpipe outpipe errpipe proc]1270 (spawn loc cmd args env stdoutf stdinf stderrf)1271 ;When shared assume already "closed", since only created ports1272 ;should be explicitly closed, and when one is closed we want1273 ;to wait.1274 (let ((clsvec (vector (not stdinf) (not stdoutf) (not stderrf))))1275 (process-output-port-set! proc1276 (input-port loc cmd inpipe stdinf1277 chicken.file.posix#fileno/stdin1278 (make-on-close loc proc clsvec 0 1 2)1279 enc))1280 (process-input-port-set! proc1281 (output-port loc cmd outpipe stdoutf1282 chicken.file.posix#fileno/stdout1283 (make-on-close loc proc clsvec 1 0 2)1284 enc))1285 (process-error-port-set! proc1286 (input-port loc cmd errpipe stderrf1287 chicken.file.posix#fileno/stderr1288 (make-on-close loc proc clsvec 2 0 1)1289 enc) )1290 proc) ) ) ) ) ) )12911292;;; Run subprocess connected with pipes:12931294;; TODO: See if this can be moved to posix-common1295(let ((%process1296 (lambda (loc err? cmd args env enc)1297 (let ((chkstrlst1298 (lambda (lst)1299 (##sys#check-list lst loc)1300 (for-each (cut ##sys#check-string <> loc) lst) )))1301 (##sys#check-string cmd loc)1302 (if args1303 (chkstrlst args)1304 (begin1305 (set! args (shell-command-arguments cmd))1306 (set! cmd (shell-command loc)) ) )1307 (when env (check-environment-list env loc))1308 (process-impl loc cmd args env #t #t err? enc)))))1309 (set! chicken.process#process1310 (lambda (cmd #!optional args env (enc 'utf-8) exactf)1311 (%process 'process #f cmd args env enc)))1312 (set! chicken.process#process*1313 (lambda (cmd #!optional args env (enc 'utf-8) exactf)1314 (%process 'process* #t cmd args env enc))))131513161317;;; chroot:13181319(set! chicken.process-context.posix#set-root-directory!1320 (let ((chroot (foreign-lambda int "chroot" nonnull-c-string)))1321 (lambda (dir)1322 (##sys#check-string dir 'set-root-directory!)1323 (when (fx< (chroot dir) 0)1324 (posix-error #:file-error 'set-root-directory! "unable to change root directory" dir) ) ) ) )13251326;;; unimplemented stuff:13271328(set!-unimplemented chicken.process#process-spawn)