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