From 8d65c71f125798cf27c479b3e72ea61c9ba0d7b2 Mon Sep 17 00:00:00 2001 From: Alex Kost Date: Thu, 19 May 2016 19:11:58 +0300 Subject: packages: Use '--no-backup-if-mismatch' for patching. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Suggested-by: Ludovic Courtès * guix/packages.scm (patch-and-repack)[build]: Use '--no-backup-if-mismatch' patch flag to avoid making *.orig files. --- guix/packages.scm | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/packages.scm b/guix/packages.scm index 3646b9ba13..728b3afcae 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès ;;; Copyright © 2014, 2015 Mark H Weaver ;;; Copyright © 2015 Eric Bavier +;;; Copyright © 2016 Alex Kost ;;; ;;; This file is part of GNU Guix. ;;; @@ -478,9 +479,11 @@ (define (apply-patch patch) (format (current-error-port) "applying '~a'...~%" patch) ;; Use '--force' so that patches that do not apply perfectly are - ;; rejected. + ;; rejected. Use '--no-backup-if-mismatch' to prevent making + ;; "*.orig" file if a patch is applied with offset. (zero? (system* (string-append #+patch "/bin/patch") - "--force" #+@flags "--input" patch))) + "--force" "--no-backup-if-mismatch" + #+@flags "--input" patch))) (define (first-file directory) ;; Return the name of the first file in DIRECTORY. -- cgit v1.2.3 From 7ee5a694a89f508b62d2e5b569a80197b813462a Mon Sep 17 00:00:00 2001 From: Taylan Ulrich Bayırlı/Kammer Date: Mon, 20 Jun 2016 23:29:12 +0200 Subject: utils: Fix 'modify-phases' docstring. * guix/build/utils.scm (modify-phases): Fix the documentation string. --- guix/build/utils.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/build/utils.scm b/guix/build/utils.scm index 2988193fce..6e706b378e 100644 --- a/guix/build/utils.scm +++ b/guix/build/utils.scm @@ -518,8 +518,8 @@ (define-syntax-rule (modify-phases phases mod-spec ...) (add-before ) (add-after ) -Where every <*-phase-name> is an automatically quoted symbol, and -an expression evaluating to a procedure." +Where every <*-phase-name> is an expression evaluating to a symbol, and + an expression evaluating to a procedure." (let* ((phases* phases) (phases* (%modify-phases phases* mod-spec)) ...) -- cgit v1.2.3 From d1fb4af6b8118b62213f722a0bbeec3dddcec5a3 Mon Sep 17 00:00:00 2001 From: 宋文武 Date: Sat, 6 Aug 2016 18:28:57 +0800 Subject: profiles: gtk-icon-themes: Use 'gtk-update-icon-cache' from 'gtk+:bin'. This is a followup to commit 7b808d7. * guix/profiles.scm (gtk-icon-themes): Use 'gtk-update-icon-cache' from the "bin" output of gtk+ package. --- guix/profiles.scm | 21 +++++++++++++++------ 1 file changed, 15 insertions(+), 6 deletions(-) (limited to 'guix') diff --git a/guix/profiles.scm b/guix/profiles.scm index cd448e3f25..169c700f19 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -642,7 +642,18 @@ (define (dump file port) (define (gtk-icon-themes manifest) "Return a derivation that unions all icon themes from manifest entries and creates the GTK+ 'icon-theme.cache' file for each theme." - (mlet %store-monad ((gtk+ (manifest-lookup-package manifest "gtk+"))) + (define gtk+ ; lazy reference + (module-ref (resolve-interface '(gnu packages gtk)) 'gtk+)) + + (mlet %store-monad ((%gtk+ (manifest-lookup-package manifest "gtk+")) + ;; XXX: Can't use gtk-update-icon-cache corresponding + ;; to the gtk+ referenced by 'manifest'. Because + ;; '%gtk+' can be either a package or store path, and + ;; there's no way to get the "bin" output for the later. + (gtk-update-icon-cache + -> #~(string-append #+gtk+:bin + "/bin/gtk-update-icon-cache"))) + (define build (with-imported-modules '((guix build utils) (guix build union) @@ -659,9 +670,7 @@ (define build (let* ((destdir (string-append #$output "/share/icons")) (icondirs (filter file-exists? (map (cut string-append <> "/share/icons") - '#$(manifest-inputs manifest)))) - (update-icon-cache (string-append - #+gtk+ "/bin/gtk-update-icon-cache"))) + '#$(manifest-inputs manifest))))) ;; Union all the icons. (mkdir-p (string-append #$output "/share")) @@ -676,11 +685,11 @@ (define build ;; "abiword_48.png". Ignore these. (when (file-is-directory? dir) (ensure-writable-directory dir) - (system* update-icon-cache "-t" dir "--quiet")))) + (system* #+gtk-update-icon-cache "-t" dir "--quiet")))) (scandir destdir (negate (cut member <> '("." ".."))))))))) ;; Don't run the hook when there's nothing to do. - (if gtk+ + (if %gtk+ (gexp->derivation "gtk-icon-themes" build #:local-build? #t #:substitutable? #f) -- cgit v1.2.3 From ff43e353a1920a47a763024cd0682f2dc805964b Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 1 Sep 2016 23:48:08 +0200 Subject: build-system/gnu: 'strip' phase lists files in sorted order. This fixes a bug whereby the choice between stripping 'libfoo.so.0.1.2' and stripping 'libfoo.so' (the symlink) would be non-deterministic. * guix/build/gnu-build-system.scm (strip)[strip-dir]: Use 'find-files' instead of 'file-system-fold' so that files are picked in deterministic order. --- guix/build/gnu-build-system.scm | 31 +++++++++++-------------------- 1 file changed, 11 insertions(+), 20 deletions(-) (limited to 'guix') diff --git a/guix/build/gnu-build-system.scm b/guix/build/gnu-build-system.scm index 34edff7f40..ab97c92a2b 100644 --- a/guix/build/gnu-build-system.scm +++ b/guix/build/gnu-build-system.scm @@ -386,26 +386,17 @@ (define (strip-dir dir) (when debug-output (format #t "debugging output written to ~s using ~s~%" debug-output objcopy-command)) - (file-system-fold (const #t) - (lambda (path stat result) ; leaf - (and (file-exists? path) ;discard dangling symlinks - (or (elf-file? path) (ar-file? path)) - (or (not debug-output) - (make-debug-file path)) - (zero? (apply system* strip-command - (append strip-flags (list path)))) - (or (not debug-output) - (add-debug-link path)))) - (const #t) ; down - (const #t) ; up - (const #t) ; skip - (lambda (path stat errno result) - (format (current-error-port) - "strip: failed to access `~a': ~a~%" - path (strerror errno)) - #f) - #t - dir)) + + (for-each (lambda (file) + (and (file-exists? file) ;discard dangling symlinks + (or (elf-file? file) (ar-file? file)) + (or (not debug-output) + (make-debug-file file)) + (zero? (apply system* strip-command + (append strip-flags (list file)))) + (or (not debug-output) + (add-debug-link file)))) + (find-files dir))) (or (not strip-binaries?) (every strip-dir -- cgit v1.2.3 From b14a8385095f6672960fb8378c6578acf1ebbf8a Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 7 Sep 2016 23:59:02 +0200 Subject: utils: 'wrap-program' produces only one wrapper file. * guix/build/utils.scm (wrap-program)[wrapper-file-name] [next-wrapper-number, wrapper-target]: Remove. [wrapped-file, already-wrapped?]: New variables. [last-line]: New procedure. Use it to append to PROG when a wrapper already exists. * tests/build-utils.scm ("wrap-program, one input, multiple calls"): Adjust the list of files to delete. --- guix/build/utils.scm | 130 +++++++++++++++++++++++++++----------------------- tests/build-utils.scm | 3 +- 2 files changed, 72 insertions(+), 61 deletions(-) (limited to 'guix') diff --git a/guix/build/utils.scm b/guix/build/utils.scm index 6e706b378e..bc6f114152 100644 --- a/guix/build/utils.scm +++ b/guix/build/utils.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès +;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès ;;; Copyright © 2013 Andreas Enge ;;; Copyright © 2013 Nikita Karetnikov ;;; Copyright © 2015 Mark H Weaver @@ -944,64 +944,76 @@ (define* (wrap-program prog #:rest vars) programs that expect particular shared libraries to be in $LD_LIBRARY_PATH, or modules in $GUILE_LOAD_PATH, etc. -If PROG has previously been wrapped by wrap-program the wrapper will point to -the previous wrapper." - (define (wrapper-file-name number) - (format #f "~a/.~a-wrap-~2'0d" (dirname prog) (basename prog) number)) - (define (next-wrapper-number) - (let ((wrappers - (find-files (dirname prog) - (string-append "\\." (basename prog) "-wrap-.*")))) - (if (null? wrappers) - 0 - (string->number (string-take-right (last wrappers) 2))))) - (define (wrapper-target number) - (if (zero? number) - (let ((prog-real (string-append (dirname prog) "/." - (basename prog) "-real"))) - (rename-file prog prog-real) - prog-real) - (wrapper-file-name number))) - - (let* ((number (next-wrapper-number)) - (target (wrapper-target number)) - (wrapper (wrapper-file-name (1+ number))) - (prog-tmp (string-append target "-tmp"))) - (define (export-variable lst) - ;; Return a string that exports an environment variable. - (match lst - ((var sep '= rest) - (format #f "export ~a=\"~a\"" - var (string-join rest sep))) - ((var sep 'prefix rest) - (format #f "export ~a=\"~a${~a~a+~a}$~a\"" - var (string-join rest sep) var sep sep var)) - ((var sep 'suffix rest) - (format #f "export ~a=\"$~a${~a~a+~a}~a\"" - var var var sep sep (string-join rest sep))) - ((var '= rest) - (format #f "export ~a=\"~a\"" - var (string-join rest ":"))) - ((var 'prefix rest) - (format #f "export ~a=\"~a${~a:+:}$~a\"" - var (string-join rest ":") var var)) - ((var 'suffix rest) - (format #f "export ~a=\"$~a${~a:+:}~a\"" - var var var (string-join rest ":"))))) - - (with-output-to-file prog-tmp - (lambda () - (format #t - "#!~a~%~a~%exec -a \"$0\" \"~a\" \"$@\"~%" - (which "bash") - (string-join (map export-variable vars) - "\n") - (canonicalize-path target)))) - - (chmod prog-tmp #o755) - (rename-file prog-tmp wrapper) - (symlink wrapper prog-tmp) - (rename-file prog-tmp prog))) +If PROG has previously been wrapped by 'wrap-program', the wrapper is extended +with definitions for VARS." + (define wrapped-file + (string-append (dirname prog) "/." (basename prog) "-real")) + + (define already-wrapped? + (file-exists? wrapped-file)) + + (define (last-line port) + ;; Return the last line read from PORT and leave PORT's cursor right + ;; before it. + (let loop ((previous-line-offset 0) + (previous-line "") + (position (seek port 0 SEEK_CUR))) + (match (read-line port 'concat) + ((? eof-object?) + (seek port previous-line-offset SEEK_SET) + previous-line) + ((? string? line) + (loop position line (+ (string-length line) position)))))) + + (define (export-variable lst) + ;; Return a string that exports an environment variable. + (match lst + ((var sep '= rest) + (format #f "export ~a=\"~a\"" + var (string-join rest sep))) + ((var sep 'prefix rest) + (format #f "export ~a=\"~a${~a~a+~a}$~a\"" + var (string-join rest sep) var sep sep var)) + ((var sep 'suffix rest) + (format #f "export ~a=\"$~a${~a~a+~a}~a\"" + var var var sep sep (string-join rest sep))) + ((var '= rest) + (format #f "export ~a=\"~a\"" + var (string-join rest ":"))) + ((var 'prefix rest) + (format #f "export ~a=\"~a${~a:+:}$~a\"" + var (string-join rest ":") var var)) + ((var 'suffix rest) + (format #f "export ~a=\"$~a${~a:+:}~a\"" + var var var (string-join rest ":"))))) + + (if already-wrapped? + + ;; PROG is already a wrapper: add the new "export VAR=VALUE" lines just + ;; before the last line. + (let* ((port (open-file prog "r+")) + (last (last-line port))) + (for-each (lambda (var) + (display (export-variable var) port) + (newline port)) + vars) + (display last port) + (close-port port)) + + ;; PROG is not wrapped yet: create a shell script that sets VARS. + (let ((prog-tmp (string-append wrapped-file "-tmp"))) + (link prog wrapped-file) + + (call-with-output-file prog-tmp + (lambda (port) + (format port + "#!~a~%~a~%exec -a \"$0\" \"~a\" \"$@\"~%" + (which "bash") + (string-join (map export-variable vars) "\n") + (canonicalize-path wrapped-file)))) + + (chmod prog-tmp #o755) + (rename-file prog-tmp prog)))) ;;; diff --git a/tests/build-utils.scm b/tests/build-utils.scm index cc59b2eff7..7d49446f66 100644 --- a/tests/build-utils.scm +++ b/tests/build-utils.scm @@ -118,8 +118,7 @@ (define-module (test-build-utils) (let* ((pipe (open-input-pipe foo)) (str (get-string-all pipe))) (with-directory-excursion directory - (for-each delete-file - '("foo" ".foo-real" ".foo-wrap-01" ".foo-wrap-02"))) + (for-each delete-file '("foo" ".foo-real"))) (and (zero? (close-pipe pipe)) str)))))) -- cgit v1.2.3 From 5c9632c75afd57f2ee2d9ee7467ba9abcd2cb292 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 12 Sep 2016 21:51:25 +0200 Subject: build-system/gnu: Do not patch symlinks in the source. This is a followup to 13a9feb5b64fd819eaed38a17da0284bbe2b8d9. * guix/build/gnu-build-system.scm (patch-source-shebangs): Remove call to 'remove'. Pass a second argument to 'find-files' to filter out symlinks; pass #:stat lstat. (patch-generated-file-shebangs): Likewise, and also filter out non-executable files. --- guix/build/gnu-build-system.scm | 23 ++++++++++++----------- 1 file changed, 12 insertions(+), 11 deletions(-) (limited to 'guix') diff --git a/guix/build/gnu-build-system.scm b/guix/build/gnu-build-system.scm index ab97c92a2b..93ddc9abc8 100644 --- a/guix/build/gnu-build-system.scm +++ b/guix/build/gnu-build-system.scm @@ -172,22 +172,23 @@ (define* (patch-source-shebangs #:key source #:allow-other-keys) $CONFIG_SHELL, but some don't, such as `mkinstalldirs' or Automake's `missing' script." (for-each patch-shebang - (remove (lambda (file) - (or (not (file-exists? file)) ;dangling symlink - (file-is-directory? file))) - (find-files ".")))) + (find-files "." + (lambda (file stat) + ;; Filter out symlinks. + (eq? 'regular (stat:type stat))) + #:stat lstat))) (define (patch-generated-file-shebangs . rest) "Patch shebangs in generated files, including `SHELL' variables in makefiles." - ;; Patch executable files, some of which might have been generated by - ;; `configure'. + ;; Patch executable regular files, some of which might have been generated + ;; by `configure'. (for-each patch-shebang - (filter (lambda (file) - (and (file-exists? file) - (executable-file? file) - (not (file-is-directory? file)))) - (find-files "."))) + (find-files "." + (lambda (file stat) + (and (eq? 'regular (stat:type stat)) + (not (zero? (logand (stat:mode stat) #o100))))) + #:stat lstat)) ;; Patch `SHELL' in generated makefiles. (for-each patch-makefile-SHELL (find-files "." "^(GNU)?[mM]akefile$"))) -- cgit v1.2.3 From d31860b9de07810e114490db5cc160a8b078c58d Mon Sep 17 00:00:00 2001 From: John Darrington Date: Sun, 25 Sep 2016 07:43:21 +0200 Subject: build-system/gnu: Add 'patch-dot-desktop-files' phase. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/build/gnu-build-system.scm (patch-dot-desktop-files): New procedure. (%standard-phases): Add it. Co-authored-by: Ludovic Courtès --- guix/build/gnu-build-system.scm | 42 +++++++++++++++++++++++++++++++++++++++++ 1 file changed, 42 insertions(+) (limited to 'guix') diff --git a/guix/build/gnu-build-system.scm b/guix/build/gnu-build-system.scm index 93ddc9abc8..1dfd85450c 100644 --- a/guix/build/gnu-build-system.scm +++ b/guix/build/gnu-build-system.scm @@ -544,6 +544,47 @@ (define* (delete-info-dir-file #:key outputs #:allow-other-keys) outputs) #t) + +(define* (patch-dot-desktop-files #:key outputs inputs #:allow-other-keys) + "Replace any references to executables in '.desktop' files with their +absolute file names." + (define bin-directories + (append-map (match-lambda + ((_ . directory) + (list (string-append directory "/bin") + (string-append directory "/sbin")))) + outputs)) + + (define (which program) + (or (search-path bin-directories program) + (begin + (format (current-error-port) + "warning: '.desktop' file refers to '~a', \ +which cannot be found~%" + program) + program))) + + (for-each (match-lambda + ((_ . directory) + (let ((applications (string-append directory + "/share/applications"))) + (when (directory-exists? applications) + (let ((files (find-files applications "\\.desktop$"))) + (format #t "adjusting ~a '.desktop' files in ~s~%" + (length files) applications) + + ;; '.desktop' files contain translations and are always + ;; UTF-8-encoded. + (with-fluids ((%default-port-encoding "UTF-8")) + (substitute* files + (("^Exec=([^/[:blank:]\r\n]*)(.*)$" _ binary rest) + (string-append "Exec=" (which binary) rest)) + (("^TryExec=([^/[:blank:]\r\n]*)(.*)$" _ binary rest) + (string-append "TryExec=" + (which binary) rest))))))))) + outputs) + #t) + (define %standard-phases ;; Standard build phases, as a list of symbol/procedure pairs. (let-syntax ((phases (syntax-rules () @@ -556,6 +597,7 @@ (define %standard-phases validate-runpath validate-documentation-location delete-info-dir-file + patch-dot-desktop-files compress-documentation))) -- cgit v1.2.3 From 29d2f451a663ecf48b9a0709edea2ae2a4124f4d Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 20 Oct 2016 22:17:07 +0200 Subject: gnu-maintenance: GNOME updater honors 'upstream-name' package property. * guix/gnu-maintenance.scm (latest-gnome-release)[upstream-name]: New variable. Use it as the first argument to 'latest-ftp-release' and when constructing #:directory. * gnu/packages/gnome.scm (gconf)[properties]: New field. (network-manager)[properties]: New field. --- gnu/packages/gnome.scm | 6 ++++-- guix/gnu-maintenance.scm | 11 +++++++---- 2 files changed, 11 insertions(+), 6 deletions(-) (limited to 'guix') diff --git a/gnu/packages/gnome.scm b/gnu/packages/gnome.scm index 9e41f3a65e..dd8305144b 100644 --- a/gnu/packages/gnome.scm +++ b/gnu/packages/gnome.scm @@ -1130,7 +1130,8 @@ (define-public gconf (synopsis "Store application preferences") (description "Gconf is a system for storing application preferences. It is intended for user preferences; not arbitrary data storage.") - (license license:lgpl2.0+))) + (license license:lgpl2.0+) + (properties '((upstream-name . "GConf"))))) (define-public gnome-mime-data @@ -4481,7 +4482,8 @@ (define-public network-manager available. It manages ethernet, WiFi, mobile broadband (WWAN), and PPPoE devices, and provides VPN integration with a variety of different VPN services.") - (license license:gpl2+))) + (license license:gpl2+) + (properties '((upstream-name . "NetworkManager"))))) (define-public mobile-broadband-provider-info (package diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm index 20f08027da..78392c9a11 100644 --- a/guix/gnu-maintenance.scm +++ b/guix/gnu-maintenance.scm @@ -483,13 +483,16 @@ (define (even-numbered? file) (let-values (((name version) (package-name->name+version file))) (even-minor-version? (or version name)))) + (define upstream-name + ;; Some packages like "NetworkManager" have camel-case names. + (or (assoc-ref (package-properties package) 'upstream-name) + (package-name package))) + (false-if-ftp-error - (latest-ftp-release (package-name package) + (latest-ftp-release upstream-name #:server "ftp.gnome.org" #:directory (string-append "/pub/gnome/sources/" - (match (package-name package) - ("gconf" "GConf") - (x x))) + upstream-name) ;; explains -- cgit v1.2.3