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>
9 ;;; This file is part of GNU Guix.
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.
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.
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/>.
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
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>.
46 #:export (%store-directory
49 package-name->name+version
55 call-with-ascii-input-file
60 with-directory-excursion
65 delete-file-recursively
68 false-if-file-not-found
71 set-path-environment-variable
72 search-path-as-string->list
73 list->search-path-as-string
82 with-atomic-file-replacement
91 remove-store-references
103 invoke-error-arguments
104 invoke-error-exit-status
105 invoke-error-term-signal
106 invoke-error-stop-signal
111 locale-category->string))
115 ;;; Guile 2.0 compatibility later.
118 ;; The bootstrap Guile is Guile 2.0, so provide a compatibility layer.
120 ((and guile-2 (not guile-2.2))
121 (define (setvbuf port mode . rest)
122 (apply (@ (guile) setvbuf) port
127 (_ mode)) ;an _IO* integer
130 (module-replace! (current-module) '(setvbuf)))
138 (define (%store-directory)
139 "Return the directory name of the store."
140 (or (getenv "NIX_STORE")
143 (define (store-file-name? file)
144 "Return true if FILE is in the store."
145 (string-prefix? (%store-directory) file))
147 (define (strip-store-file-name file)
148 "Strip the '/gnu/store' and hash from FILE, a store file name. The result
149 is typically a \"PACKAGE-VERSION\" string."
151 (+ 34 (string-length (%store-directory)))))
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
157 introduce the version part."
158 ;; See also `DrvName' in Nix.
161 (cut char-set-contains? char-set:digit <>))
163 (let loop ((chars (string->list name))
168 ((#\- (? number? n) rest ...)
169 (values (list->string (reverse prefix))
170 (list->string (cons n rest))))
172 (loop tail (cons head prefix))))))
174 (define parallel-job-count
175 ;; Number of processes to be passed next to GNU Make's `-j' argument.
177 (match (getenv "NIX_BUILD_CORES") ;set by the daemon
179 ("0" (current-processor-count))
180 (x (or (string->number x) 1)))))
182 (define (directory-exists? dir)
183 "Return #t if DIR exists and is a directory."
184 (let ((s (stat dir #f)))
186 (eq? 'directory (stat:type s)))))
188 (define (executable-file? file)
189 "Return #t if FILE exists and is executable."
190 (let ((s (stat file #f)))
192 (not (zero? (logand (stat:mode s) #o100))))))
194 (define (symbolic-link? file)
195 "Return #t if FILE is a symbolic link (aka. \"symlink\".)"
196 (eq? (stat:type (lstat file)) 'symlink))
198 (define (call-with-ascii-input-file file proc)
199 "Open FILE as an ASCII or binary file, and pass the resulting port to
200 PROC. FILE is closed when PROC's dynamic extent is left. Return the
201 return 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"))))
211 (close-input-port port)))))
213 (define (file-header-match header)
214 "Return a procedure that returns true when its argument is a file starting
215 with the bytes in HEADER, a bytevector."
217 (bytevector-length header))
220 "Return true if FILE starts with the right magic bytes."
222 (call-with-input-file file
224 (get-bytevector-n port len))
225 #:binary #t #:guess-encoding #f))
229 (equal? (get-header) header))
231 (if (= EISDIR (system-error-errno args))
232 #f ;FILE is a directory
233 (apply throw args))))))
235 (define %elf-magic-bytes
236 ;; Magic bytes of ELF files. See <elf.h>.
237 (u8-list->bytevector (map char->integer (string->list "\x7FELF"))))
240 (file-header-match %elf-magic-bytes))
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"))))
247 (file-header-match %ar-magic-bytes))
249 (define %gzip-magic-bytes
250 ;; Magic bytes of gzip file. Beware, it's a small header so there could be
255 (file-header-match %gzip-magic-bytes))
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,
260 preserve FILE's modification time."
261 (let ((stat (stat file))
262 (port (open file O_RDWR)))
266 (and (= 4 (seek port 4 SEEK_SET))
267 (put-bytevector port #vu8(0 0 0 0))))
270 (set-file-time file stat)))))
272 (define-syntax-rule (with-directory-excursion dir body ...)
273 "Run BODY with DIR as the process's current directory."
274 (let ((init (getcwd)))
283 (define (mkdir-p dir)
284 "Create directory DIR and all its ancestors."
286 (string-prefix? "/" dir))
289 (char-set-complement (char-set #\/)))
291 (let loop ((components (string-tokenize dir not-slash))
297 (let ((path (string-append root "/" head)))
303 (if (= EEXIST (system-error-errno args))
305 (apply throw args))))))
308 (define (install-file file directory)
309 "Create DIRECTORY if it does not exist and copy FILE in there under the same
312 (copy-file file (string-append directory "/" (basename file))))
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)))))
319 (define* (copy-recursively source destination
321 (log (current-output-port))
322 (follow-symlinks? #f)
324 "Copy SOURCE directory to DESTINATION. Follow symlinks if FOLLOW-SYMLINKS?
325 is true; otherwise, just preserve them. When KEEP-MTIME? is true, keep the
326 modification time of the files in SOURCE on those of DESTINATION. Write
327 verbose output to the LOG port."
329 (let ((len (string-length source)))
331 (substring file len))))
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)
340 (let ((target (readlink file)))
341 (symlink target dest)))
343 (copy-file file dest)
345 (set-file-time dest stat))))))
346 (lambda (dir stat result) ; down
347 (let ((target (string-append destination
348 (strip-source dir))))
351 (set-file-time target stat))))
352 (lambda (dir stat result) ; up
355 (lambda (file stat errno result)
356 (format (current-error-port) "i/o error: ~a: ~a~%"
357 file (strerror errno))
366 (define* (delete-file-recursively dir
367 #:key follow-mounts?)
368 "Delete DIR recursively, like `rm -rf', without following symlinks. Don't
369 follow mount points either, unless FOLLOW-MOUNTS? is true. Report but ignore
371 (let ((dev (stat:dev (lstat dir))))
372 (file-system-fold (lambda (dir stat result) ; enter?
374 (= dev (stat:dev stat))))
375 (lambda (file stat result) ; leaf
378 (lambda (dir stat result) ; up
381 (lambda (file stat errno result)
382 (format (current-error-port)
383 "warning: failed to delete ~a: ~a~%"
384 file (strerror errno)))
388 ;; Don't follow symlinks.
391 (define (file-name-predicate regexp)
392 "Return a predicate that returns true when passed a file name whose base
393 name matches REGEXP."
394 (let ((file-rx (if (regexp? regexp)
396 (make-regexp regexp))))
398 (regexp-exec file-rx (basename file)))))
400 (define* (find-files dir #:optional (pred (const #t))
404 "Return the lexicographically sorted list of files under DIR for which PRED
405 returns true. PRED is passed two arguments: the absolute file name, and its
406 stat buffer; the default predicate always returns true. PRED can also be a
407 regular expression, in which case it is equivalent to (file-name-predicate
408 PRED). STAT is used to obtain file information; using 'lstat' means that
409 symlinks are not followed. If DIRECTORIES? is true, then directories will
410 also be included. If FAIL-ON-ERROR? is true, raise an exception upon error."
411 (let ((pred (if (procedure? 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
420 (lambda (dir stat result) ; down
421 (if (and directories?
425 (lambda (dir stat result) ; up
427 (lambda (file stat result) ; skip
429 (lambda (file stat errno result)
430 (format (current-error-port) "find-files: ~a: ~a~%"
431 file (strerror errno))
433 (error "find-files failed"))
440 (define-syntax-rule (false-if-file-not-found exp)
441 "Evaluate EXP but return #f if it raises to 'system-error with ENOENT."
445 (if (= ENOENT (system-error-errno args))
447 (apply throw args)))))
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
457 returned by 'stat:type') that exist in INPUT-DIRS. Example:
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\")
464 When PATTERN is true, it is a regular expression denoting file names to look
465 for under the directories designated by FILES. For example:
467 (search-path-as-list '(\"xml\") (list docbook-xml docbook-xsl)
469 #:pattern \"^catalog\\\\.xml$\")
470 => (\"/…/xml/dtd/docbook/catalog.xml\"
471 \"/…/xml/xsl/docbook-xsl-1.78.1/catalog.xml\")
473 (append-map (lambda (input)
474 (append-map (lambda (file)
475 (let ((file (string-append input "/" file)))
477 (find-files file (lambda (file stat)
479 (eq? type (stat:type stat))
480 ((file-name-predicate pattern) file stat)))
483 (let ((stat (stat file #f)))
484 (if (and stat (eq? type (stat:type stat)))
488 (delete-duplicates input-dirs)))
490 (define (list->search-path-as-string lst separator)
492 (string-join lst separator)
494 ((head rest ...) head)
497 (define* (search-path-as-string->list path #:optional (separator #\:))
499 (string-tokenize path
500 (char-set-complement (char-set separator)))
503 (define* (set-path-environment-variable env-var files input-dirs
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
510 accordingly. Example:
512 (set-path-environment-variable \"PKG_CONFIG\"
514 (list package1 package2))
516 When PATTERN is not #f, it must be a regular expression (really a string)
517 denoting file names to look for under the directories designated by FILES:
519 (set-path-environment-variable \"XML_CATALOG_FILES\"
521 (list docbook-xml docbook-xsl)
523 #:pattern \"^catalog\\\\.xml$\")
525 (let* ((path (search-path-as-list files input-dirs
528 (value (list->search-path-as-string path separator)))
529 (if (string-null? value)
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.
535 (format #t "environment variable `~a' unset~%" env-var))
537 (setenv env-var value)
538 (format #t "environment variable `~a' set to `~a'~%"
541 (define (which program)
542 "Return the complete file name for PROGRAM as found in $PATH, or #f if
543 PROGRAM could not be found."
544 (search-path (search-path-as-string->list (getenv "PATH"))
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
557 (define (every* pred lst)
558 "This is like 'every', but process all the elements of LST instead of
559 stopping as soon as PRED returns false. This is useful when PRED has side
560 effects, such as displaying warnings or error messages."
567 (loop tail (and (pred head) result))))))
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
572 is REFERENCE in ALIST. Use KEY=? to compare keys."
573 (let-values (((before after)
576 (key=? k reference)))
578 (append before (alist-cons key value after))))
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
583 is REFERENCE in ALIST. Use KEY=? to compare keys."
584 (let-values (((before after)
587 (key=? k reference)))
590 ((reference after ...)
591 (append before (cons* reference `(,key . ,value) after)))
593 (append before `((,key . ,value)))))))
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.
597 An error is raised when no such pair exists."
598 (let-values (((before after)
605 (append before (alist-cons key value after))))))
607 (define-syntax-rule (modify-phases phases mod-spec ...)
608 "Modify PHASES sequentially as per each MOD-SPEC, which may have one of the
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>)
616 Where 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))
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))))
636 ;;; Program invocation.
639 (define-condition-type &invoke-error &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))
647 (define (invoke program . args)
648 "Invoke PROGRAM with the given ARGS. Raise an exception
649 if the exit code is non-zero; otherwise return #t."
650 (let ((code (apply system* program args)))
652 (raise (condition (&invoke-error
655 (exit-status (status:exit-val code))
656 (term-signal (status:term-sig code))
657 (stop-signal (status:stop-sig code))))))
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
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))))
671 (define (open-pipe-with-stderr program . args)
672 "Run PROGRAM with ARGS in an input pipe, but, unlike 'open-pipe*', redirect
673 both its standard output and standard error to the pipe. Return two value:
674 the pipe to read PROGRAM's data from, and the PID of the child process running
676 ;; 'open-pipe*' doesn't attempt to capture stderr in any way, which is why
677 ;; we need to roll our own.
680 (match (primitive-fork)
686 (dup2 (fileno output) 1)
687 (dup2 (fileno output) 2)
688 (apply execlp program program args))
690 (primitive-exit 127))))
693 (values input pid))))))
695 (define (invoke/quiet program . args)
696 "Invoke PROGRAM with ARGS and capture PROGRAM's standard output and standard
697 error. If PROGRAM succeeds, print nothing and return the unspecified value;
698 otherwise, raise a '&message' error condition that includes the status code
699 and 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)
708 (unless (zero? status)
709 (let-syntax ((G_ (syntax-rules () ;for xgettext
713 (message (format #f (G_ "'~a~{ ~a~}' exited \
714 with status ~a; output follows:~%~%~{ ~a~%~}")
716 (or (status:exit-val status)
718 (reverse lines)))))))))))
720 (loop (cons line lines)))))))
724 ;;; Text substitution (aka. sed).
727 (define (with-atomic-file-replacement file proc)
728 "Call PROC with two arguments: an input port for FILE, and an output
729 port for the file that is going to replace FILE. Upon success, FILE is
730 atomically replaced by what has been written to the output port, and
731 PROC'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
737 (call-with-input-file file
739 (let ((result (proc in out)))
741 (chmod template mode)
742 (rename-file template file)
745 (false-if-exception (delete-file template))))))
747 (define (substitute file pattern+procs)
748 "PATTERN+PROCS is a list of regexp/two-argument-procedure pairs. For each
749 line of FILE, and for each PATTERN that it matches, call the corresponding
750 PROC as (PROC LINE MATCHES); PROC must return the line that will be written as
751 a substitution of the original line. Be careful about using '$' to match the
752 end 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)
757 (cons (make-regexp pattern regexp/extended)
760 (with-atomic-file-replacement file
762 (let loop ((line (read-line in 'concat)))
763 (if (eof-object? line)
765 (let ((line (fold (lambda (r+p line)
768 (match (list-matches regexp line)
775 (loop (read-line in 'concat)))))))))
778 (define-syntax let-matches
779 ;; Helper macro for `substitute*'.
781 ((let-matches index match (_ vars ...) body ...)
782 (let-matches (+ 1 index) match (vars ...)
784 ((let-matches index match (var vars ...) body ...)
785 (let ((var (match:substring match index)))
786 (let-matches (+ 1 index) match (vars ...)
788 ((let-matches index match () body ...)
791 (define-syntax substitute*
793 "Substitute REGEXP in FILE by the string returned by BODY. BODY is
794 evaluated with each MATCH-VAR bound to the corresponding positional regexp
795 sub-expression. For example:
800 ((\"foo([a-z]+)bar(.*)$\" all letters end)
801 (string-append \"baz\" letter end)))
803 Here, anytime a line of FILE contains \"hello\", it is replaced by \"good
804 morning\". Anytime a line of FILE matches the second regexp, ALL is bound to
805 the complete match, LETTERS is bound to the first sub-expression, and END is
806 bound to the last one.
808 When one of the MATCH-VAR is `_', no variable is bound to the corresponding
811 Alternatively, FILE may be a list of file names, in which case they are
812 all subject to the substitutions.
814 Be careful about using '$' to match the end of a line; by itself it won't
815 match the terminating newline of a line."
816 ((substitute* file ((regexp match-var ...) body ...) ...)
818 (define (substitute-one-file file-name)
823 ;; Iterate over matches M+ and return the
824 ;; modified line based on L.
825 (let loop ((m* m+) ; matches
830 (let ((r (cons (substring l o) r)))
831 (string-concatenate-reverse r)))
833 (let-matches 0 m (match-var ...)
838 (substring l o (match:start m))
844 (for-each substitute-one-file files))
846 (substitute-one-file f)))))))
850 ;;; Patching shebangs---e.g., /bin/sh -> /gnu/store/xyz...-bash/bin/sh.
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
857 BUFFER-SIZE bytes. Call PROGRESS at the beginning and after each successful
858 transfer of BUFFER-SIZE bytes or less, passing it the total number of bytes
859 transferred and the continuation of the transfer as a thunk."
861 (make-bytevector buffer-size))
863 (define (loop total bytes)
864 (or (eof-object? bytes)
865 (let ((total (+ total bytes)))
866 (put-bytevector out buffer 0 bytes)
870 (get-bytevector-n! in buffer 0 buffer-size)))))))
872 ;; Make sure PROGRESS is called when we start so that it can measure
876 (loop 0 (get-bytevector-n! in buffer 0 buffer-size)))))
878 (define (set-file-time file stat)
879 "Set the atime/mtime of FILE to that specified by STAT."
883 (stat:atimensec stat)
884 (stat:mtimensec stat)))
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.)
891 ((? integer? x) (integer->char x))
894 (define patch-shebang
895 (let ((shebang-rx (make-regexp "^[[:blank:]]*([[:graph:]]+)[[:blank:]]*([[:graph:]]*)(.*)$")))
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
901 PATH, when FILE actually starts with a shebang. Return #t when FILE was
902 patched, #f otherwise. When KEEP-MTIME? is true, the atime/mtime of
903 FILE are kept unchanged."
904 (define (patch p interpreter rest-of-line)
905 (let* ((template (string-append file ".XXXXXX"))
906 (out (mkstemp! template))
908 (mode (stat:mode st)))
909 (with-throw-handler #t
911 (format out "#!~a~a~%"
912 interpreter rest-of-line)
915 (chmod template mode)
916 (rename-file template file)
918 (set-file-time file st))
921 (format (current-error-port)
922 "patch-shebang: ~a: error: ~a ~s~%"
924 (false-if-exception (delete-file template))
927 (call-with-ascii-input-file file
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))
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)))
941 (if (string=? bin interp)
945 (format (current-error-port)
946 "patch-shebang: ~a: changing `~a' to `~a'~%"
947 file (string-append interp " " arg1) bin)
950 (format (current-error-port)
951 "patch-shebang: ~a: changing `~a' to `~a'~%"
954 (if (string-null? arg1)
956 (string-append " " arg1 rest))))))
958 (format (current-error-port)
959 "patch-shebang: ~a: warning: no binary for interpreter `~a' found in $PATH~%"
963 (define* (patch-makefile-SHELL file #:key (keep-mtime? #t))
964 "Patch the `SHELL' variable in FILE, which is supposedly a makefile.
965 When KEEP-MTIME? is true, the atime/mtime of FILE are kept unchanged."
967 ;; For instance, Gettext-generated po/Makefile.in.in do not honor $SHELL.
969 ;; XXX: Unlike with `patch-shebang', FILE is always touched.
971 (define (find-shell name)
972 (let ((shell (which name)))
974 (format (current-error-port)
975 "patch-makefile-SHELL: warning: no binary for shell `~a' found in $PATH~%"
979 (let ((st (stat file)))
980 ;; Consider FILE is using an 8-bit encoding to avoid errors.
981 (with-fluids ((%default-port-encoding #f))
983 (("^ *SHELL[[:blank:]]*:?=[[:blank:]]*([[:graph:]]*/)([[:graph:]]+)(.*)$"
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'~%"
991 (string-append "SHELL = " new args)))))
994 (set-file-time file st))))
996 (define* (patch-/usr/bin/file file
998 (file-command (which "file"))
1000 "Patch occurrences of \"/usr/bin/file\" in FILE, replacing them with
1001 FILE-COMMAND. When KEEP-MTIME? is true, keep FILE's modification time
1003 (if (not file-command)
1004 (format (current-error-port)
1005 "patch-/usr/bin/file: warning: \
1006 no 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))
1013 (format (current-error-port)
1014 "patch-/usr/bin/file: ~a: changing `~a' to `~a'~%"
1015 file "/usr/bin/file" file-command)
1019 (set-file-time file st)))))
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
1024 PATTERN, call (PROC MATCH RESULT), where RESULT is seeded with INIT.
1025 PATTERN is a list of SRFI-14 char-sets. Call (UNMATCHED CHAR RESULT)
1026 for each unmatched character."
1027 (define initial-pattern
1028 ;; The poor developer's regexp.
1029 (if (string? pattern)
1030 (map char-set (string->list pattern))
1033 ;; Note: we're not really striving for performance here...
1034 (let loop ((chars '())
1035 (pattern initial-pattern)
1038 (cond ((null? chars)
1039 (loop (list (get-char* port))
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))
1053 (cons (car chars) matched)
1055 ((null? matched) ; common case
1059 (unmatched (car chars) result)))
1061 (let ((matched (reverse matched)))
1062 (loop (append (cdr matched) chars)
1065 (unmatched (car matched) result)))))))
1067 (define* (remove-store-references file
1068 #:optional (store (%store-directory)))
1069 "Remove from FILE occurrences of file names in STORE; return #t when
1070 store paths were encountered in FILE, #f otherwise. This procedure is
1071 known as `nuke-refs' in Nixpkgs."
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))
1079 ,@(make-list 32 (list->char-set nix-base32-chars))
1082 (with-fluids ((%default-port-encoding #f))
1083 (with-atomic-file-replacement file
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 #\/))
1095 "eeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee-"))
1100 (lambda (char result)
1101 (put-u8 out (char->integer char))
1104 (define-condition-type &wrap-error &error
1106 (program wrap-error-program)
1107 (type wrap-error-type))
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)))))
1116 (define* (wrap-program prog #:rest vars)
1117 "Make a wrapper for PROG. VARS should look like this:
1119 '(VARIABLE DELIMITER POSITION LIST-OF-DIRECTORIES)
1121 where DELIMITER is optional. ':' will be used if DELIMITER is not given.
1123 For example, this command:
1125 (wrap-program \"foo\"
1126 '(\"PATH\" \":\" = (\"/gnu/.../bar/bin\"))
1127 '(\"CERT_PATH\" suffix (\"/gnu/.../baz/certs\"
1130 will copy 'foo' to '.foo-real' and create the file 'foo' with the following
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 \"$@\"
1138 This is useful for scripts that expect particular programs to be in $PATH, for
1139 programs that expect particular shared libraries to be in $LD_LIBRARY_PATH, or
1140 modules in $GUILE_LOAD_PATH, etc.
1142 If PROG has previously been wrapped by 'wrap-program', the wrapper is extended
1143 with definitions for VARS."
1144 (define wrapped-file
1145 (string-append (dirname prog) "/." (basename prog) "-real"))
1147 (define already-wrapped?
1148 (file-exists? wrapped-file))
1150 (define (last-line port)
1151 ;; Return the last line read from PORT and leave PORT's cursor right
1153 (let loop ((previous-line-offset 0)
1155 (position (seek port 0 SEEK_CUR)))
1156 (match (read-line port 'concat)
1158 (seek port previous-line-offset SEEK_SET)
1161 (loop position line (+ (string-length line) position))))))
1163 (define (export-variable lst)
1164 ;; Return a string that exports an environment variable.
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)))
1176 (format #f "export ~a=\"~a\""
1177 var (string-join rest ":")))
1179 (format #f "export ~a=\"~a${~a:+:}$~a\""
1180 var (string-join rest ":") var var))
1182 (format #f "export ~a=\"$~a${~a:+:}~a\""
1183 var var var (string-join rest ":")))))
1185 (if already-wrapped?
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)
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)
1202 (call-with-output-file prog-tmp
1205 "#!~a~%~a~%exec -a \"$0\" \"~a\" \"$@\"~%"
1207 (string-join (map export-variable vars) "\n")
1208 (canonicalize-path wrapped-file))))
1210 (chmod prog-tmp #o755)
1211 (rename-file prog-tmp prog))))
1214 (let ((interpreter-regex
1216 (string-append "^#! ?(/[^ ]+/bin/("
1217 (string-join '("python[^ ]*"
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
1229 is the same as in the WRAP-PROGRAM procedure. This procedure differs from
1230 WRAP-PROGRAM in that it does not create a separate shell script. Instead,
1231 PROG is modified directly by prepending a Guile script, which is interpreted
1232 as a comment in the script's language.
1234 Special encoding comments as supported by Python are recreated on the second
1237 Note that this procedure can only be used once per file as Guile scripts are
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)
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)))))
1256 `(setenv ,var ,(string-join rest ":")))
1258 `(let ((current (getenv ,var)))
1259 (setenv ,var (if current
1260 (string-append ,(string-join rest ":")
1262 ,(string-join 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
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))
1278 (and=> (regexp-exec coding-line-regex (read-line p))
1279 (lambda (m) (match:substring m 0))))))))))
1281 (let* ((header (format #f "\
1282 #!~a --no-auto-compile
1288 (or coding-line "Guix wrapper")
1289 (cons 'begin (map update-env
1291 ((#:guile _ . vars) vars)
1293 `(let ((cl (command-line)))
1294 (apply execl ,interpreter
1298 ',(string-split args #\space)
1300 (template (string-append prog ".XXXXXX"))
1301 (out (mkstemp! template))
1303 (mode (stat:mode st)))
1304 (with-throw-handler #t
1306 (call-with-ascii-input-file prog
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~%"
1318 (false-if-exception (delete-file template))
1320 (&wrap-error (program prog)
1324 (&wrap-error (program prog)
1325 (type 'no-interpreter-found)))))))))
1327 (define* (make-desktop-entry-file destination #:key
1328 (type "Application") ; One of "Application", "Link" or "Directory".
1338 (d-bus-activatable #f)
1345 (categories "Application")
1351 "Create a desktop entry file at DESTINATION.
1352 You must specify NAME.
1354 Values can be booleans, numbers, strings or list of strings.
1356 Additionally, locales can be specified with an alist where the key is the
1357 locale. The #f key specifies the default. Example:
1359 #:name '((#f \"I love Guix\") (\"fr\" \"J'aime Guix\"))
1364 Name[fr]=J'aime Guix
1366 For a complete description of the format, see the specifications at
1367 https://specifications.freedesktop.org/desktop-entry-spec/desktop-entry-spec-latest.html."
1368 (define (escape-semicolon s)
1369 (string-join (string-split s #\;) "\\;"))
1370 (define* (parse key value #:optional locale)
1371 (set! value (match value
1375 ((? string? s) (escape-semicolon s))
1377 (catch 'wrong-type-arg
1378 (lambda () (string-join (map escape-semicolon value) ";"))
1379 (lambda args (error "List arguments can only contain strings: ~a" args))))
1380 (_ (error "Value must be a boolean, number, string or list of strings"))))
1381 (format #t "~a=~a~%"
1383 (format #f "~a[~a]" key locale)
1387 (define key-error-message "This procedure only takes key arguments beside DESTINATION")
1390 (error "Missing NAME key argument"))
1391 (unless (member #:type all-args)
1392 (set! all-args (append (list #:type type) all-args)))
1393 (mkdir-p (dirname destination))
1395 (with-output-to-file destination
1397 (format #t "[Desktop Entry]~%")
1398 (let loop ((args all-args))
1401 ((_) (error key-error-message))
1403 (unless (keyword? key)
1404 (error key-error-message))
1406 (string-join (map string-titlecase
1407 (string-split (symbol->string
1408 (keyword->symbol key))
1413 (for-each (lambda (locale-subvalue)
1415 (if (and (list? (cdr locale-subvalue))
1416 (= 1 (length (cdr locale-subvalue))))
1417 ;; Support both proper and improper lists for convenience.
1418 (cadr locale-subvalue)
1419 (cdr locale-subvalue))
1420 (car locale-subvalue)))
1424 (loop (cddr args))))))))
1431 (define (locale-category->string category)
1432 "Return the name of locale category CATEGORY, one of the 'LC_' constants.
1433 If CATEGORY is a bitwise or of several 'LC_' constants, an approximation is
1435 (letrec-syntax ((convert (syntax-rules ()
1437 (number->string category))
1439 (if (= first category)
1440 (symbol->string 'first)
1441 (convert rest ...))))))
1442 (convert LC_ADDRESS LC_ALL LC_COLLATE LC_CTYPE
1443 LC_IDENTIFICATION LC_MEASUREMENT LC_MESSAGES LC_MONETARY
1444 LC_NAME LC_NUMERIC LC_PAPER LC_TELEPHONE
1447 ;;; Local Variables:
1448 ;;; eval: (put 'call-with-output-file/atomic 'scheme-indent-function 1)
1449 ;;; eval: (put 'call-with-ascii-input-file 'scheme-indent-function 1)
1450 ;;; eval: (put 'with-throw-handler 'scheme-indent-function 1)
1451 ;;; eval: (put 'let-matches 'scheme-indent-function 3)
1452 ;;; eval: (put 'with-atomic-file-replacement 'scheme-indent-function 1)