debugged os
[software/python-on-guile.git] / modules / language / python / module / os.scm
1 (define-module (language python module os)
2 #:use-module (ice-9 match)
3 #:use-module (ice-9 ftw)
4 #:use-module (ice-9 control)
5 #:use-module (system foreign)
6 #:use-module (oop pf-objects)
7 #:use-module (oop goops)
8 #:use-module (rnrs bytevectors)
9 #:use-module (rnrs io ports)
10 #:use-module (language python for)
11 #:use-module (language python persist)
12 #:use-module (language python try)
13 #:use-module (language python module stat)
14 #:use-module (language python exceptions)
15 #:use-module (language python yield)
16 #:use-module (language python range)
17 #:use-module (language python string)
18 #:use-module (language python bytes)
19 #:use-module (language python dict)
20 #:use-module (language python set)
21 #:use-module (language python def)
22 #:use-module (language python module errno)
23 #:use-module (language python module resource)
24 #:use-module ((language python module python)
25 #:select ((open . builtin:open)))
26 #:use-module (language python list)
27 #:export (error name ctermid environ environb chdir fchdir getcwd
28 fsencode fdencode fspath PathLike getenv getenvb
29 get_exec_path getgid getegid geteuid fdopen
30 getgroups getgrouplist getlogin getpgid getpgrp getpid
31 getppid PRIO_PROCESS PRIO_PRGRP PRIO_USER getpriority
32 getresgid getuid initgroups putenv setegid seteuid
33 setgid setgroups setpgrp setpgid setpriority setregid
34 setresgid setreuid setresuid getsid setsid setuid strerr
35 umask uname unsetenv
36
37 path curdir pardir sep extsep altsep pathsep linesep defpath
38 devnull
39
40 dopen close closerange device_encoding dup dup2 fchmod fchown
41 fdatasync fpathconf fstat fstatvfs fsynch ftruncate isatty
42 F_LOCK F_TLOCK F_ULOCK F_TEST lockf
43 SEEK_SET SEEK_CUR SEEK_END SEEK_DATA SEEK_HOLE lseek
44 open O_RDONLY O_WRONLY O_RDWR O_APPEND O_CREAT O_EXCL
45 O_TRUNC O_SYNC O_NDELAY O_NONBLOCK O_NOCTTY O_LARGEFILE
46 O_NOTRANS O_DSYNC O_RSYNC O_CLOEXEC O_PATH O_DIRECTORY
47 O_NOFOLLOW O_DIRECT O_NOATIME O_ASYNC O_TMPFILE
48 openpty pipe pipe2 posix_fallocate
49 posix_fadvise POSIX_FADV_NORMAL POSIX_FADV_RANDOM
50 POSIX_FADV_SEQUENTIAL POSIX_FADV_WILLNEED
51 POSIX_FADV_DONTNEED POSIX_FADV_NOREUSE
52 pread pwrite read sendfile set_blocking get_blocking
53 set_blocking readv write writev set_inheritable
54 get_inheritable
55
56 getxattr listxattr removexattr setxattr XATTR_SIZE_MAX
57 XATTR_CREATE XATTR_REPLACE
58
59 abort
60 excl excle execlp execlpe excv excve execvp execvpe
61
62 _exit
63 EX_OK EX_USAGE EX_DATAERR EX_NOINPUT EX_NOUSER EX_NOHOST
64 EX_UNAVAILABLE EX_SOFTWARE EX_OSERR EX_OSFILE EX_CANTCREAT
65 EX_IOERR EX_TEMPFAIL EX_PROTOCOL
66
67 spawnl spawnle spawnlp spawnlpe spawnv spawnve spawnvp
68 spawnvpe
69
70 P_WAIT P_NOWAIT P_NOWAIT0
71
72 P_PID P_PGID P_ALL
73 WEXITED WUNTRACED WSTOPPED WNOWAIT WCONTINUED WNOHANG
74 CLD_EXITED CLD_KILLED CLD_DUMPED CLD_STOPED CLD_TRAPPED
75 CLD_CONTINUED
76
77 startfile system times wait waitid waitpid wait3 wait4
78
79 WCOREDUMP WIFCONTINUED WIFSTOPPED WIFSIGNALED WIFEXITED
80 WEXITSTATUS WSTOPSIG WTERMSIG
81
82 sched_get_priority_min sched_get_priority_max
83 sched_setscheduler sched_getscheduler sched_setparam
84 sched_getparam sched_rr_get_intervall sched_yield
85 sched_setaffinity sched_getaffinity
86
87 supports_dir_fs support_effective_ids supports_fd
88
89 confstr confstr_names cpu_count sysconf sysconf_names
90 getloadavg
91
92 RTLD_LAZY RTLD_NOW RTLD_GLOBAL RTLD_LOCAL RTLD_NODELETE
93 RTLD_NOLOAD RTLD_DEEPBIND
94
95 getrandom urandom GRND_NONBLOCK GRND_RANDOM
96 ))
97
98 (define supports_dir_fs
99 (py-set '()))
100
101 (define support_effective_ids
102 (py-set '()))
103
104 (define supports_fd
105 (py-set '()))
106
107 (define error OSError)
108 (define errno
109 (let ((f (dynamic-pointer "errno" (dynamic-link))))
110 (lambda ()
111 (pointer-address (dereference-pointer f)))))
112
113 (define-syntax-rule (aif it p x y) (let ((it p)) (if it x y)))
114 (define-syntax-rule (ca code)
115 (catch #t
116 (lambda () code)
117 (lambda x (raise error x))))
118 (define-syntax-rule (rm code)
119 (let ((r (ca code)))
120 (if (< r 0)
121 (raise error (errno) ((@ (guile) strerror) (errno)))
122 r)))
123
124 (define (py-add s x)
125 ((ref s 'add) x))
126
127 (define-syntax reg
128 (syntax-rules ()
129 ((_ () f)
130 (values))
131 ((_ (0 . l) f)
132 (begin
133 (py-add supports_dir_fs (symbol->string 'f))
134 (reg l f)))
135 ((_ (1 . l) f)
136 (begin
137 (py-add support_effective_ids (symbol->string 'f))
138 (reg l f)))
139 ((_ (2 . l) f)
140 (begin
141 (py-add supports_fd (symbol->string 'f))
142 (reg l f)))))
143
144 (define-syntax-rule (defineu f a x)
145 (begin
146 (define f
147 (catch #t
148 (lambda () x)
149 (lambda z
150 (let ((message (format #f "could not define ~a" 'f)))
151 (warn message)
152 (lambda z (error message))))))
153 (reg a f)))
154
155 (define-syntax guile
156 (syntax-rules ()
157 ((_ (x ...) code) (guile (x ...) code code))
158 ((_ (x ...) code1 code2)
159 (define code1 (lambda (x ...) (ca ((@ (guile) code2) x ...)))))
160 ((_ code) (guile code code))
161 ((_ code1 code2)
162 (define code1 (lambda x (ca (apply (@ (guile) code2) x)))))))
163
164
165 (define name "posix")
166 (guile ctermid)
167
168 (define-values (environ environb)
169 (let ()
170 (define e (dereference-pointer (dynamic-pointer "environ" (dynamic-link))))
171 (define (get-envs)
172 (let lp ((e e))
173 (let ((*e (dereference-pointer e)))
174 (if (null-pointer? *e)
175 '()
176 (cons
177 (pointer->string *e)
178 (lp (make-pointer (+ (pointer-address e) 8))))))))
179
180 (define (getkw)
181 (let lp ((es (get-envs)))
182 (if (pair? es)
183 (let ((x (string-split (car es) #\=)))
184 (let ((k (car x))
185 (v (string-join (cdr x) "=")))
186 (cons (cons k v) (lp (cdr es)))))
187 '())))
188
189 (define-python-class Env ()
190 (define __init__
191 (lambda (self) (values)))
192
193 (define __getitem__
194 (lambda (self k)
195 (let ((r ((@ (guile) getenv) (slot-ref (pystring k) 'str))))
196 (if r r (raise IndexError)))))
197
198 (define __setitem__
199 (lambda (self k v)
200 ((@ (guile) putenv) (slot-ref (pystring (+ k "=" v)) 'str))))
201
202 (define __delitem__
203 (lambda (self k)
204 ((@ (guile) putenv) (slot-ref (pystring k) 'str))))
205
206 (define __iter__
207 (lambda (self)
208 ((make-generator ()
209 (lambda (yield)
210 (for ((x : (getkw))) ()
211 (yield (car x) (cdr x)))))))))
212
213 (define-python-class Envb ()
214 (define __init__
215 (lambda (self) (values)))
216
217 (define __getitem__
218 (lambda (self k)
219 (let ((r (bytes ((@ (guile) getenv) (slot-ref (string k) 'str)))))
220 (if r r (raise IndexError)))))
221
222 (define __setitem__
223 (lambda (self k v)
224 ((@ (guile) putenv) (slot-ref (string (+ k "=" v)) 'str))))
225
226 (define __delitem__
227 (lambda (self k)
228 ((@ (guile) putenv) (slot-ref (string k) 'str))))
229
230 (define __iter__
231 (lambda (self)
232 ((make-generator ()
233 (lambda (yield)
234 (for ((x : (getkw))) ()
235 (yield (car x) (cdr x)))))))))
236
237
238 (values (Env) (Envb))))
239
240
241 (guile (path) chdir)
242
243 (define (fchdir fd)
244 (error "not implemented"))
245
246 (guile () getcwd)
247
248 (define (fsencode fn)
249 (error "not implemented"))
250 (define (fsdecode fn)
251 (error "not implemented"))
252
253 (define-method (fspath (pth <string> )) pth)
254 (define-method (fspath (pth <py-string> )) pth)
255 (define-method (fspath (pth <py-bytes> )) pth)
256 (define-method (fspath (pth <py-bytearray>)) pth)
257 (define-method (fspath (pth <p> ))
258 (aif it (ref pth '__fspath__)
259 (it)
260 (next-method)))
261
262 (define-python-class PathLike ()
263 (define __fspath__
264 (lambda (self) (error "not implemented"))))
265
266
267 (define* (getenv key #:key (default None))
268 (try
269 (lambda ()
270 (pylist-ref environ key))
271 (#:except IndexError => (lambda x default))))
272
273 (define* (getenvb key #:key (default None))
274 (try
275 (lambda ()
276 (pylist-ref environb key))
277 (#:except IndexError => (lambda x default))))
278
279 (define* (get_exec_path #:key (env #f))
280 (define (f s)
281 (let ((s (slot-ref (string s) 'str)))
282 (string-split s ":")))
283 (if env
284 (f (pylist-ref env "PATH"))
285 (f (pylist-ref environ "PATH"))))
286
287 (guile () getgid)
288 (guile () getegid)
289 (guile () geteuid)
290
291 (define (getgrouplist user group)
292 (error "not impllemeneted"))
293
294 (guile () getgroups)
295
296 (guile getlogin)
297
298 (define getpgid
299 (let ((f (pointer->procedure int
300 (dynamic-func "getpgid" (dynamic-link))
301 (list int))))
302 (lambda (pid)
303 (rm (f pid)))))
304
305
306 (guile getpgrp)
307 (guile getpid)
308 (guile getppid)
309
310 (define PRIO_PROCESS (@ (guile) PRIO_PROCESS))
311 (define PRIO_PGRP (@ (guile) PRIO_PGRP))
312 (define PRIO_USER (@ (guile) PRIO_USER))
313
314 (guile getpriority)
315
316 (define getresgid #f)
317 (defineu getresgid ()
318 (let* ((f (pointer->procedure
319 void
320 (dynamic-func "getresgid" (dynamic-link))
321 '(* * *))))
322
323 (lambda ()
324 (let* ((a (make-bytevector 8))
325 (ap (bytevector->pointer a))
326 (b (make-bytevector 8))
327 (bp (bytevector->pointer b))
328 (c (make-bytevector 8))
329 (cp (bytevector->pointer c)))
330 (rm (f ap bp cp))
331 (list
332 (bytevector-u16-ref a 0 (native-endianness))
333 (bytevector-u16-ref b 0 (native-endianness))
334 (bytevector-u16-ref c 0 (native-endianness)))))))
335
336 (guile getuid)
337
338 (define initgroups #f)
339 (defineu initgroups ()
340 (let ((f (pointer->procedure
341 int
342 (dynamic-func "initgroups" (dynamic-link))
343 (list '* int))))
344
345 (lambda (user group)
346 (rm (f (string->pointer user) group)))))
347
348 (define (putenv key value)
349 (pylist-set! environ key value))
350
351 (guile setegid)
352 (guile seteuid)
353 (guile setgid)
354
355 (guile setgroups)
356 (define setpgrp #f)
357 (defineu setpgrp ()
358 (let ((f (pointer->procedure int
359 (dynamic-func "setpgrp" (dynamic-link))
360 '())))
361 (lambda ()
362 (rm (f)))))
363
364 (guile setpgid)
365 (guile setpriority)
366
367 (define setregid #f)
368 (define setregid
369 (let ((f (pointer->procedure int
370 (dynamic-func "setregid" (dynamic-link))
371 (list int int))))
372 (lambda (a b)
373 (rm (f a b)))))
374
375 (define setresgid #f)
376 (define setresgid
377 (let ((f (pointer->procedure int
378 (dynamic-func "setresgid" (dynamic-link))
379 (list int int int))))
380 (lambda (a b c)
381 (rm (f a b c)))))
382
383 (define setreuid #f)
384 (defineu setreuid ()
385 (let ((f (pointer->procedure int
386 (dynamic-func "setreuid" (dynamic-link))
387 (list int int))))
388 (lambda (a b)
389 (rm (f a b)))))
390
391 (define setresuid #f)
392 (defineu setresuid ()
393 (let ((f (pointer->procedure int
394 (dynamic-func "setresuid" (dynamic-link))
395 (list int int int))))
396 (lambda (a b c)
397 (rm (f a b c)))))
398
399 (guile getsid)
400 (guile setsid)
401 (guile setuid)
402 (guile strerror)
403 (guile umask)
404 (guile uname)
405 (guile unsetenv)
406
407 ;; File descriptor operations
408
409 (define close
410 (lambda (fd)
411 (ca ((@ (guile) close-fdes) fd))))
412
413 (define (closerange fd_low fd_high)
414 (for ((i : (range fd_low fd_high))) ()
415 (try
416 (lambda () (close i))
417 (#:except OSError => (lambda x (values))))))
418
419 (define device_encoding (lambda (fd) (error "not implemented")))
420
421 (guile (fd) dup)
422
423 (define dup2
424 (let ((f (pointer->procedure int
425 (dynamic-func "dup3" (dynamic-link))
426 (list int int int))))
427 (lambda* (fd fd2 #:optional (inheritable? #t))
428 (if inheritable?
429 (rm (f fd fd2 O_CLOEXEC))
430 (ca ((@ (guile) dup2) fd fd2))))))
431
432 (guile (fd mode) fchmod)
433 (guile (fd uid gid) fchown)
434
435
436 (define (fdatasync fd) (error "not implemented"))
437 (define (fpathconf fd name) (error "not implemented"))
438
439 (define-syntax-rule (concat a ... stx)
440 (datum->syntax
441 stx
442 (string->symbol
443 (string-append
444 a ...
445 (symbol->string
446 (syntax->datum stx))))))
447
448 (define-syntax statset
449 (lambda (x)
450 (syntax-case x ()
451 ((_ (m ...) self scm)
452 #'(begin (statset 1 m self scm) ...))
453 ((_ 1 (m mm) self scm)
454 (with-syntax ((mem (concat "st_" #'mm))
455 (smem (concat "stat:" #'m)))
456 #'(set self 'mem (smem scm))))
457 ((_ 1 m self scm)
458 #'(statset 1 (m m) self scm)))))
459
460 (define stat-float-times #t)
461
462 (define-python-class stat_result ()
463 (define __init__
464 (lambda (self scm)
465 (ca
466 (begin
467 (statset (mode ino dev nlink uid gid size atime mtime ctime
468 (atimensec atime_ns)
469 (mtimensec mtime_ns)
470 (ctimensec ctime_ns)
471 blksize blocks perms rdev type)
472 self scm)
473 (if stat-float-times
474 (begin
475 (set self 'atime (* (ref self 'atime) 1.0))
476 (set self 'mtime (* (ref self 'mtime) 1.0))
477 (set self 'ctime (* (ref self 'ctime) 1.0))
478 (set self 'atime_ns (/ (ref self 'atime_ns) 1000000000.0))
479 (set self 'mtime_ns (/ (ref self 'mtime_ns) 1000000000.0))
480 (set self 'ctime_ns (/ (ref self 'ctime_ns) 1000000000.0)))))))))
481
482 (name-object stat_result)
483
484 (define (fstat fd)
485 (stat_result (stat fd)))
486
487 (define (fstatvfs fd) (error "not implemented"))
488
489 (guile (fd) fsynch fsync)
490
491 (guile (fd len) ftruncate truncate-file)
492
493 (guile (fd) isatty isatty?)
494
495 (define F_LOCK 1)
496 (define F_TLOCK 2)
497 (define F_ULOCK 0)
498 (define F_TEST 3)
499
500 (define lockf #f)
501 (defineu lockf (2)
502 (let ((f (pointer->procedure int
503 (dynamic-func "lockf" (dynamic-link))
504 (list int int long))))
505 (lambda (fd op len)
506 (rm (f fd op len)))))
507
508
509
510 (define SEEK_SET #x0)
511 (define SEEK_CUR #x1)
512 (define SEEK_END #x2)
513 (define SEEK_DATA #x3)
514 (define SEEK_HOLE #x4)
515
516 (define lseek #f)
517 (defineu lseek (2)
518 (let ((f (pointer->procedure int
519 (dynamic-func "lseek" (dynamic-link))
520 (list int long int))))
521 (lambda (fd pos how)
522 (rm (f fd pos how)))))
523
524 (define open
525 (let ((f (pointer->procedure int
526 (dynamic-func "openat" (dynamic-link))
527 (list int '* int int))))
528
529 (lambda* (path flags mode #:optional (dir_fd None))
530 (if (eq? dir_fd None)
531 (ca (open-fdes path flags mode))
532 (rm (f dir_fd (string->pointer path) flags mode))))))
533
534
535 (define-syntax-rule (mko O) (define O (@ (guile) O)))
536 (mko O_RDONLY)
537 (mko O_WRONLY)
538 (mko O_RDWR)
539 (mko O_APPEND)
540 (mko O_CREAT)
541 (mko O_EXCL)
542 (mko O_TRUNC)
543
544 ;;unix
545 (mko O_SYNC)
546 (mko O_NDELAY)
547 (mko O_NONBLOCK)
548 (mko O_NOCTTY)
549
550 ;;
551 (mko O_LARGEFILE)
552 (mko O_NOTRANS)
553
554 (define O_DSYNC #o10000)
555 (define O_RSYNC O_SYNC)
556 (define O_CLOEXEC #o2000000)
557 (define O_PATH #o10000000)
558 (define O_DIRECTORY #o200000)
559 (define O_NOFOLLOW #o400000)
560 (define O_DIRECT #o40000)
561 (define O_NOATIME #o1000000)
562 (define O_ASYNC #o20000)
563 (define O_TMPFILE (logior #o20000000 O_DIRECTORY))
564
565 (define openpty (lambda x (error "not implemented")))
566
567 (define fdopen builtin:open)
568
569 (define pipe
570 (let ((x (ca ((@ (guile) pipe)))))
571 (values (car x) (cdr x))))
572
573 (define pipe2 #f)
574 (defineu pipe2 ()
575 (let ((f (pointer->procedure int
576 (dynamic-func "pipe2" (dynamic-link))
577 (list int '* int))))
578 (lambda (flags)
579 (let* ((a (make-bytevector 8))
580 (ap (bytevector->pointer a)))
581 (rm (f ap flags))
582 (values (bytevector-s32-ref a 0 (native-endianness))
583 (bytevector-s32-ref a 4 (native-endianness)))))))
584
585
586 (define posix_fallocate #f)
587 (defineu posix_fallocate (2)
588 (let ((f (pointer->procedure int
589 (dynamic-func "posix_fallocate" (dynamic-link))
590 (list int long long))))
591 (lambda (fd off len)
592 (rm (f fd off len)))))
593
594 (define posix_fadvise #f)
595 (defineu posix_fadvise (2)
596 (let ((f (pointer->procedure int
597 (dynamic-func "posix_fadvise" (dynamic-link))
598 (list int long long int))))
599 (lambda (fd off len advice)
600 (rm (f fd off len advice)))))
601
602 (define POSIX_FADV_NORMAL 0)
603 (define POSIX_FADV_RANDOM 1)
604 (define POSIX_FADV_SEQUENTIAL 2)
605 (define POSIX_FADV_WILLNEED 3)
606 (define POSIX_FADV_DONTNEED 4)
607 (define POSIX_FADV_NOREUSE 5)
608
609 (define pread #f)
610 (defineu pread (2)
611 (let ((f (pointer->procedure int
612 (dynamic-func "pread" (dynamic-link))
613 (list int '* long long))))
614 (lambda (fd size offset)
615 (let* ((a (make-bytevector size))
616 (ap (bytevector->pointer a)))
617 (let ((n (rm (f fd ap size offset))))
618 (if (= n 0)
619 (make-bytevector 0)
620 (let ((o (make <bytevector>)))
621 (slot-set! o 'n (size))
622 (slot-set! o 'size n)
623 (slot-set! o 'bv a)
624 o)))))))
625
626 (define pwrite #f)
627 (defineu pwrite (2)
628 (let ((f (pointer->procedure int
629 (dynamic-func "pwrite" (dynamic-link))
630 (list int '* long long))))
631
632 (lambda (fd a offset)
633 (let* ((ap (bytevector->pointer (slot-ref (bytes a) 'bytes))))
634 (rm (f fd ap (len a) offset))))))
635
636 (define read #f)
637 (defineu read (2)
638 (let ((f (pointer->procedure int
639 (dynamic-func "read" (dynamic-link))
640 (list int '* long))))
641 (lambda (fd size)
642 (let* ((a (make-bytevector size))
643 (ap (bytevector->pointer a)))
644 (let ((n (rm (f fd ap size))))
645 (if (= n 0)
646 (make-bytevector 0)
647 (let ((o (make <bytevector>)))
648 (slot-set! o 'n (size))
649 (slot-set! o 'size n)
650 (slot-set! o 'bv a)
651 o)))))))
652
653
654 (define (sendfile out in offset count)
655 (ca
656 (if (eq? count None)
657 ((@ (guile) sendfile) out in count)
658 ((@ (guile) sendfile) out in count offset))))
659
660 (define F_GETFL 3)
661
662 (define fcntl2 #f)
663 (define fcntl3 #f)
664 (defineu fcntl2 () (pointer->procedure int
665 (dynamic-func "fcntl" (dynamic-link))
666 (list int int)))
667 (defineu fcntl3 () (pointer->procedure int
668 (dynamic-func "fcntl" (dynamic-link))
669 (list int int int)))
670
671 (define (set_blocking fd is-blocking?)
672 (let ((o (rm (fcntl2 fd F_GETFL))))
673 (if is-blocking?
674 (rm (fcntl3 fd F_GETFL (logior o O_NONBLOCK)))
675 (rm (fcntl3 fd F_GETFL (logand o (lognot O_NONBLOCK)))))))
676
677 (define (get_blocking fd)
678 (if (= (logand O_NONBLOCK (rm (fcntl2 fd F_GETFL))) 0)
679 #f
680 #t))
681
682 (define (readv fd buffers) (error "not implemented"))
683
684 (guile (fd pg) tcsetpgrp)
685 (guile (fd) ttyname)
686
687 (define write #f)
688 (defineu write (2)
689 (let ((f (pointer->procedure int
690 (dynamic-func "write" (dynamic-link))
691 (list int '* long))))
692
693 (lambda (fd a)
694 (let* ((ap (bytevector->pointer (slot-ref (bytes a) 'bytes))))
695 (rm (f fd ap (len a)))))))
696
697 (define (writev fd buffers) (error "not implemented"))
698
699
700 (define (set_inheritable fd is-inh?)
701 (let ((o (rm (fcntl2 fd F_GETFL))))
702 (if is-inh?
703 (rm (fcntl3 fd F_GETFL (logior o O_CLOEXEC)))
704 (rm (fcntl3 fd F_GETFL (logand o (lognot O_CLOEXEC)))))))
705
706 (define (get_inheritable fd)
707 (if (= (logand O_CLOEXEC (rm (fcntl2 fd F_GETFL))) 0)
708 #f
709 #t))
710
711
712 ;; Files and dir
713 (define AT_EACCESS #x200)
714 (define AT_SYMLINK_NOFOLLOW #x100)
715
716 (define F_OK (@ (guile) F_OK))
717 (define W_OK (@ (guile) W_OK))
718 (define R_OK (@ (guile) R_OK))
719 (define X_OK (@ (guile) X_OK))
720
721 (define access #f)
722 (defineu access (0 1)
723 (let ((f (pointer->procedure int
724 (dynamic-func "access" (dynamic-link))
725 (list '* int)))
726 (fa (pointer->procedure int
727 (dynamic-func "faccessat" (dynamic-link))
728 (list '* int int int))))
729
730 (lambda* (path mode #:key
731 (dir_fd None)
732 (effective_ids #f)
733 (follow_symlinks #t))
734 (if (eq? dir_fd None)
735 (rm (f (string->pointer path) mode))
736 (rm (fa (string->pointer path) mode dir_fd
737 (logior (if effective_ids AT_EACCESS 0)
738 (if follow_symlinks 0 AT_SYMLINK_NOFOLLOW))))))))
739
740
741 (define chdir #f)
742 (defineu chdir (2)
743 (let ((f (pointer->procedure int
744 (dynamic-func "chdir" (dynamic-link))
745 '(*))))
746 (lambda (pth)
747 (let ((pth (aif it (ref pth '__fspath__)
748 (it)
749 pth)))
750 (if (number? pth)
751 (rm (f pth))
752 (ca ((@ (guile) chdir) pth)))))))
753
754
755 (define chflags
756 (lambda x (error "Not implemented")))
757
758 (define chmod (lambda x #f))
759 (defineu chmod (0 2)
760 (let ((f (pointer->procedure int
761 (dynamic-func "chmod" (dynamic-link))
762 (list '* int)))
763 (ff (pointer->procedure int
764 (dynamic-func "fchmod" (dynamic-link))
765 (list int int)))
766 (fat (pointer->procedure int
767 (dynamic-func "fchmodat" (dynamic-link))
768 (list '* int int int))))
769 (lambda* (path mode #:key (dir_fd None) (follow_symlinks #t))
770 (if (number? path)
771 (rm (ff path mode))
772 (let ((path (aif it (ref path '__fspath__)
773 (it)
774 path)))
775 (if (eq? dir_fd None)
776 (rm (f (string->pointer path) mode))
777 (rm (fat (string->pointer path) mode
778 dir_fd
779 (if follow_symlinks
780 0
781 AT_SYMLINK_NOFOLLOW)))))))))
782
783
784
785 (define (path-it path)
786 (aif it (ref path '__fspath__)
787 (it)
788 path))
789
790 (define chown (lambda x #f))
791 (defineu chown (0 2)
792 (let ((f (pointer->procedure int
793 (dynamic-func "chown" (dynamic-link))
794 (list '* int int)))
795 (ff (pointer->procedure int
796 (dynamic-func "fchown" (dynamic-link))
797 (list int int int)))
798 (lf (pointer->procedure int
799 (dynamic-func "lchown" (dynamic-link))
800 (list '* int int)))
801 (fat (pointer->procedure int
802 (dynamic-func "fchownat" (dynamic-link))
803 (list '* int int int int))))
804 (lambda* (path uid gid #:key (dir_fd None) (follow_symlinks #t))
805 (if (number? path)
806 (rm (ff path uid gid))
807 (let ((path (path-it path)))
808 (if (eq? dir_fd None)
809 (if follow_symlinks
810 (rm (f (string->pointer path) uid gid))
811 (rm (lf (string->pointer path) uid gid)))
812 (rm (fat (string->pointer path) uid gid dir_fd
813 (if follow_symlinks
814 0
815 AT_SYMLINK_NOFOLLOW)))))))))
816
817 (guile (x) chroot)
818
819 (define fchdir chdir)
820
821 (guile () getcwd)
822
823 (define (getcwdb)
824 (bytes (getcwd)))
825
826 (define lchflags (lambda x (error "not implemented")))
827
828 (define (lchmod path mode)
829 (chmod path mode #:follow_symlinks #f))
830
831 (define (lchown path uid gid)
832 (chown path uid gid #:follow_symlinks #f))
833
834 (define AT_FDCWD -100)
835
836 (define link #f)
837 (defineu link (0)
838 (let ((f (pointer->procedure int
839 (dynamic-func "linkat" (dynamic-link))
840 (list '* '* int int int))))
841 (lambda* (src dst #:key
842 (src_dir_fd None)
843 (dst_dir_fd None)
844 (follow_symlinks #t))
845 (let ((src (path-it src))
846 (dst (path-it dst))
847 (src_dir_fd (if (eq? src_dir_fd None) AT_FDCWD src_dir_fd))
848 (dst_dir_fd (if (eq? dst_dir_fd None) AT_FDCWD dst_dir_fd)))
849 (rm (f (string->pointer src)
850 (string->pointer dst)
851 src_dir_fd
852 dst_dir_fd
853 (if follow_symlinks
854 0
855 AT_SYMLINK_NOFOLLOW)))))))
856
857 (define listdir
858 (lambda* (#:optional (pth "."))
859 (let ((pth (if (number? pth)
860 ((@ (guile) read-link) (format #f "/proc/self/fd/~a" pth))
861 (path-it pth))))
862 (let ((o (ca (opendir pth))))
863 (dynamic-wind
864 (lambda x #f)
865 (lambda ()
866 (let lp ((o o))
867 (let ((w (ca (readdir o))))
868 (if (eof-object? w)
869 '()
870 (if (or (equal? w ".") (equal? w ".."))
871 (lp o)
872 (cons w (lp o)))))))
873 (lambda x (closedir o)))))))
874
875 (define stat (lambda x #f))
876 (defineu stat (0 2)
877 (let ((f (pointer->procedure int
878 (dynamic-func "__fxstatat" (dynamic-link))
879 (list int int '* '* int)))
880 (g (pointer->procedure '*
881 (dynamic-func "scm_stat2scm_" (dynamic-link))
882 '(*))))
883 (lambda* (path #:key (dir_fd None) (follow_symlinks #t))
884 (if (number? path)
885 (stat_result ((@ (guile) stat) path))
886 (let ((path (path-it path)))
887 (if (eq? dir_fd None)
888 (if follow_symlinks
889 (stat_result ((@ (guile) stat) path))
890 (stat_result ((@ (guile) lstat) path)))
891 (let* ((bv (make-bytevector 80))
892 (bvp (bytevector->pointer bv)))
893 (rm (f 1 ;Special linux flag
894 (string->pointer path)
895 bvp
896 (if follow_symlinks
897 0
898 AT_SYMLINK_NOFOLLOW)))
899 (stat_result (ca (pointer->scm (g bvp)))))))))))
900
901 (define lstat
902 (lambda* (path #:key (dir_fd None))
903 (stat path #:dir_fd dir_fd #:follow_symlinks #f)))
904
905 (define mkdir #f)
906 (defineu mkdir (0)
907 (let ((fat (pointer->procedure int
908 (dynamic-func "mkdirat" (dynamic-link))
909 (list int '* int))))
910 (lambda* (path mode #:key (dir_fd None))
911 (rm (fat (if (eq? dir_fd None) AT_FDCWD dir_fd)
912 (string->pointer (path-it path))
913 mode)))))
914
915 (define* (mkdirs name mode #:key (exist_ok #f))
916 (let lp ((pre "") (l (string-split (path-it name) #\/)))
917 (match l
918 (() (values))
919 ((x) (let ((s (string-append pre "/" x)))
920 (catch #t
921 (lambda ()
922 ((@ (guile) stat) s)
923 (if exist_ok
924 (values)
925 (raise error
926 (format #f "dir ~a in mkdirs already exist" s))))
927 (lambda x
928 (mkdir s mode)))))
929 ((x . l)
930 (let ((s (string-append pre "/" x)))
931 (catch #t
932 (lambda ()
933 ((@ (guile) stat) s))
934 (lambda x
935 (mkdir s mode)))
936 (lp s l))))))
937
938 (define mkfifo #f)
939 (defineu mkfifo (0)
940 (let ((fat (pointer->procedure int
941 (dynamic-func "mkfifoat" (dynamic-link))
942 (list int '* int))))
943 (lambda* (path mode #:key (dir_fd None))
944 (rm (fat (if (eq? dir_fd None) AT_FDCWD dir_fd)
945 (string->pointer (path-it path))
946 mode)))))
947
948 (define mknod #f)
949 (defineu mknod (0)
950 (let ((fat (pointer->procedure int
951 (dynamic-func "__xmknodat" (dynamic-link))
952 (list int int '* int))))
953 (lambda* (path mode #:optional (device 0) #:key (dir_fd None))
954 (rm (fat 1 (if (eq? dir_fd None) AT_FDCWD dir_fd)
955 (string->pointer (path-it path))
956 mode
957 device)))))
958
959 (define major #f)
960 (defineu major ()
961 (let ((f (pointer->procedure int
962 (dynamic-func "gnu_dev_major" (dynamic-link))
963 (list int64))))
964 (lambda (device)
965 (ca (f device)))))
966
967 (define minor #f)
968 (defineu minor ()
969 (let ((f (pointer->procedure int
970 (dynamic-func "gnu_dev_minor" (dynamic-link))
971 (list int64))))
972 (lambda (device)
973 (ca (f device)))))
974
975 (define makedev #f)
976 (defineu makedev ()
977 (let ((f (pointer->procedure int64
978 (dynamic-func "gnu_dev_makedev" (dynamic-link))
979 (list int int))))
980 (lambda (major minor)
981 (ca (f major minor)))))
982
983 (define pathconf_names (dict))
984 (pylist-set! pathconf_names "PC_LINK_MAX" 0)
985 (pylist-set! pathconf_names "PC_MAX_CANON" 1)
986 (pylist-set! pathconf_names "PC_MAX_INPUT" 2)
987 (pylist-set! pathconf_names "PC_NAME_MAX" 3)
988 (pylist-set! pathconf_names "PC_PATH_MAX" 4)
989 (pylist-set! pathconf_names "PC_PIPE_BUF" 5)
990 (pylist-set! pathconf_names "PC_CHOWN_RESTRICTED" 6)
991 (pylist-set! pathconf_names "PC_NO_TRUNC" 7)
992 (pylist-set! pathconf_names "PC_VDISABLE" 8)
993
994 (define-syntax-rule (rmp code)
995 (let ((e (errno))
996 (r (ca code)))
997 (if (>= r 0)
998 r
999 (let ((e2 (errno)))
1000 (if (eq? e e2)
1001 (error "Bug could not find pathcond name endex")
1002 (rm e2))))))
1003
1004
1005 (define pathconf #f)
1006 (defineu pathconf (2)
1007 (let ((f (pointer->procedure long
1008 (dynamic-func "pathconf" (dynamic-link))
1009 (list '* int)))
1010 (ff (pointer->procedure long
1011 (dynamic-func "fpathconf" (dynamic-link))
1012 (list int int))))
1013 (lambda (path name)
1014 (let ((ni (pylist-ref pathconf_names name)))
1015 (if (number? path)
1016 (rmp (ff path ni))
1017 (let ((path (path-it path)))
1018 (rmp (f (string->pointer path) ni))))))))
1019
1020 (define readlink #f)
1021 (defineu readlink (0)
1022 (let ((fat (pointer->procedure int
1023 (dynamic-func "readlinkat" (dynamic-link))
1024 (list int '* '* long))))
1025 (lambda* (path #:key (dir_fd None))
1026 (let* ((n 10000)
1027 (bv (make-bytevector 10000))
1028 (bvp (bytevector->pointer bv)))
1029 (rm (fat (if (eq? dir_fd None) AT_FDCWD dir_fd)
1030 (string->pointer (path-it path))
1031 bvp
1032 n))
1033 (bytevector-u8-set! bv (- n 1) 0)
1034 (pointer->string bvp)))))
1035
1036 (define remove #f)
1037 (defineu remove (0)
1038 (let ((fat (pointer->procedure int
1039 (dynamic-func "unlinkat" (dynamic-link))
1040 (list int '* int))))
1041 (lambda* (path #:key (dir_fd None))
1042 (rm (fat (if (eq? dir_fd None) AT_FDCWD dir_fd)
1043 (string->pointer (path-it path))
1044 0)))))
1045
1046 (define unlink remove)
1047
1048 (define rmdir
1049 (lambda* (path #:key (dir_fd None))
1050 (let ((path (path-it path)))
1051 (if (eq? dir_fd None)
1052 ((@ (guile) rmdir) path)
1053 (let* ((fd (open path O_DIRECTORY #:dir_fd dir_fd))
1054 (path ((@ (guile) read-link) '
1055 (format #f "/proc/self/fd/~a" fd))))
1056 (close fd)
1057 ((@ (guile) rmdir) path))))))
1058
1059 (define (removedirs name)
1060 (let ((name (path-it name)))
1061 (let lp ((l (reverse (string-split name #\/))))
1062 (if (pair? l)
1063 (let ((path (string-join (reverse l) "/")))
1064 (catch #t
1065 (lambda () (rmdir path))
1066 (lambda x (values)))
1067 (lp (cdr l)))))))
1068
1069 (define rename #f)
1070 (defineu rename (0)
1071 (let ((fat (pointer->procedure int
1072 (dynamic-func "renameat" (dynamic-link))
1073 (list int '* int '*))))
1074 (lambda* (src dst #:key (src_dir_fd None) (dst_dir_fd None))
1075 (rm (fat (if (eq? src_dir_fd None) AT_FDCWD src_dir_fd)
1076 (string->pointer (path-it src))
1077 (if (eq? dst_dir_fd None) AT_FDCWD dst_dir_fd)
1078 (string->pointer (path-it src)))))))
1079
1080
1081 (define replace rename)
1082
1083 (define (renames old new)
1084 (let ((old (path-it old))
1085 (new (path-it new)))
1086 (let lp ((l (string-split new #\/)) (d '()))
1087 (match l
1088 (() #t)
1089 ((x) #t)
1090 (("" . l)
1091 (lp l (cons "" d)))
1092 ((x . l)
1093 (if (pair? d)
1094 (let ((path (string-join (reverse d) "/")))
1095 (catch #t
1096 (lambda () (stat path))
1097 (lambda x (mkdir path)))
1098 (lp l (cons x d)))
1099 (lp l (cons x d))))))
1100 (rename old new)
1101 (let ((l (string-split old #\/)))
1102 (if (> (length l) 1)
1103 (if (= (length l) 2)
1104 (removedirs (string-append (car l) "/"))
1105 (removedirs (string-join (reverse (cdr (reverse l))) "/")))))
1106 (values)))
1107
1108
1109
1110 (define-python-class DirEntry ()
1111 (define __init__
1112 (lambda (self path stat errno)
1113 (set self 'name (basename path))
1114 (set self 'path path)
1115 (set self '__errno errno)
1116 (set self '__stat stat)))
1117
1118 (define inode
1119 (lambda (self)
1120 (let ((stat (ref self '__stat)))
1121 (if stat
1122 (stat:ino stat)
1123 (raise error (ref self '__errno))))))
1124
1125 (define is_dir
1126 (lambda* (self #:key (follow_symlinks #t))
1127 (let ((s (stat (ref self 'path) #:follow_symlinks follow_symlinks)))
1128 ((@ (stat) is-dir?) (ref s '_st_mode)))))
1129
1130 (define is_file
1131 (lambda* (self #:key (follow_symlinks #t))
1132 (let ((s (stat (ref self 'path) #:follow_symlinks follow_symlinks)))
1133 ((@ (stat) is-reg?) (ref s '_st_mode)))))
1134
1135 (define is_symlink
1136 (lambda (self)
1137 (let ((s (stat (ref self 'path))))
1138 ((@ (stat) is-lnk?) (ref s '_st_mode)))))
1139
1140 (define stat
1141 (lambda* (self #:key (follow_symlinks #t))
1142 (stat (ref self 'path) #:follow_symlinks follow_symlinks))))
1143
1144 (define* (scandir #:optional (path "."))
1145 (make-generator ()
1146 (lambda (yield)
1147 (file-system-fold
1148 (lambda x #t)
1149 (lambda (path stat errno r)
1150 (yield (DirEntry path stat errno)))
1151 (lambda (path stat res)
1152 (yield (DirEntry path stat 0)))
1153 (lambda (path stat res)
1154 (values))
1155 (lambda (path stat res)
1156 (values))
1157 (lambda (path stat errno res)
1158 (values))
1159 #f
1160 (path-it path)))))
1161
1162 (define (stat_float_times newvalue)
1163 (set! stat-float-times newvalue))
1164
1165 (define ST_RDONLY 1)
1166 (define ST_NOSUID 2)
1167 (define ST_NODEV 4)
1168 (define ST_NOEXEC 8)
1169 (define ST_SYNCHRONOUS 16)
1170 (define ST_MANDLOCK 64)
1171 (define ST_WRITE 128)
1172 (define ST_APPEND 256)
1173 (define ST_IMMUTABLE 512)
1174 (define ST_NOATIME 1024)
1175 (define ST_NODIRATIME 2048)
1176 (define ST_RELATIME 4096)
1177
1178 (define-python-class StatVFS ()
1179 (define __init__
1180 (lambda (self a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11)
1181 (map
1182 (lambda (x y) (set self x y))
1183 '(f_bsize
1184 f_frsize
1185 f_blocks
1186 f_bfree
1187 f_bavail
1188 f_files
1189 f_ffree
1190 f_favail
1191 f_fsid
1192 f_flag
1193 f_namemax)
1194 (list a1 a2 a3 a4 a5 a6 a7 a8 a9 a10)))))
1195
1196 (define statvfs #f)
1197 (defineu statvfs (2)
1198 (let ((f (pointer->procedure int
1199 (dynamic-func "statvfs" (dynamic-link))
1200 (list '* '*)))
1201 (ff (pointer->procedure int
1202 (dynamic-func "fstatvfs" (dynamic-link))
1203 (list int '*))))
1204 (lambda (path)
1205 (let* ((bv (make-bytevector (* 11 8)))
1206 (bvp (bytevector->pointer bv)))
1207 (rm (if (number? path)
1208 (ff path bvp)
1209 (f (string->pointer (path-it path)) bvp)))
1210
1211 (StatVFS
1212 (bytevector-u64-ref bv (* 0 8) (native-endianness))
1213 (bytevector-u64-ref bv (* 1 8) (native-endianness))
1214 (bytevector-u64-ref bv (* 2 8) (native-endianness))
1215 (bytevector-u64-ref bv (* 3 8) (native-endianness))
1216 (bytevector-u64-ref bv (* 4 8) (native-endianness))
1217 (bytevector-u64-ref bv (* 5 8) (native-endianness))
1218 (bytevector-u64-ref bv (* 6 8) (native-endianness))
1219 (bytevector-u64-ref bv (* 7 8) (native-endianness))
1220 (bytevector-u64-ref bv (* 9 8) (native-endianness))
1221 (bytevector-u64-ref bv (* 10 8) (native-endianness)))))))
1222
1223 (define symlink #f)
1224 (defineu symlink (0)
1225 (let ((fat (pointer->procedure int
1226 (dynamic-func "symlinkat" (dynamic-link))
1227 (list '* int '*))))
1228
1229 (lambda* (src dst #:key (target_is_directory #f) (dir_fd None))
1230 (rm (fat ((string->pointer (path-it dst))
1231 (if (eq? dir_fd None) AT_FDCWD dir_fd)
1232 (string->pointer (path-it src))))))))
1233
1234 (define truncate #f)
1235 (defineu truncate (2)
1236 (let ((ff (pointer->procedure int
1237 (dynamic-func "ftruncate" (dynamic-link))
1238 (list int long)))
1239 (f (pointer->procedure int
1240 (dynamic-func "truncate" (dynamic-link))
1241 (list '* long))))
1242
1243 (lambda (path length)
1244 (rm (if (number? path)
1245 (ff path length)
1246 (f (string->pointer (path-it path))
1247 length))))))
1248
1249 (define UTIME_NOW (- (ash 1 30) 1))
1250
1251 (define utime #f)
1252 (defineu utime (0 2)
1253 (let ((ff (pointer->procedure int
1254 (dynamic-func "futimes" (dynamic-link))
1255 (list int '*)))
1256 (fat (pointer->procedure int
1257 (dynamic-func "futimesat" (dynamic-link))
1258 (list int '* '* int))))
1259
1260 (lambda* (path #:optional (times None) (ns #f) #:key (dir_fd None)
1261 (follow_symlinks #t))
1262 (let* ((bv (make-bytevector 32))
1263 (bvp (bytevector->pointer bv)))
1264 (if (eq? ns None)
1265 (if (eq? times None)
1266 (let ()
1267 (bytevector-s64-set! bv 0 0
1268 (native-endianness))
1269 (bytevector-s64-set! bv 8 UTIME_NOW
1270 (native-endianness))
1271 (bytevector-s64-set! bv 16 0
1272 (native-endianness))
1273 (bytevector-s64-set! bv 24 UTIME_NOW
1274 (native-endianness)))
1275 (let ((x1 (pylist-ref ns 0))
1276 (x2 (pylist-ref ns 1)))
1277 (bytevector-s64-set! bv 0 (floor-quotient x1 1000000000)
1278 (native-endianness))
1279 (bytevector-s64-set! bv 8 (modulo x1 1000000000)
1280 (native-endianness))
1281 (bytevector-s64-set! bv 16 (floor-quotient x2 1000000000)
1282 (native-endianness))
1283 (bytevector-s64-set! bv 24 (modulo x2 1000000000)
1284 (native-endianness))))
1285 (if (eq? times None)
1286 (begin
1287 (bytevector-s64-set! bv 0 (pylist-ref times 0)
1288 (native-endianness))
1289 (bytevector-s64-set! bv 8 0
1290 (native-endianness))
1291 (bytevector-s64-set! bv 16 (pylist-ref times 1)
1292 (native-endianness))
1293 (bytevector-s64-set! bv 24 0
1294 (native-endianness)))
1295 (raise error "utime cannot set both s and ns")))
1296 (rm (if (number? path)
1297 (ff path bvp)
1298 (fat (if (eq? dir_fd AT_FDCWD None) dir_fd) bvp
1299 (string->pointer (path-it path))
1300 (if follow_symlinks
1301 0
1302 AT_SYMLINK_NOFOLLOW))))))))
1303
1304
1305 (def (walk top (= topdown #t) (= onerror None) (= followlinks #f))
1306 ((make-generator ()
1307 (lambda (yield)
1308 (let/ec ret
1309 (define dirs (py-list))
1310 (define nondirs (py-list))
1311 (define entries #f)
1312
1313 (try
1314 (lambda ()
1315 (set! entries (py-list (scandir top))))
1316 (#:except error =>
1317 (lambda (x . _)
1318 (if onerror (onerror x) (ret)))))
1319
1320 (for ((entry : entries)) ()
1321 (define is_dir (try
1322 (lambda () (ref entry 'is_dir))
1323 (#:except error => (lambda x #f))))
1324 (if is_dir
1325 (pylist-append! dirs (ref entry 'name))
1326 (pylist-append! nondirs (ref entry 'name)))
1327
1328 (if (and (not topdown) is_dir)
1329 (let ((walk-into
1330 (if followlinks
1331 #t
1332 (not
1333 (try
1334 (lambda () ((ref entry 'is_symlink)))
1335 (#:except error => (lambda x #f)))))))
1336 (if walk-into
1337 (for ((a b c : (walk (ref entry 'path) topdown
1338 onerror followlinks))) ()
1339 (yield a b c)))))
1340
1341 (if topdown
1342 (begin
1343 (yield top dirs nondirs)
1344
1345 (let ((islink (ref path 'islink))
1346 (join (ref path 'join)))
1347 (for ((dirname : dirs)) ()
1348 (let ((new_path (join top dirname)))
1349 (if (or followlinks (not (islink new_path)))
1350 (for ((a b c : (walk new_path topdown onerror
1351 followlinks))) ()
1352 (yield a b c)))))))
1353 (yield top dirs nondirs))))))))
1354
1355 (define (path:samestat s1 s2)
1356 (and (equal? (ref s1 'st_dev) (ref s2 'st_dev))
1357 (equal? (ref s1 'st_ino) (ref s2 'st_ino))))
1358
1359 (define (path:normpath p)
1360 (let lp ((l (string-split (path-it p) #\/)) (r '()) (first? #t))
1361 (match l
1362 (("") (lp '() (cons "" r) #f))
1363 (("." . l)
1364 (lp l r #f))
1365 (("" . l)
1366 (if first?
1367 (lp l (cons "" r) #f)
1368 (lp l r #f)))
1369 ((".." . l)
1370 (match r
1371 (("")
1372 (raise ValueError "normpath .. beond /"))
1373 ((".." . u)
1374 (lp l (cons ".." r) #f))
1375 ((_ . u)
1376 (lp l u #f))
1377 (()
1378 (lp l (cons ".." r) #f))))
1379 ((x . l)
1380 (lp l (cons x r) #f))
1381 (() (string-join (reverse r) "/")))))
1382
1383 (define (path:join . l)
1384 (path:normpath (string-join (map path-it l) "/")))
1385
1386 (define (_fwalk topfd toppath topdown onerror follow_symlinks)
1387 ((make-generator ()
1388 (lambda (yield)
1389 (define names (listdir topfd))
1390 (define dirs (py-list))
1391 (define nondirs (py-list))
1392
1393 (for ((name : names)) ()
1394 (try
1395 (lambda ()
1396 (if (S_ISDIR (ref (stat name #:dir_fd topfd) 'st_mode))
1397 (pylist-append! dirs name)
1398 (pylist-append! nondirs name)))
1399 (#:except error =>
1400 (lambda x
1401 (try
1402 (lambda ()
1403 (if (S_ISLNK (ref (stat name #:dir_fd topfd
1404 #:follow_symlinks #f)
1405 'st_mode))
1406 (pylist-append! nondirs name)))
1407 (#:except error => (lambda x (values))))))))
1408
1409 (if topdown
1410 (yield toppath dirs nondirs topfd))
1411
1412 (for continue ((name : dirs)) ()
1413 (call-with-values
1414 (lambda ()
1415 (try
1416 (lambda ()
1417 (values (stat name #:dir_fd topfd
1418 #:follow_symlinks follow_symlinks))
1419 (open name O_RDONLY #:dir_fd topfd))
1420 (#:except error =>
1421 (lambda (err . l)
1422 (if (not (eq? onerror None))
1423 (onerror err)
1424 (continue))))))
1425 (lambda (orig_st dirfd)
1426 (try
1427 (lambda ()
1428 (if (or follow_symlinks (path:samestat orig_st (stat dirfd)))
1429 (let ((dirpath (path:join toppath name)))
1430 (for ((a b c d :
1431 (_fwalk dirfd dirpath topdown onerror
1432 follow_symlinks))) ()
1433 (yield a b c d)))))
1434
1435 #:finally
1436 (close dirfd)))))
1437
1438 (if not topdown
1439 (yield toppath dirs nondirs topfd))))))
1440
1441 (def (fwalk (= top ".") (= topdown #t) (= onerror #t)
1442 (= follow_symlinks #f) (= dir_fd None))
1443 ((make-generator ()
1444 (lambda (yield)
1445 (define orig_st (stat top #:follow_symlinks #f #:dir_fd dir_fd))
1446 (define topfd (open top O_RDONLY #:dir_fd dir_fd))
1447
1448 (try
1449 (lambda ()
1450 (if (or follow_symlinks (and (S_ISDIR (ref orig_st 'st_mode))
1451 (path:samestat orig_st (stat topfd))))
1452 (for ((a b c d :
1453 (_fwalk topfd top topdown onerror follow_symlinks)))
1454 ()
1455 (yield a b c d))))
1456 #:finally
1457 (close topfd))))))
1458
1459 ;; Extended attributes
1460 (define getxattr #f)
1461 (defineu getxattr (2)
1462 (let ((f (pointer->procedure int
1463 (dynamic-func "getxattr" (dynamic-link))
1464 (list '* '* '* int)))
1465 (lf (pointer->procedure int
1466 (dynamic-func "lgetxattr" (dynamic-link))
1467 (list '* '* '* int)))
1468 (ff (pointer->procedure int
1469 (dynamic-func "fgetxattr" (dynamic-link))
1470 (list '* '* '* int))))
1471 (lambda* (path attribute #:key (follow_symlink #t))
1472 (let ((path (ca (if (number? path)
1473 path
1474 (string->pointer (path-it path)))))
1475 (k (ca (string->pointer attribute))))
1476 (let lp ((size 128))
1477 (let* ((v (make-bytevector size))
1478 (pv (bytevector->pointer v)))
1479 (let ((n (rm (if (number? path)
1480 (ff path k pv size)
1481 (if follow_symlink
1482 (f path k pv size)
1483 (lf path k pv size))))))
1484 (if (> n (- size 2))
1485 (lp (* 2 size))
1486 (pointer->string pv)))))))))
1487
1488 (define listxattr #f)
1489 (defineu listxattr (2)
1490 (let ((f (pointer->procedure int
1491 (dynamic-func "listxattr" (dynamic-link))
1492 (list '* '* int)))
1493 (lf (pointer->procedure int
1494 (dynamic-func "llistxattr" (dynamic-link))
1495 (list '* '* int)))
1496 (ff (pointer->procedure int
1497 (dynamic-func "flistxattr" (dynamic-link))
1498 (list '* '* int))))
1499 (define (mk l)
1500 (define v (make-bytevector (+ (length l) 1)))
1501 (define vp (bytevector->pointer v))
1502 (let lp ((i 0) (l l))
1503 (if (pair? l)
1504 (begin
1505 (bytevector-u8-set! v i (car l))
1506 (lp (+ i 1) (cdr l)))
1507 (begin
1508 (bytevector-u8-set! v i 0)
1509 (pointer->string vp)))))
1510
1511 (lambda* (path attribute #:key (follow_symlink #t))
1512 (let ((path (if (number? path) path (string->pointer (path-it path)))))
1513 (let lp ((size 128))
1514 (let* ((v (make-bytevector size))
1515 (pv (bytevector->pointer v)))
1516 (let ((n (rm (if (number? path)
1517 (ff path pv size)
1518 (if follow_symlink
1519 (f path pv size)
1520 (lf path pv size))))))
1521 (if (> n (- size 2))
1522 (lp (* 2 size))
1523 (let lp ((i 0) (l '()))
1524 (if (< i n)
1525 (let lp2 ((j i) (r '()))
1526 (if (< j n)
1527 (let ((x (bytevector-u8-ref v j)))
1528 (if (= x 0)
1529 (if (null? r)
1530 (lp (+ j 1) l)
1531 (lp (+ j 1) (cons (mk (reverse r))
1532 l)))
1533 (lp2 (+ j 1) (cons x r))))
1534 (if (null? r)
1535 (lp j l)
1536 (lp j (cons (mk (reverse r)) l)))))
1537 (pylist (reverse l))))))))))))
1538
1539 (define removexattr #f)
1540 (defineu removexattr (2)
1541 (let ((f (pointer->procedure int
1542 (dynamic-func "removexattr" (dynamic-link))
1543 (list '* '*)))
1544 (lf (pointer->procedure int
1545 (dynamic-func "lremovexattr" (dynamic-link))
1546 (list '* '*)))
1547 (ff (pointer->procedure int
1548 (dynamic-func "fremovexattr" (dynamic-link))
1549 (list int '*))))
1550 (lambda* (path attribute #:key (follow_symlink #t))
1551 (let ((path (if (number? path)
1552 path
1553 (string->pointer (path-it path))))
1554 (k (ca (string->pointer attribute))))
1555 (rm (if (number? path)
1556 (ff path k)
1557 (if follow_symlink
1558 (f path k)
1559 (lf path k))))))))
1560
1561 (define setxattr #f)
1562 (defineu setxattr (2)
1563 (let ((f (pointer->procedure int
1564 (dynamic-func "setxattr" (dynamic-link))
1565 (list '* '* '* int int)))
1566 (lf (pointer->procedure int
1567 (dynamic-func "lsetxattr" (dynamic-link))
1568 (list '* '* '* int int)))
1569 (ff (pointer->procedure int
1570 (dynamic-func "fsetxattr" (dynamic-link))
1571 (list int '* '* int int))))
1572 (lambda* (path attribute value flags #:key (follow_symlink #t))
1573 (let* ((path (if (number? path) path (string->pointer (path-it path))))
1574 (val (ca (string->pointer value)))
1575 (s (string-length val))
1576 (k (ca (string->pointer attribute))))
1577 (rm (if (number? path)
1578 (ff path k val s flags)
1579 (if follow_symlink
1580 (f path k val s flags)
1581 (lf path k val s flags))))))))
1582
1583 (define XATTR_SIZE_MAX (ash 1 16))
1584 (define XATTR_CREATE 1)
1585 (define XATTR_REPLACE 2)
1586
1587 ;; Processes
1588 (define (abort) ((@ (guile) raise) (@ (guile) SIGABRT)))
1589
1590 (define (exists p)
1591 (if (number? p)
1592 (catch #t
1593 (lambda () ((@ (guile) readlink) (format #f "/proc/self/fd/~a" p)))
1594 (lambda x #f))
1595 (catch #t
1596 (lambda () ((@ (guile) stat) (path-it p)) #t)
1597 (lambda x #f))))
1598
1599 (define (comp e pth)
1600 (if (eq? (string-ref pth 0) #\/)
1601 pth
1602 (let ((r (py-get e "PATH")))
1603 (if r
1604 (let lp ((l (string-split r #\:)))
1605 (match l
1606 ((pp . l)
1607 (let ((newpath (string-join (cons pp pth) "/")))
1608 (if (exists newpath)
1609 newpath
1610 (lp l))))
1611 (()
1612 pth)))
1613 pth))))
1614
1615
1616 (define (compe e)
1617 (for ((k v : e)) ((l '()))
1618 (cons (string-append k "=" v) l)
1619 #:final (reverse l)))
1620
1621 (define (execl path . args) (apply (@ (guile) execl) (path-it path) args))
1622 (define (execle path . args) (apply (@ (guile) execl) (path-it path)
1623 (let* ((a (reverse args))
1624 (e (compe (car args)))
1625 (l (reverse (cdr args))))
1626 (cons e l))))
1627 (define (execlpe path . args)
1628 (let* ((a (reverse args))
1629 (e (compe (car args)))
1630 (l (cons e (reverse (cdr args)))))
1631 (apply (@ (guile) execle) (comp e (path-it path)) l)))
1632
1633 (define (execlp path . args) (apply (@ (guile) execlp) (path-it path) args))
1634
1635 (define (execv path args)
1636 (apply execl path (for ((a : args)) ((l '()))
1637 (cons a l)
1638 #:final (reverse l))))
1639
1640 (define (execve path args env )
1641 (apply execle path (for ((a : args)) ((l (list env)))
1642 (cons a l)
1643 #:final (reverse l))))
1644
1645 (define (execvp path args)
1646 (apply execlp path (for ((a : args)) ((l '()))
1647 (cons a l)
1648 #:final (reverse l))))
1649
1650 (define (execvp path args env)
1651 (apply execlpe path (for ((a : args)) ((l (list env)))
1652 (cons a l)
1653 #:final (reverse l))))
1654
1655
1656
1657 (define (_exit n) (primitive-_exit n))
1658
1659 (define EX_OK 0)
1660 (define EX_USAGE 64)
1661 (define EX_DATAERR 65)
1662 (define EX_NOINPUT 66)
1663 (define EX_NOUSER 67)
1664 (define EX_NOHOST 68)
1665 (define EX_UNAVAILABLE 69)
1666 (define EX_SOFTWARE 70)
1667 (define EX_OSERR 71)
1668 (define EX_OSFILE 72)
1669 (define EX_CANTCREAT 73)
1670 (define EX_IOERR 74)
1671 (define EX_TEMPFAIL 75)
1672 (define EX_PROTOCOL 76)
1673
1674 (define fork primitive-fork)
1675
1676 (define (kill pid sig) (ca ((@ (guile) kill) pid sig)))
1677
1678 (define (nice i) (ca ((@ (guile) nice) i)))
1679
1680 (define killpg
1681 (let ((f (pointer->procedure int
1682 (dynamic-func "killpg" (dynamic-link))
1683 (list int int))))
1684 (lambda (pgid sig)
1685 (rm (f pgid sig)))))
1686
1687 (define (plock . l) (error "not implemented"))
1688
1689 (define DEFAULT_BUFFER_SIZE (@@ (language python module python)
1690 DEFAULT_BUFFER_SIZE))
1691
1692 (define* (popen com #:optional (mode "r") (buffering -1))
1693 (let ((port (ca ((@ (ice-9 popen) open-pipe) com
1694 (cond
1695 ((equal? mode "r") OPEN_READ)
1696 ((equal? mode "w") OPEN_WRITE)
1697 ((or (equal? mode "rw")
1698 (equal? mode "r+")
1699 (equal? mode "w+")
1700 (equal? mode "wr"))
1701 OPEN_BOTH))))))
1702 (ca
1703 (case buffering
1704 ((-1)
1705 (setvbuf port 'block DEFAULT_BUFFER_SIZE))
1706 ((0)
1707 (setvbuf port 'none))
1708 ((1)
1709 (setvbuf port 'line))
1710 (else
1711 (setvbuf port 'block buffering))))
1712
1713 port))
1714
1715 (define P_WAIT 0)
1716 (define P_NOWAIT 1)
1717 (define P_NOWAIT0 1)
1718
1719 (define-syntax-rule (mk-spawn f ff)
1720 (define (f mode . l)
1721 (let ((pid (primitive-fork)))
1722 (if (= l 0)
1723 (apply ff l)
1724 (cond
1725 ((= mode P_WAIT)
1726 (cdr ((@ (guile) waitpid) pid)))
1727 ((= mode P_NOWAIT)
1728 pid)
1729 (else
1730 (raise ValueError "wrong mode specified in spawn command")))))))
1731
1732 (mk-spawn spawnl execl)
1733 (mk-spawn spawnle execle)
1734 (mk-spawn spawnlp execlp)
1735 (mk-spawn spawnlpe execlpe)
1736 (mk-spawn spawnv execv)
1737 (mk-spawn spawnve execve)
1738 (mk-spawn spawnvp execvp)
1739 (mk-spawn spawnvpe execvpe)
1740
1741 (define startfile
1742 (lambda x (error "not implemented")))
1743
1744 (define (system command) (ca ((@ (guile) system) command)))
1745
1746 (define-python-class Times ()
1747 (define __init__
1748 (lambda (self v)
1749 (set self 'user (tms:utime v))
1750 (set self 'system (tms:stime v))
1751 (set self 'children_user (tms:cutime v))
1752 (set self 'children_system (tms:cstime v))
1753 (set self 'elapsed (tms:clock v))))
1754 (define __repr__
1755 (lambda (self)
1756 (format #f "Time(user:~a system:~a ...)"
1757 (ref self 'user)
1758 (ref self 'system)))))
1759
1760 (define (times)
1761 (ca (Times ((@ (guile) times)))))
1762
1763 (define (wait)
1764 (let ((x ((@ (guile) waitpid) -1)))
1765 (list (car x) (cdr x))))
1766
1767 (define-python-class SigInfo ()
1768 (define __init__
1769 (lambda (self a b c d e)
1770 (set self 'si_signo a)
1771 (set self 'si_code b)
1772 (set self 'si_pid c)
1773 (set self 'si_uid d)
1774 (set self 'si_status e)))
1775
1776 (define __repr__
1777 (lambda (self)
1778 (format #f
1779 "SigInfo(signo:~a code:~a pid:~a uid:~a status:~a"
1780 (ref self 'si_signo)
1781 (ref self 'si_code)
1782 (ref self 'si_pid)
1783 (ref self 'si_uid)
1784 (ref self 'si_status)))))
1785
1786 (define waitid #f)
1787 (defineu waitid ()
1788 (let ((f (pointer->procedure int
1789 (dynamic-func "waitid" (dynamic-link))
1790 (list int int '* int))))
1791 (lambda (idtype id options)
1792 (let* ((b (make-bytevector 228))
1793 (vp (bytevector->pointer b))
1794 (ref (lambda (i) (bytevector-s32-ref
1795 b i (native-endianness))))
1796 (si_status (lambda () (ref 6)))
1797 (si_code (lambda () (ref 2)))
1798 (si_pid (lambda () (ref 4)))
1799 (si_uid (lambda () (ref 5)))
1800 (si_signo (lambda () (ref 0))))
1801 (rm (f idtype id vp options))
1802 (SigInfo (si_signo) (si_code) (si_pid) (si_uid)
1803 (si_status))))))
1804
1805 (define P_PID 1)
1806 (define P_PGID 2)
1807 (define P_ALL 0)
1808
1809 (define WEXITED 4)
1810 (define WUNTRACED 2)
1811 (define WSTOPPED 2)
1812 (define WNOWAIT #x01000000)
1813 (define WCONTINUED 8)
1814 (define WNOHANG 1)
1815
1816 (define CLD_EXITED 1)
1817 (define CLD_KILLED 2)
1818 (define CLD_DUMPED 3)
1819 (define CLD_STOPED 5)
1820 (define CLD_TRAPPED 4)
1821 (define CLD_CONTINUED 6)
1822
1823 (define (waitpid pid options)
1824 (ca ((@ (guile) waitpid) pid options)))
1825
1826 (define wait3 #f)
1827 (defineu wait3 ()
1828 (let ((f (pointer->procedure int
1829 (dynamic-func "wait3" (dynamic-link))
1830 (list '* int '*))))
1831 (lambda (option)
1832 (let* ((v (make-bytevector 250))
1833 (vp (bytevector->pointer v))
1834 (w (make-bytevector 8))
1835 (wp (bytevector->pointer w)))
1836
1837 (let ((pid (rm (f wp option vp))))
1838 (list pid
1839 (bytevector-s32-ref w 0 (native-endianness))
1840 (ResUsage v)))))))
1841
1842 (define wait4 #f)
1843 (defineu wait4 ()
1844 (let ((f (pointer->procedure int
1845 (dynamic-func "wait4" (dynamic-link))
1846 (list int '* int '*))))
1847 (lambda (pid option)
1848 (let* ((v (make-bytevector 250))
1849 (vp (bytevector->pointer v))
1850 (w (make-bytevector 8))
1851 (wp (bytevector->pointer w)))
1852
1853 (let ((pid2 (rm (f pid wp option vp))))
1854 (list pid
1855 (bytevector-s32-ref w 0 (native-endianness))
1856 (ResUsage v)))))))
1857
1858 (define __WCOREFLAG #x80)
1859 (define __W_CONTINUED #xffff)
1860
1861 (define (WCOREDUMP status) (> (logand status __WCOREFLAG) 0))
1862 (define (WIFCONTINUED status) (= status __W_CONTINUED))
1863 (define (WIFSTOPPED status) (= (logand status #xff) #x7f))
1864 (define (WIFSIGNALED status) (> (ash (+ (logand status #x7f) 1) -1) 0))
1865
1866 (define (WIFEXITED status) (= (WTERMSIG status) 0))
1867 (define (WEXITSTATUS status) (ash (logand status #xff00) 8))
1868 (define (WSTOPSIG status) (WEXITSTATUS status))
1869 (define (WTERMSIG status) (logand status #x7f))
1870
1871 ;; Scheduling
1872
1873 (define SCHED_OTHER 0)
1874 (define SCHED_BATCH 3)
1875 (define SCHED_IDLE 5)
1876 (define SCHED_FIFO 1)
1877 (define SCHED_RR 2)
1878 (define SCHED_RESET_ON_FORK #x40000000)
1879
1880 (define-python-class sched_param ()
1881 (define __init__
1882 (lambda (self v)
1883 (if (bytevector? v)
1884 (set self 'sched_priority
1885 (bytevector-s32-ref v 0 (native-endianness)))
1886 (set self 'sched_priority v)))))
1887
1888 (define sched_get_priority_min #f)
1889 (defineu sched_get_priority_min ()
1890 (let ((f (pointer->procedure int
1891 (dynamic-func "sched_get_priority_min"
1892 (dynamic-link))
1893 (list int))))
1894 (lambda (policy) (rm (f policy)))))
1895
1896 (define sched_get_priority_max #f)
1897 (defineu sched_get_priority_max ()
1898 (let ((f (pointer->procedure int
1899 (dynamic-func "sched_get_priority_max"
1900 (dynamic-link))
1901 (list int))))
1902 (lambda (policy) (rm (f policy)))))
1903
1904 (define sched_setscheduler #f)
1905 (defineu sched_setscheduler ()
1906 (let ((f (pointer->procedure int
1907 (dynamic-func "sched_setscheduler"
1908 (dynamic-link))
1909 (list int int '*))))
1910 (lambda (pid policy param)
1911 (let* ((v (make-bytevector 32))
1912 (vp (bytevector->pointer v)))
1913 (bytevector-s32-set! v 0 (ref param 'sched_priority)
1914 (native-endianness))
1915 (rm (f pid policy vp))))))
1916
1917 (define sched_getscheduler #f)
1918 (defineu sched_getscheduler ()
1919 (let ((f (pointer->procedure int
1920 (dynamic-func "sched_getscheduler"
1921 (dynamic-link))
1922 (list int))))
1923 (lambda (pid)
1924 (ca (f pid)))))
1925
1926 (define sched_setparam #f)
1927 (defineu sched_setparam ()
1928 (let ((f (pointer->procedure int
1929 (dynamic-func "sched_setparam"
1930 (dynamic-link))
1931 (list int '*))))
1932 (lambda (pid param)
1933 (let* ((v (make-bytevector 32))
1934 (vp (bytevector->pointer v)))
1935 (bytevector-s32-set! v 0 (ref param 'sched_priority)
1936 (native-endianness))
1937 (rm (f pid vp))))))
1938
1939 (define sched_getparam #f)
1940 (defineu sched_getparam ()
1941 (let ((f (pointer->procedure int
1942 (dynamic-func "sched_getparam"
1943 (dynamic-link))
1944 (list int '*))))
1945 (lambda (pid param)
1946 (let* ((v (make-bytevector 32))
1947 (vp (bytevector->pointer v)))
1948 (rm (f pid vp))
1949 (sched_param v)))))
1950
1951 (define sched_rr_get_intervall
1952 (lambda x (error "not implemented")))
1953
1954 (define sched_yield #f)
1955 (defineu sched_yield ()
1956 (let ((f (pointer->procedure int
1957 (dynamic-func "sched_yield"
1958 (dynamic-link))
1959 (list))))
1960 (lambda () (rm (f)))))
1961
1962 (define sched_setaffinity#f)
1963 (defineu sched_setaffinity ()
1964 (let ((f (pointer->procedure int
1965 (dynamic-func "sched_setaffinity"
1966 (dynamic-link))
1967 (list int int '*)))
1968 (n (/ 1024 64)))
1969 (lambda (pid mask)
1970 (let* ((v (make-bytevector (/ 1024 64)))
1971 (vp (bytevector->pointer v)))
1972
1973 (for ((m : mask)) ((i (range 1000)))
1974 (bytevector-u64-set! v i (* m 8) (native-endianness)))
1975
1976 (rm (f pid (/ n 8) vp))))))
1977
1978 (define sched_getaffinity #f)
1979 (defineu sched_getaffinity ()
1980 (let ((f (pointer->procedure int
1981 (dynamic-func "sched_getaffinity"
1982 (dynamic-link))
1983 (list int int '*)))
1984 (n (/ 1024 64)))
1985 (lambda (pid)
1986 (let* ((v (make-bytevector (/ 1024 64)))
1987 (vp (bytevector->pointer v)))
1988
1989 (rm (f pid (/ n 8) vp))
1990 (let lp ((i 0))
1991 (if (< i n)
1992 (cons (bytevector-u64-ref v (* i 8) (native-endianness))
1993 (lp (+ i 1)))
1994 '()))))))
1995
1996
1997 ;; MISC SYSTEM INFORMATION
1998 (defineu confstr_ ()
1999 (let ((f (pointer->procedure int
2000 (dynamic-func "confstr"
2001 (dynamic-link))
2002 (list int '* int))))
2003 (lambda (id)
2004 (let* ((v (make-bytevector 1024))
2005 (vp (bytevector->pointer v)))
2006 (rm (f id vp 1024))
2007 (pointer->string vp)))))
2008
2009 (define confstr_names
2010 (dict
2011 '(("LIBC_VERSION" . 2)
2012 ("LIBPTHREAD_VERSION" . 3)
2013 ("PATH" . 0))))
2014
2015 (define (confstr id)
2016 (let ((id2 (if (number? id) id (pylist-ref confstr_names id))))
2017 (if id2
2018 (confstr_ id2)
2019 (raise KeyError "no confstr for " id))))
2020
2021 (defineu cpu_count ()
2022 (let ((f (pointer->procedure int
2023 (dynamic-func "get_nprocs"
2024 (dynamic-link))
2025 (list))))
2026 (lambda ()
2027 (rm (f)))))
2028
2029
2030 (defineu sysconf_ ()
2031 (let ((f (pointer->procedure long
2032 (dynamic-func "sysconf"
2033 (dynamic-link))
2034 (list int))))
2035 (lambda (id)
2036 (rm (f id)))))
2037
2038 (define i 0)
2039 (define (f) (let ((r i)) (set! i (+ i 1)) r))
2040 (define sysconf_names
2041 (dict
2042 `(("ARG_MAX" . ,(f))
2043 ("CHILD_MAX" . ,(f))
2044 ("CLK_TCK" . ,(f))
2045 ("NGROUPS_MAX" . ,(f))
2046 ("OPEN_MAX" . ,(f))
2047 ("STREAM_MAX" . ,(f))
2048 ("TZNAME_MAX" . ,(f))
2049 ("JOB_CONTROL" . ,(f))
2050 ("SAVED_IDS" . ,(f))
2051 ("REALTIME_SIGNALS" . ,(f))
2052 ("PRIORITY_SCHEDULING" . ,(f))
2053 ("TIMERS" . ,(f))
2054 ("ASYNCHRONO√ôS_IO" . ,(f))
2055 ("PRIORITIZED_IO" . ,(f))
2056 ("SYNCHRONIZED_IO" . ,(f))
2057 ("FSYNC" . ,(f))
2058 ("MAPPED_FILES" . ,(f))
2059 ("MEMLOCK" . ,(f))
2060 ("MEMLOCK_RANGE" . ,(f))
2061 ("MEMORY_PROTECTION" . ,(f))
2062 ("MESSAGE_PASSING" . ,(f))
2063 ("SEMAPHORES" . ,(f))
2064 ("SHARED_MEMORY_OBJECTS" . ,(f))
2065 ("AIO_LISTIO_MAX" . ,(f))
2066 ("AIO_MAX" . ,(f))
2067 ("AIO_PRIO_DELTA_MAX" . ,(f))
2068 ("AIO_DELAYTIMER_MAX" . ,(f))
2069 ("MQ_OPEN_MAX" . ,(f))
2070 ("MQ_PRIO_MAX" . ,(f))
2071 ("POSIX_VERSION" . ,(f))
2072 ("PAGESIZE" . ,(f))
2073 ("RTSIG_MAX" . ,(f))
2074 ("SEM_NSEMS_MAX" . ,(f))
2075 ("SEM_VALUE_MAX" . ,(f))
2076 ("SIGQUEUE_MAX" . ,(f))
2077 ("TIMER_MAX" . ,(f))
2078
2079 ("BC_BASE_MAX" . ,(f))
2080 ("BC_DIM_MAX" . ,(f))
2081 ("BC_SCALE_MAX" . ,(f))
2082 ("BC_STRING_MAX" . ,(f))
2083 ("COLL_WEIGHTS_MAX" . ,(f))
2084 ("EQUIV_CLASS_MAX" . ,(f))
2085 ("EXPR_NEST_MAX" . ,(f))
2086 ("LINE_MAX" . ,(f))
2087 ("RE_DUP_MAX" . ,(f))
2088 ("CHARCLASS_NAME_MAX" . ,(f))
2089 ("POSIX2_VERSION" . ,(f))
2090 ("2_C_BIND" . ,(f))
2091 ("2_C_DEV" . ,(f))
2092 ("2_FORT_DEV" . ,(f))
2093 ("2_FORT_RUN" . ,(f))
2094 ("2_SW_DEF" . ,(f))
2095 ("2_LOCALEDEF" . ,(f))
2096 ("PII" . ,(f))
2097 ("PII_XTI" . ,(f))
2098 ("PII_SOCKET" . ,(f))
2099 ("PII_INTERNET" . ,(f))
2100 ("PII_OSI" . ,(f))
2101 ("POLL" . ,(f))
2102 ("SELECT" . ,(f))
2103 ("UIO_MAXIOV" . ,i)
2104 ("IOV_MAX" . ,(f))
2105 ("PII_INTERNET_STREAM" . ,(f))
2106 ("PII_INTERNET_DGRAM" . ,(f))
2107 ("PII_OSI_COTS" . ,(f))
2108 ("PII_OSI_CLTS" . ,(f))
2109 ("PII_OSI_M" . ,(f))
2110 ("T_IOV_MAX" . ,(f))
2111 ("THREADS" . ,(f))
2112 ("THREAD_SAFE_FUNCTIONS" . ,(f))
2113 ("GETGR_R_SIZE_MAX" . ,(f))
2114 ("GETPW_R_SIZE_MAX" . ,(f))
2115 ("LOGIN_NAME_MAX" . ,(f))
2116 ("TTY_NAME_MAX" . ,(f))
2117 ("THREAD_DESTRUCTOR_ITERATIONS" . ,(f))
2118 ("THREAD_KEYS_MAX" . ,(f))
2119 ("THREAD_STACK_MIN" . ,(f))
2120 ("THREAD_THREADS_MAX" . ,(f))
2121 ("THREAD_ATTR_STACKADDR" . ,(f))
2122 ("THREAD_ATTR_STACKSIZE" . ,(f))
2123 ("THREAD_PRIORITY_SCHEDULING" . ,(f))
2124 ("THREAD_PRIO_INHERIT" . ,(f))
2125 ("THREAD_PRIO_PROTECT" . ,(f))
2126 ("THREAD_PROCESS_SHARED" . ,(f))
2127 ("NPROCESSORS_CONF" . ,(f))
2128 ("NPROCESSORS_ONLN" . ,(f))
2129 ("PHYS_PAGES" . ,(f))
2130 ("AVPHYS_PAGES" . ,(f))
2131 ("ATEXIT_MAX" . ,(f))
2132 ("PASS_MAX" . ,(f))
2133 ("XOPEN_VERSION" . ,(f))
2134 ("XOPEN_XCU_VERSION" . ,(f))
2135 ("XOPEN_UNIX" . ,(f))
2136 ("XOPEN_CRYPT" . ,(f))
2137 ("XOPEN_ENH_I18N" . ,(f))
2138 ("XOPEN_SHM" . ,(f))
2139 ("2_CHAR_TERM" . ,(f))
2140 ("2_C_VERSION" . ,(f))
2141 ("2_UPE" . ,(f))
2142 ("XOPEN_XPG2" . ,(f))
2143 ("XOPEN_XPG3" . ,(f))
2144 ("XOPEN_XPG4" . ,(f))
2145 ("CHAR_BIT" . ,(f))
2146 ("CHAR_MAX" . ,(f))
2147 ("CHAR_MIN" . ,(f))
2148 ("INT_MAX" . ,(f))
2149 ("INT_MIN" . ,(f))
2150 ("LONG_BIT" . ,(f))
2151 ("WORD_BIT" . ,(f))
2152 ("MB_LEN_MAX" . ,(f))
2153 ("NZERO" . ,(f))
2154 ("SSIZE_MAX" . ,(f))
2155 ("SCHAR_MAX" . ,(f))
2156 ("SCHAR_MIN" . ,(f))
2157 ("SHRT_MAX" . ,(f))
2158 ("SHRT_MIN" . ,(f))
2159 ("UCHAR_MAX" . ,(f))
2160 ("UINT_MAX" . ,(f))
2161 ("ULONG_MAX" . ,(f))
2162 ("USHRT_MAX" . ,(f))
2163 ("NL_ARGMAX" . ,(f))
2164 ("NL_LANGMAX" . ,(f))
2165 ("NL_MSGMAX" . ,(f))
2166 ("NL_NMAX" . ,(f))
2167 ("NL_SETMAX" . ,(f))
2168 ("NL_TEXTMAX" . ,(f))
2169 ("XBS5_ILP32_OFF32" . ,(f))
2170 ("XBS5_ILP32_OFFBIG" . ,(f))
2171 ("XBS5_LP64_OFF64" . ,(f))
2172 ("XBS5_LPBIG_OFFBIG" . ,(f))
2173 ("XOPEN_LEGACY" . ,(f))
2174 ("XOPEN_REALTIME" . ,(f))
2175 ("XOPEN_REALTIME_THREADS" . ,(f))
2176 ("ADVISORY_INFO" . ,(f))
2177 ("BARRIERS" . ,(f))
2178 ("BASE" . ,(f))
2179 ("C_LANG_SUPPORT" . ,(f))
2180 ("C_LANG_SUPPORT_R" . ,(f))
2181 ("CLOCK_SELECTION" . ,(f))
2182 ("CPUTIME" . ,(f))
2183 ("THREAD_CPUTIME" . ,(f))
2184 ("DEVICE_IO" . ,(f))
2185 ("DEVICE_SPECIFIC" . ,(f))
2186 ("DEVICE_SPECIFIC_R" . ,(f))
2187 ("FD_MGMT" . ,(f))
2188 ("FIFO" . ,(f))
2189 ("PIPE" . ,(f))
2190 ("FILE_ATTRIBUTES" . ,(f))
2191 ("FILE_LOCKING" . ,(f))
2192 ("FILE_SYSTEM" . ,(f))
2193 ("MONOTONIC_CLOCK" . ,(f))
2194 ("MULTI_PROCESS" . ,(f))
2195 ("SINGLE_PROCESS" . ,(f))
2196 ("NETWORKING" . ,(f))
2197 ("READER_WRITER_LOCKS" . ,(f))
2198 ("SPIN_LOCKS" . ,(f))
2199 ("REGEXP" . ,(f))
2200 ("REGEX_VERSION" . ,(f))
2201 ("SHELL" . ,(f))
2202 ("SIGNALS" . ,(f))
2203 ("SPAWN" . ,(f))
2204 ("SPORADIC_SERVER" . ,(f))
2205 ("THREAD_SPORADIC_SERVER" . ,(f))
2206 ("SYSTEM_DATABASE" . ,(f))
2207 ("SYSTEM_DATABASE_R" . ,(f))
2208 ("TIMEOUTS" . ,(f))
2209 ("TYPED_MEMORY_OBJECTS" . ,(f))
2210 ("USER_GROUPS" . ,(f))
2211 ("USER_GROUPS_R" . ,(f))
2212 ("2_PBS" . ,(f))
2213 ("2_PBS_ACCOUNTING" . ,(f))
2214 ("2_PBS_LOCATE" . ,(f))
2215 ("2_PBS_MESSAGE" . ,(f))
2216 ("2_PBS_TRACK" . ,(f))
2217 ("SYMLOOP_MAX" . ,(f))
2218 ("STREAMS" . ,(f))
2219 ("2_PBS_CHECKPOINT" . ,(f))
2220 ("V6_ILP32_OFF32" . ,(f))
2221 ("V6_ILP32_OFFBIG" . ,(f))
2222 ("V6_LP64_OFF64" . ,(f))
2223 ("V6_LPBIG_OFFBIG" . ,(f))
2224 ("HOST_NAME_MAX" . ,(f))
2225 ("TRACE" . ,(f))
2226 ("TRACE_EVENT_FILTER" . ,(f))
2227 ("TRACE_INHERIT" . ,(f))
2228 ("TRACE_LOG" . ,(f))
2229 ("LEVEL1_ICACHE_SIZE" . ,(f))
2230 ("LEVEL1_ICACHE_ASSOC" . ,(f))
2231 ("LEVEL1_ICACHE_LINESIZE" . ,(f))
2232 ("LEVEL1_DCACHE_SIZE" . ,(f))
2233 ("LEVEL1_DCACHE_ASSOC" . ,(f))
2234 ("LEVEL1_DCACHE_LINESIZE" . ,(f))
2235 ("LEVEL2_CACHE_SIZE" . ,(f))
2236 ("LEVEL2_CACHE_ASSOC" . ,(f))
2237 ("LEVEL2_CACHE_LINESIZE" . ,(f))
2238 ("LEVEL3_CACHE_SIZE" . ,(f))
2239 ("LEVEL3_CACHE_ASSOC" . ,(f))
2240 ("LEVEL3_CACHE_LINESIZE" . ,(f))
2241 ("LEVEL4_CACHE_SIZE" . ,(f))
2242 ("LEVEL4_CACHE_ASSOC" . ,(f))
2243 ("LEVEL4_CACHE_LINESIZE" . ,(f))
2244 ("IPV6 = _SC_LEVEL1_ICACHE_SIZE + 50" . ,(f))
2245 ("RAW_SOCKETS" . ,(f))
2246 ("V7_ILP32_OFF32" . ,(f))
2247 ("V7_ILP32_OFFBIG" . ,(f))
2248 ("V7_LP64_OFF64" . ,(f))
2249 ("V7_LPBIG_OFFBIG" . ,(f))
2250 ("SS_REPL_MAX" . ,(f))
2251 ("TRACE_EVENT_NAME_MAX" . ,(f))
2252 ("TRACE_NAME_MAX" . ,(f))
2253 ("TRACE_SYS_MAX" . ,(f))
2254 ("TRACE_USER_EVENT_MAX" . ,(f))
2255 ("XOPEN_STREAMS" . ,(f))
2256 ("THREAD_ROBUST_PRIO_INHERIT" . ,(f))
2257 ("THREAD_ROBUST_PRIO_PROTECT" . ,(f)))))
2258
2259 (define (sysconf id)
2260 (let ((id2 (if (number? id) id (pylist-ref sysconf_names id))))
2261 (if id2
2262 (sysconf_ id2)
2263 (raise KeyError "no sysconf str for " id))))
2264
2265 (defineu getloadavg ()
2266 (let ((f (pointer->procedure long
2267 (dynamic-func "getloadavg"
2268 (dynamic-link))
2269 (list '* int))))
2270 (lambda ()
2271 (let* ((v (make-bytevector (* 3 8)))
2272 (vp (bytevector->pointer v)))
2273 (rm (f vp 3))
2274 (list (bytevector-ieee-double-ref v 0 (native-endianness))
2275 (bytevector-ieee-double-ref v 8 (native-endianness))
2276 (bytevector-ieee-double-ref v 16 (native-endianness)))))))
2277
2278 (define path "posixpath")
2279 (define curdir ".")
2280 (define pardir "..")
2281 (define sep "/")
2282 (define extsep ".")
2283 (define altsep None)
2284 (define pathsep ":")
2285 (define linesep "\n")
2286 (define defpath "/usr/bin/")
2287 (define devnull "/dev/null")
2288
2289 (define RTLD_LAZY 1)
2290 (define RTLD_NOW 2)
2291 (define RTLD_GLOBAL #x100)
2292 (define RTLD_LOCAL 0)
2293 (define RTLD_NODELETE #x1000)
2294 (define RTLD_NOLOAD 4)
2295 (define RTLD_DEEPBIND 8)
2296
2297 (define GRND_NONBLOCK 1)
2298 (define GRND_RANDOM 2)
2299
2300 (define* (getrandom_ size #:optional (flags 0))
2301 (define filename (if (> (logand flags GRND_RANDOM) 0)
2302 "/dev/random"
2303 "/dev/urandom"))
2304 (define port (open-file filename "r"))
2305 (if port
2306 (dynamic-wind
2307 (lambda () (values))
2308 (lambda ()
2309 (get-bytevector-n port size))
2310 (lambda () ((@ (guile) close) port)))
2311 '()))
2312
2313
2314 (define (urandom size)
2315 (bytes (getrandom_ size)))
2316
2317 (define (getrandom . l)
2318 (py-list (apply getrandom_ l)))
2319