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