guix/build/utils.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2013 Andreas Enge <andreas@enge.fr>
   4 ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
   5 ;;; Copyright © 2015, 2018 Mark H Weaver <mhw@netris.org>
   6 ;;; Copyright © 2018 Arun Isaac <arunisaac@systemreboot.net>
   7 ;;;
   8 ;;; This file is part of GNU Guix.
   9 ;;;
  10 ;;; GNU Guix is free software; you can redistribute it and/or modify it
  11 ;;; under the terms of the GNU General Public License as published by
  12 ;;; the Free Software Foundation; either version 3 of the License, or (at
  13 ;;; your option) any later version.
  14 ;;;
  15 ;;; GNU Guix is distributed in the hope that it will be useful, but
  16 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;;; GNU General Public License for more details.
  19 ;;;
  20 ;;; You should have received a copy of the GNU General Public License
  21 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  22
  23 (define-module (guix build utils)
  24   #:use-module (srfi srfi-1)
  25   #:use-module (srfi srfi-11)
  26   #:use-module (srfi srfi-26)
  27   #:use-module (srfi srfi-34)
  28   #:use-module (srfi srfi-35)
  29   #:use-module (srfi srfi-60)
  30   #:use-module (ice-9 ftw)
  31   #:use-module (ice-9 match)
  32   #:use-module (ice-9 regex)
  33   #:use-module (ice-9 rdelim)
  34   #:use-module (ice-9 format)
  35   #:use-module (ice-9 threads)
  36   #:use-module (rnrs bytevectors)
  37   #:use-module (rnrs io ports)
  38   #:re-export (alist-cons
  39                alist-delete
  40
  41                ;; Note: Re-export 'delete' to allow for proper syntax matching
  42                ;; in 'modify-phases' forms.  See
  43                ;; <https://debbugs.gnu.org/cgi/bugreport.cgi?bug=26805#16>.
  44                delete)
  45   #:export (%store-directory
  46             store-file-name?
  47             strip-store-file-name
  48             package-name->name+version
  49             parallel-job-count
  50
  51             directory-exists?
  52             executable-file?
  53             symbolic-link?
  54             call-with-ascii-input-file
  55             elf-file?
  56             ar-file?
  57             gzip-file?
  58             reset-gzip-timestamp
  59             with-directory-excursion
  60             mkdir-p
  61             install-file
  62             make-file-writable
  63             copy-recursively
  64             delete-file-recursively
  65             file-name-predicate
  66             find-files
  67             false-if-file-not-found
  68
  69             search-path-as-list
  70             set-path-environment-variable
  71             search-path-as-string->list
  72             list->search-path-as-string
  73             which
  74
  75             every*
  76             alist-cons-before
  77             alist-cons-after
  78             alist-replace
  79             modify-phases
  80
  81             with-atomic-file-replacement
  82             substitute
  83             substitute*
  84             dump-port
  85             set-file-time
  86             patch-shebang
  87             patch-makefile-SHELL
  88             patch-/usr/bin/file
  89             fold-port-matches
  90             remove-store-references
  91             wrapper?
  92             wrap-program
  93
  94             invoke
  95             invoke-error?
  96             invoke-error-program
  97             invoke-error-arguments
  98             invoke-error-exit-status
  99             invoke-error-term-signal
 100             invoke-error-stop-signal
 101             report-invoke-error
 102
 103             locale-category->string))
 104
 105 \f
 106 ;;;
 107 ;;; Guile 2.0 compatibility later.
 108 ;;;
 109
 110 ;; The bootstrap Guile is Guile 2.0, so provide a compatibility layer.
 111 (cond-expand
 112   ((and guile-2 (not guile-2.2))
 113    (define (setvbuf port mode . rest)
 114      (apply (@ (guile) setvbuf) port
 115             (match mode
 116               ('line _IOLBF)
 117               ('block _IOFBF)
 118               ('none _IONBF)
 119               (_ mode))                           ;an _IO* integer
 120             rest))
 121
 122    (module-replace! (current-module) '(setvbuf)))
 123   (else #f))
 124
 125 \f
 126 ;;;
 127 ;;; Directories.
 128 ;;;
 129
 130 (define (%store-directory)
 131   "Return the directory name of the store."
 132   (or (getenv "NIX_STORE")
 133       "/gnu/store"))
 134
 135 (define (store-file-name? file)
 136   "Return true if FILE is in the store."
 137   (string-prefix? (%store-directory) file))
 138
 139 (define (strip-store-file-name file)
 140   "Strip the '/gnu/store' and hash from FILE, a store file name.  The result
 141 is typically a \"PACKAGE-VERSION\" string."
 142   (string-drop file
 143                (+ 34 (string-length (%store-directory)))))
 144
 145 (define (package-name->name+version name)
 146   "Given NAME, a package name like \"foo-0.9.1b\", return two values:
 147 \"foo\" and \"0.9.1b\".  When the version part is unavailable, NAME and
 148 #f are returned.  The first hyphen followed by a digit is considered to
 149 introduce the version part."
 150   ;; See also `DrvName' in Nix.
 151
 152   (define number?
 153     (cut char-set-contains? char-set:digit <>))
 154
 155   (let loop ((chars   (string->list name))
 156              (prefix '()))
 157     (match chars
 158       (()
 159        (values name #f))
 160       ((#\- (? number? n) rest ...)
 161        (values (list->string (reverse prefix))
 162                (list->string (cons n rest))))
 163       ((head tail ...)
 164        (loop tail (cons head prefix))))))
 165
 166 (define parallel-job-count
 167   ;; Number of processes to be passed next to GNU Make's `-j' argument.
 168   (make-parameter
 169    (match (getenv "NIX_BUILD_CORES")              ;set by the daemon
 170      (#f  1)
 171      ("0" (current-processor-count))
 172      (x   (or (string->number x) 1)))))
 173
 174 (define (directory-exists? dir)
 175   "Return #t if DIR exists and is a directory."
 176   (let ((s (stat dir #f)))
 177     (and s
 178          (eq? 'directory (stat:type s)))))
 179
 180 (define (executable-file? file)
 181   "Return #t if FILE exists and is executable."
 182   (let ((s (stat file #f)))
 183     (and s
 184          (not (zero? (logand (stat:mode s) #o100))))))
 185
 186 (define (symbolic-link? file)
 187   "Return #t if FILE is a symbolic link (aka. \"symlink\".)"
 188   (eq? (stat:type (lstat file)) 'symlink))
 189
 190 (define (call-with-ascii-input-file file proc)
 191   "Open FILE as an ASCII or binary file, and pass the resulting port to
 192 PROC.  FILE is closed when PROC's dynamic extent is left.  Return the
 193 return values of applying PROC to the port."
 194   (let ((port (with-fluids ((%default-port-encoding #f))
 195                 ;; Use "b" so that `open-file' ignores `coding:' cookies.
 196                 (open-file file "rb"))))
 197     (dynamic-wind
 198       (lambda ()
 199         #t)
 200       (lambda ()
 201         (proc port))
 202       (lambda ()
 203         (close-input-port port)))))
 204
 205 (define (file-header-match header)
 206   "Return a procedure that returns true when its argument is a file starting
 207 with the bytes in HEADER, a bytevector."
 208   (define len
 209     (bytevector-length header))
 210
 211   (lambda (file)
 212     "Return true if FILE starts with the right magic bytes."
 213     (define (get-header)
 214       (call-with-input-file file
 215         (lambda (port)
 216           (get-bytevector-n port len))
 217         #:binary #t #:guess-encoding #f))
 218
 219     (catch 'system-error
 220       (lambda ()
 221         (equal? (get-header) header))
 222       (lambda args
 223         (if (= EISDIR (system-error-errno args))
 224             #f                                    ;FILE is a directory
 225             (apply throw args))))))
 226
 227 (define %elf-magic-bytes
 228   ;; Magic bytes of ELF files.  See <elf.h>.
 229   (u8-list->bytevector (map char->integer (string->list "\x7FELF"))))
 230
 231 (define elf-file?
 232   (file-header-match %elf-magic-bytes))
 233
 234 (define %ar-magic-bytes
 235   ;; Magic bytes of archives created by 'ar'.  See <ar.h>.
 236   (u8-list->bytevector (map char->integer (string->list "!<arch>\n"))))
 237
 238 (define ar-file?
 239   (file-header-match %ar-magic-bytes))
 240
 241 (define %gzip-magic-bytes
 242   ;; Magic bytes of gzip file.  Beware, it's a small header so there could be
 243   ;; false positives.
 244   #vu8(#x1f #x8b))
 245
 246 (define gzip-file?
 247   (file-header-match %gzip-magic-bytes))
 248
 249 (define* (reset-gzip-timestamp file #:key (keep-mtime? #t))
 250   "If FILE is a gzip file, reset its embedded timestamp (as with 'gzip
 251 --no-name') and return true.  Otherwise return #f.  When KEEP-MTIME? is true,
 252 preserve FILE's modification time."
 253   (let ((stat (stat file))
 254         (port (open file O_RDWR)))
 255     (dynamic-wind
 256       (const #t)
 257       (lambda ()
 258         (and (= 4 (seek port 4 SEEK_SET))
 259              (put-bytevector port #vu8(0 0 0 0))))
 260       (lambda ()
 261         (close-port port)
 262         (set-file-time file stat)))))
 263
 264 (define-syntax-rule (with-directory-excursion dir body ...)
 265   "Run BODY with DIR as the process's current directory."
 266   (let ((init (getcwd)))
 267    (dynamic-wind
 268      (lambda ()
 269        (chdir dir))
 270      (lambda ()
 271        body ...)
 272      (lambda ()
 273        (chdir init)))))
 274
 275 (define (mkdir-p dir)
 276   "Create directory DIR and all its ancestors."
 277   (define absolute?
 278     (string-prefix? "/" dir))
 279
 280   (define not-slash
 281     (char-set-complement (char-set #\/)))
 282
 283   (let loop ((components (string-tokenize dir not-slash))
 284              (root       (if absolute?
 285                              ""
 286                              ".")))
 287     (match components
 288       ((head tail ...)
 289        (let ((path (string-append root "/" head)))
 290          (catch 'system-error
 291            (lambda ()
 292              (mkdir path)
 293              (loop tail path))
 294            (lambda args
 295              (if (= EEXIST (system-error-errno args))
 296                  (loop tail path)
 297                  (apply throw args))))))
 298       (() #t))))
 299
 300 (define (install-file file directory)
 301   "Create DIRECTORY if it does not exist and copy FILE in there under the same
 302 name."
 303   (mkdir-p directory)
 304   (copy-file file (string-append directory "/" (basename file))))
 305
 306 (define (make-file-writable file)
 307   "Make FILE writable for its owner."
 308   (let ((stat (lstat file)))                      ;XXX: symlinks
 309     (chmod file (logior #o600 (stat:perms stat)))))
 310
 311 (define* (copy-recursively source destination
 312                            #:key
 313                            (log (current-output-port))
 314                            (follow-symlinks? #f)
 315                            keep-mtime?)
 316   "Copy SOURCE directory to DESTINATION.  Follow symlinks if FOLLOW-SYMLINKS?
 317 is true; otherwise, just preserve them.  When KEEP-MTIME? is true, keep the
 318 modification time of the files in SOURCE on those of DESTINATION.  Write
 319 verbose output to the LOG port."
 320   (define strip-source
 321     (let ((len (string-length source)))
 322       (lambda (file)
 323         (substring file len))))
 324
 325   (file-system-fold (const #t)                    ; enter?
 326                     (lambda (file stat result)    ; leaf
 327                       (let ((dest (string-append destination
 328                                                  (strip-source file))))
 329                         (format log "`~a' -> `~a'~%" file dest)
 330                         (case (stat:type stat)
 331                           ((symlink)
 332                            (let ((target (readlink file)))
 333                              (symlink target dest)))
 334                           (else
 335                            (copy-file file dest)
 336                            (when keep-mtime?
 337                              (set-file-time dest stat))))))
 338                     (lambda (dir stat result)     ; down
 339                       (let ((target (string-append destination
 340                                                    (strip-source dir))))
 341                         (mkdir-p target)
 342                         (when keep-mtime?
 343                           (set-file-time target stat))))
 344                     (lambda (dir stat result)     ; up
 345                       result)
 346                     (const #t)                    ; skip
 347                     (lambda (file stat errno result)
 348                       (format (current-error-port) "i/o error: ~a: ~a~%"
 349                               file (strerror errno))
 350                       #f)
 351                     #t
 352                     source
 353
 354                     (if follow-symlinks?
 355                         stat
 356                         lstat)))
 357
 358 (define* (delete-file-recursively dir
 359                                   #:key follow-mounts?)
 360   "Delete DIR recursively, like `rm -rf', without following symlinks.  Don't
 361 follow mount points either, unless FOLLOW-MOUNTS? is true.  Report but ignore
 362 errors."
 363   (let ((dev (stat:dev (lstat dir))))
 364     (file-system-fold (lambda (dir stat result)    ; enter?
 365                         (or follow-mounts?
 366                             (= dev (stat:dev stat))))
 367                       (lambda (file stat result)   ; leaf
 368                         (delete-file file))
 369                       (const #t)                   ; down
 370                       (lambda (dir stat result)    ; up
 371                         (rmdir dir))
 372                       (const #t)                   ; skip
 373                       (lambda (file stat errno result)
 374                         (format (current-error-port)
 375                                 "warning: failed to delete ~a: ~a~%"
 376                                 file (strerror errno)))
 377                       #t
 378                       dir
 379
 380                       ;; Don't follow symlinks.
 381                       lstat)))
 382
 383 (define (file-name-predicate regexp)
 384   "Return a predicate that returns true when passed a file name whose base
 385 name matches REGEXP."
 386   (let ((file-rx (if (regexp? regexp)
 387                      regexp
 388                      (make-regexp regexp))))
 389     (lambda (file stat)
 390       (regexp-exec file-rx (basename file)))))
 391
 392 (define* (find-files dir #:optional (pred (const #t))
 393                      #:key (stat lstat)
 394                      directories?
 395                      fail-on-error?)
 396   "Return the lexicographically sorted list of files under DIR for which PRED
 397 returns true.  PRED is passed two arguments: the absolute file name, and its
 398 stat buffer; the default predicate always returns true.  PRED can also be a
 399 regular expression, in which case it is equivalent to (file-name-predicate
 400 PRED).  STAT is used to obtain file information; using 'lstat' means that
 401 symlinks are not followed.  If DIRECTORIES? is true, then directories will
 402 also be included.  If FAIL-ON-ERROR? is true, raise an exception upon error."
 403   (let ((pred (if (procedure? pred)
 404                   pred
 405                   (file-name-predicate pred))))
 406     ;; Sort the result to get deterministic results.
 407     (sort (file-system-fold (const #t)
 408                             (lambda (file stat result) ; leaf
 409                               (if (pred file stat)
 410                                   (cons file result)
 411                                   result))
 412                             (lambda (dir stat result) ; down
 413                               (if (and directories?
 414                                        (pred dir stat))
 415                                   (cons dir result)
 416                                   result))
 417                             (lambda (dir stat result) ; up
 418                               result)
 419                             (lambda (file stat result) ; skip
 420                               result)
 421                             (lambda (file stat errno result)
 422                               (format (current-error-port) "find-files: ~a: ~a~%"
 423                                       file (strerror errno))
 424                               (when fail-on-error?
 425                                 (error "find-files failed"))
 426                               result)
 427                             '()
 428                             dir
 429                             stat)
 430           string<?)))
 431
 432 (define-syntax-rule (false-if-file-not-found exp)
 433   "Evaluate EXP but return #f if it raises to 'system-error with ENOENT."
 434   (catch 'system-error
 435     (lambda () exp)
 436     (lambda args
 437       (if (= ENOENT (system-error-errno args))
 438           #f
 439           (apply throw args)))))
 440
 441 \f
 442 ;;;
 443 ;;; Search paths.
 444 ;;;
 445
 446 (define* (search-path-as-list files input-dirs
 447                               #:key (type 'directory) pattern)
 448   "Return the list of directories among FILES of the given TYPE (a symbol as
 449 returned by 'stat:type') that exist in INPUT-DIRS.  Example:
 450
 451   (search-path-as-list '(\"share/emacs/site-lisp\" \"share/emacs/24.1\")
 452                        (list \"/package1\" \"/package2\" \"/package3\"))
 453   => (\"/package1/share/emacs/site-lisp\"
 454       \"/package3/share/emacs/site-lisp\")
 455
 456 When PATTERN is true, it is a regular expression denoting file names to look
 457 for under the directories designated by FILES.  For example:
 458
 459   (search-path-as-list '(\"xml\") (list docbook-xml docbook-xsl)
 460                        #:type 'regular
 461                        #:pattern \"^catalog\\\\.xml$\")
 462   => (\"/…/xml/dtd/docbook/catalog.xml\"
 463       \"/…/xml/xsl/docbook-xsl-1.78.1/catalog.xml\")
 464 "
 465   (append-map (lambda (input)
 466                 (append-map (lambda (file)
 467                               (let ((file (string-append input "/" file)))
 468                                 (if pattern
 469                                     (find-files file (lambda (file stat)
 470                                                        (and stat
 471                                                             (eq? type (stat:type stat))
 472                                                             ((file-name-predicate pattern) file stat)))
 473                                                 #:stat stat
 474                                                 #:directories? #t)
 475                                     (let ((stat (stat file #f)))
 476                                       (if (and stat (eq? type (stat:type stat)))
 477                                           (list file)
 478                                           '())))))
 479                             files))
 480               (delete-duplicates input-dirs)))
 481
 482 (define (list->search-path-as-string lst separator)
 483   (if separator
 484       (string-join lst separator)
 485       (match lst
 486         ((head rest ...) head)
 487         (() ""))))
 488
 489 (define* (search-path-as-string->list path #:optional (separator #\:))
 490   (if separator
 491       (string-tokenize path
 492                        (char-set-complement (char-set separator)))
 493       (list path)))
 494
 495 (define* (set-path-environment-variable env-var files input-dirs
 496                                         #:key
 497                                         (separator ":")
 498                                         (type 'directory)
 499                                         pattern)
 500   "Look for each of FILES of the given TYPE (a symbol as returned by
 501 'stat:type') in INPUT-DIRS.  Set ENV-VAR to a SEPARATOR-separated path
 502 accordingly.  Example:
 503
 504   (set-path-environment-variable \"PKG_CONFIG\"
 505                                  '(\"lib/pkgconfig\")
 506                                  (list package1 package2))
 507
 508 When PATTERN is not #f, it must be a regular expression (really a string)
 509 denoting file names to look for under the directories designated by FILES:
 510
 511   (set-path-environment-variable \"XML_CATALOG_FILES\"
 512                                  '(\"xml\")
 513                                  (list docbook-xml docbook-xsl)
 514                                  #:type 'regular
 515                                  #:pattern \"^catalog\\\\.xml$\")
 516 "
 517   (let* ((path  (search-path-as-list files input-dirs
 518                                      #:type type
 519                                      #:pattern pattern))
 520          (value (list->search-path-as-string path separator)))
 521     (if (string-null? value)
 522         (begin
 523           ;; Never set ENV-VAR to an empty string because often, the empty
 524           ;; string is equivalent to ".".  This is the case for
 525           ;; GUILE_LOAD_PATH in Guile 2.0, for instance.
 526           (unsetenv env-var)
 527           (format #t "environment variable `~a' unset~%" env-var))
 528         (begin
 529           (setenv env-var value)
 530           (format #t "environment variable `~a' set to `~a'~%"
 531                   env-var value)))))
 532
 533 (define (which program)
 534   "Return the complete file name for PROGRAM as found in $PATH, or #f if
 535 PROGRAM could not be found."
 536   (search-path (search-path-as-string->list (getenv "PATH"))
 537                program))
 538
 539 \f
 540 ;;;
 541 ;;; Phases.
 542 ;;;
 543 ;;; In (guix build gnu-build-system), there are separate phases (configure,
 544 ;;; build, test, install).  They are represented as a list of name/procedure
 545 ;;; pairs.  The following procedures make it easy to change the list of
 546 ;;; phases.
 547 ;;;
 548
 549 (define (every* pred lst)
 550   "This is like 'every', but process all the elements of LST instead of
 551 stopping as soon as PRED returns false.  This is useful when PRED has side
 552 effects, such as displaying warnings or error messages."
 553   (let loop ((lst    lst)
 554              (result #t))
 555     (match lst
 556       (()
 557        result)
 558       ((head . tail)
 559        (loop tail (and (pred head) result))))))
 560
 561 (define* (alist-cons-before reference key value alist
 562                             #:optional (key=? equal?))
 563   "Insert the KEY/VALUE pair before the first occurrence of a pair whose key
 564 is REFERENCE in ALIST.  Use KEY=? to compare keys."
 565   (let-values (((before after)
 566                 (break (match-lambda
 567                         ((k . _)
 568                          (key=? k reference)))
 569                        alist)))
 570     (append before (alist-cons key value after))))
 571
 572 (define* (alist-cons-after reference key value alist
 573                            #:optional (key=? equal?))
 574   "Insert the KEY/VALUE pair after the first occurrence of a pair whose key
 575 is REFERENCE in ALIST.  Use KEY=? to compare keys."
 576   (let-values (((before after)
 577                 (break (match-lambda
 578                         ((k . _)
 579                          (key=? k reference)))
 580                        alist)))
 581     (match after
 582       ((reference after ...)
 583        (append before (cons* reference `(,key . ,value) after)))
 584       (()
 585        (append before `((,key . ,value)))))))
 586
 587 (define* (alist-replace key value alist #:optional (key=? equal?))
 588   "Replace the first pair in ALIST whose car is KEY with the KEY/VALUE pair.
 589 An error is raised when no such pair exists."
 590   (let-values (((before after)
 591                 (break (match-lambda
 592                         ((k . _)
 593                          (key=? k key)))
 594                        alist)))
 595     (match after
 596       ((_ after ...)
 597        (append before (alist-cons key value after))))))
 598
 599 (define-syntax-rule (modify-phases phases mod-spec ...)
 600   "Modify PHASES sequentially as per each MOD-SPEC, which may have one of the
 601 following forms:
 602
 603   (delete <old-phase-name>)
 604   (replace <old-phase-name> <new-phase>)
 605   (add-before <old-phase-name> <new-phase-name> <new-phase>)
 606   (add-after <old-phase-name> <new-phase-name> <new-phase>)
 607
 608 Where every <*-phase-name> is an expression evaluating to a symbol, and
 609 <new-phase> an expression evaluating to a procedure."
 610   (let* ((phases* phases)
 611          (phases* (%modify-phases phases* mod-spec))
 612          ...)
 613     phases*))
 614
 615 (define-syntax %modify-phases
 616   (syntax-rules (delete replace add-before add-after)
 617     ((_ phases (delete old-phase-name))
 618      (alist-delete old-phase-name phases))
 619     ((_ phases (replace old-phase-name new-phase))
 620      (alist-replace old-phase-name new-phase phases))
 621     ((_ phases (add-before old-phase-name new-phase-name new-phase))
 622      (alist-cons-before old-phase-name new-phase-name new-phase phases))
 623     ((_ phases (add-after old-phase-name new-phase-name new-phase))
 624      (alist-cons-after old-phase-name new-phase-name new-phase phases))))
 625
 626 \f
 627 ;;;
 628 ;;; Program invocation.
 629 ;;;
 630
 631 (define-condition-type &invoke-error &error
 632   invoke-error?
 633   (program      invoke-error-program)
 634   (arguments    invoke-error-arguments)
 635   (exit-status  invoke-error-exit-status)
 636   (term-signal  invoke-error-term-signal)
 637   (stop-signal  invoke-error-stop-signal))
 638
 639 (define (invoke program . args)
 640   "Invoke PROGRAM with the given ARGS.  Raise an exception
 641 if the exit code is non-zero; otherwise return #t."
 642   (let ((code (apply system* program args)))
 643     (unless (zero? code)
 644       (raise (condition (&invoke-error
 645                          (program program)
 646                          (arguments args)
 647                          (exit-status (status:exit-val code))
 648                          (term-signal (status:term-sig code))
 649                          (stop-signal (status:stop-sig code))))))
 650     #t))
 651
 652 (define* (report-invoke-error c #:optional (port (current-error-port)))
 653   "Report to PORT about C, an '&invoke-error' condition, in a human-friendly
 654 way."
 655   (format port "command~{ ~s~} failed with ~:[signal~;status~] ~a~%"
 656           (cons (invoke-error-program c)
 657                 (invoke-error-arguments c))
 658           (invoke-error-exit-status c)
 659           (or (invoke-error-exit-status c)
 660               (invoke-error-term-signal c)
 661               (invoke-error-stop-signal c))))
 662
 663 \f
 664 ;;;
 665 ;;; Text substitution (aka. sed).
 666 ;;;
 667
 668 (define (with-atomic-file-replacement file proc)
 669   "Call PROC with two arguments: an input port for FILE, and an output
 670 port for the file that is going to replace FILE.  Upon success, FILE is
 671 atomically replaced by what has been written to the output port, and
 672 PROC's result is returned."
 673   (let* ((template (string-append file ".XXXXXX"))
 674          (out      (mkstemp! template))
 675          (mode     (stat:mode (stat file))))
 676     (with-throw-handler #t
 677       (lambda ()
 678         (call-with-input-file file
 679           (lambda (in)
 680             (let ((result (proc in out)))
 681               (close out)
 682               (chmod template mode)
 683               (rename-file template file)
 684               result))))
 685       (lambda (key . args)
 686         (false-if-exception (delete-file template))))))
 687
 688 (define (substitute file pattern+procs)
 689   "PATTERN+PROCS is a list of regexp/two-argument-procedure pairs.  For each
 690 line of FILE, and for each PATTERN that it matches, call the corresponding
 691 PROC as (PROC LINE MATCHES); PROC must return the line that will be written as
 692 a substitution of the original line.  Be careful about using '$' to match the
 693 end of a line; by itself it won't match the terminating newline of a line."
 694   (let ((rx+proc  (map (match-lambda
 695                         (((? regexp? pattern) . proc)
 696                          (cons pattern proc))
 697                         ((pattern . proc)
 698                          (cons (make-regexp pattern regexp/extended)
 699                                proc)))
 700                        pattern+procs)))
 701     (with-atomic-file-replacement file
 702       (lambda (in out)
 703         (let loop ((line (read-line in 'concat)))
 704           (if (eof-object? line)
 705               #t
 706               (let ((line (fold (lambda (r+p line)
 707                                   (match r+p
 708                                     ((regexp . proc)
 709                                      (match (list-matches regexp line)
 710                                        ((and m+ (_ _ ...))
 711                                         (proc line m+))
 712                                        (_ line)))))
 713                                 line
 714                                 rx+proc)))
 715                 (display line out)
 716                 (loop (read-line in 'concat)))))))))
 717
 718
 719 (define-syntax let-matches
 720   ;; Helper macro for `substitute*'.
 721   (syntax-rules (_)
 722     ((let-matches index match (_ vars ...) body ...)
 723      (let-matches (+ 1 index) match (vars ...)
 724                   body ...))
 725     ((let-matches index match (var vars ...) body ...)
 726      (let ((var (match:substring match index)))
 727        (let-matches (+ 1 index) match (vars ...)
 728                     body ...)))
 729     ((let-matches index match () body ...)
 730      (begin body ...))))
 731
 732 (define-syntax substitute*
 733   (syntax-rules ()
 734     "Substitute REGEXP in FILE by the string returned by BODY.  BODY is
 735 evaluated with each MATCH-VAR bound to the corresponding positional regexp
 736 sub-expression.  For example:
 737
 738   (substitute* file
 739      ((\"hello\")
 740       \"good morning\\n\")
 741      ((\"foo([a-z]+)bar(.*)$\" all letters end)
 742       (string-append \"baz\" letter end)))
 743
 744 Here, anytime a line of FILE contains \"hello\", it is replaced by \"good
 745 morning\".  Anytime a line of FILE matches the second regexp, ALL is bound to
 746 the complete match, LETTERS is bound to the first sub-expression, and END is
 747 bound to the last one.
 748
 749 When one of the MATCH-VAR is `_', no variable is bound to the corresponding
 750 match substring.
 751
 752 Alternatively, FILE may be a list of file names, in which case they are
 753 all subject to the substitutions.
 754
 755 Be careful about using '$' to match the end of a line; by itself it won't
 756 match the terminating newline of a line."
 757     ((substitute* file ((regexp match-var ...) body ...) ...)
 758      (let ()
 759        (define (substitute-one-file file-name)
 760          (substitute
 761           file-name
 762           (list (cons regexp
 763                       (lambda (l m+)
 764                         ;; Iterate over matches M+ and return the
 765                         ;; modified line based on L.
 766                         (let loop ((m* m+)  ; matches
 767                                    (o  0)   ; offset in L
 768                                    (r  '())) ; result
 769                           (match m*
 770                             (()
 771                              (let ((r (cons (substring l o) r)))
 772                                (string-concatenate-reverse r)))
 773                             ((m . rest)
 774                              (let-matches 0 m (match-var ...)
 775                                (loop rest
 776                                      (match:end m)
 777                                      (cons*
 778                                       (begin body ...)
 779                                       (substring l o (match:start m))
 780                                       r))))))))
 781                 ...)))
 782
 783        (match file
 784          ((files (... ...))
 785           (for-each substitute-one-file files))
 786          ((? string? f)
 787           (substitute-one-file f)))))))
 788
 789 \f
 790 ;;;
 791 ;;; Patching shebangs---e.g., /bin/sh -> /gnu/store/xyz...-bash/bin/sh.
 792 ;;;
 793
 794 (define* (dump-port in out
 795                     #:key (buffer-size 16384)
 796                     (progress (lambda (t k) (k))))
 797   "Read as much data as possible from IN and write it to OUT, using chunks of
 798 BUFFER-SIZE bytes.  Call PROGRESS at the beginning and after each successful
 799 transfer of BUFFER-SIZE bytes or less, passing it the total number of bytes
 800 transferred and the continuation of the transfer as a thunk."
 801   (define buffer
 802     (make-bytevector buffer-size))
 803
 804   (define (loop total bytes)
 805     (or (eof-object? bytes)
 806         (let ((total (+ total bytes)))
 807           (put-bytevector out buffer 0 bytes)
 808           (progress total
 809                     (lambda ()
 810                       (loop total
 811                             (get-bytevector-n! in buffer 0 buffer-size)))))))
 812
 813   ;; Make sure PROGRESS is called when we start so that it can measure
 814   ;; throughput.
 815   (progress 0
 816             (lambda ()
 817               (loop 0 (get-bytevector-n! in buffer 0 buffer-size)))))
 818
 819 (define (set-file-time file stat)
 820   "Set the atime/mtime of FILE to that specified by STAT."
 821   (utime file
 822          (stat:atime stat)
 823          (stat:mtime stat)
 824          (stat:atimensec stat)
 825          (stat:mtimensec stat)))
 826
 827 (define (get-char* p)
 828   ;; We call it `get-char', but that's really a binary version
 829   ;; thereof.  (The real `get-char' cannot be used here because our
 830   ;; bootstrap Guile is hacked to always use UTF-8.)
 831   (match (get-u8 p)
 832     ((? integer? x) (integer->char x))
 833     (x x)))
 834
 835 (define patch-shebang
 836   (let ((shebang-rx (make-regexp "^[[:blank:]]*([[:graph:]]+)[[:blank:]]*([[:graph:]]*)(.*)$")))
 837     (lambda* (file
 838               #:optional
 839               (path (search-path-as-string->list (getenv "PATH")))
 840               #:key (keep-mtime? #t))
 841       "Replace the #! interpreter file name in FILE by a valid one found in
 842 PATH, when FILE actually starts with a shebang.  Return #t when FILE was
 843 patched, #f otherwise.  When KEEP-MTIME? is true, the atime/mtime of
 844 FILE are kept unchanged."
 845       (define (patch p interpreter rest-of-line)
 846         (let* ((template (string-append file ".XXXXXX"))
 847                (out      (mkstemp! template))
 848                (st       (stat file))
 849                (mode     (stat:mode st)))
 850           (with-throw-handler #t
 851             (lambda ()
 852               (format out "#!~a~a~%"
 853                       interpreter rest-of-line)
 854               (dump-port p out)
 855               (close out)
 856               (chmod template mode)
 857               (rename-file template file)
 858               (when keep-mtime?
 859                 (set-file-time file st))
 860               #t)
 861             (lambda (key . args)
 862               (format (current-error-port)
 863                       "patch-shebang: ~a: error: ~a ~s~%"
 864                       file key args)
 865               (false-if-exception (delete-file template))
 866               #f))))
 867
 868       (call-with-ascii-input-file file
 869         (lambda (p)
 870           (and (eq? #\# (get-char* p))
 871                (eq? #\! (get-char* p))
 872                (let ((line (false-if-exception (read-line p))))
 873                  (and=> (and line (regexp-exec shebang-rx line))
 874                         (lambda (m)
 875                           (let* ((interp (match:substring m 1))
 876                                  (arg1 (match:substring m 2))
 877                                  (rest (match:substring m 3))
 878                                  (has-env (string-suffix? "/env" interp))
 879                                  (cmd (if has-env arg1 (basename interp)))
 880                                  (bin (search-path path cmd)))
 881                             (if bin
 882                                 (if (string=? bin interp)
 883                                     #f            ; nothing to do
 884                                     (if has-env
 885                                         (begin
 886                                           (format (current-error-port)
 887                                                   "patch-shebang: ~a: changing `~a' to `~a'~%"
 888                                                   file (string-append interp " " arg1) bin)
 889                                           (patch p bin rest))
 890                                       (begin
 891                                         (format (current-error-port)
 892                                                 "patch-shebang: ~a: changing `~a' to `~a'~%"
 893                                                 file interp bin)
 894                                         (patch p bin
 895                                                (if (string-null? arg1)
 896                                                    ""
 897                                                    (string-append " " arg1 rest))))))
 898                                 (begin
 899                                   (format (current-error-port)
 900                                           "patch-shebang: ~a: warning: no binary for interpreter `~a' found in $PATH~%"
 901                                           file (basename cmd))
 902                                   #f))))))))))))
 903
 904 (define* (patch-makefile-SHELL file #:key (keep-mtime? #t))
 905   "Patch the `SHELL' variable in FILE, which is supposedly a makefile.
 906 When KEEP-MTIME? is true, the atime/mtime of FILE are kept unchanged."
 907
 908   ;; For instance, Gettext-generated po/Makefile.in.in do not honor $SHELL.
 909
 910   ;; XXX: Unlike with `patch-shebang', FILE is always touched.
 911
 912   (define (find-shell name)
 913     (let ((shell (which name)))
 914       (unless shell
 915         (format (current-error-port)
 916                 "patch-makefile-SHELL: warning: no binary for shell `~a' found in $PATH~%"
 917                 name))
 918       shell))
 919
 920   (let ((st (stat file)))
 921     ;; Consider FILE is using an 8-bit encoding to avoid errors.
 922     (with-fluids ((%default-port-encoding #f))
 923       (substitute* file
 924         (("^ *SHELL[[:blank:]]*:?=[[:blank:]]*([[:graph:]]*/)([[:graph:]]+)(.*)$"
 925           _ dir shell args)
 926          (let* ((old (string-append dir shell))
 927                 (new (or (find-shell shell) old)))
 928            (unless (string=? new old)
 929              (format (current-error-port)
 930                      "patch-makefile-SHELL: ~a: changing `SHELL' from `~a' to `~a'~%"
 931                      file old new))
 932            (string-append "SHELL = " new args)))))
 933
 934    (when keep-mtime?
 935      (set-file-time file st))))
 936
 937 (define* (patch-/usr/bin/file file
 938                               #:key
 939                               (file-command (which "file"))
 940                               (keep-mtime? #t))
 941   "Patch occurrences of \"/usr/bin/file\" in FILE, replacing them with
 942 FILE-COMMAND.  When KEEP-MTIME? is true, keep FILE's modification time
 943 unchanged."
 944   (if (not file-command)
 945       (format (current-error-port)
 946               "patch-/usr/bin/file: warning: \
 947 no replacement 'file' command, doing nothing~%")
 948       (let ((st (stat file)))
 949         ;; Consider FILE is using an 8-bit encoding to avoid errors.
 950         (with-fluids ((%default-port-encoding #f))
 951           (substitute* file
 952             (("/usr/bin/file")
 953              (begin
 954                (format (current-error-port)
 955                        "patch-/usr/bin/file: ~a: changing `~a' to `~a'~%"
 956                        file "/usr/bin/file" file-command)
 957                file-command))))
 958
 959         (when keep-mtime?
 960           (set-file-time file st)))))
 961
 962 (define* (fold-port-matches proc init pattern port
 963                             #:optional (unmatched (lambda (_ r) r)))
 964   "Read from PORT character-by-character; for each match against
 965 PATTERN, call (PROC MATCH RESULT), where RESULT is seeded with INIT.
 966 PATTERN is a list of SRFI-14 char-sets.  Call (UNMATCHED CHAR RESULT)
 967 for each unmatched character."
 968   (define initial-pattern
 969     ;; The poor developer's regexp.
 970     (if (string? pattern)
 971         (map char-set (string->list pattern))
 972         pattern))
 973
 974   ;; Note: we're not really striving for performance here...
 975   (let loop ((chars   '())
 976              (pattern initial-pattern)
 977              (matched '())
 978              (result  init))
 979     (cond ((null? chars)
 980            (loop (list (get-char* port))
 981                  pattern
 982                  matched
 983                  result))
 984           ((null? pattern)
 985            (loop chars
 986                  initial-pattern
 987                  '()
 988                  (proc (list->string (reverse matched)) result)))
 989           ((eof-object? (car chars))
 990            (fold-right unmatched result matched))
 991           ((char-set-contains? (car pattern) (car chars))
 992            (loop (cdr chars)
 993                  (cdr pattern)
 994                  (cons (car chars) matched)
 995                  result))
 996           ((null? matched)                        ; common case
 997            (loop (cdr chars)
 998                  pattern
 999                  matched
1000                  (unmatched (car chars) result)))
1001           (else
1002            (let ((matched (reverse matched)))
1003              (loop (append (cdr matched) chars)
1004                    initial-pattern
1005                    '()
1006                    (unmatched (car matched) result)))))))
1007
1008 (define* (remove-store-references file
1009                                   #:optional (store (%store-directory)))
1010   "Remove from FILE occurrences of file names in STORE; return #t when
1011 store paths were encountered in FILE, #f otherwise.  This procedure is
1012 known as `nuke-refs' in Nixpkgs."
1013   (define pattern
1014     (let ((nix-base32-chars
1015            '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9
1016              #\a #\b #\c #\d #\f #\g #\h #\i #\j #\k #\l #\m #\n
1017              #\p #\q #\r #\s #\v #\w #\x #\y #\z)))
1018       `(,@(map char-set (string->list store))
1019         ,(char-set #\/)
1020         ,@(make-list 32 (list->char-set nix-base32-chars))
1021         ,(char-set #\-))))
1022
1023   (with-fluids ((%default-port-encoding #f))
1024     (with-atomic-file-replacement file
1025       (lambda (in out)
1026         ;; We cannot use `regexp-exec' here because it cannot deal with
1027         ;; strings containing NUL characters.
1028         (format #t "removing store references from `~a'...~%" file)
1029         (setvbuf in 'block 65536)
1030         (setvbuf out 'block 65536)
1031         (fold-port-matches (lambda (match result)
1032                              (put-bytevector out (string->utf8 store))
1033                              (put-u8 out (char->integer #\/))
1034                              (put-bytevector out
1035                                              (string->utf8
1036                                               "eeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee-"))
1037                              #t)
1038                            #f
1039                            pattern
1040                            in
1041                            (lambda (char result)
1042                              (put-u8 out (char->integer char))
1043                              result))))))
1044
1045 (define (wrapper? prog)
1046   "Return #t if PROG is a wrapper as produced by 'wrap-program'."
1047   (and (file-exists? prog)
1048        (let ((base (basename prog)))
1049          (and (string-prefix? "." base)
1050               (string-suffix? "-real" base)))))
1051
1052 (define* (wrap-program prog #:rest vars)
1053   "Make a wrapper for PROG.  VARS should look like this:
1054
1055   '(VARIABLE DELIMITER POSITION LIST-OF-DIRECTORIES)
1056
1057 where DELIMITER is optional.  ':' will be used if DELIMITER is not given.
1058
1059 For example, this command:
1060
1061   (wrap-program \"foo\"
1062                 '(\"PATH\" \":\" = (\"/gnu/.../bar/bin\"))
1063                 '(\"CERT_PATH\" suffix (\"/gnu/.../baz/certs\"
1064                                         \"/qux/certs\")))
1065
1066 will copy 'foo' to '.foo-real' and create the file 'foo' with the following
1067 contents:
1068
1069   #!location/of/bin/bash
1070   export PATH=\"/gnu/.../bar/bin\"
1071   export CERT_PATH=\"$CERT_PATH${CERT_PATH:+:}/gnu/.../baz/certs:/qux/certs\"
1072   exec -a $0 location/of/.foo-real \"$@\"
1073
1074 This is useful for scripts that expect particular programs to be in $PATH, for
1075 programs that expect particular shared libraries to be in $LD_LIBRARY_PATH, or
1076 modules in $GUILE_LOAD_PATH, etc.
1077
1078 If PROG has previously been wrapped by 'wrap-program', the wrapper is extended
1079 with definitions for VARS."
1080   (define wrapped-file
1081     (string-append (dirname prog) "/." (basename prog) "-real"))
1082
1083   (define already-wrapped?
1084     (file-exists? wrapped-file))
1085
1086   (define (last-line port)
1087     ;; Return the last line read from PORT and leave PORT's cursor right
1088     ;; before it.
1089     (let loop ((previous-line-offset 0)
1090                (previous-line "")
1091                (position (seek port 0 SEEK_CUR)))
1092       (match (read-line port 'concat)
1093         ((? eof-object?)
1094          (seek port previous-line-offset SEEK_SET)
1095          previous-line)
1096         ((? string? line)
1097          (loop position line (+ (string-length line) position))))))
1098
1099   (define (export-variable lst)
1100     ;; Return a string that exports an environment variable.
1101     (match lst
1102       ((var sep '= rest)
1103        (format #f "export ~a=\"~a\""
1104                var (string-join rest sep)))
1105       ((var sep 'prefix rest)
1106        (format #f "export ~a=\"~a${~a:+~a}$~a\""
1107                var (string-join rest sep) var sep var))
1108       ((var sep 'suffix rest)
1109        (format #f "export ~a=\"$~a${~a+~a}~a\""
1110                var var var sep (string-join rest sep)))
1111       ((var '= rest)
1112        (format #f "export ~a=\"~a\""
1113                var (string-join rest ":")))
1114       ((var 'prefix rest)
1115        (format #f "export ~a=\"~a${~a:+:}$~a\""
1116                var (string-join rest ":") var var))
1117       ((var 'suffix rest)
1118        (format #f "export ~a=\"$~a${~a:+:}~a\""
1119                var var var (string-join rest ":")))))
1120
1121   (if already-wrapped?
1122
1123       ;; PROG is already a wrapper: add the new "export VAR=VALUE" lines just
1124       ;; before the last line.
1125       (let* ((port (open-file prog "r+"))
1126              (last (last-line port)))
1127         (for-each (lambda (var)
1128                     (display (export-variable var) port)
1129                     (newline port))
1130                   vars)
1131         (display last port)
1132         (close-port port))
1133
1134       ;; PROG is not wrapped yet: create a shell script that sets VARS.
1135       (let ((prog-tmp (string-append wrapped-file "-tmp")))
1136         (link prog wrapped-file)
1137
1138         (call-with-output-file prog-tmp
1139           (lambda (port)
1140             (format port
1141                     "#!~a~%~a~%exec -a \"$0\" \"~a\" \"$@\"~%"
1142                     (which "bash")
1143                     (string-join (map export-variable vars) "\n")
1144                     (canonicalize-path wrapped-file))))
1145
1146         (chmod prog-tmp #o755)
1147         (rename-file prog-tmp prog))))
1148
1149 \f
1150 ;;;
1151 ;;; Locales.
1152 ;;;
1153
1154 (define (locale-category->string category)
1155   "Return the name of locale category CATEGORY, one of the 'LC_' constants.
1156 If CATEGORY is a bitwise or of several 'LC_' constants, an approximation is
1157 returned."
1158   (letrec-syntax ((convert (syntax-rules ()
1159                              ((_)
1160                               (number->string category))
1161                              ((_ first rest ...)
1162                               (if (= first category)
1163                                   (symbol->string 'first)
1164                                   (convert rest ...))))))
1165     (convert LC_ADDRESS LC_ALL LC_COLLATE LC_CTYPE
1166              LC_IDENTIFICATION LC_MEASUREMENT LC_MESSAGES LC_MONETARY
1167              LC_NAME LC_NUMERIC LC_PAPER LC_TELEPHONE
1168              LC_TIME)))
1169
1170 ;;; Local Variables:
1171 ;;; eval: (put 'call-with-output-file/atomic 'scheme-indent-function 1)
1172 ;;; eval: (put 'call-with-ascii-input-file 'scheme-indent-function 1)
1173 ;;; eval: (put 'with-throw-handler 'scheme-indent-function 1)
1174 ;;; eval: (put 'let-matches 'scheme-indent-function 3)
1175 ;;; eval: (put 'with-atomic-file-replacement 'scheme-indent-function 1)
1176 ;;; End: