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