remove warnings, reordering
[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 environ)
31 #:export (error name ctermid 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 (lam (path (= dir_fd None) (= follow_symlinks #t))
932 (if (number? path)
933 (ca (stat_result ((@ (guile) stat) path)))
934 (let ((path (path-it path)))
935 (if (eq? dir_fd None)
936 (ca
937 (if follow_symlinks
938 (stat_result ((@ (guile) stat) path))
939 (stat_result ((@ (guile) lstat) path))))
940 (let* ((bv (make-bytevector 80))
941 (bvp (bytevector->pointer bv)))
942 (rm (f 1 ;Special linux flag
943 dir_fd
944 (string->pointer path)
945 bvp
946 (if follow_symlinks
947 0
948 AT_SYMLINK_NOFOLLOW)))
949 (stat_result (error "not implemented")))))))))
950
951 (define lstat
952 (lambda* (path #:key (dir_fd None))
953 (stat path #:dir_fd dir_fd #:follow_symlinks #f)))
954
955 (defineu mkdir (0)
956 (let ((fat (pointer->procedure int
957 (dynamic-func "mkdirat" (dynamic-link))
958 (list int '* int))))
959 (lambda* (path mode #:key (dir_fd None))
960 (rm (fat (if (eq? dir_fd None) AT_FDCWD dir_fd)
961 (string->pointer (path-it path))
962 mode)))))
963
964 (define* (mkdirs name mode #:key (exist_ok #f))
965 (let lp ((pre "") (l (string-split (path-it name) #\/)))
966 (match l
967 (() (values))
968 ((x) (let ((s (string-append pre "/" x)))
969 (catch #t
970 (lambda ()
971 ((@ (guile) stat) s)
972 (if exist_ok
973 (values)
974 (raise error
975 (format #f "dir ~a in mkdirs already exist" s))))
976 (lambda x
977 (mkdir s mode)))))
978 ((x . l)
979 (let ((s (string-append pre "/" x)))
980 (catch #t
981 (lambda ()
982 ((@ (guile) stat) s))
983 (lambda x
984 (mkdir s mode)))
985 (lp s l))))))
986
987
988 (defineu mkfifo (0)
989 (let ((fat (pointer->procedure int
990 (dynamic-func "mkfifoat" (dynamic-link))
991 (list int '* int))))
992 (lambda* (path mode #:key (dir_fd None))
993 (rm (fat (if (eq? dir_fd None) AT_FDCWD dir_fd)
994 (string->pointer (path-it path))
995 mode)))))
996
997 (defineu mknod (0)
998 (let ((fat (pointer->procedure int
999 (dynamic-func "__xmknodat" (dynamic-link))
1000 (list int int '* int))))
1001 (lambda* (path mode #:optional (device 0) #:key (dir_fd None))
1002 (rm (fat 1 (if (eq? dir_fd None) AT_FDCWD dir_fd)
1003 (string->pointer (path-it path))
1004 mode
1005 device)))))
1006
1007 (defineu major ()
1008 (let ((f (pointer->procedure int
1009 (dynamic-func "gnu_dev_major" (dynamic-link))
1010 (list int64))))
1011 (lambda (device)
1012 (ca (f device)))))
1013
1014 (defineu minor ()
1015 (let ((f (pointer->procedure int
1016 (dynamic-func "gnu_dev_minor" (dynamic-link))
1017 (list int64))))
1018 (lambda (device)
1019 (ca (f device)))))
1020
1021 (defineu makedev ()
1022 (let ((f (pointer->procedure int64
1023 (dynamic-func "gnu_dev_makedev" (dynamic-link))
1024 (list int int))))
1025 (lambda (major minor)
1026 (ca (f major minor)))))
1027
1028
1029 (define pathconf_names (dict))
1030 (pylist-set! pathconf_names "PC_LINK_MAX" 0)
1031 (pylist-set! pathconf_names "PC_MAX_CANON" 1)
1032 (pylist-set! pathconf_names "PC_MAX_INPUT" 2)
1033 (pylist-set! pathconf_names "PC_NAME_MAX" 3)
1034 (pylist-set! pathconf_names "PC_PATH_MAX" 4)
1035 (pylist-set! pathconf_names "PC_PIPE_BUF" 5)
1036 (pylist-set! pathconf_names "PC_CHOWN_RESTRICTED" 6)
1037 (pylist-set! pathconf_names "PC_NO_TRUNC" 7)
1038 (pylist-set! pathconf_names "PC_VDISABLE" 8)
1039
1040 (define-syntax-rule (rmp code)
1041 (let ((e (errno))
1042 (r (ca code)))
1043 (if (>= r 0)
1044 r
1045 (let ((e2 (errno)))
1046 (if (eq? e e2)
1047 (error "Bug could not find pathcond name endex")
1048 (rm e2))))))
1049
1050 (defineu pathconf (2)
1051 (let ((f (pointer->procedure long
1052 (dynamic-func "pathconf" (dynamic-link))
1053 (list '* int)))
1054 (ff (pointer->procedure long
1055 (dynamic-func "fpathconf" (dynamic-link))
1056 (list int int))))
1057 (lambda (path name)
1058 (let ((ni (pylist-ref pathconf_names name)))
1059 (if (number? path)
1060 (rmp (ff path ni))
1061 (let ((path (path-it path)))
1062 (rmp (f (string->pointer path) ni))))))))
1063
1064 (defineu readlink (0)
1065 (let ((fat (pointer->procedure int
1066 (dynamic-func "readlinkat" (dynamic-link))
1067 (list int '* '* long))))
1068 (lambda* (path #:key (dir_fd None))
1069 (let* ((n 10000)
1070 (bv (make-bytevector 10000))
1071 (bvp (bytevector->pointer bv)))
1072 (rm (fat (if (eq? dir_fd None) AT_FDCWD dir_fd)
1073 (string->pointer (path-it path))
1074 bvp
1075 n))
1076 (bytevector-u8-set! bv (- n 1) 0)
1077 (pointer->string bvp)))))
1078
1079 (defineu remove (0)
1080 (let ((fat (pointer->procedure int
1081 (dynamic-func "unlinkat" (dynamic-link))
1082 (list int '* int))))
1083 (lambda* (path #:key (dir_fd None))
1084 (rm (fat (if (eq? dir_fd None) AT_FDCWD dir_fd)
1085 (string->pointer (path-it path))
1086 0)))))
1087
1088 (define unlink remove)
1089
1090 (define rmdir
1091 (lambda* (path #:key (dir_fd None))
1092 (let ((path (path-it path)))
1093 (if (eq? dir_fd None)
1094 ((@ (guile) rmdir) path)
1095 (let* ((fd (open path O_DIRECTORY #:dir_fd dir_fd))
1096 (path ((@ (guile) readlink) '
1097 (format #f "/proc/self/fd/~a" fd))))
1098 (close fd)
1099 ((@ (guile) rmdir) path))))))
1100
1101 (define (removedirs name)
1102 (let ((name (path-it name)))
1103 (let lp ((l (reverse (string-split name #\/))))
1104 (if (pair? l)
1105 (let ((path (string-join (reverse l) "/")))
1106 (catch #t
1107 (lambda () (rmdir path))
1108 (lambda x (values)))
1109 (lp (cdr l)))))))
1110
1111 (defineu rename (0)
1112 (let ((fat (pointer->procedure int
1113 (dynamic-func "renameat" (dynamic-link))
1114 (list int '* int '*))))
1115 (lambda* (src dst #:key (src_dir_fd None) (dst_dir_fd None))
1116 (rm (fat (if (eq? src_dir_fd None) AT_FDCWD src_dir_fd)
1117 (string->pointer (path-it src))
1118 (if (eq? dst_dir_fd None) AT_FDCWD dst_dir_fd)
1119 (string->pointer (path-it src)))))))
1120
1121
1122 (define replace rename)
1123
1124 (define (renames old new)
1125 (let ((old (path-it old))
1126 (new (path-it new)))
1127 (let lp ((l (string-split new #\/)) (d '()))
1128 (match l
1129 (() #t)
1130 ((x) #t)
1131 (("" . l)
1132 (lp l (cons "" d)))
1133 ((x . l)
1134 (if (pair? d)
1135 (let ((path (string-join (reverse d) "/")))
1136 (catch #t
1137 (lambda () (stat path))
1138 (lambda x (mkdir path)))
1139 (lp l (cons x d)))
1140 (lp l (cons x d))))))
1141 (rename old new)
1142 (let ((l (string-split old #\/)))
1143 (if (> (length l) 1)
1144 (if (= (length l) 2)
1145 (removedirs (string-append (car l) "/"))
1146 (removedirs (string-join (reverse (cdr (reverse l))) "/")))))
1147 (values)))
1148
1149 (define statu stat)
1150
1151 (define-python-class DirEntry ()
1152 (define __init__
1153 (lambda (self path stat)
1154 (set self 'name (basename path))
1155 (set self 'path path)
1156 (set self '__stat stat)))
1157
1158 (define __repr__
1159 (lambda (self)
1160 (format #f "DirEntry(~a)" (basename (ref self 'path)))))
1161
1162 (define inode
1163 (lambda (self)
1164 (let ((stat (ref self '__stat)))
1165 (if stat
1166 (stat:ino stat)
1167 (raise error "Bug no stat")))))
1168
1169 (define is_dir
1170 (lambda* (self #:key (follow_symlinks #t))
1171 (let ((s (statu (ref self 'path)
1172 #:follow_symlinks follow_symlinks)))
1173 (S_ISDIR (ref s 'st_mode)))))
1174
1175 (define is_file
1176 (lambda* (self #:key (follow_symlinks #t))
1177 (let ((s (statu (ref self 'path) #:follow_symlinks follow_symlinks)))
1178 (S_ISREG (ref s 'st_mode)))))
1179
1180 (define is_symlink
1181 (lambda (self)
1182 (let ((s (statu (ref self 'path))))
1183 (S_ISLNK (ref s 'st_mode)))))
1184
1185 (define stat
1186 (lambda* (self #:key (follow_symlinks #t))
1187 (stat (ref self 'path) #:follow_symlinks follow_symlinks))))
1188
1189 (define (one yield)
1190 (let ((first? #t))
1191 (lambda (name stat . x)
1192 (if first?
1193 (begin
1194 (set! first? #f)
1195 #t)
1196 (begin
1197 (yield (DirEntry name stat))
1198 #f)))))
1199
1200 (define* (scandir #:optional (path "."))
1201 ((make-generator ()
1202 (lambda (yield)
1203 (file-system-fold
1204 (one yield)
1205 (lambda (path stat res)
1206 (yield (DirEntry path stat))
1207 res)
1208 (lambda (path stat res)
1209 res)
1210 (lambda (path stat res)
1211 res)
1212 (lambda (path stat res)
1213 res)
1214 (lambda (path stat errno res)
1215 res)
1216 #f
1217 (path-it path))))))
1218
1219 (define (stat_float_times newvalue)
1220 (set! stat-float-times newvalue))
1221
1222 (define ST_RDONLY 1)
1223 (define ST_NOSUID 2)
1224 (define ST_NODEV 4)
1225 (define ST_NOEXEC 8)
1226 (define ST_SYNCHRONOUS 16)
1227 (define ST_MANDLOCK 64)
1228 (define ST_WRITE 128)
1229 (define ST_APPEND 256)
1230 (define ST_IMMUTABLE 512)
1231 (define ST_NOATIME 1024)
1232 (define ST_NODIRATIME 2048)
1233 (define ST_RELATIME 4096)
1234
1235 (define-python-class StatVFS ()
1236 (define __init__
1237 (lambda (self a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11)
1238 (map
1239 (lambda (x y) (set self x y))
1240 '(f_bsize
1241 f_frsize
1242 f_blocks
1243 f_bfree
1244 f_bavail
1245 f_files
1246 f_ffree
1247 f_favail
1248 f_fsid
1249 f_flag
1250 f_namemax)
1251 (list a1 a2 a3 a4 a5 a6 a7 a8 a9 a10)))))
1252
1253 (defineu statvfs (2)
1254 (let ((f (pointer->procedure int
1255 (dynamic-func "statvfs" (dynamic-link))
1256 (list '* '*)))
1257 (ff (pointer->procedure int
1258 (dynamic-func "fstatvfs" (dynamic-link))
1259 (list int '*))))
1260 (lambda (path)
1261 (let* ((bv (make-bytevector (* 11 8)))
1262 (bvp (bytevector->pointer bv)))
1263 (rm (if (number? path)
1264 (ff path bvp)
1265 (f (string->pointer (path-it path)) bvp)))
1266
1267 (StatVFS
1268 (bytevector-u64-ref bv (* 0 8) (native-endianness))
1269 (bytevector-u64-ref bv (* 1 8) (native-endianness))
1270 (bytevector-u64-ref bv (* 2 8) (native-endianness))
1271 (bytevector-u64-ref bv (* 3 8) (native-endianness))
1272 (bytevector-u64-ref bv (* 4 8) (native-endianness))
1273 (bytevector-u64-ref bv (* 5 8) (native-endianness))
1274 (bytevector-u64-ref bv (* 6 8) (native-endianness))
1275 (bytevector-u64-ref bv (* 7 8) (native-endianness))
1276 (bytevector-u64-ref bv (* 9 8) (native-endianness))
1277 (bytevector-u64-ref bv (* 10 8) (native-endianness)))))))
1278
1279
1280 (defineu symlink (0)
1281 (let ((fat (pointer->procedure int
1282 (dynamic-func "symlinkat" (dynamic-link))
1283 (list '* int '*))))
1284
1285 (lambda* (src dst #:key (target_is_directory #f) (dir_fd None))
1286 (rm (fat ((string->pointer (path-it dst))
1287 (if (eq? dir_fd None) AT_FDCWD dir_fd)
1288 (string->pointer (path-it src))))))))
1289
1290 (defineu truncate (2)
1291 (let ((ff (pointer->procedure int
1292 (dynamic-func "ftruncate" (dynamic-link))
1293 (list int long)))
1294 (f (pointer->procedure int
1295 (dynamic-func "truncate" (dynamic-link))
1296 (list '* long))))
1297
1298 (lambda (path length)
1299 (rm (if (number? path)
1300 (ff path length)
1301 (f (string->pointer (path-it path))
1302 length))))))
1303
1304 (define UTIME_NOW (- (ash 1 30) 1))
1305
1306 (define utime #f)
1307 (defineu utime (0 2)
1308 (let ((ff (pointer->procedure int
1309 (dynamic-func "futimes" (dynamic-link))
1310 (list int '*)))
1311 (fat (pointer->procedure int
1312 (dynamic-func "futimesat" (dynamic-link))
1313 (list int '* '* int))))
1314
1315 (lambda* (path #:optional (times None) (ns #f) #:key (dir_fd None)
1316 (follow_symlinks #t))
1317 (let* ((bv (make-bytevector 32))
1318 (bvp (bytevector->pointer bv)))
1319 (if (eq? ns None)
1320 (if (eq? times None)
1321 (let ()
1322 (bytevector-s64-set! bv 0 0
1323 (native-endianness))
1324 (bytevector-s64-set! bv 8 UTIME_NOW
1325 (native-endianness))
1326 (bytevector-s64-set! bv 16 0
1327 (native-endianness))
1328 (bytevector-s64-set! bv 24 UTIME_NOW
1329 (native-endianness)))
1330 (let ((x1 (pylist-ref ns 0))
1331 (x2 (pylist-ref ns 1)))
1332 (bytevector-s64-set! bv 0 (floor-quotient x1 1000000000)
1333 (native-endianness))
1334 (bytevector-s64-set! bv 8 (modulo x1 1000000000)
1335 (native-endianness))
1336 (bytevector-s64-set! bv 16 (floor-quotient x2 1000000000)
1337 (native-endianness))
1338 (bytevector-s64-set! bv 24 (modulo x2 1000000000)
1339 (native-endianness))))
1340 (if (eq? times None)
1341 (begin
1342 (bytevector-s64-set! bv 0 (pylist-ref times 0)
1343 (native-endianness))
1344 (bytevector-s64-set! bv 8 0
1345 (native-endianness))
1346 (bytevector-s64-set! bv 16 (pylist-ref times 1)
1347 (native-endianness))
1348 (bytevector-s64-set! bv 24 0
1349 (native-endianness)))
1350 (raise error "utime cannot set both s and ns")))
1351 (rm (if (number? path)
1352 (ff path bvp)
1353 (fat (if (eq? dir_fd AT_FDCWD None) dir_fd) bvp
1354 (string->pointer (path-it path))
1355 (if follow_symlinks
1356 0
1357 AT_SYMLINK_NOFOLLOW))))))))
1358
1359
1360 (def (walk top (= topdown #t) (= onerror None) (= followlinks #f))
1361 ((make-generator ()
1362 (lambda (yield)
1363 (let/ec ret
1364 (define dirs (py-list))
1365 (define nondirs (py-list))
1366 (define entries #f)
1367
1368 (try
1369 (lambda ()
1370 (set! entries (py-list (scandir top))))
1371 (#:except error =>
1372 (lambda (x . _)
1373 (if onerror (onerror x) (ret)))))
1374
1375 (for ((entry : entries)) ()
1376 (define is_dir (try
1377 (lambda () ((ref entry 'is_dir)))
1378 (#:except error => (lambda x #f))))
1379 (if is_dir
1380 (pylist-append! dirs (ref entry 'name))
1381 (pylist-append! nondirs (ref entry 'name)))
1382
1383 (if (and (not topdown) is_dir)
1384 (let ((walk-into
1385 (if followlinks
1386 #t
1387 (not
1388 (try
1389 (lambda () ((ref entry 'is_symlink)))
1390 (#:except error => (lambda x #f)))))))
1391 (if walk-into
1392 (for ((a b c : (walk (ref entry 'path) topdown
1393 onerror followlinks))) ()
1394 (yield a b c))))))
1395
1396 (if topdown
1397 (begin
1398 (yield top dirs nondirs)
1399
1400 (for ((dirname : dirs)) ()
1401 (let ((new_path (path:join top dirname)))
1402 (if (or followlinks (not (path:islink new_path)))
1403 (for ((a b c : (walk new_path topdown onerror
1404 followlinks))) ()
1405 (yield a b c))))))
1406 (yield top dirs nondirs)))))))
1407
1408 (define (path:islink p)
1409 (catch #t
1410 (lambda ()
1411 (ca (S_ISLNK (stat:mode ((@ (guile) stat) (path-it p))))))
1412 (lambda x #f)))
1413
1414 (define (path:samestat s1 s2)
1415 (and (equal? (ref s1 'st_dev) (ref s2 'st_dev))
1416 (equal? (ref s1 'st_ino) (ref s2 'st_ino))))
1417
1418 (define (path:normpath p)
1419 (let lp ((l (string-split (path-it p) #\/)) (r '()) (first? #t))
1420 (match l
1421 (("") (lp '() (cons "" r) #f))
1422 (("." . l)
1423 (lp l r #f))
1424 (("" . l)
1425 (if first?
1426 (lp l (cons "" r) #f)
1427 (lp l r #f)))
1428 ((".." . l)
1429 (match r
1430 (("")
1431 (raise ValueError "normpath .. beond /"))
1432 ((".." . u)
1433 (lp l (cons ".." r) #f))
1434 ((_ . u)
1435 (lp l u #f))
1436 (()
1437 (lp l (cons ".." r) #f))))
1438 ((x . l)
1439 (lp l (cons x r) #f))
1440 (() (string-join (reverse r) "/")))))
1441
1442 (define (path:join . l)
1443 (path:normpath (string-join (map path-it l) "/")))
1444
1445 (define (_fwalk topfd toppath topdown onerror follow_symlinks)
1446 ((make-generator ()
1447 (lambda (yield)
1448 (define names (listdir topfd))
1449 (define dirs (py-list))
1450 (define nondirs (py-list))
1451
1452 (for ((name : names)) ()
1453 (try
1454 (lambda ()
1455 (if (S_ISDIR (ref (stat name #:dir_fd topfd) 'st_mode))
1456 (pylist-append! dirs name)
1457 (pylist-append! nondirs name)))
1458 (#:except error =>
1459 (lambda x
1460 (try
1461 (lambda ()
1462 (if (S_ISLNK (ref (stat name #:dir_fd topfd
1463 #:follow_symlinks #f)
1464 'st_mode))
1465 (pylist-append! nondirs name)))
1466 (#:except error => (lambda x (values))))))))
1467
1468 (if topdown
1469 (yield toppath dirs nondirs topfd))
1470
1471 (for continue ((name : dirs)) ()
1472 (call-with-values
1473 (lambda ()
1474 (try
1475 (lambda ()
1476 (values (stat name #:dir_fd topfd
1477 #:follow_symlinks follow_symlinks)
1478 (open name O_RDONLY #:dir_fd topfd)))
1479 (#:except error =>
1480 (lambda (err . l)
1481 (if (not (eq? onerror None))
1482 (onerror err)
1483 (continue))))))
1484 (lambda (orig_st dirfd)
1485 (try
1486 (lambda ()
1487 (if (or follow_symlinks (path:samestat orig_st (stat dirfd)))
1488 (let ((dirpath (path:join toppath name)))
1489 (for ((a b c d :
1490 (_fwalk dirfd dirpath topdown onerror
1491 follow_symlinks))) ()
1492 (yield a b c d)))))
1493
1494 #:finally
1495 (lambda () (close dirfd))))))
1496
1497 (if (not topdown)
1498 (yield toppath dirs nondirs topfd))))))
1499
1500 (def (fwalk (= top ".") (= topdown #t) (= onerror #t)
1501 (= follow_symlinks #f) (= dir_fd None))
1502 ((make-generator ()
1503 (lambda (yield)
1504 (define orig_st (stat top #:follow_symlinks #f #:dir_fd dir_fd))
1505 (define topfd (open top O_RDONLY #:dir_fd dir_fd))
1506
1507 (try
1508 (lambda ()
1509 (if (or follow_symlinks (and (S_ISDIR (ref orig_st 'st_mode))
1510 (path:samestat orig_st (stat topfd))))
1511 (for ((a b c d :
1512 (_fwalk topfd top topdown onerror follow_symlinks))) ()
1513 (yield a b c d))))
1514 #:finally
1515 (lambda () (close topfd)))))))
1516
1517 ;; Extended attributes
1518 (define getxattr #f)
1519 (defineu getxattr (2)
1520 (let ((f (pointer->procedure int
1521 (dynamic-func "getxattr" (dynamic-link))
1522 (list '* '* '* int)))
1523 (lf (pointer->procedure int
1524 (dynamic-func "lgetxattr" (dynamic-link))
1525 (list '* '* '* int)))
1526 (ff (pointer->procedure int
1527 (dynamic-func "fgetxattr" (dynamic-link))
1528 (list '* '* '* int))))
1529 (lambda* (path attribute #:key (follow_symlink #t))
1530 (let ((path (ca (if (number? path)
1531 path
1532 (string->pointer (path-it path)))))
1533 (k (ca (string->pointer attribute))))
1534 (let lp ((size 128))
1535 (let* ((v (make-bytevector size))
1536 (pv (bytevector->pointer v)))
1537 (let ((n (rm (if (number? path)
1538 (ff path k pv size)
1539 (if follow_symlink
1540 (f path k pv size)
1541 (lf path k pv size))))))
1542 (if (> n (- size 2))
1543 (lp (* 2 size))
1544 (pointer->string pv)))))))))
1545
1546 (define listxattr #f)
1547 (defineu listxattr (2)
1548 (let ((f (pointer->procedure int
1549 (dynamic-func "listxattr" (dynamic-link))
1550 (list '* '* int)))
1551 (lf (pointer->procedure int
1552 (dynamic-func "llistxattr" (dynamic-link))
1553 (list '* '* int)))
1554 (ff (pointer->procedure int
1555 (dynamic-func "flistxattr" (dynamic-link))
1556 (list '* '* int))))
1557 (define (mk l)
1558 (define v (make-bytevector (+ (length l) 1)))
1559 (define vp (bytevector->pointer v))
1560 (let lp ((i 0) (l l))
1561 (if (pair? l)
1562 (begin
1563 (bytevector-u8-set! v i (car l))
1564 (lp (+ i 1) (cdr l)))
1565 (begin
1566 (bytevector-u8-set! v i 0)
1567 (pointer->string vp)))))
1568
1569 (lambda* (path attribute #:key (follow_symlink #t))
1570 (let ((path (if (number? path) path (string->pointer (path-it path)))))
1571 (let lp ((size 128))
1572 (let* ((v (make-bytevector size))
1573 (pv (bytevector->pointer v)))
1574 (let ((n (rm (if (number? path)
1575 (ff path pv size)
1576 (if follow_symlink
1577 (f path pv size)
1578 (lf path pv size))))))
1579 (if (> n (- size 2))
1580 (lp (* 2 size))
1581 (let lp ((i 0) (l '()))
1582 (if (< i n)
1583 (let lp2 ((j i) (r '()))
1584 (if (< j n)
1585 (let ((x (bytevector-u8-ref v j)))
1586 (if (= x 0)
1587 (if (null? r)
1588 (lp (+ j 1) l)
1589 (lp (+ j 1) (cons (mk (reverse r))
1590 l)))
1591 (lp2 (+ j 1) (cons x r))))
1592 (if (null? r)
1593 (lp j l)
1594 (lp j (cons (mk (reverse r)) l)))))
1595 (pylist (reverse l))))))))))))
1596
1597 (define removexattr #f)
1598 (defineu removexattr (2)
1599 (let ((f (pointer->procedure int
1600 (dynamic-func "removexattr" (dynamic-link))
1601 (list '* '*)))
1602 (lf (pointer->procedure int
1603 (dynamic-func "lremovexattr" (dynamic-link))
1604 (list '* '*)))
1605 (ff (pointer->procedure int
1606 (dynamic-func "fremovexattr" (dynamic-link))
1607 (list int '*))))
1608 (lambda* (path attribute #:key (follow_symlink #t))
1609 (let ((path (if (number? path)
1610 path
1611 (string->pointer (path-it path))))
1612 (k (ca (string->pointer attribute))))
1613 (rm (if (number? path)
1614 (ff path k)
1615 (if follow_symlink
1616 (f path k)
1617 (lf path k))))))))
1618
1619 (define setxattr #f)
1620 (defineu setxattr (2)
1621 (let ((f (pointer->procedure int
1622 (dynamic-func "setxattr" (dynamic-link))
1623 (list '* '* '* int int)))
1624 (lf (pointer->procedure int
1625 (dynamic-func "lsetxattr" (dynamic-link))
1626 (list '* '* '* int int)))
1627 (ff (pointer->procedure int
1628 (dynamic-func "fsetxattr" (dynamic-link))
1629 (list int '* '* int int))))
1630 (lambda* (path attribute value flags #:key (follow_symlink #t))
1631 (let* ((path (if (number? path) path (string->pointer (path-it path))))
1632 (val (ca (string->pointer value)))
1633 (s (string-length val))
1634 (k (ca (string->pointer attribute))))
1635 (rm (if (number? path)
1636 (ff path k val s flags)
1637 (if follow_symlink
1638 (f path k val s flags)
1639 (lf path k val s flags))))))))
1640
1641 (define XATTR_SIZE_MAX (ash 1 16))
1642 (define XATTR_CREATE 1)
1643 (define XATTR_REPLACE 2)
1644
1645 ;; Processes
1646 (define (abort) ((@ (guile) raise) (@ (guile) SIGABRT)))
1647
1648 (define (exists p)
1649 (if (number? p)
1650 (catch #t
1651 (lambda () ((@ (guile) readlink) (format #f "/proc/self/fd/~a" p)))
1652 (lambda x #f))
1653 (catch #t
1654 (lambda () ((@ (guile) stat) (path-it p)) #t)
1655 (lambda x #f))))
1656
1657 (define (comp e pth)
1658 (if (eq? (string-ref pth 0) #\/)
1659 pth
1660 (let ((r (py-get e "PATH")))
1661 (if r
1662 (let lp ((l (string-split r #\:)))
1663 (match l
1664 ((pp . l)
1665 (let ((newpath (string-join (cons pp pth) "/")))
1666 (if (exists newpath)
1667 newpath
1668 (lp l))))
1669 (()
1670 pth)))
1671 pth))))
1672
1673
1674 (define (compe e)
1675 (for ((k v : e)) ((l '()))
1676 (cons (string-append k "=" v) l)
1677 #:final (reverse l)))
1678
1679 (define (execl path . args) (apply (@ (guile) execl) (path-it path) args))
1680 (define (execle path . args) (apply (@ (guile) execl) (path-it path)
1681 (let* ((a (reverse args))
1682 (e (compe (car args)))
1683 (l (reverse (cdr args))))
1684 (cons e l))))
1685 (define (execlpe path . args)
1686 (let* ((a (reverse args))
1687 (e (compe (car args)))
1688 (l (cons e (reverse (cdr args)))))
1689 (apply (@ (guile) execle) (comp e (path-it path)) l)))
1690
1691 (define (execlp path . args) (apply (@ (guile) execlp) (path-it path) args))
1692
1693 (define (execv path args)
1694 (apply execl path (for ((a : args)) ((l '()))
1695 (cons a l)
1696 #:final (reverse l))))
1697
1698 (define (execve path args env )
1699 (apply execle path (for ((a : args)) ((l (list env)))
1700 (cons a l)
1701 #:final (reverse l))))
1702
1703 (define (execvp path args)
1704 (apply execlp path (for ((a : args)) ((l '()))
1705 (cons a l)
1706 #:final (reverse l))))
1707
1708 (define (execvp path args env)
1709 (apply execlpe path (for ((a : args)) ((l (list env)))
1710 (cons a l)
1711 #:final (reverse l))))
1712
1713
1714
1715 (define (_exit n) (primitive-_exit n))
1716
1717 (define EX_OK 0)
1718 (define EX_USAGE 64)
1719 (define EX_DATAERR 65)
1720 (define EX_NOINPUT 66)
1721 (define EX_NOUSER 67)
1722 (define EX_NOHOST 68)
1723 (define EX_UNAVAILABLE 69)
1724 (define EX_SOFTWARE 70)
1725 (define EX_OSERR 71)
1726 (define EX_OSFILE 72)
1727 (define EX_CANTCREAT 73)
1728 (define EX_IOERR 74)
1729 (define EX_TEMPFAIL 75)
1730 (define EX_PROTOCOL 76)
1731
1732 (define fork primitive-fork)
1733
1734 (define (kill pid sig) (ca ((@ (guile) kill) pid sig)))
1735
1736 (define (nice i) (ca ((@ (guile) nice) i)))
1737
1738 (define killpg
1739 (let ((f (pointer->procedure int
1740 (dynamic-func "killpg" (dynamic-link))
1741 (list int int))))
1742 (lambda (pgid sig)
1743 (rm (f pgid sig)))))
1744
1745 (define (plock . l) (error "not implemented"))
1746
1747 (define* (popen com #:optional (mode "r") (buffering -1))
1748 (let ((port (ca ((@ (ice-9 popen) open-pipe) com
1749 (cond
1750 ((equal? mode "r") OPEN_READ)
1751 ((equal? mode "w") OPEN_WRITE)
1752 ((or (equal? mode "rw")
1753 (equal? mode "r+")
1754 (equal? mode "w+")
1755 (equal? mode "wr"))
1756 OPEN_BOTH))))))
1757 (ca
1758 (case buffering
1759 ((-1)
1760 (setvbuf port 'block DEFAULT_BUFFER_SIZE))
1761 ((0)
1762 (setvbuf port 'none))
1763 ((1)
1764 (setvbuf port 'line))
1765 (else
1766 (setvbuf port 'block buffering))))
1767
1768 port))
1769
1770 (define P_WAIT 0)
1771 (define P_NOWAIT 1)
1772 (define P_NOWAIT0 1)
1773
1774 (define-syntax-rule (mk-spawn f ff)
1775 (define (f mode . l)
1776 (let ((pid (primitive-fork)))
1777 (if (= l 0)
1778 (apply ff l)
1779 (cond
1780 ((= mode P_WAIT)
1781 (cdr ((@ (guile) waitpid) pid)))
1782 ((= mode P_NOWAIT)
1783 pid)
1784 (else
1785 (raise ValueError "wrong mode specified in spawn command")))))))
1786
1787 (mk-spawn spawnl execl)
1788 (mk-spawn spawnle execle)
1789 (mk-spawn spawnlp execlp)
1790 (mk-spawn spawnlpe execlpe)
1791 (mk-spawn spawnv execv)
1792 (mk-spawn spawnve execve)
1793 (mk-spawn spawnvp execvp)
1794 (mk-spawn spawnvpe execvpe)
1795
1796 (define startfile
1797 (lambda x (error "not implemented")))
1798
1799 (define (system command) (ca ((@ (guile) system) command)))
1800
1801 (define-python-class Times ()
1802 (define __init__
1803 (lambda (self v)
1804 (set self 'user (tms:utime v))
1805 (set self 'system (tms:stime v))
1806 (set self 'children_user (tms:cutime v))
1807 (set self 'children_system (tms:cstime v))
1808 (set self 'elapsed (tms:clock v))))
1809 (define __repr__
1810 (lambda (self)
1811 (format #f "Time(user:~a system:~a ...)"
1812 (ref self 'user)
1813 (ref self 'system)))))
1814
1815 (define (times)
1816 (ca (Times ((@ (guile) times)))))
1817
1818 (define (wait)
1819 (let ((x ((@ (guile) waitpid) -1)))
1820 (list (car x) (cdr x))))
1821
1822 (define-python-class SigInfo ()
1823 (define __init__
1824 (lambda (self a b c d e)
1825 (set self 'si_signo a)
1826 (set self 'si_code b)
1827 (set self 'si_pid c)
1828 (set self 'si_uid d)
1829 (set self 'si_status e)))
1830
1831 (define __repr__
1832 (lambda (self)
1833 (format #f
1834 "SigInfo(signo:~a code:~a pid:~a uid:~a status:~a"
1835 (ref self 'si_signo)
1836 (ref self 'si_code)
1837 (ref self 'si_pid)
1838 (ref self 'si_uid)
1839 (ref self 'si_status)))))
1840
1841 (define waitid #f)
1842 (defineu waitid ()
1843 (let ((f (pointer->procedure int
1844 (dynamic-func "waitid" (dynamic-link))
1845 (list int int '* int))))
1846 (lambda (idtype id options)
1847 (let* ((b (make-bytevector 228))
1848 (vp (bytevector->pointer b))
1849 (ref (lambda (i) (bytevector-s32-ref
1850 b i (native-endianness))))
1851 (si_status (lambda () (ref 6)))
1852 (si_code (lambda () (ref 2)))
1853 (si_pid (lambda () (ref 4)))
1854 (si_uid (lambda () (ref 5)))
1855 (si_signo (lambda () (ref 0))))
1856 (rm (f idtype id vp options))
1857 (SigInfo (si_signo) (si_code) (si_pid) (si_uid)
1858 (si_status))))))
1859
1860 (define P_PID 1)
1861 (define P_PGID 2)
1862 (define P_ALL 0)
1863
1864 (define WEXITED 4)
1865 (define WUNTRACED 2)
1866 (define WSTOPPED 2)
1867 (define WNOWAIT #x01000000)
1868 (define WCONTINUED 8)
1869 (define WNOHANG 1)
1870
1871 (define CLD_EXITED 1)
1872 (define CLD_KILLED 2)
1873 (define CLD_DUMPED 3)
1874 (define CLD_STOPED 5)
1875 (define CLD_TRAPPED 4)
1876 (define CLD_CONTINUED 6)
1877
1878 (define (waitpid pid options)
1879 (ca ((@ (guile) waitpid) pid options)))
1880
1881 (define wait3 #f)
1882 (defineu wait3 ()
1883 (let ((f (pointer->procedure int
1884 (dynamic-func "wait3" (dynamic-link))
1885 (list '* int '*))))
1886 (lambda (option)
1887 (let* ((v (make-bytevector 250))
1888 (vp (bytevector->pointer v))
1889 (w (make-bytevector 8))
1890 (wp (bytevector->pointer w)))
1891
1892 (let ((pid (rm (f wp option vp))))
1893 (list pid
1894 (bytevector-s32-ref w 0 (native-endianness))
1895 (ResUsage v)))))))
1896
1897 (define wait4 #f)
1898 (defineu wait4 ()
1899 (let ((f (pointer->procedure int
1900 (dynamic-func "wait4" (dynamic-link))
1901 (list int '* int '*))))
1902 (lambda (pid option)
1903 (let* ((v (make-bytevector 250))
1904 (vp (bytevector->pointer v))
1905 (w (make-bytevector 8))
1906 (wp (bytevector->pointer w)))
1907
1908 (let ((pid2 (rm (f pid wp option vp))))
1909 (list pid
1910 (bytevector-s32-ref w 0 (native-endianness))
1911 (ResUsage v)))))))
1912
1913 (define __WCOREFLAG #x80)
1914 (define __W_CONTINUED #xffff)
1915
1916 (define (WCOREDUMP status) (> (logand status __WCOREFLAG) 0))
1917 (define (WIFCONTINUED status) (= status __W_CONTINUED))
1918 (define (WIFSTOPPED status) (= (logand status #xff) #x7f))
1919 (define (WIFSIGNALED status) (> (ash (+ (logand status #x7f) 1) -1) 0))
1920
1921 (define (WIFEXITED status) (= (WTERMSIG status) 0))
1922 (define (WEXITSTATUS status) (ash (logand status #xff00) 8))
1923 (define (WSTOPSIG status) (WEXITSTATUS status))
1924 (define (WTERMSIG status) (logand status #x7f))
1925
1926 ;; Scheduling
1927
1928 (define SCHED_OTHER 0)
1929 (define SCHED_BATCH 3)
1930 (define SCHED_IDLE 5)
1931 (define SCHED_FIFO 1)
1932 (define SCHED_RR 2)
1933 (define SCHED_RESET_ON_FORK #x40000000)
1934
1935 (define-python-class sched_param ()
1936 (define __init__
1937 (lambda (self v)
1938 (if (bytevector? v)
1939 (set self 'sched_priority
1940 (bytevector-s32-ref v 0 (native-endianness)))
1941 (set self 'sched_priority v)))))
1942
1943 (define sched_get_priority_min #f)
1944 (defineu sched_get_priority_min ()
1945 (let ((f (pointer->procedure int
1946 (dynamic-func "sched_get_priority_min"
1947 (dynamic-link))
1948 (list int))))
1949 (lambda (policy) (rm (f policy)))))
1950
1951 (define sched_get_priority_max #f)
1952 (defineu sched_get_priority_max ()
1953 (let ((f (pointer->procedure int
1954 (dynamic-func "sched_get_priority_max"
1955 (dynamic-link))
1956 (list int))))
1957 (lambda (policy) (rm (f policy)))))
1958
1959 (define sched_setscheduler #f)
1960 (defineu sched_setscheduler ()
1961 (let ((f (pointer->procedure int
1962 (dynamic-func "sched_setscheduler"
1963 (dynamic-link))
1964 (list int int '*))))
1965 (lambda (pid policy param)
1966 (let* ((v (make-bytevector 32))
1967 (vp (bytevector->pointer v)))
1968 (bytevector-s32-set! v 0 (ref param 'sched_priority)
1969 (native-endianness))
1970 (rm (f pid policy vp))))))
1971
1972 (define sched_getscheduler #f)
1973 (defineu sched_getscheduler ()
1974 (let ((f (pointer->procedure int
1975 (dynamic-func "sched_getscheduler"
1976 (dynamic-link))
1977 (list int))))
1978 (lambda (pid)
1979 (ca (f pid)))))
1980
1981 (define sched_setparam #f)
1982 (defineu sched_setparam ()
1983 (let ((f (pointer->procedure int
1984 (dynamic-func "sched_setparam"
1985 (dynamic-link))
1986 (list int '*))))
1987 (lambda (pid param)
1988 (let* ((v (make-bytevector 32))
1989 (vp (bytevector->pointer v)))
1990 (bytevector-s32-set! v 0 (ref param 'sched_priority)
1991 (native-endianness))
1992 (rm (f pid vp))))))
1993
1994 (define sched_getparam #f)
1995 (defineu sched_getparam ()
1996 (let ((f (pointer->procedure int
1997 (dynamic-func "sched_getparam"
1998 (dynamic-link))
1999 (list int '*))))
2000 (lambda (pid param)
2001 (let* ((v (make-bytevector 32))
2002 (vp (bytevector->pointer v)))
2003 (rm (f pid vp))
2004 (sched_param v)))))
2005
2006 (define sched_rr_get_intervall
2007 (lambda x (error "not implemented")))
2008
2009 (define sched_yield #f)
2010 (defineu sched_yield ()
2011 (let ((f (pointer->procedure int
2012 (dynamic-func "sched_yield"
2013 (dynamic-link))
2014 (list))))
2015 (lambda () (rm (f)))))
2016
2017 (define sched_setaffinity#f)
2018 (defineu sched_setaffinity ()
2019 (let ((f (pointer->procedure int
2020 (dynamic-func "sched_setaffinity"
2021 (dynamic-link))
2022 (list int int '*)))
2023 (n (/ 1024 64)))
2024 (lambda (pid mask)
2025 (let* ((v (make-bytevector (/ 1024 64)))
2026 (vp (bytevector->pointer v)))
2027
2028 (for ((m : mask)) ((i (range 1000)))
2029 (bytevector-u64-set! v i (* m 8) (native-endianness)))
2030
2031 (rm (f pid (/ n 8) vp))))))
2032
2033 (define sched_getaffinity #f)
2034 (defineu sched_getaffinity ()
2035 (let ((f (pointer->procedure int
2036 (dynamic-func "sched_getaffinity"
2037 (dynamic-link))
2038 (list int int '*)))
2039 (n (/ 1024 64)))
2040 (lambda (pid)
2041 (let* ((v (make-bytevector (/ 1024 64)))
2042 (vp (bytevector->pointer v)))
2043
2044 (rm (f pid (/ n 8) vp))
2045 (let lp ((i 0))
2046 (if (< i n)
2047 (cons (bytevector-u64-ref v (* i 8) (native-endianness))
2048 (lp (+ i 1)))
2049 '()))))))
2050
2051
2052 ;; MISC SYSTEM INFORMATION
2053 (defineu confstr_ ()
2054 (let ((f (pointer->procedure int
2055 (dynamic-func "confstr"
2056 (dynamic-link))
2057 (list int '* int))))
2058 (lambda (id)
2059 (let* ((v (make-bytevector 1024))
2060 (vp (bytevector->pointer v)))
2061 (rm (f id vp 1024))
2062 (pointer->string vp)))))
2063
2064 (define confstr_names
2065 (dict
2066 '(("LIBC_VERSION" . 2)
2067 ("LIBPTHREAD_VERSION" . 3)
2068 ("PATH" . 0))))
2069
2070 (define (confstr id)
2071 (let ((id2 (if (number? id) id (pylist-ref confstr_names id))))
2072 (if id2
2073 (confstr_ id2)
2074 (raise KeyError "no confstr for " id))))
2075
2076 (defineu cpu_count ()
2077 (let ((f (pointer->procedure int
2078 (dynamic-func "get_nprocs"
2079 (dynamic-link))
2080 (list))))
2081 (lambda ()
2082 (rm (f)))))
2083
2084
2085 (defineu sysconf_ ()
2086 (let ((f (pointer->procedure long
2087 (dynamic-func "sysconf"
2088 (dynamic-link))
2089 (list int))))
2090 (lambda (id)
2091 (rm (f id)))))
2092
2093 (define i 0)
2094 (define (f) (let ((r i)) (set! i (+ i 1)) r))
2095 (define sysconf_names
2096 (dict
2097 `(("ARG_MAX" . ,(f))
2098 ("CHILD_MAX" . ,(f))
2099 ("CLK_TCK" . ,(f))
2100 ("NGROUPS_MAX" . ,(f))
2101 ("OPEN_MAX" . ,(f))
2102 ("STREAM_MAX" . ,(f))
2103 ("TZNAME_MAX" . ,(f))
2104 ("JOB_CONTROL" . ,(f))
2105 ("SAVED_IDS" . ,(f))
2106 ("REALTIME_SIGNALS" . ,(f))
2107 ("PRIORITY_SCHEDULING" . ,(f))
2108 ("TIMERS" . ,(f))
2109 ("ASYNCHRONO√ôS_IO" . ,(f))
2110 ("PRIORITIZED_IO" . ,(f))
2111 ("SYNCHRONIZED_IO" . ,(f))
2112 ("FSYNC" . ,(f))
2113 ("MAPPED_FILES" . ,(f))
2114 ("MEMLOCK" . ,(f))
2115 ("MEMLOCK_RANGE" . ,(f))
2116 ("MEMORY_PROTECTION" . ,(f))
2117 ("MESSAGE_PASSING" . ,(f))
2118 ("SEMAPHORES" . ,(f))
2119 ("SHARED_MEMORY_OBJECTS" . ,(f))
2120 ("AIO_LISTIO_MAX" . ,(f))
2121 ("AIO_MAX" . ,(f))
2122 ("AIO_PRIO_DELTA_MAX" . ,(f))
2123 ("AIO_DELAYTIMER_MAX" . ,(f))
2124 ("MQ_OPEN_MAX" . ,(f))
2125 ("MQ_PRIO_MAX" . ,(f))
2126 ("POSIX_VERSION" . ,(f))
2127 ("PAGESIZE" . ,(f))
2128 ("RTSIG_MAX" . ,(f))
2129 ("SEM_NSEMS_MAX" . ,(f))
2130 ("SEM_VALUE_MAX" . ,(f))
2131 ("SIGQUEUE_MAX" . ,(f))
2132 ("TIMER_MAX" . ,(f))
2133
2134 ("BC_BASE_MAX" . ,(f))
2135 ("BC_DIM_MAX" . ,(f))
2136 ("BC_SCALE_MAX" . ,(f))
2137 ("BC_STRING_MAX" . ,(f))
2138 ("COLL_WEIGHTS_MAX" . ,(f))
2139 ("EQUIV_CLASS_MAX" . ,(f))
2140 ("EXPR_NEST_MAX" . ,(f))
2141 ("LINE_MAX" . ,(f))
2142 ("RE_DUP_MAX" . ,(f))
2143 ("CHARCLASS_NAME_MAX" . ,(f))
2144 ("POSIX2_VERSION" . ,(f))
2145 ("2_C_BIND" . ,(f))
2146 ("2_C_DEV" . ,(f))
2147 ("2_FORT_DEV" . ,(f))
2148 ("2_FORT_RUN" . ,(f))
2149 ("2_SW_DEF" . ,(f))
2150 ("2_LOCALEDEF" . ,(f))
2151 ("PII" . ,(f))
2152 ("PII_XTI" . ,(f))
2153 ("PII_SOCKET" . ,(f))
2154 ("PII_INTERNET" . ,(f))
2155 ("PII_OSI" . ,(f))
2156 ("POLL" . ,(f))
2157 ("SELECT" . ,(f))
2158 ("UIO_MAXIOV" . ,i)
2159 ("IOV_MAX" . ,(f))
2160 ("PII_INTERNET_STREAM" . ,(f))
2161 ("PII_INTERNET_DGRAM" . ,(f))
2162 ("PII_OSI_COTS" . ,(f))
2163 ("PII_OSI_CLTS" . ,(f))
2164 ("PII_OSI_M" . ,(f))
2165 ("T_IOV_MAX" . ,(f))
2166 ("THREADS" . ,(f))
2167 ("THREAD_SAFE_FUNCTIONS" . ,(f))
2168 ("GETGR_R_SIZE_MAX" . ,(f))
2169 ("GETPW_R_SIZE_MAX" . ,(f))
2170 ("LOGIN_NAME_MAX" . ,(f))
2171 ("TTY_NAME_MAX" . ,(f))
2172 ("THREAD_DESTRUCTOR_ITERATIONS" . ,(f))
2173 ("THREAD_KEYS_MAX" . ,(f))
2174 ("THREAD_STACK_MIN" . ,(f))
2175 ("THREAD_THREADS_MAX" . ,(f))
2176 ("THREAD_ATTR_STACKADDR" . ,(f))
2177 ("THREAD_ATTR_STACKSIZE" . ,(f))
2178 ("THREAD_PRIORITY_SCHEDULING" . ,(f))
2179 ("THREAD_PRIO_INHERIT" . ,(f))
2180 ("THREAD_PRIO_PROTECT" . ,(f))
2181 ("THREAD_PROCESS_SHARED" . ,(f))
2182 ("NPROCESSORS_CONF" . ,(f))
2183 ("NPROCESSORS_ONLN" . ,(f))
2184 ("PHYS_PAGES" . ,(f))
2185 ("AVPHYS_PAGES" . ,(f))
2186 ("ATEXIT_MAX" . ,(f))
2187 ("PASS_MAX" . ,(f))
2188 ("XOPEN_VERSION" . ,(f))
2189 ("XOPEN_XCU_VERSION" . ,(f))
2190 ("XOPEN_UNIX" . ,(f))
2191 ("XOPEN_CRYPT" . ,(f))
2192 ("XOPEN_ENH_I18N" . ,(f))
2193 ("XOPEN_SHM" . ,(f))
2194 ("2_CHAR_TERM" . ,(f))
2195 ("2_C_VERSION" . ,(f))
2196 ("2_UPE" . ,(f))
2197 ("XOPEN_XPG2" . ,(f))
2198 ("XOPEN_XPG3" . ,(f))
2199 ("XOPEN_XPG4" . ,(f))
2200 ("CHAR_BIT" . ,(f))
2201 ("CHAR_MAX" . ,(f))
2202 ("CHAR_MIN" . ,(f))
2203 ("INT_MAX" . ,(f))
2204 ("INT_MIN" . ,(f))
2205 ("LONG_BIT" . ,(f))
2206 ("WORD_BIT" . ,(f))
2207 ("MB_LEN_MAX" . ,(f))
2208 ("NZERO" . ,(f))
2209 ("SSIZE_MAX" . ,(f))
2210 ("SCHAR_MAX" . ,(f))
2211 ("SCHAR_MIN" . ,(f))
2212 ("SHRT_MAX" . ,(f))
2213 ("SHRT_MIN" . ,(f))
2214 ("UCHAR_MAX" . ,(f))
2215 ("UINT_MAX" . ,(f))
2216 ("ULONG_MAX" . ,(f))
2217 ("USHRT_MAX" . ,(f))
2218 ("NL_ARGMAX" . ,(f))
2219 ("NL_LANGMAX" . ,(f))
2220 ("NL_MSGMAX" . ,(f))
2221 ("NL_NMAX" . ,(f))
2222 ("NL_SETMAX" . ,(f))
2223 ("NL_TEXTMAX" . ,(f))
2224 ("XBS5_ILP32_OFF32" . ,(f))
2225 ("XBS5_ILP32_OFFBIG" . ,(f))
2226 ("XBS5_LP64_OFF64" . ,(f))
2227 ("XBS5_LPBIG_OFFBIG" . ,(f))
2228 ("XOPEN_LEGACY" . ,(f))
2229 ("XOPEN_REALTIME" . ,(f))
2230 ("XOPEN_REALTIME_THREADS" . ,(f))
2231 ("ADVISORY_INFO" . ,(f))
2232 ("BARRIERS" . ,(f))
2233 ("BASE" . ,(f))
2234 ("C_LANG_SUPPORT" . ,(f))
2235 ("C_LANG_SUPPORT_R" . ,(f))
2236 ("CLOCK_SELECTION" . ,(f))
2237 ("CPUTIME" . ,(f))
2238 ("THREAD_CPUTIME" . ,(f))
2239 ("DEVICE_IO" . ,(f))
2240 ("DEVICE_SPECIFIC" . ,(f))
2241 ("DEVICE_SPECIFIC_R" . ,(f))
2242 ("FD_MGMT" . ,(f))
2243 ("FIFO" . ,(f))
2244 ("PIPE" . ,(f))
2245 ("FILE_ATTRIBUTES" . ,(f))
2246 ("FILE_LOCKING" . ,(f))
2247 ("FILE_SYSTEM" . ,(f))
2248 ("MONOTONIC_CLOCK" . ,(f))
2249 ("MULTI_PROCESS" . ,(f))
2250 ("SINGLE_PROCESS" . ,(f))
2251 ("NETWORKING" . ,(f))
2252 ("READER_WRITER_LOCKS" . ,(f))
2253 ("SPIN_LOCKS" . ,(f))
2254 ("REGEXP" . ,(f))
2255 ("REGEX_VERSION" . ,(f))
2256 ("SHELL" . ,(f))
2257 ("SIGNALS" . ,(f))
2258 ("SPAWN" . ,(f))
2259 ("SPORADIC_SERVER" . ,(f))
2260 ("THREAD_SPORADIC_SERVER" . ,(f))
2261 ("SYSTEM_DATABASE" . ,(f))
2262 ("SYSTEM_DATABASE_R" . ,(f))
2263 ("TIMEOUTS" . ,(f))
2264 ("TYPED_MEMORY_OBJECTS" . ,(f))
2265 ("USER_GROUPS" . ,(f))
2266 ("USER_GROUPS_R" . ,(f))
2267 ("2_PBS" . ,(f))
2268 ("2_PBS_ACCOUNTING" . ,(f))
2269 ("2_PBS_LOCATE" . ,(f))
2270 ("2_PBS_MESSAGE" . ,(f))
2271 ("2_PBS_TRACK" . ,(f))
2272 ("SYMLOOP_MAX" . ,(f))
2273 ("STREAMS" . ,(f))
2274 ("2_PBS_CHECKPOINT" . ,(f))
2275 ("V6_ILP32_OFF32" . ,(f))
2276 ("V6_ILP32_OFFBIG" . ,(f))
2277 ("V6_LP64_OFF64" . ,(f))
2278 ("V6_LPBIG_OFFBIG" . ,(f))
2279 ("HOST_NAME_MAX" . ,(f))
2280 ("TRACE" . ,(f))
2281 ("TRACE_EVENT_FILTER" . ,(f))
2282 ("TRACE_INHERIT" . ,(f))
2283 ("TRACE_LOG" . ,(f))
2284 ("LEVEL1_ICACHE_SIZE" . ,(f))
2285 ("LEVEL1_ICACHE_ASSOC" . ,(f))
2286 ("LEVEL1_ICACHE_LINESIZE" . ,(f))
2287 ("LEVEL1_DCACHE_SIZE" . ,(f))
2288 ("LEVEL1_DCACHE_ASSOC" . ,(f))
2289 ("LEVEL1_DCACHE_LINESIZE" . ,(f))
2290 ("LEVEL2_CACHE_SIZE" . ,(f))
2291 ("LEVEL2_CACHE_ASSOC" . ,(f))
2292 ("LEVEL2_CACHE_LINESIZE" . ,(f))
2293 ("LEVEL3_CACHE_SIZE" . ,(f))
2294 ("LEVEL3_CACHE_ASSOC" . ,(f))
2295 ("LEVEL3_CACHE_LINESIZE" . ,(f))
2296 ("LEVEL4_CACHE_SIZE" . ,(f))
2297 ("LEVEL4_CACHE_ASSOC" . ,(f))
2298 ("LEVEL4_CACHE_LINESIZE" . ,(f))
2299 ("IPV6 = _SC_LEVEL1_ICACHE_SIZE + 50" . ,(f))
2300 ("RAW_SOCKETS" . ,(f))
2301 ("V7_ILP32_OFF32" . ,(f))
2302 ("V7_ILP32_OFFBIG" . ,(f))
2303 ("V7_LP64_OFF64" . ,(f))
2304 ("V7_LPBIG_OFFBIG" . ,(f))
2305 ("SS_REPL_MAX" . ,(f))
2306 ("TRACE_EVENT_NAME_MAX" . ,(f))
2307 ("TRACE_NAME_MAX" . ,(f))
2308 ("TRACE_SYS_MAX" . ,(f))
2309 ("TRACE_USER_EVENT_MAX" . ,(f))
2310 ("XOPEN_STREAMS" . ,(f))
2311 ("THREAD_ROBUST_PRIO_INHERIT" . ,(f))
2312 ("THREAD_ROBUST_PRIO_PROTECT" . ,(f)))))
2313
2314 (define (sysconf id)
2315 (let ((id2 (if (number? id) id (pylist-ref sysconf_names id))))
2316 (if id2
2317 (sysconf_ id2)
2318 (raise KeyError "no sysconf str for " id))))
2319
2320 (defineu getloadavg ()
2321 (let ((f (pointer->procedure long
2322 (dynamic-func "getloadavg"
2323 (dynamic-link))
2324 (list '* int))))
2325 (lambda ()
2326 (let* ((v (make-bytevector (* 3 8)))
2327 (vp (bytevector->pointer v)))
2328 (rm (f vp 3))
2329 (list (bytevector-ieee-double-ref v 0 (native-endianness))
2330 (bytevector-ieee-double-ref v 8 (native-endianness))
2331 (bytevector-ieee-double-ref v 16 (native-endianness)))))))
2332
2333 (define curdir ".")
2334 (define pardir "..")
2335 (define sep "/")
2336 (define extsep ".")
2337 (define altsep None)
2338 (define pathsep ":")
2339 (define linesep "\n")
2340 (define defpath "/usr/bin/")
2341 (define devnull "/dev/null")
2342
2343 (define RTLD_LAZY 1)
2344 (define RTLD_NOW 2)
2345 (define RTLD_GLOBAL #x100)
2346 (define RTLD_LOCAL 0)
2347 (define RTLD_NODELETE #x1000)
2348 (define RTLD_NOLOAD 4)
2349 (define RTLD_DEEPBIND 8)
2350
2351 (define GRND_NONBLOCK 1)
2352 (define GRND_RANDOM 2)
2353
2354 (define* (getrandom_ size #:optional (flags 0))
2355 (define filename (if (> (logand flags GRND_RANDOM) 0)
2356 "/dev/random"
2357 "/dev/urandom"))
2358 (define port (open-file filename "r"))
2359 (if port
2360 (dynamic-wind
2361 (lambda () (values))
2362 (lambda ()
2363 (get-bytevector-n port size))
2364 (lambda () ((@ (guile) close) port)))
2365 '()))
2366
2367
2368 (define (urandom size)
2369 (bytes (getrandom_ size)))
2370
2371 (define (getrandom . l)
2372 (py-list (apply getrandom_ l)))
2373
2374 (define path "posixpath")
2375
2376 (define (_get_exports_list mod)
2377 (let ((p (rawref mod '_export))
2378 (l '()))
2379 (module-for-each
2380 (lambda (k v)
2381 (set! l (cons (symbol->string k) l)))
2382 p)
2383 (py-list l)))
2384
2385 (define-python-class sys ()
2386 (define platform "posix"))