guix/build/syscalls.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2015 David Thompson <davet@gnu.org>
   4 ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
   5 ;;;
   6 ;;; This file is part of GNU Guix.
   7 ;;;
   8 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   9 ;;; under the terms of the GNU General Public License as published by
  10 ;;; the Free Software Foundation; either version 3 of the License, or (at
  11 ;;; your option) any later version.
  12 ;;;
  13 ;;; GNU Guix is distributed in the hope that it will be useful, but
  14 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  15 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 ;;; GNU General Public License for more details.
  17 ;;;
  18 ;;; You should have received a copy of the GNU General Public License
  19 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  20
  21 (define-module (guix build syscalls)
  22   #:use-module (system foreign)
  23   #:use-module (rnrs bytevectors)
  24   #:use-module (srfi srfi-1)
  25   #:use-module (srfi srfi-9)
  26   #:use-module (srfi srfi-9 gnu)
  27   #:use-module (ice-9 rdelim)
  28   #:use-module (ice-9 regex)
  29   #:use-module (ice-9 match)
  30   #:use-module (ice-9 ftw)
  31   #:export (errno
  32             MS_RDONLY
  33             MS_NOSUID
  34             MS_NODEV
  35             MS_NOEXEC
  36             MS_REMOUNT
  37             MS_BIND
  38             MS_MOVE
  39             MS_STRICTATIME
  40             MNT_FORCE
  41             MNT_DETACH
  42             MNT_EXPIRE
  43             UMOUNT_NOFOLLOW
  44             restart-on-EINTR
  45             mount
  46             umount
  47             mount-points
  48             swapon
  49             swapoff
  50
  51             file-system?
  52             file-system-type
  53             file-system-block-size
  54             file-system-block-count
  55             file-system-blocks-free
  56             file-system-blocks-available
  57             file-system-file-count
  58             file-system-free-file-nodes
  59             file-system-identifier
  60             file-system-maximum-name-length
  61             file-system-fragment-size
  62             file-system-mount-flags
  63             statfs
  64
  65             processes
  66             mkdtemp!
  67             fdatasync
  68             pivot-root
  69             fcntl-flock
  70
  71             CLONE_CHILD_CLEARTID
  72             CLONE_CHILD_SETTID
  73             CLONE_NEWNS
  74             CLONE_NEWUTS
  75             CLONE_NEWIPC
  76             CLONE_NEWUSER
  77             CLONE_NEWPID
  78             CLONE_NEWNET
  79             clone
  80             setns
  81
  82             PF_PACKET
  83             AF_PACKET
  84             IFF_UP
  85             IFF_BROADCAST
  86             IFF_LOOPBACK
  87             all-network-interface-names
  88             network-interface-names
  89             network-interface-flags
  90             loopback-network-interface?
  91             network-interface-address
  92             set-network-interface-flags
  93             set-network-interface-address
  94             set-network-interface-up
  95             configure-network-interface
  96
  97             interface?
  98             interface-name
  99             interface-flags
 100             interface-address
 101             interface-netmask
 102             interface-broadcast-address
 103             network-interfaces
 104
 105             termios?
 106             termios-input-flags
 107             termios-output-flags
 108             termios-control-flags
 109             termios-local-flags
 110             termios-line-discipline
 111             termios-control-chars
 112             termios-input-speed
 113             termios-output-speed
 114             local-flags
 115             tcsetattr-action
 116             tcgetattr
 117             tcsetattr
 118
 119             window-size?
 120             window-size-rows
 121             window-size-columns
 122             window-size-x-pixels
 123             window-size-y-pixels
 124             terminal-window-size
 125             terminal-columns))
 126
 127 ;;; Commentary:
 128 ;;;
 129 ;;; This module provides bindings to libc's syscall wrappers.  It uses the
 130 ;;; FFI, and thus requires a dynamically-linked Guile.  (For statically-linked
 131 ;;; Guile, we instead apply 'guile-linux-syscalls.patch'.)
 132 ;;;
 133 ;;; Code:
 134
 135 \f
 136 ;;;
 137 ;;; Packed structures.
 138 ;;;
 139
 140 (define-syntax sizeof*
 141   ;; XXX: This duplicates 'compile-time-value'.
 142   (syntax-rules (int128 array)
 143     ((_ int128)
 144      16)
 145     ((_ (array type n))
 146      (* (sizeof* type) n))
 147     ((_ type)
 148      (let-syntax ((v (lambda (s)
 149                        (let ((val (sizeof type)))
 150                          (syntax-case s ()
 151                            (_ val))))))
 152        v))))
 153
 154 (define-syntax alignof*
 155   ;; XXX: This duplicates 'compile-time-value'.
 156   (syntax-rules (int128 array)
 157     ((_ int128)
 158      16)
 159     ((_ (array type n))
 160      (alignof* type))
 161     ((_ type)
 162      (let-syntax ((v (lambda (s)
 163                        (let ((val (alignof type)))
 164                          (syntax-case s ()
 165                            (_ val))))))
 166        v))))
 167
 168 (define-syntax align                             ;as found in (system foreign)
 169   (syntax-rules (~)
 170     "Add to OFFSET whatever it takes to get proper alignment for TYPE."
 171     ((_ offset (type ~ endianness))
 172      (align offset type))
 173     ((_ offset type)
 174      (1+ (logior (1- offset) (1- (alignof* type)))))))
 175
 176 (define-syntax type-size
 177   (syntax-rules (~)
 178     ((_ (type ~ order))
 179      (sizeof* type))
 180     ((_ type)
 181      (sizeof* type))))
 182
 183 (define-syntax struct-alignment
 184   (syntax-rules ()
 185     "Compute the alignment for the aggregate made of TYPES at OFFSET.  The
 186 result is the alignment of the \"most strictly aligned component\"."
 187     ((_ offset types ...)
 188      (max (align offset types) ...))))
 189
 190 (define-syntax struct-size
 191   (syntax-rules ()
 192     "Return the size in bytes of the structure made of TYPES."
 193     ((_ offset (types-processed ...))
 194      ;; The SysV ABI P.S. says: "Aggregates (structures and arrays) and unions
 195      ;; assume the alignment of their most strictly aligned component."  As an
 196      ;; example, a struct such as "int32, int16" has size 8, not 6.
 197      (1+ (logior (1- offset)
 198                  (1- (struct-alignment offset types-processed ...)))))
 199     ((_ offset (types-processed ...) type0 types ...)
 200      (struct-size (+ (type-size type0) (align offset type0))
 201                   (type0 types-processed ...)
 202                   types ...))))
 203
 204 (define-syntax write-type
 205   (syntax-rules (~ array)
 206     ((_ bv offset (type ~ order) value)
 207      (bytevector-uint-set! bv offset value
 208                            (endianness order) (sizeof* type)))
 209     ((_ bv offset (array type n) value)
 210      (let loop ((i 0)
 211                 (value value)
 212                 (o offset))
 213        (unless (= i n)
 214          (match value
 215            ((head . tail)
 216             (write-type bv o type head)
 217             (loop (+ 1 i) tail (+ o (sizeof* type))))))))
 218     ((_ bv offset type value)
 219      (bytevector-uint-set! bv offset value
 220                            (native-endianness) (sizeof* type)))))
 221
 222 (define-syntax write-types
 223   (syntax-rules ()
 224     ((_ bv offset () ())
 225      #t)
 226     ((_ bv offset (type0 types ...) (field0 fields ...))
 227      (begin
 228        (write-type bv (align offset type0) type0 field0)
 229        (write-types bv
 230                     (+ (align offset type0) (type-size type0))
 231                     (types ...) (fields ...))))))
 232
 233 (define-syntax read-type
 234   (syntax-rules (~ array quote *)
 235     ((_ bv offset '*)
 236      (make-pointer (bytevector-uint-ref bv offset
 237                                         (native-endianness)
 238                                         (sizeof* '*))))
 239     ((_ bv offset (type ~ order))
 240      (bytevector-uint-ref bv offset
 241                           (endianness order) (sizeof* type)))
 242     ((_ bv offset (array type n))
 243      (unfold (lambda (i) (= i n))
 244              (lambda (i)
 245                (read-type bv (+ offset (* i (sizeof* type))) type))
 246              1+
 247              0))
 248     ((_ bv offset type)
 249      (bytevector-uint-ref bv offset
 250                           (native-endianness) (sizeof* type)))))
 251
 252 (define-syntax read-types
 253   (syntax-rules ()
 254     ((_ return bv offset () (values ...))
 255      (return values ...))
 256     ((_ return bv offset (type0 types ...) (values ...))
 257      (read-types return
 258                  bv
 259                  (+ (align offset type0) (type-size type0))
 260                  (types ...)
 261                  (values ... (read-type bv
 262                                         (align offset type0)
 263                                         type0))))))
 264
 265 (define-syntax define-c-struct
 266   (syntax-rules ()
 267     "Define SIZE as the size in bytes of the C structure made of FIELDS.  READ
 268 as a deserializer and WRITE! as a serializer for the C structure with the
 269 given TYPES.  READ uses WRAP-FIELDS to return its value."
 270     ((_ name size wrap-fields read write! (fields types) ...)
 271      (begin
 272        (define size
 273          (struct-size 0 () types ...))
 274        (define (write! bv offset fields ...)
 275          (write-types bv offset (types ...) (fields ...)))
 276        (define* (read bv #:optional (offset 0))
 277          (read-types wrap-fields bv offset (types ...) ()))))))
 278
 279 \f
 280 ;;;
 281 ;;; FFI.
 282 ;;;
 283
 284 (define %libc-errno-pointer
 285   ;; Glibc's 'errno' pointer.
 286   (let ((errno-loc (dynamic-func "__errno_location" (dynamic-link))))
 287     (and errno-loc
 288          (let ((proc (pointer->procedure '* errno-loc '())))
 289            (proc)))))
 290
 291 (define errno
 292   (if %libc-errno-pointer
 293       (let ((bv (pointer->bytevector %libc-errno-pointer (sizeof int))))
 294         (lambda ()
 295           "Return the current errno."
 296           ;; XXX: We assume that nothing changes 'errno' while we're doing all this.
 297           ;; In particular, that means that no async must be running here.
 298
 299           ;; Use one of the fixed-size native-ref procedures because they are
 300           ;; optimized down to a single VM instruction, which reduces the risk
 301           ;; that we fiddle with 'errno' (needed on Guile 2.0.5, libc 2.11.)
 302           (let-syntax ((ref (lambda (s)
 303                               (syntax-case s ()
 304                                 ((_ bv)
 305                                  (case (sizeof int)
 306                                    ((4)
 307                                     #'(bytevector-s32-native-ref bv 0))
 308                                    ((8)
 309                                     #'(bytevector-s64-native-ref bv 0))
 310                                    (else
 311                                     (error "unsupported 'int' size"
 312                                            (sizeof int)))))))))
 313             (ref bv))))
 314       (lambda () 0)))
 315
 316 (define (call-with-restart-on-EINTR thunk)
 317   (let loop ()
 318     (catch 'system-error
 319       thunk
 320       (lambda args
 321         (if (= (system-error-errno args) EINTR)
 322             (loop)
 323             (apply throw args))))))
 324
 325 (define-syntax-rule (restart-on-EINTR expr)
 326   "Evaluate EXPR and restart upon EINTR.  Return the value of EXPR."
 327   (call-with-restart-on-EINTR (lambda () expr)))
 328
 329 (define (syscall->procedure return-type name argument-types)
 330   "Return a procedure that wraps the C function NAME using the dynamic FFI.
 331 If an error occurs while creating the binding, defer the error report until
 332 the returned procedure is called."
 333   (catch #t
 334     (lambda ()
 335       (let ((ptr (dynamic-func name (dynamic-link))))
 336         (pointer->procedure return-type ptr argument-types)))
 337     (lambda args
 338       (lambda _
 339         (error (format #f "~a: syscall->procedure failed: ~s"
 340                        name args))))))
 341
 342 \f
 343 ;;;
 344 ;;; File systems.
 345 ;;;
 346
 347 (define (augment-mtab source target type options)
 348   "Augment /etc/mtab with information about the given mount point."
 349   (let ((port (open-file "/etc/mtab" "a")))
 350     (format port "~a ~a ~a ~a 0 0~%"
 351             source target type (or options "rw"))
 352     (close-port port)))
 353
 354 (define (read-mtab port)
 355   "Read an mtab-formatted file from PORT, returning a list of tuples."
 356   (let loop ((result '()))
 357     (let ((line (read-line port)))
 358       (if (eof-object? line)
 359           (reverse result)
 360           (loop (cons (string-tokenize line) result))))))
 361
 362 (define (remove-from-mtab target)
 363   "Remove mount point TARGET from /etc/mtab."
 364   (define entries
 365     (remove (match-lambda
 366              ((device mount-point type options freq passno)
 367               (string=? target mount-point))
 368              (_ #f))
 369             (call-with-input-file "/etc/mtab" read-mtab)))
 370
 371   (call-with-output-file "/etc/mtab"
 372     (lambda (port)
 373       (for-each (match-lambda
 374                  ((device mount-point type options freq passno)
 375                   (format port "~a ~a ~a ~a ~a ~a~%"
 376                           device mount-point type options freq passno)))
 377                 entries))))
 378
 379 ;; Linux mount flags, from libc's <sys/mount.h>.
 380 (define MS_RDONLY             1)
 381 (define MS_NOSUID             2)
 382 (define MS_NODEV              4)
 383 (define MS_NOEXEC             8)
 384 (define MS_REMOUNT           32)
 385 (define MS_BIND            4096)
 386 (define MS_MOVE            8192)
 387 (define MS_STRICTATIME 16777216)
 388
 389 (define MNT_FORCE       1)
 390 (define MNT_DETACH      2)
 391 (define MNT_EXPIRE      4)
 392 (define UMOUNT_NOFOLLOW 8)
 393
 394 (define mount
 395   (let ((proc (syscall->procedure int "mount" `(* * * ,unsigned-long *))))
 396     (lambda* (source target type #:optional (flags 0) options
 397                      #:key (update-mtab? #f))
 398       "Mount device SOURCE on TARGET as a file system TYPE.  Optionally, FLAGS
 399 may be a bitwise-or of the MS_* <sys/mount.h> constants, and OPTIONS may be a
 400 string.  When FLAGS contains MS_REMOUNT, SOURCE and TYPE are ignored.  When
 401 UPDATE-MTAB? is true, update /etc/mtab.  Raise a 'system-error' exception on
 402 error."
 403       (let ((ret (proc (if source
 404                            (string->pointer source)
 405                            %null-pointer)
 406                        (string->pointer target)
 407                        (if type
 408                            (string->pointer type)
 409                            %null-pointer)
 410                        flags
 411                        (if options
 412                            (string->pointer options)
 413                            %null-pointer)))
 414             (err (errno)))
 415         (unless (zero? ret)
 416           (throw 'system-error "mount" "mount ~S on ~S: ~A"
 417                  (list source target (strerror err))
 418                  (list err)))
 419         (when update-mtab?
 420           (augment-mtab source target type options))))))
 421
 422 (define umount
 423   (let ((proc (syscall->procedure int "umount2" `(* ,int))))
 424     (lambda* (target #:optional (flags 0)
 425                      #:key (update-mtab? #f))
 426       "Unmount TARGET.  Optionally FLAGS may be one of the MNT_* or UMOUNT_*
 427 constants from <sys/mount.h>."
 428       (let ((ret (proc (string->pointer target) flags))
 429             (err (errno)))
 430         (unless (zero? ret)
 431           (throw 'system-error "umount" "~S: ~A"
 432                  (list target (strerror err))
 433                  (list err)))
 434         (when update-mtab?
 435           (remove-from-mtab target))))))
 436
 437 (define (mount-points)
 438   "Return the mounts points for currently mounted file systems."
 439   (call-with-input-file "/proc/mounts"
 440     (lambda (port)
 441       (let loop ((result '()))
 442         (let ((line (read-line port)))
 443           (if (eof-object? line)
 444               (reverse result)
 445               (match (string-tokenize line)
 446                 ((source mount-point _ ...)
 447                  (loop (cons mount-point result))))))))))
 448
 449 (define swapon
 450   (let ((proc (syscall->procedure int "swapon" (list '* int))))
 451     (lambda* (device #:optional (flags 0))
 452       "Use the block special device at DEVICE for swapping."
 453       (let ((ret (proc (string->pointer device) flags))
 454             (err (errno)))
 455         (unless (zero? ret)
 456           (throw 'system-error "swapon" "~S: ~A"
 457                  (list device (strerror err))
 458                  (list err)))))))
 459
 460 (define swapoff
 461   (let ((proc (syscall->procedure int "swapoff" '(*))))
 462     (lambda (device)
 463       "Stop using block special device DEVICE for swapping."
 464       (let ((ret (proc (string->pointer device)))
 465             (err (errno)))
 466         (unless (zero? ret)
 467           (throw 'system-error "swapoff" "~S: ~A"
 468                  (list device (strerror err))
 469                  (list err)))))))
 470
 471 (define (kernel? pid)
 472   "Return #t if PID designates a \"kernel thread\" rather than a normal
 473 user-land process."
 474   (let ((stat (call-with-input-file (format #f "/proc/~a/stat" pid)
 475                 (compose string-tokenize read-string))))
 476     ;; See proc.txt in Linux's documentation for the list of fields.
 477     (match stat
 478       ((pid tcomm state ppid pgrp sid tty_nr tty_pgrp flags min_flt
 479             cmin_flt maj_flt cmaj_flt utime stime cutime cstime
 480             priority nice num_thread it_real_value start_time
 481             vsize rss rsslim
 482             (= string->number start_code) (= string->number end_code) _ ...)
 483        ;; Got this obscure trick from sysvinit's 'killall5' program.
 484        (and (zero? start_code) (zero? end_code))))))
 485
 486 (define (processes)
 487   "Return the list of live processes."
 488   (sort (filter-map (lambda (file)
 489                       (let ((pid (string->number file)))
 490                         (and pid
 491                              (not (kernel? pid))
 492                              pid)))
 493                     (scandir "/proc"))
 494         <))
 495
 496 (define mkdtemp!
 497   (let ((proc (syscall->procedure '* "mkdtemp" '(*))))
 498     (lambda (tmpl)
 499       "Create a new unique directory in the file system using the template
 500 string TMPL and return its file name.  TMPL must end with 'XXXXXX'."
 501       (let ((result (proc (string->pointer tmpl)))
 502             (err    (errno)))
 503         (when (null-pointer? result)
 504           (throw 'system-error "mkdtemp!" "~S: ~A"
 505                  (list tmpl (strerror err))
 506                  (list err)))
 507         (pointer->string result)))))
 508
 509 (define fdatasync
 510   (let ((proc (syscall->procedure int "fdatasync" (list int))))
 511     (lambda (port)
 512       "Flush buffered output of PORT, an output file port, and then call
 513 fdatasync(2) on the underlying file descriptor."
 514       (force-output port)
 515       (let* ((fd  (fileno port))
 516              (ret (proc fd))
 517              (err (errno)))
 518         (unless (zero? ret)
 519           (throw 'system-error "fdatasync" "~S: ~A"
 520                  (list fd (strerror err))
 521                  (list err)))))))
 522
 523
 524 (define-record-type <file-system>
 525   (file-system type block-size blocks blocks-free
 526                blocks-available files free-files identifier
 527                name-length fragment-size mount-flags spare)
 528   file-system?
 529   (type              file-system-type)
 530   (block-size        file-system-block-size)
 531   (blocks            file-system-block-count)
 532   (blocks-free       file-system-blocks-free)
 533   (blocks-available  file-system-blocks-available)
 534   (files             file-system-file-count)
 535   (free-files        file-system-free-file-nodes)
 536   (identifier        file-system-identifier)
 537   (name-length       file-system-maximum-name-length)
 538   (fragment-size     file-system-fragment-size)
 539   (mount-flags       file-system-mount-flags)
 540   (spare             file-system--spare))
 541
 542 (define-syntax fsword                             ;fsword_t
 543   (identifier-syntax long))
 544
 545 (define-c-struct %statfs                          ;<bits/statfs.h>
 546   sizeof-statfs                                   ;slightly overestimated
 547   file-system
 548   read-statfs
 549   write-statfs!
 550   (type             fsword)
 551   (block-size       fsword)
 552   (blocks           uint64)
 553   (blocks-free      uint64)
 554   (blocks-available uint64)
 555   (files            uint64)
 556   (free-files       uint64)
 557   (identifier       (array int 2))
 558   (name-length      fsword)
 559   (fragment-size    fsword)
 560   (mount-flags      fsword)
 561   (spare            (array fsword 4)))
 562
 563 (define statfs
 564   (let ((proc (syscall->procedure int "statfs64" '(* *))))
 565     (lambda (file)
 566       "Return a <file-system> data structure describing the file system
 567 mounted at FILE."
 568       (let* ((stat (make-bytevector sizeof-statfs))
 569              (ret  (proc (string->pointer file) (bytevector->pointer stat)))
 570              (err  (errno)))
 571         (if (zero? ret)
 572             (read-statfs stat)
 573             (throw 'system-error "statfs" "~A: ~A"
 574                    (list file (strerror err))
 575                    (list err)))))))
 576
 577 \f
 578 ;;;
 579 ;;; Containers.
 580 ;;;
 581
 582 ;; Linux clone flags, from linux/sched.h
 583 (define CLONE_CHILD_CLEARTID #x00200000)
 584 (define CLONE_CHILD_SETTID   #x01000000)
 585 (define CLONE_NEWNS          #x00020000)
 586 (define CLONE_NEWUTS         #x04000000)
 587 (define CLONE_NEWIPC         #x08000000)
 588 (define CLONE_NEWUSER        #x10000000)
 589 (define CLONE_NEWPID         #x20000000)
 590 (define CLONE_NEWNET         #x40000000)
 591
 592 ;; The libc interface to sys_clone is not useful for Scheme programs, so the
 593 ;; low-level system call is wrapped instead.  The 'syscall' function is
 594 ;; declared in <unistd.h> as a variadic function; in practice, it expects 6
 595 ;; pointer-sized arguments, as shown in, e.g., x86_64/syscall.S.
 596 (define clone
 597   (let* ((proc (syscall->procedure int "syscall"
 598                                    (list long                   ;sysno
 599                                          unsigned-long          ;flags
 600                                          '* '* '*
 601                                          '*)))
 602          ;; TODO: Don't do this.
 603          (syscall-id (match (utsname:machine (uname))
 604                        ("i686"   120)
 605                        ("x86_64" 56)
 606                        ("mips64" 5055)
 607                        ("armv7l" 120)
 608                        (_ #f))))
 609     (lambda (flags)
 610       "Create a new child process by duplicating the current parent process.
 611 Unlike the fork system call, clone accepts FLAGS that specify which resources
 612 are shared between the parent and child processes."
 613       (let ((ret (proc syscall-id flags
 614                        %null-pointer               ;child stack
 615                        %null-pointer %null-pointer ;ptid & ctid
 616                        %null-pointer))             ;unused
 617             (err (errno)))
 618         (if (= ret -1)
 619             (throw 'system-error "clone" "~d: ~A"
 620                    (list flags (strerror err))
 621                    (list err))
 622             ret)))))
 623
 624 (define setns
 625   ;; Some systems may be using an old (pre-2.14) version of glibc where there
 626   ;; is no 'setns' function available.
 627   (false-if-exception
 628    (let ((proc (syscall->procedure int "setns" (list int int))))
 629      (lambda (fdes nstype)
 630        "Reassociate the current process with the namespace specified by FDES, a
 631 file descriptor obtained by opening a /proc/PID/ns/* file.  NSTYPE specifies
 632 which type of namespace the current process may be reassociated with, or 0 if
 633 there is no such limitation."
 634        (let ((ret (proc fdes nstype))
 635              (err (errno)))
 636          (unless (zero? ret)
 637            (throw 'system-error "setns" "~d ~d: ~A"
 638                   (list fdes nstype (strerror err))
 639                   (list err))))))))
 640
 641 (define pivot-root
 642   (let ((proc (syscall->procedure int "pivot_root" (list '* '*))))
 643     (lambda (new-root put-old)
 644       "Change the root file system to NEW-ROOT and move the current root file
 645 system to PUT-OLD."
 646       (let ((ret (proc (string->pointer new-root)
 647                        (string->pointer put-old)))
 648             (err (errno)))
 649         (unless (zero? ret)
 650           (throw 'system-error "pivot_root" "~S ~S: ~A"
 651                  (list new-root put-old (strerror err))
 652                  (list err)))))))
 653
 654 \f
 655 ;;;
 656 ;;; Advisory file locking.
 657 ;;;
 658
 659 (define-c-struct %struct-flock                    ;<fcntl.h>
 660   sizeof-flock
 661   list
 662   read-flock
 663   write-flock!
 664   (type   short)
 665   (whence short)
 666   (start  size_t)
 667   (length size_t)
 668   (pid    int))
 669
 670 (define F_SETLKW
 671   ;; On Linux-based systems, this is usually 7, but not always
 672   ;; (exceptions include SPARC.)  On GNU/Hurd, it's 9.
 673   (cond ((string-contains %host-type "sparc") 9)  ; sparc-*-linux-gnu
 674         ((string-contains %host-type "linux") 7)  ; *-linux-gnu
 675         (else 9)))                                ; *-gnu*
 676
 677 (define F_SETLK
 678   ;; Likewise: GNU/Hurd and SPARC use 8, while the others typically use 6.
 679   (cond ((string-contains %host-type "sparc") 8)  ; sparc-*-linux-gnu
 680         ((string-contains %host-type "linux") 6)  ; *-linux-gnu
 681         (else 8)))                                ; *-gnu*
 682
 683 (define F_xxLCK
 684   ;; The F_RDLCK, F_WRLCK, and F_UNLCK constants.
 685   (cond ((string-contains %host-type "sparc") #(1 2 3))    ; sparc-*-linux-gnu
 686         ((string-contains %host-type "hppa")  #(1 2 3))    ; hppa-*-linux-gnu
 687         ((string-contains %host-type "linux") #(0 1 2))    ; *-linux-gnu
 688         (else                                 #(1 2 3))))  ; *-gnu*
 689
 690 (define fcntl-flock
 691   (let ((proc (syscall->procedure int "fcntl" `(,int ,int *))))
 692     (lambda* (fd-or-port operation #:key (wait? #t))
 693       "Perform locking OPERATION on the file beneath FD-OR-PORT.  OPERATION
 694 must be a symbol, one of 'read-lock, 'write-lock, or 'unlock.  When WAIT? is
 695 true, block until the lock is acquired; otherwise, thrown an 'flock-error'
 696 exception if it's already taken."
 697       (define (operation->int op)
 698         (case op
 699           ((read-lock)  (vector-ref F_xxLCK 0))
 700           ((write-lock) (vector-ref F_xxLCK 1))
 701           ((unlock)     (vector-ref F_xxLCK 2))
 702           (else         (error "invalid fcntl-flock operation" op))))
 703
 704       (define fd
 705         (if (port? fd-or-port)
 706             (fileno fd-or-port)
 707             fd-or-port))
 708
 709       (define bv
 710         (make-bytevector sizeof-flock))
 711
 712       (write-flock! bv 0
 713                     (operation->int operation) SEEK_SET
 714                     0 0                           ;whole file
 715                     0)
 716
 717       ;; XXX: 'fcntl' is a vararg function, but here we happily use the
 718       ;; standard ABI; crossing fingers.
 719       (let ((ret (proc fd
 720                        (if wait?
 721                            F_SETLKW               ; lock & wait
 722                            F_SETLK)               ; non-blocking attempt
 723                        (bytevector->pointer bv)))
 724             (err (errno)))
 725         (unless (zero? ret)
 726           ;; Presumably we got EAGAIN or so.
 727           (throw 'flock-error err))))))
 728
 729 \f
 730 ;;;
 731 ;;; Network interfaces.
 732 ;;;
 733
 734 (define SIOCGIFCONF                               ;from <bits/ioctls.h>
 735   (if (string-contains %host-type "linux")
 736       #x8912                                      ;GNU/Linux
 737       #xf00801a4))                                ;GNU/Hurd
 738 (define SIOCGIFFLAGS
 739   (if (string-contains %host-type "linux")
 740       #x8913                                      ;GNU/Linux
 741       #xc4804191))                                ;GNU/Hurd
 742 (define SIOCSIFFLAGS
 743   (if (string-contains %host-type "linux")
 744       #x8914                                      ;GNU/Linux
 745       -1))                                        ;FIXME: GNU/Hurd?
 746 (define SIOCGIFADDR
 747   (if (string-contains %host-type "linux")
 748       #x8915                                      ;GNU/Linux
 749       -1))                                        ;FIXME: GNU/Hurd?
 750 (define SIOCSIFADDR
 751   (if (string-contains %host-type "linux")
 752       #x8916                                      ;GNU/Linux
 753       -1))                                        ;FIXME: GNU/Hurd?
 754
 755 ;; Flags and constants from <net/if.h>.
 756
 757 (define IFF_UP #x1)                               ;Interface is up
 758 (define IFF_BROADCAST #x2)                        ;Broadcast address valid.
 759 (define IFF_LOOPBACK #x8)                         ;Is a loopback net.
 760
 761 (define IF_NAMESIZE 16)                           ;maximum interface name size
 762
 763 (define ifconf-struct
 764   ;; 'struct ifconf', from <net/if.h>.
 765   (list int                                       ;int ifc_len
 766         '*))                                      ;struct ifreq *ifc_ifcu
 767
 768 (define ifreq-struct-size
 769   ;; 'struct ifreq' begins with an array of IF_NAMESIZE bytes containing the
 770   ;; interface name (nul-terminated), followed by a bunch of stuff.  This is
 771   ;; its size in bytes.
 772   (if (= 8 (sizeof '*))
 773       40
 774       32))
 775
 776 (define-c-struct sockaddr-in                      ;<linux/in.h>
 777   sizeof-sockaddrin
 778   (lambda (family port address)
 779     (make-socket-address family address port))
 780   read-sockaddr-in
 781   write-sockaddr-in!
 782   (family    unsigned-short)
 783   (port      (int16 ~ big))
 784   (address   (int32 ~ big)))
 785
 786 (define-c-struct sockaddr-in6                     ;<linux/in6.h>
 787   sizeof-sockaddr-in6
 788   (lambda (family port flowinfo address scopeid)
 789     (make-socket-address family address port flowinfo scopeid))
 790   read-sockaddr-in6
 791   write-sockaddr-in6!
 792   (family    unsigned-short)
 793   (port      (int16 ~ big))
 794   (flowinfo  (int32 ~ big))
 795   (address   (int128 ~ big))
 796   (scopeid   int32))
 797
 798 (define (write-socket-address! sockaddr bv index)
 799   "Write SOCKADDR, a socket address as returned by 'make-socket-address', to
 800 bytevector BV at INDEX."
 801   (let ((family (sockaddr:fam sockaddr)))
 802     (cond ((= family AF_INET)
 803            (write-sockaddr-in! bv index
 804                                family
 805                                (sockaddr:port sockaddr)
 806                                (sockaddr:addr sockaddr)))
 807           ((= family AF_INET6)
 808            (write-sockaddr-in6! bv index
 809                                 family
 810                                 (sockaddr:port sockaddr)
 811                                 (sockaddr:flowinfo sockaddr)
 812                                 (sockaddr:addr sockaddr)
 813                                 (sockaddr:scopeid sockaddr)))
 814           (else
 815            (error "unsupported socket address" sockaddr)))))
 816
 817 (define PF_PACKET 17)                             ;<bits/socket.h>
 818 (define AF_PACKET PF_PACKET)
 819
 820 (define* (read-socket-address bv #:optional (index 0))
 821   "Read a socket address from bytevector BV at INDEX."
 822   (let ((family (bytevector-u16-native-ref bv index)))
 823     (cond ((= family AF_INET)
 824            (read-sockaddr-in bv index))
 825           ((= family AF_INET6)
 826            (read-sockaddr-in6 bv index))
 827           (else
 828            ;; XXX: Unsupported address family, such as AF_PACKET.  Return a
 829            ;; vector such that the vector can at least call 'sockaddr:fam'.
 830            (vector family)))))
 831
 832 (define %ioctl
 833   ;; The most terrible interface, live from Scheme.
 834   (syscall->procedure int "ioctl" (list int unsigned-long '*)))
 835
 836 (define (bytevector->string-list bv stride len)
 837   "Return the null-terminated strings found in BV every STRIDE bytes.  Read at
 838 most LEN bytes from BV."
 839   (let loop ((bytes  (take (bytevector->u8-list bv)
 840                            (min len (bytevector-length bv))))
 841              (result '()))
 842     (match bytes
 843       (()
 844        (reverse result))
 845       (_
 846        (loop (drop bytes stride)
 847              (cons (list->string (map integer->char
 848                                       (take-while (negate zero?) bytes)))
 849                    result))))))
 850
 851 (define* (network-interface-names #:optional sock)
 852   "Return the names of existing network interfaces.  This is typically limited
 853 to interfaces that are currently up."
 854   (let* ((close? (not sock))
 855          (sock   (or sock (socket SOCK_STREAM AF_INET 0)))
 856          (len    (* ifreq-struct-size 10))
 857          (reqs   (make-bytevector len))
 858          (conf   (make-c-struct ifconf-struct
 859                                 (list len (bytevector->pointer reqs))))
 860          (ret    (%ioctl (fileno sock) SIOCGIFCONF conf))
 861          (err    (errno)))
 862     (when close?
 863       (close-port sock))
 864     (if (zero? ret)
 865         (bytevector->string-list reqs ifreq-struct-size
 866                                  (match (parse-c-struct conf ifconf-struct)
 867                                    ((len . _) len)))
 868         (throw 'system-error "network-interface-list"
 869                "network-interface-list: ~A"
 870                (list (strerror err))
 871                (list err)))))
 872
 873 (define %interface-line
 874   ;; Regexp matching an interface line in Linux's /proc/net/dev.
 875   (make-regexp "^[[:blank:]]*([[:graph:]]+):.*$"))
 876
 877 (define (all-network-interface-names)
 878   "Return all the names of the registered network interfaces, including those
 879 that are not up."
 880   (call-with-input-file "/proc/net/dev"           ;XXX: Linux-specific
 881     (lambda (port)
 882       (let loop ((interfaces '()))
 883         (let ((line (read-line port)))
 884           (cond ((eof-object? line)
 885                  (reverse interfaces))
 886                 ((regexp-exec %interface-line line)
 887                  =>
 888                  (lambda (match)
 889                    (loop (cons (match:substring match 1) interfaces))))
 890                 (else
 891                  (loop interfaces))))))))
 892
 893 (define (network-interface-flags socket name)
 894   "Return a number that is the bit-wise or of 'IFF*' flags for network
 895 interface NAME."
 896   (let ((req (make-bytevector ifreq-struct-size)))
 897     (bytevector-copy! (string->utf8 name) 0 req 0
 898                       (min (string-length name) (- IF_NAMESIZE 1)))
 899     (let* ((ret (%ioctl (fileno socket) SIOCGIFFLAGS
 900                         (bytevector->pointer req)))
 901            (err (errno)))
 902       (if (zero? ret)
 903
 904           ;; The 'ifr_flags' field is IF_NAMESIZE bytes after the beginning of
 905           ;; 'struct ifreq', and it's a short int.
 906           (bytevector-sint-ref req IF_NAMESIZE (native-endianness)
 907                                (sizeof short))
 908
 909           (throw 'system-error "network-interface-flags"
 910                  "network-interface-flags on ~A: ~A"
 911                  (list name (strerror err))
 912                  (list err))))))
 913
 914 (define (loopback-network-interface? name)
 915   "Return true if NAME designates a loopback network interface."
 916   (let* ((sock  (socket SOCK_STREAM AF_INET 0))
 917          (flags (network-interface-flags sock name)))
 918     (close-port sock)
 919     (not (zero? (logand flags IFF_LOOPBACK)))))
 920
 921 (define (set-network-interface-flags socket name flags)
 922   "Set the flag of network interface NAME to FLAGS."
 923   (let ((req (make-bytevector ifreq-struct-size)))
 924     (bytevector-copy! (string->utf8 name) 0 req 0
 925                       (min (string-length name) (- IF_NAMESIZE 1)))
 926     ;; Set the 'ifr_flags' field.
 927     (bytevector-uint-set! req IF_NAMESIZE flags (native-endianness)
 928                           (sizeof short))
 929     (let* ((ret (%ioctl (fileno socket) SIOCSIFFLAGS
 930                         (bytevector->pointer req)))
 931            (err (errno)))
 932       (unless (zero? ret)
 933         (throw 'system-error "set-network-interface-flags"
 934                "set-network-interface-flags on ~A: ~A"
 935                (list name (strerror err))
 936                (list err))))))
 937
 938 (define (set-network-interface-address socket name sockaddr)
 939   "Set the address of network interface NAME to SOCKADDR."
 940   (let ((req (make-bytevector ifreq-struct-size)))
 941     (bytevector-copy! (string->utf8 name) 0 req 0
 942                       (min (string-length name) (- IF_NAMESIZE 1)))
 943     ;; Set the 'ifr_addr' field.
 944     (write-socket-address! sockaddr req IF_NAMESIZE)
 945     (let* ((ret (%ioctl (fileno socket) SIOCSIFADDR
 946                         (bytevector->pointer req)))
 947            (err (errno)))
 948       (unless (zero? ret)
 949         (throw 'system-error "set-network-interface-address"
 950                "set-network-interface-address on ~A: ~A"
 951                (list name (strerror err))
 952                (list err))))))
 953
 954 (define (network-interface-address socket name)
 955   "Return the address of network interface NAME.  The result is an object of
 956 the same type as that returned by 'make-socket-address'."
 957   (let ((req (make-bytevector ifreq-struct-size)))
 958     (bytevector-copy! (string->utf8 name) 0 req 0
 959                       (min (string-length name) (- IF_NAMESIZE 1)))
 960     (let* ((ret (%ioctl (fileno socket) SIOCGIFADDR
 961                         (bytevector->pointer req)))
 962            (err (errno)))
 963       (if (zero? ret)
 964           (read-socket-address req IF_NAMESIZE)
 965           (throw 'system-error "network-interface-address"
 966                  "network-interface-address on ~A: ~A"
 967                  (list name (strerror err))
 968                  (list err))))))
 969
 970 (define (configure-network-interface name sockaddr flags)
 971   "Configure network interface NAME to use SOCKADDR, an address as returned by
 972 'make-socket-address', and FLAGS, a bitwise-or of IFF_* constants."
 973   (let ((sock (socket (sockaddr:fam sockaddr) SOCK_STREAM 0)))
 974     (dynamic-wind
 975       (const #t)
 976       (lambda ()
 977         (set-network-interface-address sock name sockaddr)
 978         (set-network-interface-flags sock name flags))
 979       (lambda ()
 980         (close-port sock)))))
 981
 982 (define* (set-network-interface-up name
 983                                    #:key (family AF_INET))
 984   "Turn up the interface NAME."
 985   (let ((sock (socket family SOCK_STREAM 0)))
 986     (dynamic-wind
 987       (const #t)
 988       (lambda ()
 989         (let ((flags (network-interface-flags sock name)))
 990           (set-network-interface-flags sock name
 991                                        (logior flags IFF_UP))))
 992       (lambda ()
 993         (close-port sock)))))
 994
 995 \f
 996 ;;;
 997 ;;; Details about network interfaces---aka. 'getifaddrs'.
 998 ;;;
 999
1000 ;; Network interfaces.  XXX: We would call it <network-interface> but that
1001 ;; would collide with the ioctl wrappers above.
1002 (define-record-type <interface>
1003   (make-interface name flags address netmask broadcast-address)
1004   interface?
1005   (name              interface-name)               ;string
1006   (flags             interface-flags)              ;or'd IFF_* values
1007   (address           interface-address)            ;sockaddr | #f
1008   (netmask           interface-netmask)            ;sockaddr | #f
1009   (broadcast-address interface-broadcast-address)) ;sockaddr | #f
1010
1011 (define (write-interface interface port)
1012   (match interface
1013     (($ <interface> name flags address)
1014      (format port "#<interface ~s " name)
1015      (unless (zero? (logand IFF_UP flags))
1016        (display "up " port))
1017
1018      ;; Check whether ADDRESS really is a sockaddr.
1019      (when address
1020        (if (member (sockaddr:fam address) (list AF_INET AF_INET6))
1021            (format port "~a " (inet-ntop (sockaddr:fam address)
1022                                          (sockaddr:addr address)))
1023            (format port "family:~a " (sockaddr:fam address))))
1024
1025      (format port "~a>" (number->string (object-address interface) 16)))))
1026
1027 (set-record-type-printer! <interface> write-interface)
1028
1029 (define (values->interface next name flags address netmask
1030                            broadcast-address data)
1031   "Given the raw field values passed as arguments, return a pair whose car is
1032 an <interface> object, and whose cdr is the pointer NEXT."
1033   (define (maybe-socket-address pointer)
1034     (if (null-pointer? pointer)
1035         #f
1036         (read-socket-address (pointer->bytevector pointer 50)))) ;XXX: size
1037
1038   (cons (make-interface (if (null-pointer? name)
1039                             #f
1040                             (pointer->string name))
1041                         flags
1042                         (maybe-socket-address address)
1043                         (maybe-socket-address netmask)
1044                         (maybe-socket-address broadcast-address)
1045                         ;; Ignore DATA.
1046                         )
1047         next))
1048
1049 (define-c-struct ifaddrs                          ;<ifaddrs.h>
1050   %sizeof-ifaddrs
1051   values->interface
1052   read-ifaddrs
1053   write-ifaddrs!
1054   (next          '*)
1055   (name          '*)
1056   (flags         unsigned-int)
1057   (addr          '*)
1058   (netmask       '*)
1059   (broadcastaddr '*)
1060   (data          '*))
1061
1062 (define (unfold-interface-list ptr)
1063   "Call 'read-ifaddrs' on PTR and all its 'next' fields, recursively, and
1064 return the list of resulting <interface> objects."
1065   (let loop ((ptr    ptr)
1066              (result '()))
1067     (if (null-pointer? ptr)
1068         (reverse result)
1069         (match (read-ifaddrs (pointer->bytevector ptr %sizeof-ifaddrs))
1070           ((ifaddr . ptr)
1071            (loop ptr (cons ifaddr result)))))))
1072
1073 (define network-interfaces
1074   (let ((proc (syscall->procedure int "getifaddrs" (list '*))))
1075     (lambda ()
1076       "Return a list of <interface> objects, each denoting a configured
1077 network interface.  This is implemented using the 'getifaddrs' libc function."
1078       (let* ((ptr (bytevector->pointer (make-bytevector (sizeof* '*))))
1079              (ret (proc ptr))
1080              (err (errno)))
1081         (if (zero? ret)
1082             (let* ((ptr    (dereference-pointer ptr))
1083                    (result (unfold-interface-list ptr)))
1084               (free-ifaddrs ptr)
1085               result)
1086             (throw 'system-error "network-interfaces" "~A"
1087                    (list (strerror err))
1088                    (list err)))))))
1089
1090 (define free-ifaddrs
1091   (syscall->procedure void "freeifaddrs" '(*)))
1092
1093 \f
1094 ;;;
1095 ;;; Terminals.
1096 ;;;
1097
1098 (define-syntax bits->symbols-body
1099   (syntax-rules ()
1100     ((_ bits () ())
1101      '())
1102     ((_ bits (name names ...) (value values ...))
1103      (let ((result (bits->symbols-body bits (names ...) (values ...))))
1104        (if (zero? (logand bits value))
1105            result
1106            (cons 'name result))))))
1107
1108 (define-syntax define-bits
1109   (syntax-rules (define)
1110     "Define the given numerical constants under CONSTRUCTOR, such that
1111  (CONSTRUCTOR NAME) returns VALUE.  Define BITS->SYMBOLS as a procedure that,
1112 given an integer, returns the list of names of the constants that are or'd."
1113     ((_ constructor bits->symbols (define names values) ...)
1114      (begin
1115        (define-syntax constructor
1116          (syntax-rules (names ...)
1117            ((_ names) values) ...
1118            ((_ several (... ...))
1119             (logior (constructor several) (... ...)))))
1120        (define (bits->symbols bits)
1121          (bits->symbols-body bits (names ...) (values ...)))
1122        (define names values) ...))))
1123
1124 ;; 'local-flags' bits from <bits/termios.h>
1125 (define-bits local-flags
1126   local-flags->symbols
1127  (define ISIG #o0000001)
1128  (define ICANON #o0000002)
1129  (define XCASE #o0000004)
1130  (define ECHO #o0000010)
1131  (define ECHOE #o0000020)
1132  (define ECHOK #o0000040)
1133  (define ECHONL #o0000100)
1134  (define NOFLSH #o0000200)
1135  (define TOSTOP #o0000400)
1136  (define ECHOCTL #o0001000)
1137  (define ECHOPRT #o0002000)
1138  (define ECHOKE #o0004000)
1139  (define FLUSHO #o0010000)
1140  (define PENDIN #o0040000)
1141  (define IEXTEN #o0100000)
1142  (define EXTPROC #o0200000))
1143
1144 ;; "Actions" values for 'tcsetattr'.
1145 (define-bits tcsetattr-action
1146   %unused-tcsetattr-action->symbols
1147   (define TCSANOW  0)
1148   (define TCSADRAIN 1)
1149   (define TCSAFLUSH 2))
1150
1151 (define-record-type <termios>
1152   (termios input-flags output-flags control-flags local-flags
1153            line-discipline control-chars
1154            input-speed output-speed)
1155   termios?
1156   (input-flags      termios-input-flags)
1157   (output-flags     termios-output-flags)
1158   (control-flags    termios-control-flags)
1159   (local-flags      termios-local-flags)
1160   (line-discipline  termios-line-discipline)
1161   (control-chars    termios-control-chars)
1162   (input-speed      termios-input-speed)
1163   (output-speed     termios-output-speed))
1164
1165 (define-c-struct %termios                         ;<bits/termios.h>
1166   sizeof-termios
1167   termios
1168   read-termios
1169   write-termios!
1170   (input-flags      unsigned-int)
1171   (output-flags     unsigned-int)
1172   (control-flags    unsigned-int)
1173   (local-flags      unsigned-int)
1174   (line-discipline  uint8)
1175   (control-chars    (array uint8 32))
1176   (input-speed      unsigned-int)
1177   (output-speed     unsigned-int))
1178
1179 (define tcgetattr
1180   (let ((proc (syscall->procedure int "tcgetattr" (list int '*))))
1181     (lambda (fd)
1182       "Return the <termios> structure for the tty at FD."
1183       (let* ((bv  (make-bytevector sizeof-termios))
1184              (ret (proc fd (bytevector->pointer bv)))
1185              (err (errno)))
1186         (if (zero? ret)
1187             (read-termios bv)
1188             (throw 'system-error "tcgetattr" "~A"
1189                    (list (strerror err))
1190                    (list err)))))))
1191
1192 (define tcsetattr
1193   (let ((proc (syscall->procedure int "tcsetattr" (list int int '*))))
1194     (lambda (fd actions termios)
1195       "Use TERMIOS for the tty at FD.  ACTIONS is one of of the values
1196 produced by 'tcsetattr-action'; see tcsetattr(3) for details."
1197       (define bv
1198         (make-bytevector sizeof-termios))
1199
1200       (let-syntax ((match/write (syntax-rules ()
1201                                   ((_ fields ...)
1202                                    (match termios
1203                                      (($ <termios> fields ...)
1204                                       (write-termios! bv 0 fields ...)))))))
1205         (match/write input-flags output-flags control-flags local-flags
1206                      line-discipline control-chars input-speed output-speed))
1207
1208       (let ((ret (proc fd actions (bytevector->pointer bv)))
1209             (err (errno)))
1210         (unless (zero? ret)
1211           (throw 'system-error "tcgetattr" "~A"
1212                  (list (strerror err))
1213                  (list err)))))))
1214
1215 (define-syntax TIOCGWINSZ                         ;<asm-generic/ioctls.h>
1216   (identifier-syntax #x5413))
1217
1218 (define-record-type <window-size>
1219   (window-size rows columns x-pixels y-pixels)
1220   window-size?
1221   (rows     window-size-rows)
1222   (columns  window-size-columns)
1223   (x-pixels window-size-x-pixels)
1224   (y-pixels window-size-y-pixels))
1225
1226 (define-c-struct winsize                          ;<bits/ioctl-types.h>
1227   sizeof-winsize
1228   window-size
1229   read-winsize
1230   write-winsize!
1231   (rows          unsigned-short)
1232   (columns       unsigned-short)
1233   (x-pixels      unsigned-short)
1234   (y-pixels      unsigned-short))
1235
1236 (define* (terminal-window-size #:optional (port (current-output-port)))
1237   "Return a <window-size> structure describing the terminal at PORT, or raise
1238 a 'system-error' if PORT is not backed by a terminal.  This procedure
1239 corresponds to the TIOCGWINSZ ioctl."
1240   (let* ((size (make-bytevector sizeof-winsize))
1241          (ret  (%ioctl (fileno port) TIOCGWINSZ
1242                        (bytevector->pointer size)))
1243          (err  (errno)))
1244     (if (zero? ret)
1245         (read-winsize size)
1246         (throw 'system-error "terminal-window-size" "~A"
1247                (list (strerror err))
1248                (list err)))))
1249
1250 (define* (terminal-columns #:optional (port (current-output-port)))
1251   "Return the best approximation of the number of columns of the terminal at
1252 PORT, trying to guess a reasonable value if all else fails.  The result is
1253 always a positive integer."
1254   (define (fall-back)
1255     (match (and=> (getenv "COLUMNS") string->number)
1256       (#f 80)
1257       ((? number? columns)
1258        (if (> columns 0) columns 80))))
1259
1260   (catch 'system-error
1261     (lambda ()
1262       (if (file-port? port)
1263           (match (window-size-columns (terminal-window-size port))
1264             ;; Things like Emacs shell-mode return 0, which is unreasonable.
1265             (0 (fall-back))
1266             ((? number? columns) columns))
1267           (fall-back)))
1268     (lambda args
1269       (let ((errno (system-error-errno args)))
1270         ;; ENOTTY is what we're after but 2012-and-earlier Linux versions
1271         ;; would return EINVAL instead in some cases:
1272         ;; <https://bugs.ruby-lang.org/issues/10494>.
1273         (if (or (= errno ENOTTY) (= errno EINVAL))
1274             (fall-back)
1275             (apply throw args))))))
1276
1277 ;;; syscalls.scm ends here