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