193bf4bb5d53305481195b58fbf26489a98f10c6
[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 (statset (mode ino dev nlink uid gid size atime mtime ctime
364 (atimensec atime_ns)
365 (mtimensec mtime_ns)
366 (ctimensec ctime_ns)
367 blksize blocks perms rdev type)
368 self scm)))))
369 (name-object stat_result)
370
371 (define (fstat fd)
372 (stat_result (stat fd)))
373
374 (define (fstatvfs fd) (error "not implemented"))
375
376 (guile (fd) fsynch fsync)
377
378 (guil (fd len) ftruncate truncate-file)
379
380 (guile (fd) isatty isatty?)
381
382 (define F_LOCK 1)
383 (define F_TLOCK 2)
384 (define F_ULOCK 0)
385 (define F_TEST 3)
386 (define lockf
387 (let ((f (pointer->procedure 'int
388 (dynamic-func "lockf" (dynamic-link))
389 '(int int long))))
390 (lambda (fd op len)
391 (rm (f fd op len)))))
392
393
394
395 (define SEEK_SET #x0)
396 (define SEEK_CUR #x1)
397 (define SEEK_END #x2)
398 (define SEEK_DATA #x3)
399 (define SEEK_HOLE #x4)
400
401 (define lseek
402 (let ((f (pointer->procedure 'int
403 (dynamic-func "lseek" (dynamic-link))
404 '(int long int))))
405 (lambda (fd pos how)
406 (rm (f fd pos how)))))
407
408 (define open
409 (let ((f (pointer->procedure 'int
410 (dynamic-func "openat" (dynamic-link))
411 '(int * int int))))
412
413 (lambda* (path flags mode #:optional (dir_fd None))
414 (if (eq? dir_fd None)
415 (ca (open-fdes path flags mode))
416 (rm (f dir_fd (string->pointer path) flags mode))))))
417
418
419 (define-syntax-rule (mko O) (define O (@ (guile) O)))
420 (mko O_RDONLY)
421 (mko O_WRONLY)
422 (mko O_RDWR)
423 (mko O_APPEND)
424 (mko O_CREAT)
425 (mko O_EXCL)
426 (mko O_TRUNC)
427
428 ;;unix
429 (mko O_SYNC)
430 (mko O_NDELAY)
431 (mko O_NONBLOCK)
432 (mko O_NOCTTY)
433
434 ;;
435 (mko O_LARGEFILE)
436 (mko O_NOTRANS)
437
438 (define O_DSYNC #o10000)
439 (define O_RSYNC O_SYNC)
440 (define O_CLOEXEC #o2000000)
441 (define O_PATH #o10000000)
442 (define O_DIRECTORY #o200000)
443 (define O_NOFOLLOW #o400000)
444 (define O_DIRECT #o40000)
445 (define O_NOATIME #o1000000)
446 (define O_ASYNC #o20000)
447 (define O_TMPFILE (logior #o20000000 O_DIRECTORY))
448
449 (define openpty (lambda x (error "not implemented")))
450
451 (define pipe
452 (let ((x (ca (@ (guile) pipe))))
453 (values (car x) (cdr x))))
454
455 (define pipe2
456 (let ((f (pointer->procedure 'int
457 (dynamic-func "pipe2" (dynamic-link))
458 '(int * int))))
459 (lambda (flags)
460 (let* ((a (make-bytevector 16))
461 (ap (bytevector->pointer a)))
462 (rm (f ap flags))
463 (values (bytevector-s32-ref a 0)
464 (bytevector-s32-ref a 1))))))
465
466
467 (define posix_fallocate
468 (let ((f (pointer->procedure 'int
469 (dynamic-func "posix_fallocate" (dynamic-link))
470 '(int long long))))
471 (lambda (fd off len)
472 (rm (f fd off len)))))
473
474 (define posix_fadvise
475 (let ((f (pointer->procedure 'int
476 (dynamic-func "posix_fadvise" (dynamic-link))
477 '(int long long int))))
478 (lambda (fd off len advice)
479 (rm (f fd off len advice)))))
480
481 (define POSIX_FADV_NORMAL 0)
482 (define POSIX_FADV_RANDOM 1)
483 (define POSIX_FADV_SEQUENTIAL 2)
484 (define POSIX_FADV_WILLNEED 3)
485 (define POSIX_FADV_DONTNEED 4)
486 (define POSIX_FADV_NOREUSE 5)
487
488 (define pread
489 (let ((f (pointer->procedure 'int
490 (dynamic-func "pread" (dynamic-link))
491 '(int * long long))))
492 (lambda (fd size offset)
493 (let* ((a (make-bytevector size))
494 (ap (bytevector->pointer a)))
495 (let ((n (rm (f fd ap size offset))))
496 (if (= n 0)
497 (make-bytevector 0)
498 (let ((o (make <bytevector>)))
499 (slot-set! o 'n (size))
500 (slot-set! o 'size n)
501 (slot-set! o 'bv a)
502 o)))))))
503
504 (define pwrite
505 (let ((f (pointer->procedure 'int
506 (dynamic-func "pwrite" (dynamic-link))
507 '(int * long long))))
508
509 (lambda (fd a offset)
510 (let* ((ap (bytevector->pointer a)))
511 (rm (f fd ap size offset))))))
512
513 (define read
514 (let ((f (pointer->procedure 'int
515 (dynamic-func "read" (dynamic-link))
516 '(int * long))))
517 (lambda (fd size)
518 (let* ((a (make-bytevector size))
519 (ap (bytevector->pointer a)))
520 (let ((n (rm (f fd ap size))))
521 (if (= n 0)
522 (make-bytevector 0)
523 (let ((o (make <bytevector>)))
524 (slot-set! o 'n (size))
525 (slot-set! o 'size n)
526 (slot-set! o 'bv a)
527 o)))))))
528
529 (define (sendfile out in offset count)
530 (ca
531 (if (eq? count None)
532 ((@ (guile) sendfile out in count))
533 ((@ (guile) sendfile out in count offset)))))
534
535 (define F_GETFL 3)
536 (define fcntl2 (pointer->procedure 'int
537 (dynamic-func "fcntl" (dynamic-link))
538 '(int int)))
539 (define fcntl3 (pointer->procedure 'int
540 (dynamic-func "fcntl" (dynamic-link))
541 '(int int INT)))
542
543 (define (set_blocking fd is-blocking?)
544 (let ((o (rm (fcntl2 fd F_GETFL))))
545 (if is-blocking?
546 (rm (fcntl3 fd F_GETFL (logior o O_NONBLOCK)))
547 (rm (fcntl3 fd F_GETFL (logand o (lognot O_NONBLOCK)))))))
548
549 (define (get_blocking fd)
550 (if (= (logand O_NONBLOCK (rm (fcntl2 fd F_GETFL))) 0)
551 #f
552 #t))
553
554 (define (readv fd buffers) (error "not implemented"))
555
556 (guile (fd pg) tcsetpgrp)
557 (guile (fd) ttyname)
558
559 (define write
560 (let ((f (pointer->procedure 'int
561 (dynamic-func "write" (dynamic-link))
562 '(int * long))))
563
564 (lambda (fd a)
565 (let* ((ap (bytevector->pointer a)))
566 (rm (f fd ap size))))))
567
568 (define (writev fd buffers) (error "not implemented"))
569
570
571 (define (set_inheritable fd is-inh?)
572 (let ((o (rm (fcntl2 fd F_GETFL))))
573 (if is-inh?
574 (rm (fcntl3 fd F_GETFL (logior o O_CLOEXEC)))
575 (rm (fcntl3 fd F_GETFL (logand o (lognot O_CLOEXEC)))))))
576
577 (define (get_inheritable fd)
578 (if (= (logand O_CLOEXEC (rm (fcntl2 fd F_GETFL))) 0)
579 #f
580 #t))
581
582
583 ;; Files and dir
584 (define AT_EACCESS #x200)
585 (define AT_SYMLINK_NOFOLLOW #x100)
586
587 (define F_OK (@ (guile) F_OK))
588 (define W_OK (@ (guile) W_OK))
589 (define R_OK (@ (guile) R_OK))
590 (define X_OK (@ (guile) X_OK))
591
592 (define access
593 (let ((f (pointer->procedure 'int
594 (dynamic-func "access" (dynamic-link))
595 '(* int)))
596 (fa (pointer->procedure 'int
597 (dynamic-func "faccessat" (dynamic-link))
598 '(* int int int))))
599
600 (lambda* (path mode #:key
601 (dir_fd None)
602 (effective_ids #f)
603 (follow_symlinks #t))
604 (if (eq? dir_fd None)
605 (rm (f (string->pointer path) mode))
606 (rm (fa (string->pointer path) mode dir_fd
607 (logior (if effective_ids AT_EACCESS 0)
608 (if follow_symlinks 0 AT_SYMLINK_NOFOLLOW))))))))
609
610
611
612 (define chdir
613 (let ((f (pointer->procedure 'int
614 (dynamic-func "access" (dynamic-link))
615 '(*))))
616 (lambda (pth)
617 (let ((pth (aif it (ref pth '__fspath__)
618 (it)
619 pth)))
620 (if (int? pth)
621 (rm (f pth))
622 (ca ((@ (guile) chdir) pth)))))))
623
624
625 (define chflags
626 (lambda x (error "Not implemented")))
627
628 (define chmod
629 (let ((f (pointer->procedure 'int
630 (dynamic-func "chmod" (dynamic-link))
631 '(* int)))
632 (ff (pointer->procedure 'int
633 (dynamic-func "fchmod" (dynamic-link))
634 '(int int)))
635 (fat (pointer->procedure 'int
636 (dynamic-func "fchmodat" (dynamic-link))
637 '(* int int int))))
638 (lambda* (path mode #:key (dir_fd None) (follow_symlinks #t))
639 (if (int? path)
640 (rm (ff path mode))
641 (let ((path (aif it (ref path '__fspath__)
642 (it)
643 path)))
644 (if (eq? dir_fd None)
645 (rm (f (string->pointer path) mode))
646 (rm (fat (string->pointer path) mode
647 dir_fd
648 (if follow_symlinks
649 0
650 AT_SYMLINK_NOFOLLOW)))))))))
651
652
653
654 (define (path-it path)
655 (aif it (ref path '__fspath__)
656 (it)
657 path))
658
659 (define chown
660 (let ((f (pointer->procedure 'int
661 (dynamic-func "chown" (dynamic-link))
662 '(* int int)))
663 (ff (pointer->procedure 'int
664 (dynamic-func "fchown" (dynamic-link))
665 '(int int int)))
666 (lf (pointer->procedure 'int
667 (dynamic-func "lchow" (dynamic-link))
668 '(* int int)))
669 (fat (pointer->procedure 'int
670 (dynamic-func "fchownat" (dynamic-link))
671 '(* int int int int))))
672 (lambda* (path uid gid #:key (dir_fd None) (follow_symlinks #t))
673 (if (int? path)
674 (rm (ff path uid gid))
675 (let ((path (path-it path)))
676 (if (eq? dir_fd None)
677 (if follow_symlinks
678 (rm (f (string->pointer path) uid gid))
679 (rm (lf (string->pointer path) uid gid)))
680 (rm (fat (string->pointer path) uid gid dir_fd
681 (if follow_symlinks
682 0
683 AT_SYMLINK_NOFOLLOW)))))))))
684
685 (guile ((x)) chroot)
686
687 (define fchdir chdir)
688
689 (guile () getcwd)
690
691 (define (getcwdb)
692 (byte (getcwd)))
693
694 (define lchflags (lambda x (error "not implemented")))
695
696 (define (lchmod path mode)
697 (chmod path mode #:follow_symlinks #f))
698
699 (define (lchown path uid gid)
700 (chown path uid gid #:follow_symlinks #f))
701
702 (define link
703 (let ((f (pointer->procedure 'int
704 (dynamic-func "linkat" (dynamic-link))
705 '(* * int int int))))
706 (lambda* (src dst #:key
707 (src_dir_fd None)
708 (dst_dir_fd None),
709 (follow_symlinks #t))
710 (let ((src (path-it src))
711 (dst (path-it dst))
712 (src_dir_fd (if (eq? src_dir_fd None) AT_FDCWD src_dir_fd))
713 (dst_dir_fd (if (eq? dst_dir_fd None) AT_FDCWD dst_dir_fd)))
714 (rm (f (string->pointer src)
715 (string->pointer dst)
716 src_dir_fd
717 dst_dir_fd
718 (if follow_symlinks
719 0
720 AT_SYMLINK_NOFOLLOW)))))))
721
722 (define listdir
723 (lambda* (#:optional (pth "."))
724 (let ((pth (if (number? pth)
725 ((@ (guile) read-link) (format #f "/proc/self/fd/~a" pth))
726 (path-it pth))))
727 (let ((o (ca (opendir pth))))
728 (dynamic-wind
729 (lambda x #f)
730 (lambda ()
731 (let lp ((o ) (l '()))
732 (let ((w (ca (readdir o))))
733 (if (eof-object? w)
734 '()
735 (cons w (lp o))))))
736 (lambda x (closedir o)))))))
737
738 (define stat
739 (let ((f (pointer->procedure int
740 (dynamic-func "__fxstatat" (dynamic-link))
741 (list int int '* '* int)))
742 (g (pointer->procedure '*
743 (dynamic-func "scm_stat2scm_" (dynamic-link))
744 '(*))))
745 (lambda* (path #:key (dir_fd None) (follow_symlinks #t))
746 (if (number? path)
747 (stat_result ((@ (guile) stat) path))
748 (let ((path (path-it path)))
749 (if (eq? dir_fd None)
750 (if follow_symlinks
751 (stat_result ((@ (guile) stat) path))
752 (stat_result ((@ (guile) lstat) path)))
753 (let* ((bv (make-bytevector 80))
754 (bvp (bytevector->pointer bv)))
755 (rm (f 1 ;Special linux flag
756 (string->pointer path)
757 bvp
758 (if follow_symlinks
759 0
760 AT_SYMLINK_NOFOLLOW)))
761 (stat_result (ca (pointer->scm (g bvp)))))))))))
762
763 (define lstat
764 (lambda* (path #:key (dir_fd None))
765 (stat path #:dir_fd dir_fd #:follow_symlinks #f)))
766
767 (define mkdir
768 (let ((fat (pointer->procedure int
769 (dynamic-func "mkdirat" (dynamic-link))
770 (list int * int))))
771 (lambda* (path mode #:key (dir_fd None))
772 (rm (fat (if (eq? dir_fd None) AT_FDCWD dir_fd)
773 (string->pointer (path-it path))
774 mode)))))
775
776 (define* (mkdirs name mode #:key (exist_ok #f))
777 (let lp ((pre "") (l (string-split (path-it name) #\/)))
778 (match l
779 (() (values))
780 ((x) (let ((s (string-append pre "/" x)))
781 (catch #t
782 (lambda ()
783 ((@ (guile) stat) s)
784 (if exist_ok
785 (values)
786 (raise error
787 (format #f "dir ~a in mkdirs already exist" s))))
788 (lambda x
789 (mkdir s mode)))))
790 ((x . l)
791 (let ((s (string-append pre "/" x)))
792 (catch #t
793 (lambda ()
794 ((@ (guile) stat) s))
795 (lambda x
796 (mkdir s mode)))
797 (lp s l))))))
798
799 (define mkfifo
800 (let ((fat (pointer->procedure int
801 (dynamic-func "mkfifoat" (dynamic-link))
802 (list int * int))))
803 (lambda* (path mode #:key (dir_fd None))
804 (rm (fat (if (eq? dir_fd None) AT_FDCWD dir_fd)
805 (string->pointer (path-it path))
806 mode)))))
807
808 (define mknod
809 (let ((fat (pointer->procedure int
810 (dynamic-func "mknodat" (dynamic-link))
811 (list int * int))))
812 (lambda* (path mode #:optional (device 0) #:key (dir_fd None))
813 (rm (fat (if (eq? dir_fd None) AT_FDCWD dir_fd)
814 (string->pointer (path-it path))
815 mode
816 device)))))
817
818 (define major
819 (let ((f (pointer->procedure int
820 (dynamic-func "gnu_dev_major" (dynamic-link))
821 (list int64))))
822 (lambda (device)
823 (ca (f device)))))
824
825 (define minor
826 (let ((f (pointer->procedure int
827 (dynamic-func "gnu_dev_minor" (dynamic-link))
828 (list int64))))
829 (lambda (device)
830 (ca (f device)))))
831
832 (define makedev
833 (let ((f (pointer->procedure int64
834 (dynamic-func "gnu_dev_makedev" (dynamic-link))
835 (list int int))))
836 (lambda (major minor)
837 (ca (f major minor)))))
838
839 (define pathconf_names (dict))
840 (pylist-set! pathconf_names "PC_LINK_MAX" 0)
841 (pylist-set! pathconf_names "PC_MAX_CANON" 1)
842 (pylist-set! pathconf_names "PC_MAX_INPUT" 2)
843 (pylist-set! pathconf_names "PC_NAME_MAX" 3)
844 (pylist-set! pathconf_names "PC_PATH_MAX" 4)
845 (pylist-set! pathconf_names "PC_PIPE_BUF" 5)
846 (pylist-set! pathconf_names "PC_CHOWN_RESTRICTED" 6)
847 (pylist-set! pathconf_names "PC_NO_TRUNC" 7)
848 (pylist-set! pathconf_names "PC_VDISABLE" 8)
849
850 (define-syntax-rule (rmp code)
851 (let ((e (errno))
852 (r (ca code)))
853 (if (>= r 0)
854 r
855 (let ((e2 (errno)))
856 (if (eq? e e2)
857 (error "Bug could not find pathcond name endex")
858 (rm e2))))))
859
860
861 (define pathconf
862 (let ((f (pointer->procedure long
863 (dynamic-func "pathconf" (dynamic-link))
864 (list '* int)))
865 (ff (pointer->procedure long
866 (dynamic-func "fpathconf" (dynamic-link))
867 (list int int))))
868 (lambda (path name)
869 (let ((ni (pylist-ref pathconf_names name)))
870 (if (number? path)
871 (rmp (ff path ni))
872 (let ((path (path-it path)))
873 (rmp (f (string->pointer path) ni))))))))
874
875 (define readlink
876 (let ((fat (pointer->procedure int
877 (dynamic-func "readlinkat" (dynamic-link))
878 (list int * * long))))
879 (lambda* (path #:key (dir_fd None))
880 (let* ((n 10000)
881 (bv (make-bytevector 10000))
882 (bvp (bytevector->pointer bv)))
883 (rm (fat (if (eq? dir_fd None) AT_FDCWD dir_fd)
884 (string->pointer (path-it path))
885 bvp
886 n))
887 (bytevector-u8-set! bv (- n 1) 0)
888 (pointer->string bvp)))))
889
890
891 (define remove
892 (let ((fat (pointer->procedure int
893 (dynamic-func "unlinkat" (dynamic-link))
894 (list int * int))))
895 (lambda* (path #:key (dir_fd None))
896 (rm (fat (if (eq? dir_fd None) AT_FDCWD dir_fd)
897 (string->pointer (path-it path))
898 0)))))
899
900 (define unlink remove)
901
902 (define rmdir
903 (lambda (path #:key (dir_fd None))
904 (let ((path (path-it path)))
905 (if (eq? dir_fd None)
906 ((@ (guile) rmdir) path)
907 (let* ((fd (open path O_DIRECTORY #:dir_fd dir_fd))
908 (path ((@ (guile) read-link) '
909 (format #f "/proc/self/fd/~a" fd))))
910 (close fd)
911 ((@ (guile) rmdir) path))))))
912
913 (define (removedirs name)
914 (let ((name (path-it name)))
915 (let lp ((l (reverse (string-split name #\/))))
916 (if (pair? l)
917 (let ((path (string-join (reverse l) "/")))
918 (catch #t
919 (lambda () (rmdir path))
920 (lambda x (values)))
921 (lp (cdr l)))))))
922
923 (define rename
924 (let ((fat (pointer->procedure int
925 (dynamic-func "renameat" (dynamic-link))
926 (list int * int *))))
927 (lambda* (src dst #:key (src_dir_fd None) (dst_dir_fd None))
928 (rm (fat (if (eq? src_dir_fd None) AT_FDCWD src_dir_fd)
929 (string->pointer (path-it src))
930 (if (eq? dst_dir_fd None) AT_FDCWD dst_dir_fd)
931 (string->pointer (path-it src)))))))
932
933
934 (define replace rename)
935
936 (define (renames old new)
937 (let ((old (path-it old))
938 (new (path-it new)))
939 (let lp ((l (string-split new #\/)) (d '()))
940 (match l
941 (() #t)
942 ((x) #t)
943 (("" . l)
944 (lp l (cons "" d)))
945 ((x . l)
946 (if (pair? d)
947 (let ((path (string-join (reverse d) "/")))
948 (catch #t
949 (lambda () (stat path))
950 (lambda x (mkdir path)))
951 (lp l (cons x d)))
952 (lp l (cons x d))))))
953 (rename old new)
954 (let ((l (split old #\/)))
955 (if (> (length l) 1)
956 (if (= (length l) 2)
957 (removedirs (string-concat (car l) "/"))
958 (removedirs (string-join (reverse (cdr (reverse l))) "/")))))
959 (values)))
960
961
962
963 (define-python-class DirEntry ()
964 (define __init__
965 (lambda (self path stat errno)
966 (set self 'name (basename path))
967 (set self 'path path)
968 (set self '__errno errno)
969 (set self '__stat stat)))
970
971 (define inode
972 (lambda (self)
973 (let ((stat (ref self '__stat)))
974 (if stat
975 (stat:ino stat)
976 (raise error (ref self '__errno))))))
977
978 (define is_dir
979 (lambda* (self #:key (follow_symlinks #t))
980 (let ((s (stat (ref self 'path) #:follow_symlink follow_symlink)))
981 ((@ (stat) is-dir?) (ref s '_st_mode)))))
982
983 (define is_file
984 (lambda* (self #:key (follow_symlinks #t))
985 (let ((s (stat (ref self 'path) #:follow_symlink follow_symlink)))
986 ((@ (stat) is-reg?) (ref s '_st_mode)))))
987
988 (define is_symlink
989 (lambda (self)
990 (let ((s (stat (ref self 'path))))
991 ((@ (stat) is-lnk?) (ref s '_st_mode)))))
992
993 (define stat
994 (lambda* (self #:key (follow_symlinks #t))
995 (stat (ref self 'path) #:follow_symlinks follow_symlinks))))
996
997 (define* (scandir #:optional (path "."))
998 (make-generator ()
999 (lambda (yield)
1000 (file-system-fold
1001 (lambda x #t)
1002 (lambda (path stat errno r)
1003 (yield (DirEntry path stat errno)))
1004 (lambda (path stat res)
1005 (yield (DirEntry path stat 0)))
1006 (lambda (path stat res)
1007 (values))
1008 (lambda (path stat res)
1009 (values))
1010 (lambda (path stat errno res)
1011 (values))
1012 #f
1013 (path-it path)))))
1014
1015
1016
1017
1018
1019
1020