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