statvfs
[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 dopen close closerange device_encoding dup dup2 fchmod fchown
28 fdatasync fpathconf fstat fstatvfs fsynch ftruncate isatty
29 F_LOCK F_TLOCK F_ULOCK F_TEST lockf
30 SEEK_SET SEEK_CUR SEEK_END SEEK_DATA SEEK_HOLE lseek
31 open O_RDONLY O_WRONLY O_RDWR O_APPEND O_CREAT O_EXCL
32 O_TRUNC O_SYNC O_NDELAY O_NONBLOCK O_NOCTTY O_LARGEFILE
33 O_NOTRANS O_DSYNC O_RSYNC O_CLOEXEC O_PATH O_DIRECTORY
34 O_NOFOLLOW O_DIRECT O_NOATIME O_ASYNC O_TMPFILE
35 openpty pipe pipe2 posix_fallocate
36 posix_fadvise POSIX_FADV_NORMAL POSIX_FADV_RANDOM
37 POSIX_FADV_SEQUENTIAL POSIX_FADV_WILLNEED
38 POSIX_FADV_DONTNEED POSIX_FADV_NOREUSE
39 pread pwrite read sendfile set_blocking get_blocking
40 set_blocking readv write writev set_inheritable
41 get_inheritable
42 ))
43
44 (define error 'OSError)
45 (define errno
46 (let ((f (dynamic-pointer "errno" (dynamic-link))))
47 (lambda ()
48 (pointer-address (dereference-pointer f)))))
49
50 (define-syntax-rule (aif it p x y) (let ((it p)) (if it x y)))
51 (define-syntax-rule (ca code)
52 (catch #t
53 (lambda () code)
54 (lambda x (raise error x))))
55 (define-syntax-rule (rm code)
56 (let ((r (ca code)))
57 (if (< r 0)
58 (raise error (errno) ((@ (guile) strerror) (errno)))
59 (values))))
60
61 (define-syntax guile
62 (syntax-rules ()
63 ((_ (x ...) code) (guile (x ...) code code))
64 ((_ (x ...) code1 code2)
65 (define code1 (lambda (x ...) (ca ((@ (guile) code2 x ...))))))
66 ((_ code) (guile code code))
67 ((_ code1 code2)
68 (define code1 (lambda x (ca (apply (@ (guile) code2 x))))))))
69
70 (define name "posix")
71 (guile ctermid)
72
73 (define-values (environ environb)
74 (let ()
75 (define e (dereference-pointer (dynamic-pointer "environ" (dynamic-link))))
76 (define (get-envs)
77 (let lp ((e e))
78 (let ((*e (dereference-pointer e)))
79 (if (null-pointer? *e)
80 '()
81 (cons
82 (pointer->string *e)
83 (lp (make-pointer (+ (pointer-address e) 8))))))))
84
85 (define (getkw)
86 (let lp ((es (get-envs)))
87 (if (pair? es)
88 (let ((x (string-split (car es) #\=)))
89 (let ((k (car x))
90 (v (string-join (cdr x) "=")))
91 (cons (cons k v) (lp (cdr es)))))
92 '())))
93
94 (define-python-class Env ()
95 (define __init__
96 (lambda (self) (values)))
97
98 (define __getitem__
99 (lambda (self k)
100 (let ((r ((@ (guile) getenv) (slot-ref (pystring k) 'str))))
101 (if r r (raise IndexError)))))
102
103 (define __setitem__
104 (lambda (self k v)
105 (putenv (slot-ref (pystring (+ k "=" v)) 'str))))
106
107 (define __delitem__
108 (lambda (self k)
109 (putenv (slot-ref (pystring k) 'str))))
110
111 (define __iter__
112 (lambda (self)
113 ((make-generator ()
114 (lambda (yield)
115 (for ((x : (getkw))) ()
116 (yield (car x) (cdr x)))))))))
117
118 (define-python-class Envb ()
119 (define __init__
120 (lambda (self) (values)))
121
122 (define __getitem__
123 (lambda (self k)
124 (let ((r (bytes ((@ (guile) getenv) (slot-ref (string k) 'str)))))
125 (if r r (raise IndexError)))))
126
127 (define __setitem__
128 (lambda (self k v)
129 (putenv (slot-ref (string (+ k "=" v)) 'str))))
130
131 (define __delitem__
132 (lambda (self k)
133 (putenv (slot-ref (string k) 'str))))
134
135 (define __iter__
136 (lambda (self)
137 ((make-generator ()
138 (lambda (yield)
139 (for ((x : (getkw))) ()
140 (yield (car x) (cdr x)))))))))
141
142
143 (values (Env) (Envb))))
144
145
146 (guile (path) chdir)
147
148 (define (fchdir fd)
149 (error "not implemented"))
150
151 (guile () getcwd)
152
153 (define (fsencode fn)
154 (error "not implemented"))
155 (define (fsdecode fn)
156 (error "not implemented"))
157
158 (define-method (fspath (pth <string> )) pth)
159 (define-method (fspath (pth <py-string> )) pth)
160 (define-method (fspath (pth <py-bytes> )) pth)
161 (define-method (fspath (pth <py-bytearray>)) pth)
162 (define-method (fspath (pth <p> ))
163 (aif it (ref pth '__fspath__)
164 (it)
165 (next-method)))
166
167 (define-python-class PathLike ()
168 (define __fspath__
169 (lambda (self) (error "not implemented"))))
170
171
172 (define* (getenv key #:key (default None))
173 (try
174 (lambda ()
175 (pylist-ref environ key))
176 (#:except IndexError => (lambda x default))))
177
178 (define* (getenvb key #:key (default None))
179 (try
180 (lambda ()
181 (pylist-ref environb key))
182 (#:except IndexError => (lambda x default))))
183
184 (define* (get_exec_path #:key (env #f))
185 (define (f s)
186 (let ((s (slot-ref (string s) 'str)))
187 (string-split str ":")))
188 (if env
189 (f (pylist-ref env "PATH"))
190 (f (pylist-ref environ "PATH"))))
191
192 (guile () getgid)
193 (guile () getegid)
194 (guile () geteuid)
195
196 (define (getgrouplist user group)
197 (error "not impllemeneted"))
198
199 (guile () getgroups)
200
201 (guile getlogin)
202
203 (define getpgid
204 (let ((f (pointer->procedure int
205 (dynamic-func "getpgid" (dynamic-link))
206 (list int))))
207 (lambda (pid)
208 (rm (f pid)))))
209
210
211 (guile getpgrp)
212 (guile getpid)
213 (guile getppid)
214
215 (define PRIO_PROCESS (@ (guile) PRIO_PROCESS))
216 (define PRIO_PRGRP (@ (guile) PRIO_PRGRP))
217 (define PRIO_USER (@ (guile) PRIO_USER))
218
219 (guile getpriority)
220
221 (define getresgid
222 (let* ((f (pointer->procedure
223 void
224 (dynamic-func "getresgid" (dynamic-link))
225 '(* * *))))
226
227 (lambda ()
228 (let* ((a (make-bytevector 8))
229 (ap (bytevector->pointer a))
230 (b (make-bytevector 8))
231 (bp (bytevector->pointer b))
232 (c (make-bytevector 8))
233 (cp (bytevector->pointer c)))
234 (rm (f ap bp cp))
235 (list
236 (bytevector-u16-ref a 0 (native-endianness))
237 (bytevector-u16-ref b 0 (native-endianness))
238 (bytevector-u16-ref c 0 (native-endianness)))))))
239
240 (guile getuid)
241
242 (define initgroup
243 (let ((f (pointer->procedure
244 'int
245 (dynamic-func "initgroups" (dynamic-link))
246 '(* int))))
247
248 (lambda (user group)
249 (rm (string->pointer user) group))))
250
251 (define (putenv key value)
252 (pylist-set! environ key value))
253
254 (guile setegid)
255 (guile seteuid)
256 (guile setgid)
257
258 (guile setgroups)
259 (define setpgrp
260 (let ((f (pointer->procedure 'int
261 (dynamic-func "setpgrp" (dynamic-link))
262 '())))
263 (lambda ()
264 (rm (f)))))
265
266 (guile setpgid)
267 (guile setpriority)
268
269 (define setregid
270 (let ((f (pointer->procedure 'int
271 (dynamic-func "setregid" (dynamic-link))
272 '(int int))))
273 (lambda (a b)
274 (rm (f a b)))))
275
276 (define setresgid
277 (let ((f (pointer->procedure 'int
278 (dynamic-func "setresgid" (dynamic-link))
279 '(int int int))))
280 (lambda (a b c)
281 (rm (f a b c)))))
282
283 (define setreuid
284 (let ((f (pointer->procedure 'int
285 (dynamic-func "setreuid" (dynamic-link))
286 '(int int))))
287 (lambda (a b)
288 (rm (f a b)))))
289
290 (define setresuid
291 (let ((f (pointer->procedure 'int
292 (dynamic-func "setresuid" (dynamic-link))
293 '(int int int))))
294 (lambda (a b c)
295 (rm (f a b c)))))
296
297 (guile getsid)
298 (guile setsid)
299 (guile setuid)
300 (guile strerror)
301 (guile umask)
302 (guile uname)
303 (guile unsetenv)
304
305 ;; File descriptor operations
306 (define fdopen open)
307
308 (define close
309 (lambda (fd)
310 (ca (close-fd fd))))
311
312 (define (closerange fd_low fd_high)
313 (for ((i : (range low high))) ()
314 (try:
315 (lambda () (close i))
316 (#:except OSError => (lambda (x) (values))))))
317
318 (define device_encoding (lambda (fd) (error "not implemented")))
319
320 (guile (fd) dup)
321
322 (define dup2
323 (let ((f (pointer->procedure 'int
324 (dynamic-func "dup3" (dynamic-link))
325 '(int int int))))
326 (lambda* (fd fd2 #:optional (inheritable? #t))
327 (if inheritable?
328 (rm (f fd fd2 O_CLOEXEC))
329 (ca ((@ (guile) dup2) fd fd2))))))
330
331 (guile (fd mode) fchmod)
332 (guile (fd uid gid) fchown)
333
334
335 (define (fdatasync fd) (error "not implemented"))
336 (define (fpathconf fd name) (error "not implemented"))
337
338 (define-syntax-rule (concat a ... stx)
339 (datum->syntax
340 stx
341 (string->symbol
342 (string-append
343 a ...
344 (symbol->string
345 (syntax->datum stx))))))
346
347 (define-syntax statset
348 (lambda (x)
349 (syntax-case x ()
350 ((_ (m ...) self scm)
351 #'(begin (statset 1 m self scm) ...))
352 ((_ 1 (m mm) self scm)
353 (with-syntax ((mem (concat "st_" #'mm))
354 (smem (concat "stat:" #'m)))
355 #'(set self 'mem (smem scm)))))))
356 ((_ 1 m self scm)
357 (statset 1 (m m) self scm))))
358
359 (define-python-class stat_result ()
360 (define __init__
361 (lambda (self scm)
362 (ca
363 (begin
364 (statset (mode ino dev nlink uid gid size atime mtime ctime
365 (atimensec atime_ns)
366 (mtimensec mtime_ns)
367 (ctimensec ctime_ns)
368 blksize blocks perms rdev type)
369 self scm)
370 (if stat-float-times
371 (begin
372 (set self 'atime (* (ref self 'atime) 1.0))
373 (set self 'mtime (* (ref self 'mtime) 1.0))
374 (set self 'ctime (* (ref self 'ctime) 1.0))
375 (set self 'atime_ns (/ (ref self 'atime_ns) 1000000000.0))
376 (set self 'mtime_ns (/ (ref self 'mtime_ns) 1000000000.0))
377 (set self 'ctime_ns (/ (ref self 'ctime_ns) 1000000000.0)))))))))
378
379 (name-object stat_result)
380
381 (define (fstat fd)
382 (stat_result (stat fd)))
383
384 (define (fstatvfs fd) (error "not implemented"))
385
386 (guile (fd) fsynch fsync)
387
388 (guil (fd len) ftruncate truncate-file)
389
390 (guile (fd) isatty isatty?)
391
392 (define F_LOCK 1)
393 (define F_TLOCK 2)
394 (define F_ULOCK 0)
395 (define F_TEST 3)
396 (define lockf
397 (let ((f (pointer->procedure 'int
398 (dynamic-func "lockf" (dynamic-link))
399 '(int int long))))
400 (lambda (fd op len)
401 (rm (f fd op len)))))
402
403
404
405 (define SEEK_SET #x0)
406 (define SEEK_CUR #x1)
407 (define SEEK_END #x2)
408 (define SEEK_DATA #x3)
409 (define SEEK_HOLE #x4)
410
411 (define lseek
412 (let ((f (pointer->procedure 'int
413 (dynamic-func "lseek" (dynamic-link))
414 '(int long int))))
415 (lambda (fd pos how)
416 (rm (f fd pos how)))))
417
418 (define open
419 (let ((f (pointer->procedure 'int
420 (dynamic-func "openat" (dynamic-link))
421 '(int * int int))))
422
423 (lambda* (path flags mode #:optional (dir_fd None))
424 (if (eq? dir_fd None)
425 (ca (open-fdes path flags mode))
426 (rm (f dir_fd (string->pointer path) flags mode))))))
427
428
429 (define-syntax-rule (mko O) (define O (@ (guile) O)))
430 (mko O_RDONLY)
431 (mko O_WRONLY)
432 (mko O_RDWR)
433 (mko O_APPEND)
434 (mko O_CREAT)
435 (mko O_EXCL)
436 (mko O_TRUNC)
437
438 ;;unix
439 (mko O_SYNC)
440 (mko O_NDELAY)
441 (mko O_NONBLOCK)
442 (mko O_NOCTTY)
443
444 ;;
445 (mko O_LARGEFILE)
446 (mko O_NOTRANS)
447
448 (define O_DSYNC #o10000)
449 (define O_RSYNC O_SYNC)
450 (define O_CLOEXEC #o2000000)
451 (define O_PATH #o10000000)
452 (define O_DIRECTORY #o200000)
453 (define O_NOFOLLOW #o400000)
454 (define O_DIRECT #o40000)
455 (define O_NOATIME #o1000000)
456 (define O_ASYNC #o20000)
457 (define O_TMPFILE (logior #o20000000 O_DIRECTORY))
458
459 (define openpty (lambda x (error "not implemented")))
460
461 (define pipe
462 (let ((x (ca (@ (guile) pipe))))
463 (values (car x) (cdr x))))
464
465 (define pipe2
466 (let ((f (pointer->procedure 'int
467 (dynamic-func "pipe2" (dynamic-link))
468 '(int * int))))
469 (lambda (flags)
470 (let* ((a (make-bytevector 16))
471 (ap (bytevector->pointer a)))
472 (rm (f ap flags))
473 (values (bytevector-s32-ref a 0 (native-endianness))
474 (bytevector-s32-ref a 1 (native-endianness)))))))
475
476
477 (define posix_fallocate
478 (let ((f (pointer->procedure 'int
479 (dynamic-func "posix_fallocate" (dynamic-link))
480 '(int long long))))
481 (lambda (fd off len)
482 (rm (f fd off len)))))
483
484 (define posix_fadvise
485 (let ((f (pointer->procedure 'int
486 (dynamic-func "posix_fadvise" (dynamic-link))
487 '(int long long int))))
488 (lambda (fd off len advice)
489 (rm (f fd off len advice)))))
490
491 (define POSIX_FADV_NORMAL 0)
492 (define POSIX_FADV_RANDOM 1)
493 (define POSIX_FADV_SEQUENTIAL 2)
494 (define POSIX_FADV_WILLNEED 3)
495 (define POSIX_FADV_DONTNEED 4)
496 (define POSIX_FADV_NOREUSE 5)
497
498 (define pread
499 (let ((f (pointer->procedure 'int
500 (dynamic-func "pread" (dynamic-link))
501 '(int * long long))))
502 (lambda (fd size offset)
503 (let* ((a (make-bytevector size))
504 (ap (bytevector->pointer a)))
505 (let ((n (rm (f fd ap size offset))))
506 (if (= n 0)
507 (make-bytevector 0)
508 (let ((o (make <bytevector>)))
509 (slot-set! o 'n (size))
510 (slot-set! o 'size n)
511 (slot-set! o 'bv a)
512 o)))))))
513
514 (define pwrite
515 (let ((f (pointer->procedure 'int
516 (dynamic-func "pwrite" (dynamic-link))
517 '(int * long long))))
518
519 (lambda (fd a offset)
520 (let* ((ap (bytevector->pointer a)))
521 (rm (f fd ap size offset))))))
522
523 (define read
524 (let ((f (pointer->procedure 'int
525 (dynamic-func "read" (dynamic-link))
526 '(int * long))))
527 (lambda (fd size)
528 (let* ((a (make-bytevector size))
529 (ap (bytevector->pointer a)))
530 (let ((n (rm (f fd ap size))))
531 (if (= n 0)
532 (make-bytevector 0)
533 (let ((o (make <bytevector>)))
534 (slot-set! o 'n (size))
535 (slot-set! o 'size n)
536 (slot-set! o 'bv a)
537 o)))))))
538
539 (define (sendfile out in offset count)
540 (ca
541 (if (eq? count None)
542 ((@ (guile) sendfile out in count))
543 ((@ (guile) sendfile out in count offset)))))
544
545 (define F_GETFL 3)
546 (define fcntl2 (pointer->procedure 'int
547 (dynamic-func "fcntl" (dynamic-link))
548 '(int int)))
549 (define fcntl3 (pointer->procedure 'int
550 (dynamic-func "fcntl" (dynamic-link))
551 '(int int INT)))
552
553 (define (set_blocking fd is-blocking?)
554 (let ((o (rm (fcntl2 fd F_GETFL))))
555 (if is-blocking?
556 (rm (fcntl3 fd F_GETFL (logior o O_NONBLOCK)))
557 (rm (fcntl3 fd F_GETFL (logand o (lognot O_NONBLOCK)))))))
558
559 (define (get_blocking fd)
560 (if (= (logand O_NONBLOCK (rm (fcntl2 fd F_GETFL))) 0)
561 #f
562 #t))
563
564 (define (readv fd buffers) (error "not implemented"))
565
566 (guile (fd pg) tcsetpgrp)
567 (guile (fd) ttyname)
568
569 (define write
570 (let ((f (pointer->procedure 'int
571 (dynamic-func "write" (dynamic-link))
572 '(int * long))))
573
574 (lambda (fd a)
575 (let* ((ap (bytevector->pointer a)))
576 (rm (f fd ap size))))))
577
578 (define (writev fd buffers) (error "not implemented"))
579
580
581 (define (set_inheritable fd is-inh?)
582 (let ((o (rm (fcntl2 fd F_GETFL))))
583 (if is-inh?
584 (rm (fcntl3 fd F_GETFL (logior o O_CLOEXEC)))
585 (rm (fcntl3 fd F_GETFL (logand o (lognot O_CLOEXEC)))))))
586
587 (define (get_inheritable fd)
588 (if (= (logand O_CLOEXEC (rm (fcntl2 fd F_GETFL))) 0)
589 #f
590 #t))
591
592
593 ;; Files and dir
594 (define AT_EACCESS #x200)
595 (define AT_SYMLINK_NOFOLLOW #x100)
596
597 (define F_OK (@ (guile) F_OK))
598 (define W_OK (@ (guile) W_OK))
599 (define R_OK (@ (guile) R_OK))
600 (define X_OK (@ (guile) X_OK))
601
602 (define access
603 (let ((f (pointer->procedure 'int
604 (dynamic-func "access" (dynamic-link))
605 '(* int)))
606 (fa (pointer->procedure 'int
607 (dynamic-func "faccessat" (dynamic-link))
608 '(* int int int))))
609
610 (lambda* (path mode #:key
611 (dir_fd None)
612 (effective_ids #f)
613 (follow_symlinks #t))
614 (if (eq? dir_fd None)
615 (rm (f (string->pointer path) mode))
616 (rm (fa (string->pointer path) mode dir_fd
617 (logior (if effective_ids AT_EACCESS 0)
618 (if follow_symlinks 0 AT_SYMLINK_NOFOLLOW))))))))
619
620
621
622 (define chdir
623 (let ((f (pointer->procedure 'int
624 (dynamic-func "access" (dynamic-link))
625 '(*))))
626 (lambda (pth)
627 (let ((pth (aif it (ref pth '__fspath__)
628 (it)
629 pth)))
630 (if (int? pth)
631 (rm (f pth))
632 (ca ((@ (guile) chdir) pth)))))))
633
634
635 (define chflags
636 (lambda x (error "Not implemented")))
637
638 (define chmod
639 (let ((f (pointer->procedure 'int
640 (dynamic-func "chmod" (dynamic-link))
641 '(* int)))
642 (ff (pointer->procedure 'int
643 (dynamic-func "fchmod" (dynamic-link))
644 '(int int)))
645 (fat (pointer->procedure 'int
646 (dynamic-func "fchmodat" (dynamic-link))
647 '(* int int int))))
648 (lambda* (path mode #:key (dir_fd None) (follow_symlinks #t))
649 (if (int? path)
650 (rm (ff path mode))
651 (let ((path (aif it (ref path '__fspath__)
652 (it)
653 path)))
654 (if (eq? dir_fd None)
655 (rm (f (string->pointer path) mode))
656 (rm (fat (string->pointer path) mode
657 dir_fd
658 (if follow_symlinks
659 0
660 AT_SYMLINK_NOFOLLOW)))))))))
661
662
663
664 (define (path-it path)
665 (aif it (ref path '__fspath__)
666 (it)
667 path))
668
669 (define chown
670 (let ((f (pointer->procedure 'int
671 (dynamic-func "chown" (dynamic-link))
672 '(* int int)))
673 (ff (pointer->procedure 'int
674 (dynamic-func "fchown" (dynamic-link))
675 '(int int int)))
676 (lf (pointer->procedure 'int
677 (dynamic-func "lchow" (dynamic-link))
678 '(* int int)))
679 (fat (pointer->procedure 'int
680 (dynamic-func "fchownat" (dynamic-link))
681 '(* int int int int))))
682 (lambda* (path uid gid #:key (dir_fd None) (follow_symlinks #t))
683 (if (int? path)
684 (rm (ff path uid gid))
685 (let ((path (path-it path)))
686 (if (eq? dir_fd None)
687 (if follow_symlinks
688 (rm (f (string->pointer path) uid gid))
689 (rm (lf (string->pointer path) uid gid)))
690 (rm (fat (string->pointer path) uid gid dir_fd
691 (if follow_symlinks
692 0
693 AT_SYMLINK_NOFOLLOW)))))))))
694
695 (guile ((x)) chroot)
696
697 (define fchdir chdir)
698
699 (guile () getcwd)
700
701 (define (getcwdb)
702 (byte (getcwd)))
703
704 (define lchflags (lambda x (error "not implemented")))
705
706 (define (lchmod path mode)
707 (chmod path mode #:follow_symlinks #f))
708
709 (define (lchown path uid gid)
710 (chown path uid gid #:follow_symlinks #f))
711
712 (define link
713 (let ((f (pointer->procedure 'int
714 (dynamic-func "linkat" (dynamic-link))
715 '(* * int int int))))
716 (lambda* (src dst #:key
717 (src_dir_fd None)
718 (dst_dir_fd None),
719 (follow_symlinks #t))
720 (let ((src (path-it src))
721 (dst (path-it dst))
722 (src_dir_fd (if (eq? src_dir_fd None) AT_FDCWD src_dir_fd))
723 (dst_dir_fd (if (eq? dst_dir_fd None) AT_FDCWD dst_dir_fd)))
724 (rm (f (string->pointer src)
725 (string->pointer dst)
726 src_dir_fd
727 dst_dir_fd
728 (if follow_symlinks
729 0
730 AT_SYMLINK_NOFOLLOW)))))))
731
732 (define listdir
733 (lambda* (#:optional (pth "."))
734 (let ((pth (if (number? pth)
735 ((@ (guile) read-link) (format #f "/proc/self/fd/~a" pth))
736 (path-it pth))))
737 (let ((o (ca (opendir pth))))
738 (dynamic-wind
739 (lambda x #f)
740 (lambda ()
741 (let lp ((o ) (l '()))
742 (let ((w (ca (readdir o))))
743 (if (eof-object? w)
744 '()
745 (cons w (lp o))))))
746 (lambda x (closedir o)))))))
747
748 (define stat
749 (let ((f (pointer->procedure int
750 (dynamic-func "__fxstatat" (dynamic-link))
751 (list int int '* '* int)))
752 (g (pointer->procedure '*
753 (dynamic-func "scm_stat2scm_" (dynamic-link))
754 '(*))))
755 (lambda* (path #:key (dir_fd None) (follow_symlinks #t))
756 (if (number? path)
757 (stat_result ((@ (guile) stat) path))
758 (let ((path (path-it path)))
759 (if (eq? dir_fd None)
760 (if follow_symlinks
761 (stat_result ((@ (guile) stat) path))
762 (stat_result ((@ (guile) lstat) path)))
763 (let* ((bv (make-bytevector 80))
764 (bvp (bytevector->pointer bv)))
765 (rm (f 1 ;Special linux flag
766 (string->pointer path)
767 bvp
768 (if follow_symlinks
769 0
770 AT_SYMLINK_NOFOLLOW)))
771 (stat_result (ca (pointer->scm (g bvp)))))))))))
772
773 (define lstat
774 (lambda* (path #:key (dir_fd None))
775 (stat path #:dir_fd dir_fd #:follow_symlinks #f)))
776
777 (define mkdir
778 (let ((fat (pointer->procedure int
779 (dynamic-func "mkdirat" (dynamic-link))
780 (list int * int))))
781 (lambda* (path mode #:key (dir_fd None))
782 (rm (fat (if (eq? dir_fd None) AT_FDCWD dir_fd)
783 (string->pointer (path-it path))
784 mode)))))
785
786 (define* (mkdirs name mode #:key (exist_ok #f))
787 (let lp ((pre "") (l (string-split (path-it name) #\/)))
788 (match l
789 (() (values))
790 ((x) (let ((s (string-append pre "/" x)))
791 (catch #t
792 (lambda ()
793 ((@ (guile) stat) s)
794 (if exist_ok
795 (values)
796 (raise error
797 (format #f "dir ~a in mkdirs already exist" s))))
798 (lambda x
799 (mkdir s mode)))))
800 ((x . l)
801 (let ((s (string-append pre "/" x)))
802 (catch #t
803 (lambda ()
804 ((@ (guile) stat) s))
805 (lambda x
806 (mkdir s mode)))
807 (lp s l))))))
808
809 (define mkfifo
810 (let ((fat (pointer->procedure int
811 (dynamic-func "mkfifoat" (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 mknod
819 (let ((fat (pointer->procedure int
820 (dynamic-func "mknodat" (dynamic-link))
821 (list int * int))))
822 (lambda* (path mode #:optional (device 0) #:key (dir_fd None))
823 (rm (fat (if (eq? dir_fd None) AT_FDCWD dir_fd)
824 (string->pointer (path-it path))
825 mode
826 device)))))
827
828 (define major
829 (let ((f (pointer->procedure int
830 (dynamic-func "gnu_dev_major" (dynamic-link))
831 (list int64))))
832 (lambda (device)
833 (ca (f device)))))
834
835 (define minor
836 (let ((f (pointer->procedure int
837 (dynamic-func "gnu_dev_minor" (dynamic-link))
838 (list int64))))
839 (lambda (device)
840 (ca (f device)))))
841
842 (define makedev
843 (let ((f (pointer->procedure int64
844 (dynamic-func "gnu_dev_makedev" (dynamic-link))
845 (list int int))))
846 (lambda (major minor)
847 (ca (f major minor)))))
848
849 (define pathconf_names (dict))
850 (pylist-set! pathconf_names "PC_LINK_MAX" 0)
851 (pylist-set! pathconf_names "PC_MAX_CANON" 1)
852 (pylist-set! pathconf_names "PC_MAX_INPUT" 2)
853 (pylist-set! pathconf_names "PC_NAME_MAX" 3)
854 (pylist-set! pathconf_names "PC_PATH_MAX" 4)
855 (pylist-set! pathconf_names "PC_PIPE_BUF" 5)
856 (pylist-set! pathconf_names "PC_CHOWN_RESTRICTED" 6)
857 (pylist-set! pathconf_names "PC_NO_TRUNC" 7)
858 (pylist-set! pathconf_names "PC_VDISABLE" 8)
859
860 (define-syntax-rule (rmp code)
861 (let ((e (errno))
862 (r (ca code)))
863 (if (>= r 0)
864 r
865 (let ((e2 (errno)))
866 (if (eq? e e2)
867 (error "Bug could not find pathcond name endex")
868 (rm e2))))))
869
870
871 (define pathconf
872 (let ((f (pointer->procedure long
873 (dynamic-func "pathconf" (dynamic-link))
874 (list '* int)))
875 (ff (pointer->procedure long
876 (dynamic-func "fpathconf" (dynamic-link))
877 (list int int))))
878 (lambda (path name)
879 (let ((ni (pylist-ref pathconf_names name)))
880 (if (number? path)
881 (rmp (ff path ni))
882 (let ((path (path-it path)))
883 (rmp (f (string->pointer path) ni))))))))
884
885 (define readlink
886 (let ((fat (pointer->procedure int
887 (dynamic-func "readlinkat" (dynamic-link))
888 (list int * * long))))
889 (lambda* (path #:key (dir_fd None))
890 (let* ((n 10000)
891 (bv (make-bytevector 10000))
892 (bvp (bytevector->pointer bv)))
893 (rm (fat (if (eq? dir_fd None) AT_FDCWD dir_fd)
894 (string->pointer (path-it path))
895 bvp
896 n))
897 (bytevector-u8-set! bv (- n 1) 0)
898 (pointer->string bvp)))))
899
900
901 (define remove
902 (let ((fat (pointer->procedure int
903 (dynamic-func "unlinkat" (dynamic-link))
904 (list int * int))))
905 (lambda* (path #:key (dir_fd None))
906 (rm (fat (if (eq? dir_fd None) AT_FDCWD dir_fd)
907 (string->pointer (path-it path))
908 0)))))
909
910 (define unlink remove)
911
912 (define rmdir
913 (lambda (path #:key (dir_fd None))
914 (let ((path (path-it path)))
915 (if (eq? dir_fd None)
916 ((@ (guile) rmdir) path)
917 (let* ((fd (open path O_DIRECTORY #:dir_fd dir_fd))
918 (path ((@ (guile) read-link) '
919 (format #f "/proc/self/fd/~a" fd))))
920 (close fd)
921 ((@ (guile) rmdir) path))))))
922
923 (define (removedirs name)
924 (let ((name (path-it name)))
925 (let lp ((l (reverse (string-split name #\/))))
926 (if (pair? l)
927 (let ((path (string-join (reverse l) "/")))
928 (catch #t
929 (lambda () (rmdir path))
930 (lambda x (values)))
931 (lp (cdr l)))))))
932
933 (define rename
934 (let ((fat (pointer->procedure int
935 (dynamic-func "renameat" (dynamic-link))
936 (list int * int *))))
937 (lambda* (src dst #:key (src_dir_fd None) (dst_dir_fd None))
938 (rm (fat (if (eq? src_dir_fd None) AT_FDCWD src_dir_fd)
939 (string->pointer (path-it src))
940 (if (eq? dst_dir_fd None) AT_FDCWD dst_dir_fd)
941 (string->pointer (path-it src)))))))
942
943
944 (define replace rename)
945
946 (define (renames old new)
947 (let ((old (path-it old))
948 (new (path-it new)))
949 (let lp ((l (string-split new #\/)) (d '()))
950 (match l
951 (() #t)
952 ((x) #t)
953 (("" . l)
954 (lp l (cons "" d)))
955 ((x . l)
956 (if (pair? d)
957 (let ((path (string-join (reverse d) "/")))
958 (catch #t
959 (lambda () (stat path))
960 (lambda x (mkdir path)))
961 (lp l (cons x d)))
962 (lp l (cons x d))))))
963 (rename old new)
964 (let ((l (split old #\/)))
965 (if (> (length l) 1)
966 (if (= (length l) 2)
967 (removedirs (string-concat (car l) "/"))
968 (removedirs (string-join (reverse (cdr (reverse l))) "/")))))
969 (values)))
970
971
972
973 (define-python-class DirEntry ()
974 (define __init__
975 (lambda (self path stat errno)
976 (set self 'name (basename path))
977 (set self 'path path)
978 (set self '__errno errno)
979 (set self '__stat stat)))
980
981 (define inode
982 (lambda (self)
983 (let ((stat (ref self '__stat)))
984 (if stat
985 (stat:ino stat)
986 (raise error (ref self '__errno))))))
987
988 (define is_dir
989 (lambda* (self #:key (follow_symlinks #t))
990 (let ((s (stat (ref self 'path) #:follow_symlink follow_symlink)))
991 ((@ (stat) is-dir?) (ref s '_st_mode)))))
992
993 (define is_file
994 (lambda* (self #:key (follow_symlinks #t))
995 (let ((s (stat (ref self 'path) #:follow_symlink follow_symlink)))
996 ((@ (stat) is-reg?) (ref s '_st_mode)))))
997
998 (define is_symlink
999 (lambda (self)
1000 (let ((s (stat (ref self 'path))))
1001 ((@ (stat) is-lnk?) (ref s '_st_mode)))))
1002
1003 (define stat
1004 (lambda* (self #:key (follow_symlinks #t))
1005 (stat (ref self 'path) #:follow_symlinks follow_symlinks))))
1006
1007 (define* (scandir #:optional (path "."))
1008 (make-generator ()
1009 (lambda (yield)
1010 (file-system-fold
1011 (lambda x #t)
1012 (lambda (path stat errno r)
1013 (yield (DirEntry path stat errno)))
1014 (lambda (path stat res)
1015 (yield (DirEntry path stat 0)))
1016 (lambda (path stat res)
1017 (values))
1018 (lambda (path stat res)
1019 (values))
1020 (lambda (path stat errno res)
1021 (values))
1022 #f
1023 (path-it path)))))
1024
1025 (define stat-float-times #t)
1026 (define (stat_float_times newvalue)
1027 (set! stat-float-times newvalue))
1028
1029 (define ST_RDONLY 1)
1030 (define ST_NOSUID 2)
1031 (define ST_NODEV 4)
1032 (define ST_NOEXEC 8)
1033 (define ST_SYNCHRONOUS 16)
1034 (define ST_MANDLOCK 64)
1035 (define ST_WRITE 128)
1036 (define ST_APPEND 256)
1037 (define ST_IMMUTABLE 512)
1038 (define ST_NOATIME 1024)
1039 (define ST_NODIRATIME 2048)
1040 (define ST_RELATIME 4096)
1041
1042 (define-python-class StatVFS ()
1043 (define __init__
1044 (lambda (self a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11)
1045 (map
1046 (lambda (x y) (set self x y))
1047 '(f_bsize
1048 f_frsize
1049 f_blocks
1050 f_bfree
1051 f_bavail
1052 f_files
1053 f_ffree
1054 f_favail
1055 f_fsid
1056 f_flag
1057 f_namemax)
1058 (list a1 a2 a3 a4 a5 a6 a7 a8 a9 a10)))))
1059
1060 (define statvfs
1061 (let ((f (pointer->procedure int
1062 (dynamic-func "statvfs" (dynamic-link))
1063 (list * *)))
1064 (ff (pointer->procedure int
1065 (dynamic-func "fstatvfs" (dynamic-link))
1066 (list int *)))))
1067 (lambda (path)
1068 (let* ((bv (make-bytevector 11*8))
1069 (bvp (bytevector->pointer bv)))
1070 (rm (if (number? path)
1071 (ff path bvp)
1072 (f (string->pointer (path-it path)) bvp)))
1073
1074 (StatVFS
1075 (bytevector-u64-ref bv 0 (native-endianness))
1076 (bytevector-u64-ref bv 1 (native-endianness))
1077 (bytevector-u64-ref bv 2 (native-endianness))
1078 (bytevector-u64-ref bv 3 (native-endianness))
1079 (bytevector-u64-ref bv 4 (native-endianness))
1080 (bytevector-u64-ref bv 5 (native-endianness))
1081 (bytevector-u64-ref bv 6 (native-endianness))
1082 (bytevector-u64-ref bv 8 (native-endianness))
1083 (bytevector-u64-ref bv 9 (native-endianness))
1084 (bytevector-u64-ref bv 10 (native-endianness)))))))