~ chicken-core (master) /posix-common.scm
Trap1;;;; posix-common.scm - common code for UNIX and Windows versions of the posix unit2;3; Copyright (c) 2010-2022, The CHICKEN Team4; All rights reserved.5;6; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following7; conditions are met:8;9; Redistributions of source code must retain the above copyright notice, this list of conditions and the following10; disclaimer.11; Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following12; disclaimer in the documentation and/or other materials provided with the distribution.13; Neither the name of the author nor the names of its contributors may be used to endorse or promote14; products derived from this software without specific prior written permission.15;16; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS17; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY18; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR19; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR20; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR21; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY22; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR23; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE24; POSSIBILITY OF SUCH DAMAGE.252627(declare28 (foreign-declare #<<EOF2930#include <signal.h>3132static int C_not_implemented(void);33int C_not_implemented() { return -1; }3435#if defined(_WIN32) && !defined(__CYGWIN__)36static struct _stat64i32 C_statbuf;37#define C_fstat _fstat64i3238#else39static struct stat C_statbuf;40#define C_fstat fstat41#endif4243#define C_stat_type (C_statbuf.st_mode & S_IFMT)44#define C_stat_perm (C_statbuf.st_mode & ~S_IFMT)4546#define C_u_i_stat(fn) C_fix(C_stat(C_OS_FILENAME(fn, 0), &C_statbuf))47#define C_u_i_fstat(fd) C_fix(C_fstat(C_unfix(fd), &C_statbuf))4849#ifndef S_IFSOCK50# define S_IFSOCK 014000051#endif5253#ifndef S_IRUSR54# define S_IRUSR S_IREAD55#endif56#ifndef S_IWUSR57# define S_IWUSR S_IWRITE58#endif59#ifndef S_IXUSR60# define S_IXUSR S_IEXEC61#endif6263#ifndef S_IRGRP64# define S_IRGRP S_IREAD65#endif66#ifndef S_IWGRP67# define S_IWGRP S_IWRITE68#endif69#ifndef S_IXGRP70# define S_IXGRP S_IEXEC71#endif7273#ifndef S_IROTH74# define S_IROTH S_IREAD75#endif76#ifndef S_IWOTH77# define S_IWOTH S_IWRITE78#endif79#ifndef S_IXOTH80# define S_IXOTH S_IEXEC81#endif8283#define cpy_tmvec_to_tmstc08(ptm, v) \84 ((ptm)->tm_sec = C_unfix(C_block_item((v), 0)), \85 (ptm)->tm_min = C_unfix(C_block_item((v), 1)), \86 (ptm)->tm_hour = C_unfix(C_block_item((v), 2)), \87 (ptm)->tm_mday = C_unfix(C_block_item((v), 3)), \88 (ptm)->tm_mon = C_unfix(C_block_item((v), 4)), \89 (ptm)->tm_year = C_unfix(C_block_item((v), 5)), \90 (ptm)->tm_wday = C_unfix(C_block_item((v), 6)), \91 (ptm)->tm_yday = C_unfix(C_block_item((v), 7)), \92 (ptm)->tm_isdst = (C_block_item((v), 8) != C_SCHEME_FALSE))9394#define cpy_tmvec_to_tmstc9(ptm, v) \95 (((struct tm *)ptm)->tm_gmtoff = -C_unfix(C_block_item((v), 9)))9697#define C_tm_set_08(v, tm) cpy_tmvec_to_tmstc08( (tm), (v) )98#define C_tm_set_9(v, tm) cpy_tmvec_to_tmstc9( (tm), (v) )99100static struct tm *101C_tm_set( C_word v, void *tm )102{103 C_tm_set_08( v, (struct tm *)tm );104#if defined(C_GNU_ENV) && !defined(__CYGWIN__) && !defined(__uClinux__)105 C_tm_set_9( v, (struct tm *)tm );106#endif107 return tm;108}109110#define TIME_STRING_MAXLENGTH 255111static char C_time_string [TIME_STRING_MAXLENGTH + 1];112#undef TIME_STRING_MAXLENGTH113114#define C_strftime(v, f, tm) \115 (strftime(C_time_string, sizeof(C_time_string), C_c_string(f), C_tm_set((v), (tm))) ? C_time_string : NULL)116#define C_a_mktime(ptr, c, v, tm) C_int64_to_num(ptr, mktime(C_tm_set((v), C_data_pointer(tm))))117#define C_asctime(v, tm) (asctime(C_tm_set((v), (tm))))118119#define C_fdopen(a, n, fd, m) C_mpointer(a, fdopen(C_unfix(fd), C_c_string(m)))120#define C_dup(x) C_fix(dup(C_unfix(x)))121#define C_dup2(x, y) C_fix(dup2(C_unfix(x), C_unfix(y)))122123#define C_set_file_ptr(port, ptr) (C_set_block_item(port, 0, (C_block_item(ptr, 0))), C_SCHEME_UNDEFINED)124125/* It is assumed that 'int' is-a 'long' */126#define C_ftell(a, n, p) C_int64_to_num(a, ftell(C_port_file(p)))127#define C_fseek(p, n, w) C_mk_nbool(fseek(C_port_file(p), C_num_to_int64(n), C_unfix(w)))128#define C_lseek(fd, o, w) C_fix(lseek(C_unfix(fd), C_num_to_int64(o), C_unfix(w)))129130EOF131))132133(include "common-declarations.scm")134135(import (only (scheme base) port?))136137(define-syntax define-unimplemented138 (syntax-rules ()139 ((_ ?name)140 (define (?name . _)141 (error '?name (##core#immutable '"this function is not available on this platform")) ) ) ) )142143(define-syntax set!-unimplemented144 (syntax-rules ()145 ((_ ?name)146 (set! ?name147 (lambda _148 (error '?name (##core#immutable '"this function is not available on this platform"))) ) ) ) )149150151;;; Error codes:152153(define-foreign-variable _errno int "errno")154155(define-foreign-variable _eperm int "EPERM")156(define-foreign-variable _enoent int "ENOENT")157(define-foreign-variable _esrch int "ESRCH")158(define-foreign-variable _eintr int "EINTR")159(define-foreign-variable _eio int "EIO")160(define-foreign-variable _enoexec int "ENOEXEC")161(define-foreign-variable _ebadf int "EBADF")162(define-foreign-variable _echild int "ECHILD")163(define-foreign-variable _enomem int "ENOMEM")164(define-foreign-variable _eacces int "EACCES")165(define-foreign-variable _efault int "EFAULT")166(define-foreign-variable _ebusy int "EBUSY")167(define-foreign-variable _eexist int "EEXIST")168(define-foreign-variable _enotdir int "ENOTDIR")169(define-foreign-variable _eisdir int "EISDIR")170(define-foreign-variable _einval int "EINVAL")171(define-foreign-variable _emfile int "EMFILE")172(define-foreign-variable _enospc int "ENOSPC")173(define-foreign-variable _espipe int "ESPIPE")174(define-foreign-variable _epipe int "EPIPE")175(define-foreign-variable _eagain int "EAGAIN")176(define-foreign-variable _erofs int "EROFS")177(define-foreign-variable _enxio int "ENXIO")178(define-foreign-variable _e2big int "E2BIG")179(define-foreign-variable _exdev int "EXDEV")180(define-foreign-variable _enodev int "ENODEV")181(define-foreign-variable _enfile int "ENFILE")182(define-foreign-variable _enotty int "ENOTTY")183(define-foreign-variable _efbig int "EFBIG")184(define-foreign-variable _emlink int "EMLINK")185(define-foreign-variable _edom int "EDOM")186(define-foreign-variable _erange int "ERANGE")187(define-foreign-variable _edeadlk int "EDEADLK")188(define-foreign-variable _enametoolong int "ENAMETOOLONG")189(define-foreign-variable _enolck int "ENOLCK")190(define-foreign-variable _enosys int "ENOSYS")191(define-foreign-variable _enotempty int "ENOTEMPTY")192(define-foreign-variable _eilseq int "EILSEQ")193(define-foreign-variable _ewouldblock int "EWOULDBLOCK")194195(define posix-error196 (let ([strerror (foreign-lambda c-string "strerror" int)]197 [string-append string-append] )198 (lambda (type loc msg . args)199 (let ([rn (##sys#update-errno)])200 (apply ##sys#signal-hook/errno201 type rn loc (string-append msg " - " (strerror rn)) args)))))202203(define ##sys#posix-error posix-error)204205206;;; File properties207208(define-foreign-variable _stat_st_ino unsigned-int "C_statbuf.st_ino")209(define-foreign-variable _stat_st_nlink unsigned-int "C_statbuf.st_nlink")210(define-foreign-variable _stat_st_gid unsigned-int "C_statbuf.st_gid")211(define-foreign-variable _stat_st_size integer64 "C_statbuf.st_size")212(define-foreign-variable _stat_st_mtime integer64 "C_statbuf.st_mtime")213(define-foreign-variable _stat_st_atime integer64 "C_statbuf.st_atime")214(define-foreign-variable _stat_st_ctime integer64 "C_statbuf.st_ctime")215(define-foreign-variable _stat_st_uid unsigned-int "C_statbuf.st_uid")216(define-foreign-variable _stat_st_mode unsigned-int "C_statbuf.st_mode")217(define-foreign-variable _stat_st_dev unsigned-int "C_statbuf.st_dev")218(define-foreign-variable _stat_st_rdev unsigned-int "C_statbuf.st_rdev")219220(define-syntax stat-mode221 (er-macro-transformer222 (lambda (x r c)223 ;; no need to rename here224 (let* ((mode (cadr x))225 (name (symbol->string mode)))226 `(##core#begin227 (declare228 (foreign-declare229 ,(string-append "#ifndef " name "\n"230 "#define " name " S_IFREG\n"231 "#endif\n")))232 (define-foreign-variable ,mode unsigned-int))))))233234(stat-mode S_IFLNK)235(stat-mode S_IFREG)236(stat-mode S_IFDIR)237(stat-mode S_IFCHR)238(stat-mode S_IFBLK)239(stat-mode S_IFSOCK)240(stat-mode S_IFIFO)241242(define (stat file link err loc)243 (let ((r (cond ((fixnum? file) (##core#inline "C_u_i_fstat" file))244 ((port? file) (##core#inline "C_u_i_fstat" (chicken.file.posix#port->fileno file)))245 ((string? file)246 (let ((path (##sys#make-c-string file loc)))247 (if link248 (##core#inline "C_u_i_lstat" path)249 (##core#inline "C_u_i_stat" path))))250 (else251 (##sys#signal-hook252 #:type-error loc "bad argument type - not a fixnum, port or string" file)) ) ) )253 (if (fx< r 0)254 (if err255 (posix-error #:file-error loc "cannot access file" file)256 #f)257 #t)))258259(set! chicken.file.posix#file-stat260 (lambda (f #!optional link)261 (stat f link #t 'file-stat)262 (vector _stat_st_ino _stat_st_mode _stat_st_nlink263 _stat_st_uid _stat_st_gid _stat_st_size264 _stat_st_atime _stat_st_ctime _stat_st_mtime265 _stat_st_dev _stat_st_rdev266 _stat_st_blksize _stat_st_blocks) ) )267268(set! chicken.file.posix#set-file-permissions!269 (lambda (f p)270 (##sys#check-fixnum p 'set-file-permissions!)271 (let ((r (cond ((fixnum? f) (##core#inline "C_fchmod" f p))272 ((port? f) (##core#inline "C_fchmod" (chicken.file.posix#port->fileno f) p))273 ((string? f)274 (##core#inline "C_chmod"275 (##sys#make-c-string f 'set-file-permissions!) p))276 (else277 (##sys#signal-hook278 #:type-error 'file-permissions279 "bad argument type - not a fixnum, port or string" f)) ) ) )280 (when (fx< r 0)281 (posix-error #:file-error 'set-file-permissions! "cannot change file permissions" f p) ) )))282283(set! chicken.file.posix#file-modification-time284 (lambda (f)285 (stat f #f #t 'file-modification-time)286 _stat_st_mtime))287(set! chicken.file.posix#file-access-time288 (lambda (f)289 (stat f #f #t 'file-access-time)290 _stat_st_atime))291(set! chicken.file.posix#file-change-time292 (lambda (f)293 (stat f #f #t 'file-change-time)294 _stat_st_ctime))295296(set! chicken.file.posix#set-file-times!297 (lambda (f . rest)298 (let-optionals* rest ((atime (current-seconds)) (mtime atime))299 (when atime (##sys#check-exact-integer atime 'set-file-times!))300 (when mtime (##sys#check-exact-integer mtime 'set-file-times!))301 (let ((r ((foreign-lambda int "set_file_mtime"302 scheme-object scheme-object scheme-object)303 f atime mtime)))304 (when (fx< r 0)305 (apply posix-error306 #:file-error307 'set-file-times! "cannot set file times" f rest))))))308309(set! chicken.file.posix#file-size310 (lambda (f) (stat f #f #t 'file-size) _stat_st_size))311312(set! chicken.file.posix#set-file-owner!313 (lambda (f uid)314 (chown 'set-file-owner! f uid -1)))315316(set! chicken.file.posix#set-file-group!317 (lambda (f gid)318 (chown 'set-file-group! f -1 gid)))319320(set! chicken.file.posix#file-owner321 (getter-with-setter322 (lambda (f) (stat f #f #t 'file-owner) _stat_st_uid)323 chicken.file.posix#set-file-owner!324 "(chicken.file.posix#file-owner f)") )325326(set! chicken.file.posix#file-group327 (getter-with-setter328 (lambda (f) (stat f #f #t 'file-group) _stat_st_gid)329 chicken.file.posix#set-file-group!330 "(chicken.file.posix#file-group f)") )331332(set! chicken.file.posix#file-permissions333 (getter-with-setter334 (lambda (f)335 (stat f #f #t 'file-permissions)336 (foreign-value "C_stat_perm" unsigned-int))337 chicken.file.posix#set-file-permissions!338 "(chicken.file.posix#file-permissions f)"))339340(set! chicken.file.posix#file-type341 (lambda (file #!optional link (err #t))342 (and (stat file link err 'file-type)343 (let ((res (foreign-value "C_stat_type" unsigned-int)))344 (cond345 ((fx= res S_IFREG) 'regular-file)346 ((fx= res S_IFLNK) 'symbolic-link)347 ((fx= res S_IFDIR) 'directory)348 ((fx= res S_IFCHR) 'character-device)349 ((fx= res S_IFBLK) 'block-device)350 ((fx= res S_IFIFO) 'fifo)351 ((fx= res S_IFSOCK) 'socket)352 (else 'regular-file))))))353354(set! chicken.file.posix#regular-file?355 (lambda (file)356 (eq? 'regular-file (chicken.file.posix#file-type file #f #f))))357358(set! chicken.file.posix#symbolic-link?359 (lambda (file)360 (eq? 'symbolic-link (chicken.file.posix#file-type file #t #f))))361362(set! chicken.file.posix#block-device?363 (lambda (file)364 (eq? 'block-device (chicken.file.posix#file-type file #f #f))))365366(set! chicken.file.posix#character-device?367 (lambda (file)368 (eq? 'character-device (chicken.file.posix#file-type file #f #f))))369370(set! chicken.file.posix#fifo?371 (lambda (file)372 (eq? 'fifo (chicken.file.posix#file-type file #f #f))))373374(set! chicken.file.posix#socket?375 (lambda (file)376 (eq? 'socket (chicken.file.posix#file-type file #f #f))))377378(set! chicken.file.posix#directory?379 (lambda (file)380 (eq? 'directory (chicken.file.posix#file-type file #f #f))))381382383;;; File position access:384385(define-foreign-variable _seek_set int "SEEK_SET")386(define-foreign-variable _seek_cur int "SEEK_CUR")387(define-foreign-variable _seek_end int "SEEK_END")388389(set! chicken.file.posix#seek/set _seek_set)390(set! chicken.file.posix#seek/end _seek_end)391(set! chicken.file.posix#seek/cur _seek_cur)392393(set! chicken.file.posix#set-file-position!394 (lambda (port pos . whence)395 (let ((whence (if (pair? whence) (car whence) _seek_set)))396 (##sys#check-fixnum pos 'set-file-position!)397 (##sys#check-fixnum whence 'set-file-position!)398 (unless (cond ((port? port)399 (and-let* ((stream (eq? (##sys#slot port 7) 'stream))400 (res (##core#inline "C_fseek" port pos whence)))401 (##sys#setislot port 6 #f) ;; Reset EOF status402 res))403 ((fixnum? port)404 (##core#inline "C_lseek" port pos whence))405 (else406 (##sys#signal-hook #:type-error 'set-file-position! "invalid file" port)) )407 (posix-error #:file-error 'set-file-position! "cannot set file position" port pos) ) ) ) )408409(set! chicken.file.posix#file-position410 (getter-with-setter411 (lambda (port)412 (let ((pos (cond ((port? port)413 (if (eq? (##sys#slot port 7) 'stream)414 (##core#inline_allocate ("C_ftell" 7) port)415 -1) )416 ((fixnum? port)417 (##core#inline "C_lseek" port 0 _seek_cur) )418 (else419 (##sys#signal-hook #:type-error 'file-position "invalid file" port)) ) ) )420 (when (< pos 0)421 (posix-error #:file-error 'file-position "cannot retrieve file position of port" port) )422 pos) )423 chicken.file.posix#set-file-position! ; doesn't accept WHENCE424 "(chicken.file.posix#file-position port)"))425426427;;; Using file-descriptors:428429(define-foreign-variable _stdin_fileno int "STDIN_FILENO")430(define-foreign-variable _stdout_fileno int "STDOUT_FILENO")431(define-foreign-variable _stderr_fileno int "STDERR_FILENO")432433(set! chicken.file.posix#fileno/stdin _stdin_fileno)434(set! chicken.file.posix#fileno/stdout _stdout_fileno)435(set! chicken.file.posix#fileno/stderr _stderr_fileno)436437(define-foreign-variable _o_rdonly int "O_RDONLY")438(define-foreign-variable _o_wronly int "O_WRONLY")439(define-foreign-variable _o_rdwr int "O_RDWR")440(define-foreign-variable _o_creat int "O_CREAT")441(define-foreign-variable _o_append int "O_APPEND")442(define-foreign-variable _o_excl int "O_EXCL")443(define-foreign-variable _o_trunc int "O_TRUNC")444(define-foreign-variable _o_binary int "O_BINARY")445(define-foreign-variable _o_text int "O_TEXT")446447(set! chicken.file.posix#open/rdonly _o_rdonly)448(set! chicken.file.posix#open/wronly _o_wronly)449(set! chicken.file.posix#open/rdwr _o_rdwr)450(set! chicken.file.posix#open/read _o_rdonly)451(set! chicken.file.posix#open/write _o_wronly)452(set! chicken.file.posix#open/creat _o_creat)453(set! chicken.file.posix#open/append _o_append)454(set! chicken.file.posix#open/excl _o_excl)455(set! chicken.file.posix#open/trunc _o_trunc)456(set! chicken.file.posix#open/binary _o_binary)457(set! chicken.file.posix#open/text _o_text)458459;; open/noinherit is platform-specific460461(define-foreign-variable _s_irusr int "S_IRUSR")462(define-foreign-variable _s_iwusr int "S_IWUSR")463(define-foreign-variable _s_ixusr int "S_IXUSR")464(define-foreign-variable _s_irgrp int "S_IRGRP")465(define-foreign-variable _s_iwgrp int "S_IWGRP")466(define-foreign-variable _s_ixgrp int "S_IXGRP")467(define-foreign-variable _s_iroth int "S_IROTH")468(define-foreign-variable _s_iwoth int "S_IWOTH")469(define-foreign-variable _s_ixoth int "S_IXOTH")470(define-foreign-variable _s_irwxu int "S_IRUSR | S_IWUSR | S_IXUSR")471(define-foreign-variable _s_irwxg int "S_IRGRP | S_IWGRP | S_IXGRP")472(define-foreign-variable _s_irwxo int "S_IROTH | S_IWOTH | S_IXOTH")473474(set! chicken.file.posix#perm/irusr _s_irusr)475(set! chicken.file.posix#perm/iwusr _s_iwusr)476(set! chicken.file.posix#perm/ixusr _s_ixusr)477(set! chicken.file.posix#perm/irgrp _s_irgrp)478(set! chicken.file.posix#perm/iwgrp _s_iwgrp)479(set! chicken.file.posix#perm/ixgrp _s_ixgrp)480(set! chicken.file.posix#perm/iroth _s_iroth)481(set! chicken.file.posix#perm/iwoth _s_iwoth)482(set! chicken.file.posix#perm/ixoth _s_ixoth)483(set! chicken.file.posix#perm/irwxu _s_irwxu)484(set! chicken.file.posix#perm/irwxg _s_irwxg)485(set! chicken.file.posix#perm/irwxo _s_irwxo)486487;; perm/isvtx, perm/isuid and perm/isgid are platform-specific488489(let ()490 (define (mode inp m loc)491 (##sys#make-c-string492 (cond (m (case m493 ((#:append) (if (not inp) "a" (##sys#error "invalid mode for input file" m)))494 (else (##sys#error "invalid mode argument" m)) ) )495 (inp "r")496 (else "w") )497 loc) )498 (define (check loc fd inp r enc)499 (if (##sys#null-pointer? r)500 (posix-error #:file-error loc "cannot open file" fd)501 (let ((port (##sys#make-port (if inp 1 2) ##sys#stream-port-class "(fdport)" 'stream)))502 (##core#inline "C_set_file_ptr" port r)503 (##sys#setslot port 15 enc)504 port) ) )505 (set! chicken.file.posix#open-input-file*506 (lambda (fd #!optional m (enc 'utf-8))507 (##sys#check-fixnum fd 'open-input-file*)508 (check 'open-input-file* fd #t (##core#inline_allocate ("C_fdopen" 2) fd (mode #t m 'open-input-file*)) enc)) )509 (set! chicken.file.posix#open-output-file*510 (lambda (fd #!optional m (enc 'utf-8))511 (##sys#check-fixnum fd 'open-output-file*)512 (check 'open-output-file* fd #f (##core#inline_allocate ("C_fdopen" 2) fd (mode #f m 'open-output-file*)) enc) ) ) )513514(set! chicken.file.posix#port->fileno515 (lambda (port)516 (##sys#check-open-port port 'port->fileno)517 (cond ((eq? 'socket (##sys#slot port 7))518 ;; Extract socket-FD from the port's "data" object - this is identical519 ;; to "##sys#tcp-port->fileno" in the tcp unit (tcp.scm). We code it in520 ;; this low-level manner to avoid depend on code defined there.521 ;; Peter agrees with that. I think. Have a nice day.522 (##sys#slot (##sys#port-data port) 0) )523 ((not (zero? (##sys#peek-unsigned-integer port 0)))524 (let ([fd (##core#inline "C_port_fileno" port)])525 (when (fx< fd 0)526 (posix-error #:file-error 'port->fileno "cannot access file-descriptor of port" port) )527 fd) )528 (else (posix-error #:type-error 'port->fileno "port has no attached file" port)) ) ) )529530(set! chicken.file.posix#duplicate-fileno531 (lambda (old . new)532 (##sys#check-fixnum old 'duplicate-fileno)533 (let ([fd (if (null? new)534 (##core#inline "C_dup" old)535 (let ([n (car new)])536 (##sys#check-fixnum n 'duplicate-fileno)537 (##core#inline "C_dup2" old n) ) ) ] )538 (when (fx< fd 0)539 (posix-error #:file-error 'duplicate-fileno "cannot duplicate file-descriptor" old) )540 fd) ) )541542543;;; Access process ID:544545(set! chicken.process-context.posix#current-process-id546 (foreign-lambda int "C_getpid"))547548549;;; Set or get current directory by file descriptor:550551(set! chicken.process-context.posix#change-directory*552 (lambda (fd)553 (##sys#check-fixnum fd 'change-directory*)554 (unless (fx= 0 (##core#inline "C_fchdir" fd))555 (posix-error #:file-error 'change-directory* "cannot change current directory" fd))556 fd))557558(set! ##sys#change-directory-hook559 (let ((cd ##sys#change-directory-hook))560 (lambda (dir)561 ((if (fixnum? dir)562 chicken.process-context.posix#change-directory*563 cd) dir))))564565;;; umask566567(set! chicken.file.posix#file-creation-mode568 (getter-with-setter569 (lambda (#!optional um)570 (when um (##sys#check-fixnum um 'file-creation-mode))571 (let ((um2 (##core#inline "C_umask" (or um 0))))572 (unless um (##core#inline "C_umask" um2)) ; restore573 um2))574 (lambda (um)575 (##sys#check-fixnum um 'file-creation-mode)576 (##core#inline "C_umask" um))577 "(chicken.file.posix#file-creation-mode mode)"))578579580;;; Time related things:581582(define decode-seconds (##core#primitive "C_decode_seconds"))583584(define (check-time-vector loc tm)585 (##sys#check-vector tm loc)586 (when (fx< (##sys#size tm) 10)587 (##sys#error loc "time vector too short" tm) ) )588589(set! chicken.time.posix#seconds->local-time590 (lambda (#!optional (secs (current-seconds)))591 (##sys#check-exact-integer secs 'seconds->local-time)592 (decode-seconds secs #f) ))593594(set! chicken.time.posix#seconds->utc-time595 (lambda (#!optional (secs (current-seconds)))596 (##sys#check-exact-integer secs 'seconds->utc-time)597 (decode-seconds secs #t) ) )598599(set! chicken.time.posix#seconds->string600 (let ([ctime (foreign-lambda c-string "C_ctime" integer)])601 (lambda (#!optional (secs (current-seconds)))602 (##sys#check-exact-integer secs 'seconds->string)603 (let ([str (ctime secs)])604 (if str605 (##sys#substring str 0 (fx- (string-length str) 1))606 (##sys#error 'seconds->string "cannot convert seconds to string" secs) ) ) ) ) )607608(set! chicken.time.posix#local-time->seconds609 (let ((tm-size (foreign-value "sizeof(struct tm)" int)))610 (lambda (tm)611 (check-time-vector 'local-time->seconds tm)612 (let ((t (##core#inline_allocate ("C_a_mktime" 7) tm (##sys#make-string tm-size #\nul))))613 (if (= -1 t)614 (##sys#error 'local-time->seconds "cannot convert time vector to seconds" tm)615 t)))))616617(set! chicken.time.posix#time->string618 (let ((asctime (foreign-lambda c-string "C_asctime" scheme-object scheme-pointer))619 (strftime (foreign-lambda c-string "C_strftime" scheme-object scheme-object scheme-pointer))620 (tm-size (foreign-value "sizeof(struct tm)" int)))621 (lambda (tm #!optional fmt)622 (check-time-vector 'time->string tm)623 (if fmt624 (begin625 (##sys#check-string fmt 'time->string)626 (or (strftime tm (##sys#make-c-string fmt 'time->string) (##sys#make-string tm-size #\nul))627 (##sys#error 'time->string "time formatting overflows buffer" tm)) )628 (let ([str (asctime tm (##sys#make-string tm-size #\nul))])629 (if str630 (##sys#substring str 0 (fx- (string-length str) 1))631 (##sys#error 'time->string "cannot convert time vector to string" tm) ) ) ) ) ) )632633634;;; Signals635636(set! chicken.process.signal#set-signal-handler! ; DEPRECATED637 (lambda (sig proc)638 (##sys#check-fixnum sig 'set-signal-handler!)639 (##core#inline "C_establish_signal_handler" sig (and proc sig))640 (vector-set! ##sys#signal-vector sig proc) ) )641642(set! chicken.process.signal#signal-handler ; DEPRECATED643 (getter-with-setter644 (lambda (sig)645 (##sys#check-fixnum sig 'signal-handler)646 (##sys#slot ##sys#signal-vector sig) )647 chicken.process.signal#set-signal-handler!648 "(chicken.process.signal#signal-handler sig)"))649650(set! chicken.process.signal#make-signal-handler651 (lambda sigs652 (let ((q (##sys#make-event-queue)))653 (for-each654 (lambda (sig)655 (##sys#check-fixnum sig 'make-signal-handler)656 (##core#inline "C_establish_signal_handler" sig sig)657 (vector-set! ##sys#signal-vector sig658 (lambda (sig) (##sys#add-event-to-queue! q sig))))659 sigs)660 (lambda (#!optional wait)661 (if wait662 (##sys#wait-for-next-event q)663 (##sys#get-next-event q))))))664665(set! chicken.process.signal#signal-ignore666 (lambda (sig)667 (##sys#check-fixnum sig 'signal-ignore)668 (##core#inline "C_establish_signal_handler" sig #f)669 (vector-set! ##sys#signal-vector sig #f)))670671(set! chicken.process.signal#signal-default672 (lambda (sig)673 (##sys#check-fixnum sig 'signal-default)674 (##core#inline "C_establish_signal_handler" sig #t)675 (vector-set! ##sys#signal-vector sig #f)))676677678;;; Processes679680(define children '())681682(define-record process683 id returned-normally? input-port output-port error-port exit-status)684685(define (get-pid x #!optional default)686 (cond ((fixnum? x) x)687 ((process? x) (process-id x))688 (else default)))689690(define (register-pid pid)691 (let ((p (make-process pid #f #f #f #f #f)))692 (set! children (cons (cons pid p) children))693 p))694695(define (drop-child pid)696 (set! children697 (let rec ((cs children))698 (cond ((null? cs) '())699 ((eq? pid (caar cs)) (cdr cs))700 (else (rec (cdr cs)))))))701702(set! chicken.process#process? process?)703(set! chicken.process#process-id process-id)704(set! chicken.process#process-exit-status process-exit-status)705(set! chicken.process#process-returned-normally? process-returned-normally?)706(set! chicken.process#process-input-port process-input-port)707(set! chicken.process#process-output-port process-output-port)708(set! chicken.process#process-error-port process-error-port)709710(set! chicken.process#process-sleep711 (lambda (n)712 (##sys#check-fixnum n 'process-sleep)713 (##core#inline "C_i_process_sleep" n)))714715(set! chicken.process#process-wait716 (lambda args717 (let-optionals* args ((proc #f) (nohang #f))718 (if (and (process? proc) (process-exit-status proc))719 (values (process-id proc)720 (process-returned-normally? proc)721 (process-exit-status proc))722 (let ((pid (get-pid proc -1)))723 (##sys#check-fixnum pid 'process-wait)724 (receive (epid enorm ecode) (process-wait-impl pid nohang)725 (cond726 ((fx= epid -1)727 (posix-error #:process-error 'process-wait728 "waiting for child process failed" pid))729 ((fx= epid 0)730 (values 0 #f #f))731 (else732 (unless (process? proc)733 (let ((a (assq epid children)))734 (when a735 (set! proc (cdr a)))))736 (drop-child epid)737 (when (process? proc)738 (process-returned-normally?-set! proc enorm)739 (process-exit-status-set! proc ecode))740 (values epid enorm ecode))) ) )) ) ) )741742;; This can construct argv or envp for process-execute or process-run743(define list->c-string-buffer744 (lambda (string-list convert loc)745 (##sys#check-list string-list loc)746747 (let* ((string-count (##sys#length string-list))748 ;; NUL-terminated, so we must add one749 (buffer (make-pointer-vector (add1 string-count) #f)))750751 (handle-exceptions exn752 ;; Free to avoid memory leak, then reraise753 (begin (free-c-string-buffer buffer) (signal exn))754755 (do ((sl string-list (cdr sl))756 (i 0 (fx+ i 1)))757 ((or (null? sl) (fx= i string-count))) ; Should coincide758759 (##sys#check-string (car sl) loc)760 ;; This avoids embedded NULs and appends a NUL, so "cs" is761 ;; safe to copy and use as-is in the pointer-vector.762 (let* ((cs (##sys#make-c-string (convert (car sl)) loc))763 (csp (c-string->allocated-pointer cs)))764 (unless csp (error loc "Out of memory"))765 (pointer-vector-set! buffer i csp)))766767 buffer))))768769(define (free-c-string-buffer buffer-array)770 (let ((size (pointer-vector-length buffer-array)))771 (do ((i 0 (fx+ i 1)))772 ((fx= i size))773 (and-let* ((s (pointer-vector-ref buffer-array i)))774 (free s)))))775776;; Environments are represented as string->string association lists777(define (check-environment-list lst loc)778 (##sys#check-list lst loc)779 (for-each780 (lambda (p)781 (##sys#check-pair p loc)782 (##sys#check-string (car p) loc)783 (##sys#check-string (cdr p) loc))784 lst))785786(define call-with-exec-args787 (let ((nop (lambda (x) x)))788 (lambda (loc filename argconv arglist envlist proc)789 (let* ((args (cons filename arglist)) ; Add argv[0]790 (argbuf (list->c-string-buffer args argconv loc))791 (envbuf #f))792793 (handle-exceptions exn794 ;; Free to avoid memory leak, then reraise795 (begin (free-c-string-buffer argbuf)796 (when envbuf (free-c-string-buffer envbuf))797 (signal exn))798799 ;; Envlist is never converted, so we always use nop here800 (when envlist801 (check-environment-list envlist loc)802 (set! envbuf803 (list->c-string-buffer804 (map (lambda (p) (string-append (car p) "=" (cdr p))) envlist)805 nop loc)))806807 (proc (##sys#make-c-string filename loc) argbuf envbuf))))))808809;; Pipes:810811(define-foreign-variable _pipe_buf int "PIPE_BUF")812(set! chicken.process#pipe/buf _pipe_buf)813814(let ()815 (define (mode arg) (if (pair? arg) (##sys#slot arg 0) #:text))816 (define (badmode m) (##sys#error "illegal input/output mode specifier" m))817 (define (check loc cmd inp r)818 (if (##sys#null-pointer? r)819 (posix-error #:file-error loc "cannot open pipe" cmd)820 (let ((port (##sys#make-port (if inp 1 2) ##sys#stream-port-class "(pipe)" 'stream)))821 (##core#inline "C_set_file_ptr" port r)822 port) ) )823 (set! chicken.process#open-input-pipe824 (lambda (cmd . m)825 (##sys#check-string cmd 'open-input-pipe)826 (let ([m (mode m)])827 (check828 'open-input-pipe829 cmd #t830 (case m831 ((#:text) (##core#inline_allocate ("open_text_input_pipe" 2) (##sys#make-c-string cmd 'open-input-pipe)))832 ((#:binary) (##core#inline_allocate ("open_binary_input_pipe" 2) (##sys#make-c-string cmd 'open-input-pipe)))833 (else (badmode m)) ) ) ) ) )834 (set! chicken.process#open-output-pipe835 (lambda (cmd . m)836 (##sys#check-string cmd 'open-output-pipe)837 (let ((m (mode m)))838 (check839 'open-output-pipe840 cmd #f841 (case m842 ((#:text) (##core#inline_allocate ("open_text_output_pipe" 2) (##sys#make-c-string cmd 'open-output-pipe)))843 ((#:binary) (##core#inline_allocate ("open_binary_output_pipe" 2) (##sys#make-c-string cmd 'open-output-pipe)))844 (else (badmode m)) ) ) ) ) )845 (set! chicken.process#close-input-pipe846 (lambda (port)847 (##sys#check-input-port port #t 'close-input-pipe)848 (let ((r (##core#inline "close_pipe" port)))849 (when (eq? -1 r)850 (posix-error #:file-error 'close-input-pipe "error while closing pipe" port))851 r) ) )852 (set! chicken.process#close-output-pipe853 (lambda (port)854 (##sys#check-output-port port #t 'close-output-pipe)855 (let ((r (##core#inline "close_pipe" port)))856 (when (eq? -1 r)857 (posix-error #:file-error 'close-output-pipe "error while closing pipe" port))858 r) ) ))859860(set! chicken.process#with-input-from-pipe861 (lambda (cmd thunk . mode)862 (let ((p (apply chicken.process#open-input-pipe cmd mode)))863 (fluid-let ((##sys#standard-input p))864 (call-with-values thunk865 (lambda results866 (chicken.process#close-input-pipe p)867 (apply values results) ) ) ) ) ) )868869(set! chicken.process#call-with-output-pipe870 (lambda (cmd proc . mode)871 (let ((p (apply chicken.process#open-output-pipe cmd mode)))872 (call-with-values873 (lambda () (proc p))874 (lambda results875 (chicken.process#close-output-pipe p)876 (apply values results) ) ) ) ) )877878(set! chicken.process#call-with-input-pipe879 (lambda (cmd proc . mode)880 (let ([p (apply chicken.process#open-input-pipe cmd mode)])881 (call-with-values882 (lambda () (proc p))883 (lambda results884 (chicken.process#close-input-pipe p)885 (apply values results) ) ) ) ) )886887(set! chicken.process#with-output-to-pipe888 (lambda (cmd thunk . mode)889 (let ((p (apply chicken.process#open-output-pipe cmd mode)))890 (fluid-let ((##sys#standard-output p))891 (call-with-values thunk892 (lambda results893 (chicken.process#close-output-pipe p)894 (apply values results) ) ) ) ) ) )