(define-module (language python module os) #:use-module (ice-9 match) #:use-module (ice-9 ftw) #:use-module (ice-9 control) #:use-module (system foreign) #:use-module (oop pf-objects) #:use-module (oop goops) #:use-module (rnrs bytevectors) #:use-module (rnrs io ports) #:use-module (language python for) #:use-module (language python persist) #:use-module (language python try) #:use-module (language python module stat) #:use-module (language python module) #:use-module (language python exceptions) #:use-module (language python yield) #:use-module (language python range) #:use-module (language python string) #:use-module (language python bytes) #:use-module (language python dict) #:use-module (language python set) #:use-module (language python def) #:use-module (language python module errno) #:use-module ((language python module io) #:select ((open . builtin:open) DEFAULT_BUFFER_SIZE)) #:use-module (language python module resource) #:use-module (language python list) #:replace (getcwd getuid getenv) #:export (error name ctermid environ environb chdir fchdir fsencode fdencode fspath PathLike getenvb get_exec_path getgid getegid geteuid fdopen getgroups getgrouplist getlogin getpgid getpgrp getpid getppid PRIO_PROCESS PRIO_PRGRP PRIO_USER getpriority getresgid initgroups putenv setegid seteuid setgid setgroups setpgrp setpgid setpriority setregid setresgid setreuid setresuid getsid setsid setuid strerr umask uname unsetenv curdir pardir sep extsep altsep pathsep linesep defpath devnull path dopen close closerange device_encoding dup dup2 fchmod fchown fdatasync fpathconf fstat fstatvfs fsynch ftruncate isatty F_LOCK F_TLOCK F_ULOCK F_TEST lockf SEEK_SET SEEK_CUR SEEK_END SEEK_DATA SEEK_HOLE lseek open O_RDONLY O_WRONLY O_RDWR O_APPEND O_CREAT O_EXCL O_TRUNC O_SYNC O_NDELAY O_NONBLOCK O_NOCTTY O_LARGEFILE O_NOTRANS O_DSYNC O_RSYNC O_CLOEXEC O_PATH O_DIRECTORY O_NOFOLLOW O_DIRECT O_NOATIME O_ASYNC O_TMPFILE openpty pipe pipe2 posix_fallocate posix_fadvise POSIX_FADV_NORMAL POSIX_FADV_RANDOM POSIX_FADV_SEQUENTIAL POSIX_FADV_WILLNEED POSIX_FADV_DONTNEED POSIX_FADV_NOREUSE pread pwrite read sendfile set_blocking get_blocking set_blocking readv write writev set_inheritable get_inheritable F_OK W_OK R_OK X_O AT_EACCESS AT_SYMLINK_NOFOLLOW lchown lchmod lchflags getcwdb fchdir chroot chown chmod chflags chdir access listdir link stat lstat mkdir mkdirs mkfifo mknod major minor makedev pathconf_names pathconf readlink remove unlink rmdir removedirs rename replace renames scandir stat_float_times ST_RDONLY ST_NOSUID ST_NODEV ST_NOEXEC ST_SYNCHRONOUS ST_MANDLOCK ST_WRITE ST_APPEND ST_IMMUTABLE ST_NOATIME ST_NODIRATIME ST_RELATIME statvfs symlink truncate utime walk fwalk getxattr listxattr removexattr setxattr XATTR_SIZE_MAX XATTR_CREATE XATTR_REPLACE abort excl excle execlp execlpe excv excve execvp execvpe _exit EX_OK EX_USAGE EX_DATAERR EX_NOINPUT EX_NOUSER EX_NOHOST EX_UNAVAILABLE EX_SOFTWARE EX_OSERR EX_OSFILE EX_CANTCREAT EX_IOERR EX_TEMPFAIL EX_PROTOCOL spawnl spawnle spawnlp spawnlpe spawnv spawnve spawnvp spawnvpe P_WAIT P_NOWAIT P_NOWAIT0 P_PID P_PGID P_ALL WEXITED WUNTRACED WSTOPPED WNOWAIT WCONTINUED WNOHANG CLD_EXITED CLD_KILLED CLD_DUMPED CLD_STOPED CLD_TRAPPED CLD_CONTINUED startfile system times wait waitid waitpid wait3 wait4 WCOREDUMP WIFCONTINUED WIFSTOPPED WIFSIGNALED WIFEXITED WEXITSTATUS WSTOPSIG WTERMSIG sched_get_priority_min sched_get_priority_max sched_setscheduler sched_getscheduler sched_setparam sched_getparam sched_rr_get_intervall sched_yield sched_setaffinity sched_getaffinity supports_dir_fs support_effective_ids supports_fd confstr confstr_names cpu_count sysconf sysconf_names getloadavg RTLD_LAZY RTLD_NOW RTLD_GLOBAL RTLD_LOCAL RTLD_NODELETE RTLD_NOLOAD RTLD_DEEPBIND getrandom urandom GRND_NONBLOCK GRND_RANDOM )) (define supports_dir_fs (py-set '())) (define support_effective_ids (py-set '())) (define supports_fd (py-set '())) (define error OSError) (define errno (let ((f (dynamic-pointer "errno" (dynamic-link)))) (lambda () (pointer-address (dereference-pointer f))))) (define-syntax-rule (aif it p x y) (let ((it p)) (if it x y))) (define-syntax-rule (ca code) (catch #t (lambda () code) (lambda x (raise error x)))) (define-syntax-rule (rm code) (let ((r (ca code))) (if (< r 0) (raise error (errno) ((@ (guile) strerror) (errno))) r))) (define (py-add s x) ((ref s 'add) x)) (define-syntax reg (syntax-rules () ((_ () f) (values)) ((_ (0 . l) f) (begin (py-add supports_dir_fs (symbol->string 'f)) (reg l f))) ((_ (1 . l) f) (begin (py-add support_effective_ids (symbol->string 'f)) (reg l f))) ((_ (2 . l) f) (begin (py-add supports_fd (symbol->string 'f)) (reg l f))))) (define-syntax-rule (defineu f a x) (begin (define f (catch #t (lambda () x) (lambda z (let ((message (format #f "could not define ~a" 'f))) (warn message) (lambda z (error message)))))) (reg a f))) (define-syntax guile (syntax-rules () ((_ (x ...) code) (guile (x ...) code code)) ((_ (x ...) code1 code2) (define code1 (lambda (x ...) (ca ((@ (guile) code2) x ...))))) ((_ code) (guile code code)) ((_ code1 code2) (define code1 (lambda x (ca (apply (@ (guile) code2) x))))))) (define name "posix") (guile ctermid) (define-values (environ environb) (let () (define e (dereference-pointer (dynamic-pointer "environ" (dynamic-link)))) (define (get-envs) (let lp ((e e)) (let ((*e (dereference-pointer e))) (if (null-pointer? *e) '() (cons (pointer->string *e) (lp (make-pointer (+ (pointer-address e) 8)))))))) (define (getkw) (let lp ((es (get-envs))) (if (pair? es) (let ((x (string-split (car es) #\=))) (let ((k (car x)) (v (string-join (cdr x) "="))) (cons (cons k v) (lp (cdr es))))) '()))) (define-python-class Env () (define __init__ (lambda (self) (values))) (define __getitem__ (lambda (self k) (let ((r ((@ (guile) getenv) (slot-ref (pystring k) 'str)))) (if r r (raise IndexError))))) (define __setitem__ (lambda (self k v) ((@ (guile) putenv) (slot-ref (pystring (+ k "=" v)) 'str)))) (define __delitem__ (lambda (self k) ((@ (guile) putenv) (slot-ref (pystring k) 'str)))) (define __iter__ (lambda (self) ((make-generator () (lambda (yield) (for ((x : (getkw))) () (yield (car x) (cdr x))))))))) (define-python-class Envb () (define __init__ (lambda (self) (values))) (define __getitem__ (lambda (self k) (let ((r (bytes ((@ (guile) getenv) (slot-ref (string k) 'str))))) (if r r (raise IndexError))))) (define __setitem__ (lambda (self k v) ((@ (guile) putenv) (slot-ref (string (+ k "=" v)) 'str)))) (define __delitem__ (lambda (self k) ((@ (guile) putenv) (slot-ref (string k) 'str)))) (define __iter__ (lambda (self) ((make-generator () (lambda (yield) (for ((x : (getkw))) () (yield (car x) (cdr x))))))))) (values (Env) (Envb)))) (guile (path) chdir) (define (fchdir fd) (error "not implemented")) (guile () getcwd) (define (fsencode fn) (error "not implemented")) (define (fsdecode fn) (error "not implemented")) (define-method (fspath (pth )) pth) (define-method (fspath (pth )) pth) (define-method (fspath (pth )) pth) (define-method (fspath (pth )) pth) (define-method (fspath (pth

)) (aif it (ref pth '__fspath__) (it) (next-method))) (define-python-class PathLike () (define __fspath__ (lambda (self) (error "not implemented")))) (define* (getenv key #:key (default None)) (try (lambda () (pylist-ref environ key)) (#:except IndexError => (lambda x default)))) (define* (getenvb key #:key (default None)) (try (lambda () (pylist-ref environb key)) (#:except IndexError => (lambda x default)))) (define* (get_exec_path #:key (env #f)) (define (f s) (let ((s (slot-ref (string s) 'str))) (string-split s ":"))) (if env (f (pylist-ref env "PATH")) (f (pylist-ref environ "PATH")))) (guile () getgid) (guile () getegid) (guile () geteuid) (define (getgrouplist user group) (error "not impllemeneted")) (guile () getgroups) (guile getlogin) (define getpgid (let ((f (pointer->procedure int (dynamic-func "getpgid" (dynamic-link)) (list int)))) (lambda (pid) (rm (f pid))))) (guile getpgrp) (guile getpid) (guile getppid) (define PRIO_PROCESS (@ (guile) PRIO_PROCESS)) (define PRIO_PGRP (@ (guile) PRIO_PGRP)) (define PRIO_USER (@ (guile) PRIO_USER)) (guile getpriority) (define getresgid #f) (defineu getresgid () (let* ((f (pointer->procedure void (dynamic-func "getresgid" (dynamic-link)) '(* * *)))) (lambda () (let* ((a (make-bytevector 8)) (ap (bytevector->pointer a)) (b (make-bytevector 8)) (bp (bytevector->pointer b)) (c (make-bytevector 8)) (cp (bytevector->pointer c))) (rm (f ap bp cp)) (list (bytevector-u16-ref a 0 (native-endianness)) (bytevector-u16-ref b 0 (native-endianness)) (bytevector-u16-ref c 0 (native-endianness))))))) (guile getuid) (define initgroups #f) (defineu initgroups () (let ((f (pointer->procedure int (dynamic-func "initgroups" (dynamic-link)) (list '* int)))) (lambda (user group) (rm (f (string->pointer user) group))))) (define (putenv key value) (pylist-set! environ key value)) (guile setegid) (guile seteuid) (guile setgid) (guile setgroups) (define setpgrp #f) (defineu setpgrp () (let ((f (pointer->procedure int (dynamic-func "setpgrp" (dynamic-link)) '()))) (lambda () (rm (f))))) (guile setpgid) (guile setpriority) (define setregid #f) (define setregid (let ((f (pointer->procedure int (dynamic-func "setregid" (dynamic-link)) (list int int)))) (lambda (a b) (rm (f a b))))) (define setresgid #f) (define setresgid (let ((f (pointer->procedure int (dynamic-func "setresgid" (dynamic-link)) (list int int int)))) (lambda (a b c) (rm (f a b c))))) (define setreuid #f) (defineu setreuid () (let ((f (pointer->procedure int (dynamic-func "setreuid" (dynamic-link)) (list int int)))) (lambda (a b) (rm (f a b))))) (define setresuid #f) (defineu setresuid () (let ((f (pointer->procedure int (dynamic-func "setresuid" (dynamic-link)) (list int int int)))) (lambda (a b c) (rm (f a b c))))) (guile getsid) (guile setsid) (guile setuid) (guile strerror) (guile umask) (guile uname) (guile unsetenv) ;; File descriptor operations (define close (lambda (fd) (ca ((@ (guile) close-fdes) fd)))) (define (closerange fd_low fd_high) (for ((i : (range fd_low fd_high))) () (try (lambda () (close i)) (#:except OSError => (lambda x (values)))))) (define device_encoding (lambda (fd) (error "not implemented"))) (guile (fd) dup) (define dup2 (let ((f (pointer->procedure int (dynamic-func "dup3" (dynamic-link)) (list int int int)))) (lambda* (fd fd2 #:optional (inheritable? #t)) (if inheritable? (rm (f fd fd2 O_CLOEXEC)) (ca ((@ (guile) dup2) fd fd2)))))) (guile (fd mode) fchmod) (guile (fd uid gid) fchown) (define (fdatasync fd) (error "not implemented")) (define (fpathconf fd name) (error "not implemented")) (define-syntax-rule (concat a ... stx) (datum->syntax stx (string->symbol (string-append a ... (symbol->string (syntax->datum stx)))))) (define-syntax statset (lambda (x) (syntax-case x () ((_ (m ...) self scm) #'(begin (statset 1 m self scm) ...)) ((_ 1 (m mm) self scm) (with-syntax ((mem (concat "st_" #'mm)) (smem (concat "stat:" #'m))) #'(set self 'mem (smem scm)))) ((_ 1 m self scm) #'(statset 1 (m m) self scm))))) (define stat-float-times #t) (define-python-class stat_result () (define __init__ (lambda (self scm) (ca (begin (statset (mode ino dev nlink uid gid size atime mtime ctime (atimensec atime_ns) (mtimensec mtime_ns) (ctimensec ctime_ns) blksize blocks perms rdev type) self scm) (if stat-float-times (begin (set self 'st_atime (* (ref self 'st_atime) 1.0)) (set self 'st_mtime (* (ref self 'st_mtime) 1.0)) (set self 'st_ctime (* (ref self 'st_ctime) 1.0)) (set self 'st_atime_ns (/ (ref self 'st_atime_ns) 1000000000.0)) (set self 'st_mtime_ns (/ (ref self 'st_mtime_ns) 1000000000.0)) (set self 'st_ctime_ns (/ (ref self 'st_ctime_ns) 1000000000.0))))))))) (name-object stat_result) (define (fstat fd) (stat_result (stat fd))) (define (fstatvfs fd) (error "not implemented")) (guile (fd) fsynch fsync) (guile (fd len) ftruncate truncate-file) (guile (fd) isatty isatty?) (define F_LOCK 1) (define F_TLOCK 2) (define F_ULOCK 0) (define F_TEST 3) (define lockf #f) (defineu lockf (2) (let ((f (pointer->procedure int (dynamic-func "lockf" (dynamic-link)) (list int int long)))) (lambda (fd op len) (rm (f fd op len))))) (define SEEK_SET #x0) (define SEEK_CUR #x1) (define SEEK_END #x2) (define SEEK_DATA #x3) (define SEEK_HOLE #x4) (define lseek #f) (defineu lseek (2) (let ((f (pointer->procedure int (dynamic-func "lseek" (dynamic-link)) (list int long int)))) (lambda (fd pos how) (rm (f fd pos how))))) (define open (let ((f (pointer->procedure int (dynamic-func "openat" (dynamic-link)) (list int '* int int)))) (lam (path flags (= mode #o777) (= dir_fd None)) (if (eq? dir_fd None) (ca (open-fdes path flags mode)) (rm (f dir_fd (string->pointer path) flags mode)))))) (define-syntax-rule (mko O) (define O (@ (guile) O))) (mko O_RDONLY) (mko O_WRONLY) (mko O_RDWR) (mko O_APPEND) (mko O_CREAT) (mko O_EXCL) (mko O_TRUNC) ;;unix (mko O_SYNC) (mko O_NDELAY) (mko O_NONBLOCK) (mko O_NOCTTY) ;; (mko O_LARGEFILE) (mko O_NOTRANS) (define O_DSYNC #o10000) (define O_RSYNC O_SYNC) (define O_CLOEXEC #o2000000) (define O_PATH #o10000000) (define O_DIRECTORY #o200000) (define O_NOFOLLOW #o400000) (define O_DIRECT #o40000) (define O_NOATIME #o1000000) (define O_ASYNC #o20000) (define O_TMPFILE (logior #o20000000 O_DIRECTORY)) (define openpty (lambda x (error "not implemented"))) (define fdopen builtin:open) (define pipe (let ((x (ca ((@ (guile) pipe))))) (values (car x) (cdr x)))) (define pipe2 #f) (defineu pipe2 () (let ((f (pointer->procedure int (dynamic-func "pipe2" (dynamic-link)) (list int '* int)))) (lambda (flags) (let* ((a (make-bytevector 8)) (ap (bytevector->pointer a))) (rm (f ap flags)) (values (bytevector-s32-ref a 0 (native-endianness)) (bytevector-s32-ref a 4 (native-endianness))))))) (define posix_fallocate #f) (defineu posix_fallocate (2) (let ((f (pointer->procedure int (dynamic-func "posix_fallocate" (dynamic-link)) (list int long long)))) (lambda (fd off len) (rm (f fd off len))))) (define posix_fadvise #f) (defineu posix_fadvise (2) (let ((f (pointer->procedure int (dynamic-func "posix_fadvise" (dynamic-link)) (list int long long int)))) (lambda (fd off len advice) (rm (f fd off len advice))))) (define POSIX_FADV_NORMAL 0) (define POSIX_FADV_RANDOM 1) (define POSIX_FADV_SEQUENTIAL 2) (define POSIX_FADV_WILLNEED 3) (define POSIX_FADV_DONTNEED 4) (define POSIX_FADV_NOREUSE 5) (define pread #f) (defineu pread (2) (let ((f (pointer->procedure int (dynamic-func "pread" (dynamic-link)) (list int '* long long)))) (lambda (fd size offset) (let* ((a (make-bytevector size)) (ap (bytevector->pointer a))) (let ((n (rm (f fd ap size offset)))) (if (= n 0) (make-bytevector 0) (let ((o (make ))) (slot-set! o 'n (size)) (slot-set! o 'size n) (slot-set! o 'bv a) o))))))) (define pwrite #f) (defineu pwrite (2) (let ((f (pointer->procedure int (dynamic-func "pwrite" (dynamic-link)) (list int '* long long)))) (lambda (fd a offset) (let* ((ap (bytevector->pointer (slot-ref (bytes a) 'bytes)))) (rm (f fd ap (len a) offset)))))) (define read #f) (defineu read (2) (let ((f (pointer->procedure int (dynamic-func "read" (dynamic-link)) (list int '* long)))) (lambda (fd size) (let* ((a (make-bytevector size)) (ap (bytevector->pointer a))) (let ((n (rm (f fd ap size)))) (if (= n 0) (make-bytevector 0) (let ((o (make ))) (slot-set! o 'n (size)) (slot-set! o 'size n) (slot-set! o 'bv a) o))))))) (define (sendfile out in offset count) (ca (if (eq? count None) ((@ (guile) sendfile) out in count) ((@ (guile) sendfile) out in count offset)))) (define F_GETFL 3) (defineu fcntl2 () (pointer->procedure int (dynamic-func "fcntl" (dynamic-link)) (list int int))) (defineu fcntl3 () (pointer->procedure int (dynamic-func "fcntl" (dynamic-link)) (list int int int))) (define (set_blocking fd is-blocking?) (let ((o (rm (fcntl2 fd F_GETFL)))) (if is-blocking? (rm (fcntl3 fd F_GETFL (logior o O_NONBLOCK))) (rm (fcntl3 fd F_GETFL (logand o (lognot O_NONBLOCK))))))) (define (get_blocking fd) (let ((fd (if (port? fd) (port->fdes fd) fd))) (if (= (logand O_NONBLOCK (rm (fcntl2 fd F_GETFL))) 0) #f #t))) (define (readv fd buffers) (error "not implemented")) (guile (fd pg) tcsetpgrp) (guile (fd) ttyname) (define write #f) (defineu write (2) (let ((f (pointer->procedure int (dynamic-func "write" (dynamic-link)) (list int '* long)))) (lambda (fd a) (let* ((ap (bytevector->pointer (slot-ref (bytes a) 'bytes)))) (rm (f fd ap (len a))))))) (define (writev fd buffers) (error "not implemented")) (define (set_inheritable fd is-inh?) (let ((o (rm (fcntl2 fd F_GETFL)))) (if is-inh? (rm (fcntl3 fd F_GETFL (logior o O_CLOEXEC))) (rm (fcntl3 fd F_GETFL (logand o (lognot O_CLOEXEC))))))) (define (get_inheritable fd) (if (= (logand O_CLOEXEC (rm (fcntl2 fd F_GETFL))) 0) #f #t)) ;; Files and dir (define AT_EACCESS #x200) (define AT_SYMLINK_NOFOLLOW #x100) (define F_OK (@ (guile) F_OK)) (define W_OK (@ (guile) W_OK)) (define R_OK (@ (guile) R_OK)) (define X_OK (@ (guile) X_OK)) (define access #f) (defineu access (0 1) (let ((f (pointer->procedure int (dynamic-func "access" (dynamic-link)) (list '* int))) (fa (pointer->procedure int (dynamic-func "faccessat" (dynamic-link)) (list '* int int int)))) (lambda* (path mode #:key (dir_fd None) (effective_ids #f) (follow_symlinks #t)) (if (eq? dir_fd None) (rm (f (string->pointer path) mode)) (rm (fa (string->pointer path) mode dir_fd (logior (if effective_ids AT_EACCESS 0) (if follow_symlinks 0 AT_SYMLINK_NOFOLLOW)))))))) (define chdir #f) (defineu chdir (2) (let ((f (pointer->procedure int (dynamic-func "chdir" (dynamic-link)) '(*)))) (lambda (pth) (let ((pth (aif it (ref pth '__fspath__) (it) pth))) (if (number? pth) (rm (f pth)) (ca ((@ (guile) chdir) pth))))))) (define chflags (lambda x (error "Not implemented"))) (defineu chmod (0 2) (let ((f (pointer->procedure int (dynamic-func "chmod" (dynamic-link)) (list '* int))) (ff (pointer->procedure int (dynamic-func "fchmod" (dynamic-link)) (list int int))) (fat (pointer->procedure int (dynamic-func "fchmodat" (dynamic-link)) (list '* int int int)))) (lambda* (path mode #:key (dir_fd None) (follow_symlinks #t)) (if (number? path) (rm (ff path mode)) (let ((path (aif it (ref path '__fspath__) (it) path))) (if (eq? dir_fd None) (rm (f (string->pointer path) mode)) (rm (fat (string->pointer path) mode dir_fd (if follow_symlinks 0 AT_SYMLINK_NOFOLLOW))))))))) (define (path-it path) (aif it (ref path '__fspath__) (it) path)) (defineu chown (0 2) (let ((f (pointer->procedure int (dynamic-func "chown" (dynamic-link)) (list '* int int))) (ff (pointer->procedure int (dynamic-func "fchown" (dynamic-link)) (list int int int))) (lf (pointer->procedure int (dynamic-func "lchown" (dynamic-link)) (list '* int int))) (fat (pointer->procedure int (dynamic-func "fchownat" (dynamic-link)) (list '* int int int int)))) (lambda* (path uid gid #:key (dir_fd None) (follow_symlinks #t)) (if (number? path) (rm (ff path uid gid)) (let ((path (path-it path))) (if (eq? dir_fd None) (if follow_symlinks (rm (f (string->pointer path) uid gid)) (rm (lf (string->pointer path) uid gid))) (rm (fat (string->pointer path) uid gid dir_fd (if follow_symlinks 0 AT_SYMLINK_NOFOLLOW))))))))) (guile (x) chroot) (define fchdir chdir) (guile () getcwd) (define (getcwdb) (bytes (getcwd))) (define lchflags (lambda x (error "not implemented"))) (define (lchmod path mode) (chmod path mode #:follow_symlinks #f)) (define (lchown path uid gid) (chown path uid gid #:follow_symlinks #f)) (define AT_FDCWD -100) (define link #f) (defineu link (0) (let ((f (pointer->procedure int (dynamic-func "linkat" (dynamic-link)) (list '* '* int int int)))) (lambda* (src dst #:key (src_dir_fd None) (dst_dir_fd None) (follow_symlinks #t)) (let ((src (path-it src)) (dst (path-it dst)) (src_dir_fd (if (eq? src_dir_fd None) AT_FDCWD src_dir_fd)) (dst_dir_fd (if (eq? dst_dir_fd None) AT_FDCWD dst_dir_fd))) (rm (f (string->pointer src) (string->pointer dst) src_dir_fd dst_dir_fd (if follow_symlinks 0 AT_SYMLINK_NOFOLLOW))))))) (define listdir (lambda* (#:optional (pth ".")) (let ((pth (if (number? pth) ((@ (guile) readlink) (format #f "/proc/self/fd/~a" pth)) (path-it pth)))) (let ((o (ca (opendir pth)))) (dynamic-wind (lambda x #f) (lambda () (let lp ((o o)) (let ((w (ca (readdir o)))) (if (eof-object? w) '() (if (or (equal? w ".") (equal? w "..")) (lp o) (cons w (lp o))))))) (lambda x (closedir o))))))) (defineu stat (0 2) (let ((f (pointer->procedure int (dynamic-func "__fxstatat" (dynamic-link)) (list int int '* '* int))) (g (pointer->procedure '* (dynamic-func "scm_stat2scm_" (dynamic-link)) '(*)))) (lam (path (= dir_fd None) (= follow_symlinks #t)) (if (number? path) (ca (stat_result ((@ (guile) stat) path))) (let ((path (path-it path))) (if (eq? dir_fd None) (ca (if follow_symlinks (stat_result ((@ (guile) stat) path)) (stat_result ((@ (guile) lstat) path)))) (let* ((bv (make-bytevector 80)) (bvp (bytevector->pointer bv))) (rm (f 1 ;Special linux flag dir_fd (string->pointer path) bvp (if follow_symlinks 0 AT_SYMLINK_NOFOLLOW))) (stat_result (ca (pointer->scm (g bvp))))))))))) (define lstat (lambda* (path #:key (dir_fd None)) (stat path #:dir_fd dir_fd #:follow_symlinks #f))) (defineu mkdir (0) (let ((fat (pointer->procedure int (dynamic-func "mkdirat" (dynamic-link)) (list int '* int)))) (lambda* (path mode #:key (dir_fd None)) (rm (fat (if (eq? dir_fd None) AT_FDCWD dir_fd) (string->pointer (path-it path)) mode))))) (define* (mkdirs name mode #:key (exist_ok #f)) (let lp ((pre "") (l (string-split (path-it name) #\/))) (match l (() (values)) ((x) (let ((s (string-append pre "/" x))) (catch #t (lambda () ((@ (guile) stat) s) (if exist_ok (values) (raise error (format #f "dir ~a in mkdirs already exist" s)))) (lambda x (mkdir s mode))))) ((x . l) (let ((s (string-append pre "/" x))) (catch #t (lambda () ((@ (guile) stat) s)) (lambda x (mkdir s mode))) (lp s l)))))) (defineu mkfifo (0) (let ((fat (pointer->procedure int (dynamic-func "mkfifoat" (dynamic-link)) (list int '* int)))) (lambda* (path mode #:key (dir_fd None)) (rm (fat (if (eq? dir_fd None) AT_FDCWD dir_fd) (string->pointer (path-it path)) mode))))) (defineu mknod (0) (let ((fat (pointer->procedure int (dynamic-func "__xmknodat" (dynamic-link)) (list int int '* int)))) (lambda* (path mode #:optional (device 0) #:key (dir_fd None)) (rm (fat 1 (if (eq? dir_fd None) AT_FDCWD dir_fd) (string->pointer (path-it path)) mode device))))) (defineu major () (let ((f (pointer->procedure int (dynamic-func "gnu_dev_major" (dynamic-link)) (list int64)))) (lambda (device) (ca (f device))))) (defineu minor () (let ((f (pointer->procedure int (dynamic-func "gnu_dev_minor" (dynamic-link)) (list int64)))) (lambda (device) (ca (f device))))) (defineu makedev () (let ((f (pointer->procedure int64 (dynamic-func "gnu_dev_makedev" (dynamic-link)) (list int int)))) (lambda (major minor) (ca (f major minor))))) (define pathconf_names (dict)) (pylist-set! pathconf_names "PC_LINK_MAX" 0) (pylist-set! pathconf_names "PC_MAX_CANON" 1) (pylist-set! pathconf_names "PC_MAX_INPUT" 2) (pylist-set! pathconf_names "PC_NAME_MAX" 3) (pylist-set! pathconf_names "PC_PATH_MAX" 4) (pylist-set! pathconf_names "PC_PIPE_BUF" 5) (pylist-set! pathconf_names "PC_CHOWN_RESTRICTED" 6) (pylist-set! pathconf_names "PC_NO_TRUNC" 7) (pylist-set! pathconf_names "PC_VDISABLE" 8) (define-syntax-rule (rmp code) (let ((e (errno)) (r (ca code))) (if (>= r 0) r (let ((e2 (errno))) (if (eq? e e2) (error "Bug could not find pathcond name endex") (rm e2)))))) (defineu pathconf (2) (let ((f (pointer->procedure long (dynamic-func "pathconf" (dynamic-link)) (list '* int))) (ff (pointer->procedure long (dynamic-func "fpathconf" (dynamic-link)) (list int int)))) (lambda (path name) (let ((ni (pylist-ref pathconf_names name))) (if (number? path) (rmp (ff path ni)) (let ((path (path-it path))) (rmp (f (string->pointer path) ni)))))))) (defineu readlink (0) (let ((fat (pointer->procedure int (dynamic-func "readlinkat" (dynamic-link)) (list int '* '* long)))) (lambda* (path #:key (dir_fd None)) (let* ((n 10000) (bv (make-bytevector 10000)) (bvp (bytevector->pointer bv))) (rm (fat (if (eq? dir_fd None) AT_FDCWD dir_fd) (string->pointer (path-it path)) bvp n)) (bytevector-u8-set! bv (- n 1) 0) (pointer->string bvp))))) (defineu remove (0) (let ((fat (pointer->procedure int (dynamic-func "unlinkat" (dynamic-link)) (list int '* int)))) (lambda* (path #:key (dir_fd None)) (rm (fat (if (eq? dir_fd None) AT_FDCWD dir_fd) (string->pointer (path-it path)) 0))))) (define unlink remove) (define rmdir (lambda* (path #:key (dir_fd None)) (let ((path (path-it path))) (if (eq? dir_fd None) ((@ (guile) rmdir) path) (let* ((fd (open path O_DIRECTORY #:dir_fd dir_fd)) (path ((@ (guile) readlink) ' (format #f "/proc/self/fd/~a" fd)))) (close fd) ((@ (guile) rmdir) path)))))) (define (removedirs name) (let ((name (path-it name))) (let lp ((l (reverse (string-split name #\/)))) (if (pair? l) (let ((path (string-join (reverse l) "/"))) (catch #t (lambda () (rmdir path)) (lambda x (values))) (lp (cdr l))))))) (defineu rename (0) (let ((fat (pointer->procedure int (dynamic-func "renameat" (dynamic-link)) (list int '* int '*)))) (lambda* (src dst #:key (src_dir_fd None) (dst_dir_fd None)) (rm (fat (if (eq? src_dir_fd None) AT_FDCWD src_dir_fd) (string->pointer (path-it src)) (if (eq? dst_dir_fd None) AT_FDCWD dst_dir_fd) (string->pointer (path-it src))))))) (define replace rename) (define (renames old new) (let ((old (path-it old)) (new (path-it new))) (let lp ((l (string-split new #\/)) (d '())) (match l (() #t) ((x) #t) (("" . l) (lp l (cons "" d))) ((x . l) (if (pair? d) (let ((path (string-join (reverse d) "/"))) (catch #t (lambda () (stat path)) (lambda x (mkdir path))) (lp l (cons x d))) (lp l (cons x d)))))) (rename old new) (let ((l (string-split old #\/))) (if (> (length l) 1) (if (= (length l) 2) (removedirs (string-append (car l) "/")) (removedirs (string-join (reverse (cdr (reverse l))) "/"))))) (values))) (define statu stat) (define-python-class DirEntry () (define __init__ (lambda (self path stat) (set self 'name (basename path)) (set self 'path path) (set self '__stat stat))) (define __repr__ (lambda (self) (format #f "DirEntry(~a)" (basename (ref self 'path))))) (define inode (lambda (self) (let ((stat (ref self '__stat))) (if stat (stat:ino stat) (raise error "Bug no stat"))))) (define is_dir (lambda* (self #:key (follow_symlinks #t)) (let ((s (statu (ref self 'path) #:follow_symlinks follow_symlinks))) (S_ISDIR (ref s 'st_mode))))) (define is_file (lambda* (self #:key (follow_symlinks #t)) (let ((s (statu (ref self 'path) #:follow_symlinks follow_symlinks))) (S_ISREG (ref s 'st_mode))))) (define is_symlink (lambda (self) (let ((s (statu (ref self 'path)))) (S_ISLNK (ref s 'st_mode))))) (define stat (lambda* (self #:key (follow_symlinks #t)) (stat (ref self 'path) #:follow_symlinks follow_symlinks)))) (define (one yield) (let ((first? #t)) (lambda (name stat . x) (if first? (begin (set! first? #f) #t) (begin (yield (DirEntry name stat)) #f))))) (define* (scandir #:optional (path ".")) ((make-generator () (lambda (yield) (file-system-fold (one yield) (lambda (path stat res) (yield (DirEntry path stat)) res) (lambda (path stat res) res) (lambda (path stat res) res) (lambda (path stat res) res) (lambda (path stat errno res) res) #f (path-it path)))))) (define (stat_float_times newvalue) (set! stat-float-times newvalue)) (define ST_RDONLY 1) (define ST_NOSUID 2) (define ST_NODEV 4) (define ST_NOEXEC 8) (define ST_SYNCHRONOUS 16) (define ST_MANDLOCK 64) (define ST_WRITE 128) (define ST_APPEND 256) (define ST_IMMUTABLE 512) (define ST_NOATIME 1024) (define ST_NODIRATIME 2048) (define ST_RELATIME 4096) (define-python-class StatVFS () (define __init__ (lambda (self a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11) (map (lambda (x y) (set self x y)) '(f_bsize f_frsize f_blocks f_bfree f_bavail f_files f_ffree f_favail f_fsid f_flag f_namemax) (list a1 a2 a3 a4 a5 a6 a7 a8 a9 a10))))) (defineu statvfs (2) (let ((f (pointer->procedure int (dynamic-func "statvfs" (dynamic-link)) (list '* '*))) (ff (pointer->procedure int (dynamic-func "fstatvfs" (dynamic-link)) (list int '*)))) (lambda (path) (let* ((bv (make-bytevector (* 11 8))) (bvp (bytevector->pointer bv))) (rm (if (number? path) (ff path bvp) (f (string->pointer (path-it path)) bvp))) (StatVFS (bytevector-u64-ref bv (* 0 8) (native-endianness)) (bytevector-u64-ref bv (* 1 8) (native-endianness)) (bytevector-u64-ref bv (* 2 8) (native-endianness)) (bytevector-u64-ref bv (* 3 8) (native-endianness)) (bytevector-u64-ref bv (* 4 8) (native-endianness)) (bytevector-u64-ref bv (* 5 8) (native-endianness)) (bytevector-u64-ref bv (* 6 8) (native-endianness)) (bytevector-u64-ref bv (* 7 8) (native-endianness)) (bytevector-u64-ref bv (* 9 8) (native-endianness)) (bytevector-u64-ref bv (* 10 8) (native-endianness))))))) (defineu symlink (0) (let ((fat (pointer->procedure int (dynamic-func "symlinkat" (dynamic-link)) (list '* int '*)))) (lambda* (src dst #:key (target_is_directory #f) (dir_fd None)) (rm (fat ((string->pointer (path-it dst)) (if (eq? dir_fd None) AT_FDCWD dir_fd) (string->pointer (path-it src)))))))) (defineu truncate (2) (let ((ff (pointer->procedure int (dynamic-func "ftruncate" (dynamic-link)) (list int long))) (f (pointer->procedure int (dynamic-func "truncate" (dynamic-link)) (list '* long)))) (lambda (path length) (rm (if (number? path) (ff path length) (f (string->pointer (path-it path)) length)))))) (define UTIME_NOW (- (ash 1 30) 1)) (define utime #f) (defineu utime (0 2) (let ((ff (pointer->procedure int (dynamic-func "futimes" (dynamic-link)) (list int '*))) (fat (pointer->procedure int (dynamic-func "futimesat" (dynamic-link)) (list int '* '* int)))) (lambda* (path #:optional (times None) (ns #f) #:key (dir_fd None) (follow_symlinks #t)) (let* ((bv (make-bytevector 32)) (bvp (bytevector->pointer bv))) (if (eq? ns None) (if (eq? times None) (let () (bytevector-s64-set! bv 0 0 (native-endianness)) (bytevector-s64-set! bv 8 UTIME_NOW (native-endianness)) (bytevector-s64-set! bv 16 0 (native-endianness)) (bytevector-s64-set! bv 24 UTIME_NOW (native-endianness))) (let ((x1 (pylist-ref ns 0)) (x2 (pylist-ref ns 1))) (bytevector-s64-set! bv 0 (floor-quotient x1 1000000000) (native-endianness)) (bytevector-s64-set! bv 8 (modulo x1 1000000000) (native-endianness)) (bytevector-s64-set! bv 16 (floor-quotient x2 1000000000) (native-endianness)) (bytevector-s64-set! bv 24 (modulo x2 1000000000) (native-endianness)))) (if (eq? times None) (begin (bytevector-s64-set! bv 0 (pylist-ref times 0) (native-endianness)) (bytevector-s64-set! bv 8 0 (native-endianness)) (bytevector-s64-set! bv 16 (pylist-ref times 1) (native-endianness)) (bytevector-s64-set! bv 24 0 (native-endianness))) (raise error "utime cannot set both s and ns"))) (rm (if (number? path) (ff path bvp) (fat (if (eq? dir_fd AT_FDCWD None) dir_fd) bvp (string->pointer (path-it path)) (if follow_symlinks 0 AT_SYMLINK_NOFOLLOW)))))))) (def (walk top (= topdown #t) (= onerror None) (= followlinks #f)) ((make-generator () (lambda (yield) (let/ec ret (define dirs (py-list)) (define nondirs (py-list)) (define entries #f) (try (lambda () (set! entries (py-list (scandir top)))) (#:except error => (lambda (x . _) (if onerror (onerror x) (ret))))) (for ((entry : entries)) () (define is_dir (try (lambda () ((ref entry 'is_dir))) (#:except error => (lambda x #f)))) (if is_dir (pylist-append! dirs (ref entry 'name)) (pylist-append! nondirs (ref entry 'name))) (if (and (not topdown) is_dir) (let ((walk-into (if followlinks #t (not (try (lambda () ((ref entry 'is_symlink))) (#:except error => (lambda x #f))))))) (if walk-into (for ((a b c : (walk (ref entry 'path) topdown onerror followlinks))) () (yield a b c)))))) (if topdown (begin (yield top dirs nondirs) (for ((dirname : dirs)) () (let ((new_path (path:join top dirname))) (if (or followlinks (not (path:islink new_path))) (for ((a b c : (walk new_path topdown onerror followlinks))) () (yield a b c)))))) (yield top dirs nondirs))))))) (define (path:islink p) (ca (S_ISLNK (stat:mode ((@ (guile) stat) (path-it p)))))) (define (path:samestat s1 s2) (and (equal? (ref s1 'st_dev) (ref s2 'st_dev)) (equal? (ref s1 'st_ino) (ref s2 'st_ino)))) (define (path:normpath p) (let lp ((l (string-split (path-it p) #\/)) (r '()) (first? #t)) (match l (("") (lp '() (cons "" r) #f)) (("." . l) (lp l r #f)) (("" . l) (if first? (lp l (cons "" r) #f) (lp l r #f))) ((".." . l) (match r (("") (raise ValueError "normpath .. beond /")) ((".." . u) (lp l (cons ".." r) #f)) ((_ . u) (lp l u #f)) (() (lp l (cons ".." r) #f)))) ((x . l) (lp l (cons x r) #f)) (() (string-join (reverse r) "/"))))) (define (path:join . l) (path:normpath (string-join (map path-it l) "/"))) (define (_fwalk topfd toppath topdown onerror follow_symlinks) ((make-generator () (lambda (yield) (define names (listdir topfd)) (define dirs (py-list)) (define nondirs (py-list)) (for ((name : names)) () (try (lambda () (if (S_ISDIR (ref (stat name #:dir_fd topfd) 'st_mode)) (pylist-append! dirs name) (pylist-append! nondirs name))) (#:except error => (lambda x (try (lambda () (if (S_ISLNK (ref (stat name #:dir_fd topfd #:follow_symlinks #f) 'st_mode)) (pylist-append! nondirs name))) (#:except error => (lambda x (values)))))))) (if topdown (yield toppath dirs nondirs topfd)) (for continue ((name : dirs)) () (call-with-values (lambda () (try (lambda () (values (stat name #:dir_fd topfd #:follow_symlinks follow_symlinks) (open name O_RDONLY #:dir_fd topfd))) (#:except error => (lambda (err . l) (if (not (eq? onerror None)) (onerror err) (continue)))))) (lambda (orig_st dirfd) (try (lambda () (if (or follow_symlinks (path:samestat orig_st (stat dirfd))) (let ((dirpath (path:join toppath name))) (for ((a b c d : (_fwalk dirfd dirpath topdown onerror follow_symlinks))) () (yield a b c d))))) #:finally (lambda () (close dirfd)))))) (if (not topdown) (yield toppath dirs nondirs topfd)))))) (def (fwalk (= top ".") (= topdown #t) (= onerror #t) (= follow_symlinks #f) (= dir_fd None)) ((make-generator () (lambda (yield) (define orig_st (stat top #:follow_symlinks #f #:dir_fd dir_fd)) (define topfd (open top O_RDONLY #:dir_fd dir_fd)) (try (lambda () (if (or follow_symlinks (and (S_ISDIR (ref orig_st 'st_mode)) (path:samestat orig_st (stat topfd)))) (for ((a b c d : (_fwalk topfd top topdown onerror follow_symlinks))) () (yield a b c d)))) #:finally (lambda () (close topfd))))))) ;; Extended attributes (define getxattr #f) (defineu getxattr (2) (let ((f (pointer->procedure int (dynamic-func "getxattr" (dynamic-link)) (list '* '* '* int))) (lf (pointer->procedure int (dynamic-func "lgetxattr" (dynamic-link)) (list '* '* '* int))) (ff (pointer->procedure int (dynamic-func "fgetxattr" (dynamic-link)) (list '* '* '* int)))) (lambda* (path attribute #:key (follow_symlink #t)) (let ((path (ca (if (number? path) path (string->pointer (path-it path))))) (k (ca (string->pointer attribute)))) (let lp ((size 128)) (let* ((v (make-bytevector size)) (pv (bytevector->pointer v))) (let ((n (rm (if (number? path) (ff path k pv size) (if follow_symlink (f path k pv size) (lf path k pv size)))))) (if (> n (- size 2)) (lp (* 2 size)) (pointer->string pv))))))))) (define listxattr #f) (defineu listxattr (2) (let ((f (pointer->procedure int (dynamic-func "listxattr" (dynamic-link)) (list '* '* int))) (lf (pointer->procedure int (dynamic-func "llistxattr" (dynamic-link)) (list '* '* int))) (ff (pointer->procedure int (dynamic-func "flistxattr" (dynamic-link)) (list '* '* int)))) (define (mk l) (define v (make-bytevector (+ (length l) 1))) (define vp (bytevector->pointer v)) (let lp ((i 0) (l l)) (if (pair? l) (begin (bytevector-u8-set! v i (car l)) (lp (+ i 1) (cdr l))) (begin (bytevector-u8-set! v i 0) (pointer->string vp))))) (lambda* (path attribute #:key (follow_symlink #t)) (let ((path (if (number? path) path (string->pointer (path-it path))))) (let lp ((size 128)) (let* ((v (make-bytevector size)) (pv (bytevector->pointer v))) (let ((n (rm (if (number? path) (ff path pv size) (if follow_symlink (f path pv size) (lf path pv size)))))) (if (> n (- size 2)) (lp (* 2 size)) (let lp ((i 0) (l '())) (if (< i n) (let lp2 ((j i) (r '())) (if (< j n) (let ((x (bytevector-u8-ref v j))) (if (= x 0) (if (null? r) (lp (+ j 1) l) (lp (+ j 1) (cons (mk (reverse r)) l))) (lp2 (+ j 1) (cons x r)))) (if (null? r) (lp j l) (lp j (cons (mk (reverse r)) l))))) (pylist (reverse l)))))))))))) (define removexattr #f) (defineu removexattr (2) (let ((f (pointer->procedure int (dynamic-func "removexattr" (dynamic-link)) (list '* '*))) (lf (pointer->procedure int (dynamic-func "lremovexattr" (dynamic-link)) (list '* '*))) (ff (pointer->procedure int (dynamic-func "fremovexattr" (dynamic-link)) (list int '*)))) (lambda* (path attribute #:key (follow_symlink #t)) (let ((path (if (number? path) path (string->pointer (path-it path)))) (k (ca (string->pointer attribute)))) (rm (if (number? path) (ff path k) (if follow_symlink (f path k) (lf path k)))))))) (define setxattr #f) (defineu setxattr (2) (let ((f (pointer->procedure int (dynamic-func "setxattr" (dynamic-link)) (list '* '* '* int int))) (lf (pointer->procedure int (dynamic-func "lsetxattr" (dynamic-link)) (list '* '* '* int int))) (ff (pointer->procedure int (dynamic-func "fsetxattr" (dynamic-link)) (list int '* '* int int)))) (lambda* (path attribute value flags #:key (follow_symlink #t)) (let* ((path (if (number? path) path (string->pointer (path-it path)))) (val (ca (string->pointer value))) (s (string-length val)) (k (ca (string->pointer attribute)))) (rm (if (number? path) (ff path k val s flags) (if follow_symlink (f path k val s flags) (lf path k val s flags)))))))) (define XATTR_SIZE_MAX (ash 1 16)) (define XATTR_CREATE 1) (define XATTR_REPLACE 2) ;; Processes (define (abort) ((@ (guile) raise) (@ (guile) SIGABRT))) (define (exists p) (if (number? p) (catch #t (lambda () ((@ (guile) readlink) (format #f "/proc/self/fd/~a" p))) (lambda x #f)) (catch #t (lambda () ((@ (guile) stat) (path-it p)) #t) (lambda x #f)))) (define (comp e pth) (if (eq? (string-ref pth 0) #\/) pth (let ((r (py-get e "PATH"))) (if r (let lp ((l (string-split r #\:))) (match l ((pp . l) (let ((newpath (string-join (cons pp pth) "/"))) (if (exists newpath) newpath (lp l)))) (() pth))) pth)))) (define (compe e) (for ((k v : e)) ((l '())) (cons (string-append k "=" v) l) #:final (reverse l))) (define (execl path . args) (apply (@ (guile) execl) (path-it path) args)) (define (execle path . args) (apply (@ (guile) execl) (path-it path) (let* ((a (reverse args)) (e (compe (car args))) (l (reverse (cdr args)))) (cons e l)))) (define (execlpe path . args) (let* ((a (reverse args)) (e (compe (car args))) (l (cons e (reverse (cdr args))))) (apply (@ (guile) execle) (comp e (path-it path)) l))) (define (execlp path . args) (apply (@ (guile) execlp) (path-it path) args)) (define (execv path args) (apply execl path (for ((a : args)) ((l '())) (cons a l) #:final (reverse l)))) (define (execve path args env ) (apply execle path (for ((a : args)) ((l (list env))) (cons a l) #:final (reverse l)))) (define (execvp path args) (apply execlp path (for ((a : args)) ((l '())) (cons a l) #:final (reverse l)))) (define (execvp path args env) (apply execlpe path (for ((a : args)) ((l (list env))) (cons a l) #:final (reverse l)))) (define (_exit n) (primitive-_exit n)) (define EX_OK 0) (define EX_USAGE 64) (define EX_DATAERR 65) (define EX_NOINPUT 66) (define EX_NOUSER 67) (define EX_NOHOST 68) (define EX_UNAVAILABLE 69) (define EX_SOFTWARE 70) (define EX_OSERR 71) (define EX_OSFILE 72) (define EX_CANTCREAT 73) (define EX_IOERR 74) (define EX_TEMPFAIL 75) (define EX_PROTOCOL 76) (define fork primitive-fork) (define (kill pid sig) (ca ((@ (guile) kill) pid sig))) (define (nice i) (ca ((@ (guile) nice) i))) (define killpg (let ((f (pointer->procedure int (dynamic-func "killpg" (dynamic-link)) (list int int)))) (lambda (pgid sig) (rm (f pgid sig))))) (define (plock . l) (error "not implemented")) (define* (popen com #:optional (mode "r") (buffering -1)) (let ((port (ca ((@ (ice-9 popen) open-pipe) com (cond ((equal? mode "r") OPEN_READ) ((equal? mode "w") OPEN_WRITE) ((or (equal? mode "rw") (equal? mode "r+") (equal? mode "w+") (equal? mode "wr")) OPEN_BOTH)))))) (ca (case buffering ((-1) (setvbuf port 'block DEFAULT_BUFFER_SIZE)) ((0) (setvbuf port 'none)) ((1) (setvbuf port 'line)) (else (setvbuf port 'block buffering)))) port)) (define P_WAIT 0) (define P_NOWAIT 1) (define P_NOWAIT0 1) (define-syntax-rule (mk-spawn f ff) (define (f mode . l) (let ((pid (primitive-fork))) (if (= l 0) (apply ff l) (cond ((= mode P_WAIT) (cdr ((@ (guile) waitpid) pid))) ((= mode P_NOWAIT) pid) (else (raise ValueError "wrong mode specified in spawn command"))))))) (mk-spawn spawnl execl) (mk-spawn spawnle execle) (mk-spawn spawnlp execlp) (mk-spawn spawnlpe execlpe) (mk-spawn spawnv execv) (mk-spawn spawnve execve) (mk-spawn spawnvp execvp) (mk-spawn spawnvpe execvpe) (define startfile (lambda x (error "not implemented"))) (define (system command) (ca ((@ (guile) system) command))) (define-python-class Times () (define __init__ (lambda (self v) (set self 'user (tms:utime v)) (set self 'system (tms:stime v)) (set self 'children_user (tms:cutime v)) (set self 'children_system (tms:cstime v)) (set self 'elapsed (tms:clock v)))) (define __repr__ (lambda (self) (format #f "Time(user:~a system:~a ...)" (ref self 'user) (ref self 'system))))) (define (times) (ca (Times ((@ (guile) times))))) (define (wait) (let ((x ((@ (guile) waitpid) -1))) (list (car x) (cdr x)))) (define-python-class SigInfo () (define __init__ (lambda (self a b c d e) (set self 'si_signo a) (set self 'si_code b) (set self 'si_pid c) (set self 'si_uid d) (set self 'si_status e))) (define __repr__ (lambda (self) (format #f "SigInfo(signo:~a code:~a pid:~a uid:~a status:~a" (ref self 'si_signo) (ref self 'si_code) (ref self 'si_pid) (ref self 'si_uid) (ref self 'si_status))))) (define waitid #f) (defineu waitid () (let ((f (pointer->procedure int (dynamic-func "waitid" (dynamic-link)) (list int int '* int)))) (lambda (idtype id options) (let* ((b (make-bytevector 228)) (vp (bytevector->pointer b)) (ref (lambda (i) (bytevector-s32-ref b i (native-endianness)))) (si_status (lambda () (ref 6))) (si_code (lambda () (ref 2))) (si_pid (lambda () (ref 4))) (si_uid (lambda () (ref 5))) (si_signo (lambda () (ref 0)))) (rm (f idtype id vp options)) (SigInfo (si_signo) (si_code) (si_pid) (si_uid) (si_status)))))) (define P_PID 1) (define P_PGID 2) (define P_ALL 0) (define WEXITED 4) (define WUNTRACED 2) (define WSTOPPED 2) (define WNOWAIT #x01000000) (define WCONTINUED 8) (define WNOHANG 1) (define CLD_EXITED 1) (define CLD_KILLED 2) (define CLD_DUMPED 3) (define CLD_STOPED 5) (define CLD_TRAPPED 4) (define CLD_CONTINUED 6) (define (waitpid pid options) (ca ((@ (guile) waitpid) pid options))) (define wait3 #f) (defineu wait3 () (let ((f (pointer->procedure int (dynamic-func "wait3" (dynamic-link)) (list '* int '*)))) (lambda (option) (let* ((v (make-bytevector 250)) (vp (bytevector->pointer v)) (w (make-bytevector 8)) (wp (bytevector->pointer w))) (let ((pid (rm (f wp option vp)))) (list pid (bytevector-s32-ref w 0 (native-endianness)) (ResUsage v))))))) (define wait4 #f) (defineu wait4 () (let ((f (pointer->procedure int (dynamic-func "wait4" (dynamic-link)) (list int '* int '*)))) (lambda (pid option) (let* ((v (make-bytevector 250)) (vp (bytevector->pointer v)) (w (make-bytevector 8)) (wp (bytevector->pointer w))) (let ((pid2 (rm (f pid wp option vp)))) (list pid (bytevector-s32-ref w 0 (native-endianness)) (ResUsage v))))))) (define __WCOREFLAG #x80) (define __W_CONTINUED #xffff) (define (WCOREDUMP status) (> (logand status __WCOREFLAG) 0)) (define (WIFCONTINUED status) (= status __W_CONTINUED)) (define (WIFSTOPPED status) (= (logand status #xff) #x7f)) (define (WIFSIGNALED status) (> (ash (+ (logand status #x7f) 1) -1) 0)) (define (WIFEXITED status) (= (WTERMSIG status) 0)) (define (WEXITSTATUS status) (ash (logand status #xff00) 8)) (define (WSTOPSIG status) (WEXITSTATUS status)) (define (WTERMSIG status) (logand status #x7f)) ;; Scheduling (define SCHED_OTHER 0) (define SCHED_BATCH 3) (define SCHED_IDLE 5) (define SCHED_FIFO 1) (define SCHED_RR 2) (define SCHED_RESET_ON_FORK #x40000000) (define-python-class sched_param () (define __init__ (lambda (self v) (if (bytevector? v) (set self 'sched_priority (bytevector-s32-ref v 0 (native-endianness))) (set self 'sched_priority v))))) (define sched_get_priority_min #f) (defineu sched_get_priority_min () (let ((f (pointer->procedure int (dynamic-func "sched_get_priority_min" (dynamic-link)) (list int)))) (lambda (policy) (rm (f policy))))) (define sched_get_priority_max #f) (defineu sched_get_priority_max () (let ((f (pointer->procedure int (dynamic-func "sched_get_priority_max" (dynamic-link)) (list int)))) (lambda (policy) (rm (f policy))))) (define sched_setscheduler #f) (defineu sched_setscheduler () (let ((f (pointer->procedure int (dynamic-func "sched_setscheduler" (dynamic-link)) (list int int '*)))) (lambda (pid policy param) (let* ((v (make-bytevector 32)) (vp (bytevector->pointer v))) (bytevector-s32-set! v 0 (ref param 'sched_priority) (native-endianness)) (rm (f pid policy vp)))))) (define sched_getscheduler #f) (defineu sched_getscheduler () (let ((f (pointer->procedure int (dynamic-func "sched_getscheduler" (dynamic-link)) (list int)))) (lambda (pid) (ca (f pid))))) (define sched_setparam #f) (defineu sched_setparam () (let ((f (pointer->procedure int (dynamic-func "sched_setparam" (dynamic-link)) (list int '*)))) (lambda (pid param) (let* ((v (make-bytevector 32)) (vp (bytevector->pointer v))) (bytevector-s32-set! v 0 (ref param 'sched_priority) (native-endianness)) (rm (f pid vp)))))) (define sched_getparam #f) (defineu sched_getparam () (let ((f (pointer->procedure int (dynamic-func "sched_getparam" (dynamic-link)) (list int '*)))) (lambda (pid param) (let* ((v (make-bytevector 32)) (vp (bytevector->pointer v))) (rm (f pid vp)) (sched_param v))))) (define sched_rr_get_intervall (lambda x (error "not implemented"))) (define sched_yield #f) (defineu sched_yield () (let ((f (pointer->procedure int (dynamic-func "sched_yield" (dynamic-link)) (list)))) (lambda () (rm (f))))) (define sched_setaffinity#f) (defineu sched_setaffinity () (let ((f (pointer->procedure int (dynamic-func "sched_setaffinity" (dynamic-link)) (list int int '*))) (n (/ 1024 64))) (lambda (pid mask) (let* ((v (make-bytevector (/ 1024 64))) (vp (bytevector->pointer v))) (for ((m : mask)) ((i (range 1000))) (bytevector-u64-set! v i (* m 8) (native-endianness))) (rm (f pid (/ n 8) vp)))))) (define sched_getaffinity #f) (defineu sched_getaffinity () (let ((f (pointer->procedure int (dynamic-func "sched_getaffinity" (dynamic-link)) (list int int '*))) (n (/ 1024 64))) (lambda (pid) (let* ((v (make-bytevector (/ 1024 64))) (vp (bytevector->pointer v))) (rm (f pid (/ n 8) vp)) (let lp ((i 0)) (if (< i n) (cons (bytevector-u64-ref v (* i 8) (native-endianness)) (lp (+ i 1))) '())))))) ;; MISC SYSTEM INFORMATION (defineu confstr_ () (let ((f (pointer->procedure int (dynamic-func "confstr" (dynamic-link)) (list int '* int)))) (lambda (id) (let* ((v (make-bytevector 1024)) (vp (bytevector->pointer v))) (rm (f id vp 1024)) (pointer->string vp))))) (define confstr_names (dict '(("LIBC_VERSION" . 2) ("LIBPTHREAD_VERSION" . 3) ("PATH" . 0)))) (define (confstr id) (let ((id2 (if (number? id) id (pylist-ref confstr_names id)))) (if id2 (confstr_ id2) (raise KeyError "no confstr for " id)))) (defineu cpu_count () (let ((f (pointer->procedure int (dynamic-func "get_nprocs" (dynamic-link)) (list)))) (lambda () (rm (f))))) (defineu sysconf_ () (let ((f (pointer->procedure long (dynamic-func "sysconf" (dynamic-link)) (list int)))) (lambda (id) (rm (f id))))) (define i 0) (define (f) (let ((r i)) (set! i (+ i 1)) r)) (define sysconf_names (dict `(("ARG_MAX" . ,(f)) ("CHILD_MAX" . ,(f)) ("CLK_TCK" . ,(f)) ("NGROUPS_MAX" . ,(f)) ("OPEN_MAX" . ,(f)) ("STREAM_MAX" . ,(f)) ("TZNAME_MAX" . ,(f)) ("JOB_CONTROL" . ,(f)) ("SAVED_IDS" . ,(f)) ("REALTIME_SIGNALS" . ,(f)) ("PRIORITY_SCHEDULING" . ,(f)) ("TIMERS" . ,(f)) ("ASYNCHRONOÙS_IO" . ,(f)) ("PRIORITIZED_IO" . ,(f)) ("SYNCHRONIZED_IO" . ,(f)) ("FSYNC" . ,(f)) ("MAPPED_FILES" . ,(f)) ("MEMLOCK" . ,(f)) ("MEMLOCK_RANGE" . ,(f)) ("MEMORY_PROTECTION" . ,(f)) ("MESSAGE_PASSING" . ,(f)) ("SEMAPHORES" . ,(f)) ("SHARED_MEMORY_OBJECTS" . ,(f)) ("AIO_LISTIO_MAX" . ,(f)) ("AIO_MAX" . ,(f)) ("AIO_PRIO_DELTA_MAX" . ,(f)) ("AIO_DELAYTIMER_MAX" . ,(f)) ("MQ_OPEN_MAX" . ,(f)) ("MQ_PRIO_MAX" . ,(f)) ("POSIX_VERSION" . ,(f)) ("PAGESIZE" . ,(f)) ("RTSIG_MAX" . ,(f)) ("SEM_NSEMS_MAX" . ,(f)) ("SEM_VALUE_MAX" . ,(f)) ("SIGQUEUE_MAX" . ,(f)) ("TIMER_MAX" . ,(f)) ("BC_BASE_MAX" . ,(f)) ("BC_DIM_MAX" . ,(f)) ("BC_SCALE_MAX" . ,(f)) ("BC_STRING_MAX" . ,(f)) ("COLL_WEIGHTS_MAX" . ,(f)) ("EQUIV_CLASS_MAX" . ,(f)) ("EXPR_NEST_MAX" . ,(f)) ("LINE_MAX" . ,(f)) ("RE_DUP_MAX" . ,(f)) ("CHARCLASS_NAME_MAX" . ,(f)) ("POSIX2_VERSION" . ,(f)) ("2_C_BIND" . ,(f)) ("2_C_DEV" . ,(f)) ("2_FORT_DEV" . ,(f)) ("2_FORT_RUN" . ,(f)) ("2_SW_DEF" . ,(f)) ("2_LOCALEDEF" . ,(f)) ("PII" . ,(f)) ("PII_XTI" . ,(f)) ("PII_SOCKET" . ,(f)) ("PII_INTERNET" . ,(f)) ("PII_OSI" . ,(f)) ("POLL" . ,(f)) ("SELECT" . ,(f)) ("UIO_MAXIOV" . ,i) ("IOV_MAX" . ,(f)) ("PII_INTERNET_STREAM" . ,(f)) ("PII_INTERNET_DGRAM" . ,(f)) ("PII_OSI_COTS" . ,(f)) ("PII_OSI_CLTS" . ,(f)) ("PII_OSI_M" . ,(f)) ("T_IOV_MAX" . ,(f)) ("THREADS" . ,(f)) ("THREAD_SAFE_FUNCTIONS" . ,(f)) ("GETGR_R_SIZE_MAX" . ,(f)) ("GETPW_R_SIZE_MAX" . ,(f)) ("LOGIN_NAME_MAX" . ,(f)) ("TTY_NAME_MAX" . ,(f)) ("THREAD_DESTRUCTOR_ITERATIONS" . ,(f)) ("THREAD_KEYS_MAX" . ,(f)) ("THREAD_STACK_MIN" . ,(f)) ("THREAD_THREADS_MAX" . ,(f)) ("THREAD_ATTR_STACKADDR" . ,(f)) ("THREAD_ATTR_STACKSIZE" . ,(f)) ("THREAD_PRIORITY_SCHEDULING" . ,(f)) ("THREAD_PRIO_INHERIT" . ,(f)) ("THREAD_PRIO_PROTECT" . ,(f)) ("THREAD_PROCESS_SHARED" . ,(f)) ("NPROCESSORS_CONF" . ,(f)) ("NPROCESSORS_ONLN" . ,(f)) ("PHYS_PAGES" . ,(f)) ("AVPHYS_PAGES" . ,(f)) ("ATEXIT_MAX" . ,(f)) ("PASS_MAX" . ,(f)) ("XOPEN_VERSION" . ,(f)) ("XOPEN_XCU_VERSION" . ,(f)) ("XOPEN_UNIX" . ,(f)) ("XOPEN_CRYPT" . ,(f)) ("XOPEN_ENH_I18N" . ,(f)) ("XOPEN_SHM" . ,(f)) ("2_CHAR_TERM" . ,(f)) ("2_C_VERSION" . ,(f)) ("2_UPE" . ,(f)) ("XOPEN_XPG2" . ,(f)) ("XOPEN_XPG3" . ,(f)) ("XOPEN_XPG4" . ,(f)) ("CHAR_BIT" . ,(f)) ("CHAR_MAX" . ,(f)) ("CHAR_MIN" . ,(f)) ("INT_MAX" . ,(f)) ("INT_MIN" . ,(f)) ("LONG_BIT" . ,(f)) ("WORD_BIT" . ,(f)) ("MB_LEN_MAX" . ,(f)) ("NZERO" . ,(f)) ("SSIZE_MAX" . ,(f)) ("SCHAR_MAX" . ,(f)) ("SCHAR_MIN" . ,(f)) ("SHRT_MAX" . ,(f)) ("SHRT_MIN" . ,(f)) ("UCHAR_MAX" . ,(f)) ("UINT_MAX" . ,(f)) ("ULONG_MAX" . ,(f)) ("USHRT_MAX" . ,(f)) ("NL_ARGMAX" . ,(f)) ("NL_LANGMAX" . ,(f)) ("NL_MSGMAX" . ,(f)) ("NL_NMAX" . ,(f)) ("NL_SETMAX" . ,(f)) ("NL_TEXTMAX" . ,(f)) ("XBS5_ILP32_OFF32" . ,(f)) ("XBS5_ILP32_OFFBIG" . ,(f)) ("XBS5_LP64_OFF64" . ,(f)) ("XBS5_LPBIG_OFFBIG" . ,(f)) ("XOPEN_LEGACY" . ,(f)) ("XOPEN_REALTIME" . ,(f)) ("XOPEN_REALTIME_THREADS" . ,(f)) ("ADVISORY_INFO" . ,(f)) ("BARRIERS" . ,(f)) ("BASE" . ,(f)) ("C_LANG_SUPPORT" . ,(f)) ("C_LANG_SUPPORT_R" . ,(f)) ("CLOCK_SELECTION" . ,(f)) ("CPUTIME" . ,(f)) ("THREAD_CPUTIME" . ,(f)) ("DEVICE_IO" . ,(f)) ("DEVICE_SPECIFIC" . ,(f)) ("DEVICE_SPECIFIC_R" . ,(f)) ("FD_MGMT" . ,(f)) ("FIFO" . ,(f)) ("PIPE" . ,(f)) ("FILE_ATTRIBUTES" . ,(f)) ("FILE_LOCKING" . ,(f)) ("FILE_SYSTEM" . ,(f)) ("MONOTONIC_CLOCK" . ,(f)) ("MULTI_PROCESS" . ,(f)) ("SINGLE_PROCESS" . ,(f)) ("NETWORKING" . ,(f)) ("READER_WRITER_LOCKS" . ,(f)) ("SPIN_LOCKS" . ,(f)) ("REGEXP" . ,(f)) ("REGEX_VERSION" . ,(f)) ("SHELL" . ,(f)) ("SIGNALS" . ,(f)) ("SPAWN" . ,(f)) ("SPORADIC_SERVER" . ,(f)) ("THREAD_SPORADIC_SERVER" . ,(f)) ("SYSTEM_DATABASE" . ,(f)) ("SYSTEM_DATABASE_R" . ,(f)) ("TIMEOUTS" . ,(f)) ("TYPED_MEMORY_OBJECTS" . ,(f)) ("USER_GROUPS" . ,(f)) ("USER_GROUPS_R" . ,(f)) ("2_PBS" . ,(f)) ("2_PBS_ACCOUNTING" . ,(f)) ("2_PBS_LOCATE" . ,(f)) ("2_PBS_MESSAGE" . ,(f)) ("2_PBS_TRACK" . ,(f)) ("SYMLOOP_MAX" . ,(f)) ("STREAMS" . ,(f)) ("2_PBS_CHECKPOINT" . ,(f)) ("V6_ILP32_OFF32" . ,(f)) ("V6_ILP32_OFFBIG" . ,(f)) ("V6_LP64_OFF64" . ,(f)) ("V6_LPBIG_OFFBIG" . ,(f)) ("HOST_NAME_MAX" . ,(f)) ("TRACE" . ,(f)) ("TRACE_EVENT_FILTER" . ,(f)) ("TRACE_INHERIT" . ,(f)) ("TRACE_LOG" . ,(f)) ("LEVEL1_ICACHE_SIZE" . ,(f)) ("LEVEL1_ICACHE_ASSOC" . ,(f)) ("LEVEL1_ICACHE_LINESIZE" . ,(f)) ("LEVEL1_DCACHE_SIZE" . ,(f)) ("LEVEL1_DCACHE_ASSOC" . ,(f)) ("LEVEL1_DCACHE_LINESIZE" . ,(f)) ("LEVEL2_CACHE_SIZE" . ,(f)) ("LEVEL2_CACHE_ASSOC" . ,(f)) ("LEVEL2_CACHE_LINESIZE" . ,(f)) ("LEVEL3_CACHE_SIZE" . ,(f)) ("LEVEL3_CACHE_ASSOC" . ,(f)) ("LEVEL3_CACHE_LINESIZE" . ,(f)) ("LEVEL4_CACHE_SIZE" . ,(f)) ("LEVEL4_CACHE_ASSOC" . ,(f)) ("LEVEL4_CACHE_LINESIZE" . ,(f)) ("IPV6 = _SC_LEVEL1_ICACHE_SIZE + 50" . ,(f)) ("RAW_SOCKETS" . ,(f)) ("V7_ILP32_OFF32" . ,(f)) ("V7_ILP32_OFFBIG" . ,(f)) ("V7_LP64_OFF64" . ,(f)) ("V7_LPBIG_OFFBIG" . ,(f)) ("SS_REPL_MAX" . ,(f)) ("TRACE_EVENT_NAME_MAX" . ,(f)) ("TRACE_NAME_MAX" . ,(f)) ("TRACE_SYS_MAX" . ,(f)) ("TRACE_USER_EVENT_MAX" . ,(f)) ("XOPEN_STREAMS" . ,(f)) ("THREAD_ROBUST_PRIO_INHERIT" . ,(f)) ("THREAD_ROBUST_PRIO_PROTECT" . ,(f))))) (define (sysconf id) (let ((id2 (if (number? id) id (pylist-ref sysconf_names id)))) (if id2 (sysconf_ id2) (raise KeyError "no sysconf str for " id)))) (defineu getloadavg () (let ((f (pointer->procedure long (dynamic-func "getloadavg" (dynamic-link)) (list '* int)))) (lambda () (let* ((v (make-bytevector (* 3 8))) (vp (bytevector->pointer v))) (rm (f vp 3)) (list (bytevector-ieee-double-ref v 0 (native-endianness)) (bytevector-ieee-double-ref v 8 (native-endianness)) (bytevector-ieee-double-ref v 16 (native-endianness))))))) (define curdir ".") (define pardir "..") (define sep "/") (define extsep ".") (define altsep None) (define pathsep ":") (define linesep "\n") (define defpath "/usr/bin/") (define devnull "/dev/null") (define RTLD_LAZY 1) (define RTLD_NOW 2) (define RTLD_GLOBAL #x100) (define RTLD_LOCAL 0) (define RTLD_NODELETE #x1000) (define RTLD_NOLOAD 4) (define RTLD_DEEPBIND 8) (define GRND_NONBLOCK 1) (define GRND_RANDOM 2) (define* (getrandom_ size #:optional (flags 0)) (define filename (if (> (logand flags GRND_RANDOM) 0) "/dev/random" "/dev/urandom")) (define port (open-file filename "r")) (if port (dynamic-wind (lambda () (values)) (lambda () (get-bytevector-n port size)) (lambda () ((@ (guile) close) port))) '())) (define (urandom size) (bytes (getrandom_ size))) (define (getrandom . l) (py-list (apply getrandom_ l))) (define path "posixpath")