guix/build/utils.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2013 Andreas Enge <andreas@enge.fr>
   4 ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.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 utils)
  22   #:use-module (srfi srfi-1)
  23   #:use-module (srfi srfi-11)
  24   #:use-module (ice-9 ftw)
  25   #:use-module (ice-9 match)
  26   #:use-module (ice-9 regex)
  27   #:use-module (ice-9 rdelim)
  28   #:use-module (ice-9 format)
  29   #:use-module (rnrs bytevectors)
  30   #:use-module (rnrs io ports)
  31   #:re-export (alist-cons
  32                alist-delete)
  33   #:export (%store-directory
  34             parallel-job-count
  35
  36             directory-exists?
  37             executable-file?
  38             symbolic-link?
  39             call-with-ascii-input-file
  40             elf-file?
  41             ar-file?
  42             with-directory-excursion
  43             mkdir-p
  44             copy-recursively
  45             delete-file-recursively
  46             find-files
  47
  48             search-path-as-list
  49             set-path-environment-variable
  50             search-path-as-string->list
  51             list->search-path-as-string
  52             which
  53
  54             alist-cons-before
  55             alist-cons-after
  56             alist-replace
  57             with-atomic-file-replacement
  58             substitute
  59             substitute*
  60             dump-port
  61             set-file-time
  62             patch-shebang
  63             patch-makefile-SHELL
  64             patch-/usr/bin/file
  65             fold-port-matches
  66             remove-store-references
  67             wrap-program))
  68
  69
  70 ;;;
  71 ;;; Directories.
  72 ;;;
  73
  74 (define (%store-directory)
  75   "Return the directory name of the store."
  76   (or (getenv "NIX_STORE")
  77       "/gnu/store"))
  78
  79 (define parallel-job-count
  80   ;; Number of processes to be passed next to GNU Make's `-j' argument.
  81   (make-parameter
  82    (match (getenv "NIX_BUILD_CORES")              ;set by the daemon
  83      (#f  1)
  84      ("0" (current-processor-count))
  85      (x   (or (string->number x) 1)))))
  86
  87 (define (directory-exists? dir)
  88   "Return #t if DIR exists and is a directory."
  89   (let ((s (stat dir #f)))
  90     (and s
  91          (eq? 'directory (stat:type s)))))
  92
  93 (define (executable-file? file)
  94   "Return #t if FILE exists and is executable."
  95   (let ((s (stat file #f)))
  96     (and s
  97          (not (zero? (logand (stat:mode s) #o100))))))
  98
  99 (define (symbolic-link? file)
 100   "Return #t if FILE is a symbolic link (aka. \"symlink\".)"
 101   (eq? (stat:type (lstat file)) 'symlink))
 102
 103 (define (call-with-ascii-input-file file proc)
 104   "Open FILE as an ASCII or binary file, and pass the resulting port to
 105 PROC.  FILE is closed when PROC's dynamic extent is left.  Return the
 106 return values of applying PROC to the port."
 107   (let ((port (with-fluids ((%default-port-encoding #f))
 108                 ;; Use "b" so that `open-file' ignores `coding:' cookies.
 109                 (open-file file "rb"))))
 110     (dynamic-wind
 111       (lambda ()
 112         #t)
 113       (lambda ()
 114         (proc port))
 115       (lambda ()
 116         (close-input-port port)))))
 117
 118 (define (file-header-match header)
 119   "Return a procedure that returns true when its argument is a file starting
 120 with the bytes in HEADER, a bytevector."
 121   (define len
 122     (bytevector-length header))
 123
 124   (lambda (file)
 125     "Return true if FILE starts with the right magic bytes."
 126     (define (get-header)
 127       (call-with-input-file file
 128         (lambda (port)
 129           (get-bytevector-n port len))
 130         #:binary #t #:guess-encoding #f))
 131
 132     (catch 'system-error
 133       (lambda ()
 134         (equal? (get-header) header))
 135       (lambda args
 136         (if (= EISDIR (system-error-errno args))
 137             #f                                    ;FILE is a directory
 138             (apply throw args))))))
 139
 140 (define %elf-magic-bytes
 141   ;; Magic bytes of ELF files.  See <elf.h>.
 142   (u8-list->bytevector (map char->integer (string->list "\x7FELF"))))
 143
 144 (define elf-file?
 145   (file-header-match %elf-magic-bytes))
 146
 147 (define %ar-magic-bytes
 148   ;; Magic bytes of archives created by 'ar'.  See <ar.h>.
 149   (u8-list->bytevector (map char->integer (string->list "!<arch>\n"))))
 150
 151 (define ar-file?
 152   (file-header-match %ar-magic-bytes))
 153
 154 (define-syntax-rule (with-directory-excursion dir body ...)
 155   "Run BODY with DIR as the process's current directory."
 156   (let ((init (getcwd)))
 157    (dynamic-wind
 158      (lambda ()
 159        (chdir dir))
 160      (lambda ()
 161        body ...)
 162      (lambda ()
 163        (chdir init)))))
 164
 165 (define (mkdir-p dir)
 166   "Create directory DIR and all its ancestors."
 167   (define absolute?
 168     (string-prefix? "/" dir))
 169
 170   (define not-slash
 171     (char-set-complement (char-set #\/)))
 172
 173   (let loop ((components (string-tokenize dir not-slash))
 174              (root       (if absolute?
 175                              ""
 176                              ".")))
 177     (match components
 178       ((head tail ...)
 179        (let ((path (string-append root "/" head)))
 180          (catch 'system-error
 181            (lambda ()
 182              (mkdir path)
 183              (loop tail path))
 184            (lambda args
 185              (if (= EEXIST (system-error-errno args))
 186                  (loop tail path)
 187                  (apply throw args))))))
 188       (() #t))))
 189
 190 (define* (copy-recursively source destination
 191                            #:key
 192                            (log (current-output-port))
 193                            (follow-symlinks? #f)
 194                            keep-mtime?)
 195   "Copy SOURCE directory to DESTINATION.  Follow symlinks if FOLLOW-SYMLINKS?
 196 is true; otherwise, just preserve them.  When KEEP-MTIME? is true, keep the
 197 modification time of the files in SOURCE on those of DESTINATION.  Write
 198 verbose output to the LOG port."
 199   (define strip-source
 200     (let ((len (string-length source)))
 201       (lambda (file)
 202         (substring file len))))
 203
 204   (file-system-fold (const #t)                    ; enter?
 205                     (lambda (file stat result)    ; leaf
 206                       (let ((dest (string-append destination
 207                                                  (strip-source file))))
 208                         (format log "`~a' -> `~a'~%" file dest)
 209                         (case (stat:type stat)
 210                           ((symlink)
 211                            (let ((target (readlink file)))
 212                              (symlink target dest)))
 213                           (else
 214                            (copy-file file dest)
 215                            (when keep-mtime?
 216                              (set-file-time dest stat))))))
 217                     (lambda (dir stat result)     ; down
 218                       (let ((target (string-append destination
 219                                                    (strip-source dir))))
 220                         (mkdir-p target)
 221                         (when keep-mtime?
 222                           (set-file-time target stat))))
 223                     (lambda (dir stat result)     ; up
 224                       result)
 225                     (const #t)                    ; skip
 226                     (lambda (file stat errno result)
 227                       (format (current-error-port) "i/o error: ~a: ~a~%"
 228                               file (strerror errno))
 229                       #f)
 230                     #t
 231                     source
 232
 233                     (if follow-symlinks?
 234                         stat
 235                         lstat)))
 236
 237 (define* (delete-file-recursively dir
 238                                   #:key follow-mounts?)
 239   "Delete DIR recursively, like `rm -rf', without following symlinks.  Don't
 240 follow mount points either, unless FOLLOW-MOUNTS? is true.  Report but ignore
 241 errors."
 242   (let ((dev (stat:dev (lstat dir))))
 243     (file-system-fold (lambda (dir stat result)    ; enter?
 244                         (or follow-mounts?
 245                             (= dev (stat:dev stat))))
 246                       (lambda (file stat result)   ; leaf
 247                         (delete-file file))
 248                       (const #t)                   ; down
 249                       (lambda (dir stat result)    ; up
 250                         (rmdir dir))
 251                       (const #t)                   ; skip
 252                       (lambda (file stat errno result)
 253                         (format (current-error-port)
 254                                 "warning: failed to delete ~a: ~a~%"
 255                                 file (strerror errno)))
 256                       #t
 257                       dir
 258
 259                       ;; Don't follow symlinks.
 260                       lstat)))
 261
 262 (define (find-files dir regexp)
 263   "Return the lexicographically sorted list of files under DIR whose basename
 264 matches REGEXP."
 265   (define file-rx
 266     (if (regexp? regexp)
 267         regexp
 268         (make-regexp regexp)))
 269
 270   ;; Sort the result to get deterministic results.
 271   (sort (file-system-fold (const #t)
 272                           (lambda (file stat result)   ; leaf
 273                             (if (regexp-exec file-rx (basename file))
 274                                 (cons file result)
 275                                 result))
 276                           (lambda (dir stat result)    ; down
 277                             result)
 278                           (lambda (dir stat result)    ; up
 279                             result)
 280                           (lambda (file stat result)   ; skip
 281                             result)
 282                           (lambda (file stat errno result)
 283                             (format (current-error-port) "find-files: ~a: ~a~%"
 284                                     file (strerror errno))
 285                             result)
 286                           '()
 287                           dir)
 288         string<?))
 289
 290 \f
 291 ;;;
 292 ;;; Search paths.
 293 ;;;
 294
 295 (define* (search-path-as-list files input-dirs
 296                               #:key (type 'directory) pattern)
 297   "Return the list of directories among FILES of the given TYPE (a symbol as
 298 returned by 'stat:type') that exist in INPUT-DIRS.  Example:
 299
 300   (search-path-as-list '(\"share/emacs/site-lisp\" \"share/emacs/24.1\")
 301                        (list \"/package1\" \"/package2\" \"/package3\"))
 302   => (\"/package1/share/emacs/site-lisp\"
 303       \"/package3/share/emacs/site-lisp\")
 304
 305 When PATTERN is true, it is a regular expression denoting file names to look
 306 for under the directories designated by FILES.  For example:
 307
 308   (search-path-as-list '(\"xml\") (list docbook-xml docbook-xsl)
 309                        #:type 'regular
 310                        #:pattern \"^catalog\\\\.xml$\")
 311   => (\"/…/xml/dtd/docbook/catalog.xml\"
 312       \"/…/xml/xsl/docbook-xsl-1.78.1/catalog.xml\")
 313 "
 314   (append-map (lambda (input)
 315                 (append-map (lambda (file)
 316                               (let ((file (string-append input "/" file)))
 317                                 ;; XXX: By using 'find-files', we implicitly
 318                                 ;; assume #:type 'regular.
 319                                 (if pattern
 320                                     (find-files file pattern)
 321                                     (let ((stat (stat file #f)))
 322                                       (if (and stat (eq? type (stat:type stat)))
 323                                           (list file)
 324                                           '())))))
 325                             files))
 326               (delete-duplicates input-dirs)))
 327
 328 (define (list->search-path-as-string lst separator)
 329   (string-join lst separator))
 330
 331 (define* (search-path-as-string->list path #:optional (separator #\:))
 332   (string-tokenize path (char-set-complement (char-set separator))))
 333
 334 (define* (set-path-environment-variable env-var files input-dirs
 335                                         #:key
 336                                         (separator ":")
 337                                         (type 'directory)
 338                                         pattern)
 339   "Look for each of FILES of the given TYPE (a symbol as returned by
 340 'stat:type') in INPUT-DIRS.  Set ENV-VAR to a SEPARATOR-separated path
 341 accordingly.  Example:
 342
 343   (set-path-environment-variable \"PKG_CONFIG\"
 344                                  '(\"lib/pkgconfig\")
 345                                  (list package1 package2))
 346
 347 When PATTERN is not #f, it must be a regular expression (really a string)
 348 denoting file names to look for under the directories designated by FILES:
 349
 350   (set-path-environment-variable \"XML_CATALOG_FILES\"
 351                                  '(\"xml\")
 352                                  (list docbook-xml docbook-xsl)
 353                                  #:type 'regular
 354                                  #:pattern \"^catalog\\\\.xml$\")
 355 "
 356   (let* ((path  (search-path-as-list files input-dirs
 357                                      #:type type
 358                                      #:pattern pattern))
 359          (value (list->search-path-as-string path separator)))
 360     (if (string-null? value)
 361         (begin
 362           ;; Never set ENV-VAR to an empty string because often, the empty
 363           ;; string is equivalent to ".".  This is the case for
 364           ;; GUILE_LOAD_PATH in Guile 2.0, for instance.
 365           (unsetenv env-var)
 366           (format #t "environment variable `~a' unset~%" env-var))
 367         (begin
 368           (setenv env-var value)
 369           (format #t "environment variable `~a' set to `~a'~%"
 370                   env-var value)))))
 371
 372 (define (which program)
 373   "Return the complete file name for PROGRAM as found in $PATH, or #f if
 374 PROGRAM could not be found."
 375   (search-path (search-path-as-string->list (getenv "PATH"))
 376                program))
 377
 378 \f
 379 ;;;
 380 ;;; Phases.
 381 ;;;
 382 ;;; In (guix build gnu-build-system), there are separate phases (configure,
 383 ;;; build, test, install).  They are represented as a list of name/procedure
 384 ;;; pairs.  The following procedures make it easy to change the list of
 385 ;;; phases.
 386 ;;;
 387
 388 (define* (alist-cons-before reference key value alist
 389                             #:optional (key=? equal?))
 390   "Insert the KEY/VALUE pair before the first occurrence of a pair whose key
 391 is REFERENCE in ALIST.  Use KEY=? to compare keys."
 392   (let-values (((before after)
 393                 (break (match-lambda
 394                         ((k . _)
 395                          (key=? k reference)))
 396                        alist)))
 397     (append before (alist-cons key value after))))
 398
 399 (define* (alist-cons-after reference key value alist
 400                            #:optional (key=? equal?))
 401   "Insert the KEY/VALUE pair after the first occurrence of a pair whose key
 402 is REFERENCE in ALIST.  Use KEY=? to compare keys."
 403   (let-values (((before after)
 404                 (break (match-lambda
 405                         ((k . _)
 406                          (key=? k reference)))
 407                        alist)))
 408     (match after
 409       ((reference after ...)
 410        (append before (cons* reference `(,key . ,value) after)))
 411       (()
 412        (append before `((,key . ,value)))))))
 413
 414 (define* (alist-replace key value alist #:optional (key=? equal?))
 415   "Replace the first pair in ALIST whose car is KEY with the KEY/VALUE pair.
 416 An error is raised when no such pair exists."
 417   (let-values (((before after)
 418                 (break (match-lambda
 419                         ((k . _)
 420                          (key=? k key)))
 421                        alist)))
 422     (match after
 423       ((_ after ...)
 424        (append before (alist-cons key value after))))))
 425
 426 \f
 427 ;;;
 428 ;;; Text substitution (aka. sed).
 429 ;;;
 430
 431 (define (with-atomic-file-replacement file proc)
 432   "Call PROC with two arguments: an input port for FILE, and an output
 433 port for the file that is going to replace FILE.  Upon success, FILE is
 434 atomically replaced by what has been written to the output port, and
 435 PROC's result is returned."
 436   (let* ((template (string-append file ".XXXXXX"))
 437          (out      (mkstemp! template))
 438          (mode     (stat:mode (stat file))))
 439     (with-throw-handler #t
 440       (lambda ()
 441         (call-with-input-file file
 442           (lambda (in)
 443             (let ((result (proc in out)))
 444               (close out)
 445               (chmod template mode)
 446               (rename-file template file)
 447               result))))
 448       (lambda (key . args)
 449         (false-if-exception (delete-file template))))))
 450
 451 (define (substitute file pattern+procs)
 452   "PATTERN+PROCS is a list of regexp/two-argument-procedure pairs.  For each
 453 line of FILE, and for each PATTERN that it matches, call the corresponding
 454 PROC as (PROC LINE MATCHES); PROC must return the line that will be written as
 455 a substitution of the original line.  Be careful about using '$' to match the
 456 end of a line; by itself it won't match the terminating newline of a line."
 457   (let ((rx+proc  (map (match-lambda
 458                         (((? regexp? pattern) . proc)
 459                          (cons pattern proc))
 460                         ((pattern . proc)
 461                          (cons (make-regexp pattern regexp/extended)
 462                                proc)))
 463                        pattern+procs)))
 464     (with-atomic-file-replacement file
 465       (lambda (in out)
 466         (let loop ((line (read-line in 'concat)))
 467           (if (eof-object? line)
 468               #t
 469               (let ((line (fold (lambda (r+p line)
 470                                   (match r+p
 471                                     ((regexp . proc)
 472                                      (match (list-matches regexp line)
 473                                        ((and m+ (_ _ ...))
 474                                         (proc line m+))
 475                                        (_ line)))))
 476                                 line
 477                                 rx+proc)))
 478                 (display line out)
 479                 (loop (read-line in 'concat)))))))))
 480
 481
 482 (define-syntax let-matches
 483   ;; Helper macro for `substitute*'.
 484   (syntax-rules (_)
 485     ((let-matches index match (_ vars ...) body ...)
 486      (let-matches (+ 1 index) match (vars ...)
 487                   body ...))
 488     ((let-matches index match (var vars ...) body ...)
 489      (let ((var (match:substring match index)))
 490        (let-matches (+ 1 index) match (vars ...)
 491                     body ...)))
 492     ((let-matches index match () body ...)
 493      (begin body ...))))
 494
 495 (define-syntax substitute*
 496   (syntax-rules ()
 497     "Substitute REGEXP in FILE by the string returned by BODY.  BODY is
 498 evaluated with each MATCH-VAR bound to the corresponding positional regexp
 499 sub-expression.  For example:
 500
 501   (substitute* file
 502      ((\"hello\")
 503       \"good morning\\n\")
 504      ((\"foo([a-z]+)bar(.*)$\" all letters end)
 505       (string-append \"baz\" letter end)))
 506
 507 Here, anytime a line of FILE contains \"hello\", it is replaced by \"good
 508 morning\".  Anytime a line of FILE matches the second regexp, ALL is bound to
 509 the complete match, LETTERS is bound to the first sub-expression, and END is
 510 bound to the last one.
 511
 512 When one of the MATCH-VAR is `_', no variable is bound to the corresponding
 513 match substring.
 514
 515 Alternatively, FILE may be a list of file names, in which case they are
 516 all subject to the substitutions.
 517
 518 Be careful about using '$' to match the end of a line; by itself it won't
 519 match the terminating newline of a line."
 520     ((substitute* file ((regexp match-var ...) body ...) ...)
 521      (let ()
 522        (define (substitute-one-file file-name)
 523          (substitute
 524           file-name
 525           (list (cons regexp
 526                       (lambda (l m+)
 527                         ;; Iterate over matches M+ and return the
 528                         ;; modified line based on L.
 529                         (let loop ((m* m+)  ; matches
 530                                    (o  0)   ; offset in L
 531                                    (r  '())) ; result
 532                           (match m*
 533                             (()
 534                              (let ((r (cons (substring l o) r)))
 535                                (string-concatenate-reverse r)))
 536                             ((m . rest)
 537                              (let-matches 0 m (match-var ...)
 538                                (loop rest
 539                                      (match:end m)
 540                                      (cons*
 541                                       (begin body ...)
 542                                       (substring l o (match:start m))
 543                                       r))))))))
 544                 ...)))
 545
 546        (match file
 547          ((files (... ...))
 548           (for-each substitute-one-file files))
 549          ((? string? f)
 550           (substitute-one-file f)))))))
 551
 552 \f
 553 ;;;
 554 ;;; Patching shebangs---e.g., /bin/sh -> /gnu/store/xyz...-bash/bin/sh.
 555 ;;;
 556
 557 (define* (dump-port in out
 558                     #:key (buffer-size 16384)
 559                     (progress (lambda (t k) (k))))
 560   "Read as much data as possible from IN and write it to OUT, using
 561 chunks of BUFFER-SIZE bytes.  Call PROGRESS after each successful
 562 transfer of BUFFER-SIZE bytes or less, passing it the total number of
 563 bytes transferred and the continuation of the transfer as a thunk."
 564   (define buffer
 565     (make-bytevector buffer-size))
 566
 567   (let loop ((total 0)
 568              (bytes (get-bytevector-n! in buffer 0 buffer-size)))
 569     (or (eof-object? bytes)
 570         (let ((total (+ total bytes)))
 571           (put-bytevector out buffer 0 bytes)
 572           (progress total
 573                     (lambda ()
 574                       (loop total
 575                             (get-bytevector-n! in buffer 0 buffer-size))))))))
 576
 577 (define (set-file-time file stat)
 578   "Set the atime/mtime of FILE to that specified by STAT."
 579   (utime file
 580          (stat:atime stat)
 581          (stat:mtime stat)
 582          (stat:atimensec stat)
 583          (stat:mtimensec stat)))
 584
 585 (define patch-shebang
 586   (let ((shebang-rx (make-regexp "^[[:blank:]]*([[:graph:]]+)[[:blank:]]*([[:graph:]]*)(.*)$")))
 587     (lambda* (file
 588               #:optional
 589               (path (search-path-as-string->list (getenv "PATH")))
 590               #:key (keep-mtime? #t))
 591       "Replace the #! interpreter file name in FILE by a valid one found in
 592 PATH, when FILE actually starts with a shebang.  Return #t when FILE was
 593 patched, #f otherwise.  When KEEP-MTIME? is true, the atime/mtime of
 594 FILE are kept unchanged."
 595       (define (patch p interpreter rest-of-line)
 596         (let* ((template (string-append file ".XXXXXX"))
 597                (out      (mkstemp! template))
 598                (st       (stat file))
 599                (mode     (stat:mode st)))
 600           (with-throw-handler #t
 601             (lambda ()
 602               (format out "#!~a~a~%"
 603                       interpreter rest-of-line)
 604               (dump-port p out)
 605               (close out)
 606               (chmod template mode)
 607               (rename-file template file)
 608               (when keep-mtime?
 609                 (set-file-time file st))
 610               #t)
 611             (lambda (key . args)
 612               (format (current-error-port)
 613                       "patch-shebang: ~a: error: ~a ~s~%"
 614                       file key args)
 615               (false-if-exception (delete-file template))
 616               #f))))
 617
 618       (call-with-ascii-input-file file
 619         (lambda (p)
 620           (and (eq? #\# (read-char p))
 621                (eq? #\! (read-char p))
 622                (let ((line (false-if-exception (read-line p))))
 623                  (and=> (and line (regexp-exec shebang-rx line))
 624                         (lambda (m)
 625                           (let* ((interp (match:substring m 1))
 626                                  (arg1 (match:substring m 2))
 627                                  (rest (match:substring m 3))
 628                                  (has-env (string-suffix? "/env" interp))
 629                                  (cmd (if has-env arg1 (basename interp)))
 630                                  (bin (search-path path cmd)))
 631                             (if bin
 632                                 (if (string=? bin interp)
 633                                     #f            ; nothing to do
 634                                     (if has-env
 635                                         (begin
 636                                           (format (current-error-port)
 637                                                   "patch-shebang: ~a: changing `~a' to `~a'~%"
 638                                                   file (string-append interp " " arg1) bin)
 639                                           (patch p bin rest))
 640                                       (begin
 641                                         (format (current-error-port)
 642                                                 "patch-shebang: ~a: changing `~a' to `~a'~%"
 643                                                 file interp bin)
 644                                         (patch p bin
 645                                                (if (string-null? arg1)
 646                                                    ""
 647                                                    (string-append " " arg1 rest))))))
 648                                 (begin
 649                                   (format (current-error-port)
 650                                           "patch-shebang: ~a: warning: no binary for interpreter `~a' found in $PATH~%"
 651                                           file (basename cmd))
 652                                   #f))))))))))))
 653
 654 (define* (patch-makefile-SHELL file #:key (keep-mtime? #t))
 655   "Patch the `SHELL' variable in FILE, which is supposedly a makefile.
 656 When KEEP-MTIME? is true, the atime/mtime of FILE are kept unchanged."
 657
 658   ;; For instance, Gettext-generated po/Makefile.in.in do not honor $SHELL.
 659
 660   ;; XXX: Unlike with `patch-shebang', FILE is always touched.
 661
 662   (define (find-shell name)
 663     (let ((shell (which name)))
 664       (unless shell
 665         (format (current-error-port)
 666                 "patch-makefile-SHELL: warning: no binary for shell `~a' found in $PATH~%"
 667                 name))
 668       shell))
 669
 670   (let ((st (stat file)))
 671    (substitute* file
 672      (("^ *SHELL[[:blank:]]*:?=[[:blank:]]*([[:graph:]]*/)([[:graph:]]+)(.*)$"
 673        _ dir shell args)
 674       (let* ((old (string-append dir shell))
 675              (new (or (find-shell shell) old)))
 676         (unless (string=? new old)
 677           (format (current-error-port)
 678                   "patch-makefile-SHELL: ~a: changing `SHELL' from `~a' to `~a'~%"
 679                   file old new))
 680         (string-append "SHELL = " new args))))
 681
 682    (when keep-mtime?
 683      (set-file-time file st))))
 684
 685 (define* (patch-/usr/bin/file file
 686                               #:key
 687                               (file-command (which "file"))
 688                               (keep-mtime? #t))
 689   "Patch occurrences of \"/usr/bin/file\" in FILE, replacing them with
 690 FILE-COMMAND.  When KEEP-MTIME? is true, keep FILE's modification time
 691 unchanged."
 692   (if (not file-command)
 693       (format (current-error-port)
 694               "patch-/usr/bin/file: warning: \
 695 no replacement 'file' command, doing nothing~%")
 696       (let ((st (stat file)))
 697         (substitute* file
 698           (("/usr/bin/file")
 699            (begin
 700              (format (current-error-port)
 701                      "patch-/usr/bin/file: ~a: changing `~a' to `~a'~%"
 702                      file "/usr/bin/file" file-command)
 703              file-command)))
 704
 705         (when keep-mtime?
 706           (set-file-time file st)))))
 707
 708 (define* (fold-port-matches proc init pattern port
 709                             #:optional (unmatched (lambda (_ r) r)))
 710   "Read from PORT character-by-character; for each match against
 711 PATTERN, call (PROC MATCH RESULT), where RESULT is seeded with INIT.
 712 PATTERN is a list of SRFI-14 char-sets.  Call (UNMATCHED CHAR RESULT)
 713 for each unmatched character."
 714   (define initial-pattern
 715     ;; The poor developer's regexp.
 716     (if (string? pattern)
 717         (map char-set (string->list pattern))
 718         pattern))
 719
 720   (define (get-char p)
 721     ;; We call it `get-char', but that's really a binary version
 722     ;; thereof.  (The real `get-char' cannot be used here because our
 723     ;; bootstrap Guile is hacked to always use UTF-8.)
 724     (match (get-u8 p)
 725       ((? integer? x) (integer->char x))
 726       (x x)))
 727
 728   ;; Note: we're not really striving for performance here...
 729   (let loop ((chars   '())
 730              (pattern initial-pattern)
 731              (matched '())
 732              (result  init))
 733     (cond ((null? chars)
 734            (loop (list (get-char port))
 735                  pattern
 736                  matched
 737                  result))
 738           ((null? pattern)
 739            (loop chars
 740                  initial-pattern
 741                  '()
 742                  (proc (list->string (reverse matched)) result)))
 743           ((eof-object? (car chars))
 744            (fold-right unmatched result matched))
 745           ((char-set-contains? (car pattern) (car chars))
 746            (loop (cdr chars)
 747                  (cdr pattern)
 748                  (cons (car chars) matched)
 749                  result))
 750           ((null? matched)                        ; common case
 751            (loop (cdr chars)
 752                  pattern
 753                  matched
 754                  (unmatched (car chars) result)))
 755           (else
 756            (let ((matched (reverse matched)))
 757              (loop (append (cdr matched) chars)
 758                    initial-pattern
 759                    '()
 760                    (unmatched (car matched) result)))))))
 761
 762 (define* (remove-store-references file
 763                                   #:optional (store (%store-directory)))
 764   "Remove from FILE occurrences of file names in STORE; return #t when
 765 store paths were encountered in FILE, #f otherwise.  This procedure is
 766 known as `nuke-refs' in Nixpkgs."
 767   (define pattern
 768     (let ((nix-base32-chars
 769            '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9
 770              #\a #\b #\c #\d #\f #\g #\h #\i #\j #\k #\l #\m #\n
 771              #\p #\q #\r #\s #\v #\w #\x #\y #\z)))
 772       `(,@(map char-set (string->list store))
 773         ,(char-set #\/)
 774         ,@(make-list 32 (list->char-set nix-base32-chars))
 775         ,(char-set #\-))))
 776
 777   (with-fluids ((%default-port-encoding #f))
 778     (with-atomic-file-replacement file
 779       (lambda (in out)
 780         ;; We cannot use `regexp-exec' here because it cannot deal with
 781         ;; strings containing NUL characters.
 782         (format #t "removing store references from `~a'...~%" file)
 783         (setvbuf in _IOFBF 65536)
 784         (setvbuf out _IOFBF 65536)
 785         (fold-port-matches (lambda (match result)
 786                              (put-bytevector out (string->utf8 store))
 787                              (put-u8 out (char->integer #\/))
 788                              (put-bytevector out
 789                                              (string->utf8
 790                                               "eeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee-"))
 791                              #t)
 792                            #f
 793                            pattern
 794                            in
 795                            (lambda (char result)
 796                              (put-u8 out (char->integer char))
 797                              result))))))
 798
 799 (define* (wrap-program prog #:rest vars)
 800   "Make a wrapper for PROG.  VARS should look like this:
 801
 802   '(VARIABLE DELIMITER POSITION LIST-OF-DIRECTORIES)
 803
 804 where DELIMITER is optional.  ':' will be used if DELIMITER is not given.
 805
 806 For example, this command:
 807
 808   (wrap-program \"foo\"
 809                 '(\"PATH\" \":\" = (\"/gnu/.../bar/bin\"))
 810                 '(\"CERT_PATH\" suffix (\"/gnu/.../baz/certs\"
 811                                         \"/qux/certs\")))
 812
 813 will copy 'foo' to '.foo-real' and create the file 'foo' with the following
 814 contents:
 815
 816   #!location/of/bin/bash
 817   export PATH=\"/gnu/.../bar/bin\"
 818   export CERT_PATH=\"$CERT_PATH${CERT_PATH:+:}/gnu/.../baz/certs:/qux/certs\"
 819   exec -a $0 location/of/.foo-real \"$@\"
 820
 821 This is useful for scripts that expect particular programs to be in $PATH, for
 822 programs that expect particular shared libraries to be in $LD_LIBRARY_PATH, or
 823 modules in $GUILE_LOAD_PATH, etc.
 824
 825 If PROG has previously been wrapped by wrap-program the wrapper will point to
 826 the previous wrapper."
 827   (define (wrapper-file-name number)
 828     (format #f "~a/.~a-wrap-~2'0d" (dirname prog) (basename prog) number))
 829   (define (next-wrapper-number)
 830     (let ((wrappers
 831            (find-files (dirname prog)
 832                        (string-append "\\." (basename prog) "-wrap-.*"))))
 833       (if (null? wrappers)
 834           0
 835           (string->number (string-take-right (last wrappers) 2)))))
 836   (define (wrapper-target number)
 837     (if (zero? number)
 838         (let ((prog-real (string-append (dirname prog) "/."
 839                                         (basename prog) "-real")))
 840           (rename-file prog prog-real)
 841           prog-real)
 842         (wrapper-file-name number)))
 843
 844   (let* ((number   (next-wrapper-number))
 845          (target   (wrapper-target number))
 846          (wrapper  (wrapper-file-name (1+ number)))
 847          (prog-tmp (string-append target "-tmp")))
 848     (define (export-variable lst)
 849       ;; Return a string that exports an environment variable.
 850       (match lst
 851         ((var sep '= rest)
 852          (format #f "export ~a=\"~a\""
 853                  var (string-join rest sep)))
 854         ((var sep 'prefix rest)
 855          (format #f "export ~a=\"~a${~a~a+~a}$~a\""
 856                  var (string-join rest sep) var sep sep var))
 857         ((var sep 'suffix rest)
 858          (format #f "export ~a=\"$~a${~a~a+~a}~a\""
 859                  var var var sep sep (string-join rest sep)))
 860         ((var '= rest)
 861          (format #f "export ~a=\"~a\""
 862                  var (string-join rest ":")))
 863         ((var 'prefix rest)
 864          (format #f "export ~a=\"~a${~a:+:}$~a\""
 865                  var (string-join rest ":") var var))
 866         ((var 'suffix rest)
 867          (format #f "export ~a=\"$~a${~a:+:}~a\""
 868                  var var var (string-join rest ":")))))
 869
 870     (with-output-to-file prog-tmp
 871       (lambda ()
 872         (format #t
 873                 "#!~a~%~a~%exec -a \"$0\" \"~a\" \"$@\"~%"
 874                 (which "bash")
 875                 (string-join (map export-variable vars)
 876                              "\n")
 877                 (canonicalize-path target))))
 878
 879     (chmod prog-tmp #o755)
 880     (rename-file prog-tmp wrapper)
 881     (symlink wrapper prog-tmp)
 882     (rename-file prog-tmp prog)))
 883
 884 ;;; Local Variables:
 885 ;;; eval: (put 'call-with-output-file/atomic 'scheme-indent-function 1)
 886 ;;; eval: (put 'call-with-ascii-input-file 'scheme-indent-function 1)
 887 ;;; eval: (put 'with-throw-handler 'scheme-indent-function 1)
 888 ;;; eval: (put 'let-matches 'scheme-indent-function 3)
 889 ;;; eval: (put 'with-atomic-file-replacement 'scheme-indent-function 1)
 890 ;;; End: