guix/utils.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2013, 2014, 2015 Mark H Weaver <mhw@netris.org>
   4 ;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org>
   5 ;;; Copyright © 2014 Ian Denhardt <ian@zenhack.net>
   6 ;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>
   7 ;;; Copyright © 2015 David Thompson <davet@gnu.org>
   8 ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
   9 ;;; Copyright © 2018, 2020 Marius Bakke <marius@gnu.org>
  10 ;;; Copyright © 2020 Efraim Flashner <efraim@flashner.co.il>
  11 ;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com>
  12 ;;; Copyright © 2021 Chris Marusich <cmmarusich@gmail.com>
  13 ;;;
  14 ;;; This file is part of GNU Guix.
  15 ;;;
  16 ;;; GNU Guix is free software; you can redistribute it and/or modify it
  17 ;;; under the terms of the GNU General Public License as published by
  18 ;;; the Free Software Foundation; either version 3 of the License, or (at
  19 ;;; your option) any later version.
  20 ;;;
  21 ;;; GNU Guix is distributed in the hope that it will be useful, but
  22 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  23 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  24 ;;; GNU General Public License for more details.
  25 ;;;
  26 ;;; You should have received a copy of the GNU General Public License
  27 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  28
  29 (define-module (guix utils)
  30   #:use-module (guix config)
  31   #:use-module (srfi srfi-1)
  32   #:use-module (srfi srfi-9)
  33   #:use-module (srfi srfi-11)
  34   #:use-module (srfi srfi-26)
  35   #:use-module (srfi srfi-39)
  36   #:use-module (ice-9 ftw)
  37   #:use-module (rnrs io ports)                    ;need 'port-position' etc.
  38   #:use-module ((rnrs bytevectors) #:select (bytevector-u8-set!))
  39   #:use-module (guix memoization)
  40   #:use-module ((guix build utils) #:select (dump-port mkdir-p delete-file-recursively))
  41   #:use-module ((guix build syscalls) #:select (mkdtemp! fdatasync))
  42   #:use-module ((guix combinators) #:select (fold2))
  43   #:use-module (guix diagnostics)           ;<location>, &error-location, etc.
  44   #:use-module (ice-9 format)
  45   #:use-module (ice-9 regex)
  46   #:use-module (ice-9 match)
  47   #:use-module (ice-9 format)
  48   #:use-module ((ice-9 iconv) #:prefix iconv:)
  49   #:autoload   (zlib) (make-zlib-input-port make-zlib-output-port)
  50   #:use-module (system foreign)
  51   #:re-export (<location>                         ;for backwards compatibility
  52                location
  53                location?
  54                location-file
  55                location-line
  56                location-column
  57                source-properties->location
  58                location->source-properties
  59
  60                &error-location
  61                error-location?
  62                error-location
  63
  64                &fix-hint
  65                fix-hint?
  66                condition-fix-hint)
  67   #:export (strip-keyword-arguments
  68             default-keyword-arguments
  69             substitute-keyword-arguments
  70             ensure-keyword-arguments
  71
  72             current-source-directory
  73
  74             nix-system->gnu-triplet
  75             gnu-triplet->nix-system
  76             %current-system
  77             %current-target-system
  78             package-name->name+version
  79             target-mingw?
  80             target-arm32?
  81             target-aarch64?
  82             target-arm?
  83             target-powerpc?
  84             target-64bit?
  85             cc-for-target
  86             cxx-for-target
  87             pkg-config-for-target
  88
  89             version-compare
  90             version>?
  91             version>=?
  92             version-prefix
  93             version-major+minor+point
  94             version-major+minor
  95             version-major
  96             version-unique-prefix
  97             guile-version>?
  98             version-prefix?
  99             string-replace-substring
 100             file-extension
 101             file-sans-extension
 102             tarball-sans-extension
 103             compressed-file?
 104             switch-symlinks
 105             call-with-temporary-output-file
 106             call-with-temporary-directory
 107             with-atomic-file-output
 108
 109             with-environment-variables
 110             arguments-from-environment-variable
 111
 112             config-directory
 113             cache-directory
 114
 115             readlink*
 116             edit-expression
 117
 118             filtered-port
 119             decompressed-port
 120             call-with-decompressed-port
 121             compressed-output-port
 122             call-with-compressed-output-port
 123             canonical-newline-port
 124
 125             string-distance
 126             string-closest))
 127
 128 \f
 129 ;;;
 130 ;;; Environment variables.
 131 ;;;
 132
 133 (define (call-with-environment-variables variables thunk)
 134   "Call THUNK with the environment VARIABLES set."
 135   (let ((environment (environ)))
 136     (dynamic-wind
 137       (lambda ()
 138         (for-each (match-lambda
 139                     ((variable value)
 140                      (setenv variable value)))
 141                   variables))
 142       thunk
 143       (lambda ()
 144         (environ environment)))))
 145
 146 (define-syntax-rule (with-environment-variables variables exp ...)
 147   "Evaluate EXP with the given environment VARIABLES set."
 148   (call-with-environment-variables variables
 149                                    (lambda () exp ...)))
 150
 151 (define (arguments-from-environment-variable variable)
 152   "Retrieve value of environment variable denoted by string VARIABLE in the
 153 form of a list of strings (`char-set:graphic' tokens) suitable for consumption
 154 by `args-fold', if VARIABLE is defined, otherwise return an empty list."
 155   (let ((env (getenv variable)))
 156     (if env
 157         (string-tokenize env char-set:graphic)
 158         '())))
 159
 160 \f
 161 ;;;
 162 ;;; Filtering & pipes.
 163 ;;;
 164
 165 (define (filtered-port command input)
 166   "Return an input port where data drained from INPUT is filtered through
 167 COMMAND (a list).  In addition, return a list of PIDs that the caller must
 168 wait.  When INPUT is a file port, it must be unbuffered; otherwise, any
 169 buffered data is lost."
 170   (let loop ((input input)
 171              (pids  '()))
 172     (if (file-port? input)
 173         (match (pipe)
 174           ((in . out)
 175            (match (primitive-fork)
 176              (0
 177               (dynamic-wind
 178                 (const #f)
 179                 (lambda ()
 180                   (close-port in)
 181                   (close-port (current-input-port))
 182                   (dup2 (fileno input) 0)
 183                   (close-port (current-output-port))
 184                   (dup2 (fileno out) 1)
 185                   (catch 'system-error
 186                     (lambda ()
 187                       (apply execl (car command) command))
 188                     (lambda args
 189                       (format (current-error-port)
 190                               "filtered-port: failed to execute '~{~a ~}': ~a~%"
 191                               command (strerror (system-error-errno args))))))
 192                 (lambda ()
 193                   (primitive-_exit 1))))
 194              (child
 195               (close-port out)
 196               (values in (cons child pids))))))
 197
 198         ;; INPUT is not a file port, so fork just for the sake of tunneling it
 199         ;; through a file port.
 200         (match (pipe)
 201           ((in . out)
 202            (match (primitive-fork)
 203              (0
 204               (dynamic-wind
 205                 (const #t)
 206                 (lambda ()
 207                   (close-port in)
 208                   (dump-port input out))
 209                 (lambda ()
 210                   (close-port input)
 211                   (false-if-exception (close out))
 212                   (primitive-_exit 0))))
 213              (child
 214               (close-port input)
 215               (close-port out)
 216               (loop in (cons child pids)))))))))
 217
 218 (define (lzip-port proc port . args)
 219   "Return the lzip port produced by calling PROC (a symbol) on PORT and ARGS.
 220 Raise an error if lzlib support is missing."
 221   (let ((make-port (module-ref (resolve-interface '(lzlib)) proc)))
 222     (make-port port)))
 223
 224 (define (zstd-port proc port . args)
 225   "Return the zstd port produced by calling PROC (a symbol) on PORT and ARGS.
 226 Raise an error if zstd support is missing."
 227   (let ((make-port (module-ref (resolve-interface '(zstd)) proc)))
 228     (make-port port)))
 229
 230 (define (decompressed-port compression input)
 231   "Return an input port where INPUT is decompressed according to COMPRESSION,
 232 a symbol such as 'xz."
 233   (match compression
 234     ((or #f 'none) (values input '()))
 235     ('bzip2        (filtered-port `(,%bzip2 "-dc") input))
 236     ('xz           (filtered-port `(,%xz "-dc") input))
 237     ('gzip         (values (make-zlib-input-port input #:format 'gzip)
 238                            '()))
 239     ('lzip         (values (lzip-port 'make-lzip-input-port input)
 240                            '()))
 241     ('zstd         (values (zstd-port 'make-zstd-input-port input)
 242                            '()))
 243     (_             (error "unsupported compression scheme" compression))))
 244
 245 (define (call-with-decompressed-port compression port proc)
 246   "Call PROC with a wrapper around PORT, a file port, that decompresses data
 247 read from PORT according to COMPRESSION, a symbol such as 'xz."
 248   (let-values (((decompressed pids)
 249                 (decompressed-port compression port)))
 250     (dynamic-wind
 251       (const #f)
 252       (lambda ()
 253         (proc decompressed))
 254       (lambda ()
 255         (close-port decompressed)
 256         (unless (every (compose zero? cdr waitpid) pids)
 257           (error "decompressed-port failure" pids))))))
 258
 259 (define (filtered-output-port command output)
 260   "Return an output port.  Data written to that port is filtered through
 261 COMMAND and written to OUTPUT, an output file port.  In addition, return a
 262 list of PIDs to wait for.  OUTPUT must be unbuffered; otherwise, any buffered
 263 data is lost."
 264   (match (pipe)
 265     ((in . out)
 266      (match (primitive-fork)
 267        (0
 268         (dynamic-wind
 269           (const #f)
 270           (lambda ()
 271             (close-port out)
 272             (close-port (current-input-port))
 273             (dup2 (fileno in) 0)
 274             (close-port (current-output-port))
 275             (dup2 (fileno output) 1)
 276             (catch 'system-error
 277               (lambda ()
 278                 (apply execl (car command) command))
 279               (lambda args
 280                 (format (current-error-port)
 281                         "filtered-output-port: failed to execute '~{~a ~}': ~a~%"
 282                         command (strerror (system-error-errno args))))))
 283           (lambda ()
 284             (primitive-_exit 1))))
 285        (child
 286         (close-port in)
 287         (values out (list child)))))))
 288
 289 (define* (compressed-output-port compression output
 290                                  #:key (options '()))
 291   "Return an output port whose input is compressed according to COMPRESSION,
 292 a symbol such as 'xz, and then written to OUTPUT.  In addition return a list
 293 of PIDs to wait for.  OPTIONS is a list of strings passed to the compression
 294 program--e.g., '(\"--fast\")."
 295   (match compression
 296     ((or #f 'none) (values output '()))
 297     ('bzip2        (filtered-output-port `(,%bzip2 "-c" ,@options) output))
 298     ('xz           (filtered-output-port `(,%xz "-c" ,@options) output))
 299     ('gzip         (values (make-zlib-output-port output #:format 'gzip)
 300                            '()))
 301     ('lzip         (values (lzip-port 'make-lzip-output-port output)
 302                            '()))
 303     ('zstd         (values (zstd-port 'make-zstd-output-port output)
 304                            '()))
 305     (_             (error "unsupported compression scheme" compression))))
 306
 307 (define* (call-with-compressed-output-port compression port proc
 308                                            #:key (options '()))
 309   "Call PROC with a wrapper around PORT, a file port, that compresses data
 310 that goes to PORT according to COMPRESSION, a symbol such as 'xz.  OPTIONS is
 311 a list of command-line arguments passed to the compression program."
 312   (let-values (((compressed pids)
 313                 (compressed-output-port compression port
 314                                         #:options options)))
 315     (dynamic-wind
 316       (const #f)
 317       (lambda ()
 318         (proc compressed))
 319       (lambda ()
 320         (close-port compressed)
 321         (unless (every (compose zero? cdr waitpid) pids)
 322           (error "compressed-output-port failure" pids))))))
 323
 324 (define* (edit-expression source-properties proc #:key (encoding "UTF-8"))
 325   "Edit the expression specified by SOURCE-PROPERTIES using PROC, which should
 326 be a procedure that takes the original expression in string and returns a new
 327 one.  ENCODING will be used to interpret all port I/O, it default to UTF-8.
 328 This procedure returns #t on success."
 329   (with-fluids ((%default-port-encoding encoding))
 330     (let* ((file   (assq-ref source-properties 'filename))
 331            (line   (assq-ref source-properties 'line))
 332            (column (assq-ref source-properties 'column))
 333            (in     (open-input-file file))
 334            ;; The start byte position of the expression.
 335            (start  (begin (while (not (and (= line (port-line in))
 336                                            (= column (port-column in))))
 337                             (when (eof-object? (read-char in))
 338                               (error (format #f "~a: end of file~%" in))))
 339                           (ftell in)))
 340            ;; The end byte position of the expression.
 341            (end    (begin (read in) (ftell in))))
 342       (seek in 0 SEEK_SET) ; read from the beginning of the file.
 343       (let* ((pre-bv  (get-bytevector-n in start))
 344              ;; The expression in string form.
 345              (str     (iconv:bytevector->string
 346                        (get-bytevector-n in (- end start))
 347                        (port-encoding in)))
 348              (post-bv (get-bytevector-all in))
 349              (str*    (proc str)))
 350         ;; Verify the edited expression is still a scheme expression.
 351         (call-with-input-string str* read)
 352         ;; Update the file with edited expression.
 353         (with-atomic-file-output file
 354           (lambda (out)
 355             (put-bytevector out pre-bv)
 356             (display str* out)
 357             ;; post-bv maybe the end-of-file object.
 358             (when (not (eof-object? post-bv))
 359               (put-bytevector out post-bv))
 360             #t))))))
 361
 362 \f
 363 ;;;
 364 ;;; Keyword arguments.
 365 ;;;
 366
 367 (define (strip-keyword-arguments keywords args)
 368   "Remove all of the keyword arguments listed in KEYWORDS from ARGS."
 369   (let loop ((args   args)
 370              (result '()))
 371     (match args
 372       (()
 373        (reverse result))
 374       (((? keyword? kw) arg . rest)
 375        (loop rest
 376              (if (memq kw keywords)
 377                  result
 378                  (cons* arg kw result))))
 379       ((head . tail)
 380        (loop tail (cons head result))))))
 381
 382 (define (default-keyword-arguments args defaults)
 383   "Return ARGS augmented with any keyword/value from DEFAULTS for
 384 keywords not already present in ARGS."
 385   (let loop ((defaults defaults)
 386              (args     args))
 387     (match defaults
 388       ((kw value rest ...)
 389        (loop rest
 390              (if (memq kw args)
 391                  args
 392                  (cons* kw value args))))
 393       (()
 394        args))))
 395
 396 (define-syntax collect-default-args
 397   (syntax-rules ()
 398     ((_)
 399      '())
 400     ((_ (_ _) rest ...)
 401      (collect-default-args rest ...))
 402     ((_ (kw _ dflt) rest ...)
 403      (cons* kw dflt (collect-default-args rest ...)))))
 404
 405 (define-syntax substitute-keyword-arguments
 406   (syntax-rules ()
 407     "Return a new list of arguments where the value for keyword arg KW is
 408 replaced by EXP.  EXP is evaluated in a context where VAR is bound to the
 409 previous value of the keyword argument, or DFLT if given."
 410     ((_ original-args ((kw var dflt ...) exp) ...)
 411      (let loop ((args (default-keyword-arguments
 412                         original-args
 413                         (collect-default-args (kw var dflt ...) ...)))
 414                 (before '()))
 415        (match args
 416          ((kw var rest (... ...))
 417           (loop rest (cons* exp kw before)))
 418          ...
 419          ((x rest (... ...))
 420           (loop rest (cons x before)))
 421          (()
 422           (reverse before)))))))
 423
 424 (define (delkw kw lst)
 425   "Remove KW and its associated value from LST, a keyword/value list such
 426 as '(#:foo 1 #:bar 2)."
 427   (let loop ((lst    lst)
 428              (result '()))
 429     (match lst
 430       (()
 431        (reverse result))
 432       ((kw? value rest ...)
 433        (if (eq? kw? kw)
 434            (append (reverse result) rest)
 435            (loop rest (cons* value kw? result)))))))
 436
 437 (define (ensure-keyword-arguments args kw/values)
 438   "Force the keywords arguments KW/VALUES in the keyword argument list ARGS.
 439 For instance:
 440
 441   (ensure-keyword-arguments '(#:foo 2) '(#:foo 2))
 442   => (#:foo 2)
 443
 444   (ensure-keyword-arguments '(#:foo 2) '(#:bar 3))
 445   => (#:foo 2 #:bar 3)
 446
 447   (ensure-keyword-arguments '(#:foo 2) '(#:bar 3 #:foo 42))
 448   => (#:foo 42 #:bar 3)
 449 "
 450   (let loop ((args      args)
 451              (kw/values kw/values)
 452              (result    '()))
 453     (match args
 454       (()
 455        (append (reverse result) kw/values))
 456       ((kw value rest ...)
 457        (match (memq kw kw/values)
 458          ((_ value . _)
 459           (loop rest (delkw kw kw/values) (cons* value kw result)))
 460          (#f
 461           (loop rest kw/values (cons* value kw result))))))))
 462
 463 \f
 464 ;;;
 465 ;;; System strings.
 466 ;;;
 467
 468 (define* (nix-system->gnu-triplet
 469           #:optional (system (%current-system)) (vendor "unknown"))
 470   "Return a guess of the GNU triplet corresponding to Nix system
 471 identifier SYSTEM."
 472   (match system
 473     ("armhf-linux"
 474      (string-append "arm-" vendor "-linux-gnueabihf"))
 475     (_
 476      (let* ((dash (string-index system #\-))
 477             (arch (substring system 0 dash))
 478             (os   (substring system (+ 1 dash))))
 479        (string-append arch
 480                       "-" vendor "-"
 481                       (if (string=? os "linux")
 482                           "linux-gnu"
 483                           os))))))
 484
 485 (define (gnu-triplet->nix-system triplet)
 486   "Return the Nix system type corresponding to TRIPLET, a GNU triplet as
 487 returned by `config.guess'."
 488   (let ((triplet (cond ((string-match "^i[345]86-(.*)$" triplet)
 489                         =>
 490                         (lambda (m)
 491                           (string-append "i686-" (match:substring m 1))))
 492                        (else triplet))))
 493     (cond ((string-match "^arm[^-]*-([^-]+-)?linux-gnueabihf" triplet)
 494            "armhf-linux")
 495           ((string-match "^([^-]+)-([^-]+-)?linux-gnu.*" triplet)
 496            =>
 497            (lambda (m)
 498              ;; Nix omits `-gnu' for GNU/Linux.
 499              (string-append (match:substring m 1) "-linux")))
 500           ((string-match "^([^-]+)-([^-]+-)?([[:alpha:]]+)([0-9]+\\.?)*$" triplet)
 501            =>
 502            (lambda (m)
 503              ;; Nix strip the version number from names such as `gnu0.3',
 504              ;; `darwin10.2.0', etc., and always strips the vendor part.
 505              (string-append (match:substring m 1) "-"
 506                             (match:substring m 3))))
 507           (else triplet))))
 508
 509 (define %current-system
 510   ;; System type as expected by Nix, usually ARCHITECTURE-KERNEL.
 511   ;; By default, this is equal to (gnu-triplet->nix-system %host-type).
 512   (make-parameter %system))
 513
 514 (define %current-target-system
 515   ;; Either #f or a GNU triplet representing the target system we are
 516   ;; cross-building to.
 517   (make-parameter #f))
 518
 519 (define* (package-name->name+version spec
 520                                      #:optional (delimiter #\@))
 521   "Given SPEC, a package name like \"foo@0.9.1b\", return two values: \"foo\"
 522 and \"0.9.1b\".  When the version part is unavailable, SPEC and #f are
 523 returned.  Both parts must not contain any '@'.  Optionally, DELIMITER can be
 524 a character other than '@'."
 525   (match (string-rindex spec delimiter)
 526     (#f  (values spec #f))
 527     (idx (values (substring spec 0 idx)
 528                  (substring spec (1+ idx))))))
 529
 530 (define* (target-mingw? #:optional (target (%current-target-system)))
 531   (and target
 532        (string-suffix? "-mingw32" target)))
 533
 534 (define* (target-arm32? #:optional (target (or (%current-target-system)
 535                                                (%current-system))))
 536   (string-prefix? "arm" target))
 537
 538 (define* (target-aarch64? #:optional (target (or (%current-target-system)
 539                                                  (%current-system))))
 540   (string-prefix? "aarch64" target))
 541
 542 (define* (target-arm? #:optional (target (or (%current-target-system)
 543                                              (%current-system))))
 544   (or (target-arm32? target) (target-aarch64? target)))
 545
 546 (define* (target-powerpc? #:optional (target (or (%current-target-system)
 547                                                  (%current-system))))
 548   (string-prefix? "powerpc" target))
 549
 550 (define* (target-64bit? #:optional (system (or (%current-target-system)
 551                                                (%current-system))))
 552   (any (cut string-prefix? <> system) '("x86_64" "aarch64" "mips64" "powerpc64")))
 553
 554 (define* (cc-for-target #:optional (target (%current-target-system)))
 555   (if target
 556       (string-append target "-gcc")
 557       "gcc"))
 558
 559 (define* (cxx-for-target #:optional (target (%current-target-system)))
 560   (if target
 561       (string-append target "-g++")
 562       "g++"))
 563
 564 (define* (pkg-config-for-target #:optional (target (%current-target-system)))
 565   (if target
 566       (string-append target "-pkg-config")
 567       "pkg-config"))
 568
 569 (define version-compare
 570   (let ((strverscmp
 571          (let ((sym (or (dynamic-func "strverscmp" (dynamic-link))
 572                         (error "could not find `strverscmp' (from GNU libc)"))))
 573            (pointer->procedure int sym (list '* '*)))))
 574     (lambda (a b)
 575       "Return '> when A denotes a newer version than B,
 576 '< when A denotes a older version than B,
 577 or '= when they denote equal versions."
 578       (let ((result (strverscmp (string->pointer a) (string->pointer b))))
 579         (cond ((positive? result) '>)
 580               ((negative? result) '<)
 581               (else '=))))))
 582
 583 (define (version-prefix version-string num-parts)
 584   "Truncate version-string to the first num-parts components of the version.
 585 For example, (version-prefix \"2.1.47.4.23\" 3) returns \"2.1.47\""
 586   (string-join (take (string-split version-string #\.) num-parts) "."))
 587
 588 (define (version-major+minor+point version-string)
 589   "Return \"major>.<minor>.<point>\", where major, minor and point are the
 590 major, minor and point version numbers from the version-string.  For example,
 591 (version-major+minor+point \"6.4.5.2\") returns \"6.4.5\" or
 592 (version-major+minor+point \"1.19.2-2581-324ca14c3003\") returns \"1.19.2\"."
 593   (let* ((3-dot (version-prefix version-string 3))
 594          (index (string-index 3-dot #\-)))
 595     (or (false-if-exception (substring 3-dot 0 index))
 596         3-dot)))
 597
 598 (define (version-major+minor version-string)
 599   "Return \"<major>.<minor>\", where major and minor are the major and
 600 minor version numbers from version-string."
 601   (version-prefix version-string 2))
 602
 603 (define (version-major version-string)
 604   "Return the major version number as string from the version-string."
 605   (version-prefix version-string 1))
 606
 607 (define (version-unique-prefix version versions)
 608   "Return the shortest version prefix to unambiguously identify VERSION among
 609 VERSIONS.  For example:
 610
 611   (version-unique-prefix \"2.0\" '(\"3.0\" \"2.0\"))
 612   => \"2\"
 613
 614   (version-unique-prefix \"2.2\" '(\"3.0.5\" \"2.0.9\" \"2.2.7\"))
 615   => \"2.2\"
 616
 617   (version-unique-prefix \"27.1\" '(\"27.1\"))
 618   => \"\"
 619 "
 620   (define not-dot
 621     (char-set-complement (char-set #\.)))
 622
 623   (define other-versions
 624     (delete version versions))
 625
 626   (let loop ((prefix     '())
 627              (components (string-tokenize version not-dot)))
 628     (define prefix-str
 629       (string-join prefix "."))
 630
 631     (if (any (cut string-prefix? prefix-str <>) other-versions)
 632         (match components
 633           ((head . tail)
 634            (loop `(,@prefix ,head) tail))
 635           (()
 636            version))
 637         prefix-str)))
 638
 639 (define (version>? a b)
 640   "Return #t when A denotes a version strictly newer than B."
 641   (eq? '> (version-compare a b)))
 642
 643 (define (version>=? a b)
 644   "Return #t when A denotes a version newer or equal to B."
 645   (case (version-compare a b)
 646     ((> =) #t)
 647     (else #f)))
 648
 649 (define (guile-version>? str)
 650   "Return #t if the running Guile version is greater than STR."
 651   ;; Note: Using (version>? (version) "2.0.5") or similar doesn't work,
 652   ;; because the result of (version) can have a prefix, like "2.0.5-deb1".
 653   (version>? (string-append (major-version) "."
 654                             (minor-version) "."
 655                             (micro-version))
 656              str))
 657
 658 (define version-prefix?
 659   (let ((not-dot (char-set-complement (char-set #\.))))
 660     (lambda (v1 v2)
 661       "Return true if V1 is a version prefix of V2:
 662
 663   (version-prefix? \"4.1\" \"4.16.2\") => #f
 664   (version-prefix? \"4.1\" \"4.1.2\") => #t
 665 "
 666       (define (list-prefix? lst1 lst2)
 667         (match lst1
 668           (() #t)
 669           ((head1 tail1 ...)
 670            (match lst2
 671              (() #f)
 672              ((head2 tail2 ...)
 673               (and (equal? head1 head2)
 674                    (list-prefix? tail1 tail2)))))))
 675
 676       (list-prefix? (string-tokenize v1 not-dot)
 677                     (string-tokenize v2 not-dot)))))
 678
 679 \f
 680 ;;;
 681 ;;; Files.
 682 ;;;
 683
 684 (define (file-extension file)
 685   "Return the extension of FILE or #f if there is none."
 686   (let ((dot (string-rindex file #\.)))
 687     (and dot (substring file (+ 1 dot) (string-length file)))))
 688
 689 (define (file-sans-extension file)
 690   "Return the substring of FILE without its extension, if any."
 691   (let ((dot (string-rindex file #\.)))
 692     (if dot
 693         (substring file 0 dot)
 694         file)))
 695
 696 (define (tarball-sans-extension tarball)
 697   "Return TARBALL without its .tar.* or .zip extension."
 698   (let ((end (or (string-contains tarball ".tar")
 699                  (string-contains tarball ".tgz")
 700                  (string-contains tarball ".zip"))))
 701     (substring tarball 0 end)))
 702
 703 (define (compressed-file? file)
 704   "Return true if FILE denotes a compressed file."
 705   (->bool (member (file-extension file)
 706                   '("gz" "bz2" "xz" "lz" "lzma" "tgz" "tbz2" "zip"))))
 707
 708 (define (switch-symlinks link target)
 709   "Atomically switch LINK, a symbolic link, to point to TARGET.  Works
 710 both when LINK already exists and when it does not."
 711   (let ((pivot (string-append link ".new")))
 712     (symlink target pivot)
 713     (rename-file pivot link)))
 714
 715 (define* (string-replace-substring str substr replacement
 716                                    #:optional
 717                                    (start 0)
 718                                    (end (string-length str)))
 719   "Replace all occurrences of SUBSTR in the START--END range of STR by
 720 REPLACEMENT."
 721   (match (string-length substr)
 722     (0
 723      (error "string-replace-substring: empty substring"))
 724     (substr-length
 725      (let loop ((start  start)
 726                 (pieces (list (substring str 0 start))))
 727        (match (string-contains str substr start end)
 728          (#f
 729           (string-concatenate-reverse
 730            (cons (substring str start) pieces)))
 731          (index
 732           (loop (+ index substr-length)
 733                 (cons* replacement
 734                        (substring str start index)
 735                        pieces))))))))
 736
 737 (define (call-with-temporary-output-file proc)
 738   "Call PROC with a name of a temporary file and open output port to that
 739 file; close the file and delete it when leaving the dynamic extent of this
 740 call."
 741   (let* ((directory (or (getenv "TMPDIR") "/tmp"))
 742          (template  (string-append directory "/guix-file.XXXXXX"))
 743          (out       (mkstemp! template)))
 744     (dynamic-wind
 745       (lambda ()
 746         #t)
 747       (lambda ()
 748         (proc template out))
 749       (lambda ()
 750         (false-if-exception (close out))
 751         (false-if-exception (delete-file template))))))
 752
 753 (define (call-with-temporary-directory proc)
 754   "Call PROC with a name of a temporary directory; close the directory and
 755 delete it when leaving the dynamic extent of this call."
 756   (let* ((directory (or (getenv "TMPDIR") "/tmp"))
 757          (template  (string-append directory "/guix-directory.XXXXXX"))
 758          (tmp-dir   (mkdtemp! template)))
 759     (dynamic-wind
 760       (const #t)
 761       (lambda ()
 762         (proc tmp-dir))
 763       (lambda ()
 764         (false-if-exception (delete-file-recursively tmp-dir))))))
 765
 766 (define (with-atomic-file-output file proc)
 767   "Call PROC with an output port for the file that is going to replace FILE.
 768 Upon success, FILE is atomically replaced by what has been written to the
 769 output port, and PROC's result is returned."
 770   (let* ((template (string-append file ".XXXXXX"))
 771          (out      (mkstemp! template)))
 772     (with-throw-handler #t
 773       (lambda ()
 774         (let ((result (proc out)))
 775           (fdatasync out)
 776           (close-port out)
 777           (rename-file template file)
 778           result))
 779       (lambda (key . args)
 780         (false-if-exception (delete-file template))
 781         (close-port out)))))
 782
 783 (define* (xdg-directory variable suffix #:key (ensure? #t))
 784   "Return the name of the XDG directory that matches VARIABLE and SUFFIX,
 785 after making sure that it exists if ENSURE? is true.  VARIABLE is an
 786 environment variable name like \"XDG_CONFIG_HOME\"; SUFFIX is a suffix like
 787 \"/.config\".  Honor the XDG specs,
 788 <http://standards.freedesktop.org/basedir-spec/basedir-spec-latest.html>."
 789   (let ((dir (and=> (or (getenv variable)
 790                         (and=> (or (getenv "HOME")
 791                                    (passwd:dir (getpwuid (getuid))))
 792                                (cut string-append <> suffix)))
 793                     (cut string-append <> "/guix"))))
 794     (when ensure?
 795       (mkdir-p dir))
 796     dir))
 797
 798 (define config-directory
 799   (cut xdg-directory "XDG_CONFIG_HOME" "/.config" <...>))
 800
 801 (define cache-directory
 802   (cut xdg-directory "XDG_CACHE_HOME" "/.cache" <...>))
 803
 804 (define (readlink* file)
 805   "Call 'readlink' until the result is not a symlink."
 806   (define %max-symlink-depth 50)
 807
 808   (let loop ((file  file)
 809              (depth 0))
 810     (define (absolute target)
 811       (if (absolute-file-name? target)
 812           target
 813           (string-append (dirname file) "/" target)))
 814
 815     (if (>= depth %max-symlink-depth)
 816         file
 817         (call-with-values
 818             (lambda ()
 819               (catch 'system-error
 820                 (lambda ()
 821                   (values #t (readlink file)))
 822                 (lambda args
 823                   (let ((errno (system-error-errno args)))
 824                     (if (or (= errno EINVAL))
 825                         (values #f file)
 826                         (apply throw args))))))
 827           (lambda (success? target)
 828             (if success?
 829                 (loop (absolute target) (+ depth 1))
 830                 file))))))
 831
 832 (define (canonical-newline-port port)
 833   "Return an input port that wraps PORT such that all newlines consist
 834   of a single linefeed."
 835   (define (get-position)
 836     (if (port-has-port-position? port) (port-position port) #f))
 837   (define (set-position! position)
 838     (if (port-has-set-port-position!? port)
 839         (set-port-position! position port)
 840         #f))
 841   (define (close) (close-port port))
 842   (define (read! bv start n)
 843     (let loop ((count 0)
 844                (byte (get-u8 port)))
 845       (cond ((eof-object? byte) count)
 846             ;; XXX: consume all CRs even if not followed by LF.
 847             ((eqv? byte (char->integer #\return)) (loop count (get-u8 port)))
 848             ((= count (- n 1))
 849              (bytevector-u8-set! bv (+ start count) byte)
 850              n)
 851             (else
 852              (bytevector-u8-set! bv (+ start count) byte)
 853              (loop (+ count 1) (get-u8 port))))))
 854   (make-custom-binary-input-port "canonical-newline-port"
 855                                  read!
 856                                  get-position
 857                                  set-position!
 858                                  close))
 859 \f
 860 ;;;
 861 ;;; Source location.
 862 ;;;
 863
 864 (define absolute-dirname
 865   ;; Memoize to avoid repeated 'stat' storms from 'search-path'.
 866   (mlambda (file)
 867     "Return the absolute name of the directory containing FILE, or #f upon
 868 failure."
 869     (match (search-path %load-path file)
 870       (#f #f)
 871       ((? string? file)
 872        ;; If there are relative names in %LOAD-PATH, FILE can be relative and
 873        ;; needs to be canonicalized.
 874        (if (string-prefix? "/" file)
 875            (dirname file)
 876            (canonicalize-path (dirname file)))))))
 877
 878 (define-syntax current-source-directory
 879   (lambda (s)
 880     "Return the absolute name of the current directory, or #f if it could not
 881 be determined."
 882     (syntax-case s ()
 883       ((_)
 884        (match (assq 'filename (or (syntax-source s) '()))
 885          (('filename . (? string? file-name))
 886           ;; If %FILE-PORT-NAME-CANONICALIZATION is 'relative, then FILE-NAME
 887           ;; can be relative.  In that case, we try to find out at run time
 888           ;; the absolute file name by looking at %LOAD-PATH; doing this at
 889           ;; run time rather than expansion time is necessary to allow files
 890           ;; to be moved on the file system.
 891           (if (string-prefix? "/" file-name)
 892               (dirname file-name)
 893               #`(absolute-dirname #,file-name)))
 894          ((or ('filename . #f) #f)
 895           ;; raising an error would upset Geiser users
 896           #f))))))
 897
 898 \f
 899 ;;;
 900 ;;; String comparison.
 901 ;;;
 902
 903 (define (string-distance s1 s2)
 904   "Compute the Levenshtein distance between two strings."
 905   ;; Naive implemenation
 906   (define loop
 907     (mlambda (as bt)
 908       (match as
 909         (() (length bt))
 910         ((a s ...)
 911          (match bt
 912            (() (length as))
 913            ((b t ...)
 914             (if (char=? a b)
 915                 (loop s t)
 916                 (1+ (min
 917                      (loop as t)
 918                      (loop s bt)
 919                      (loop s t))))))))))
 920
 921   (let ((c1 (string->list s1))
 922         (c2 (string->list s2)))
 923     (loop c1 c2)))
 924
 925 (define* (string-closest trial tests #:key (threshold 3))
 926   "Return the string from TESTS that is the closest from the TRIAL,
 927 according to 'string-distance'.  If the TESTS are too far from TRIAL,
 928 according to THRESHOLD, then #f is returned."
 929   (identity                              ;discard second return value
 930     (fold2 (lambda (test closest minimal)
 931              (let ((dist (string-distance trial test)))
 932                (if (and  (< dist minimal) (< dist threshold))
 933                    (values test dist)
 934                    (values closest minimal))))
 935            #f +inf.0
 936            tests)))
 937
 938 ;;; Local Variables:
 939 ;;; eval: (put 'call-with-progress-reporter 'scheme-indent-function 1)
 940 ;;; End: