guix/build/syscalls.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2015 David Thompson <davet@gnu.org>
   4 ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
   5 ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
   6 ;;;
   7 ;;; This file is part of GNU Guix.
   8 ;;;
   9 ;;; GNU Guix is free software; you can redistribute it and/or modify it
  10 ;;; under the terms of the GNU General Public License as published by
  11 ;;; the Free Software Foundation; either version 3 of the License, or (at
  12 ;;; your option) any later version.
  13 ;;;
  14 ;;; GNU Guix is distributed in the hope that it will be useful, but
  15 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;;; GNU General Public License for more details.
  18 ;;;
  19 ;;; You should have received a copy of the GNU General Public License
  20 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  21
  22 (define-module (guix build syscalls)
  23   #:use-module (system foreign)
  24   #:use-module (system base target)             ;for cross-compilation support
  25   #:use-module (rnrs bytevectors)
  26   #:autoload   (ice-9 binary-ports) (get-bytevector-n)
  27   #:use-module (srfi srfi-1)
  28   #:use-module (srfi srfi-9)
  29   #:use-module (srfi srfi-9 gnu)
  30   #:use-module (srfi srfi-11)
  31   #:use-module (srfi srfi-19)
  32   #:use-module (srfi srfi-26)
  33   #:use-module (ice-9 rdelim)
  34   #:use-module (ice-9 regex)
  35   #:use-module (ice-9 match)
  36   #:use-module (ice-9 ftw)
  37   #:export (MS_RDONLY
  38             MS_NOSUID
  39             MS_NODEV
  40             MS_NOEXEC
  41             MS_REMOUNT
  42             MS_BIND
  43             MS_MOVE
  44             MS_STRICTATIME
  45             MNT_FORCE
  46             MNT_DETACH
  47             MNT_EXPIRE
  48             UMOUNT_NOFOLLOW
  49             restart-on-EINTR
  50             mount-points
  51             swapon
  52             swapoff
  53
  54             file-system?
  55             file-system-type
  56             file-system-block-size
  57             file-system-block-count
  58             file-system-blocks-free
  59             file-system-blocks-available
  60             file-system-file-count
  61             file-system-free-file-nodes
  62             file-system-identifier
  63             file-system-maximum-name-length
  64             file-system-fragment-size
  65             file-system-mount-flags
  66             statfs
  67             free-disk-space
  68
  69             processes
  70             mkdtemp!
  71             fdatasync
  72             pivot-root
  73             scandir*
  74             fcntl-flock
  75
  76             set-thread-name
  77             thread-name
  78
  79             CLONE_CHILD_CLEARTID
  80             CLONE_CHILD_SETTID
  81             CLONE_NEWNS
  82             CLONE_NEWUTS
  83             CLONE_NEWIPC
  84             CLONE_NEWUSER
  85             CLONE_NEWPID
  86             CLONE_NEWNET
  87             clone
  88             setns
  89
  90             PF_PACKET
  91             AF_PACKET
  92             all-network-interface-names
  93             network-interface-names
  94             network-interface-netmask
  95             network-interface-running?
  96             loopback-network-interface?
  97             network-interface-address
  98             set-network-interface-netmask
  99             set-network-interface-up
 100             configure-network-interface
 101             add-network-route/gateway
 102             delete-network-route
 103
 104             interface?
 105             interface-name
 106             interface-flags
 107             interface-address
 108             interface-netmask
 109             interface-broadcast-address
 110             network-interfaces
 111
 112             termios?
 113             termios-input-flags
 114             termios-output-flags
 115             termios-control-flags
 116             termios-local-flags
 117             termios-line-discipline
 118             termios-control-chars
 119             termios-input-speed
 120             termios-output-speed
 121             local-flags
 122             input-flags
 123             tcsetattr-action
 124             tcgetattr
 125             tcsetattr
 126
 127             window-size?
 128             window-size-rows
 129             window-size-columns
 130             window-size-x-pixels
 131             window-size-y-pixels
 132             terminal-window-size
 133             terminal-columns
 134
 135             utmpx?
 136             utmpx-login-type
 137             utmpx-pid
 138             utmpx-line
 139             utmpx-id
 140             utmpx-user
 141             utmpx-host
 142             utmpx-termination-status
 143             utmpx-exit-status
 144             utmpx-session-id
 145             utmpx-time
 146             utmpx-address
 147             login-type
 148             utmpx-entries
 149             (read-utmpx-from-port . read-utmpx)))
 150
 151 ;;; Commentary:
 152 ;;;
 153 ;;; This module provides bindings to libc's syscall wrappers.  It uses the
 154 ;;; FFI, and thus requires a dynamically-linked Guile.
 155 ;;;
 156 ;;; Some syscalls are already defined in statically-linked Guile by applying
 157 ;;; 'guile-linux-syscalls.patch'.
 158 ;;;
 159 ;;; Visibility of syscall's symbols shared between this module and static Guile
 160 ;;; is a bit delicate. It is handled by 'define-as-needed' macro.
 161 ;;;
 162 ;;; This macro is used to export symbols in dynamic Guile context, and to
 163 ;;; re-export them in static Guile context.
 164 ;;;
 165 ;;; This way, even if they don't appear in #:export list, it is safe to use
 166 ;;; syscalls from this module in static or dynamic Guile context.
 167 ;;;
 168 ;;; Code:
 169
 170 \f
 171 ;;;
 172 ;;; Packed structures.
 173 ;;;
 174
 175 (define-syntax sizeof*
 176   ;; XXX: This duplicates 'compile-time-value'.
 177   (syntax-rules (int128 array)
 178     ((_ int128)
 179      16)
 180     ((_ (array type n))
 181      (* (sizeof* type) n))
 182     ((_ type)
 183      (let-syntax ((v (lambda (s)
 184                        (let ((val (sizeof type)))
 185                          (syntax-case s ()
 186                            (_ val))))))
 187        v))))
 188
 189 (define-syntax alignof*
 190   ;; XXX: This duplicates 'compile-time-value'.
 191   (syntax-rules (int128 array)
 192     ((_ int128)
 193      16)
 194     ((_ (array type n))
 195      (alignof* type))
 196     ((_ type)
 197      (let-syntax ((v (lambda (s)
 198                        (let ((val (alignof type)))
 199                          (syntax-case s ()
 200                            (_ val))))))
 201        v))))
 202
 203 (define-syntax align                             ;as found in (system foreign)
 204   (syntax-rules (~)
 205     "Add to OFFSET whatever it takes to get proper alignment for TYPE."
 206     ((_ offset (type ~ endianness))
 207      (align offset type))
 208     ((_ offset type)
 209      (1+ (logior (1- offset) (1- (alignof* type)))))))
 210
 211 (define-syntax type-size
 212   (syntax-rules (~)
 213     ((_ (type ~ order))
 214      (sizeof* type))
 215     ((_ type)
 216      (sizeof* type))))
 217
 218 (define-syntax struct-alignment
 219   (syntax-rules ()
 220     "Compute the alignment for the aggregate made of TYPES at OFFSET.  The
 221 result is the alignment of the \"most strictly aligned component\"."
 222     ((_ offset types ...)
 223      (max (align offset types) ...))))
 224
 225 (define-syntax struct-size
 226   (syntax-rules ()
 227     "Return the size in bytes of the structure made of TYPES."
 228     ((_ offset (types-processed ...))
 229      ;; The SysV ABI P.S. says: "Aggregates (structures and arrays) and unions
 230      ;; assume the alignment of their most strictly aligned component."  As an
 231      ;; example, a struct such as "int32, int16" has size 8, not 6.
 232      (1+ (logior (1- offset)
 233                  (1- (struct-alignment offset types-processed ...)))))
 234     ((_ offset (types-processed ...) type0 types ...)
 235      (struct-size (+ (type-size type0) (align offset type0))
 236                   (type0 types-processed ...)
 237                   types ...))))
 238
 239 (define-syntax write-type
 240   (syntax-rules (~ array *)
 241     ((_ bv offset (type ~ order) value)
 242      (bytevector-uint-set! bv offset value
 243                            (endianness order) (sizeof* type)))
 244     ((_ bv offset (array type n) value)
 245      (let loop ((i 0)
 246                 (value value)
 247                 (o offset))
 248        (unless (= i n)
 249          (match value
 250            ((head . tail)
 251             (write-type bv o type head)
 252             (loop (+ 1 i) tail (+ o (sizeof* type))))))))
 253     ((_ bv offset '* value)
 254      (bytevector-uint-set! bv offset (pointer-address value)
 255                            (native-endianness) (sizeof* '*)))
 256     ((_ bv offset type value)
 257      (bytevector-uint-set! bv offset value
 258                            (native-endianness) (sizeof* type)))))
 259
 260 (define-syntax write-types
 261   (syntax-rules ()
 262     ((_ bv offset () ())
 263      #t)
 264     ((_ bv offset (type0 types ...) (field0 fields ...))
 265      (begin
 266        (write-type bv (align offset type0) type0 field0)
 267        (write-types bv
 268                     (+ (align offset type0) (type-size type0))
 269                     (types ...) (fields ...))))))
 270
 271 (define-syntax read-type
 272   (syntax-rules (~ array quote *)
 273     ((_ bv offset '*)
 274      (make-pointer (bytevector-uint-ref bv offset
 275                                         (native-endianness)
 276                                         (sizeof* '*))))
 277     ((_ bv offset (type ~ order))
 278      (bytevector-uint-ref bv offset
 279                           (endianness order) (sizeof* type)))
 280     ((_ bv offset (array type n))
 281      (unfold (lambda (i) (= i n))
 282              (lambda (i)
 283                (read-type bv (+ offset (* i (sizeof* type))) type))
 284              1+
 285              0))
 286     ((_ bv offset type)
 287      (bytevector-uint-ref bv offset
 288                           (native-endianness) (sizeof* type)))))
 289
 290 (define-syntax read-types
 291   (syntax-rules ()
 292     ((_ return bv offset () (values ...))
 293      (return values ...))
 294     ((_ return bv offset (type0 types ...) (values ...))
 295      (read-types return
 296                  bv
 297                  (+ (align offset type0) (type-size type0))
 298                  (types ...)
 299                  (values ... (read-type bv
 300                                         (align offset type0)
 301                                         type0))))))
 302
 303 (define-syntax define-c-struct-macro
 304   (syntax-rules ()
 305     "Define NAME as a macro that can be queried to get information about the C
 306 struct it represents.  In particular:
 307
 308   (NAME field-offset FIELD)
 309
 310 returns the offset in bytes of FIELD within the C struct represented by NAME."
 311     ((_ name ((fields types) ...))
 312      (define-c-struct-macro name
 313        (fields ...) 0 ()
 314        ((fields types) ...)))
 315     ((_ name (fields ...) offset (clauses ...) ((field type) rest ...))
 316      (define-c-struct-macro name
 317        (fields ...)
 318        (+ (align offset type) (type-size type))
 319        (clauses ... ((_ field-offset field) (align offset type)))
 320        (rest ...)))
 321     ((_ name (fields ...) offset (clauses ...) ())
 322      (define-syntax name
 323        (syntax-rules (field-offset fields ...)
 324          clauses ...)))))
 325
 326 (define-syntax define-c-struct
 327   (syntax-rules ()
 328     "Define SIZE as the size in bytes of the C structure made of FIELDS.  READ
 329 as a deserializer and WRITE! as a serializer for the C structure with the
 330 given TYPES.  READ uses WRAP-FIELDS to return its value."
 331     ((_ name size wrap-fields read write! (fields types) ...)
 332      (begin
 333        (define-c-struct-macro name
 334          ((fields types) ...))
 335        (define size
 336          (struct-size 0 () types ...))
 337        (define (write! bv offset fields ...)
 338          (write-types bv offset (types ...) (fields ...)))
 339        (define* (read bv #:optional (offset 0))
 340          (read-types wrap-fields bv offset (types ...) ()))))))
 341
 342 (define-syntax-rule (c-struct-field-offset type field)
 343   "Return the offset in BYTES of FIELD within TYPE, where TYPE is a C struct
 344 defined with 'define-c-struct' and FIELD is a field identifier.  An
 345 expansion-time error is raised if FIELD does not exist in TYPE."
 346   (type field-offset field))
 347
 348 \f
 349 ;;;
 350 ;;; FFI.
 351 ;;;
 352
 353 (define %libc-errno-pointer
 354   ;; Glibc's 'errno' pointer, for use with Guile < 2.0.12.
 355   (let ((errno-loc (false-if-exception
 356                     (dynamic-func "__errno_location" (dynamic-link)))))
 357     (and errno-loc
 358          (let ((proc (pointer->procedure '* errno-loc '())))
 359            (proc)))))
 360
 361 (define errno                                     ;for Guile < 2.0.12
 362   (if %libc-errno-pointer
 363       (let ((bv (pointer->bytevector %libc-errno-pointer (sizeof int))))
 364         (lambda ()
 365           "Return the current errno."
 366           ;; XXX: We assume that nothing changes 'errno' while we're doing all this.
 367           ;; In particular, that means that no async must be running here.
 368
 369           ;; Use one of the fixed-size native-ref procedures because they are
 370           ;; optimized down to a single VM instruction, which reduces the risk
 371           ;; that we fiddle with 'errno' (needed on Guile 2.0.5, libc 2.11.)
 372           (let-syntax ((ref (lambda (s)
 373                               (syntax-case s ()
 374                                 ((_ bv)
 375                                  (case (sizeof int)
 376                                    ((4)
 377                                     #'(bytevector-s32-native-ref bv 0))
 378                                    ((8)
 379                                     #'(bytevector-s64-native-ref bv 0))
 380                                    (else
 381                                     (error "unsupported 'int' size"
 382                                            (sizeof int)))))))))
 383             (ref bv))))
 384       (lambda () 0)))
 385
 386 (define (call-with-restart-on-EINTR thunk)
 387   (let loop ()
 388     (catch 'system-error
 389       thunk
 390       (lambda args
 391         (if (= (system-error-errno args) EINTR)
 392             (loop)
 393             (apply throw args))))))
 394
 395 (define-syntax-rule (restart-on-EINTR expr)
 396   "Evaluate EXPR and restart upon EINTR.  Return the value of EXPR."
 397   (call-with-restart-on-EINTR (lambda () expr)))
 398
 399 (define (syscall->procedure return-type name argument-types)
 400   "Return a procedure that wraps the C function NAME using the dynamic FFI,
 401 and that returns two values: NAME's return value, and errno.
 402
 403 If an error occurs while creating the binding, defer the error report until
 404 the returned procedure is called."
 405   (catch #t
 406     (lambda ()
 407       (let ((ptr (dynamic-func name (dynamic-link))))
 408         ;; The #:return-errno? facility was introduced in Guile 2.0.12.
 409         ;; Support older versions of Guile by catching 'wrong-number-of-args'.
 410         (catch 'wrong-number-of-args
 411           (lambda ()
 412             (pointer->procedure return-type ptr argument-types
 413                                 #:return-errno? #t))
 414           (lambda (key . rest)
 415             (let ((proc (pointer->procedure return-type ptr argument-types)))
 416               (lambda args
 417                 (let ((result (apply proc args))
 418                       (err    (errno)))
 419                   (values result err))))))))
 420     (lambda args
 421       (lambda _
 422         (error (format #f "~a: syscall->procedure failed: ~s"
 423                        name args))))))
 424
 425 (define-syntax define-as-needed
 426   (syntax-rules ()
 427     "Define VARIABLE.  If VARIABLE already exists in (guile) then re-export it,
 428   otherwise export the newly-defined VARIABLE."
 429     ((_ (proc args ...) body ...)
 430      (define-as-needed proc (lambda* (args ...) body ...)))
 431     ((_ variable value)
 432      (begin
 433        (when (module-defined? the-scm-module 'variable)
 434          (re-export variable))
 435
 436        (define variable
 437          (if (module-defined? the-scm-module 'variable)
 438              (module-ref the-scm-module 'variable)
 439              value))
 440
 441        (unless (module-defined? the-scm-module 'variable)
 442          (export variable))))))
 443
 444 \f
 445 ;;;
 446 ;;; File systems.
 447 ;;;
 448
 449 (define (augment-mtab source target type options)
 450   "Augment /etc/mtab with information about the given mount point."
 451   (let ((port (open-file "/etc/mtab" "a")))
 452     (format port "~a ~a ~a ~a 0 0~%"
 453             source target type (or options "rw"))
 454     (close-port port)))
 455
 456 (define (read-mtab port)
 457   "Read an mtab-formatted file from PORT, returning a list of tuples."
 458   (let loop ((result '()))
 459     (let ((line (read-line port)))
 460       (if (eof-object? line)
 461           (reverse result)
 462           (loop (cons (string-tokenize line) result))))))
 463
 464 (define (remove-from-mtab target)
 465   "Remove mount point TARGET from /etc/mtab."
 466   (define entries
 467     (remove (match-lambda
 468              ((device mount-point type options freq passno)
 469               (string=? target mount-point))
 470              (_ #f))
 471             (call-with-input-file "/etc/mtab" read-mtab)))
 472
 473   (call-with-output-file "/etc/mtab"
 474     (lambda (port)
 475       (for-each (match-lambda
 476                  ((device mount-point type options freq passno)
 477                   (format port "~a ~a ~a ~a ~a ~a~%"
 478                           device mount-point type options freq passno)))
 479                 entries))))
 480
 481 ;; Linux mount flags, from libc's <sys/mount.h>.
 482 (define MS_RDONLY             1)
 483 (define MS_NOSUID             2)
 484 (define MS_NODEV              4)
 485 (define MS_NOEXEC             8)
 486 (define MS_REMOUNT           32)
 487 (define MS_BIND            4096)
 488 (define MS_MOVE            8192)
 489 (define MS_STRICTATIME 16777216)
 490
 491 (define MNT_FORCE       1)
 492 (define MNT_DETACH      2)
 493 (define MNT_EXPIRE      4)
 494 (define UMOUNT_NOFOLLOW 8)
 495
 496 (define-as-needed (mount source target type
 497                          #:optional (flags 0) options
 498                          #:key (update-mtab? #f))
 499   "Mount device SOURCE on TARGET as a file system TYPE.
 500 Optionally, FLAGS may be a bitwise-or of the MS_* <sys/mount.h>
 501 constants, and OPTIONS may be a string.  When FLAGS contains
 502 MS_REMOUNT, SOURCE and TYPE are ignored.  When UPDATE-MTAB? is true,
 503 update /etc/mtab.  Raise a 'system-error' exception on error."
 504   ;; XXX: '#:update-mtab?' is not implemented by core 'mount'.
 505   (let ((proc (syscall->procedure int "mount" `(* * * ,unsigned-long *))))
 506     (let-values (((ret err)
 507                   (proc (if source
 508                             (string->pointer source)
 509                             %null-pointer)
 510                         (string->pointer target)
 511                         (if type
 512                             (string->pointer type)
 513                             %null-pointer)
 514                         flags
 515                         (if options
 516                             (string->pointer options)
 517                             %null-pointer))))
 518       (unless (zero? ret)
 519         (throw 'system-error "mount" "mount ~S on ~S: ~A"
 520                (list source target (strerror err))
 521                (list err)))
 522       (when update-mtab?
 523         (augment-mtab source target type options)))))
 524
 525 (define-as-needed (umount target
 526                           #:optional (flags 0)
 527                           #:key (update-mtab? #f))
 528   "Unmount TARGET.  Optionally FLAGS may be one of the MNT_* or UMOUNT_*
 529 constants from <sys/mount.h>."
 530   ;; XXX: '#:update-mtab?' is not implemented by core 'umount'.
 531   (let ((proc (syscall->procedure int "umount2" `(* ,int))))
 532     (let-values (((ret err)
 533                   (proc (string->pointer target) flags)))
 534       (unless (zero? ret)
 535         (throw 'system-error "umount" "~S: ~A"
 536                (list target (strerror err))
 537                (list err)))
 538       (when update-mtab?
 539         (remove-from-mtab target)))))
 540
 541 (define (mount-points)
 542   "Return the mounts points for currently mounted file systems."
 543   (call-with-input-file "/proc/mounts"
 544     (lambda (port)
 545       (let loop ((result '()))
 546         (let ((line (read-line port)))
 547           (if (eof-object? line)
 548               (reverse result)
 549               (match (string-tokenize line)
 550                 ((source mount-point _ ...)
 551                  (loop (cons mount-point result))))))))))
 552
 553 (define swapon
 554   (let ((proc (syscall->procedure int "swapon" (list '* int))))
 555     (lambda* (device #:optional (flags 0))
 556       "Use the block special device at DEVICE for swapping."
 557       (let-values (((ret err)
 558                     (proc (string->pointer device) flags)))
 559         (unless (zero? ret)
 560           (throw 'system-error "swapon" "~S: ~A"
 561                  (list device (strerror err))
 562                  (list err)))))))
 563
 564 (define swapoff
 565   (let ((proc (syscall->procedure int "swapoff" '(*))))
 566     (lambda (device)
 567       "Stop using block special device DEVICE for swapping."
 568       (let-values (((ret err) (proc (string->pointer device))))
 569         (unless (zero? ret)
 570           (throw 'system-error "swapoff" "~S: ~A"
 571                  (list device (strerror err))
 572                  (list err)))))))
 573
 574 (define-as-needed RB_AUTOBOOT    #x01234567)
 575 (define-as-needed RB_HALT_SYSTEM #xcdef0123)
 576 (define-as-needed RB_ENABLED_CAD #x89abcdef)
 577 (define-as-needed RB_DISABLE_CAD 0)
 578 (define-as-needed RB_POWER_OFF   #x4321fedc)
 579 (define-as-needed RB_SW_SUSPEND  #xd000fce2)
 580 (define-as-needed RB_KEXEC       #x45584543)
 581
 582 (define-as-needed (reboot #:optional (cmd RB_AUTOBOOT))
 583   (let ((proc (syscall->procedure int "reboot" (list int))))
 584     (let-values (((ret err) (proc cmd)))
 585       (unless (zero? ret)
 586         (throw 'system-error "reboot" "~S: ~A"
 587                (list cmd (strerror err))
 588                (list err))))))
 589
 590 (define-as-needed (load-linux-module data #:optional (options ""))
 591   (let ((proc (syscall->procedure int "init_module"
 592                                   (list '* unsigned-long '*))))
 593     (let-values (((ret err)
 594                   (proc (bytevector->pointer data)
 595                         (bytevector-length data)
 596                         (string->pointer options))))
 597       (unless (zero? ret)
 598         (throw 'system-error "load-linux-module" "~A"
 599                (list (strerror err))
 600                (list err))))))
 601
 602 (define (kernel? pid)
 603   "Return #t if PID designates a \"kernel thread\" rather than a normal
 604 user-land process."
 605   (let ((stat (call-with-input-file (format #f "/proc/~a/stat" pid)
 606                 (compose string-tokenize read-string))))
 607     ;; See proc.txt in Linux's documentation for the list of fields.
 608     (match stat
 609       ((pid tcomm state ppid pgrp sid tty_nr tty_pgrp flags min_flt
 610             cmin_flt maj_flt cmaj_flt utime stime cutime cstime
 611             priority nice num_thread it_real_value start_time
 612             vsize rss rsslim
 613             (= string->number start_code) (= string->number end_code) _ ...)
 614        ;; Got this obscure trick from sysvinit's 'killall5' program.
 615        (and (zero? start_code) (zero? end_code))))))
 616
 617 (define (processes)
 618   "Return the list of live processes."
 619   (sort (filter-map (lambda (file)
 620                       (let ((pid (string->number file)))
 621                         (and pid
 622                              (not (kernel? pid))
 623                              pid)))
 624                     (scandir "/proc"))
 625         <))
 626
 627 (define mkdtemp!
 628   (let ((proc (syscall->procedure '* "mkdtemp" '(*))))
 629     (lambda (tmpl)
 630       "Create a new unique directory in the file system using the template
 631 string TMPL and return its file name.  TMPL must end with 'XXXXXX'."
 632       (let-values (((result err) (proc (string->pointer tmpl))))
 633         (when (null-pointer? result)
 634           (throw 'system-error "mkdtemp!" "~S: ~A"
 635                  (list tmpl (strerror err))
 636                  (list err)))
 637         (pointer->string result)))))
 638
 639 (define fdatasync
 640   (let ((proc (syscall->procedure int "fdatasync" (list int))))
 641     (lambda (port)
 642       "Flush buffered output of PORT, an output file port, and then call
 643 fdatasync(2) on the underlying file descriptor."
 644       (force-output port)
 645       (let*-values (((fd)      (fileno port))
 646                     ((ret err) (proc fd)))
 647         (unless (zero? ret)
 648           (throw 'system-error "fdatasync" "~S: ~A"
 649                  (list fd (strerror err))
 650                  (list err)))))))
 651
 652
 653 (define-record-type <file-system>
 654   (file-system type block-size blocks blocks-free
 655                blocks-available files free-files identifier
 656                name-length fragment-size mount-flags spare)
 657   file-system?
 658   (type              file-system-type)
 659   (block-size        file-system-block-size)
 660   (blocks            file-system-block-count)
 661   (blocks-free       file-system-blocks-free)
 662   (blocks-available  file-system-blocks-available)
 663   (files             file-system-file-count)
 664   (free-files        file-system-free-file-nodes)
 665   (identifier        file-system-identifier)
 666   (name-length       file-system-maximum-name-length)
 667   (fragment-size     file-system-fragment-size)
 668   (mount-flags       file-system-mount-flags)
 669   (spare             file-system--spare))
 670
 671 (define-syntax fsword                             ;fsword_t
 672   (identifier-syntax long))
 673
 674 (define-c-struct %statfs                          ;<bits/statfs.h>
 675   sizeof-statfs                                   ;slightly overestimated
 676   file-system
 677   read-statfs
 678   write-statfs!
 679   (type             fsword)
 680   (block-size       fsword)
 681   (blocks           uint64)
 682   (blocks-free      uint64)
 683   (blocks-available uint64)
 684   (files            uint64)
 685   (free-files       uint64)
 686   (identifier       (array int 2))
 687   (name-length      fsword)
 688   (fragment-size    fsword)
 689   (mount-flags      fsword)
 690   (spare            (array fsword 4)))
 691
 692 (define statfs
 693   (let ((proc (syscall->procedure int "statfs64" '(* *))))
 694     (lambda (file)
 695       "Return a <file-system> data structure describing the file system
 696 mounted at FILE."
 697       (let*-values (((stat)    (make-bytevector sizeof-statfs))
 698                     ((ret err) (proc (string->pointer file)
 699                                      (bytevector->pointer stat))))
 700         (if (zero? ret)
 701             (read-statfs stat)
 702             (throw 'system-error "statfs" "~A: ~A"
 703                    (list file (strerror err))
 704                    (list err)))))))
 705
 706 (define (free-disk-space file)
 707   "Return the free disk space, in bytes, on the file system that hosts FILE."
 708   (let ((fs (statfs file)))
 709     (* (file-system-block-size fs)
 710        (file-system-blocks-available fs))))
 711
 712 \f
 713 ;;;
 714 ;;; Containers.
 715 ;;;
 716
 717 ;; Linux clone flags, from linux/sched.h
 718 (define CLONE_CHILD_CLEARTID #x00200000)
 719 (define CLONE_CHILD_SETTID   #x01000000)
 720 (define CLONE_NEWNS          #x00020000)
 721 (define CLONE_NEWUTS         #x04000000)
 722 (define CLONE_NEWIPC         #x08000000)
 723 (define CLONE_NEWUSER        #x10000000)
 724 (define CLONE_NEWPID         #x20000000)
 725 (define CLONE_NEWNET         #x40000000)
 726
 727 (cond-expand
 728   (guile-2.2
 729    (define %set-automatic-finalization-enabled?!
 730      ;; When using a statically-linked Guile, for instance in the initrd, we
 731      ;; cannot resolve this symbol, but most of the time we don't need it
 732      ;; anyway.  Thus, delay it.
 733      (let ((proc (delay
 734                    (pointer->procedure int
 735                                        (dynamic-func
 736                                         "scm_set_automatic_finalization_enabled"
 737                                         (dynamic-link))
 738                                        (list int)))))
 739        (lambda (enabled?)
 740          "Switch on or off automatic finalization in a separate thread.
 741 Turning finalization off shuts down the finalization thread as a side effect."
 742          (->bool ((force proc) (if enabled? 1 0))))))
 743
 744    (define-syntax-rule (without-automatic-finalization exp)
 745      "Turn off automatic finalization within the dynamic extent of EXP."
 746      (let ((enabled? #t))
 747        (dynamic-wind
 748          (lambda ()
 749            (set! enabled? (%set-automatic-finalization-enabled?! #f)))
 750          (lambda ()
 751            exp)
 752          (lambda ()
 753            (%set-automatic-finalization-enabled?! enabled?))))))
 754
 755   (else
 756    (define-syntax-rule (without-automatic-finalization exp)
 757      ;; Nothing to do here: Guile 2.0 does not have a separate finalization
 758      ;; thread.
 759      exp)))
 760
 761 ;; The libc interface to sys_clone is not useful for Scheme programs, so the
 762 ;; low-level system call is wrapped instead.  The 'syscall' function is
 763 ;; declared in <unistd.h> as a variadic function; in practice, it expects 6
 764 ;; pointer-sized arguments, as shown in, e.g., x86_64/syscall.S.
 765 (define clone
 766   (let* ((proc (syscall->procedure int "syscall"
 767                                    (list long                   ;sysno
 768                                          unsigned-long          ;flags
 769                                          '* '* '*
 770                                          '*)))
 771          ;; TODO: Don't do this.
 772          (syscall-id (match (utsname:machine (uname))
 773                        ("i686"   120)
 774                        ("x86_64" 56)
 775                        ("mips64" 5055)
 776                        ("armv7l" 120)
 777                        ("aarch64" 220)
 778                        (_ #f))))
 779     (lambda (flags)
 780       "Create a new child process by duplicating the current parent process.
 781 Unlike the fork system call, clone accepts FLAGS that specify which resources
 782 are shared between the parent and child processes."
 783       (let-values (((ret err)
 784                     ;; Guile 2.2 runs a finalization thread.  'primitive-fork'
 785                     ;; takes care of shutting it down before forking, and we
 786                     ;; must do the same here.  Failing to do that, if the
 787                     ;; child process calls 'primitive-fork', it will hang
 788                     ;; while trying to pthread_join the finalization thread
 789                     ;; since that thread does not exist.
 790                     (without-automatic-finalization
 791                      (proc syscall-id flags
 792                            %null-pointer              ;child stack
 793                            %null-pointer %null-pointer ;ptid & ctid
 794                            %null-pointer))))           ;unused
 795         (if (= ret -1)
 796             (throw 'system-error "clone" "~d: ~A"
 797                    (list flags (strerror err))
 798                    (list err))
 799             ret)))))
 800
 801 (define setns
 802   ;; Some systems may be using an old (pre-2.14) version of glibc where there
 803   ;; is no 'setns' function available.
 804   (false-if-exception
 805    (let ((proc (syscall->procedure int "setns" (list int int))))
 806      (lambda (fdes nstype)
 807        "Reassociate the current process with the namespace specified by FDES, a
 808 file descriptor obtained by opening a /proc/PID/ns/* file.  NSTYPE specifies
 809 which type of namespace the current process may be reassociated with, or 0 if
 810 there is no such limitation."
 811        (let-values (((ret err) (proc fdes nstype)))
 812          (unless (zero? ret)
 813            (throw 'system-error "setns" "~d ~d: ~A"
 814                   (list fdes nstype (strerror err))
 815                   (list err))))))))
 816
 817 (define pivot-root
 818   (let ((proc (syscall->procedure int "pivot_root" (list '* '*))))
 819     (lambda (new-root put-old)
 820       "Change the root file system to NEW-ROOT and move the current root file
 821 system to PUT-OLD."
 822       (let-values (((ret err)
 823                     (proc (string->pointer new-root)
 824                           (string->pointer put-old))))
 825         (unless (zero? ret)
 826           (throw 'system-error "pivot_root" "~S ~S: ~A"
 827                  (list new-root put-old (strerror err))
 828                  (list err)))))))
 829
 830 \f
 831 ;;;
 832 ;;; Opendir & co.
 833 ;;;
 834
 835 (define (file-type->symbol type)
 836   ;; Convert TYPE to symbols like 'stat:type' does.
 837   (cond ((= type DT_REG)  'regular)
 838         ((= type DT_LNK)  'symlink)
 839         ((= type DT_DIR)  'directory)
 840         ((= type DT_FIFO) 'fifo)
 841         ((= type DT_CHR)  'char-special)
 842         ((= type DT_BLK)  'block-special)
 843         ((= type DT_SOCK) 'socket)
 844         (else             'unknown)))
 845
 846 ;; 'struct dirent64' for GNU/Linux.
 847 (define-c-struct %struct-dirent-header/linux
 848   sizeof-dirent-header/linux
 849   (lambda (inode offset length type name)
 850     `((type . ,(file-type->symbol type))
 851       (inode . ,inode)))
 852   read-dirent-header/linux
 853   write-dirent-header!/linux
 854   (inode  int64)
 855   (offset int64)
 856   (length unsigned-short)
 857   (type   uint8)
 858   (name   uint8))                                 ;first byte of 'd_name'
 859
 860 ;; 'struct dirent64' for GNU/Hurd.
 861 (define-c-struct %struct-dirent-header/hurd
 862   sizeof-dirent-header/hurd
 863   (lambda (inode length type name-length name)
 864     `((type . ,(file-type->symbol type))
 865       (inode . ,inode)))
 866   read-dirent-header/hurd
 867   write-dirent-header!/hurd
 868   (inode   int64)
 869   (length  unsigned-short)
 870   (type    uint8)
 871   (namelen uint8)
 872   (name    uint8))
 873
 874 (define-syntax define-generic-identifier
 875   (syntax-rules (gnu/linux gnu/hurd =>)
 876     "Define a generic identifier that adjust to the current GNU variant."
 877     ((_ id (gnu/linux => linux) (gnu/hurd => hurd))
 878      (define-syntax id
 879        (lambda (s)
 880          (syntax-case s ()
 881            ((_ args (... ...))
 882             (if (string-contains (or (target-type) %host-type)
 883                                  "linux")
 884                 #'(linux args (... ...))
 885                 #'(hurd args (... ...))))
 886            (_
 887             (if (string-contains (or (target-type) %host-type)
 888                                  "linux")
 889                 #'linux
 890                 #'hurd))))))))
 891
 892 (define-generic-identifier read-dirent-header
 893   (gnu/linux => read-dirent-header/linux)
 894   (gnu/hurd  => read-dirent-header/hurd))
 895
 896 (define-generic-identifier %struct-dirent-header
 897   (gnu/linux => %struct-dirent-header/linux)
 898   (gnu/hurd  => %struct-dirent-header/hurd))
 899
 900 (define-generic-identifier sizeof-dirent-header
 901   (gnu/linux => sizeof-dirent-header/linux)
 902   (gnu/hurd  => sizeof-dirent-header/hurd))
 903
 904 ;; Constants for the 'type' field, from <dirent.h>.
 905 (define DT_UNKNOWN 0)
 906 (define DT_FIFO 1)
 907 (define DT_CHR 2)
 908 (define DT_DIR 4)
 909 (define DT_BLK 6)
 910 (define DT_REG 8)
 911 (define DT_LNK 10)
 912 (define DT_SOCK 12)
 913 (define DT_WHT 14)
 914
 915 (define string->pointer/utf-8
 916   (cut string->pointer <> "UTF-8"))
 917
 918 (define pointer->string/utf-8
 919   (cut pointer->string <> <> "UTF-8"))
 920
 921 (define opendir*
 922   (let ((proc (syscall->procedure '* "opendir" '(*))))
 923     (lambda* (name #:optional (string->pointer string->pointer/utf-8))
 924       (let-values (((ptr err)
 925                     (proc (string->pointer name))))
 926         (if (null-pointer? ptr)
 927             (throw 'system-error "opendir*"
 928                    "~A: ~A" (list name (strerror err))
 929                    (list err))
 930             ptr)))))
 931
 932 (define closedir*
 933   (let ((proc (syscall->procedure int "closedir" '(*))))
 934     (lambda (directory)
 935       (let-values (((ret err)
 936                     (proc directory)))
 937         (unless (zero? ret)
 938           (throw 'system-error "closedir"
 939                  "closedir: ~A" (list (strerror err))
 940                  (list err)))))))
 941
 942 (define readdir*
 943   (let ((proc (syscall->procedure '* "readdir64" '(*))))
 944     (lambda* (directory #:optional (pointer->string pointer->string/utf-8))
 945       (let ((ptr (proc directory)))
 946         (and (not (null-pointer? ptr))
 947              (cons (pointer->string
 948                     (make-pointer (+ (pointer-address ptr)
 949                                      (c-struct-field-offset
 950                                       %struct-dirent-header name)))
 951                     -1)
 952                    (read-dirent-header
 953                     (pointer->bytevector ptr sizeof-dirent-header))))))))
 954
 955 (define* (scandir* name #:optional
 956                    (select? (const #t))
 957                    (entry<? (lambda (entry1 entry2)
 958                               (match entry1
 959                                 ((name1 . _)
 960                                  (match entry2
 961                                    ((name2 . _)
 962                                     (string<? name1 name2)))))))
 963                    #:key
 964                    (string->pointer string->pointer/utf-8)
 965                    (pointer->string pointer->string/utf-8))
 966   "This procedure improves on Guile's 'scandir' procedure in several ways:
 967
 968    1. Systematically encode decode file names using STRING->POINTER and
 969       POINTER->STRING (UTF-8 by default; this works around a defect in Guile 2.0/2.2
 970       where 'scandir' decodes file names according to the current locale, which is
 971       not always desirable.
 972
 973    2. Each entry that is returned has the form (NAME . PROPERTIES).
 974       PROPERTIES is an alist showing additional properties about the entry, as
 975       found in 'struct dirent'.  An entry may look like this:
 976
 977         (\"foo.scm\" (type . regular) (inode . 123456))
 978
 979       Callers must be prepared to deal with the case where 'type' is 'unknown'
 980       since some file systems do not provide that information.
 981
 982    3. Raise to 'system-error' when NAME cannot be opened."
 983   (let ((directory (opendir* name string->pointer)))
 984     (dynamic-wind
 985       (const #t)
 986       (lambda ()
 987         (let loop ((result '()))
 988           (match (readdir* directory pointer->string)
 989             (#f
 990              (sort result entry<?))
 991             (entry
 992              (loop (if (select? entry)
 993                        (cons entry result)
 994                        result))))))
 995       (lambda ()
 996         (closedir* directory)))))
 997
 998 \f
 999 ;;;
1000 ;;; Advisory file locking.
1001 ;;;
1002
1003 (define-c-struct %struct-flock                    ;<fcntl.h>
1004   sizeof-flock
1005   list
1006   read-flock
1007   write-flock!
1008   (type   short)
1009   (whence short)
1010   (start  size_t)
1011   (length size_t)
1012   (pid    int))
1013
1014 (define F_SETLKW
1015   ;; On Linux-based systems, this is usually 7, but not always
1016   ;; (exceptions include SPARC.)  On GNU/Hurd, it's 9.
1017   (cond ((string-contains %host-type "sparc") 9)  ; sparc-*-linux-gnu
1018         ((string-contains %host-type "linux") 7)  ; *-linux-gnu
1019         (else 9)))                                ; *-gnu*
1020
1021 (define F_SETLK
1022   ;; Likewise: GNU/Hurd and SPARC use 8, while the others typically use 6.
1023   (cond ((string-contains %host-type "sparc") 8)  ; sparc-*-linux-gnu
1024         ((string-contains %host-type "linux") 6)  ; *-linux-gnu
1025         (else 8)))                                ; *-gnu*
1026
1027 (define F_xxLCK
1028   ;; The F_RDLCK, F_WRLCK, and F_UNLCK constants.
1029   (cond ((string-contains %host-type "sparc") #(1 2 3))    ; sparc-*-linux-gnu
1030         ((string-contains %host-type "hppa")  #(1 2 3))    ; hppa-*-linux-gnu
1031         ((string-contains %host-type "linux") #(0 1 2))    ; *-linux-gnu
1032         (else                                 #(1 2 3))))  ; *-gnu*
1033
1034 (define fcntl-flock
1035   (let ((proc (syscall->procedure int "fcntl" `(,int ,int *))))
1036     (lambda* (fd-or-port operation #:key (wait? #t))
1037       "Perform locking OPERATION on the file beneath FD-OR-PORT.  OPERATION
1038 must be a symbol, one of 'read-lock, 'write-lock, or 'unlock.  When WAIT? is
1039 true, block until the lock is acquired; otherwise, thrown an 'flock-error'
1040 exception if it's already taken."
1041       (define (operation->int op)
1042         (case op
1043           ((read-lock)  (vector-ref F_xxLCK 0))
1044           ((write-lock) (vector-ref F_xxLCK 1))
1045           ((unlock)     (vector-ref F_xxLCK 2))
1046           (else         (error "invalid fcntl-flock operation" op))))
1047
1048       (define fd
1049         (if (port? fd-or-port)
1050             (fileno fd-or-port)
1051             fd-or-port))
1052
1053       (define bv
1054         (make-bytevector sizeof-flock))
1055
1056       (write-flock! bv 0
1057                     (operation->int operation) SEEK_SET
1058                     0 0                           ;whole file
1059                     0)
1060
1061       ;; XXX: 'fcntl' is a vararg function, but here we happily use the
1062       ;; standard ABI; crossing fingers.
1063       (let-values (((ret err)
1064                     (proc fd
1065                           (if wait?
1066                               F_SETLKW            ;lock & wait
1067                               F_SETLK)            ;non-blocking attempt
1068                           (bytevector->pointer bv))))
1069         (unless (zero? ret)
1070           ;; Presumably we got EAGAIN or so.
1071           (throw 'flock-error err))))))
1072
1073 \f
1074 ;;;
1075 ;;; Miscellaneous, aka. 'prctl'.
1076 ;;;
1077
1078 (define %prctl
1079   ;; Should it win the API contest against 'ioctl'?  You tell us!
1080   (syscall->procedure int "prctl"
1081                       (list int unsigned-long unsigned-long
1082                             unsigned-long unsigned-long)))
1083
1084 (define PR_SET_NAME 15)                           ;<linux/prctl.h>
1085 (define PR_GET_NAME 16)
1086
1087 (define %max-thread-name-length
1088   ;; Maximum length in bytes of the process name, including the terminating
1089   ;; zero.
1090   16)
1091
1092 (define (set-thread-name name)
1093   "Set the name of the calling thread to NAME.  NAME is truncated to 15
1094 bytes."
1095   (let ((ptr (string->pointer name)))
1096     (let-values (((ret err)
1097                   (%prctl PR_SET_NAME
1098                           (pointer-address ptr) 0 0 0)))
1099       (unless (zero? ret)
1100         (throw 'set-process-name "set-process-name"
1101                "set-process-name: ~A"
1102                (list (strerror err))
1103                (list err))))))
1104
1105 (define (thread-name)
1106   "Return the name of the calling thread as a string."
1107   (let ((buf (make-bytevector %max-thread-name-length)))
1108     (let-values (((ret err)
1109                   (%prctl PR_GET_NAME
1110                           (pointer-address (bytevector->pointer buf))
1111                           0 0 0)))
1112       (if (zero? ret)
1113           (bytes->string (bytevector->u8-list buf))
1114           (throw 'process-name "process-name"
1115                  "process-name: ~A"
1116                  (list (strerror err))
1117                  (list err))))))
1118
1119 \f
1120 ;;;
1121 ;;; Network interfaces.
1122 ;;;
1123
1124 (define SIOCGIFCONF                               ;from <bits/ioctls.h>
1125   (if (string-contains %host-type "linux")
1126       #x8912                                      ;GNU/Linux
1127       #xf00801a4))                                ;GNU/Hurd
1128 (define SIOCGIFFLAGS
1129   (if (string-contains %host-type "linux")
1130       #x8913                                      ;GNU/Linux
1131       #xc4804191))                                ;GNU/Hurd
1132 (define SIOCSIFFLAGS
1133   (if (string-contains %host-type "linux")
1134       #x8914                                      ;GNU/Linux
1135       -1))                                        ;FIXME: GNU/Hurd?
1136 (define SIOCGIFADDR
1137   (if (string-contains %host-type "linux")
1138       #x8915                                      ;GNU/Linux
1139       -1))                                        ;FIXME: GNU/Hurd?
1140 (define SIOCSIFADDR
1141   (if (string-contains %host-type "linux")
1142       #x8916                                      ;GNU/Linux
1143       -1))                                        ;FIXME: GNU/Hurd?
1144 (define SIOCGIFNETMASK
1145   (if (string-contains %host-type "linux")
1146       #x891b                                      ;GNU/Linux
1147       -1))                                        ;FIXME: GNU/Hurd?
1148 (define SIOCSIFNETMASK
1149   (if (string-contains %host-type "linux")
1150       #x891c                                      ;GNU/Linux
1151       -1))                                        ;FIXME: GNU/Hurd?
1152 (define SIOCADDRT
1153   (if (string-contains %host-type "linux")
1154       #x890B                                      ;GNU/Linux
1155       -1))                                        ;FIXME: GNU/Hurd?
1156 (define SIOCDELRT
1157   (if (string-contains %host-type "linux")
1158       #x890C                                      ;GNU/Linux
1159       -1))                                        ;FIXME: GNU/Hurd?
1160
1161 ;; Flags and constants from <net/if.h>.
1162
1163 (define-as-needed IFF_UP #x1)                     ;Interface is up
1164 (define-as-needed IFF_BROADCAST #x2)              ;Broadcast address valid.
1165 (define-as-needed IFF_LOOPBACK #x8)               ;Is a loopback net.
1166 (define-as-needed IFF_RUNNING #x40)               ;interface RFC2863 OPER_UP
1167
1168 (define IF_NAMESIZE 16)                           ;maximum interface name size
1169
1170 (define-c-struct %ifconf-struct
1171   sizeof-ifconf
1172   list
1173   read-ifconf
1174   write-ifconf!
1175   (length  int)                                   ;int ifc_len
1176   (request '*))                                   ;struct ifreq *ifc_ifcu
1177
1178 (define ifreq-struct-size
1179   ;; 'struct ifreq' begins with an array of IF_NAMESIZE bytes containing the
1180   ;; interface name (nul-terminated), followed by a bunch of stuff.  This is
1181   ;; its size in bytes.
1182   (if (= 8 (sizeof '*))
1183       40
1184       32))
1185
1186 (define-c-struct sockaddr-in                      ;<linux/in.h>
1187   sizeof-sockaddrin
1188   (lambda (family port address)
1189     (make-socket-address family address port))
1190   read-sockaddr-in
1191   write-sockaddr-in!
1192   (family    unsigned-short)
1193   (port      (int16 ~ big))
1194   (address   (int32 ~ big)))
1195
1196 (define-c-struct sockaddr-in6                     ;<linux/in6.h>
1197   sizeof-sockaddr-in6
1198   (lambda (family port flowinfo address scopeid)
1199     (make-socket-address family address port flowinfo scopeid))
1200   read-sockaddr-in6
1201   write-sockaddr-in6!
1202   (family    unsigned-short)
1203   (port      (int16 ~ big))
1204   (flowinfo  (int32 ~ big))
1205   (address   (int128 ~ big))
1206   (scopeid   int32))
1207
1208 (define (write-socket-address! sockaddr bv index)
1209   "Write SOCKADDR, a socket address as returned by 'make-socket-address', to
1210 bytevector BV at INDEX."
1211   (let ((family (sockaddr:fam sockaddr)))
1212     (cond ((= family AF_INET)
1213            (write-sockaddr-in! bv index
1214                                family
1215                                (sockaddr:port sockaddr)
1216                                (sockaddr:addr sockaddr)))
1217           ((= family AF_INET6)
1218            (write-sockaddr-in6! bv index
1219                                 family
1220                                 (sockaddr:port sockaddr)
1221                                 (sockaddr:flowinfo sockaddr)
1222                                 (sockaddr:addr sockaddr)
1223                                 (sockaddr:scopeid sockaddr)))
1224           (else
1225            (error "unsupported socket address" sockaddr)))))
1226
1227 (define PF_PACKET 17)                             ;<bits/socket.h>
1228 (define AF_PACKET PF_PACKET)
1229
1230 (define* (read-socket-address bv #:optional (index 0))
1231   "Read a socket address from bytevector BV at INDEX."
1232   (let ((family (bytevector-u16-native-ref bv index)))
1233     (cond ((= family AF_INET)
1234            (read-sockaddr-in bv index))
1235           ((= family AF_INET6)
1236            (read-sockaddr-in6 bv index))
1237           (else
1238            ;; XXX: Unsupported address family, such as AF_PACKET.  Return a
1239            ;; vector such that the vector can at least call 'sockaddr:fam'.
1240            (vector family)))))
1241
1242 (define %ioctl
1243   ;; The most terrible interface, live from Scheme.
1244   (syscall->procedure int "ioctl" (list int unsigned-long '*)))
1245
1246 (define (bytes->string bytes)
1247   "Read BYTES, a list of bytes, and return the null-terminated string decoded
1248 from there, or #f if that would be an empty string."
1249   (match (take-while (negate zero?) bytes)
1250     (()
1251      #f)
1252     (non-zero
1253      (list->string (map integer->char non-zero)))))
1254
1255 (define (bytevector->string-list bv stride len)
1256   "Return the null-terminated strings found in BV every STRIDE bytes.  Read at
1257 most LEN bytes from BV."
1258   (let loop ((bytes  (take (bytevector->u8-list bv)
1259                            (min len (bytevector-length bv))))
1260              (result '()))
1261     (match bytes
1262       (()
1263        (reverse result))
1264       (_
1265        (loop (drop bytes stride)
1266              (cons (bytes->string bytes) result))))))
1267
1268 (define* (network-interface-names #:optional sock)
1269   "Return the names of existing network interfaces.  This is typically limited
1270 to interfaces that are currently up."
1271   (let* ((close? (not sock))
1272          (sock   (or sock (socket SOCK_STREAM AF_INET 0)))
1273          (len    (* ifreq-struct-size 10))
1274          (reqs   (make-bytevector len))
1275          (conf   (make-bytevector sizeof-ifconf)))
1276     (write-ifconf! conf 0
1277                    len (bytevector->pointer reqs))
1278
1279     (let-values (((ret err)
1280                   (%ioctl (fileno sock) SIOCGIFCONF
1281                           (bytevector->pointer conf))))
1282       (when close?
1283         (close-port sock))
1284       (if (zero? ret)
1285           (bytevector->string-list reqs ifreq-struct-size
1286                                    (match (read-ifconf conf)
1287                                      ((len . _) len)))
1288           (throw 'system-error "network-interface-list"
1289                  "network-interface-list: ~A"
1290                  (list (strerror err))
1291                  (list err))))))
1292
1293 (define %interface-line
1294   ;; Regexp matching an interface line in Linux's /proc/net/dev.
1295   (make-regexp "^[[:blank:]]*([[:graph:]]+):.*$"))
1296
1297 (define (all-network-interface-names)
1298   "Return all the names of the registered network interfaces, including those
1299 that are not up."
1300   (call-with-input-file "/proc/net/dev"           ;XXX: Linux-specific
1301     (lambda (port)
1302       (let loop ((interfaces '()))
1303         (let ((line (read-line port)))
1304           (cond ((eof-object? line)
1305                  (reverse interfaces))
1306                 ((regexp-exec %interface-line line)
1307                  =>
1308                  (lambda (match)
1309                    (loop (cons (match:substring match 1) interfaces))))
1310                 (else
1311                  (loop interfaces))))))))
1312
1313 (define-as-needed (network-interface-flags socket name)
1314   "Return a number that is the bit-wise or of 'IFF*' flags for network
1315 interface NAME."
1316   (let ((req (make-bytevector ifreq-struct-size)))
1317     (bytevector-copy! (string->utf8 name) 0 req 0
1318                       (min (string-length name) (- IF_NAMESIZE 1)))
1319     (let-values (((ret err)
1320                   (%ioctl (fileno socket) SIOCGIFFLAGS
1321                           (bytevector->pointer req))))
1322       (if (zero? ret)
1323
1324           ;; The 'ifr_flags' field is IF_NAMESIZE bytes after the
1325           ;; beginning of 'struct ifreq', and it's a short int.
1326           (bytevector-sint-ref req IF_NAMESIZE (native-endianness)
1327                                (sizeof short))
1328
1329           (throw 'system-error "network-interface-flags"
1330                  "network-interface-flags on ~A: ~A"
1331                  (list name (strerror err))
1332                  (list err))))))
1333
1334 (define (loopback-network-interface? name)
1335   "Return true if NAME designates a loopback network interface."
1336   (let* ((sock  (socket SOCK_STREAM AF_INET 0))
1337          (flags (network-interface-flags sock name)))
1338     (close-port sock)
1339     (not (zero? (logand flags IFF_LOOPBACK)))))
1340
1341 (define (network-interface-running? name)
1342   "Return true if NAME designates a running network interface."
1343   (let* ((sock  (socket SOCK_STREAM AF_INET 0))
1344          (flags (network-interface-flags sock name)))
1345     (close-port sock)
1346     (not (zero? (logand flags IFF_RUNNING)))))
1347
1348 (define-as-needed (set-network-interface-flags socket name flags)
1349   "Set the flag of network interface NAME to FLAGS."
1350   (let ((req (make-bytevector ifreq-struct-size)))
1351     (bytevector-copy! (string->utf8 name) 0 req 0
1352                       (min (string-length name) (- IF_NAMESIZE 1)))
1353     ;; Set the 'ifr_flags' field.
1354     (bytevector-uint-set! req IF_NAMESIZE flags (native-endianness)
1355                           (sizeof short))
1356     (let-values (((ret err)
1357                   (%ioctl (fileno socket) SIOCSIFFLAGS
1358                           (bytevector->pointer req))))
1359       (unless (zero? ret)
1360         (throw 'system-error "set-network-interface-flags"
1361                "set-network-interface-flags on ~A: ~A"
1362                (list name (strerror err))
1363                (list err))))))
1364
1365 (define-as-needed (set-network-interface-address socket name sockaddr)
1366   "Set the address of network interface NAME to SOCKADDR."
1367   (let ((req (make-bytevector ifreq-struct-size)))
1368     (bytevector-copy! (string->utf8 name) 0 req 0
1369                       (min (string-length name) (- IF_NAMESIZE 1)))
1370     ;; Set the 'ifr_addr' field.
1371     (write-socket-address! sockaddr req IF_NAMESIZE)
1372     (let-values (((ret err)
1373                   (%ioctl (fileno socket) SIOCSIFADDR
1374                           (bytevector->pointer req))))
1375       (unless (zero? ret)
1376         (throw 'system-error "set-network-interface-address"
1377                "set-network-interface-address on ~A: ~A"
1378                (list name (strerror err))
1379                (list err))))))
1380
1381 (define (set-network-interface-netmask socket name sockaddr)
1382   "Set the network mask of interface NAME to SOCKADDR."
1383   (let ((req (make-bytevector ifreq-struct-size)))
1384     (bytevector-copy! (string->utf8 name) 0 req 0
1385                       (min (string-length name) (- IF_NAMESIZE 1)))
1386     ;; Set the 'ifr_addr' field.
1387     (write-socket-address! sockaddr req IF_NAMESIZE)
1388     (let-values (((ret err)
1389                   (%ioctl (fileno socket) SIOCSIFNETMASK
1390                           (bytevector->pointer req))))
1391       (unless (zero? ret)
1392         (throw 'system-error "set-network-interface-netmask"
1393                "set-network-interface-netmask on ~A: ~A"
1394                (list name (strerror err))
1395                (list err))))))
1396
1397 (define (network-interface-address socket name)
1398   "Return the address of network interface NAME.  The result is an object of
1399 the same type as that returned by 'make-socket-address'."
1400   (let ((req (make-bytevector ifreq-struct-size)))
1401     (bytevector-copy! (string->utf8 name) 0 req 0
1402                       (min (string-length name) (- IF_NAMESIZE 1)))
1403     (let-values (((ret err)
1404                   (%ioctl (fileno socket) SIOCGIFADDR
1405                           (bytevector->pointer req))))
1406       (if (zero? ret)
1407           (read-socket-address req IF_NAMESIZE)
1408           (throw 'system-error "network-interface-address"
1409                  "network-interface-address on ~A: ~A"
1410                  (list name (strerror err))
1411                  (list err))))))
1412
1413 (define (network-interface-netmask socket name)
1414   "Return the netmask of network interface NAME.  The result is an object of
1415 the same type as that returned by 'make-socket-address'."
1416   (let ((req (make-bytevector ifreq-struct-size)))
1417     (bytevector-copy! (string->utf8 name) 0 req 0
1418                       (min (string-length name) (- IF_NAMESIZE 1)))
1419     (let-values (((ret err)
1420                   (%ioctl (fileno socket) SIOCGIFNETMASK
1421                           (bytevector->pointer req))))
1422       (if (zero? ret)
1423           (read-socket-address req IF_NAMESIZE)
1424           (throw 'system-error "network-interface-netmask"
1425                  "network-interface-netmask on ~A: ~A"
1426                  (list name (strerror err))
1427                  (list err))))))
1428
1429 (define* (configure-network-interface name sockaddr flags
1430                                       #:key netmask)
1431   "Configure network interface NAME to use SOCKADDR, an address as returned by
1432 'make-socket-address', and FLAGS, a bitwise-or of IFF_* constants.  If NETMASK
1433 is true, it must be a socket address to use as the network mask."
1434   (let ((sock (socket (sockaddr:fam sockaddr) SOCK_STREAM 0)))
1435     (dynamic-wind
1436       (const #t)
1437       (lambda ()
1438         (set-network-interface-address sock name sockaddr)
1439         (set-network-interface-flags sock name flags)
1440         (when netmask
1441           (set-network-interface-netmask sock name netmask)))
1442       (lambda ()
1443         (close-port sock)))))
1444
1445 (define* (set-network-interface-up name
1446                                    #:key (family AF_INET))
1447   "Turn up the interface NAME."
1448   (let ((sock (socket family SOCK_STREAM 0)))
1449     (dynamic-wind
1450       (const #t)
1451       (lambda ()
1452         (let ((flags (network-interface-flags sock name)))
1453           (set-network-interface-flags sock name
1454                                        (logior flags IFF_UP))))
1455       (lambda ()
1456         (close-port sock)))))
1457
1458 \f
1459 ;;;
1460 ;;; Network routes.
1461 ;;;
1462
1463 (define-c-struct %rtentry                 ;'struct rtentry' from <net/route.h>
1464   sizeof-rtentry
1465   list
1466   read-rtentry
1467   write-rtentry!
1468   (pad1            unsigned-long)
1469   (destination     (array uint8 16))              ;struct sockaddr
1470   (gateway         (array uint8 16))              ;struct sockaddr
1471   (genmask         (array uint8 16))              ;struct sockaddr
1472   (flags           unsigned-short)
1473   (pad2            short)
1474   (pad3            long)
1475   (tos             uint8)
1476   (class           uint8)
1477   (pad4            (array uint8 (if (= 8 (sizeof* '*)) 3 1)))
1478   (metric          short)
1479   (device          '*)
1480   (mtu             unsigned-long)
1481   (window          unsigned-long)
1482   (initial-rtt     unsigned-short))
1483
1484 (define RTF_UP #x0001)                     ;'rtentry' flags from <net/route.h>
1485 (define RTF_GATEWAY #x0002)
1486
1487 (define %sockaddr-any
1488   (make-socket-address AF_INET INADDR_ANY 0))
1489
1490 (define add-network-route/gateway
1491   ;; To allow field names to be matched as literals, we need to move them out
1492   ;; of the lambda's body since the parameters have the same name.  A lot of
1493   ;; fuss for very little.
1494   (let-syntax ((gateway-offset (identifier-syntax
1495                                 (c-struct-field-offset %rtentry gateway)))
1496                (destination-offset (identifier-syntax
1497                                     (c-struct-field-offset %rtentry destination)))
1498                (genmask-offset (identifier-syntax
1499                                 (c-struct-field-offset %rtentry genmask))))
1500     (lambda* (socket gateway
1501                      #:key (destination %sockaddr-any) (genmask %sockaddr-any))
1502       "Add a network route for DESTINATION (a socket address as returned by
1503 'make-socket-address') that goes through GATEWAY (a socket address).  For
1504 instance, the call:
1505
1506   (add-network-route/gateway sock
1507                              (make-socket-address
1508                                AF_INET
1509                                (inet-pton AF_INET \"192.168.0.1\")
1510                                0))
1511
1512 is equivalent to this 'net-tools' command:
1513
1514   route add -net default gw 192.168.0.1
1515
1516 because the default value of DESTINATION is \"0.0.0.0\"."
1517       (let ((route (make-bytevector sizeof-rtentry 0)))
1518         (write-socket-address! gateway route gateway-offset)
1519         (write-socket-address! destination route destination-offset)
1520         (write-socket-address! genmask route genmask-offset)
1521         (bytevector-u16-native-set! route
1522                                     (c-struct-field-offset %rtentry flags)
1523                                     (logior RTF_UP RTF_GATEWAY))
1524         (let-values (((ret err)
1525                       (%ioctl (fileno socket) SIOCADDRT
1526                               (bytevector->pointer route))))
1527           (unless (zero? ret)
1528             (throw 'system-error "add-network-route/gateway"
1529                    "add-network-route/gateway: ~A"
1530                    (list (strerror err))
1531                    (list err))))))))
1532
1533 (define delete-network-route
1534   (let-syntax ((destination-offset (identifier-syntax
1535                                     (c-struct-field-offset %rtentry destination))))
1536     (lambda* (socket destination)
1537       "Delete the network route for DESTINATION.  For instance, the call:
1538
1539   (delete-network-route sock
1540                         (make-socket-address AF_INET INADDR_ANY 0))
1541
1542 is equivalent to the 'net-tools' command:
1543
1544   route del -net default
1545 "
1546
1547       (let ((route (make-bytevector sizeof-rtentry 0)))
1548         (write-socket-address! destination route destination-offset)
1549         (let-values (((ret err)
1550                       (%ioctl (fileno socket) SIOCDELRT
1551                               (bytevector->pointer route))))
1552           (unless (zero? ret)
1553             (throw 'system-error "delete-network-route"
1554                    "delete-network-route: ~A"
1555                    (list (strerror err))
1556                    (list err))))))))
1557
1558 \f
1559 ;;;
1560 ;;; Details about network interfaces---aka. 'getifaddrs'.
1561 ;;;
1562
1563 ;; Network interfaces.  XXX: We would call it <network-interface> but that
1564 ;; would collide with the ioctl wrappers above.
1565 (define-record-type <interface>
1566   (make-interface name flags address netmask broadcast-address)
1567   interface?
1568   (name              interface-name)               ;string
1569   (flags             interface-flags)              ;or'd IFF_* values
1570   (address           interface-address)            ;sockaddr | #f
1571   (netmask           interface-netmask)            ;sockaddr | #f
1572   (broadcast-address interface-broadcast-address)) ;sockaddr | #f
1573
1574 (define (write-interface interface port)
1575   (match interface
1576     (($ <interface> name flags address)
1577      (format port "#<interface ~s " name)
1578      (unless (zero? (logand IFF_UP flags))
1579        (display "up " port))
1580
1581      ;; Check whether ADDRESS really is a sockaddr.
1582      (when address
1583        (if (member (sockaddr:fam address) (list AF_INET AF_INET6))
1584            (format port "~a " (inet-ntop (sockaddr:fam address)
1585                                          (sockaddr:addr address)))
1586            (format port "family:~a " (sockaddr:fam address))))
1587
1588      (format port "~a>" (number->string (object-address interface) 16)))))
1589
1590 (set-record-type-printer! <interface> write-interface)
1591
1592 (define (values->interface next name flags address netmask
1593                            broadcast-address data)
1594   "Given the raw field values passed as arguments, return a pair whose car is
1595 an <interface> object, and whose cdr is the pointer NEXT."
1596   (define (maybe-socket-address pointer)
1597     (if (null-pointer? pointer)
1598         #f
1599         (read-socket-address (pointer->bytevector pointer 50)))) ;XXX: size
1600
1601   (cons (make-interface (if (null-pointer? name)
1602                             #f
1603                             (pointer->string name))
1604                         flags
1605                         (maybe-socket-address address)
1606                         (maybe-socket-address netmask)
1607                         (maybe-socket-address broadcast-address)
1608                         ;; Ignore DATA.
1609                         )
1610         next))
1611
1612 (define-c-struct ifaddrs                          ;<ifaddrs.h>
1613   %sizeof-ifaddrs
1614   values->interface
1615   read-ifaddrs
1616   write-ifaddrs!
1617   (next          '*)
1618   (name          '*)
1619   (flags         unsigned-int)
1620   (addr          '*)
1621   (netmask       '*)
1622   (broadcastaddr '*)
1623   (data          '*))
1624
1625 (define (unfold-interface-list ptr)
1626   "Call 'read-ifaddrs' on PTR and all its 'next' fields, recursively, and
1627 return the list of resulting <interface> objects."
1628   (let loop ((ptr    ptr)
1629              (result '()))
1630     (if (null-pointer? ptr)
1631         (reverse result)
1632         (match (read-ifaddrs (pointer->bytevector ptr %sizeof-ifaddrs))
1633           ((ifaddr . ptr)
1634            (loop ptr (cons ifaddr result)))))))
1635
1636 (define network-interfaces
1637   (let ((proc (syscall->procedure int "getifaddrs" (list '*))))
1638     (lambda ()
1639       "Return a list of <interface> objects, each denoting a configured
1640 network interface.  This is implemented using the 'getifaddrs' libc function."
1641       (let*-values (((ptr)
1642                      (bytevector->pointer (make-bytevector (sizeof* '*))))
1643                     ((ret err)
1644                      (proc ptr)))
1645         (if (zero? ret)
1646             (let* ((ptr    (dereference-pointer ptr))
1647                    (result (unfold-interface-list ptr)))
1648               (free-ifaddrs ptr)
1649               result)
1650             (throw 'system-error "network-interfaces" "~A"
1651                    (list (strerror err))
1652                    (list err)))))))
1653
1654 (define free-ifaddrs
1655   (syscall->procedure void "freeifaddrs" '(*)))
1656
1657 \f
1658 ;;;
1659 ;;; Terminals.
1660 ;;;
1661
1662 (define-syntax bits->symbols-body
1663   (syntax-rules ()
1664     ((_ bits () ())
1665      '())
1666     ((_ bits (name names ...) (value values ...))
1667      (let ((result (bits->symbols-body bits (names ...) (values ...))))
1668        (if (zero? (logand bits value))
1669            result
1670            (cons 'name result))))))
1671
1672 (define-syntax define-bits
1673   (syntax-rules (define)
1674     "Define the given numerical constants under CONSTRUCTOR, such that
1675  (CONSTRUCTOR NAME) returns VALUE.  Define BITS->SYMBOLS as a procedure that,
1676 given an integer, returns the list of names of the constants that are or'd."
1677     ((_ constructor bits->symbols (define names values) ...)
1678      (begin
1679        (define-syntax constructor
1680          (syntax-rules (names ...)
1681            ((_) 0)
1682            ((_ names) values) ...
1683            ((_ first rest (... ...))
1684             (logior (constructor first) rest (... ...)))))
1685        (define (bits->symbols bits)
1686          (bits->symbols-body bits (names ...) (values ...)))))))
1687
1688 ;; 'local-flags' bits from <bits/termios.h>
1689 (define-bits local-flags
1690   local-flags->symbols
1691  (define ISIG #o0000001)
1692  (define ICANON #o0000002)
1693  (define XCASE #o0000004)
1694  (define ECHO #o0000010)
1695  (define ECHOE #o0000020)
1696  (define ECHOK #o0000040)
1697  (define ECHONL #o0000100)
1698  (define NOFLSH #o0000200)
1699  (define TOSTOP #o0000400)
1700  (define ECHOCTL #o0001000)
1701  (define ECHOPRT #o0002000)
1702  (define ECHOKE #o0004000)
1703  (define FLUSHO #o0010000)
1704  (define PENDIN #o0040000)
1705  (define IEXTEN #o0100000)
1706  (define EXTPROC #o0200000))
1707
1708 (define-bits input-flags
1709   input-flags->symbols
1710   (define IGNBRK #o0000001)
1711   (define BRKINT #o0000002)
1712   (define IGNPAR #o0000004)
1713   (define PARMRK #o0000010)
1714   (define INPCK #o0000020)
1715   (define ISTRIP #o0000040)
1716   (define INLCR #o0000100)
1717   (define IGNCR #o0000200)
1718   (define ICRNL #o0000400)
1719   (define IUCLC #o0001000)
1720   (define IXON #o0002000)
1721   (define IXANY #o0004000)
1722   (define IXOFF #o0010000)
1723   (define IMAXBEL #o0020000)
1724   (define IUTF8 #o0040000))
1725
1726 ;; "Actions" values for 'tcsetattr'.
1727 (define-bits tcsetattr-action
1728   %unused-tcsetattr-action->symbols
1729   (define TCSANOW  0)
1730   (define TCSADRAIN 1)
1731   (define TCSAFLUSH 2))
1732
1733 (define-record-type <termios>
1734   (termios input-flags output-flags control-flags local-flags
1735            line-discipline control-chars
1736            input-speed output-speed)
1737   termios?
1738   (input-flags      termios-input-flags)
1739   (output-flags     termios-output-flags)
1740   (control-flags    termios-control-flags)
1741   (local-flags      termios-local-flags)
1742   (line-discipline  termios-line-discipline)
1743   (control-chars    termios-control-chars)
1744   (input-speed      termios-input-speed)
1745   (output-speed     termios-output-speed))
1746
1747 (define-c-struct %termios                         ;<bits/termios.h>
1748   sizeof-termios
1749   termios
1750   read-termios
1751   write-termios!
1752   (input-flags      unsigned-int)
1753   (output-flags     unsigned-int)
1754   (control-flags    unsigned-int)
1755   (local-flags      unsigned-int)
1756   (line-discipline  uint8)
1757   (control-chars    (array uint8 32))
1758   (input-speed      unsigned-int)
1759   (output-speed     unsigned-int))
1760
1761 (define tcgetattr
1762   (let ((proc (syscall->procedure int "tcgetattr" (list int '*))))
1763     (lambda (fd)
1764       "Return the <termios> structure for the tty at FD."
1765       (let*-values (((bv)      (make-bytevector sizeof-termios))
1766                     ((ret err) (proc fd (bytevector->pointer bv))))
1767         (if (zero? ret)
1768             (read-termios bv)
1769             (throw 'system-error "tcgetattr" "~A"
1770                    (list (strerror err))
1771                    (list err)))))))
1772
1773 (define tcsetattr
1774   (let ((proc (syscall->procedure int "tcsetattr" (list int int '*))))
1775     (lambda (fd actions termios)
1776       "Use TERMIOS for the tty at FD.  ACTIONS is one of of the values
1777 produced by 'tcsetattr-action'; see tcsetattr(3) for details."
1778       (define bv
1779         (make-bytevector sizeof-termios))
1780
1781       (let-syntax ((match/write (syntax-rules ()
1782                                   ((_ fields ...)
1783                                    (match termios
1784                                      (($ <termios> fields ...)
1785                                       (write-termios! bv 0 fields ...)))))))
1786         (match/write input-flags output-flags control-flags local-flags
1787                      line-discipline control-chars input-speed output-speed))
1788
1789       (let-values (((ret err) (proc fd actions (bytevector->pointer bv))))
1790         (unless (zero? ret)
1791           (throw 'system-error "tcgetattr" "~A"
1792                  (list (strerror err))
1793                  (list err)))))))
1794
1795 (define-syntax TIOCGWINSZ                         ;<asm-generic/ioctls.h>
1796   (identifier-syntax #x5413))
1797
1798 (define-record-type <window-size>
1799   (window-size rows columns x-pixels y-pixels)
1800   window-size?
1801   (rows     window-size-rows)
1802   (columns  window-size-columns)
1803   (x-pixels window-size-x-pixels)
1804   (y-pixels window-size-y-pixels))
1805
1806 (define-c-struct winsize                          ;<bits/ioctl-types.h>
1807   sizeof-winsize
1808   window-size
1809   read-winsize
1810   write-winsize!
1811   (rows          unsigned-short)
1812   (columns       unsigned-short)
1813   (x-pixels      unsigned-short)
1814   (y-pixels      unsigned-short))
1815
1816 (define* (terminal-window-size #:optional (port (current-output-port)))
1817   "Return a <window-size> structure describing the terminal at PORT, or raise
1818 a 'system-error' if PORT is not backed by a terminal.  This procedure
1819 corresponds to the TIOCGWINSZ ioctl."
1820   (let*-values (((size)    (make-bytevector sizeof-winsize))
1821                 ((ret err) (%ioctl (fileno port) TIOCGWINSZ
1822                                    (bytevector->pointer size))))
1823     (if (zero? ret)
1824         (read-winsize size)
1825         (throw 'system-error "terminal-window-size" "~A"
1826                (list (strerror err))
1827                (list err)))))
1828
1829 (define* (terminal-columns #:optional (port (current-output-port)))
1830   "Return the best approximation of the number of columns of the terminal at
1831 PORT, trying to guess a reasonable value if all else fails.  The result is
1832 always a positive integer."
1833   (define (fall-back)
1834     (match (and=> (getenv "COLUMNS") string->number)
1835       (#f 80)
1836       ((? number? columns)
1837        (if (> columns 0) columns 80))))
1838
1839   (catch 'system-error
1840     (lambda ()
1841       (if (file-port? port)
1842           (match (window-size-columns (terminal-window-size port))
1843             ;; Things like Emacs shell-mode return 0, which is unreasonable.
1844             (0 (fall-back))
1845             ((? number? columns) columns))
1846           (fall-back)))
1847     (lambda args
1848       (let ((errno (system-error-errno args)))
1849         ;; ENOTTY is what we're after but 2012-and-earlier Linux versions
1850         ;; would return EINVAL instead in some cases:
1851         ;; <https://bugs.ruby-lang.org/issues/10494>.
1852         ;; Furthermore, some FUSE file systems like unionfs return ENOSYS for
1853         ;; that ioctl.
1854         (if (memv errno (list ENOTTY EINVAL ENOSYS))
1855             (fall-back)
1856             (apply throw args))))))
1857
1858 \f
1859 ;;;
1860 ;;; utmpx.
1861 ;;;
1862
1863 (define-record-type <utmpx-entry>
1864   (utmpx type pid line id user host termination exit
1865          session time address)
1866   utmpx?
1867   (type           utmpx-login-type)               ;login-type
1868   (pid            utmpx-pid)
1869   (line           utmpx-line)                     ;device name
1870   (id             utmpx-id)
1871   (user           utmpx-user)                     ;user name
1872   (host           utmpx-host)                     ;host name | #f
1873   (termination    utmpx-termination-status)
1874   (exit           utmpx-exit-status)
1875   (session        utmpx-session-id)               ;session ID, for windowing
1876   (time           utmpx-time)                     ;entry time
1877   (address        utmpx-address))
1878
1879 (define-c-struct %utmpx                           ;<utmpx.h>
1880   sizeof-utmpx
1881   (lambda (type pid line id user host termination exit session
1882                 seconds useconds address %reserved)
1883     (utmpx type pid
1884            (bytes->string line) id
1885            (bytes->string user)
1886            (bytes->string host) termination exit
1887            session
1888            (make-time time-utc (* 1000 useconds) seconds)
1889            address))
1890   read-utmpx
1891   write-utmpx!
1892   (type           short)
1893   (pid            int)
1894   (line           (array uint8 32))
1895   (id             (array uint8 4))
1896   (user           (array uint8 32))
1897   (host           (array uint8 256))
1898   (termination    short)
1899   (exit           short)
1900   (session        int32)
1901   (time-seconds   int32)
1902   (time-useconds  int32)
1903   (address-v6     (array int32 4))
1904   (%reserved      (array uint8 20)))
1905
1906 (define-bits login-type
1907   %unused-login-type->symbols
1908   (define EMPTY 0)                      ;No valid user accounting information.
1909   (define RUN_LVL 1)                    ;The system's runlevel.
1910   (define BOOT_TIME 2)                  ;Time of system boot.
1911   (define NEW_TIME 3)                   ;Time after system clock changed.
1912   (define OLD_TIME 4)                   ;Time when system clock changed.
1913
1914   (define INIT_PROCESS 5)                ;Process spawned by the init process.
1915   (define LOGIN_PROCESS 6)               ;Session leader of a logged in user.
1916   (define USER_PROCESS 7)                ;Normal process.
1917   (define DEAD_PROCESS 8)                ;Terminated process.
1918
1919   (define ACCOUNTING 9))                 ;System accounting.
1920
1921 (define setutxent
1922   (let ((proc (syscall->procedure void "setutxent" '())))
1923     (lambda ()
1924       "Open the user accounting database."
1925       (proc))))
1926
1927 (define endutxent
1928   (let ((proc (syscall->procedure void "endutxent" '())))
1929     (lambda ()
1930       "Close the user accounting database."
1931       (proc))))
1932
1933 (define getutxent
1934   (let ((proc (syscall->procedure '* "getutxent" '())))
1935     (lambda ()
1936       "Return the next entry from the user accounting database."
1937       (let ((ptr (proc)))
1938         (if (null-pointer? ptr)
1939             #f
1940             (read-utmpx (pointer->bytevector ptr sizeof-utmpx)))))))
1941
1942 (define (utmpx-entries)
1943   "Return the list of entries read from the user accounting database."
1944   (setutxent)
1945   (let loop ((entries '()))
1946     (match (getutxent)
1947       (#f
1948        (endutxent)
1949        (reverse entries))
1950       ((? utmpx? entry)
1951        (loop (cons entry entries))))))
1952
1953 (define (read-utmpx-from-port port)
1954   "Read a utmpx entry from PORT.  Return either the EOF object or a utmpx
1955 entry."
1956   (match (get-bytevector-n port sizeof-utmpx)
1957     ((? eof-object? eof)
1958      eof)
1959     ((? bytevector? bv)
1960      (read-utmpx bv))))
1961
1962 ;;; syscalls.scm ends here