~ chicken-core (chicken-5) /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; }3435static C_TLS struct stat C_statbuf;3637#define C_stat_type (C_statbuf.st_mode & S_IFMT)38#define C_stat_perm (C_statbuf.st_mode & ~S_IFMT)3940#define C_u_i_stat(fn) C_fix(C_stat(C_c_string(fn), &C_statbuf))41#define C_u_i_fstat(fd) C_fix(fstat(C_unfix(fd), &C_statbuf))4243#ifndef S_IFSOCK44# define S_IFSOCK 014000045#endif4647#ifndef S_IRUSR48# define S_IRUSR S_IREAD49#endif50#ifndef S_IWUSR51# define S_IWUSR S_IWRITE52#endif53#ifndef S_IXUSR54# define S_IXUSR S_IEXEC55#endif5657#ifndef S_IRGRP58# define S_IRGRP S_IREAD59#endif60#ifndef S_IWGRP61# define S_IWGRP S_IWRITE62#endif63#ifndef S_IXGRP64# define S_IXGRP S_IEXEC65#endif6667#ifndef S_IROTH68# define S_IROTH S_IREAD69#endif70#ifndef S_IWOTH71# define S_IWOTH S_IWRITE72#endif73#ifndef S_IXOTH74# define S_IXOTH S_IEXEC75#endif7677#define cpy_tmvec_to_tmstc08(ptm, v) \78 ((ptm)->tm_sec = C_unfix(C_block_item((v), 0)), \79 (ptm)->tm_min = C_unfix(C_block_item((v), 1)), \80 (ptm)->tm_hour = C_unfix(C_block_item((v), 2)), \81 (ptm)->tm_mday = C_unfix(C_block_item((v), 3)), \82 (ptm)->tm_mon = C_unfix(C_block_item((v), 4)), \83 (ptm)->tm_year = C_unfix(C_block_item((v), 5)), \84 (ptm)->tm_wday = C_unfix(C_block_item((v), 6)), \85 (ptm)->tm_yday = C_unfix(C_block_item((v), 7)), \86 (ptm)->tm_isdst = (C_block_item((v), 8) != C_SCHEME_FALSE))8788#define cpy_tmvec_to_tmstc9(ptm, v) \89 (((struct tm *)ptm)->tm_gmtoff = -C_unfix(C_block_item((v), 9)))9091#define C_tm_set_08(v, tm) cpy_tmvec_to_tmstc08( (tm), (v) )92#define C_tm_set_9(v, tm) cpy_tmvec_to_tmstc9( (tm), (v) )9394static struct tm *95C_tm_set( C_word v, void *tm )96{97 C_tm_set_08( v, (struct tm *)tm );98#if defined(C_GNU_ENV) && !defined(__CYGWIN__) && !defined(__uClinux__)99 C_tm_set_9( v, (struct tm *)tm );100#endif101 return tm;102}103104#define TIME_STRING_MAXLENGTH 255105static char C_time_string [TIME_STRING_MAXLENGTH + 1];106#undef TIME_STRING_MAXLENGTH107108#define C_strftime(v, f, tm) \109 (strftime(C_time_string, sizeof(C_time_string), C_c_string(f), C_tm_set((v), (tm))) ? C_time_string : NULL)110#define C_a_mktime(ptr, c, v, tm) C_int64_to_num(ptr, mktime(C_tm_set((v), C_data_pointer(tm))))111#define C_asctime(v, tm) (asctime(C_tm_set((v), (tm))))112113#define C_fdopen(a, n, fd, m) C_mpointer(a, fdopen(C_unfix(fd), C_c_string(m)))114#define C_dup(x) C_fix(dup(C_unfix(x)))115#define C_dup2(x, y) C_fix(dup2(C_unfix(x), C_unfix(y)))116117#define C_set_file_ptr(port, ptr) (C_set_block_item(port, 0, (C_block_item(ptr, 0))), C_SCHEME_UNDEFINED)118119/* It is assumed that 'int' is-a 'long' */120#define C_ftell(a, n, p) C_int64_to_num(a, ftell(C_port_file(p)))121#define C_fseek(p, n, w) C_mk_nbool(fseek(C_port_file(p), C_num_to_int64(n), C_unfix(w)))122#define C_lseek(fd, o, w) C_fix(lseek(C_unfix(fd), C_num_to_int64(o), C_unfix(w)))123124EOF125))126127(include "common-declarations.scm")128129(define-syntax define-unimplemented130 (syntax-rules ()131 ((_ ?name)132 (define (?name . _)133 (error '?name (##core#immutable '"this function is not available on this platform")) ) ) ) )134135(define-syntax set!-unimplemented136 (syntax-rules ()137 ((_ ?name)138 (set! ?name139 (lambda _140 (error '?name (##core#immutable '"this function is not available on this platform"))) ) ) ) )141142143;;; Error codes:144145(define-foreign-variable _errno int "errno")146147(define-foreign-variable _eperm int "EPERM")148(define-foreign-variable _enoent int "ENOENT")149(define-foreign-variable _esrch int "ESRCH")150(define-foreign-variable _eintr int "EINTR")151(define-foreign-variable _eio int "EIO")152(define-foreign-variable _enoexec int "ENOEXEC")153(define-foreign-variable _ebadf int "EBADF")154(define-foreign-variable _echild int "ECHILD")155(define-foreign-variable _enomem int "ENOMEM")156(define-foreign-variable _eacces int "EACCES")157(define-foreign-variable _efault int "EFAULT")158(define-foreign-variable _ebusy int "EBUSY")159(define-foreign-variable _eexist int "EEXIST")160(define-foreign-variable _enotdir int "ENOTDIR")161(define-foreign-variable _eisdir int "EISDIR")162(define-foreign-variable _einval int "EINVAL")163(define-foreign-variable _emfile int "EMFILE")164(define-foreign-variable _enospc int "ENOSPC")165(define-foreign-variable _espipe int "ESPIPE")166(define-foreign-variable _epipe int "EPIPE")167(define-foreign-variable _eagain int "EAGAIN")168(define-foreign-variable _erofs int "EROFS")169(define-foreign-variable _enxio int "ENXIO")170(define-foreign-variable _e2big int "E2BIG")171(define-foreign-variable _exdev int "EXDEV")172(define-foreign-variable _enodev int "ENODEV")173(define-foreign-variable _enfile int "ENFILE")174(define-foreign-variable _enotty int "ENOTTY")175(define-foreign-variable _efbig int "EFBIG")176(define-foreign-variable _emlink int "EMLINK")177(define-foreign-variable _edom int "EDOM")178(define-foreign-variable _erange int "ERANGE")179(define-foreign-variable _edeadlk int "EDEADLK")180(define-foreign-variable _enametoolong int "ENAMETOOLONG")181(define-foreign-variable _enolck int "ENOLCK")182(define-foreign-variable _enosys int "ENOSYS")183(define-foreign-variable _enotempty int "ENOTEMPTY")184(define-foreign-variable _eilseq int "EILSEQ")185(define-foreign-variable _ewouldblock int "EWOULDBLOCK")186187(define posix-error188 (let ([strerror (foreign-lambda c-string "strerror" int)]189 [string-append string-append] )190 (lambda (type loc msg . args)191 (let ([rn (##sys#update-errno)])192 (apply ##sys#signal-hook/errno193 type rn loc (string-append msg " - " (strerror rn)) args)))))194195(define ##sys#posix-error posix-error)196197198;;; File properties199200(define-foreign-variable _stat_st_ino unsigned-int "C_statbuf.st_ino")201(define-foreign-variable _stat_st_nlink unsigned-int "C_statbuf.st_nlink")202(define-foreign-variable _stat_st_gid unsigned-int "C_statbuf.st_gid")203(define-foreign-variable _stat_st_size integer64 "C_statbuf.st_size")204(define-foreign-variable _stat_st_mtime integer64 "C_statbuf.st_mtime")205(define-foreign-variable _stat_st_atime integer64 "C_statbuf.st_atime")206(define-foreign-variable _stat_st_ctime integer64 "C_statbuf.st_ctime")207(define-foreign-variable _stat_st_uid unsigned-int "C_statbuf.st_uid")208(define-foreign-variable _stat_st_mode unsigned-int "C_statbuf.st_mode")209(define-foreign-variable _stat_st_dev unsigned-int "C_statbuf.st_dev")210(define-foreign-variable _stat_st_rdev unsigned-int "C_statbuf.st_rdev")211212(define-syntax stat-mode213 (er-macro-transformer214 (lambda (x r c)215 ;; no need to rename here216 (let* ((mode (cadr x))217 (name (symbol->string mode)))218 `(##core#begin219 (declare220 (foreign-declare221 ,(string-append "#ifndef " name "\n"222 "#define " name " S_IFREG\n"223 "#endif\n")))224 (define-foreign-variable ,mode unsigned-int))))))225226(stat-mode S_IFLNK)227(stat-mode S_IFREG)228(stat-mode S_IFDIR)229(stat-mode S_IFCHR)230(stat-mode S_IFBLK)231(stat-mode S_IFSOCK)232(stat-mode S_IFIFO)233234(define (stat file link err loc)235 (let ((r (cond ((fixnum? file) (##core#inline "C_u_i_fstat" file))236 ((port? file) (##core#inline "C_u_i_fstat" (chicken.file.posix#port->fileno file)))237 ((string? file)238 (let ((path (##sys#make-c-string file loc)))239 (if link240 (##core#inline "C_u_i_lstat" path)241 (##core#inline "C_u_i_stat" path))))242 (else243 (##sys#signal-hook244 #:type-error loc "bad argument type - not a fixnum, port or string" file)) ) ) )245 (if (fx< r 0)246 (if err247 (posix-error #:file-error loc "cannot access file" file)248 #f)249 #t)))250251(set! chicken.file.posix#file-stat252 (lambda (f #!optional link)253 (stat f link #t 'file-stat)254 (vector _stat_st_ino _stat_st_mode _stat_st_nlink255 _stat_st_uid _stat_st_gid _stat_st_size256 _stat_st_atime _stat_st_ctime _stat_st_mtime257 _stat_st_dev _stat_st_rdev258 _stat_st_blksize _stat_st_blocks) ) )259260(set! chicken.file.posix#set-file-permissions!261 (lambda (f p)262 (##sys#check-fixnum p 'set-file-permissions!)263 (let ((r (cond ((fixnum? f) (##core#inline "C_fchmod" f p))264 ((port? f) (##core#inline "C_fchmod" (chicken.file.posix#port->fileno f) p))265 ((string? f)266 (##core#inline "C_chmod"267 (##sys#make-c-string f 'set-file-permissions!) p))268 (else269 (##sys#signal-hook270 #:type-error 'file-permissions271 "bad argument type - not a fixnum, port or string" f)) ) ) )272 (when (fx< r 0)273 (posix-error #:file-error 'set-file-permissions! "cannot change file permissions" f p) ) )))274275(set! chicken.file.posix#file-modification-time276 (lambda (f)277 (stat f #f #t 'file-modification-time)278 _stat_st_mtime))279(set! chicken.file.posix#file-access-time280 (lambda (f)281 (stat f #f #t 'file-access-time)282 _stat_st_atime))283(set! chicken.file.posix#file-change-time284 (lambda (f)285 (stat f #f #t 'file-change-time)286 _stat_st_ctime))287288(set! chicken.file.posix#set-file-times!289 (lambda (f . rest)290 (let-optionals* rest ((atime (current-seconds)) (mtime atime))291 (when atime (##sys#check-exact-integer atime 'set-file-times!))292 (when mtime (##sys#check-exact-integer mtime 'set-file-times!))293 (let ((r ((foreign-lambda int "set_file_mtime"294 c-string scheme-object scheme-object)295 f atime mtime)))296 (when (fx< r 0)297 (apply posix-error298 #:file-error299 'set-file-times! "cannot set file times" f rest))))))300301(set! chicken.file.posix#file-size302 (lambda (f) (stat f #f #t 'file-size) _stat_st_size))303304(set! chicken.file.posix#set-file-owner!305 (lambda (f uid)306 (chown 'set-file-owner! f uid -1)))307308(set! chicken.file.posix#set-file-group!309 (lambda (f gid)310 (chown 'set-file-group! f -1 gid)))311312(set! chicken.file.posix#file-owner313 (getter-with-setter314 (lambda (f) (stat f #f #t 'file-owner) _stat_st_uid)315 chicken.file.posix#set-file-owner!316 "(chicken.file.posix#file-owner f)") )317318(set! chicken.file.posix#file-group319 (getter-with-setter320 (lambda (f) (stat f #f #t 'file-group) _stat_st_gid)321 chicken.file.posix#set-file-group!322 "(chicken.file.posix#file-group f)") )323324(set! chicken.file.posix#file-permissions325 (getter-with-setter326 (lambda (f)327 (stat f #f #t 'file-permissions)328 (foreign-value "C_stat_perm" unsigned-int))329 chicken.file.posix#set-file-permissions!330 "(chicken.file.posix#file-permissions f)"))331332(set! chicken.file.posix#file-type333 (lambda (file #!optional link (err #t))334 (and (stat file link err 'file-type)335 (let ((res (foreign-value "C_stat_type" unsigned-int)))336 (cond337 ((fx= res S_IFREG) 'regular-file)338 ((fx= res S_IFLNK) 'symbolic-link)339 ((fx= res S_IFDIR) 'directory)340 ((fx= res S_IFCHR) 'character-device)341 ((fx= res S_IFBLK) 'block-device)342 ((fx= res S_IFIFO) 'fifo)343 ((fx= res S_IFSOCK) 'socket)344 (else 'regular-file))))))345346(set! chicken.file.posix#regular-file?347 (lambda (file)348 (eq? 'regular-file (chicken.file.posix#file-type file #f #f))))349350(set! chicken.file.posix#symbolic-link?351 (lambda (file)352 (eq? 'symbolic-link (chicken.file.posix#file-type file #t #f))))353354(set! chicken.file.posix#block-device?355 (lambda (file)356 (eq? 'block-device (chicken.file.posix#file-type file #f #f))))357358(set! chicken.file.posix#character-device?359 (lambda (file)360 (eq? 'character-device (chicken.file.posix#file-type file #f #f))))361362(set! chicken.file.posix#fifo?363 (lambda (file)364 (eq? 'fifo (chicken.file.posix#file-type file #f #f))))365366(set! chicken.file.posix#socket?367 (lambda (file)368 (eq? 'socket (chicken.file.posix#file-type file #f #f))))369370(set! chicken.file.posix#directory?371 (lambda (file)372 (eq? 'directory (chicken.file.posix#file-type file #f #f))))373374375;;; File position access:376377(define-foreign-variable _seek_set int "SEEK_SET")378(define-foreign-variable _seek_cur int "SEEK_CUR")379(define-foreign-variable _seek_end int "SEEK_END")380381(set! chicken.file.posix#seek/set _seek_set)382(set! chicken.file.posix#seek/end _seek_end)383(set! chicken.file.posix#seek/cur _seek_cur)384385(set! chicken.file.posix#set-file-position!386 (lambda (port pos . whence)387 (let ((whence (if (pair? whence) (car whence) _seek_set)))388 (##sys#check-fixnum pos 'set-file-position!)389 (##sys#check-fixnum whence 'set-file-position!)390 (unless (cond ((port? port)391 (and-let* ((stream (eq? (##sys#slot port 7) 'stream))392 (res (##core#inline "C_fseek" port pos whence)))393 (##sys#setislot port 6 #f) ;; Reset EOF status394 res))395 ((fixnum? port)396 (##core#inline "C_lseek" port pos whence))397 (else398 (##sys#signal-hook #:type-error 'set-file-position! "invalid file" port)) )399 (posix-error #:file-error 'set-file-position! "cannot set file position" port pos) ) ) ) )400401(set! chicken.file.posix#file-position402 (getter-with-setter403 (lambda (port)404 (let ((pos (cond ((port? port)405 (if (eq? (##sys#slot port 7) 'stream)406 (##core#inline_allocate ("C_ftell" 7) port)407 -1) )408 ((fixnum? port)409 (##core#inline "C_lseek" port 0 _seek_cur) )410 (else411 (##sys#signal-hook #:type-error 'file-position "invalid file" port)) ) ) )412 (when (< pos 0)413 (posix-error #:file-error 'file-position "cannot retrieve file position of port" port) )414 pos) )415 chicken.file.posix#set-file-position! ; doesn't accept WHENCE416 "(chicken.file.posix#file-position port)"))417418419;;; Using file-descriptors:420421(define-foreign-variable _stdin_fileno int "STDIN_FILENO")422(define-foreign-variable _stdout_fileno int "STDOUT_FILENO")423(define-foreign-variable _stderr_fileno int "STDERR_FILENO")424425(set! chicken.file.posix#fileno/stdin _stdin_fileno)426(set! chicken.file.posix#fileno/stdout _stdout_fileno)427(set! chicken.file.posix#fileno/stderr _stderr_fileno)428429(define-foreign-variable _o_rdonly int "O_RDONLY")430(define-foreign-variable _o_wronly int "O_WRONLY")431(define-foreign-variable _o_rdwr int "O_RDWR")432(define-foreign-variable _o_creat int "O_CREAT")433(define-foreign-variable _o_append int "O_APPEND")434(define-foreign-variable _o_excl int "O_EXCL")435(define-foreign-variable _o_trunc int "O_TRUNC")436(define-foreign-variable _o_binary int "O_BINARY")437(define-foreign-variable _o_text int "O_TEXT")438439(set! chicken.file.posix#open/rdonly _o_rdonly)440(set! chicken.file.posix#open/wronly _o_wronly)441(set! chicken.file.posix#open/rdwr _o_rdwr)442(set! chicken.file.posix#open/read _o_rdonly)443(set! chicken.file.posix#open/write _o_wronly)444(set! chicken.file.posix#open/creat _o_creat)445(set! chicken.file.posix#open/append _o_append)446(set! chicken.file.posix#open/excl _o_excl)447(set! chicken.file.posix#open/trunc _o_trunc)448(set! chicken.file.posix#open/binary _o_binary)449(set! chicken.file.posix#open/text _o_text)450451;; open/noinherit is platform-specific452453(define-foreign-variable _s_irusr int "S_IRUSR")454(define-foreign-variable _s_iwusr int "S_IWUSR")455(define-foreign-variable _s_ixusr int "S_IXUSR")456(define-foreign-variable _s_irgrp int "S_IRGRP")457(define-foreign-variable _s_iwgrp int "S_IWGRP")458(define-foreign-variable _s_ixgrp int "S_IXGRP")459(define-foreign-variable _s_iroth int "S_IROTH")460(define-foreign-variable _s_iwoth int "S_IWOTH")461(define-foreign-variable _s_ixoth int "S_IXOTH")462(define-foreign-variable _s_irwxu int "S_IRUSR | S_IWUSR | S_IXUSR")463(define-foreign-variable _s_irwxg int "S_IRGRP | S_IWGRP | S_IXGRP")464(define-foreign-variable _s_irwxo int "S_IROTH | S_IWOTH | S_IXOTH")465466(set! chicken.file.posix#perm/irusr _s_irusr)467(set! chicken.file.posix#perm/iwusr _s_iwusr)468(set! chicken.file.posix#perm/ixusr _s_ixusr)469(set! chicken.file.posix#perm/irgrp _s_irgrp)470(set! chicken.file.posix#perm/iwgrp _s_iwgrp)471(set! chicken.file.posix#perm/ixgrp _s_ixgrp)472(set! chicken.file.posix#perm/iroth _s_iroth)473(set! chicken.file.posix#perm/iwoth _s_iwoth)474(set! chicken.file.posix#perm/ixoth _s_ixoth)475(set! chicken.file.posix#perm/irwxu _s_irwxu)476(set! chicken.file.posix#perm/irwxg _s_irwxg)477(set! chicken.file.posix#perm/irwxo _s_irwxo)478479;; perm/isvtx, perm/isuid and perm/isgid are platform-specific480481(let ()482 (define (mode inp m loc)483 (##sys#make-c-string484 (cond ((pair? m)485 (let ([m (car m)])486 (case m487 ((#:append) (if (not inp) "a" (##sys#error "invalid mode for input file" m)))488 (else (##sys#error "invalid mode argument" m)) ) ) )489 [inp "r"]490 [else "w"] )491 loc) )492 (define (check loc fd inp r)493 (if (##sys#null-pointer? r)494 (posix-error #:file-error loc "cannot open file" fd)495 (let ((port (##sys#make-port (if inp 1 2) ##sys#stream-port-class "(fdport)" 'stream)))496 (##core#inline "C_set_file_ptr" port r)497 port) ) )498 (set! chicken.file.posix#open-input-file*499 (lambda (fd . m)500 (##sys#check-fixnum fd 'open-input-file*)501 (check 'open-input-file* fd #t (##core#inline_allocate ("C_fdopen" 2) fd (mode #t m 'open-input-file*))) ) )502 (set! chicken.file.posix#open-output-file*503 (lambda (fd . m)504 (##sys#check-fixnum fd 'open-output-file*)505 (check 'open-output-file* fd #f (##core#inline_allocate ("C_fdopen" 2) fd (mode #f m 'open-output-file*)) ) ) ) )506507(set! chicken.file.posix#port->fileno508 (lambda (port)509 (##sys#check-open-port port 'port->fileno)510 (cond ((eq? 'socket (##sys#slot port 7))511 ;; Extract socket-FD from the port's "data" object - this is identical512 ;; to "##sys#tcp-port->fileno" in the tcp unit (tcp.scm). We code it in513 ;; this low-level manner to avoid depend on code defined there.514 ;; Peter agrees with that. I think. Have a nice day.515 (##sys#slot (##sys#port-data port) 0) )516 ((not (zero? (##sys#peek-unsigned-integer port 0)))517 (let ([fd (##core#inline "C_port_fileno" port)])518 (when (fx< fd 0)519 (posix-error #:file-error 'port->fileno "cannot access file-descriptor of port" port) )520 fd) )521 (else (posix-error #:type-error 'port->fileno "port has no attached file" port)) ) ) )522523(set! chicken.file.posix#duplicate-fileno524 (lambda (old . new)525 (##sys#check-fixnum old 'duplicate-fileno)526 (let ([fd (if (null? new)527 (##core#inline "C_dup" old)528 (let ([n (car new)])529 (##sys#check-fixnum n 'duplicate-fileno)530 (##core#inline "C_dup2" old n) ) ) ] )531 (when (fx< fd 0)532 (posix-error #:file-error 'duplicate-fileno "cannot duplicate file-descriptor" old) )533 fd) ) )534535536;;; Access process ID:537538(set! chicken.process-context.posix#current-process-id539 (foreign-lambda int "C_getpid"))540541542;;; Set or get current directory by file descriptor:543544(set! chicken.process-context.posix#change-directory*545 (lambda (fd)546 (##sys#check-fixnum fd 'change-directory*)547 (unless (fx= 0 (##core#inline "C_fchdir" fd))548 (posix-error #:file-error 'change-directory* "cannot change current directory" fd))549 fd))550551(set! ##sys#change-directory-hook552 (let ((cd ##sys#change-directory-hook))553 (lambda (dir)554 ((if (fixnum? dir)555 chicken.process-context.posix#change-directory*556 cd) dir))))557558;;; umask559560(set! chicken.file.posix#file-creation-mode561 (getter-with-setter562 (lambda (#!optional um)563 (when um (##sys#check-fixnum um 'file-creation-mode))564 (let ((um2 (##core#inline "C_umask" (or um 0))))565 (unless um (##core#inline "C_umask" um2)) ; restore566 um2))567 (lambda (um)568 (##sys#check-fixnum um 'file-creation-mode)569 (##core#inline "C_umask" um))570 "(chicken.file.posix#file-creation-mode mode)"))571572573;;; Time related things:574575(define decode-seconds (##core#primitive "C_decode_seconds"))576577(define (check-time-vector loc tm)578 (##sys#check-vector tm loc)579 (when (fx< (##sys#size tm) 10)580 (##sys#error loc "time vector too short" tm) ) )581582(set! chicken.time.posix#seconds->local-time583 (lambda (#!optional (secs (current-seconds)))584 (##sys#check-exact-integer secs 'seconds->local-time)585 (decode-seconds secs #f) ))586587(set! chicken.time.posix#seconds->utc-time588 (lambda (#!optional (secs (current-seconds)))589 (##sys#check-exact-integer secs 'seconds->utc-time)590 (decode-seconds secs #t) ) )591592(set! chicken.time.posix#seconds->string593 (let ([ctime (foreign-lambda c-string "C_ctime" integer)])594 (lambda (#!optional (secs (current-seconds)))595 (##sys#check-exact-integer secs 'seconds->string)596 (let ([str (ctime secs)])597 (if str598 (##sys#substring str 0 (fx- (##sys#size str) 1))599 (##sys#error 'seconds->string "cannot convert seconds to string" secs) ) ) ) ) )600601(set! chicken.time.posix#local-time->seconds602 (let ((tm-size (foreign-value "sizeof(struct tm)" int)))603 (lambda (tm)604 (check-time-vector 'local-time->seconds tm)605 (let ((t (##core#inline_allocate ("C_a_mktime" 7) tm (##sys#make-string tm-size #\nul))))606 (if (= -1 t)607 (##sys#error 'local-time->seconds "cannot convert time vector to seconds" tm)608 t)))))609610(set! chicken.time.posix#time->string611 (let ((asctime (foreign-lambda c-string "C_asctime" scheme-object scheme-pointer))612 (strftime (foreign-lambda c-string "C_strftime" scheme-object scheme-object scheme-pointer))613 (tm-size (foreign-value "sizeof(struct tm)" int)))614 (lambda (tm #!optional fmt)615 (check-time-vector 'time->string tm)616 (if fmt617 (begin618 (##sys#check-string fmt 'time->string)619 (or (strftime tm (##sys#make-c-string fmt 'time->string) (##sys#make-string tm-size #\nul))620 (##sys#error 'time->string "time formatting overflows buffer" tm)) )621 (let ([str (asctime tm (##sys#make-string tm-size #\nul))])622 (if str623 (##sys#substring str 0 (fx- (##sys#size str) 1))624 (##sys#error 'time->string "cannot convert time vector to string" tm) ) ) ) ) ) )625626627;;; Signals628629(set! chicken.process.signal#set-signal-handler! ; DEPRECATED630 (lambda (sig proc)631 (##sys#check-fixnum sig 'set-signal-handler!)632 (##core#inline "C_establish_signal_handler" sig (and proc sig))633 (vector-set! ##sys#signal-vector sig proc) ) )634635(set! chicken.process.signal#signal-handler ; DEPRECATED636 (getter-with-setter637 (lambda (sig)638 (##sys#check-fixnum sig 'signal-handler)639 (##sys#slot ##sys#signal-vector sig) )640 chicken.process.signal#set-signal-handler!641 "(chicken.process.signal#signal-handler sig)"))642643(set! chicken.process.signal#make-signal-handler644 (lambda sigs645 (let ((q (##sys#make-event-queue)))646 (for-each647 (lambda (sig)648 (##sys#check-fixnum sig 'make-signal-handler)649 (##core#inline "C_establish_signal_handler" sig sig)650 (vector-set! ##sys#signal-vector sig651 (lambda (sig) (##sys#add-event-to-queue! q sig))))652 sigs)653 (lambda (#!optional wait)654 (if wait655 (##sys#wait-for-next-event q)656 (##sys#get-next-event q))))))657658(set! chicken.process.signal#signal-ignore659 (lambda (sig)660 (##sys#check-fixnum sig 'signal-ignore)661 (##core#inline "C_establish_signal_handler" sig #f)662 (vector-set! ##sys#signal-vector sig #f)))663664(set! chicken.process.signal#signal-default665 (lambda (sig)666 (##sys#check-fixnum sig 'signal-default)667 (##core#inline "C_establish_signal_handler" sig #t)668 (vector-set! ##sys#signal-vector sig #f)))669670671;;; Processes672673(set! chicken.process#process-sleep674 (lambda (n)675 (##sys#check-fixnum n 'process-sleep)676 (##core#inline "C_i_process_sleep" n)))677678(set! chicken.process#process-wait679 (lambda args680 (let-optionals* args ((pid #f) (nohang #f))681 (let ((pid (or pid -1)))682 (##sys#check-fixnum pid 'process-wait)683 (receive (epid enorm ecode) (process-wait-impl pid nohang)684 (if (fx= epid -1)685 (posix-error #:process-error 'process-wait "waiting for child process failed" pid)686 (values epid enorm ecode) ) ) ) ) ) )687688;; This can construct argv or envp for process-execute or process-run689(define list->c-string-buffer690 (let ((c-string->allocated-pointer691 (foreign-lambda* c-pointer ((scheme-object o))692 "char *ptr = C_malloc(C_header_size(o)); \n"693 "if (ptr != NULL) {\n"694 " C_memcpy(ptr, C_data_pointer(o), C_header_size(o)); \n"695 "}\n"696 "C_return(ptr);")))697 (lambda (string-list convert loc)698 (##sys#check-list string-list loc)699700 (let* ((string-count (##sys#length string-list))701 ;; NUL-terminated, so we must add one702 (buffer (make-pointer-vector (add1 string-count) #f)))703704 (handle-exceptions exn705 ;; Free to avoid memory leak, then reraise706 (begin (free-c-string-buffer buffer) (signal exn))707708 (do ((sl string-list (cdr sl))709 (i 0 (fx+ i 1)))710 ((or (null? sl) (fx= i string-count))) ; Should coincide711712 (##sys#check-string (car sl) loc)713 ;; This avoids embedded NULs and appends a NUL, so "cs" is714 ;; safe to copy and use as-is in the pointer-vector.715 (let* ((cs (##sys#make-c-string (convert (car sl)) loc))716 (csp (c-string->allocated-pointer cs)))717 (unless csp (error loc "Out of memory"))718 (pointer-vector-set! buffer i csp)))719720 buffer)))))721722(define (free-c-string-buffer buffer-array)723 (let ((size (pointer-vector-length buffer-array)))724 (do ((i 0 (fx+ i 1)))725 ((fx= i size))726 (and-let* ((s (pointer-vector-ref buffer-array i)))727 (free s)))))728729;; Environments are represented as string->string association lists730(define (check-environment-list lst loc)731 (##sys#check-list lst loc)732 (for-each733 (lambda (p)734 (##sys#check-pair p loc)735 (##sys#check-string (car p) loc)736 (##sys#check-string (cdr p) loc))737 lst))738739(define call-with-exec-args740 (let ((nop (lambda (x) x)))741 (lambda (loc filename argconv arglist envlist proc)742 (let* ((args (cons filename arglist)) ; Add argv[0]743 (argbuf (list->c-string-buffer args argconv loc))744 (envbuf #f))745746 (handle-exceptions exn747 ;; Free to avoid memory leak, then reraise748 (begin (free-c-string-buffer argbuf)749 (when envbuf (free-c-string-buffer envbuf))750 (signal exn))751752 ;; Envlist is never converted, so we always use nop here753 (when envlist754 (check-environment-list envlist loc)755 (set! envbuf756 (list->c-string-buffer757 (map (lambda (p) (string-append (car p) "=" (cdr p))) envlist)758 nop loc)))759760 (proc (##sys#make-c-string filename loc) argbuf envbuf))))))761762;; Pipes:763764(define-foreign-variable _pipe_buf int "PIPE_BUF")765(set! chicken.process#pipe/buf _pipe_buf)766767(let ()768 (define (mode arg) (if (pair? arg) (##sys#slot arg 0) #:text))769 (define (badmode m) (##sys#error "illegal input/output mode specifier" m))770 (define (check loc cmd inp r)771 (if (##sys#null-pointer? r)772 (posix-error #:file-error loc "cannot open pipe" cmd)773 (let ((port (##sys#make-port (if inp 1 2) ##sys#stream-port-class "(pipe)" 'stream)))774 (##core#inline "C_set_file_ptr" port r)775 port) ) )776 (set! chicken.process#open-input-pipe777 (lambda (cmd . m)778 (##sys#check-string cmd 'open-input-pipe)779 (let ([m (mode m)])780 (check781 'open-input-pipe782 cmd #t783 (case m784 ((#:text) (##core#inline_allocate ("open_text_input_pipe" 2) (##sys#make-c-string cmd 'open-input-pipe)))785 ((#:binary) (##core#inline_allocate ("open_binary_input_pipe" 2) (##sys#make-c-string cmd 'open-input-pipe)))786 (else (badmode m)) ) ) ) ) )787 (set! chicken.process#open-output-pipe788 (lambda (cmd . m)789 (##sys#check-string cmd 'open-output-pipe)790 (let ((m (mode m)))791 (check792 'open-output-pipe793 cmd #f794 (case m795 ((#:text) (##core#inline_allocate ("open_text_output_pipe" 2) (##sys#make-c-string cmd 'open-output-pipe)))796 ((#:binary) (##core#inline_allocate ("open_binary_output_pipe" 2) (##sys#make-c-string cmd 'open-output-pipe)))797 (else (badmode m)) ) ) ) ) )798 (set! chicken.process#close-input-pipe799 (lambda (port)800 (##sys#check-input-port port #t 'close-input-pipe)801 (let ((r (##core#inline "close_pipe" port)))802 (when (eq? -1 r)803 (posix-error #:file-error 'close-input-pipe "error while closing pipe" port))804 r) ) )805 (set! chicken.process#close-output-pipe806 (lambda (port)807 (##sys#check-output-port port #t 'close-output-pipe)808 (let ((r (##core#inline "close_pipe" port)))809 (when (eq? -1 r)810 (posix-error #:file-error 'close-output-pipe "error while closing pipe" port))811 r) ) ))812813(set! chicken.process#with-input-from-pipe814 (lambda (cmd thunk . mode)815 (let ((p (apply chicken.process#open-input-pipe cmd mode)))816 (fluid-let ((##sys#standard-input p))817 (call-with-values thunk818 (lambda results819 (chicken.process#close-input-pipe p)820 (apply values results) ) ) ) ) ) )821822(set! chicken.process#call-with-output-pipe823 (lambda (cmd proc . mode)824 (let ((p (apply chicken.process#open-output-pipe cmd mode)))825 (call-with-values826 (lambda () (proc p))827 (lambda results828 (chicken.process#close-output-pipe p)829 (apply values results) ) ) ) ) )830831(set! chicken.process#call-with-input-pipe832 (lambda (cmd proc . mode)833 (let ([p (apply chicken.process#open-input-pipe cmd mode)])834 (call-with-values835 (lambda () (proc p))836 (lambda results837 (chicken.process#close-input-pipe p)838 (apply values results) ) ) ) ) )839840(set! chicken.process#with-output-to-pipe841 (lambda (cmd thunk . mode)842 (let ((p (apply chicken.process#open-output-pipe cmd mode)))843 (fluid-let ((##sys#standard-output p))844 (call-with-values thunk845 (lambda results846 (chicken.process#close-output-pipe p)847 (apply values results) ) ) ) ) ) )