~ chicken-core (master) /posixunix.scm
Trap1;;;; posixunix.scm - Miscellaneous file- and process-handling routines2;3; Copyright (c) 2008-2022, The CHICKEN Team4; Copyright (c) 2000-2007, Felix L. Winkelmann5; All rights reserved.6;7; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following8; conditions are met:9;10; Redistributions of source code must retain the above copyright notice, this list of conditions and the following11; disclaimer.12; Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following13; disclaimer in the documentation and/or other materials provided with the distribution.14; Neither the name of the author nor the names of its contributors may be used to endorse or promote15; products derived from this software without specific prior written permission.16;17; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS18; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY19; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR20; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR21; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR22; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY23; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR24; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE25; POSSIBILITY OF SUCH DAMAGE.262728;; these are not available on Windows2930(define-foreign-variable _stat_st_blksize unsigned-int "C_statbuf.st_blksize")31(define-foreign-variable _stat_st_blocks unsigned-int "C_statbuf.st_blocks")3233(include "posix-common.scm")3435#>3637static int C_wait_status;3839#include <sys/time.h>40#include <sys/wait.h>41#include <sys/ioctl.h>42#include <fcntl.h>43#include <dirent.h>44#include <pwd.h>45#include <utime.h>4647#if defined(__sun) && defined(__SVR4)48# include <sys/tty.h>49# include <termios.h>50#endif5152#ifdef __linux__53# include <sys/file.h>54#endif5556#include <sys/mman.h>57#include <poll.h>5859#ifndef O_FSYNC60# define O_FSYNC O_SYNC61#endif6263#ifndef PIPE_BUF64# ifdef __CYGWIN__65# define PIPE_BUF _POSIX_PIPE_BUF66# else67# define PIPE_BUF 102468# endif69#endif7071#ifndef O_BINARY72# define O_BINARY 073#endif74#ifndef O_TEXT75# define O_TEXT 076#endif7778#ifndef MAP_FILE79# define MAP_FILE 080#endif8182#ifndef MAP_ANON83# define MAP_ANON 084#endif8586#ifndef FILENAME_MAX87# define FILENAME_MAX 102488#endif8990static DIR *temphandle;91static struct passwd *C_user;9293/* Android doesn't provide pw_gecos in the passwd struct */94#ifdef __ANDROID__95# define C_PW_GECOS ("")96#else97# define C_PW_GECOS (C_user->pw_gecos)98#endif99100static int C_pipefds[ 2 ];101static time_t C_secs;102static struct timeval C_timeval;103static struct stat C_statbuf;104105#define C_fchdir(fd) C_fix(fchdir(C_unfix(fd)))106107#define open_binary_input_pipe(a, n, name) C_mpointer(a, popen(C_c_string(name), "r"))108#define open_text_input_pipe(a, n, name) open_binary_input_pipe(a, n, name)109#define open_binary_output_pipe(a, n, name) C_mpointer(a, popen(C_c_string(name), "w"))110#define open_text_output_pipe(a, n, name) open_binary_output_pipe(a, n, name)111#define close_pipe(p) C_fix(pclose(C_port_file(p)))112113#define C_fork fork114#define C_waitpid(id, o) C_fix(waitpid(C_unfix(id), &C_wait_status, C_unfix(o)))115#define C_getppid getppid116#define C_kill(id, s) C_fix(kill(C_unfix(id), C_unfix(s)))117#define C_getuid getuid118#define C_getgid getgid119#define C_geteuid geteuid120#define C_getegid getegid121#define C_chown(fn, u, g) C_fix(chown(C_c_string(fn), C_unfix(u), C_unfix(g)))122#define C_fchown(fd, u, g) C_fix(fchown(C_unfix(fd), C_unfix(u), C_unfix(g)))123#define C_chmod(fn, m) C_fix(chmod(C_c_string(fn), C_unfix(m)))124#define C_fchmod(fd, m) C_fix(fchmod(C_unfix(fd), C_unfix(m)))125#define C_setuid(id) C_fix(setuid(C_unfix(id)))126#define C_setgid(id) C_fix(setgid(C_unfix(id)))127#define C_seteuid(id) C_fix(seteuid(C_unfix(id)))128#define C_setegid(id) C_fix(setegid(C_unfix(id)))129#define C_setsid(dummy) C_fix(setsid())130#define C_setpgid(x, y) C_fix(setpgid(C_unfix(x), C_unfix(y)))131#define C_getpgid(x) C_fix(getpgid(C_unfix(x)))132#define C_symlink(o, n) C_fix(symlink(C_c_string(o), C_c_string(n)))133#define C_do_readlink(f, b) C_fix(readlink(C_c_string(f), C_c_string(b), FILENAME_MAX))134#define C_getpwnam(n) C_mk_bool((C_user = getpwnam(C_c_string(n))) != NULL)135#define C_getpwuid(u) C_mk_bool((C_user = getpwuid(C_unfix(u))) != NULL)136#define C_pipe(d) C_fix(pipe(C_pipefds))137#define C_truncate(f, n) C_fix(truncate(C_c_string(f), C_num_to_int(n)))138#define C_ftruncate(f, n) C_fix(ftruncate(C_unfix(f), C_num_to_int(n)))139#define C_alarm alarm140#define C_close(fd) C_fix(close(C_unfix(fd)))141#define C_umask(m) C_fix(umask(C_unfix(m)))142143#define C_u_i_lstat(fn) C_fix(lstat(C_c_string(fn), &C_statbuf))144145#define C_u_i_execvp(f,a) C_fix(execvp(C_c_string(f), (char *const *)C_c_pointer_vector_or_null(a)))146#define C_u_i_execve(f,a,e) C_fix(execve(C_c_string(f), (char *const *)C_c_pointer_vector_or_null(a), (char *const *)C_c_pointer_vector_or_null(e)))147148static int C_uw;149#define C_WIFEXITED(n) (C_uw = C_unfix(n), C_mk_bool(WIFEXITED(C_uw)))150#define C_WIFSIGNALED(n) (C_uw = C_unfix(n), C_mk_bool(WIFSIGNALED(C_uw)))151#define C_WIFSTOPPED(n) (C_uw = C_unfix(n), C_mk_bool(WIFSTOPPED(C_uw)))152#define C_WEXITSTATUS(n) (C_uw = C_unfix(n), C_fix(WEXITSTATUS(C_uw)))153#define C_WTERMSIG(n) (C_uw = C_unfix(n), C_fix(WTERMSIG(C_uw)))154#define C_WSTOPSIG(n) (C_uw = C_unfix(n), C_fix(WSTOPSIG(C_uw)))155156#ifdef __CYGWIN__157# define C_mkfifo(fn, m) C_fix(-1)158#else159# define C_mkfifo(fn, m) C_fix(mkfifo(C_c_string(fn), C_unfix(m)))160#endif161162static C_word C_flock(C_word n, C_word f)163{164 return C_fix(flock(C_unfix(n), C_unfix(f)));165}166167static sigset_t C_sigset;168#define C_sigemptyset(d) (sigemptyset(&C_sigset), C_SCHEME_UNDEFINED)169#define C_sigaddset(s) (sigaddset(&C_sigset, C_unfix(s)), C_SCHEME_UNDEFINED)170#define C_sigdelset(s) (sigdelset(&C_sigset, C_unfix(s)), C_SCHEME_UNDEFINED)171#define C_sigismember(s) C_mk_bool(sigismember(&C_sigset, C_unfix(s)))172#define C_sigprocmask_set(d) C_fix(sigprocmask(SIG_SETMASK, &C_sigset, NULL))173#define C_sigprocmask_block(d) C_fix(sigprocmask(SIG_BLOCK, &C_sigset, NULL))174#define C_sigprocmask_unblock(d) C_fix(sigprocmask(SIG_UNBLOCK, &C_sigset, NULL))175#define C_sigprocmask_get(d) C_fix(sigprocmask(SIG_SETMASK, NULL, &C_sigset))176177#define C_open(fn, fl, m) C_fix(open(C_c_string(fn), C_unfix(fl), C_unfix(m)))178#define C_read(fd, b, n) C_fix(read(C_unfix(fd), C_c_string(b), C_unfix(n)))179#define C_write(fd, b, start, n) C_fix(write(C_unfix(fd), C_c_string(b) + C_unfix(start), C_unfix(n)))180#define C_mkstemp(t) C_fix(mkstemp(C_c_string(t)))181182#define C_ctime(n) (C_secs = (n), ctime(&C_secs))183184#if defined(__SVR4) || defined(C_MACOSX) || defined(__ANDROID__) || defined(_AIX)185/* Seen here: http://lists.samba.org/archive/samba-technical/2002-November/025571.html */186187static time_t C_timegm(struct tm *t)188{189 time_t tl, tb;190 struct tm *tg;191192 tl = mktime (t);193 if (tl == -1)194 {195 t->tm_hour--;196 tl = mktime (t);197 if (tl == -1)198 return -1; /* can't deal with output from strptime */199 tl += 3600;200 }201 tg = gmtime (&tl);202 tg->tm_isdst = 0;203 tb = mktime (tg);204 if (tb == -1)205 {206 tg->tm_hour--;207 tb = mktime (tg);208 if (tb == -1)209 return -1; /* can't deal with output from gmtime */210 tb += 3600;211 }212 return (tl - (tb - tl));213}214#else215#define C_timegm timegm216#endif217218#define C_a_timegm(ptr, c, v, tm) C_int64_to_num(ptr, C_timegm(C_tm_set((v), C_data_pointer(tm))))219220#ifdef __linux__221extern char *strptime(const char *s, const char *format, struct tm *tm);222extern pid_t getpgid(pid_t pid);223#endif224225/* tm_get could be in posix-common, but it's only used in here */226#define cpy_tmstc08_to_tmvec(v, ptm) \227 (C_set_block_item((v), 0, C_fix(((struct tm *)ptm)->tm_sec)), \228 C_set_block_item((v), 1, C_fix((ptm)->tm_min)), \229 C_set_block_item((v), 2, C_fix((ptm)->tm_hour)), \230 C_set_block_item((v), 3, C_fix((ptm)->tm_mday)), \231 C_set_block_item((v), 4, C_fix((ptm)->tm_mon)), \232 C_set_block_item((v), 5, C_fix((ptm)->tm_year)), \233 C_set_block_item((v), 6, C_fix((ptm)->tm_wday)), \234 C_set_block_item((v), 7, C_fix((ptm)->tm_yday)), \235 C_set_block_item((v), 8, ((ptm)->tm_isdst ? C_SCHEME_TRUE : C_SCHEME_FALSE)))236237#define cpy_tmstc9_to_tmvec(v, ptm) \238 (C_set_block_item((v), 9, C_fix(-(ptm)->tm_gmtoff)))239240#define C_tm_get_08(v, tm) cpy_tmstc08_to_tmvec( (v), (tm) )241#define C_tm_get_9(v, tm) cpy_tmstc9_to_tmvec( (v), (tm) )242243static C_word244C_tm_get( C_word v, void *tm )245{246 C_tm_get_08( v, (struct tm *)tm );247#if defined(C_GNU_ENV) && !defined(__CYGWIN__) && !defined(__uClinux__)248 C_tm_get_9( v, (struct tm *)tm );249#endif250 return v;251}252253#define C_strptime(s, f, v, stm) \254 (strptime(C_c_string(s), C_c_string(f), ((struct tm *)(stm))) ? C_tm_get((v), (stm)) : C_SCHEME_FALSE)255256static int set_file_mtime(C_word filename, C_word atime, C_word mtime)257{258 struct stat sb;259 struct utimbuf tb;260 C_word bv = C_block_item(filename, 0);261262 /* Only lstat if needed */263 if (atime == C_SCHEME_FALSE || mtime == C_SCHEME_FALSE) {264 if (lstat(C_c_string(bv), &sb) == -1) return -1;265 }266267 if (atime == C_SCHEME_FALSE) {268 tb.actime = sb.st_atime;269 } else {270 tb.actime = C_num_to_int64(atime);271 }272 if (mtime == C_SCHEME_FALSE) {273 tb.modtime = sb.st_mtime;274 } else {275 tb.modtime = C_num_to_int64(mtime);276 }277 return utime(C_c_string(bv), &tb);278}279280<#281282;; Faster versions of common operations283284(define ##sys#file-nonblocking!285 (foreign-lambda* bool ([int fd])286 "int val = fcntl(fd, F_GETFL, 0);"287 "if(val == -1) C_return(0);"288 "C_return(fcntl(fd, F_SETFL, val | O_NONBLOCK) != -1);" ) )289290(define ##sys#file-select-one (foreign-lambda int "C_check_fd_ready" int) )291292;;; Lo-level I/O:293294(define-foreign-variable _f_dupfd int "F_DUPFD")295(define-foreign-variable _f_getfd int "F_GETFD")296(define-foreign-variable _f_setfd int "F_SETFD")297(define-foreign-variable _f_getfl int "F_GETFL")298(define-foreign-variable _f_setfl int "F_SETFL")299300(set! chicken.file.posix#fcntl/dupfd _f_dupfd)301(set! chicken.file.posix#fcntl/getfd _f_getfd)302(set! chicken.file.posix#fcntl/setfd _f_setfd)303(set! chicken.file.posix#fcntl/getfl _f_getfl)304(set! chicken.file.posix#fcntl/setfl _f_setfl)305306(define-foreign-variable _o_nonblock int "O_NONBLOCK")307(define-foreign-variable _o_noctty int "O_NOCTTY")308(define-foreign-variable _o_fsync int "O_FSYNC")309(define-foreign-variable _o_sync int "O_SYNC")310(set! chicken.file.posix#open/nonblock _o_nonblock)311(set! chicken.file.posix#open/noctty _o_noctty)312(set! chicken.file.posix#open/fsync _o_fsync)313(set! chicken.file.posix#open/sync _o_sync)314315;; Windows-only definitions316(set! chicken.file.posix#open/noinherit 0)317318(set! chicken.process#spawn/overlay 0)319(set! chicken.process#spawn/wait 0)320(set! chicken.process#spawn/nowait 0)321(set! chicken.process#spawn/nowaito 0)322(set! chicken.process#spawn/detach 0)323324(define-foreign-variable _s_isuid int "S_ISUID")325(define-foreign-variable _s_isgid int "S_ISGID")326(define-foreign-variable _s_isvtx int "S_ISVTX")327(set! chicken.file.posix#perm/isvtx _s_isvtx)328(set! chicken.file.posix#perm/isuid _s_isuid)329(set! chicken.file.posix#perm/isgid _s_isgid)330331(set! chicken.file.posix#file-control332 (let ([fcntl (foreign-lambda int fcntl int int long)])333 (lambda (fd cmd #!optional (arg 0))334 (##sys#check-fixnum fd 'file-control)335 (##sys#check-fixnum cmd 'file-control)336 (let ([res (fcntl fd cmd arg)])337 (if (fx= res -1)338 (posix-error #:file-error 'file-control "cannot control file" fd cmd)339 res ) ) ) ) )340341(set! chicken.file.posix#file-open342 (let ((defmode (bitwise-ior _s_irusr _s_iwusr _s_irgrp _s_iwgrp _s_iroth _s_iwoth)))343 (lambda (filename flags . mode)344 (let ([mode (if (pair? mode) (car mode) defmode)])345 (##sys#check-string filename 'file-open)346 (##sys#check-fixnum flags 'file-open)347 (##sys#check-fixnum mode 'file-open)348 (let ([fd (##core#inline "C_open" (##sys#make-c-string filename 'file-open) flags mode)])349 (when (eq? -1 fd)350 (posix-error #:file-error 'file-open "cannot open file" filename flags mode) )351 fd) ) ) ) )352353(set! chicken.file.posix#file-close354 (lambda (fd)355 (##sys#check-fixnum fd 'file-close)356 (let loop ()357 (when (fx< (##core#inline "C_close" fd) 0)358 (cond359 ((fx= _errno _eintr) (##sys#dispatch-interrupt loop))360 (else361 (posix-error #:file-error 'file-close "cannot close file" fd)))))))362363(set! chicken.file.posix#file-read364 (lambda (fd size . buffer)365 (##sys#check-fixnum fd 'file-read)366 (##sys#check-fixnum size 'file-read)367 (let ([buf (if (pair? buffer) (car buffer) (##sys#make-bytevector size))])368 (unless (##core#inline "C_byteblockp" buf)369 (##sys#signal-hook #:type-error 'file-read "bad argument type - not a bytevector" buf) )370 (let ([n (##core#inline "C_read" fd buf size)])371 (when (eq? -1 n)372 (posix-error #:file-error 'file-read "cannot read from file" fd size) )373 (list buf n) ) ) ) )374375(set! chicken.file.posix#file-write376 (lambda (fd buffer . size)377 (##sys#check-fixnum fd 'file-write)378 (unless (##core#inline "C_byteblockp" buffer)379 (##sys#signal-hook #:type-error 'file-write "bad argument type - not a bytevector" buffer) )380 (let ([size (if (pair? size) (car size) (##sys#size buffer))])381 (##sys#check-fixnum size 'file-write)382 (let ([n (##core#inline "C_write" fd buffer 0 size)])383 (when (eq? -1 n)384 (posix-error #:file-error 'file-write "cannot write to file" fd size) )385 n) ) ) )386387(set! chicken.file.posix#file-mkstemp388 (lambda (template)389 (##sys#check-string template 'file-mkstemp)390 (let* ([buf (##sys#make-c-string template 'file-mkstemp)]391 [fd (##core#inline "C_mkstemp" buf)]392 [path-length (string-length buf)])393 (when (eq? -1 fd)394 (posix-error #:file-error 'file-mkstemp "cannot create temporary file" template) )395 (values fd (##sys#substring buf 0 (fx- path-length 1) ) ) ) ) )396397398;;; I/O multiplexing:399400(set! chicken.file.posix#file-select401 (lambda (fdsr fdsw . timeout)402 (let* ((tm (if (pair? timeout) (car timeout) #f))403 (fdsrl (cond ((not fdsr) '())404 ((fixnum? fdsr) (list fdsr))405 (else (##sys#check-list fdsr 'file-select)406 fdsr)))407 (fdswl (cond ((not fdsw) '())408 ((fixnum? fdsw) (list fdsw))409 (else (##sys#check-list fdsw 'file-select)410 fdsw)))411 (nfdsr (##sys#length fdsrl))412 (nfdsw (##sys#length fdswl))413 (nfds (fx+ nfdsr nfdsw))414 (fds-blob (##sys#make-bytevector415 (fx* nfds (foreign-value "sizeof(struct pollfd)" int)))))416 (do ((i 0 (fx+ i 1))417 (fdsrl fdsrl (cdr fdsrl)))418 ((null? fdsrl))419 ((foreign-lambda* void ((int i) (int fd) (scheme-pointer p))420 "struct pollfd *fds = p;"421 "fds[i].fd = fd; fds[i].events = POLLIN;") i (car fdsrl) fds-blob))422 (do ((i nfdsr (fx+ i 1))423 (fdswl fdswl (cdr fdswl)))424 ((null? fdswl))425 ((foreign-lambda* void ((int i) (int fd) (scheme-pointer p))426 "struct pollfd *fds = p;"427 "fds[i].fd = fd; fds[i].events = POLLOUT;") i (car fdswl) fds-blob))428 (let ((n ((foreign-lambda int "poll" scheme-pointer int int)429 fds-blob nfds (if tm (inexact->exact (truncate (* (max 0 tm) 1000))) -1))))430 (cond ((fx< n 0)431 (posix-error #:file-error 'file-select "failed" fdsr fdsw) )432 ((fx= n 0) (values (if (pair? fdsr) '() #f) (if (pair? fdsw) '() #f)))433 (else434 (let ((rl (let lp ((i 0) (res '()) (fds fdsrl))435 (cond ((null? fds) (##sys#fast-reverse res))436 (((foreign-lambda* bool ((int i) (scheme-pointer p))437 "struct pollfd *fds = p;"438 "C_return(fds[i].revents & (POLLIN|POLLERR|POLLHUP|POLLNVAL));")439 i fds-blob)440 (lp (fx+ i 1) (cons (car fds) res) (cdr fds)))441 (else (lp (fx+ i 1) res (cdr fds))))))442 (wl (let lp ((i nfdsr) (res '()) (fds fdswl))443 (cond ((null? fds) (##sys#fast-reverse res))444 (((foreign-lambda* bool ((int i) (scheme-pointer p))445 "struct pollfd *fds = p;"446 "C_return(fds[i].revents & (POLLOUT|POLLERR|POLLHUP|POLLNVAL));")447 i fds-blob)448 (lp (fx+ i 1) (cons (car fds) res) (cdr fds)))449 (else (lp (fx+ i 1) res (cdr fds)))))))450 (values451 (and fdsr (if (fixnum? fdsr) (and (memq fdsr rl) fdsr) rl))452 (and fdsw (if (fixnum? fdsw) (and (memq fdsw wl) fdsw) wl))))))))))453454455;;; Pipe primitive:456457(define-foreign-variable _pipefd0 int "C_pipefds[ 0 ]")458(define-foreign-variable _pipefd1 int "C_pipefds[ 1 ]")459460(set! chicken.process#create-pipe461 (lambda (#!optional mode)462 (when (fx< (##core#inline "C_pipe" #f) 0)463 (posix-error #:file-error 'create-pipe "cannot create pipe") )464 (values _pipefd0 _pipefd1)) )465466467;;; Signal processing:468469(define-foreign-variable _nsig int "NSIG")470(define-foreign-variable _sigterm int "SIGTERM")471(define-foreign-variable _sigkill int "SIGKILL")472(define-foreign-variable _sigint int "SIGINT")473(define-foreign-variable _sighup int "SIGHUP")474(define-foreign-variable _sigfpe int "SIGFPE")475(define-foreign-variable _sigill int "SIGILL")476(define-foreign-variable _sigbus int "SIGBUS")477(define-foreign-variable _sigsegv int "SIGSEGV")478(define-foreign-variable _sigabrt int "SIGABRT")479(define-foreign-variable _sigtrap int "SIGTRAP")480(define-foreign-variable _sigquit int "SIGQUIT")481(define-foreign-variable _sigalrm int "SIGALRM")482(define-foreign-variable _sigpipe int "SIGPIPE")483(define-foreign-variable _sigusr1 int "SIGUSR1")484(define-foreign-variable _sigusr2 int "SIGUSR2")485(define-foreign-variable _sigvtalrm int "SIGVTALRM")486(define-foreign-variable _sigprof int "SIGPROF")487(define-foreign-variable _sigio int "SIGIO")488(define-foreign-variable _sigurg int "SIGURG")489(define-foreign-variable _sigchld int "SIGCHLD")490(define-foreign-variable _sigcont int "SIGCONT")491(define-foreign-variable _sigstop int "SIGSTOP")492(define-foreign-variable _sigtstp int "SIGTSTP")493(define-foreign-variable _sigxcpu int "SIGXCPU")494(define-foreign-variable _sigxfsz int "SIGXFSZ")495(define-foreign-variable _sigwinch int "SIGWINCH")496497(set! chicken.process.signal#signal/term _sigterm)498(set! chicken.process.signal#signal/kill _sigkill)499(set! chicken.process.signal#signal/int _sigint)500(set! chicken.process.signal#signal/hup _sighup)501(set! chicken.process.signal#signal/fpe _sigfpe)502(set! chicken.process.signal#signal/ill _sigill)503(set! chicken.process.signal#signal/segv _sigsegv)504(set! chicken.process.signal#signal/abrt _sigabrt)505(set! chicken.process.signal#signal/trap _sigtrap)506(set! chicken.process.signal#signal/quit _sigquit)507(set! chicken.process.signal#signal/alrm _sigalrm)508(set! chicken.process.signal#signal/vtalrm _sigvtalrm)509(set! chicken.process.signal#signal/prof _sigprof)510(set! chicken.process.signal#signal/io _sigio)511(set! chicken.process.signal#signal/urg _sigurg)512(set! chicken.process.signal#signal/chld _sigchld)513(set! chicken.process.signal#signal/cont _sigcont)514(set! chicken.process.signal#signal/stop _sigstop)515(set! chicken.process.signal#signal/tstp _sigtstp)516(set! chicken.process.signal#signal/pipe _sigpipe)517(set! chicken.process.signal#signal/xcpu _sigxcpu)518(set! chicken.process.signal#signal/xfsz _sigxfsz)519(set! chicken.process.signal#signal/usr1 _sigusr1)520(set! chicken.process.signal#signal/usr2 _sigusr2)521(set! chicken.process.signal#signal/winch _sigwinch)522(set! chicken.process.signal#signal/bus _sigbus)523(set! chicken.process.signal#signal/break 0)524525(set! chicken.process.signal#signals-list526 (list527 chicken.process.signal#signal/term528 chicken.process.signal#signal/kill529 chicken.process.signal#signal/int530 chicken.process.signal#signal/hup531 chicken.process.signal#signal/fpe532 chicken.process.signal#signal/ill533 chicken.process.signal#signal/segv534 chicken.process.signal#signal/abrt535 chicken.process.signal#signal/trap536 chicken.process.signal#signal/quit537 chicken.process.signal#signal/alrm538 chicken.process.signal#signal/vtalrm539 chicken.process.signal#signal/prof540 chicken.process.signal#signal/io541 chicken.process.signal#signal/urg542 chicken.process.signal#signal/chld543 chicken.process.signal#signal/cont544 chicken.process.signal#signal/stop545 chicken.process.signal#signal/tstp546 chicken.process.signal#signal/pipe547 chicken.process.signal#signal/xcpu548 chicken.process.signal#signal/xfsz549 chicken.process.signal#signal/usr1550 chicken.process.signal#signal/usr2551 chicken.process.signal#signal/winch552 chicken.process.signal#signal/bus))553554(set! chicken.process.signal#set-signal-mask!555 (lambda (sigs)556 (##sys#check-list sigs 'set-signal-mask!)557 (##core#inline "C_sigemptyset" 0)558 (for-each559 (lambda (s)560 (##sys#check-fixnum s 'set-signal-mask!)561 (##core#inline "C_sigaddset" s) )562 sigs)563 (when (fx< (##core#inline "C_sigprocmask_set" 0) 0)564 (posix-error #:process-error 'set-signal-mask! "cannot set signal mask") )))565566(define chicken.process.signal#signal-mask567 (getter-with-setter568 (lambda ()569 (##core#inline "C_sigprocmask_get" 0)570 (let loop ((sigs chicken.process.signal#signals-list) (mask '()))571 (if (null? sigs)572 mask573 (let ([sig (car sigs)])574 (loop (cdr sigs)575 (if (##core#inline "C_sigismember" sig) (cons sig mask) mask)) ) ) ) )576 chicken.process.signal#set-signal-mask!577 "(chicken.process.signal#signal-mask)"))578579(set! chicken.process.signal#signal-masked?580 (lambda (sig)581 (##sys#check-fixnum sig 'signal-masked?)582 (##core#inline "C_sigprocmask_get" 0)583 (##core#inline "C_sigismember" sig)) )584585(set! chicken.process.signal#signal-mask!586 (lambda (sig)587 (##sys#check-fixnum sig 'signal-mask!)588 (##core#inline "C_sigemptyset" 0)589 (##core#inline "C_sigaddset" sig)590 (when (fx< (##core#inline "C_sigprocmask_block" 0) 0)591 (posix-error #:process-error 'signal-mask! "cannot block signal") )))592593(set! chicken.process.signal#signal-unmask!594 (lambda (sig)595 (##sys#check-fixnum sig 'signal-unmask!)596 (##core#inline "C_sigemptyset" 0)597 (##core#inline "C_sigaddset" sig)598 (when (fx< (##core#inline "C_sigprocmask_unblock" 0) 0)599 (posix-error #:process-error 'signal-unmask! "cannot unblock signal") )) )600601602;;; Getting group- and user-information:603604(set! chicken.process-context.posix#current-user-id605 (getter-with-setter606 (foreign-lambda int "C_getuid")607 (lambda (id)608 (##sys#check-fixnum id 'current-user-id)609 (when (fx< (##core#inline "C_setuid" id) 0)610 (##sys#error/errno (##sys#update-errno)611 'current-user-id!-setter "cannot set user ID" id)))612 "(chicken.process-context.posix#current-user-id)"))613614(set! chicken.process-context.posix#current-effective-user-id615 (getter-with-setter616 (foreign-lambda int "C_geteuid")617 (lambda (id)618 (##sys#check-fixnum id 'current-effective-user-id)619 (when (fx< (##core#inline "C_seteuid" id) 0)620 (##sys#error/errno (##sys#update-errno)621 'effective-user-id!-setter622 "cannot set effective user ID" id)))623 "(chicken.process-context.posix#current-effective-user-id)"))624625(set! chicken.process-context.posix#current-group-id626 (getter-with-setter627 (foreign-lambda int "C_getgid")628 (lambda (id)629 (##sys#check-fixnum id 'current-group-id)630 (when (fx< (##core#inline "C_setgid" id) 0)631 (##sys#error/errno (##sys#update-errno)632 'current-group-id!-setter "cannot set group ID" id)))633 "(chicken.process-context.posix#current-group-id)") )634635(set! chicken.process-context.posix#current-effective-group-id636 (getter-with-setter637 (foreign-lambda int "C_getegid")638 (lambda (id)639 (##sys#check-fixnum id 'current-effective-group-id)640 (when (fx< (##core#inline "C_setegid" id) 0)641 (##sys#error/errno (##sys#update-errno)642 'effective-group-id!-setter643 "cannot set effective group ID" id)))644 "(chicken.process-context.posix#current-effective-group-id)") )645646(define-foreign-variable _user-name nonnull-c-string "C_user->pw_name")647(define-foreign-variable _user-passwd nonnull-c-string "C_user->pw_passwd")648(define-foreign-variable _user-uid int "C_user->pw_uid")649(define-foreign-variable _user-gid int "C_user->pw_gid")650(define-foreign-variable _user-gecos nonnull-c-string "C_PW_GECOS")651(define-foreign-variable _user-dir c-string "C_user->pw_dir")652(define-foreign-variable _user-shell c-string "C_user->pw_shell")653654(set! chicken.process-context.posix#user-information655 (lambda (user #!optional as-vector)656 (let ([r (if (fixnum? user)657 (##core#inline "C_getpwuid" user)658 (begin659 (##sys#check-string user 'user-information)660 (##core#inline "C_getpwnam" (##sys#make-c-string user 'user-information)) ) ) ] )661 (and r662 ((if as-vector vector list)663 _user-name664 _user-passwd665 _user-uid666 _user-gid667 _user-gecos668 _user-dir669 _user-shell) ) )) )670671(set! chicken.process-context.posix#current-user-name672 (lambda ()673 (car (chicken.process-context.posix#user-information674 (chicken.process-context.posix#current-user-id)))) )675676(set! chicken.process-context.posix#current-effective-user-name677 (lambda ()678 (car (chicken.process-context.posix#user-information679 (chicken.process-context.posix#current-effective-user-id)))) )680681(define chown682 (lambda (loc f uid gid)683 (##sys#check-fixnum uid loc)684 (##sys#check-fixnum gid loc)685 (let ((r (cond686 ((port? f)687 (##core#inline "C_fchown" (chicken.file.posix#port->fileno f) uid gid))688 ((fixnum? f)689 (##core#inline "C_fchown" f uid gid))690 ((string? f)691 (##core#inline "C_chown"692 (##sys#make-c-string f loc) uid gid))693 (else (##sys#signal-hook694 #:type-error loc695 "bad argument type - not a fixnum, port or string" f)))))696 (when (fx< r 0)697 (posix-error #:file-error loc "cannot change file owner" f uid gid) )) ) )698699(set! chicken.process-context.posix#create-session700 (lambda ()701 (let ([a (##core#inline "C_setsid" #f)])702 (when (fx< a 0)703 (##sys#error/errno (##sys#update-errno)704 'create-session "cannot create session"))705 a)) )706707(set! chicken.process-context.posix#process-group-id708 (getter-with-setter709 (lambda (pid)710 (##sys#check-fixnum pid 'process-group-id)711 (let ([a (##core#inline "C_getpgid" pid)])712 (when (fx< a 0)713 (##sys#error/errno (##sys#update-errno)714 'process-group-id715 "cannot retrieve process group ID" pid))716 a))717 (lambda (pid pgid)718 (##sys#check-fixnum pid 'process-group)719 (##sys#check-fixnum pgid 'process-group)720 (when (fx< (##core#inline "C_setpgid" pid pgid) 0)721 (##sys#error/errno (##sys#update-errno)722 'process-group "cannot set process group ID" pid pgid)))723 "(chicken.process-context.posix#process-group-id pid)"))724725726;;; Hard and symbolic links:727728(set! chicken.file.posix#create-symbolic-link729 (lambda (old new)730 (##sys#check-string old 'create-symbolic-link)731 (##sys#check-string new 'create-symbolic-link)732 (when (fx< (##core#inline733 "C_symlink"734 (##sys#make-c-string old 'create-symbolic-link)735 (##sys#make-c-string new 'create-symbolic-link) )736 0)737 (posix-error #:file-error 'create-symbolic-link "cannot create symbolic link" old new) ) ) )738739(define-foreign-variable _filename_max int "FILENAME_MAX")740741(define ##sys#read-symbolic-link742 (let ((buf (##sys#make-bytevector (fx+ _filename_max 1) 0)))743 (lambda (fname location)744 (let ((len (##core#inline745 "C_do_readlink"746 (##sys#make-c-string fname location)747 buf)))748 (if (fx< len 0)749 (posix-error #:file-error location "cannot read symbolic link" fname)750 (##sys#buffer->string buf 0 len))))))751752(set! chicken.file.posix#read-symbolic-link753 (lambda (fname #!optional canonicalize)754 (##sys#check-string fname 'read-symbolic-link)755 (if canonicalize756 (receive (base-origin base-directory directory-components) (decompose-directory fname)757 (let loop ((components directory-components)758 (result (string-append (or base-origin "") (or base-directory ""))))759 (if (null? components)760 result761 (let ((pathname (make-pathname result (car components))))762 (if (##sys#file-exists? pathname #f #f 'read-symbolic-link)763 (loop (cdr components)764 (if (chicken.file.posix#symbolic-link? pathname)765 (let ((target (##sys#read-symbolic-link pathname 'read-symbolic-link)))766 (if (absolute-pathname? target)767 target768 (make-pathname result target)))769 pathname))770 (##sys#signal-hook #:file-error 'read-symbolic-link "could not canonicalize path with symbolic links, component does not exist" pathname))))))771 (##sys#read-symbolic-link fname 'read-symbolic-link))))772773(set! chicken.file.posix#file-link774 (let ((link (foreign-lambda int "link" nonnull-c-string nonnull-c-string)))775 (lambda (old new)776 (##sys#check-string old 'file-link)777 (##sys#check-string new 'file-link)778 (when (fx< (link old new) 0)779 (posix-error #:file-error 'hard-link "could not create hard link" old new) ) ) ) )780781782(define ##sys#custom-input-port783 (lambda (loc nam fd #!optional (nonblocking? #f) (bufi 1) (on-close void) (more? #f) enc)784 (when nonblocking? (##sys#file-nonblocking! fd) )785 (let ((bufsiz (if (fixnum? bufi) bufi (##sys#size bufi)))786 (buf (if (fixnum? bufi) (##sys#make-bytevector bufi) bufi))787 (buflen 0)788 (bufpos 0)789 (this-port #f))790 (let ([ready?791 (lambda ()792 (let ((res (##sys#file-select-one fd)))793 (if (fx= -1 res)794 (if (or (fx= _errno _ewouldblock)795 (fx= _errno _eagain))796 #f797 (posix-error #:file-error loc "cannot select" fd nam))798 (fx= 1 res))))]799 [peek800 (lambda ()801 (if (fx>= bufpos buflen)802 #!eof803 (##sys#decode-buffer buf bufpos 1 (##sys#slot this-port 15)804 (lambda (buf start n)805 (##core#inline "C_utf_decode" buf start)))))]806 [fetch807 (lambda ()808 (let loop ()809 (let ([cnt (##core#inline "C_read" fd buf bufsiz)])810 (cond ((fx= cnt -1)811 (cond812 ((or (fx= _errno _ewouldblock)813 (fx= _errno _eagain))814 (##sys#thread-block-for-i/o! ##sys#current-thread fd #:input)815 (##sys#thread-yield!)816 (loop) )817 ((fx= _errno _eintr)818 (##sys#dispatch-interrupt loop))819 (else (posix-error #:file-error loc "cannot read" fd nam) )))820 [(and more? (fx= cnt 0))821 ;; When "more" keep trying, otherwise read once more822 ;; to guard against race conditions823 (if more?824 (begin825 (##sys#thread-yield!)826 (loop) )827 (let ([cnt (##core#inline "C_read" fd buf bufsiz)])828 (when (fx= cnt -1)829 (if (or (fx= _errno _ewouldblock)830 (fx= _errno _eagain))831 (set! cnt 0)832 (posix-error #:file-error loc "cannot read" fd nam) ) )833 (set! buflen cnt)834 (set! bufpos 0) ) )]835 [else836 (set! buflen cnt)837 (set! bufpos 0)]) ) ) )] )838 (let ([the-port839 (make-input-port840 (lambda () ; read-char841 (when (fx>= bufpos buflen)842 (fetch))843 (if (fx>= bufpos buflen)844 #!eof845 (##sys#decode-buffer buf bufpos 1 (##sys#slot this-port 15)846 (lambda (buf start n)847 (set! bufpos (fx+ bufpos n))848 (##core#inline "C_utf_decode" buf start)))))849 (lambda () ; char-ready?850 (or (fx< bufpos buflen)851 (ready?)) )852 (lambda () ; close853 (when (fx< (##core#inline "C_close" fd) 0)854 (posix-error #:file-error loc "cannot close" fd nam))855 (on-close))856 peek-char:857 (lambda () ; peek-char858 (when (fx>= bufpos buflen)859 (fetch))860 (peek) )861 read-bytevector:862 (lambda (port n dest start) ; read-bytevector!863 (let loop ([n (or n (fx- (##sys#size dest) start))]864 [m 0]865 [start start])866 (cond [(eq? 0 n) m]867 [(fx< bufpos buflen)868 (let* ([rest (fx- buflen bufpos)]869 [n2 (if (fx< n rest) n rest)])870 (##core#inline "C_copy_memory_with_offset"871 dest buf start bufpos n2)872 (set! bufpos (fx+ bufpos n2))873 (loop (fx- n n2) (fx+ m n2) (fx+ start n2)) ) ]874 [else875 (fetch)876 (if (eq? 0 buflen)877 m878 (loop n m start) ) ] ) ) )879 read-line:880 (lambda (p limit) ; read-line881 (when (fx>= bufpos buflen)882 (fetch))883 (if (fx>= bufpos buflen)884 #!eof885 (let ((limit (or limit (fx- most-positive-fixnum bufpos))))886 (receive (next line full-line?)887 (##sys#scan-buffer-line888 buf889 (fxmin buflen (fx+ bufpos limit))890 bufpos891 (lambda (pos)892 (let ((nbytes (fx- pos bufpos)))893 (cond ((fx>= nbytes limit)894 (values #f pos #f))895 (else896 (set! limit (fx- limit nbytes))897 (fetch)898 (if (fx< bufpos buflen)899 (values buf bufpos900 (fxmin buflen901 (fx+ bufpos limit)))902 (values #f bufpos #f))))))903 (##sys#slot this-port 15))904 ;; Update row & column position905 (if full-line?906 (begin907 (##sys#setislot p 4 (fx+ (##sys#slot p 4) 1))908 (##sys#setislot p 5 0))909 (##sys#setislot p 5 (fx+ (##sys#slot p 5)910 (string-length line))))911 (set! bufpos next)912 line)) ) )913 read-buffered:914 (lambda (port) ; read-buffered915 (if (fx>= bufpos buflen)916 ""917 (let* ((len (fx- buflen bufpos))918 (str (##sys#buffer->string/encoding buf bufpos len (##sys#slot this-port 15))))919 (set! bufpos buflen)920 str))))])921 (set! this-port the-port)922 (##sys#setslot this-port 3 nam)923 (##sys#setslot this-port 15 enc)924 this-port ) ) ) ) )925926(define ##sys#custom-output-port927 (lambda (loc nam fd #!optional (nonblocking? #f) (bufi 0) (on-close void)928 enc)929 (when nonblocking? (##sys#file-nonblocking! fd) )930 (letrec ((this-port #f)931 (poke932 (lambda (bv start len)933 (let loop ()934 (let ((cnt (##core#inline "C_write" fd bv start len)))935 (cond ((fx= -1 cnt)936 (cond937 ((or (fx= _errno _ewouldblock)938 (fx= _errno _eagain))939 (##sys#thread-yield!)940 (poke bv start len) )941 ((fx= _errno _eintr)942 (##sys#dispatch-interrupt loop))943 (else944 (posix-error loc #:file-error "cannot write" fd nam) ) ) )945 ((fx< cnt len)946 (poke bv (fx+ start cnt) (fx- len cnt)) ) ) ) )))947 (store948 (let ([bufsiz (if (fixnum? bufi) bufi (##sys#size bufi))])949 (if (fx= 0 bufsiz)950 (lambda (str)951 (when str952 (let ((bv (##sys#slot str 0)))953 (poke bv 0 (fx- (##sys#size bv) 1)))))954 (let ((buf (if (fixnum? bufi) (##sys#make-bytevector bufi) bufi))955 (bufpos 0))956 (lambda (str)957 (if str958 (let ((bv (##sys#slot str 0)))959 (let loop ((rem (fx- bufsiz bufpos))960 (start 0)961 (len (fx- (##sys#size bv) 1)))962 (cond ((fx= 0 rem)963 (poke buf 0 bufsiz)964 (set! bufpos 0)965 (loop bufsiz 0 len))966 ((fx< rem len)967 (##core#inline "C_copy_memory_with_offset" buf bv bufpos 0 len)968 (loop 0 rem (fx- len rem)))969 (else970 (##core#inline "C_copy_memory_with_offset" buf bv bufpos start len)971 (set! bufpos (fx+ bufpos len))) ) )972 (when (fx< 0 bufpos)973 (poke buf bufpos) ) ) ) ) ) ))))974 (let ((the-port975 (make-output-port976 (lambda (str) (store str))977 (lambda () ; close978 (when (fx< (##core#inline "C_close" fd) 0)979 (posix-error #:file-error loc "cannot close" fd nam))980 (on-close))981 force-output:982 (lambda () ; flush983 (store #f) ) )) )984 (set! this-port the-port)985 (##sys#setslot this-port 3 nam)986 (##sys#setslot this-port 15 enc)987 this-port ) ) ) )988989990;;; Other file operations:991992(set! chicken.file.posix#file-truncate993 (lambda (fname off)994 (##sys#check-exact-integer off 'file-truncate)995 (when (fx< (cond ((string? fname) (##core#inline "C_truncate" (##sys#make-c-string fname 'file-truncate) off))996 ((port? fname) (##core#inline "C_ftruncate" (chicken.file.posix#port->fileno fname) off))997 ((fixnum? fname) (##core#inline "C_ftruncate" fname off))998 (else (##sys#error 'file-truncate "invalid file" fname)))999 0)1000 (posix-error #:file-error 'file-truncate "cannot truncate file" fname off) ) ) )100110021003;;; File locking:10041005(define-foreign-variable _lock_sh int "LOCK_SH")1006(define-foreign-variable _lock_ex int "LOCK_EX")1007(define-foreign-variable _lock_un int "LOCK_UN")1008(define-foreign-variable _lock_nb int "LOCK_NB")10091010(let ()1011 (define (err msg port loc)1012 (posix-error #:file-error loc msg port) )1013 (define (fileno x loc)1014 (if (port? x)1015 (chicken.file.posix#port->fileno x)1016 (begin1017 (##sys#check-exact-integer x loc)1018 x)))1019 (set! chicken.file.posix#file-lock1020 (lambda (port #!optional shared)1021 (let loop ()1022 (let ((r (##core#inline "C_flock" (fileno port 'file-lock)1023 (##core#inline "C_fixnum_or" _lock_nb (if shared _lock_sh _lock_ex)))))1024 (cond ((eq? r 0) #t)1025 ((fx= _errno _eintr) (loop))1026 ((fx= _errno _ewouldblock) #f)1027 (else (err "locking file failed" port 'file-lock)))))))1028 (set! chicken.file.posix#file-lock/blocking1029 (lambda (port #!optional shared)1030 (let loop ()1031 (let ((r (##core#inline "C_flock" (fileno port 'file-lock/blocking)1032 (if shared _lock_sh _lock_ex))))1033 (cond ((eq? r 0) #t)1034 ((fx= _errno _eintr) (loop))1035 (else (err "locking file failed" port 'file-lock/blocking)))))))1036 (set! chicken.file.posix#file-unlock1037 (lambda (port)1038 (let loop ()1039 (let ((r (##core#inline "C_flock" (fileno port 'file-unlock) _lock_un)))1040 (cond ((eq? r 0))1041 ((fx= _errno _eintr) (loop))1042 (else (err "unlocking file failed" port 'file-unlock))))))))104310441045;;; FIFOs:10461047(set! chicken.file.posix#create-fifo1048 (lambda (fname . mode)1049 (##sys#check-string fname 'create-fifo)1050 (let ([mode (if (pair? mode) (car mode) (fxior _s_irwxu (fxior _s_irwxg _s_irwxo)))])1051 (##sys#check-fixnum mode 'create-fifo)1052 (when (fx< (##core#inline "C_mkfifo" (##sys#make-c-string fname 'create-fifo) mode) 0)1053 (posix-error #:file-error 'create-fifo "cannot create FIFO" fname mode) ) ) ) )105410551056;;; Time related things:10571058(set! chicken.time.posix#string->time1059 (let ((strptime (foreign-lambda scheme-object "C_strptime" scheme-object scheme-object scheme-object scheme-pointer))1060 (tm-size (foreign-value "sizeof(struct tm)" int)))1061 (lambda (tim #!optional (fmt "%a %b %e %H:%M:%S %Z %Y"))1062 (##sys#check-string tim 'string->time)1063 (##sys#check-string fmt 'string->time)1064 (strptime (##sys#make-c-string tim 'string->time) (##sys#make-c-string fmt) (make-vector 10 #f) (##sys#make-string tm-size #\nul)) ) ) )10651066(set! chicken.time.posix#utc-time->seconds1067 (let ((tm-size (foreign-value "sizeof(struct tm)" int)))1068 (lambda (tm)1069 (check-time-vector 'utc-time->seconds tm)1070 (let ((t (##core#inline_allocate ("C_a_timegm" 7) tm (##sys#make-string tm-size #\nul))))1071 (if (= -1 t)1072 (##sys#error 'utc-time->seconds "cannot convert time vector to seconds" tm)1073 t)))))10741075(set! chicken.time.posix#local-timezone-abbreviation1076 (foreign-lambda* c-string ()1077 "\n#if !defined(__CYGWIN__) && !defined(__SVR4) && !defined(__uClinux__) && !defined(__hpux__) && !defined(_AIX)\n"1078 "time_t clock = time(NULL);"1079 "struct tm *ltm = C_localtime(&clock);"1080 "char *z = ltm ? (char *)ltm->tm_zone : 0;"1081 "\n#else\n"1082 "char *z = (daylight ? tzname[1] : tzname[0]);"1083 "\n#endif\n"1084 "C_return(z);") )108510861087;;; Other things:10881089(set! chicken.process.signal#set-alarm!1090 (foreign-lambda int "C_alarm" int))109110921093;;; Process handling:10941095(define c-string->allocated-pointer1096 (foreign-lambda* c-pointer ((scheme-object o))1097 "char *ptr = C_malloc(C_header_size(o)); \n"1098 "if (ptr != NULL) {\n"1099 " C_memcpy(ptr, C_data_pointer(o), C_header_size(o)); \n"1100 "}\n"1101 "C_return(ptr);"))11021103(set! chicken.process#process-fork1104 (let ((fork (foreign-lambda int "C_fork")))1105 (lambda (#!optional thunk killothers)1106 ;; flush all stdio streams before fork1107 ((foreign-lambda int "C_fflush" c-pointer) #f)1108 (let ((pid (fork)))1109 (cond ((fx= -1 pid) ; error1110 (posix-error #:process-error 'process-fork "cannot create child process"))1111 ((fx= 0 pid) ; child process1112 (set! children '())1113 (when killothers1114 (call-with-current-continuation (lambda (continue) (##sys#kill-other-threads (lambda () (continue #f))))))1115 (if thunk1116 (##sys#call-with-cthulhu1117 (lambda ()1118 (thunk)1119 ;; Make sure to run clean up tasks.1120 ;; NOTE: ##sys#call-with-cthulhu will invoke1121 ;; a more low-level runtime C_exit_runtime(0)1122 (exit 0)))1123 #f))1124 (else ; parent process1125 (register-pid pid)))))))11261127(set! chicken.process#process-execute1128 (lambda (filename #!optional (arglist '()) envlist _)1129 (call-with-exec-args1130 'process-execute filename (lambda (x) x) arglist envlist1131 (lambda (prg argbuf envbuf)1132 (let ((r (if envbuf1133 (##core#inline "C_u_i_execve" prg argbuf envbuf)1134 (##core#inline "C_u_i_execvp" prg argbuf))))1135 (when (fx= r -1)1136 (posix-error #:process-error 'process-execute "cannot execute process" filename)))))))11371138(define-foreign-variable _wnohang int "WNOHANG")1139(define-foreign-variable _wait-status int "C_wait_status")11401141(define (process-wait-impl pid nohang)1142 (let* ((res (##core#inline "C_waitpid" pid (if nohang _wnohang 0)))1143 (norm (##core#inline "C_WIFEXITED" _wait-status)) )1144 (if (and (fx= res -1) (fx= _errno _eintr))1145 (##sys#dispatch-interrupt1146 (lambda () (process-wait-impl pid nohang)))1147 (values1148 res1149 norm1150 (cond (norm (##core#inline "C_WEXITSTATUS" _wait-status))1151 ((##core#inline "C_WIFSIGNALED" _wait-status)1152 (##core#inline "C_WTERMSIG" _wait-status))1153 (else (##core#inline "C_WSTOPSIG" _wait-status)) ) )) ) )11541155(set! chicken.process-context.posix#parent-process-id (foreign-lambda int "C_getppid"))11561157(set! chicken.process#process-signal1158 (lambda (id . sig)1159 (let ((sig (if (pair? sig) (car sig) _sigterm))1160 (pid (if (process? id) (process-id id) id)))1161 (##sys#check-fixnum pid 'process-signal)1162 (##sys#check-fixnum sig 'process-signal)1163 (let ((r (##core#inline "C_kill" pid sig)))1164 (when (fx= r -1)1165 (posix-error #:process-error 'process-signal1166 "could not send signal to process" id sig) ) ) ) ) )11671168(define (shell-command loc)1169 (or (get-environment-variable "SHELL") "/bin/sh") )11701171(define (shell-command-arguments cmdlin)1172 (list "-c" cmdlin) )11731174(set! chicken.process#process-run1175 (lambda (f . args)1176 (let ((args (if (pair? args) (car args) #f))1177 (proc (chicken.process#process-fork)) )1178 (cond (proc)1179 (args (chicken.process#process-execute f args))1180 (else1181 (chicken.process#process-execute1182 (shell-command 'process-run)1183 (shell-command-arguments f)) ) ) ) ) )11841185;;; Run subprocess connected with pipes:11861187;; process-impl1188; loc caller procedure symbol1189; cmd pathname or commandline1190; args string-list or '()1191; env string-list or #f1192; stdoutf #f then share, or #t then create1193; stdinf #f then share, or #t then create1194; stderrf #f then share, or #t then create1195;1196; (values stdin-input-port? stdout-output-port? pid stderr-input-port?)1197; where stdin-input-port?, etc. is a port or #f, indicating no port created.11981199(define-constant DEFAULT-INPUT-BUFFER-SIZE 256)1200(define-constant DEFAULT-OUTPUT-BUFFER-SIZE 0)12011202;FIXME process-execute, process-fork don't show parent caller12031204(define process-impl1205 (let ((replace-fd1206 (lambda (loc fd stdfd)1207 (unless (fx= stdfd fd)1208 (chicken.file.posix#duplicate-fileno fd stdfd)1209 (chicken.file.posix#file-close fd) ) )) )1210 (let ((make-on-close1211 (lambda (loc proc clsvec idx idxa idxb)1212 (lambda ()1213 (vector-set! clsvec idx #t)1214 (when (and (vector-ref clsvec idxa) (vector-ref clsvec idxb))1215 (chicken.process#process-wait proc #f) )1216 (void)) ))1217 (needed-pipe1218 (lambda (loc port)1219 (and port1220 (receive (i o) (chicken.process#create-pipe)1221 (cons i o))) ))1222 [connect-parent1223 (lambda (loc pipe port fd)1224 (and port1225 (let ([usefd (car pipe)] [clsfd (cdr pipe)])1226 (chicken.file.posix#file-close clsfd)1227 usefd) ) )]1228 [connect-child1229 (lambda (loc pipe port stdfd)1230 (when port1231 (let ([usefd (car pipe)] [clsfd (cdr pipe)])1232 (chicken.file.posix#file-close clsfd)1233 (replace-fd loc usefd stdfd)) ) )] )1234 (let (1235 (spawn1236 (let ([swapped-ends1237 (lambda (pipe)1238 (and pipe1239 (cons (cdr pipe) (car pipe)) ) )])1240 (lambda (loc cmd args env stdoutf stdinf stderrf)1241 (let ([ipipe (needed-pipe loc stdinf)]1242 [opipe (needed-pipe loc stdoutf)]1243 [epipe (needed-pipe loc stderrf)])1244 (values1245 ipipe (swapped-ends opipe) epipe1246 (chicken.process#process-fork1247 (lambda ()1248 (connect-child loc opipe stdinf chicken.file.posix#fileno/stdin)1249 (connect-child loc (swapped-ends ipipe) stdoutf chicken.file.posix#fileno/stdout)1250 (connect-child loc (swapped-ends epipe) stderrf chicken.file.posix#fileno/stderr)1251 (chicken.process#process-execute cmd args env)))) ) ) ))1252 [input-port1253 (lambda (loc cmd pipe stdf stdfd on-close enc)1254 (and-let* ([fd (connect-parent loc pipe stdf stdfd)])1255 (##sys#custom-input-port loc cmd fd #t DEFAULT-INPUT-BUFFER-SIZE on-close #f enc) ) )]1256 [output-port1257 (lambda (loc cmd pipe stdf stdfd on-close enc)1258 (and-let* ([fd (connect-parent loc pipe stdf stdfd)])1259 (##sys#custom-output-port loc cmd fd #t DEFAULT-OUTPUT-BUFFER-SIZE on-close enc) ) )] )1260 (lambda (loc cmd args env stdoutf stdinf stderrf enc)1261 (receive [inpipe outpipe errpipe proc]1262 (spawn loc cmd args env stdoutf stdinf stderrf)1263 ;When shared assume already "closed", since only created ports1264 ;should be explicitly closed, and when one is closed we want1265 ;to wait.1266 (let ((clsvec (vector (not stdinf) (not stdoutf) (not stderrf))))1267 (process-output-port-set! proc1268 (input-port loc cmd inpipe stdinf1269 chicken.file.posix#fileno/stdin1270 (make-on-close loc proc clsvec 0 1 2)1271 enc))1272 (process-input-port-set! proc1273 (output-port loc cmd outpipe stdoutf1274 chicken.file.posix#fileno/stdout1275 (make-on-close loc proc clsvec 1 0 2)1276 enc))1277 (process-error-port-set! proc1278 (input-port loc cmd errpipe stderrf1279 chicken.file.posix#fileno/stderr1280 (make-on-close loc proc clsvec 2 0 1)1281 enc) )1282 proc) ) ) ) ) ) )12831284;;; Run subprocess connected with pipes:12851286;; TODO: See if this can be moved to posix-common1287(let ((%process1288 (lambda (loc err? cmd args env enc)1289 (let ((chkstrlst1290 (lambda (lst)1291 (##sys#check-list lst loc)1292 (for-each (cut ##sys#check-string <> loc) lst) )))1293 (##sys#check-string cmd loc)1294 (if args1295 (chkstrlst args)1296 (begin1297 (set! args (shell-command-arguments cmd))1298 (set! cmd (shell-command loc)) ) )1299 (when env (check-environment-list env loc))1300 (process-impl loc cmd args env #t #t err? enc)))))1301 (set! chicken.process#process1302 (lambda (cmd #!optional args env (enc 'utf-8) exactf)1303 (%process 'process #f cmd args env enc)))1304 (set! chicken.process#process*1305 (lambda (cmd #!optional args env (enc 'utf-8) exactf)1306 (%process 'process* #t cmd args env enc))))130713081309;;; chroot:13101311(set! chicken.process-context.posix#set-root-directory!1312 (let ((chroot (foreign-lambda int "chroot" nonnull-c-string)))1313 (lambda (dir)1314 (##sys#check-string dir 'set-root-directory!)1315 (when (fx< (chroot dir) 0)1316 (posix-error #:file-error 'set-root-directory! "unable to change root directory" dir) ) ) ) )13171318;;; unimplemented stuff:13191320(set!-unimplemented chicken.process#process-spawn)