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