--- /dev/null
--- /dev/null
++;;; char-fold-tests.el --- Tests for char-fold.el -*- lexical-binding: t; -*-
++
++;; Copyright (C) 2013-2016 Free Software Foundation, Inc.
++
++;; Author: Artur Malabarba <bruce.connor.am@gmail.com>
++
++;; This program 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.
++
++;; This program 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 this program. If not, see <http://www.gnu.org/licenses/>.
++
++;;; Code:
++
++(require 'ert)
++(require 'char-fold)
++
++(defun char-fold--random-word (n)
++ (mapconcat (lambda (_) (string (+ 9 (random 117))))
++ (make-list n nil) ""))
++
++(defun char-fold--test-search-with-contents (contents string)
++ (with-temp-buffer
++ (insert contents)
++ (goto-char (point-min))
++ (should (search-forward-regexp (char-fold-to-regexp string) nil 'noerror))
++ (goto-char (point-min))
++ (should (char-fold-search-forward string nil 'noerror))
++ (should (char-fold-search-backward string nil 'noerror))))
++
++\f
++(ert-deftest char-fold--test-consistency ()
++ (dotimes (n 30)
++ (let ((w (char-fold--random-word n)))
++ ;; A folded string should always match the original string.
++ (char-fold--test-search-with-contents w w))))
++
++(ert-deftest char-fold--test-lax-whitespace ()
++ (dotimes (n 40)
++ (let ((w1 (char-fold--random-word n))
++ (w2 (char-fold--random-word n))
++ (search-spaces-regexp "\\s-+"))
++ (char-fold--test-search-with-contents
++ (concat w1 "\s\n\s\t\f\t\n\r\t" w2)
++ (concat w1 " " w2))
++ (char-fold--test-search-with-contents
++ (concat w1 "\s\n\s\t\f\t\n\r\t" w2)
++ (concat w1 (make-string 10 ?\s) w2)))))
++
++(defun char-fold--test-match-exactly (string &rest strings-to-match)
++ (let ((re (concat "\\`" (char-fold-to-regexp string) "\\'")))
++ (dolist (it strings-to-match)
++ (should (string-match re it)))
++ ;; Case folding
++ (let ((case-fold-search t))
++ (dolist (it strings-to-match)
++ (should (string-match (upcase re) (downcase it)))
++ (should (string-match (downcase re) (upcase it)))))))
++
++(ert-deftest char-fold--test-some-defaults ()
++ (dolist (it '(("ffl" . "ffl") ("ffi" . "ffi")
++ ("fi" . "fi") ("ff" . "ff")
++ ("ä" . "ä")))
++ (char-fold--test-search-with-contents (cdr it) (car it))
++ (let ((multi (char-table-extra-slot char-fold-table 0))
++ (char-fold-table (make-char-table 'char-fold-table)))
++ (set-char-table-extra-slot char-fold-table 0 multi)
++ (char-fold--test-match-exactly (car it) (cdr it)))))
++
++(ert-deftest char-fold--test-fold-to-regexp ()
++ (let ((char-fold-table (make-char-table 'char-fold-table))
++ (multi (make-char-table 'char-fold-table)))
++ (set-char-table-extra-slot char-fold-table 0 multi)
++ (aset char-fold-table ?a "xx")
++ (aset char-fold-table ?1 "44")
++ (aset char-fold-table ?\s "-!-")
++ (char-fold--test-match-exactly "a1a1" "xx44xx44")
++ (char-fold--test-match-exactly "a1 a 1" "xx44-!--!-xx-!-44")
++ (aset multi ?a '(("1" . "99")
++ ("2" . "88")
++ ("12" . "77")))
++ (char-fold--test-match-exactly "a" "xx")
++ (char-fold--test-match-exactly "a1" "xx44" "99")
++ (char-fold--test-match-exactly "a12" "77" "xx442" "992")
++ (char-fold--test-match-exactly "a2" "88")
++ (aset multi ?1 '(("2" . "yy")))
++ (char-fold--test-match-exactly "a1" "xx44" "99")
++ (char-fold--test-match-exactly "a12" "77" "xx442" "992")
++ ;; Support for this case is disabled. See function definition or:
++ ;; https://lists.gnu.org/archive/html/emacs-devel/2015-11/msg02562.html
++ ;; (char-fold--test-match-exactly "a12" "xxyy")
++ ))
++
++(ert-deftest char-fold--speed-test ()
++ (dolist (string (append '("tty-set-up-initial-frame-face"
++ "tty-set-up-initial-frame-face-frame-faceframe-faceframe-faceframe-face")
++ (mapcar #'char-fold--random-word '(10 50 100
++ 50 100))))
++ (message "Testing %s" string)
++ ;; Make sure we didn't just fallback on the trivial search.
++ (should-not (string= (regexp-quote string)
++ (char-fold-to-regexp string)))
++ (with-temp-buffer
++ (save-excursion (insert string))
++ (let ((time (time-to-seconds (current-time))))
++ ;; Our initial implementation of case-folding in char-folding
++ ;; created a lot of redundant paths in the regexp. Because of
++ ;; that, if a really long string "almost" matches, the regexp
++ ;; engine took a long time to realize that it doesn't match.
++ (should-not (char-fold-search-forward (concat string "c") nil 'noerror))
++ ;; Ensure it took less than a second.
++ (should (< (- (time-to-seconds (current-time))
++ time)
++ 1))))))
++
++(provide 'char-fold-tests)
++;;; char-fold-tests.el ends here
--- /dev/null
- (should (package-install 'signed-good))
- (should-error (package-install 'signed-bad))
+;;; package-test.el --- Tests for the Emacs package system
+
+;; Copyright (C) 2013-2016 Free Software Foundation, Inc.
+
+;; Author: Daniel Hackney <dan@haxney.org>
+;; Version: 1.0
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs 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 Emacs 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 Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; You may want to run this from a separate Emacs instance from your
+;; main one, because a bug in the code below could mess with your
+;; installed packages.
+
+;; Run this in a clean Emacs session using:
+;;
+;; $ emacs -Q --batch -L . -l package-test.el -l ert -f ert-run-tests-batch-and-exit
+
+;;; Code:
+
+(require 'package)
+(require 'ert)
+(require 'cl-lib)
+
+(setq package-menu-async nil)
+
+(defvar package-test-user-dir nil
+ "Directory to use for installing packages during testing.")
+
+(defvar package-test-file-dir (file-name-directory (or load-file-name
+ buffer-file-name))
+ "Directory of the actual \"package-test.el\" file.")
+
+(defvar simple-single-desc
+ (package-desc-create :name 'simple-single
+ :version '(1 3)
+ :summary "A single-file package with no dependencies"
+ :kind 'single
+ :extras '((:authors ("J. R. Hacker" . "jrh@example.com"))
+ (:maintainer "J. R. Hacker" . "jrh@example.com")
+ (:url . "http://doodles.au")))
+ "Expected `package-desc' parsed from simple-single-1.3.el.")
+
+(defvar simple-depend-desc
+ (package-desc-create :name 'simple-depend
+ :version '(1 0)
+ :summary "A single-file package with a dependency."
+ :kind 'single
+ :reqs '((simple-single (1 3)))
+ :extras '((:authors ("J. R. Hacker" . "jrh@example.com"))
+ (:maintainer "J. R. Hacker" . "jrh@example.com")))
+ "Expected `package-desc' parsed from simple-depend-1.0.el.")
+
+(defvar multi-file-desc
+ (package-desc-create :name 'multi-file
+ :version '(0 2 3)
+ :summary "Example of a multi-file tar package"
+ :kind 'tar
+ :extras '((:url . "http://puddles.li")))
+ "Expected `package-desc' from \"multi-file-0.2.3.tar\".")
+
+(defvar new-pkg-desc
+ (package-desc-create :name 'new-pkg
+ :version '(1 0)
+ :kind 'single)
+ "Expected `package-desc' parsed from new-pkg-1.0.el.")
+
+(defvar simple-depend-desc-1
+ (package-desc-create :name 'simple-depend-1
+ :version '(1 0)
+ :summary "A single-file package with a dependency."
+ :kind 'single
+ :reqs '((simple-depend (1 0))
+ (multi-file (0 1))))
+ "`package-desc' used for testing dependencies.")
+
+(defvar simple-depend-desc-2
+ (package-desc-create :name 'simple-depend-2
+ :version '(1 0)
+ :summary "A single-file package with a dependency."
+ :kind 'single
+ :reqs '((simple-depend-1 (1 0))
+ (multi-file (0 1))))
+ "`package-desc' used for testing dependencies.")
+
+(defvar package-test-data-dir (expand-file-name "package-resources" package-test-file-dir)
+ "Base directory of package test files.")
+
+(defvar package-test-fake-contents-file
+ (expand-file-name "archive-contents" package-test-data-dir)
+ "Path to a static copy of \"archive-contents\".")
+
+(cl-defmacro with-package-test ((&optional &key file
+ basedir
+ install
+ location
+ update-news
+ upload-base)
+ &rest body)
+ "Set up temporary locations and variables for testing."
+ (declare (indent 1))
+ `(let* ((package-test-user-dir (make-temp-file "pkg-test-user-dir-" t))
+ (process-environment (cons (format "HOME=%s" package-test-user-dir)
+ process-environment))
+ (package-user-dir package-test-user-dir)
+ (package-archives `(("gnu" . ,(or ,location package-test-data-dir))))
+ (default-directory package-test-file-dir)
+ abbreviated-home-dir
+ package--initialized
+ package-alist
+ ,@(if update-news
+ '(package-update-news-on-upload t)
+ (list (cl-gensym)))
+ ,@(if upload-base
+ '((package-test-archive-upload-base (make-temp-file "pkg-archive-base-" t))
+ (package-archive-upload-base package-test-archive-upload-base))
+ (list (cl-gensym)))) ;; Dummy value so `let' doesn't try to bind nil
+ (let ((buf (get-buffer "*Packages*")))
+ (when (buffer-live-p buf)
+ (kill-buffer buf)))
+ (unwind-protect
+ (progn
+ ,(if basedir `(cd ,basedir))
+ (unless (file-directory-p package-user-dir)
+ (mkdir package-user-dir))
+ (cl-letf (((symbol-function 'yes-or-no-p) (lambda (&rest r) t))
+ ((symbol-function 'y-or-n-p) (lambda (&rest r) t)))
+ ,@(when install
+ `((package-initialize)
+ (package-refresh-contents)
+ (mapc 'package-install ,install)))
+ (with-temp-buffer
+ ,(if file
+ `(insert-file-contents ,file))
+ ,@body)))
+
+ (when (file-directory-p package-test-user-dir)
+ (delete-directory package-test-user-dir t))
+
+ (when (and (boundp 'package-test-archive-upload-base)
+ (file-directory-p package-test-archive-upload-base))
+ (delete-directory package-test-archive-upload-base t)))))
+
+(defmacro with-fake-help-buffer (&rest body)
+ "Execute BODY in a temp buffer which is treated as the \"*Help*\" buffer."
+ `(with-temp-buffer
+ (help-mode)
+ ;; Trick `help-buffer' into using the temp buffer.
+ (let ((help-xref-following t))
+ ,@body)))
+
+(defun package-test-strip-version (dir)
+ (replace-regexp-in-string "-pkg\\.el\\'" "" (package--description-file dir)))
+
+(defun package-test-suffix-matches (base suffix-list)
+ "Return file names matching BASE concatenated with each item in SUFFIX-LIST"
+ (cl-mapcan
+ '(lambda (item) (file-expand-wildcards (concat base item)))
+ suffix-list))
+
+(defvar tar-parse-info)
+(declare-function tar-header-name "tar-mode" (cl-x) t) ; defstruct
+
+(defun package-test-search-tar-file (filename)
+ "Search the current buffer's `tar-parse-info' variable for FILENAME.
+
+Must called from within a `tar-mode' buffer."
+ (cl-dolist (header tar-parse-info)
+ (let ((tar-name (tar-header-name header)))
+ (when (string= tar-name filename)
+ (cl-return t)))))
+
+(defun package-test-desc-version-string (desc)
+ "Return the package version as a string."
+ (package-version-join (package-desc-version desc)))
+
+(ert-deftest package-test-desc-from-buffer ()
+ "Parse an elisp buffer to get a `package-desc' object."
+ (with-package-test (:basedir "package-resources" :file "simple-single-1.3.el")
+ (should (equal (package-buffer-info) simple-single-desc)))
+ (with-package-test (:basedir "package-resources" :file "simple-depend-1.0.el")
+ (should (equal (package-buffer-info) simple-depend-desc)))
+ (with-package-test (:basedir "package-resources"
+ :file "multi-file-0.2.3.tar")
+ (tar-mode)
+ (should (equal (package-tar-file-info) multi-file-desc))))
+
+(ert-deftest package-test-install-single ()
+ "Install a single file without using an archive."
+ (with-package-test (:basedir "package-resources" :file "simple-single-1.3.el")
+ (should (package-install-from-buffer))
+ (package-initialize)
+ (should (package-installed-p 'simple-single))
+ ;; Check if we properly report an "already installed".
+ (package-install 'simple-single)
+ (with-current-buffer "*Messages*"
+ (should (string-match "^[`‘']simple-single[’'] is already installed\n?\\'"
+ (buffer-string))))
+ (should (package-installed-p 'simple-single))
+ (let* ((simple-pkg-dir (file-name-as-directory
+ (expand-file-name
+ "simple-single-1.3"
+ package-test-user-dir)))
+ (autoloads-file (expand-file-name "simple-single-autoloads.el"
+ simple-pkg-dir)))
+ (should (file-directory-p simple-pkg-dir))
+ (with-temp-buffer
+ (insert-file-contents (expand-file-name "simple-single-pkg.el"
+ simple-pkg-dir))
+ (should (string= (buffer-string)
+ (concat ";;; -*- no-byte-compile: t -*-\n"
+ "(define-package \"simple-single\" \"1.3\" "
+ "\"A single-file package "
+ "with no dependencies\" 'nil "
+ ":authors '((\"J. R. Hacker\" . \"jrh@example.com\")) "
+ ":maintainer '(\"J. R. Hacker\" . \"jrh@example.com\") "
+ ":url \"http://doodles.au\""
+ ")\n"))))
+ (should (file-exists-p autoloads-file))
+ (should-not (get-file-buffer autoloads-file)))))
+
+(ert-deftest package-test-install-dependency ()
+ "Install a package which includes a dependency."
+ (with-package-test ()
+ (package-initialize)
+ (package-refresh-contents)
+ (package-install 'simple-depend)
+ (should (package-installed-p 'simple-single))
+ (should (package-installed-p 'simple-depend))))
+
+(ert-deftest package-test-macro-compilation ()
+ "Install a package which includes a dependency."
+ (with-package-test (:basedir "package-resources")
+ (package-install-file (expand-file-name "macro-problem-package-1.0/"))
+ (require 'macro-problem)
+ ;; `macro-problem-func' uses a macro from `macro-aux'.
+ (should (equal (macro-problem-func) '(progn a b)))
+ (package-install-file (expand-file-name "macro-problem-package-2.0/"))
+ ;; After upgrading, `macro-problem-func' depends on a new version
+ ;; of the macro from `macro-aux'.
+ (should (equal (macro-problem-func) '(1 b)))
+ ;; `macro-problem-10-and-90' depends on an entirely new macro from `macro-aux'.
+ (should (equal (macro-problem-10-and-90) '(10 90)))))
+
+(ert-deftest package-test-install-two-dependencies ()
+ "Install a package which includes a dependency."
+ (with-package-test ()
+ (package-initialize)
+ (package-refresh-contents)
+ (package-install 'simple-two-depend)
+ (should (package-installed-p 'simple-single))
+ (should (package-installed-p 'simple-depend))
+ (should (package-installed-p 'simple-two-depend))))
+
+(ert-deftest package-test-refresh-contents ()
+ "Parse an \"archive-contents\" file."
+ (with-package-test ()
+ (package-initialize)
+ (package-refresh-contents)
+ (should (eq 4 (length package-archive-contents)))))
+
+(ert-deftest package-test-install-single-from-archive ()
+ "Install a single package from a package archive."
+ (with-package-test ()
+ (package-initialize)
+ (package-refresh-contents)
+ (package-install 'simple-single)))
+
+(ert-deftest package-test-install-prioritized ()
+ "Install a lower version from a higher-prioritized archive."
+ (with-package-test ()
+ (let* ((newer-version (expand-file-name "package-resources/newer-versions"
+ package-test-file-dir))
+ (package-archives `(("older" . ,package-test-data-dir)
+ ("newer" . ,newer-version)))
+ (package-archive-priorities '(("older" . 100))))
+
+ (package-initialize)
+ (package-refresh-contents)
+ (package-install 'simple-single)
+
+ (let ((installed (cadr (assq 'simple-single package-alist))))
+ (should (version-list-= '(1 3)
+ (package-desc-version installed)))))))
+
+(ert-deftest package-test-install-multifile ()
+ "Check properties of the installed multi-file package."
+ (with-package-test (:basedir "package-resources" :install '(multi-file))
+ (let ((autoload-file
+ (expand-file-name "multi-file-autoloads.el"
+ (expand-file-name
+ "multi-file-0.2.3"
+ package-test-user-dir)))
+ (installed-files '("dir" "multi-file.info" "multi-file-sub.elc"
+ "multi-file-autoloads.el" "multi-file.elc"))
+ (autoload-forms '("^(defvar multi-file-custom-var"
+ "^(custom-autoload 'multi-file-custom-var"
+ "^(autoload 'multi-file-mode"))
+ (pkg-dir (file-name-as-directory
+ (expand-file-name
+ "multi-file-0.2.3"
+ package-test-user-dir))))
+ (package-refresh-contents)
+ (should (package-installed-p 'multi-file))
+ (with-temp-buffer
+ (insert-file-contents-literally autoload-file)
+ (dolist (fn installed-files)
+ (should (file-exists-p (expand-file-name fn pkg-dir))))
+ (dolist (re autoload-forms)
+ (goto-char (point-min))
+ (should (re-search-forward re nil t)))))))
+
+(ert-deftest package-test-update-listing ()
+ "Ensure installed package status is updated."
+ (with-package-test ()
+ (let ((buf (package-list-packages)))
+ (search-forward-regexp "^ +simple-single")
+ (package-menu-mark-install)
+ (package-menu-execute)
+ (run-hooks 'post-command-hook)
+ (should (package-installed-p 'simple-single))
+ (switch-to-buffer "*Packages*")
+ (goto-char (point-min))
+ (should (re-search-forward "^\\s-+simple-single\\s-+1.3\\s-+installed" nil t))
+ (goto-char (point-min))
+ (should-not (re-search-forward "^\\s-+simple-single\\s-+1.3\\s-+\\(available\\|new\\)" nil t))
+ (kill-buffer buf))))
+
+(ert-deftest package-test-update-archives ()
+ "Test updating package archives."
+ (with-package-test ()
+ (let ((buf (package-list-packages)))
+ (package-menu-refresh)
+ (search-forward-regexp "^ +simple-single")
+ (package-menu-mark-install)
+ (package-menu-execute)
+ (should (package-installed-p 'simple-single))
+ (let ((package-test-data-dir
+ (expand-file-name "package-resources/newer-versions" package-test-file-dir)))
+ (setq package-archives `(("gnu" . ,package-test-data-dir)))
+ (package-menu-refresh)
+
+ ;; New version should be available and old version should be installed
+ (goto-char (point-min))
+ (should (re-search-forward "^\\s-+simple-single\\s-+1.4\\s-+available" nil t))
+ (should (re-search-forward "^\\s-+simple-single\\s-+1.3\\s-+installed" nil t))
+
+ (goto-char (point-min))
+ (should (re-search-forward "^\\s-+new-pkg\\s-+1.0\\s-+\\(available\\|new\\)" nil t))
+
+ (package-menu-mark-upgrades)
+ (package-menu-execute)
+ (package-menu-refresh)
+ (should (package-installed-p 'simple-single '(1 4)))))))
+
+(ert-deftest package-test-update-archives-async ()
+ "Test updating package archives asynchronously."
+ (skip-unless (executable-find "python2"))
+ ;; For some reason this test doesn't work reliably on hydra.nixos.org.
+ (skip-unless (not (getenv "NIX_STORE")))
+ (with-package-test (:basedir
+ package-test-data-dir
+ :location "http://0.0.0.0:8000/")
+ (let* ((package-menu-async t)
+ (process (start-process
+ "package-server" "package-server-buffer"
+ (executable-find "python2")
+ (expand-file-name "package-test-server.py"))))
+ (unwind-protect
+ (progn
+ (list-packages)
+ (should package--downloads-in-progress)
+ (should mode-line-process)
+ (should-not
+ (with-timeout (10 'timeout)
+ (while package--downloads-in-progress
+ (accept-process-output nil 1))
+ nil))
+ ;; If the server process died, there's some non-Emacs problem.
+ ;; Eg maybe the port was already in use.
+ (skip-unless (process-live-p process))
+ (goto-char (point-min))
+ (should
+ (search-forward-regexp "^ +simple-single" nil t)))
+ (if (process-live-p process) (kill-process process))))))
+
+(ert-deftest package-test-describe-package ()
+ "Test displaying help for a package."
+
+ (require 'finder-inf)
+ ;; Built-in
+ (with-fake-help-buffer
+ (describe-package '5x5)
+ (goto-char (point-min))
+ (should (search-forward "5x5 is a built-in package." nil t))
+ ;; Don't assume the descriptions are in any particular order.
+ (save-excursion (should (search-forward "Status: Built-in." nil t)))
+ (save-excursion (should (search-forward "Summary: simple little puzzle game" nil t)))
+ (should (search-forward "The aim of 5x5" nil t)))
+
+ ;; Installed
+ (with-package-test ()
+ (package-initialize)
+ (package-refresh-contents)
+ (package-install 'simple-single)
+ (with-fake-help-buffer
+ (describe-package 'simple-single)
+ (goto-char (point-min))
+ (should (search-forward "simple-single is an installed package." nil t))
+ (save-excursion (should (re-search-forward "Status: Installed in ['`‘]simple-single-1.3/['’] (unsigned)." nil t)))
+ (save-excursion (should (search-forward "Version: 1.3" nil t)))
+ (save-excursion (should (search-forward "Summary: A single-file package with no dependencies" nil t)))
+ (save-excursion (should (search-forward "Homepage: http://doodles.au" nil t)))
+ (save-excursion (should (re-search-forward "Keywords: \\[?frobnicate\\]?" nil t)))
+ ;; No description, though. Because at this point we don't know
+ ;; what archive the package originated from, and we don't have
+ ;; its readme file saved.
+ )))
+
+(ert-deftest package-test-describe-non-installed-package ()
+ "Test displaying of the readme for non-installed package."
+
+ (with-package-test ()
+ (package-initialize)
+ (package-refresh-contents)
+ (with-fake-help-buffer
+ (describe-package 'simple-single)
+ (goto-char (point-min))
+ (should (search-forward "Homepage: http://doodles.au" nil t))
+ (should (search-forward "This package provides a minor mode to frobnicate"
+ nil t)))))
+
+(ert-deftest package-test-describe-non-installed-multi-file-package ()
+ "Test displaying of the readme for non-installed multi-file package."
+
+ (with-package-test ()
+ (package-initialize)
+ (package-refresh-contents)
+ (with-fake-help-buffer
+ (describe-package 'multi-file)
+ (goto-char (point-min))
+ (should (search-forward "Homepage: http://puddles.li" nil t))
+ (should (search-forward "This is a bare-bones readme file for the multi-file"
+ nil t)))))
+
+(ert-deftest package-test-signed ()
+ "Test verifying package signature."
+ (skip-unless (ignore-errors
+ (let ((homedir (make-temp-file "package-test" t)))
+ (unwind-protect
+ (let ((process-environment
+ (cons (format "HOME=%s" homedir)
+ process-environment)))
+ (epg-check-configuration (epg-configuration))
+ (epg-find-configuration 'OpenPGP))
+ (delete-directory homedir t)))))
+ (let* ((keyring (expand-file-name "key.pub" package-test-data-dir))
+ (package-test-data-dir
+ (expand-file-name "package-resources/signed" package-test-file-dir)))
+ (with-package-test ()
+ (package-initialize)
+ (package-import-keyring keyring)
+ (package-refresh-contents)
++ (let ((package-check-signature 'allow-unsigned))
++ (should (package-install 'signed-good))
++ (should-error (package-install 'signed-bad)))
++ (let ((package-check-signature t))
++ (should (package-install 'signed-good))
++ (should-error (package-install 'signed-bad)))
++ (let ((package-check-signature nil))
++ (should (package-install 'signed-good))
++ (should (package-install 'signed-bad)))
+ ;; Check if the installed package status is updated.
+ (let ((buf (package-list-packages)))
+ (package-menu-refresh)
+ (should (re-search-forward
+ "^\\s-+signed-good\\s-+\\(\\S-+\\)\\s-+\\(\\S-+\\)\\s-"
+ nil t))
+ (should (string-equal (match-string-no-properties 1) "1.0"))
+ (should (string-equal (match-string-no-properties 2) "installed")))
+ ;; Check if the package description is updated.
+ (with-fake-help-buffer
+ (describe-package 'signed-good)
+ (goto-char (point-min))
+ (should (re-search-forward "signed-good is an? \\(\\S-+\\) package." nil t))
+ (should (string-equal (match-string-no-properties 1) "installed"))
+ (should (re-search-forward
+ "Status: Installed in ['`‘]signed-good-1.0/['’]."
+ nil t))))))
+
+
+\f
+;;; Tests for package-x features.
+
+(require 'package-x)
+
+(defvar package-x-test--single-archive-entry-1-3
+ (cons 'simple-single
+ (package-make-ac-desc '(1 3) nil
+ "A single-file package with no dependencies"
+ 'single
+ '((:authors ("J. R. Hacker" . "jrh@example.com"))
+ (:maintainer "J. R. Hacker" . "jrh@example.com")
+ (:url . "http://doodles.au"))))
+ "Expected contents of the archive entry from the \"simple-single\" package.")
+
+(defvar package-x-test--single-archive-entry-1-4
+ (cons 'simple-single
+ (package-make-ac-desc '(1 4) nil
+ "A single-file package with no dependencies"
+ 'single
+ '((:authors ("J. R. Hacker" . "jrh@example.com"))
+ (:maintainer "J. R. Hacker" . "jrh@example.com"))))
+ "Expected contents of the archive entry from the updated \"simple-single\" package.")
+
+(ert-deftest package-x-test-upload-buffer ()
+ "Test creating an \"archive-contents\" file"
+ (with-package-test (:basedir "package-resources"
+ :file "simple-single-1.3.el"
+ :upload-base t)
+ (package-upload-buffer)
+ (should (file-exists-p (expand-file-name "archive-contents"
+ package-archive-upload-base)))
+ (should (file-exists-p (expand-file-name "simple-single-1.3.el"
+ package-archive-upload-base)))
+ (should (file-exists-p (expand-file-name "simple-single-readme.txt"
+ package-archive-upload-base)))
+
+ (let (archive-contents)
+ (with-temp-buffer
+ (insert-file-contents
+ (expand-file-name "archive-contents"
+ package-archive-upload-base))
+ (setq archive-contents
+ (package-read-from-string
+ (buffer-substring (point-min) (point-max)))))
+ (should (equal archive-contents
+ (list 1 package-x-test--single-archive-entry-1-3))))))
+
+(ert-deftest package-x-test-upload-new-version ()
+ "Test uploading a new version of a package"
+ (with-package-test (:basedir "package-resources"
+ :file "simple-single-1.3.el"
+ :upload-base t)
+ (package-upload-buffer)
+ (with-temp-buffer
+ (insert-file-contents "newer-versions/simple-single-1.4.el")
+ (package-upload-buffer))
+
+ (let (archive-contents)
+ (with-temp-buffer
+ (insert-file-contents
+ (expand-file-name "archive-contents"
+ package-archive-upload-base))
+ (setq archive-contents
+ (package-read-from-string
+ (buffer-substring (point-min) (point-max)))))
+ (should (equal archive-contents
+ (list 1 package-x-test--single-archive-entry-1-4))))))
+
+(ert-deftest package-test-get-deps ()
+ "Test `package--get-deps' with complex structures."
+ (let ((package-alist
+ (mapcar (lambda (p) (list (package-desc-name p) p))
+ (list simple-single-desc
+ simple-depend-desc
+ multi-file-desc
+ new-pkg-desc
+ simple-depend-desc-1
+ simple-depend-desc-2))))
+ (should
+ (equal (package--get-deps 'simple-depend)
+ '(simple-single)))
+ (should
+ (equal (package--get-deps 'simple-depend 'indirect)
+ nil))
+ (should
+ (equal (package--get-deps 'simple-depend 'direct)
+ '(simple-single)))
+ (should
+ (equal (package--get-deps 'simple-depend-2)
+ '(simple-depend-1 multi-file simple-depend simple-single)))
+ (should
+ (equal (package--get-deps 'simple-depend-2 'indirect)
+ '(simple-depend multi-file simple-single)))
+ (should
+ (equal (package--get-deps 'simple-depend-2 'direct)
+ '(simple-depend-1 multi-file)))))
+
+(ert-deftest package-test-sort-by-dependence ()
+ "Test `package--sort-by-dependence' with complex structures."
+ (let ((package-alist
+ (mapcar (lambda (p) (list (package-desc-name p) p))
+ (list simple-single-desc
+ simple-depend-desc
+ multi-file-desc
+ new-pkg-desc
+ simple-depend-desc-1
+ simple-depend-desc-2)))
+ (delete-list
+ (list simple-single-desc
+ simple-depend-desc
+ multi-file-desc
+ new-pkg-desc
+ simple-depend-desc-1
+ simple-depend-desc-2)))
+ (should
+ (equal (package--sort-by-dependence delete-list)
+
+ (list simple-depend-desc-2 simple-depend-desc-1 new-pkg-desc
+ multi-file-desc simple-depend-desc simple-single-desc)))
+ (should
+ (equal (package--sort-by-dependence (reverse delete-list))
+ (list new-pkg-desc simple-depend-desc-2 simple-depend-desc-1
+ multi-file-desc simple-depend-desc simple-single-desc)))))
+
+(provide 'package-test)
+
+;;; package-test.el ends here
--- /dev/null
- ;; This program 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.
- ;;
- ;; This program 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.
- ;;
+;;; data-tests.el --- tests for src/data.c
+
+;; Copyright (C) 2013-2016 Free Software Foundation, Inc.
+
+;; This file is part of GNU Emacs.
+
- ;; along with this program. If not, see `http://www.gnu.org/licenses/'.
++;; GNU Emacs 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 Emacs 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 Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;; Code:
+
+(require 'cl-lib)
+(eval-when-compile (require 'cl))
+
+(ert-deftest data-tests-= ()
+ (should-error (=))
+ (should (= 1))
+ (should (= 2 2))
+ (should (= 9 9 9 9 9 9 9 9 9))
+ (should-not (apply #'= '(3 8 3)))
+ (should-error (= 9 9 'foo))
+ ;; Short circuits before getting to bad arg
+ (should-not (= 9 8 'foo)))
+
+(ert-deftest data-tests-< ()
+ (should-error (<))
+ (should (< 1))
+ (should (< 2 3))
+ (should (< -6 -1 0 2 3 4 8 9 999))
+ (should-not (apply #'< '(3 8 3)))
+ (should-error (< 9 10 'foo))
+ ;; Short circuits before getting to bad arg
+ (should-not (< 9 8 'foo)))
+
+(ert-deftest data-tests-> ()
+ (should-error (>))
+ (should (> 1))
+ (should (> 3 2))
+ (should (> 6 1 0 -2 -3 -4 -8 -9 -999))
+ (should-not (apply #'> '(3 8 3)))
+ (should-error (> 9 8 'foo))
+ ;; Short circuits before getting to bad arg
+ (should-not (> 8 9 'foo)))
+
+(ert-deftest data-tests-<= ()
+ (should-error (<=))
+ (should (<= 1))
+ (should (<= 2 3))
+ (should (<= -6 -1 -1 0 0 0 2 3 4 8 999))
+ (should-not (apply #'<= '(3 8 3 3)))
+ (should-error (<= 9 10 'foo))
+ ;; Short circuits before getting to bad arg
+ (should-not (<= 9 8 'foo)))
+
+(ert-deftest data-tests->= ()
+ (should-error (>=))
+ (should (>= 1))
+ (should (>= 3 2))
+ (should (>= 666 1 0 0 -2 -3 -3 -3 -4 -8 -8 -9 -999))
+ (should-not (apply #'>= '(3 8 3)))
+ (should-error (>= 9 8 'foo))
+ ;; Short circuits before getting to bad arg
+ (should-not (>= 8 9 'foo)))
+
+;; Bool vector tests. Compactly represent bool vectors as hex
+;; strings.
+
+(ert-deftest bool-vector-count-population-all-0-nil ()
+ (cl-loop for sz in '(0 45 1 64 9 344)
+ do (let* ((bv (make-bool-vector sz nil)))
+ (should
+ (zerop
+ (bool-vector-count-population bv))))))
+
+(ert-deftest bool-vector-count-population-all-1-t ()
+ (cl-loop for sz in '(0 45 1 64 9 344)
+ do (let* ((bv (make-bool-vector sz t)))
+ (should
+ (eql
+ (bool-vector-count-population bv)
+ sz)))))
+
+(ert-deftest bool-vector-count-population-1-nil ()
+ (let* ((bv (make-bool-vector 45 nil)))
+ (aset bv 40 t)
+ (aset bv 0 t)
+ (should
+ (eql
+ (bool-vector-count-population bv)
+ 2))))
+
+(ert-deftest bool-vector-count-population-1-t ()
+ (let* ((bv (make-bool-vector 45 t)))
+ (aset bv 40 nil)
+ (aset bv 0 nil)
+ (should
+ (eql
+ (bool-vector-count-population bv)
+ 43))))
+
+(defun mock-bool-vector-count-consecutive (a b i)
+ (loop for i from i below (length a)
+ while (eq (aref a i) b)
+ sum 1))
+
+(defun test-bool-vector-bv-from-hex-string (desc)
+ (let (bv nchars nibbles)
+ (dolist (c (string-to-list desc))
+ (push (string-to-number
+ (char-to-string c)
+ 16)
+ nibbles))
+ (setf bv (make-bool-vector (* 4 (length nibbles)) nil))
+ (let ((i 0))
+ (dolist (n (nreverse nibbles))
+ (dotimes (_ 4)
+ (aset bv i (> (logand 1 n) 0))
+ (incf i)
+ (setf n (lsh n -1)))))
+ bv))
+
+(defun test-bool-vector-to-hex-string (bv)
+ (let (nibbles (v (cl-coerce bv 'list)))
+ (while v
+ (push (logior
+ (lsh (if (nth 0 v) 1 0) 0)
+ (lsh (if (nth 1 v) 1 0) 1)
+ (lsh (if (nth 2 v) 1 0) 2)
+ (lsh (if (nth 3 v) 1 0) 3))
+ nibbles)
+ (setf v (nthcdr 4 v)))
+ (mapconcat (lambda (n) (format "%X" n))
+ (nreverse nibbles)
+ "")))
+
+(defun test-bool-vector-count-consecutive-tc (desc)
+ "Run a test case for bool-vector-count-consecutive.
+DESC is a string describing the test. It is a sequence of
+hexadecimal digits describing the bool vector. We exhaustively
+test all counts at all possible positions in the vector by
+comparing the subr with a much slower lisp implementation."
+ (let ((bv (test-bool-vector-bv-from-hex-string desc)))
+ (loop
+ for lf in '(nil t)
+ do (loop
+ for pos from 0 upto (length bv)
+ for cnt = (mock-bool-vector-count-consecutive bv lf pos)
+ for rcnt = (bool-vector-count-consecutive bv lf pos)
+ unless (eql cnt rcnt)
+ do (error "FAILED testcase %S %3S %3S %3S"
+ pos lf cnt rcnt)))))
+
+(defconst bool-vector-test-vectors
+'(""
+ "0"
+ "F"
+ "0F"
+ "F0"
+ "00000000000000000000000000000FFFFF0000000"
+ "44a50234053fba3340000023444a50234053fba33400000234"
+ "12341234123456123412346001234123412345612341234600"
+ "44a50234053fba33400000234"
+ "1234123412345612341234600"
+ "44a50234053fba33400000234"
+ "1234123412345612341234600"
+ "44a502340"
+ "123412341"
+ "0000000000000000000000000"
+ "FFFFFFFFFFFFFFFF1"))
+
+(ert-deftest bool-vector-count-consecutive ()
+ (mapc #'test-bool-vector-count-consecutive-tc
+ bool-vector-test-vectors))
+
+(defun test-bool-vector-apply-mock-op (mock a b c)
+ "Compute (slowly) the correct result of a bool-vector set operation."
+ (let (changed nv)
+ (assert (eql (length b) (length c)))
+ (if a (setf nv a)
+ (setf a (make-bool-vector (length b) nil))
+ (setf changed t))
+
+ (loop for i below (length b)
+ for mockr = (funcall mock
+ (if (aref b i) 1 0)
+ (if (aref c i) 1 0))
+ for r = (not (= 0 mockr))
+ do (progn
+ (unless (eq (aref a i) r)
+ (setf changed t))
+ (setf (aref a i) r)))
+ (if changed a)))
+
+(defun test-bool-vector-binop (mock real)
+ "Test a binary set operation."
+ (loop for s1 in bool-vector-test-vectors
+ for bv1 = (test-bool-vector-bv-from-hex-string s1)
+ for vecs2 = (cl-remove-if-not
+ (lambda (x) (eql (length x) (length s1)))
+ bool-vector-test-vectors)
+ do (loop for s2 in vecs2
+ for bv2 = (test-bool-vector-bv-from-hex-string s2)
+ for mock-result = (test-bool-vector-apply-mock-op
+ mock nil bv1 bv2)
+ for real-result = (funcall real bv1 bv2)
+ do (progn
+ (should (equal mock-result real-result))))))
+
+(ert-deftest bool-vector-intersection-op ()
+ (test-bool-vector-binop
+ #'logand
+ #'bool-vector-intersection))
+
+(ert-deftest bool-vector-union-op ()
+ (test-bool-vector-binop
+ #'logior
+ #'bool-vector-union))
+
+(ert-deftest bool-vector-xor-op ()
+ (test-bool-vector-binop
+ #'logxor
+ #'bool-vector-exclusive-or))
+
+(ert-deftest bool-vector-set-difference-op ()
+ (test-bool-vector-binop
+ (lambda (a b) (logand a (lognot b)))
+ #'bool-vector-set-difference))
+
+(ert-deftest bool-vector-change-detection ()
+ (let* ((vc1 (test-bool-vector-bv-from-hex-string "abcdef"))
+ (vc2 (test-bool-vector-bv-from-hex-string "012345"))
+ (vc3 (make-bool-vector (length vc1) nil))
+ (c1 (bool-vector-union vc1 vc2 vc3))
+ (c2 (bool-vector-union vc1 vc2 vc3)))
+ (should (equal c1 (test-bool-vector-apply-mock-op
+ #'logior
+ nil
+ vc1 vc2)))
+ (should (not c2))))
+
+(ert-deftest bool-vector-not ()
+ (let* ((v1 (test-bool-vector-bv-from-hex-string "FFFF3"))
+ (v2 (test-bool-vector-bv-from-hex-string "0000C"))
+ (v3 (bool-vector-not v1)))
+ (should (equal v2 v3))))
projects / emacs.git / commitdiff