1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
3 ;;; Copyright © 2013 Andreas Enge <andreas@enge.fr>
4 ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
5 ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
7 ;;; This file is part of GNU Guix.
9 ;;; GNU Guix is free software; you can redistribute it and/or modify it
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.
14 ;;; GNU Guix is distributed in the hope that it will be useful, but
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.
19 ;;; You should have received a copy of the GNU General Public License
20 ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
22 (define-module (guix build utils)
23 #:use-module (srfi srfi-1)
24 #:use-module (srfi srfi-11)
25 #:use-module (srfi srfi-26)
26 #:use-module (srfi srfi-60)
27 #:use-module (ice-9 ftw)
28 #:use-module (ice-9 match)
29 #:use-module (ice-9 regex)
30 #:use-module (ice-9 rdelim)
31 #:use-module (ice-9 format)
32 #:use-module (rnrs bytevectors)
33 #:use-module (rnrs io ports)
34 #:re-export (alist-cons
36 #:export (%store-directory
39 package-name->name+version
45 call-with-ascii-input-file
48 with-directory-excursion
52 delete-file-recursively
57 set-path-environment-variable
58 search-path-as-string->list
59 list->search-path-as-string
66 with-atomic-file-replacement
75 remove-store-references
78 locale-category->string))
85 (define (%store-directory)
86 "Return the directory name of the store."
87 (or (getenv "NIX_STORE")
90 (define (store-file-name? file)
91 "Return true if FILE is in the store."
92 (string-prefix? (%store-directory) file))
94 (define (strip-store-file-name file)
95 "Strip the '/gnu/store' and hash from FILE, a store file name. The result
96 is typically a \"PACKAGE-VERSION\" string."
98 (+ 34 (string-length (%store-directory)))))
100 (define (package-name->name+version name)
101 "Given NAME, a package name like \"foo-0.9.1b\", return two values:
102 \"foo\" and \"0.9.1b\". When the version part is unavailable, NAME and
103 #f are returned. The first hyphen followed by a digit is considered to
104 introduce the version part."
105 ;; See also `DrvName' in Nix.
108 (cut char-set-contains? char-set:digit <>))
110 (let loop ((chars (string->list name))
115 ((#\- (? number? n) rest ...)
116 (values (list->string (reverse prefix))
117 (list->string (cons n rest))))
119 (loop tail (cons head prefix))))))
121 (define parallel-job-count
122 ;; Number of processes to be passed next to GNU Make's `-j' argument.
124 (match (getenv "NIX_BUILD_CORES") ;set by the daemon
126 ("0" (current-processor-count))
127 (x (or (string->number x) 1)))))
129 (define (directory-exists? dir)
130 "Return #t if DIR exists and is a directory."
131 (let ((s (stat dir #f)))
133 (eq? 'directory (stat:type s)))))
135 (define (executable-file? file)
136 "Return #t if FILE exists and is executable."
137 (let ((s (stat file #f)))
139 (not (zero? (logand (stat:mode s) #o100))))))
141 (define (symbolic-link? file)
142 "Return #t if FILE is a symbolic link (aka. \"symlink\".)"
143 (eq? (stat:type (lstat file)) 'symlink))
145 (define (call-with-ascii-input-file file proc)
146 "Open FILE as an ASCII or binary file, and pass the resulting port to
147 PROC. FILE is closed when PROC's dynamic extent is left. Return the
148 return values of applying PROC to the port."
149 (let ((port (with-fluids ((%default-port-encoding #f))
150 ;; Use "b" so that `open-file' ignores `coding:' cookies.
151 (open-file file "rb"))))
158 (close-input-port port)))))
160 (define (file-header-match header)
161 "Return a procedure that returns true when its argument is a file starting
162 with the bytes in HEADER, a bytevector."
164 (bytevector-length header))
167 "Return true if FILE starts with the right magic bytes."
169 (call-with-input-file file
171 (get-bytevector-n port len))
172 #:binary #t #:guess-encoding #f))
176 (equal? (get-header) header))
178 (if (= EISDIR (system-error-errno args))
179 #f ;FILE is a directory
180 (apply throw args))))))
182 (define %elf-magic-bytes
183 ;; Magic bytes of ELF files. See <elf.h>.
184 (u8-list->bytevector (map char->integer (string->list "\x7FELF"))))
187 (file-header-match %elf-magic-bytes))
189 (define %ar-magic-bytes
190 ;; Magic bytes of archives created by 'ar'. See <ar.h>.
191 (u8-list->bytevector (map char->integer (string->list "!<arch>\n"))))
194 (file-header-match %ar-magic-bytes))
196 (define-syntax-rule (with-directory-excursion dir body ...)
197 "Run BODY with DIR as the process's current directory."
198 (let ((init (getcwd)))
207 (define (mkdir-p dir)
208 "Create directory DIR and all its ancestors."
210 (string-prefix? "/" dir))
213 (char-set-complement (char-set #\/)))
215 (let loop ((components (string-tokenize dir not-slash))
221 (let ((path (string-append root "/" head)))
227 (if (= EEXIST (system-error-errno args))
229 (apply throw args))))))
232 (define (install-file file directory)
233 "Create DIRECTORY if it does not exist and copy FILE in there under the same
236 (copy-file file (string-append directory "/" (basename file))))
238 (define* (copy-recursively source destination
240 (log (current-output-port))
241 (follow-symlinks? #f)
243 "Copy SOURCE directory to DESTINATION. Follow symlinks if FOLLOW-SYMLINKS?
244 is true; otherwise, just preserve them. When KEEP-MTIME? is true, keep the
245 modification time of the files in SOURCE on those of DESTINATION. Write
246 verbose output to the LOG port."
248 (let ((len (string-length source)))
250 (substring file len))))
252 (file-system-fold (const #t) ; enter?
253 (lambda (file stat result) ; leaf
254 (let ((dest (string-append destination
255 (strip-source file))))
256 (format log "`~a' -> `~a'~%" file dest)
257 (case (stat:type stat)
259 (let ((target (readlink file)))
260 (symlink target dest)))
262 (copy-file file dest)
264 (set-file-time dest stat))))))
265 (lambda (dir stat result) ; down
266 (let ((target (string-append destination
267 (strip-source dir))))
270 (set-file-time target stat))))
271 (lambda (dir stat result) ; up
274 (lambda (file stat errno result)
275 (format (current-error-port) "i/o error: ~a: ~a~%"
276 file (strerror errno))
285 (define* (delete-file-recursively dir
286 #:key follow-mounts?)
287 "Delete DIR recursively, like `rm -rf', without following symlinks. Don't
288 follow mount points either, unless FOLLOW-MOUNTS? is true. Report but ignore
290 (let ((dev (stat:dev (lstat dir))))
291 (file-system-fold (lambda (dir stat result) ; enter?
293 (= dev (stat:dev stat))))
294 (lambda (file stat result) ; leaf
297 (lambda (dir stat result) ; up
300 (lambda (file stat errno result)
301 (format (current-error-port)
302 "warning: failed to delete ~a: ~a~%"
303 file (strerror errno)))
307 ;; Don't follow symlinks.
310 (define (file-name-predicate regexp)
311 "Return a predicate that returns true when passed a file name whose base
312 name matches REGEXP."
313 (let ((file-rx (if (regexp? regexp)
315 (make-regexp regexp))))
317 (regexp-exec file-rx (basename file)))))
319 (define* (find-files dir #:optional (pred (const #t))
323 "Return the lexicographically sorted list of files under DIR for which PRED
324 returns true. PRED is passed two arguments: the absolute file name, and its
325 stat buffer; the default predicate always returns true. PRED can also be a
326 regular expression, in which case it is equivalent to (file-name-predicate
327 PRED). STAT is used to obtain file information; using 'lstat' means that
328 symlinks are not followed. If DIRECTORIES? is true, then directories will
329 also be included. If FAIL-ON-ERROR? is true, raise an exception upon error."
330 (let ((pred (if (procedure? pred)
332 (file-name-predicate pred))))
333 ;; Sort the result to get deterministic results.
334 (sort (file-system-fold (const #t)
335 (lambda (file stat result) ; leaf
339 (lambda (dir stat result) ; down
340 (if (and directories?
344 (lambda (dir stat result) ; up
346 (lambda (file stat result) ; skip
348 (lambda (file stat errno result)
349 (format (current-error-port) "find-files: ~a: ~a~%"
350 file (strerror errno))
352 (error "find-files failed"))
364 (define* (search-path-as-list files input-dirs
365 #:key (type 'directory) pattern)
366 "Return the list of directories among FILES of the given TYPE (a symbol as
367 returned by 'stat:type') that exist in INPUT-DIRS. Example:
369 (search-path-as-list '(\"share/emacs/site-lisp\" \"share/emacs/24.1\")
370 (list \"/package1\" \"/package2\" \"/package3\"))
371 => (\"/package1/share/emacs/site-lisp\"
372 \"/package3/share/emacs/site-lisp\")
374 When PATTERN is true, it is a regular expression denoting file names to look
375 for under the directories designated by FILES. For example:
377 (search-path-as-list '(\"xml\") (list docbook-xml docbook-xsl)
379 #:pattern \"^catalog\\\\.xml$\")
380 => (\"/…/xml/dtd/docbook/catalog.xml\"
381 \"/…/xml/xsl/docbook-xsl-1.78.1/catalog.xml\")
383 (append-map (lambda (input)
384 (append-map (lambda (file)
385 (let ((file (string-append input "/" file)))
386 ;; XXX: By using 'find-files', we implicitly
387 ;; assume #:type 'regular.
389 (find-files file pattern)
390 (let ((stat (stat file #f)))
391 (if (and stat (eq? type (stat:type stat)))
395 (delete-duplicates input-dirs)))
397 (define (list->search-path-as-string lst separator)
398 (string-join lst separator))
400 (define* (search-path-as-string->list path #:optional (separator #\:))
401 (string-tokenize path (char-set-complement (char-set separator))))
403 (define* (set-path-environment-variable env-var files input-dirs
408 "Look for each of FILES of the given TYPE (a symbol as returned by
409 'stat:type') in INPUT-DIRS. Set ENV-VAR to a SEPARATOR-separated path
410 accordingly. Example:
412 (set-path-environment-variable \"PKG_CONFIG\"
414 (list package1 package2))
416 When PATTERN is not #f, it must be a regular expression (really a string)
417 denoting file names to look for under the directories designated by FILES:
419 (set-path-environment-variable \"XML_CATALOG_FILES\"
421 (list docbook-xml docbook-xsl)
423 #:pattern \"^catalog\\\\.xml$\")
425 (let* ((path (search-path-as-list files input-dirs
428 (value (list->search-path-as-string path separator)))
429 (if (string-null? value)
431 ;; Never set ENV-VAR to an empty string because often, the empty
432 ;; string is equivalent to ".". This is the case for
433 ;; GUILE_LOAD_PATH in Guile 2.0, for instance.
435 (format #t "environment variable `~a' unset~%" env-var))
437 (setenv env-var value)
438 (format #t "environment variable `~a' set to `~a'~%"
441 (define (which program)
442 "Return the complete file name for PROGRAM as found in $PATH, or #f if
443 PROGRAM could not be found."
444 (search-path (search-path-as-string->list (getenv "PATH"))
451 ;;; In (guix build gnu-build-system), there are separate phases (configure,
452 ;;; build, test, install). They are represented as a list of name/procedure
453 ;;; pairs. The following procedures make it easy to change the list of
457 (define* (alist-cons-before reference key value alist
458 #:optional (key=? equal?))
459 "Insert the KEY/VALUE pair before the first occurrence of a pair whose key
460 is REFERENCE in ALIST. Use KEY=? to compare keys."
461 (let-values (((before after)
464 (key=? k reference)))
466 (append before (alist-cons key value after))))
468 (define* (alist-cons-after reference key value alist
469 #:optional (key=? equal?))
470 "Insert the KEY/VALUE pair after the first occurrence of a pair whose key
471 is REFERENCE in ALIST. Use KEY=? to compare keys."
472 (let-values (((before after)
475 (key=? k reference)))
478 ((reference after ...)
479 (append before (cons* reference `(,key . ,value) after)))
481 (append before `((,key . ,value)))))))
483 (define* (alist-replace key value alist #:optional (key=? equal?))
484 "Replace the first pair in ALIST whose car is KEY with the KEY/VALUE pair.
485 An error is raised when no such pair exists."
486 (let-values (((before after)
493 (append before (alist-cons key value after))))))
495 (define-syntax-rule (modify-phases phases mod-spec ...)
496 "Modify PHASES sequentially as per each MOD-SPEC, which may have one of the
499 (delete <old-phase-name>)
500 (replace <old-phase-name> <new-phase>)
501 (add-before <old-phase-name> <new-phase-name> <new-phase>)
502 (add-after <old-phase-name> <new-phase-name> <new-phase>)
504 Where every <*-phase-name> is an automatically quoted symbol, and <new-phase>
505 an expression evaluating to a procedure."
506 (let* ((phases* phases)
507 (phases* (%modify-phases phases* mod-spec))
511 (define-syntax %modify-phases
512 (syntax-rules (delete replace add-before add-after)
513 ((_ phases (delete old-phase-name))
514 (alist-delete old-phase-name phases))
515 ((_ phases (replace old-phase-name new-phase))
516 (alist-replace old-phase-name new-phase phases))
517 ((_ phases (add-before old-phase-name new-phase-name new-phase))
518 (alist-cons-before old-phase-name new-phase-name new-phase phases))
519 ((_ phases (add-after old-phase-name new-phase-name new-phase))
520 (alist-cons-after old-phase-name new-phase-name new-phase phases))))
524 ;;; Text substitution (aka. sed).
527 (define (with-atomic-file-replacement file proc)
528 "Call PROC with two arguments: an input port for FILE, and an output
529 port for the file that is going to replace FILE. Upon success, FILE is
530 atomically replaced by what has been written to the output port, and
531 PROC's result is returned."
532 (let* ((template (string-append file ".XXXXXX"))
533 (out (mkstemp! template))
534 (mode (stat:mode (stat file))))
535 (with-throw-handler #t
537 (call-with-input-file file
539 (let ((result (proc in out)))
541 (chmod template mode)
542 (rename-file template file)
545 (false-if-exception (delete-file template))))))
547 (define (substitute file pattern+procs)
548 "PATTERN+PROCS is a list of regexp/two-argument-procedure pairs. For each
549 line of FILE, and for each PATTERN that it matches, call the corresponding
550 PROC as (PROC LINE MATCHES); PROC must return the line that will be written as
551 a substitution of the original line. Be careful about using '$' to match the
552 end of a line; by itself it won't match the terminating newline of a line."
553 (let ((rx+proc (map (match-lambda
554 (((? regexp? pattern) . proc)
557 (cons (make-regexp pattern regexp/extended)
560 (with-atomic-file-replacement file
562 (let loop ((line (read-line in 'concat)))
563 (if (eof-object? line)
565 (let ((line (fold (lambda (r+p line)
568 (match (list-matches regexp line)
575 (loop (read-line in 'concat)))))))))
578 (define-syntax let-matches
579 ;; Helper macro for `substitute*'.
581 ((let-matches index match (_ vars ...) body ...)
582 (let-matches (+ 1 index) match (vars ...)
584 ((let-matches index match (var vars ...) body ...)
585 (let ((var (match:substring match index)))
586 (let-matches (+ 1 index) match (vars ...)
588 ((let-matches index match () body ...)
591 (define-syntax substitute*
593 "Substitute REGEXP in FILE by the string returned by BODY. BODY is
594 evaluated with each MATCH-VAR bound to the corresponding positional regexp
595 sub-expression. For example:
600 ((\"foo([a-z]+)bar(.*)$\" all letters end)
601 (string-append \"baz\" letter end)))
603 Here, anytime a line of FILE contains \"hello\", it is replaced by \"good
604 morning\". Anytime a line of FILE matches the second regexp, ALL is bound to
605 the complete match, LETTERS is bound to the first sub-expression, and END is
606 bound to the last one.
608 When one of the MATCH-VAR is `_', no variable is bound to the corresponding
611 Alternatively, FILE may be a list of file names, in which case they are
612 all subject to the substitutions.
614 Be careful about using '$' to match the end of a line; by itself it won't
615 match the terminating newline of a line."
616 ((substitute* file ((regexp match-var ...) body ...) ...)
618 (define (substitute-one-file file-name)
623 ;; Iterate over matches M+ and return the
624 ;; modified line based on L.
625 (let loop ((m* m+) ; matches
630 (let ((r (cons (substring l o) r)))
631 (string-concatenate-reverse r)))
633 (let-matches 0 m (match-var ...)
638 (substring l o (match:start m))
644 (for-each substitute-one-file files))
646 (substitute-one-file f)))))))
650 ;;; Patching shebangs---e.g., /bin/sh -> /gnu/store/xyz...-bash/bin/sh.
653 (define* (dump-port in out
654 #:key (buffer-size 16384)
655 (progress (lambda (t k) (k))))
656 "Read as much data as possible from IN and write it to OUT, using chunks of
657 BUFFER-SIZE bytes. Call PROGRESS at the beginning and after each successful
658 transfer of BUFFER-SIZE bytes or less, passing it the total number of bytes
659 transferred and the continuation of the transfer as a thunk."
661 (make-bytevector buffer-size))
663 (define (loop total bytes)
664 (or (eof-object? bytes)
665 (let ((total (+ total bytes)))
666 (put-bytevector out buffer 0 bytes)
670 (get-bytevector-n! in buffer 0 buffer-size)))))))
672 ;; Make sure PROGRESS is called when we start so that it can measure
676 (loop 0 (get-bytevector-n! in buffer 0 buffer-size)))))
678 (define (set-file-time file stat)
679 "Set the atime/mtime of FILE to that specified by STAT."
683 (stat:atimensec stat)
684 (stat:mtimensec stat)))
686 (define (get-char* p)
687 ;; We call it `get-char', but that's really a binary version
688 ;; thereof. (The real `get-char' cannot be used here because our
689 ;; bootstrap Guile is hacked to always use UTF-8.)
691 ((? integer? x) (integer->char x))
694 (define patch-shebang
695 (let ((shebang-rx (make-regexp "^[[:blank:]]*([[:graph:]]+)[[:blank:]]*([[:graph:]]*)(.*)$")))
698 (path (search-path-as-string->list (getenv "PATH")))
699 #:key (keep-mtime? #t))
700 "Replace the #! interpreter file name in FILE by a valid one found in
701 PATH, when FILE actually starts with a shebang. Return #t when FILE was
702 patched, #f otherwise. When KEEP-MTIME? is true, the atime/mtime of
703 FILE are kept unchanged."
704 (define (patch p interpreter rest-of-line)
705 (let* ((template (string-append file ".XXXXXX"))
706 (out (mkstemp! template))
708 (mode (stat:mode st)))
709 (with-throw-handler #t
711 (format out "#!~a~a~%"
712 interpreter rest-of-line)
715 (chmod template mode)
716 (rename-file template file)
718 (set-file-time file st))
721 (format (current-error-port)
722 "patch-shebang: ~a: error: ~a ~s~%"
724 (false-if-exception (delete-file template))
727 (call-with-ascii-input-file file
729 (and (eq? #\# (get-char* p))
730 (eq? #\! (get-char* p))
731 (let ((line (false-if-exception (read-line p))))
732 (and=> (and line (regexp-exec shebang-rx line))
734 (let* ((interp (match:substring m 1))
735 (arg1 (match:substring m 2))
736 (rest (match:substring m 3))
737 (has-env (string-suffix? "/env" interp))
738 (cmd (if has-env arg1 (basename interp)))
739 (bin (search-path path cmd)))
741 (if (string=? bin interp)
745 (format (current-error-port)
746 "patch-shebang: ~a: changing `~a' to `~a'~%"
747 file (string-append interp " " arg1) bin)
750 (format (current-error-port)
751 "patch-shebang: ~a: changing `~a' to `~a'~%"
754 (if (string-null? arg1)
756 (string-append " " arg1 rest))))))
758 (format (current-error-port)
759 "patch-shebang: ~a: warning: no binary for interpreter `~a' found in $PATH~%"
763 (define* (patch-makefile-SHELL file #:key (keep-mtime? #t))
764 "Patch the `SHELL' variable in FILE, which is supposedly a makefile.
765 When KEEP-MTIME? is true, the atime/mtime of FILE are kept unchanged."
767 ;; For instance, Gettext-generated po/Makefile.in.in do not honor $SHELL.
769 ;; XXX: Unlike with `patch-shebang', FILE is always touched.
771 (define (find-shell name)
772 (let ((shell (which name)))
774 (format (current-error-port)
775 "patch-makefile-SHELL: warning: no binary for shell `~a' found in $PATH~%"
779 (let ((st (stat file)))
780 ;; Consider FILE is using an 8-bit encoding to avoid errors.
781 (with-fluids ((%default-port-encoding #f))
783 (("^ *SHELL[[:blank:]]*:?=[[:blank:]]*([[:graph:]]*/)([[:graph:]]+)(.*)$"
785 (let* ((old (string-append dir shell))
786 (new (or (find-shell shell) old)))
787 (unless (string=? new old)
788 (format (current-error-port)
789 "patch-makefile-SHELL: ~a: changing `SHELL' from `~a' to `~a'~%"
791 (string-append "SHELL = " new args)))))
794 (set-file-time file st))))
796 (define* (patch-/usr/bin/file file
798 (file-command (which "file"))
800 "Patch occurrences of \"/usr/bin/file\" in FILE, replacing them with
801 FILE-COMMAND. When KEEP-MTIME? is true, keep FILE's modification time
803 (if (not file-command)
804 (format (current-error-port)
805 "patch-/usr/bin/file: warning: \
806 no replacement 'file' command, doing nothing~%")
807 (let ((st (stat file)))
808 ;; Consider FILE is using an 8-bit encoding to avoid errors.
809 (with-fluids ((%default-port-encoding #f))
813 (format (current-error-port)
814 "patch-/usr/bin/file: ~a: changing `~a' to `~a'~%"
815 file "/usr/bin/file" file-command)
819 (set-file-time file st)))))
821 (define* (fold-port-matches proc init pattern port
822 #:optional (unmatched (lambda (_ r) r)))
823 "Read from PORT character-by-character; for each match against
824 PATTERN, call (PROC MATCH RESULT), where RESULT is seeded with INIT.
825 PATTERN is a list of SRFI-14 char-sets. Call (UNMATCHED CHAR RESULT)
826 for each unmatched character."
827 (define initial-pattern
828 ;; The poor developer's regexp.
829 (if (string? pattern)
830 (map char-set (string->list pattern))
833 ;; Note: we're not really striving for performance here...
834 (let loop ((chars '())
835 (pattern initial-pattern)
839 (loop (list (get-char* port))
847 (proc (list->string (reverse matched)) result)))
848 ((eof-object? (car chars))
849 (fold-right unmatched result matched))
850 ((char-set-contains? (car pattern) (car chars))
853 (cons (car chars) matched)
855 ((null? matched) ; common case
859 (unmatched (car chars) result)))
861 (let ((matched (reverse matched)))
862 (loop (append (cdr matched) chars)
865 (unmatched (car matched) result)))))))
867 (define* (remove-store-references file
868 #:optional (store (%store-directory)))
869 "Remove from FILE occurrences of file names in STORE; return #t when
870 store paths were encountered in FILE, #f otherwise. This procedure is
871 known as `nuke-refs' in Nixpkgs."
873 (let ((nix-base32-chars
874 '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9
875 #\a #\b #\c #\d #\f #\g #\h #\i #\j #\k #\l #\m #\n
876 #\p #\q #\r #\s #\v #\w #\x #\y #\z)))
877 `(,@(map char-set (string->list store))
879 ,@(make-list 32 (list->char-set nix-base32-chars))
882 (with-fluids ((%default-port-encoding #f))
883 (with-atomic-file-replacement file
885 ;; We cannot use `regexp-exec' here because it cannot deal with
886 ;; strings containing NUL characters.
887 (format #t "removing store references from `~a'...~%" file)
888 (setvbuf in _IOFBF 65536)
889 (setvbuf out _IOFBF 65536)
890 (fold-port-matches (lambda (match result)
891 (put-bytevector out (string->utf8 store))
892 (put-u8 out (char->integer #\/))
895 "eeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee-"))
900 (lambda (char result)
901 (put-u8 out (char->integer char))
904 (define* (wrap-program prog #:rest vars)
905 "Make a wrapper for PROG. VARS should look like this:
907 '(VARIABLE DELIMITER POSITION LIST-OF-DIRECTORIES)
909 where DELIMITER is optional. ':' will be used if DELIMITER is not given.
911 For example, this command:
913 (wrap-program \"foo\"
914 '(\"PATH\" \":\" = (\"/gnu/.../bar/bin\"))
915 '(\"CERT_PATH\" suffix (\"/gnu/.../baz/certs\"
918 will copy 'foo' to '.foo-real' and create the file 'foo' with the following
921 #!location/of/bin/bash
922 export PATH=\"/gnu/.../bar/bin\"
923 export CERT_PATH=\"$CERT_PATH${CERT_PATH:+:}/gnu/.../baz/certs:/qux/certs\"
924 exec -a $0 location/of/.foo-real \"$@\"
926 This is useful for scripts that expect particular programs to be in $PATH, for
927 programs that expect particular shared libraries to be in $LD_LIBRARY_PATH, or
928 modules in $GUILE_LOAD_PATH, etc.
930 If PROG has previously been wrapped by wrap-program the wrapper will point to
931 the previous wrapper."
932 (define (wrapper-file-name number)
933 (format #f "~a/.~a-wrap-~2'0d" (dirname prog) (basename prog) number))
934 (define (next-wrapper-number)
936 (find-files (dirname prog)
937 (string-append "\\." (basename prog) "-wrap-.*"))))
940 (string->number (string-take-right (last wrappers) 2)))))
941 (define (wrapper-target number)
943 (let ((prog-real (string-append (dirname prog) "/."
944 (basename prog) "-real")))
945 (rename-file prog prog-real)
947 (wrapper-file-name number)))
949 (let* ((number (next-wrapper-number))
950 (target (wrapper-target number))
951 (wrapper (wrapper-file-name (1+ number)))
952 (prog-tmp (string-append target "-tmp")))
953 (define (export-variable lst)
954 ;; Return a string that exports an environment variable.
957 (format #f "export ~a=\"~a\""
958 var (string-join rest sep)))
959 ((var sep 'prefix rest)
960 (format #f "export ~a=\"~a${~a~a+~a}$~a\""
961 var (string-join rest sep) var sep sep var))
962 ((var sep 'suffix rest)
963 (format #f "export ~a=\"$~a${~a~a+~a}~a\""
964 var var var sep sep (string-join rest sep)))
966 (format #f "export ~a=\"~a\""
967 var (string-join rest ":")))
969 (format #f "export ~a=\"~a${~a:+:}$~a\""
970 var (string-join rest ":") var var))
972 (format #f "export ~a=\"$~a${~a:+:}~a\""
973 var var var (string-join rest ":")))))
975 (with-output-to-file prog-tmp
978 "#!~a~%~a~%exec -a \"$0\" \"~a\" \"$@\"~%"
980 (string-join (map export-variable vars)
982 (canonicalize-path target))))
984 (chmod prog-tmp #o755)
985 (rename-file prog-tmp wrapper)
986 (symlink wrapper prog-tmp)
987 (rename-file prog-tmp prog)))
994 (define (locale-category->string category)
995 "Return the name of locale category CATEGORY, one of the 'LC_' constants.
996 If CATEGORY is a bitwise or of several 'LC_' constants, an approximation is
998 (letrec-syntax ((convert (syntax-rules ()
1000 (number->string category))
1002 (if (= first category)
1003 (symbol->string 'first)
1004 (convert rest ...))))))
1005 (convert LC_ADDRESS LC_ALL LC_COLLATE LC_CTYPE
1006 LC_IDENTIFICATION LC_MEASUREMENT LC_MESSAGES LC_MONETARY
1007 LC_NAME LC_NUMERIC LC_PAPER LC_TELEPHONE
1010 ;;; Local Variables:
1011 ;;; eval: (put 'call-with-output-file/atomic 'scheme-indent-function 1)
1012 ;;; eval: (put 'call-with-ascii-input-file 'scheme-indent-function 1)
1013 ;;; eval: (put 'with-throw-handler 'scheme-indent-function 1)
1014 ;;; eval: (put 'let-matches 'scheme-indent-function 3)
1015 ;;; eval: (put 'with-atomic-file-replacement 'scheme-indent-function 1)