modules/language/python/module/os.scm

   1 (define-module (language python module os)
   2   #:use-module (system foreign)
   3   #:use-module (oop pf-objects)
   4   #:use-module (oop goops)
   5   #:use-module (rnrs bytevectors)
   6   #:use-module (language python for)
   7   #:use-module ((language python module python) #:select (open))
   8   #:use-module (language python try)
   9   #:use-module (language python exceptions)
  10   #:use-module (language python yield)
  11   #:use-module (language python string)
  12   #:use-module (language python bytes)
  13   #:use-module (language python list)
  14   #:export (error name ctermid environ environb chdir fchdir getcwd
  15                   fsencode fdencode fspath PathLike getenv getenvb
  16                   get_exec_path getgid getegid geteuid
  17                   getgroups getgrouplist getlogin getpgid getpgrp getpid
  18                   getppid PRIO_PROCESS PRIO_PRGRP PRIO_USER getpriority
  19                   getresgid getuid initgroups putenv setegid seteuid
  20                   setgid setgroups setpgrp setpgid setpriority setregid
  21                   setresgid setreuid setresuid getsid setsid setuid strerr
  22                   umask  uname  unsetenv
  23
  24                   dopen close closerange device_encoding dup dup2 fchmod fchown
  25                   fdatasync fpathconf fstat fstatvfs fsynch ftruncate isatty
  26                   F_LOCK F_TLOCK F_ULOCK F_TEST lockf
  27                   SEEK_SET SEEK_CUR SEEK_END SEEK_DATA SEEK_HOLE lseek
  28                   open O_RDONLY O_WRONLY O_RDWR O_APPEND O_CREAT O_EXCL
  29                   O_TRUNC O_SYNC O_NDELAY O_NONBLOCK O_NOCTTY O_LARGEFILE
  30                   O_NOTRANS O_DSYNC O_RSYNC O_CLOEXEC O_PATH O_DIRECTORY
  31                   O_NOFOLLOW O_DIRECT O_NOATIME O_ASYNC O_TMPFILE
  32                   openpty pipe pipe2 posix_fallocate
  33                   posix_fadvise POSIX_FADV_NORMAL POSIX_FADV_RANDOM
  34                   POSIX_FADV_SEQUENTIAL POSIX_FADV_WILLNEED
  35                   POSIX_FADV_DONTNEED POSIX_FADV_NOREUSE
  36                   pread pwrite read sendfile set_blocking get_blocking
  37                   set_blocking readv write writev set_inheritable
  38                   get_inheritable
  39                   ))
  40
  41 (define error 'OSError)
  42
  43 (define-syntax-rule (aif it p x y) (let ((it p)) (if it x y)))
  44 (define-syntax-rule (ca code)
  45   (catch #t
  46     (lambda () code)
  47     (lambda x (raise error x))))
  48 (define-syntax-rule (rm code)
  49   (let ((r (ca code)))
  50     (if (< r 0)
  51         (raise error)
  52         (values))))
  53
  54 (define-syntax guile
  55   (syntax-rules ()
  56     ((_ (x ...) code)        (guile (x ...) code code))
  57     ((_ (x ...) code1 code2)
  58      (define code1 (lambda (x ...) (ca ((@ (guile) code2 x ...))))))
  59     ((_ code) (guile code code))
  60     ((_ code1 code2)
  61      (define code1 (lambda x (ca (apply (@ (guile) code2 x))))))))
  62
  63 (define name  "posix")
  64 (guile ctermid)
  65
  66 (define-values (environ environb)
  67   (let ()
  68     (define e (dereference-pointer (dynamic-pointer "environ" (dynamic-link))))
  69     (define (get-envs)
  70       (let lp ((e e))
  71         (let ((*e  (dereference-pointer e)))
  72           (if (null-pointer? *e)
  73               '()
  74               (cons
  75                (pointer->string *e)
  76                (lp (make-pointer (+ (pointer-address e) 8))))))))
  77
  78     (define (getkw)
  79       (let lp ((es (get-envs)))
  80         (if (pair? es)
  81             (let ((x (string-split (car es) #\=)))
  82               (let ((k (car x))
  83                     (v (string-join (cdr x) "=")))
  84                 (cons (cons k v) (lp (cdr es)))))
  85             '())))
  86
  87     (define-python-class Env ()
  88       (define __init__
  89         (lambda (self) (values)))
  90
  91       (define __getitem__
  92         (lambda (self k)
  93           (let ((r ((@ (guile) getenv) (slot-ref (pystring k) 'str))))
  94             (if r r (raise IndexError)))))
  95
  96       (define __setitem__
  97         (lambda (self k v)
  98           (putenv (slot-ref (pystring (+ k "=" v)) 'str))))
  99
 100       (define __delitem__
 101         (lambda (self k)
 102           (putenv (slot-ref (pystring k) 'str))))
 103
 104       (define __iter__
 105         (lambda (self)
 106           ((make-generator ()
 107              (lambda (yield)
 108                (for ((x : (getkw))) ()
 109                     (yield (car x) (cdr x)))))))))
 110
 111     (define-python-class Envb ()
 112       (define __init__
 113         (lambda (self) (values)))
 114
 115       (define __getitem__
 116         (lambda (self k)
 117           (let ((r (bytes ((@ (guile) getenv) (slot-ref (string k) 'str)))))
 118             (if r r (raise IndexError)))))
 119
 120       (define __setitem__
 121         (lambda (self k v)
 122           (putenv (slot-ref (string (+ k "=" v)) 'str))))
 123
 124       (define __delitem__
 125         (lambda (self k)
 126           (putenv (slot-ref (string k) 'str))))
 127
 128       (define __iter__
 129         (lambda (self)
 130           ((make-generator ()
 131              (lambda (yield)
 132                (for ((x : (getkw))) ()
 133                     (yield (car x) (cdr x)))))))))
 134
 135
 136     (values (Env) (Envb))))
 137
 138
 139 (guile (path) chdir)
 140
 141 (define (fchdir fd)
 142   (error "not implemented"))
 143
 144 (guile () getcwd)
 145
 146 (define (fsencode fn)
 147   (error "not implemented"))
 148 (define (fsdecode fn)
 149   (error "not implemented"))
 150
 151 (define-method (fspath (pth <string>      )) pth)
 152 (define-method (fspath (pth <py-string>   )) pth)
 153 (define-method (fspath (pth <py-bytes>    )) pth)
 154 (define-method (fspath (pth <py-bytearray>)) pth)
 155 (define-method (fspath (pth <p>           ))
 156   (aif it (ref pth '__fspath__)
 157        (it)
 158        (next-method)))
 159
 160 (define-python-class PathLike ()
 161   (define __fspath__
 162     (lambda (self) (error "not implemented"))))
 163
 164
 165 (define* (getenv key #:key (default None))
 166   (try
 167    (lambda ()
 168      (pylist-ref environ key))
 169    (#:except IndexError => (lambda x default))))
 170
 171 (define* (getenvb key #:key (default None))
 172   (try
 173    (lambda ()
 174      (pylist-ref environb key))
 175    (#:except IndexError => (lambda x default))))
 176
 177 (define* (get_exec_path #:key (env #f))
 178   (define (f s)
 179     (let ((s (slot-ref (string s) 'str)))
 180       (string-split str ":")))
 181   (if env
 182       (f (pylist-ref env     "PATH"))
 183       (f (pylist-ref environ "PATH"))))
 184
 185 (guile () getgid)
 186 (guile () getegid)
 187 (guile () geteuid)
 188
 189 (define (getgrouplist user group)
 190   (error "not impllemeneted"))
 191
 192 (guile () getgroups)
 193
 194 (guile getlogin)
 195
 196 (define getpgid
 197   (let ((f (pointer->procedure int
 198                                (dynamic-func "getpgid" (dynamic-link))
 199                                (list int))))
 200     (lambda (pid)
 201       (rm (f pid)))))
 202
 203
 204 (guile getpgrp)
 205 (guile getpid)
 206 (guile getppid)
 207
 208 (define PRIO_PROCESS (@ (guile) PRIO_PROCESS))
 209 (define PRIO_PRGRP   (@ (guile) PRIO_PRGRP))
 210 (define PRIO_USER    (@ (guile) PRIO_USER))
 211
 212 (guile getpriority)
 213
 214 (define getresgid
 215   (let* ((f  (pointer->procedure
 216               void
 217               (dynamic-func "getresgid" (dynamic-link))
 218               '(* * *))))
 219
 220     (lambda ()
 221       (let* ((a  (make-bytevector 8))
 222              (ap (bytevector->pointer a))
 223              (b (make-bytevector 8))
 224              (bp (bytevector->pointer b))
 225              (c (make-bytevector 8))
 226              (cp (bytevector->pointer c)))
 227         (rm (f ap bp cp))
 228         (list
 229          (bytevector-u16-ref a 0 (native-endianness))
 230          (bytevector-u16-ref b 0 (native-endianness))
 231          (bytevector-u16-ref c 0 (native-endianness)))))))
 232
 233 (guile getuid)
 234
 235 (define initgroup
 236   (let ((f (pointer->procedure
 237             'int
 238             (dynamic-func "initgroups" (dynamic-link))
 239             '(* int))))
 240
 241     (lambda (user group)
 242       (rm (string->pointer user) group))))
 243
 244 (define (putenv key value)
 245   (pylist-set! environ key value))
 246
 247 (guile setegid)
 248 (guile seteuid)
 249 (guile setgid)
 250
 251 (guile setgroups)
 252 (define setpgrp
 253   (let ((f (pointer->procedure 'int
 254                                (dynamic-func "setpgrp" (dynamic-link))
 255                                '())))
 256     (lambda ()
 257       (rm (f)))))
 258
 259 (guile setpgid)
 260 (guile setpriority)
 261
 262 (define setregid
 263   (let ((f (pointer->procedure 'int
 264                                (dynamic-func "setregid" (dynamic-link))
 265                                '(int int))))
 266     (lambda (a b)
 267       (rm (f a b)))))
 268
 269 (define setresgid
 270   (let ((f (pointer->procedure 'int
 271                                (dynamic-func "setresgid" (dynamic-link))
 272                                '(int int int))))
 273     (lambda (a b c)
 274       (rm (f a b c)))))
 275
 276 (define setreuid
 277   (let ((f (pointer->procedure 'int
 278                                (dynamic-func "setreuid" (dynamic-link))
 279                                '(int int))))
 280     (lambda (a b)
 281       (rm (f a b)))))
 282
 283 (define setresuid
 284   (let ((f (pointer->procedure 'int
 285                                (dynamic-func "setresuid" (dynamic-link))
 286                                '(int int int))))
 287     (lambda (a b c)
 288       (rm (f a b c)))))
 289
 290 (guile getsid)
 291 (guile setsid)
 292 (guile setuid)
 293 (guile strerror)
 294 (guile umask)
 295 (guile uname)
 296 (guile unsetenv)
 297
 298 ;; File descriptor operations
 299 (define fdopen open)
 300
 301 (define close
 302   (lambda (fd)
 303     (ca (close-fd fd))))
 304
 305 (define (closerange fd_low fd_high)
 306   (for ((i : (range low high))) ()
 307        (try:
 308         (lambda () (close i))
 309         (#:except OSError => (lambda (x) (values))))))
 310
 311 (define device_encoding (lambda (fd) (error "not implemented")))
 312
 313 (guile (fd) dup)
 314
 315 (define dup2
 316   (let ((f (pointer->procedure 'int
 317                                (dynamic-func "dup3" (dynamic-link))
 318                                '(int int int))))
 319     (lambda* (fd fd2 #:optional (inheritable? #t))
 320       (if inheritable?
 321           (rm (f fd fd2 O_CLOEXEC))
 322           (ca ((@ (guile) dup2) fd fd2))))))
 323
 324 (guile (fd mode) fchmod)
 325 (guile (fd uid gid) fchown)
 326
 327
 328 (define (fdatasync fd) (error "not implemented"))
 329 (define (fpathconf fd name) (error "not implemented"))
 330
 331 (define (concat a ... stx)
 332   (datum->syntax
 333    stx
 334    (symbol->string
 335     (string-append
 336      a ...
 337      (symbol->string
 338       (syntax->datum stx))))))
 339
 340 (define-syntax statset
 341   (lambda (x)
 342     (syntax-case x ()
 343       ((_ (m ...) self scm)
 344        (begin
 345          (statset m self scm) ...))
 346       ((_ m self scm)
 347        (with-syntax ((mem  (concat "st_" #'m))
 348                      (smem (concat "stat;" #'m)))
 349          #'(set self 'mem (smem scm)))))))
 350
 351 (define-python-class stat_result ()
 352   (define __init__
 353      (lambda (self scm)
 354        (ca
 355         (statset (mode ino dev nlink uid gid size atime mtime ctime)
 356                  self scm)))))
 357 (name-object stat_result)
 358
 359 (define (fstat fd)
 360   (stat_result (stat fd)))
 361
 362 (define (fstatvfs fd) (error "not implemented"))
 363
 364 (guile (fd) fsynch fsync)
 365
 366 (guil (fd len) ftruncate truncate-file)
 367
 368 (guile (fd) isatty isatty?)
 369
 370 (define F_LOCK  1)
 371 (define F_TLOCK 2)
 372 (define F_ULOCK 0)
 373 (define F_TEST  3)
 374 (define lockf
 375   (let ((f (pointer->procedure 'int
 376                                (dynamic-func "lockf" (dynamic-link))
 377                                '(int int long))))
 378     (lambda (fd op len)
 379       (rm (f fd op len)))))
 380
 381
 382
 383 (define SEEK_SET  #x0)
 384 (define SEEK_CUR  #x1)
 385 (define SEEK_END  #x2)
 386 (define SEEK_DATA #x3)
 387 (define SEEK_HOLE #x4)
 388
 389 (define lseek
 390   (let ((f (pointer->procedure 'int
 391                                (dynamic-func "lseek" (dynamic-link))
 392                                '(int long int))))
 393     (lambda (fd pos how)
 394       (rm (f fd pos how)))))
 395
 396 (define open
 397   (let ((f (pointer->procedure 'int
 398                                (dynamic-func "openat" (dynamic-link))
 399                                '(int * int int))))
 400
 401     (lambda* (path flags mode #:optional (dir_fd None))
 402       (if (eq? dir_fd None)
 403           (ca (open-fdes path flags mode))
 404           (rm (f dir_fd (string->pointer path) flags mode))))))
 405
 406
 407 (define-syntax-rule (mko O) (define O (@ (guile) O)))
 408 (mko O_RDONLY)
 409 (mko O_WRONLY)
 410 (mko O_RDWR)
 411 (mko O_APPEND)
 412 (mko O_CREAT)
 413 (mko O_EXCL)
 414 (mko O_TRUNC)
 415
 416 ;;unix
 417 (mko O_SYNC)
 418 (mko O_NDELAY)
 419 (mko O_NONBLOCK)
 420 (mko O_NOCTTY)
 421
 422 ;;
 423 (mko O_LARGEFILE)
 424 (mko O_NOTRANS)
 425
 426 (define O_DSYNC     #o10000)
 427 (define O_RSYNC     O_SYNC)
 428 (define O_CLOEXEC   #o2000000)
 429 (define O_PATH      #o10000000)
 430 (define O_DIRECTORY #o200000)
 431 (define O_NOFOLLOW  #o400000)
 432 (define O_DIRECT    #o40000)
 433 (define O_NOATIME   #o1000000)
 434 (define O_ASYNC     #o20000)
 435 (define O_TMPFILE   (logior #o20000000 O_DIRECTORY))
 436
 437 (define openpty (lambda x (error "not implemented")))
 438
 439 (define pipe
 440   (let ((x (ca (@ (guile) pipe))))
 441     (values (car x) (cdr x))))
 442
 443 (define pipe2
 444   (let ((f (pointer->procedure 'int
 445                                (dynamic-func "pipe2" (dynamic-link))
 446                                '(int * int))))
 447     (lambda (flags)
 448       (let* ((a  (make-bytevector 16))
 449              (ap (bytevector->pointer a)))
 450         (rm (f ap flags))
 451         (values (bytevector-s32-ref a 0)
 452                 (bytevector-s32-ref a 1))))))
 453
 454
 455 (define posix_fallocate
 456   (let ((f (pointer->procedure 'int
 457                                (dynamic-func "posix_fallocate" (dynamic-link))
 458                                '(int long long))))
 459     (lambda (fd off len)
 460       (rm (f fd off len)))))
 461
 462 (define posix_fadvise
 463    (let ((f (pointer->procedure 'int
 464                                (dynamic-func "posix_fadvise" (dynamic-link))
 465                                '(int long long int))))
 466     (lambda (fd off len advice)
 467       (rm (f fd off len advice)))))
 468
 469 (define POSIX_FADV_NORMAL     0)
 470 (define POSIX_FADV_RANDOM     1)
 471 (define POSIX_FADV_SEQUENTIAL 2)
 472 (define POSIX_FADV_WILLNEED   3)
 473 (define POSIX_FADV_DONTNEED   4)
 474 (define POSIX_FADV_NOREUSE    5)
 475
 476 (define pread
 477   (let ((f (pointer->procedure 'int
 478                                (dynamic-func "pread" (dynamic-link))
 479                                '(int * long long))))
 480     (lambda (fd size offset)
 481       (let* ((a  (make-bytevector size))
 482              (ap (bytevector->pointer a)))
 483         (let ((n (rm (f fd ap size offset))))
 484           (if (= n 0)
 485               (make-bytevector 0)
 486               (let ((o (make <bytevector>)))
 487                 (slot-set! o 'n (size))
 488                 (slot-set! o 'size n)
 489                 (slot-set! o 'bv   a)
 490                 o)))))))
 491
 492 (define pwrite
 493   (let ((f (pointer->procedure 'int
 494                                (dynamic-func "pwrite" (dynamic-link))
 495                                '(int * long long))))
 496
 497     (lambda (fd a offset)
 498       (let* ((ap (bytevector->pointer a)))
 499         (rm (f fd ap size offset))))))
 500
 501 (define read
 502   (let ((f (pointer->procedure 'int
 503                                (dynamic-func "read" (dynamic-link))
 504                                '(int * long))))
 505     (lambda (fd size)
 506       (let* ((a  (make-bytevector size))
 507              (ap (bytevector->pointer a)))
 508         (let ((n (rm (f fd ap size))))
 509           (if (= n 0)
 510               (make-bytevector 0)
 511               (let ((o (make <bytevector>)))
 512                 (slot-set! o 'n (size))
 513                 (slot-set! o 'size n)
 514                 (slot-set! o 'bv   a)
 515                 o)))))))
 516
 517 (define (sendfile out in offset count)
 518   (ca
 519    (if (eq? count None)
 520        ((@ (guile) sendfile out in count))
 521        ((@ (guile) sendfile out in count offset)))))
 522
 523 (define F_GETFL 3)
 524 (define fcntl2 (pointer->procedure 'int
 525                                    (dynamic-func "fcntl" (dynamic-link))
 526                                    '(int int)))
 527 (define fcntl3 (pointer->procedure 'int
 528                                    (dynamic-func "fcntl" (dynamic-link))
 529                                    '(int int INT)))
 530
 531 (define (set_blocking fd is-blocking?)
 532   (let ((o (rm (fcntl2 fd F_GETFL))))
 533     (if is-blocking?
 534         (rm (fcntl3 fd F_GETFL (logior o O_NONBLOCK)))
 535         (rm (fcntl3 fd F_GETFL (logand o (lognot O_NONBLOCK)))))))
 536
 537 (define (get_blocking fd)
 538   (if (= (logand O_NONBLOCK (rm (fcntl2 fd F_GETFL))) 0)
 539       #f
 540       #t))
 541
 542 (define (readv fd buffers) (error "not implemented"))
 543
 544 (guile (fd pg) tcsetpgrp)
 545 (guile (fd)    ttyname)
 546
 547 (define write
 548   (let ((f (pointer->procedure 'int
 549                                (dynamic-func "write" (dynamic-link))
 550                                '(int * long))))
 551
 552     (lambda (fd a)
 553       (let* ((ap (bytevector->pointer a)))
 554         (rm (f fd ap size))))))
 555
 556 (define (writev fd buffers) (error "not implemented"))
 557
 558
 559 (define (set_inheritable fd is-inh?)
 560   (let ((o (rm (fcntl2 fd F_GETFL))))
 561     (if is-inh?
 562         (rm (fcntl3 fd F_GETFL (logior o O_CLOEXEC)))
 563         (rm (fcntl3 fd F_GETFL (logand o (lognot O_CLOEXEC)))))))
 564
 565 (define (get_inheritable fd)
 566   (if (= (logand O_CLOEXEC (rm (fcntl2 fd F_GETFL))) 0)
 567       #f
 568       #t))
 569
 570
 571 ;; Files and dir
 572 (define AT_EACCESS          #x200)
 573 (define AT_SYMLINK_NOFOLLOW #x100)
 574
 575 (define F_OK (@ (guile) F_OK))
 576 (define W_OK (@ (guile) W_OK))
 577 (define R_OK (@ (guile) R_OK))
 578 (define X_OK (@ (guile) X_OK))
 579
 580 (define access
 581   (let ((f  (pointer->procedure 'int
 582                                (dynamic-func "access" (dynamic-link))
 583                                '(* int)))
 584         (fa (pointer->procedure 'int
 585                                 (dynamic-func "faccessat" (dynamic-link))
 586                                 '(* int int int))))
 587
 588     (lambda* (path mode #:key
 589                    (dir_fd None)
 590                    (effective_ids #f)
 591                    (follow_symlinks #t))
 592       (if (eq? dir_fd None)
 593           (rm (f  (string->pointer path) mode))
 594           (rm (fa (string->pointer path) mode dir_fd
 595                   (logior (if effective_ids AT_EACCESS 0)
 596                           (if follow_symlinks 0 AT_SYMLINK_NOFOLLOW))))))))
 597
 598
 599
 600 (define chdir
 601   (let ((f (pointer->procedure 'int
 602                                (dynamic-func "access" (dynamic-link))
 603                                '(*))))
 604     (lambda (pth)
 605       (let ((pth (aif it (ref pth '__fspath__)
 606                       (it)
 607                       pth)))
 608         (if (int? pth)
 609             (rm (f pth))
 610             (ca ((@ (guile) chdir) pth)))))))
 611
 612
 613 (define chflags
 614   (lambda x (error "Not implemented")))
 615
 616 (define chmod
 617   (let ((f   (pointer->procedure 'int
 618                                  (dynamic-func "chmod" (dynamic-link))
 619                                  '(* int)))
 620         (ff  (pointer->procedure 'int
 621                                  (dynamic-func "fchmod" (dynamic-link))
 622                                  '(int int)))
 623         (fat (pointer->procedure 'int
 624                                  (dynamic-func "fchmodat" (dynamic-link))
 625                                  '(* int int int))))
 626   (lambda* (path mode #:key (dir_fd None) (follow_symlinks #t))
 627     (if (int? path)
 628         (rm (ff path mode))
 629         (let ((path (aif it (ref path '__fspath__)
 630                          (it)
 631                          path)))
 632           (if (eq? dir_fd None)
 633               (rm (f   (string->pointer path) mode))
 634               (rm (fat (string->pointer path) mode
 635                        dir_fd
 636                        (if follow_symlinks
 637                            0
 638                            AT_SYMLINK_NOFOLLOW)))))))))
 639
 640
 641
 642 (define (path-it path)
 643   (aif it (ref path '__fspath__)
 644        (it)
 645        path))
 646
 647 (define chown
 648   (let ((f   (pointer->procedure 'int
 649                                  (dynamic-func "chown" (dynamic-link))
 650                                  '(* int int)))
 651         (ff  (pointer->procedure 'int
 652                                  (dynamic-func "fchown" (dynamic-link))
 653                                  '(int int int)))
 654         (lf  (pointer->procedure 'int
 655                                  (dynamic-func "lchow" (dynamic-link))
 656                                  '(* int int)))
 657         (fat (pointer->procedure 'int
 658                                  (dynamic-func "fchownat" (dynamic-link))
 659                                  '(* int int int int))))
 660     (lambda* (path uid gid #:key (dir_fd None) (follow_symlinks #t))
 661       (if (int? path)
 662           (rm (ff path uid gid))
 663           (let ((path (path-it path)))
 664             (if (eq? dir_fd None)
 665                 (if follow_symlinks
 666                     (rm (f  (string->pointer path) uid gid))
 667                     (rm (lf (string->pointer path) uid gid)))
 668                 (rm (fat (string->pointer path) uid gid dir_fd
 669                          (if follow_symlinks
 670                              0
 671                              AT_SYMLINK_NOFOLLOW)))))))))
 672
 673 (guile ((x)) chroot)
 674
 675 (define fchdir chdir)
 676
 677 (guile () getcwd)
 678
 679 (define (getcwdb)
 680   (byte (getcwd)))
 681
 682 (define lchflags (lambda x (error "not implemented")))
 683
 684 (define (lchmod path mode)
 685   (chmod path mode #:follow_symlinks #f))
 686
 687 (define (lchown path uid gid)
 688   (chown path uid gid #:follow_symlinks #f))
 689
 690 (define link
 691   (let ((f (pointer->procedure 'int
 692                                  (dynamic-func "linkat" (dynamic-link))
 693                                  '(* * int int int))))
 694     (lambda* (src dst #:key
 695                   (src_dir_fd None)
 696                   (dst_dir_fd None),
 697                   (follow_symlinks #t))
 698       (let ((src (path-it src))
 699             (dst (path-it dst))
 700             (src_dir_fd (if (eq? src_dir_fd None) AT_FDCWD src_dir_fd))
 701             (dst_dir_fd (if (eq? dst_dir_fd None) AT_FDCWD dst_dir_fd)))
 702         (rm (f (string->pointer src)
 703                (string->pointer dst)
 704                src_dir_fd
 705                dst_dir_fd
 706                (if follow_symlinks
 707                    0
 708                    AT_SYMLINK_NOFOLLOW)))))))
 709
 710 (define listdir
 711   (lambda* (#:optional (pth "."))
 712     (let ((pth (if (number? pth)
 713                    (read-link (format #f "/proc/self/fd/~a" pth))
 714                    (path-it pth))))
 715       (let ((o (ca (opendir pth))))
 716         (dynamic-wind
 717           (lambda x #f)
 718           (lambda ()
 719             (let lp ((o ) (l '()))
 720               (let ((w (ca (readdir o))))
 721                 (if (eof-object? w)
 722                     '()
 723                     (cons w (lp o))))))
 724           (lambda x (closedir o)))))))
 725
 726 (define stat
 727   (let ((f (pointer->procedure 'int
 728                                (dynamic-func "fstatat" (dynamic-link))
 729                                '(int * * int)))
 730         (g (pointer->procedure '*
 731                                (dynamic-func "scm_stat2scm_" (dynamic-link))
 732                                '(*))))
 733     (lambda* (path #:key (dir_fd None) (follow_symlinks #t))
 734       (if (number? path)
 735           (stat_result ((@ (guile) stat) path))
 736           (let ((path (get-path path)))
 737             (if (eq? dir_fd None)
 738                 (if follow_symlinks
 739                     (stat_result ((@ (guile) stat) path))
 740                     (stat_result ((@ (guile) lstat) path)))
 741                 (let ((bv  (make-bytevector 80))
 742                       (bvp (bytevector->pointer bv)))
 743                   (rm (f dir_fd
 744                          (string->pointer path)
 745                          bvp
 746                          (if follow_symlinks
 747                              0
 748                              AT_SYMLINK_NOFOLLOW)))
 749                   (stat_result (ca (pointer->scm (g bvp)))))))))))
 750
 751 (define lstat
 752   (lambda* (path #:key (dir_fd None))
 753     (stat path #:dir_fd dir_fd #:follow_symlinks #f)))
 754
 755
 756
 757
 758
 759