guix/build/utils.scm

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