~ 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 (eq? 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 ((eq? _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 ((eq? 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 'file-link "could not create hard link" old new) ) ) ) )784785(define-inline (eagain/ewouldblock? e)786 (or (eq? e _ewouldblock)787 (eq? 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 (eq? -1 res)801 (if (eagain/ewouldblock? _errno)802 #f803 (posix-error #:file-error loc "cannot select" fd nam))804 (eq? 1 res))))]805 [peek806 (lambda ()807 (if (fx>= bufpos buflen)808 #!eof809 (let ((p bufpos))810 (##sys#read-char/encoding811 this-port (##sys#slot this-port 15)812 (lambda (buf start len dec)813 (dec buf start len814 (lambda (buf start len)815 (set! bufpos p)816 (##core#inline "C_utf_decode" buf start))))))))]817 (fetch818 (lambda ()819 (let loop ()820 (let ((cnt (##core#inline "C_read" fd buf bufsiz)))821 (cond ((eq? cnt -1)822 (cond823 ((eagain/ewouldblock? _errno)824 (##sys#thread-block-for-i/o! ##sys#current-thread fd #:input)825 (##sys#thread-yield!)826 (loop) )827 ((eq? _errno _eintr)828 (##sys#dispatch-interrupt loop))829 (else (posix-error #:file-error loc "cannot read" fd nam) )))830 ((and more? (eq? cnt 0))831 ;; When "more" keep trying, otherwise read once more832 ;; to guard against race conditions833 (if more?834 (begin835 (##sys#thread-yield!)836 (loop) )837 (let ([cnt (##core#inline "C_read" fd buf (fx- bufsiz d))])838 (when (eq? cnt -1)839 (if (eagain/ewouldblock? _errno)840 (set! cnt 0)841 (posix-error #:file-error loc "cannot read" fd nam) ) )842 (set! buflen cnt)843 (set! bufpos 0) ) ))844 (else845 (set! buflen cnt)846 (set! bufpos 0))) ) ))))847 (let ([the-port848 (make-input-port849 (lambda () ; read-char850 (when (fx>= bufpos buflen)851 (fetch))852 (if (fx>= bufpos buflen)853 #!eof854 (##sys#read-char/encoding855 this-port (##sys#slot this-port 15)856 (lambda (buf start len dec)857 (dec buf start len858 (lambda (buf start len)859 (##core#inline "C_utf_decode" buf start)))))))860 (lambda () ; char-ready? (effectively u8-ready?)861 (or (fx< bufpos buflen)862 (ready?)) )863 (lambda () ; close864 (when (fx< (##core#inline "C_close" fd) 0)865 (posix-error #:file-error loc "cannot close" fd nam))866 (on-close))867 peek-char:868 (lambda () ; peek-char869 (when (fx>= bufpos buflen)870 (fetch))871 (peek) )872 read-bytevector:873 (lambda (dest start end) ; read-bytevector!874 (let loop ([n (fx- end start)]875 [m 0]876 [start start])877 (cond [(eq? 0 n) m]878 [(fx< bufpos buflen)879 (let* ([rest (fx- buflen bufpos)]880 [n2 (if (fx< n rest) n rest)])881 (##core#inline "C_copy_memory_with_offset" dest buf start bufpos n2)882 (set! bufpos (fx+ bufpos n2))883 (loop (fx- n n2) (fx+ m n2) (fx+ start n2)) ) ]884 [else885 (fetch)886 (if (eq? 0 buflen)887 m888 (loop n m start) ) ] ) ) )889 read-line:890 (lambda (p limit) ; read-line891 (when (fx>= bufpos buflen) (fetch))892 (if (fx>= bufpos buflen)893 #!eof894 (let ((limit (or limit (fx- most-positive-fixnum bufpos))))895 (receive (next line full-line?)896 (##sys#scan-buffer-line897 buf898 (fxmin buflen (fx+ bufpos limit))899 bufpos900 (lambda (pos)901 (let ((nbytes (fx- pos bufpos)))902 (cond ((fx>= nbytes limit)903 (values #f pos #f))904 (else905 (set! limit (fx- limit nbytes))906 (fetch)907 (if (fx< bufpos buflen)908 (values buf bufpos909 (fxmin buflen910 (fx+ bufpos limit)))911 (values #f bufpos #f))))))912 (##sys#slot this-port 15))913 ;; Update row & column position914 (if full-line?915 (begin916 (##sys#setislot p 4 (fx+ (##sys#slot p 4) 1))917 (##sys#setislot p 5 0))918 (##sys#setislot p 5 (fx+ (##sys#slot p 5)919 (string-length line))))920 (set! bufpos next)921 line)) ) )922 read-buffered:923 (lambda (port) ; read-buffered924 (if (fx>= bufpos buflen)925 ""926 (let* ((len (fx- buflen bufpos))927 (str (##sys#buffer->string/encoding buf bufpos len (##sys#slot this-port 15))))928 (set! bufpos buflen)929 str))))])930 (set! this-port the-port)931 (##sys#setslot this-port 3 nam)932 (##sys#setslot this-port 15 enc)933 this-port ) ) ) ) )934935(define ##sys#custom-output-port936 (lambda (loc nam fd #!optional (nonblocking? #f) (bufi 0) (on-close void)937 enc)938 (when nonblocking? (##sys#file-nonblocking! fd) )939 (letrec ((this-port #f)940 (poke941 (lambda (bv start len)942 (let loop ()943 (let ((cnt (##core#inline "C_write" fd bv start len)))944 (cond ((eq? -1 cnt)945 (cond946 ((eagain/ewouldblock? _errno)947 (##sys#thread-yield!)948 (poke bv start len) )949 ((eq? _errno _eintr)950 (##sys#dispatch-interrupt loop))951 (else952 (posix-error loc #:file-error "cannot write" fd nam) ) ) )953 ((fx< cnt len)954 (poke bv (fx+ start cnt) (fx- len cnt)) ) ) ) )))955 (store956 (let ([bufsiz (if (fixnum? bufi) bufi (##sys#size bufi))])957 (if (eq? 0 bufsiz)958 (lambda (str)959 (when str960 (let ((bv (##sys#slot str 0)))961 (poke bv 0 (fx- (##sys#size bv) 1)))))962 (let ((buf (if (fixnum? bufi) (##sys#make-bytevector bufi) bufi))963 (bufpos 0))964 (lambda (str)965 (if str966 (let ((bv (##sys#slot str 0)))967 (let loop ((rem (fx- bufsiz bufpos))968 (start 0)969 (len (fx- (##sys#size bv) 1)))970 (cond ((eq? 0 rem)971 (poke buf 0 bufsiz)972 (set! bufpos 0)973 (loop bufsiz 0 len))974 ((fx< rem len)975 (##core#inline "C_copy_memory_with_offset" buf bv bufpos 0 len)976 (loop 0 rem (fx- len rem)))977 (else978 (##core#inline "C_copy_memory_with_offset" buf bv bufpos start len)979 (set! bufpos (fx+ bufpos len))) ) )980 (when (fx< 0 bufpos)981 (poke buf bufpos) ) ) ) ) ) ))))982 (let ((the-port983 (make-output-port984 (lambda (str) (store str))985 (lambda () ; close986 (when (fx< (##core#inline "C_close" fd) 0)987 (posix-error #:file-error loc "cannot close" fd nam))988 (on-close))989 force-output:990 (lambda () ; flush991 (store #f) ) )) )992 (set! this-port the-port)993 (##sys#setslot this-port 3 nam)994 (##sys#setslot this-port 15 enc)995 this-port ) ) ) )996997998;;; Other file operations:9991000(set! chicken.file.posix#file-truncate1001 (lambda (fname off)1002 (##sys#check-exact-integer off 'file-truncate)1003 (when (fx< (cond ((string? fname) (##core#inline "C_truncate" (##sys#make-c-string fname 'file-truncate) off))1004 ((port? fname) (##core#inline "C_ftruncate" (chicken.file.posix#port->fileno fname) off))1005 ((fixnum? fname) (##core#inline "C_ftruncate" fname off))1006 (else (##sys#error 'file-truncate "invalid file" fname)))1007 0)1008 (posix-error #:file-error 'file-truncate "cannot truncate file" fname off) ) ) )100910101011;;; File locking:10121013(define-foreign-variable _lock_sh int "LOCK_SH")1014(define-foreign-variable _lock_ex int "LOCK_EX")1015(define-foreign-variable _lock_un int "LOCK_UN")1016(define-foreign-variable _lock_nb int "LOCK_NB")10171018(let ()1019 (define (err msg port loc)1020 (posix-error #:file-error loc msg port) )1021 (define (fileno x loc)1022 (if (port? x)1023 (chicken.file.posix#port->fileno x)1024 (begin1025 (##sys#check-exact-integer x loc)1026 x)))1027 (set! chicken.file.posix#file-lock1028 (lambda (port #!optional shared)1029 (let loop ()1030 (let ((r (##core#inline "C_flock" (fileno port 'file-lock)1031 (##core#inline "C_fixnum_or" _lock_nb (if shared _lock_sh _lock_ex)))))1032 (cond ((eq? r 0) #t)1033 ((eq? _errno _eintr) (loop))1034 ((eagain/ewouldblock? _errno) #f)1035 (else (err "locking file failed" port 'file-lock)))))))1036 (set! chicken.file.posix#file-lock/blocking1037 (lambda (port #!optional shared)1038 (let loop ()1039 (let ((r (##core#inline "C_flock" (fileno port 'file-lock/blocking)1040 (if shared _lock_sh _lock_ex))))1041 (cond ((eq? r 0) #t)1042 ((eq? _errno _eintr) (loop))1043 (else (err "locking file failed" port 'file-lock/blocking)))))))1044 (set! chicken.file.posix#file-unlock1045 (lambda (port)1046 (let loop ()1047 (let ((r (##core#inline "C_flock" (fileno port 'file-unlock) _lock_un)))1048 (cond ((eq? r 0))1049 ((eq? _errno _eintr) (loop))1050 (else (err "unlocking file failed" port 'file-unlock))))))))105110521053;;; FIFOs:10541055(set! chicken.file.posix#create-fifo1056 (lambda (fname . mode)1057 (##sys#check-string fname 'create-fifo)1058 (let ([mode (if (pair? mode) (car mode) (fxior _s_irwxu (fxior _s_irwxg _s_irwxo)))])1059 (##sys#check-fixnum mode 'create-fifo)1060 (when (fx< (##core#inline "C_mkfifo" (##sys#make-c-string fname 'create-fifo) mode) 0)1061 (posix-error #:file-error 'create-fifo "cannot create FIFO" fname mode) ) ) ) )106210631064;;; Time related things:10651066(set! chicken.time.posix#string->time1067 (let ((strptime (foreign-lambda scheme-object "C_strptime" scheme-object scheme-object scheme-object scheme-pointer))1068 (tm-size (foreign-value "sizeof(struct tm)" int)))1069 (lambda (tim #!optional (fmt "%a %b %e %H:%M:%S %Z %Y"))1070 (##sys#check-string tim 'string->time)1071 (##sys#check-string fmt 'string->time)1072 (strptime (##sys#make-c-string tim 'string->time) (##sys#make-c-string fmt) (make-vector 10 #f) (##sys#make-bytevector tm-size 0)) ) ) )10731074(set! chicken.time.posix#utc-time->seconds1075 (let ((tm-size (foreign-value "sizeof(struct tm)" int)))1076 (lambda (tm)1077 (check-time-vector 'utc-time->seconds tm)1078 (let ((t (##core#inline_allocate ("C_a_timegm" 7) tm (##sys#make-bytevector tm-size 0))))1079 (if (= -1 t)1080 (##sys#error 'utc-time->seconds "cannot convert time vector to seconds" tm)1081 t)))))10821083(set! chicken.time.posix#local-timezone-abbreviation1084 (foreign-lambda* c-string ()1085 "\n#if !defined(__CYGWIN__) && !defined(__SVR4) && !defined(__uClinux__) && !defined(__hpux__) && !defined(_AIX)\n"1086 "time_t clock = time(NULL);"1087 "struct tm *ltm = C_localtime(&clock);"1088 "char *z = ltm ? (char *)ltm->tm_zone : 0;"1089 "\n#else\n"1090 "char *z = (daylight ? tzname[1] : tzname[0]);"1091 "\n#endif\n"1092 "C_return(z);") )109310941095;;; Other things:10961097(set! chicken.process.signal#set-alarm!1098 (foreign-lambda int "C_alarm" int))109911001101;;; Process handling:11021103(define c-string->allocated-pointer1104 (foreign-lambda* c-pointer ((scheme-object o))1105 "char *ptr = C_malloc(C_header_size(o)); \n"1106 "if (ptr != NULL) {\n"1107 " C_memcpy(ptr, C_data_pointer(o), C_header_size(o)); \n"1108 "}\n"1109 "C_return(ptr);"))11101111(set! chicken.process#process-fork1112 (let ((fork (foreign-lambda int "C_fork")))1113 (lambda (#!optional thunk killothers)1114 ;; flush all stdio streams before fork1115 ((foreign-lambda int "C_fflush" c-pointer) #f)1116 (let ((pid (fork)))1117 (cond ((eq? -1 pid) ; error1118 (posix-error #:process-error 'process-fork "cannot create child process"))1119 ((eq? 0 pid) ; child process1120 (set! children '())1121 (when killothers1122 (call-with-current-continuation1123 (lambda (continue) (##sys#kill-other-threads (lambda () (continue #f))))))1124 (if thunk1125 (##sys#call-with-cthulhu1126 (lambda ()1127 (thunk)1128 ;; Make sure to run clean up tasks.1129 ;; NOTE: ##sys#call-with-cthulhu will invoke1130 ;; a more low-level runtime C_exit_runtime(0)1131 (exit 0)))1132 #f))1133 (else ; parent process1134 (register-pid pid)))))))11351136(set! chicken.process#process-execute1137 (lambda (filename #!optional (arglist '()) envlist _)1138 (call-with-exec-args1139 'process-execute filename (lambda (x) x) arglist envlist1140 (lambda (prg argbuf envbuf)1141 (let ((r (if envbuf1142 (##core#inline "C_u_i_execve" prg argbuf envbuf)1143 (##core#inline "C_u_i_execvp" prg argbuf))))1144 (when (eq? r -1)1145 (posix-error #:process-error 'process-execute "cannot execute process" filename)))))))11461147(define-foreign-variable _wnohang int "WNOHANG")1148(define-foreign-variable _wait-status int "C_wait_status")11491150(define (process-wait-impl pid nohang)1151 (let* ((res (##core#inline "C_waitpid" pid (if nohang _wnohang 0)))1152 (norm (##core#inline "C_WIFEXITED" _wait-status)) )1153 (if (and (eq? res -1) (eq? _errno _eintr))1154 (##sys#dispatch-interrupt1155 (lambda () (process-wait-impl pid nohang)))1156 (values1157 res1158 norm1159 (cond (norm (##core#inline "C_WEXITSTATUS" _wait-status))1160 ((##core#inline "C_WIFSIGNALED" _wait-status)1161 (##core#inline "C_WTERMSIG" _wait-status))1162 (else (##core#inline "C_WSTOPSIG" _wait-status)) ) )) ) )11631164(set! chicken.process-context.posix#parent-process-id (foreign-lambda int "C_getppid"))11651166(set! chicken.process#process-signal1167 (lambda (id . sig)1168 (let ((sig (if (pair? sig) (car sig) _sigterm))1169 (pid (if (process? id) (process-id id) id)))1170 (##sys#check-fixnum pid 'process-signal)1171 (##sys#check-fixnum sig 'process-signal)1172 (let ((r (##core#inline "C_kill" pid sig)))1173 (when (eq? r -1)1174 (posix-error #:process-error 'process-signal1175 "could not send signal to process" id sig) ) ) ) ) )11761177(define (shell-command loc)1178 (or (get-environment-variable "SHELL") "/bin/sh") )11791180(define (shell-command-arguments cmdlin)1181 (list "-c" cmdlin) )11821183(set! chicken.process#process-run1184 (lambda (f . args)1185 (let ((args (if (pair? args) (car args) #f))1186 (proc (chicken.process#process-fork)) )1187 (cond (proc)1188 (args (chicken.process#process-execute f args))1189 (else1190 (chicken.process#process-execute1191 (shell-command 'process-run)1192 (shell-command-arguments f)) ) ) ) ) )11931194;;; Run subprocess connected with pipes:11951196;; process-impl1197; loc caller procedure symbol1198; cmd pathname or commandline1199; args string-list or '()1200; env string-list or #f1201; stdoutf #f then share, or #t then create1202; stdinf #f then share, or #t then create1203; stderrf #f then share, or #t then create1204;1205; (values stdin-input-port? stdout-output-port? pid stderr-input-port?)1206; where stdin-input-port?, etc. is a port or #f, indicating no port created.12071208(define-constant DEFAULT-INPUT-BUFFER-SIZE 256)1209(define-constant DEFAULT-OUTPUT-BUFFER-SIZE 0)12101211;FIXME process-execute, process-fork don't show parent caller12121213(define process-impl1214 (let ((replace-fd1215 (lambda (loc fd stdfd)1216 (unless (eq? stdfd fd)1217 (chicken.file.posix#duplicate-fileno fd stdfd)1218 (chicken.file.posix#file-close fd) ) )) )1219 (let ((make-on-close1220 (lambda (loc proc clsvec idx idxa idxb)1221 (lambda ()1222 (vector-set! clsvec idx #t)1223 (when (and (vector-ref clsvec idxa) (vector-ref clsvec idxb))1224 (chicken.process#process-wait proc #f) )1225 (void)) ))1226 (needed-pipe1227 (lambda (loc port)1228 (and port1229 (receive (i o) (chicken.process#create-pipe)1230 (cons i o))) ))1231 [connect-parent1232 (lambda (loc pipe port fd)1233 (and port1234 (let ([usefd (car pipe)] [clsfd (cdr pipe)])1235 (chicken.file.posix#file-close clsfd)1236 usefd) ) )]1237 [connect-child1238 (lambda (loc pipe port stdfd)1239 (when port1240 (let ([usefd (car pipe)] [clsfd (cdr pipe)])1241 (chicken.file.posix#file-close clsfd)1242 (replace-fd loc usefd stdfd)) ) )] )1243 (let (1244 (spawn1245 (let ([swapped-ends1246 (lambda (pipe)1247 (and pipe1248 (cons (cdr pipe) (car pipe)) ) )])1249 (lambda (loc cmd args env stdoutf stdinf stderrf)1250 (let ([ipipe (needed-pipe loc stdinf)]1251 [opipe (needed-pipe loc stdoutf)]1252 [epipe (needed-pipe loc stderrf)])1253 (values1254 ipipe (swapped-ends opipe) epipe1255 (chicken.process#process-fork1256 (lambda ()1257 (connect-child loc opipe stdinf chicken.file.posix#fileno/stdin)1258 (connect-child loc (swapped-ends ipipe) stdoutf chicken.file.posix#fileno/stdout)1259 (connect-child loc (swapped-ends epipe) stderrf chicken.file.posix#fileno/stderr)1260 (handle-exceptions ex1261 (begin1262 (print-error-message ex ##sys#standard-error)1263 (##core#inline "C_exit_runtime" 126))1264 (chicken.process#process-execute cmd args env)))) ) ) )))1265 [input-port1266 (lambda (loc cmd pipe stdf stdfd on-close enc)1267 (and-let* ([fd (connect-parent loc pipe stdf stdfd)])1268 (##sys#custom-input-port loc cmd fd #t DEFAULT-INPUT-BUFFER-SIZE on-close #f enc) ) )]1269 [output-port1270 (lambda (loc cmd pipe stdf stdfd on-close enc)1271 (and-let* ([fd (connect-parent loc pipe stdf stdfd)])1272 (##sys#custom-output-port loc cmd fd #t DEFAULT-OUTPUT-BUFFER-SIZE on-close enc) ) )] )1273 (lambda (loc cmd args env stdoutf stdinf stderrf enc)1274 (receive [inpipe outpipe errpipe proc]1275 (spawn loc cmd args env stdoutf stdinf stderrf)1276 ;When shared assume already "closed", since only created ports1277 ;should be explicitly closed, and when one is closed we want1278 ;to wait.1279 (let ((clsvec (vector (not stdinf) (not stdoutf) (not stderrf))))1280 (process-output-port-set! proc1281 (input-port loc cmd inpipe stdinf1282 chicken.file.posix#fileno/stdin1283 (make-on-close loc proc clsvec 0 1 2)1284 enc))1285 (process-input-port-set! proc1286 (output-port loc cmd outpipe stdoutf1287 chicken.file.posix#fileno/stdout1288 (make-on-close loc proc clsvec 1 0 2)1289 enc))1290 (process-error-port-set! proc1291 (input-port loc cmd errpipe stderrf1292 chicken.file.posix#fileno/stderr1293 (make-on-close loc proc clsvec 2 0 1)1294 enc) )1295 proc) ) ) ) ) ) )12961297;;; Run subprocess connected with pipes:12981299;; TODO: See if this can be moved to posix-common1300(let ((%process1301 (lambda (loc err? cmd args env enc)1302 (let ((chkstrlst1303 (lambda (lst)1304 (##sys#check-list lst loc)1305 (for-each (cut ##sys#check-string <> loc) lst) )))1306 (##sys#check-string cmd loc)1307 (if args1308 (chkstrlst args)1309 (begin1310 (set! args (shell-command-arguments cmd))1311 (set! cmd (shell-command loc)) ) )1312 (when env (check-environment-list env loc))1313 (process-impl loc cmd args env #t #t err? enc)))))1314 (set! chicken.process#process1315 (lambda (cmd #!optional args env (enc 'utf-8) exactf)1316 (%process 'process #f cmd args env enc)))1317 (set! chicken.process#process*1318 (lambda (cmd #!optional args env (enc 'utf-8) exactf)1319 (%process 'process* #t cmd args env enc))))132013211322;;; chroot:13231324(set! chicken.process-context.posix#set-root-directory!1325 (let ((chroot (foreign-lambda int "chroot" nonnull-c-string)))1326 (lambda (dir)1327 (##sys#check-string dir 'set-root-directory!)1328 (when (fx< (chroot dir) 0)1329 (posix-error #:file-error 'set-root-directory! "unable to change root directory" dir) ) ) ) )13301331;;; unimplemented stuff:13321333(set!-unimplemented chicken.process#process-spawn)