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