Merge branch 'master' into core-updates

4 files changed, 241 insertions, 0 deletions

diff --git a/tests/derivations.scm b/tests/derivations.scm
index 19bcebcb21..855b059d16 100644
--- a/tests/derivations.scm
+++ b/tests/derivations.scm
@@ -151,6 +151,28 @@
          ;; the contents.
          (valid-path? %store (derivation->output-path drv)))))
 
+(test-assert "identical files are deduplicated"
+  (let* ((build1  (add-text-to-store %store "one.sh"
+                                     "echo hello, world > \"$out\"\n"
+                                     '()))
+         (build2  (add-text-to-store %store "two.sh"
+                                     "# Hey!\necho hello, world > \"$out\"\n"
+                                     '()))
+         (drv1    (derivation %store "foo"
+                              %bash `(,build1)
+                              #:inputs `((,%bash) (,build1))))
+         (drv2    (derivation %store "bar"
+                              %bash `(,build2)
+                              #:inputs `((,%bash) (,build2)))))
+    (and (build-derivations %store (list drv1 drv2))
+         (let ((file1 (derivation->output-path drv1))
+               (file2 (derivation->output-path drv2)))
+           (and (valid-path? %store file1) (valid-path? %store file2)
+                (string=? (call-with-input-file file1 get-string-all)
+                          "hello, world\n")
+                (= (stat:ino (lstat file1))
+                   (stat:ino (lstat file2))))))))
+
 (test-assert "fixed-output-derivation?"
   (let* ((builder    (add-text-to-store %store "my-fixed-builder.sh"
                                         "echo -n hello > $out" '()))
diff --git a/tests/gexp.scm b/tests/gexp.scm
index bf52401c66..ea4df48403 100644
--- a/tests/gexp.scm
+++ b/tests/gexp.scm
@@ -324,6 +324,78 @@
     (return (string=? (derivation-file-name drv)
                       (derivation-file-name xdrv)))))
 
+(test-assertm "gexp->derivation, store copy"
+  (let ((build-one #~(call-with-output-file #$output
+                       (lambda (port)
+                         (display "This is the one." port))))
+        (build-two (lambda (one)
+                     #~(begin
+                         (mkdir #$output)
+                         (symlink #$one (string-append #$output "/one"))
+                         (call-with-output-file (string-append #$output "/two")
+                           (lambda (port)
+                             (display "This is the second one." port))))))
+        (build-drv #~(begin
+                       (use-modules (guix build store-copy))
+
+                       (mkdir #$output)
+                       (populate-store '("graph") #$output))))
+    (mlet* %store-monad ((one (gexp->derivation "one" build-one))
+                         (two (gexp->derivation "two" (build-two one)))
+                         (drv (gexp->derivation "store-copy" build-drv
+                                                #:references-graphs
+                                                `(("graph" ,two))
+                                                #:modules
+                                                '((guix build store-copy)
+                                                  (guix build utils))))
+                         (ok? (built-derivations (list drv)))
+                         (out -> (derivation->output-path drv)))
+      (let ((one (derivation->output-path one))
+            (two (derivation->output-path two)))
+        (return (and ok?
+                     (file-exists? (string-append out "/" one))
+                     (file-exists? (string-append out "/" two))
+                     (file-exists? (string-append out "/" two "/two"))
+                     (string=? (readlink (string-append out "/" two "/one"))
+                               one)))))))
+
+(test-assertm "gexp->derivation #:references-graphs"
+  (mlet* %store-monad
+      ((one (text-file "one" "hello, world"))
+       (two (gexp->derivation "two"
+                              #~(symlink #$one #$output:chbouib)))
+       (drv (gexp->derivation "ref-graphs"
+                              #~(begin
+                                  (use-modules (guix build store-copy))
+                                  (with-output-to-file #$output
+                                    (lambda ()
+                                      (write (call-with-input-file "guile"
+                                               read-reference-graph))))
+                                  (with-output-to-file #$output:one
+                                    (lambda ()
+                                      (write (call-with-input-file "one"
+                                               read-reference-graph))))
+                                  (with-output-to-file #$output:two
+                                    (lambda ()
+                                      (write (call-with-input-file "two"
+                                               read-reference-graph)))))
+                              #:references-graphs `(("one" ,one)
+                                                    ("two" ,two "chbouib")
+                                                    ("guile" ,%bootstrap-guile))
+                              #:modules '((guix build store-copy)
+                                          (guix build utils))))
+       (ok? (built-derivations (list drv)))
+       (guile-drv  (package->derivation %bootstrap-guile))
+       (g-one   -> (derivation->output-path drv "one"))
+       (g-two   -> (derivation->output-path drv "two"))
+       (g-guile -> (derivation->output-path drv)))
+    (return (and ok?
+                 (equal? (call-with-input-file g-one read) (list one))
+                 (equal? (call-with-input-file g-two read)
+                         (list one (derivation->output-path two "chbouib")))
+                 (equal? (call-with-input-file g-guile read)
+                         (list (derivation->output-path guile-drv)))))))
+
 (define shebang
   (string-append "#!" (derivation->output-path (%guile-for-build))
                  "/bin/guile --no-auto-compile"))
diff --git a/tests/lint.scm b/tests/lint.scm
new file mode 100644
index 0000000000..56558c904f
--- /dev/null
+++ b/tests/lint.scm
@@ -0,0 +1,110 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2012, 2013 Cyril Roelandt <tipecaml@gmail.com>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+
+(define-module (test-packages)
+  #:use-module (guix build download)
+  #:use-module (guix build-system gnu)
+  #:use-module (guix packages)
+  #:use-module (guix scripts lint)
+  #:use-module (guix ui)
+  #:use-module (gnu packages)
+  #:use-module (gnu packages pkg-config)
+  #:use-module (srfi srfi-64))
+
+;; Test the linter.
+
+
+(test-begin "lint")
+
+(define-syntax-rule (dummy-package name* extra-fields ...)
+  (package extra-fields ... (name name*) (version "0") (source #f)
+           (build-system gnu-build-system)
+           (synopsis #f) (description #f)
+           (home-page #f) (license #f) ))
+
+(define (call-with-warnings thunk)
+  (let ((port (open-output-string)))
+    (parameterize ((guix-warning-port port))
+      (thunk))
+    (get-output-string port)))
+
+(test-assert "synopsis: ends with a period"
+  (->bool
+   (string-contains (call-with-warnings
+                      (lambda ()
+                        (let ((pkg (dummy-package "x"
+                                     (synopsis "Bad synopsis."))))
+                          (check-synopsis-style pkg))))
+                    "no period allowed at the end of the synopsis")))
+
+(test-assert "synopsis: ends with 'etc.'"
+  (->bool
+   (string-null? (call-with-warnings
+                   (lambda ()
+                     (let ((pkg (dummy-package "x"
+                                  (synopsis "Foo, bar, etc."))))
+                       (check-synopsis-style pkg)))))))
+
+(test-assert "synopsis: starts with 'A'"
+  (->bool
+   (string-contains (call-with-warnings
+                      (lambda ()
+                        (let ((pkg (dummy-package "x"
+                                     (synopsis "A bad synopŝis"))))
+                          (check-synopsis-style pkg))))
+                    "no article allowed at the beginning of the synopsis")))
+
+(test-assert "synopsis: starts with 'An'"
+  (->bool
+   (string-contains (call-with-warnings
+                      (lambda ()
+                        (let ((pkg (dummy-package "x"
+                                     (synopsis "An awful synopsis"))))
+                        (check-synopsis-style pkg))))
+                    "no article allowed at the beginning of the synopsis")))
+
+(test-assert "inputs: pkg-config is probably a native input"
+  (->bool
+   (string-contains
+     (call-with-warnings
+       (lambda ()
+         (let ((pkg (dummy-package "x"
+                      (inputs `(("pkg-config" ,pkg-config))))))
+              (check-inputs-should-be-native pkg))))
+         "pkg-config should probably be a native input")))
+
+(test-assert "patches: file names"
+  (->bool
+   (string-contains
+     (call-with-warnings
+       (lambda ()
+         (let ((pkg (dummy-package "x"
+                      (source
+                       (origin
+                        (method url-fetch)
+                        (uri "someurl")
+                        (sha256 "somesha")
+                        (patches (list "/path/to/y.patch")))))))
+              (check-patches pkg))))
+         "file names of patches should start with the package name")))
+
+(test-end "lint")
+
+
+(exit (= (test-runner-fail-count (test-runner-current)) 0))
diff --git a/tests/profiles.scm b/tests/profiles.scm
index 047c5ba49b..99f1fd2763 100644
--- a/tests/profiles.scm
+++ b/tests/profiles.scm
@@ -26,6 +26,8 @@
   #:use-module (guix derivations)
   #:use-module (gnu packages bootstrap)
   #:use-module (ice-9 match)
+  #:use-module (ice-9 regex)
+  #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-64))
 
 ;; Test the (guix profiles) module.
@@ -53,6 +55,13 @@
   (manifest-entry (inherit guile-2.0.9)
     (output "debug")))
 
+(define glibc
+  (manifest-entry
+    (name "glibc")
+    (version "2.19")
+    (item "/gnu/store/...")
+    (output "out")))
+
 
 (test-begin "profiles")
 
@@ -136,6 +145,34 @@
          (equal? m1 m2)
          (null? (manifest-entries m3)))))
 
+(test-assert "manifest-transaction-effects"
+  (let* ((m0 (manifest (list guile-1.8.8)))
+         (t  (manifest-transaction
+              (install (list guile-2.0.9 glibc))
+              (remove (list (manifest-pattern (name "coreutils")))))))
+    (let-values (((remove install upgrade)
+                  (manifest-transaction-effects m0 t)))
+      (and (null? remove)
+           (equal? (list glibc) install)
+           (equal? (list (cons guile-1.8.8 guile-2.0.9)) upgrade)))))
+
+(test-assert "manifest-show-transaction"
+  (let* ((m (manifest (list guile-1.8.8)))
+         (t (manifest-transaction (install (list guile-2.0.9)))))
+    (let-values (((remove install upgrade)
+                  (manifest-transaction-effects m t)))
+      (with-store store
+        (and (string-match "guile\t1.8.8 → 2.0.9"
+                           (with-fluids ((%default-port-encoding "UTF-8"))
+                             (with-error-to-string
+                              (lambda ()
+                                (manifest-show-transaction store m t)))))
+             (string-match "guile\t1.8.8 -> 2.0.9"
+                           (with-fluids ((%default-port-encoding "ISO-8859-1"))
+                             (with-error-to-string
+                              (lambda ()
+                                (manifest-show-transaction store m t))))))))))
+
 (test-assert "profile-derivation"
   (run-with-store %store
     (mlet* %store-monad