diff options
Diffstat (limited to 'test/lisp')
113 files changed, 28177 insertions, 0 deletions
diff --git a/test/lisp/abbrev-tests.el b/test/lisp/abbrev-tests.el new file mode 100644 index 00000000000..0d93e268a99 --- /dev/null +++ b/test/lisp/abbrev-tests.el @@ -0,0 +1,127 @@ +;;; abbrev-tests.el --- Test suite for abbrevs -*- lexical-binding: t; -*- + +;; Copyright (C) 2015-2016 Free Software Foundation, Inc. + +;; Author: Eli Zaretskii <eliz@gnu.org> +;; Keywords: abbrevs + +;; 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: + +;; `kill-all-abbrevs-test' will remove all user *and* system abbrevs +;; if called noninteractively with the init file loaded. + +;;; Code: + +(require 'ert) +(require 'abbrev) +(require 'seq) + +;; set up test abbrev table and abbrev entry +(defun setup-test-abbrev-table () + (defvar ert-test-abbrevs nil) + (define-abbrev-table 'ert-test-abbrevs '(("a-e-t" "abbrev-ert-test"))) + (abbrev-table-put ert-test-abbrevs :ert-test "ert-test-value") + ert-test-abbrevs) + +(ert-deftest abbrev-table-p-test () + (should-not (abbrev-table-p 42)) + (should-not (abbrev-table-p "aoeu")) + (should-not (abbrev-table-p '())) + (should-not (abbrev-table-p [])) + ;; Missing :abbrev-table-modiff counter: + (should-not (abbrev-table-p (obarray-make))) + (let* ((table (obarray-make))) + (abbrev-table-put table :abbrev-table-modiff 42) + (should (abbrev-table-p table)))) + +(ert-deftest abbrev-make-abbrev-table-test () + ;; Table without properties: + (let ((table (make-abbrev-table))) + (should (abbrev-table-p table)) + (should (= (length table) obarray-default-size))) + ;; Table with one property 'foo with value 'bar: + (let ((table (make-abbrev-table '(foo bar)))) + (should (abbrev-table-p table)) + (should (= (length table) obarray-default-size)) + (should (eq (abbrev-table-get table 'foo) 'bar)))) + +(ert-deftest abbrev-table-get-put-test () + (let ((table (make-abbrev-table))) + (should-not (abbrev-table-get table 'foo)) + (should (= (abbrev-table-put table 'foo 42) 42)) + (should (= (abbrev-table-get table 'foo) 42)) + (should (eq (abbrev-table-put table 'foo 'bar) 'bar)) + (should (eq (abbrev-table-get table 'foo) 'bar)))) + +(ert-deftest copy-abbrev-table-test () + (defvar foo-abbrev-table nil) ; Avoid compiler warning + (define-abbrev-table 'foo-abbrev-table + '()) + (should (abbrev-table-p foo-abbrev-table)) + ;; Bug 21828 + (let ((new-foo-abbrev-table + (condition-case nil + (copy-abbrev-table foo-abbrev-table) + (error nil)))) + (should (abbrev-table-p new-foo-abbrev-table))) + (should-not (string-equal (buffer-name) "*Backtrace*"))) + +(ert-deftest kill-all-abbrevs-test () + "Test undefining all defined abbrevs" + (unless noninteractive + (ert-skip "Cannot test kill-all-abbrevs in interactive mode")) + + (let ((num-tables 0)) + ;; ensure at least one abbrev exists + (should (abbrev-table-p (setup-test-abbrev-table))) + (setf num-tables (length abbrev-table-name-list)) + (kill-all-abbrevs) + + ;; no tables should have been removed/added + (should (= num-tables (length abbrev-table-name-list))) + ;; number of empty tables should be the same as number of tables + (should (= num-tables (length (seq-filter + (lambda (table) + (abbrev-table-empty-p (symbol-value table))) + abbrev-table-name-list)))))) + +(ert-deftest abbrev-table-name-test () + "Test returning name of abbrev-table" + (let ((ert-test-abbrevs (setup-test-abbrev-table)) + (no-such-table nil)) + (should (equal 'ert-test-abbrevs (abbrev-table-name ert-test-abbrevs))) + (should (equal nil (abbrev-table-name no-such-table))))) + +(ert-deftest clear-abbrev-table-test () + "Test clearing single abbrev table" + (let ((ert-test-abbrevs (setup-test-abbrev-table))) + (should (equal "a-e-t" (symbol-name + (abbrev-symbol "a-e-t" ert-test-abbrevs)))) + (should (equal "abbrev-ert-test" (symbol-value + (abbrev-symbol "a-e-t" ert-test-abbrevs)))) + + (clear-abbrev-table ert-test-abbrevs) + + (should (equal "nil" (symbol-name + (abbrev-symbol "a-e-t" ert-test-abbrevs)))) + (should (equal nil (symbol-value + (abbrev-symbol "a-e-t" ert-test-abbrevs)))) + (should (equal t (abbrev-table-empty-p ert-test-abbrevs))))) + +(provide 'abbrev-tests) +;;; abbrev-tests.el ends here diff --git a/test/lisp/autorevert-tests.el b/test/lisp/autorevert-tests.el new file mode 100644 index 00000000000..b37850054fa --- /dev/null +++ b/test/lisp/autorevert-tests.el @@ -0,0 +1,256 @@ +;;; auto-revert-tests.el --- Tests of auto-revert + +;; Copyright (C) 2015-2016 Free Software Foundation, Inc. + +;; Author: Michael Albinus <michael.albinus@gmx.de> + +;; 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/'. + +;;; Commentary: + +;; A whole test run can be performed calling the command `auto-revert-test-all'. + +;;; Code: + +(require 'ert) +(require 'autorevert) +(setq auto-revert-notify-exclude-dir-regexp "nothing-to-be-excluded" + auto-revert-stop-on-user-input nil) + +(defconst auto-revert--timeout 10 + "Time to wait until a message appears in the *Messages* buffer.") + +(defun auto-revert--wait-for-revert (buffer) + "Wait until the *Messages* buffer reports reversion of BUFFER." + (with-timeout (auto-revert--timeout nil) + (with-current-buffer "*Messages*" + (while + (null (string-match + (format-message "Reverting buffer `%s'." (buffer-name buffer)) + (buffer-string))) + (if (with-current-buffer buffer auto-revert-use-notify) + (read-event nil nil 0.1) + (sleep-for 0.1)))))) + +(ert-deftest auto-revert-test00-auto-revert-mode () + "Check autorevert for a file." + ;; `auto-revert-buffers' runs every 5". And we must wait, until the + ;; file has been reverted. + (let ((tmpfile (make-temp-file "auto-revert-test")) + buf) + (unwind-protect + (progn + (with-current-buffer (get-buffer-create "*Messages*") + (narrow-to-region (point-max) (point-max))) + (write-region "any text" nil tmpfile nil 'no-message) + (setq buf (find-file-noselect tmpfile)) + (with-current-buffer buf + (should (string-equal (buffer-string) "any text")) + ;; `buffer-stale--default-function' checks for + ;; `verify-visited-file-modtime'. We must ensure that it + ;; returns nil. + (sleep-for 1) + (auto-revert-mode 1) + (should auto-revert-mode) + + ;; Modify file. We wait for a second, in order to have + ;; another timestamp. + (sleep-for 1) + (write-region "another text" nil tmpfile nil 'no-message) + + ;; Check, that the buffer has been reverted. + (auto-revert--wait-for-revert buf) + (should (string-match "another text" (buffer-string))) + + ;; When the buffer is modified, it shall not be reverted. + (with-current-buffer (get-buffer-create "*Messages*") + (narrow-to-region (point-max) (point-max))) + (set-buffer-modified-p t) + (sleep-for 1) + (write-region "any text" nil tmpfile nil 'no-message) + + ;; Check, that the buffer hasn't been reverted. + (auto-revert--wait-for-revert buf) + (should-not (string-match "any text" (buffer-string))))) + + ;; Exit. + (with-current-buffer "*Messages*" (widen)) + (ignore-errors + (with-current-buffer buf (set-buffer-modified-p nil)) + (kill-buffer buf)) + (ignore-errors (delete-file tmpfile))))) + +;; This is inspired by Bug#21841. +(ert-deftest auto-revert-test01-auto-revert-several-files () + "Check autorevert for several files at once." + (skip-unless (executable-find "cp")) + + (let* ((cp (executable-find "cp")) + (tmpdir1 (make-temp-file "auto-revert-test" 'dir)) + (tmpdir2 (make-temp-file "auto-revert-test" 'dir)) + (tmpfile1 + (make-temp-file (expand-file-name "auto-revert-test" tmpdir1))) + (tmpfile2 + (make-temp-file (expand-file-name "auto-revert-test" tmpdir1))) + buf1 buf2) + (unwind-protect + (progn + (with-current-buffer (get-buffer-create "*Messages*") + (narrow-to-region (point-max) (point-max))) + (write-region "any text" nil tmpfile1 nil 'no-message) + (setq buf1 (find-file-noselect tmpfile1)) + (write-region "any text" nil tmpfile2 nil 'no-message) + (setq buf2 (find-file-noselect tmpfile2)) + + (dolist (buf (list buf1 buf2)) + (with-current-buffer buf + (should (string-equal (buffer-string) "any text")) + ;; `buffer-stale--default-function' checks for + ;; `verify-visited-file-modtime'. We must ensure that + ;; it returns nil. + (sleep-for 1) + (auto-revert-mode 1) + (should auto-revert-mode))) + + ;; Modify files. We wait for a second, in order to have + ;; another timestamp. + (sleep-for 1) + (write-region + "another text" nil + (expand-file-name (file-name-nondirectory tmpfile1) tmpdir2) + nil 'no-message) + (write-region + "another text" nil + (expand-file-name (file-name-nondirectory tmpfile2) tmpdir2) + nil 'no-message) + ;;(copy-directory tmpdir2 tmpdir1 nil 'copy-contents) + ;; Strange, that `copy-directory' does not work as expected. + ;; The following shell command is not portable on all + ;; platforms, unfortunately. + (shell-command (format "%s %s/* %s" cp tmpdir2 tmpdir1)) + + ;; Check, that the buffers have been reverted. + (dolist (buf (list buf1 buf2)) + (with-current-buffer buf + (auto-revert--wait-for-revert buf) + (should (string-match "another text" (buffer-string)))))) + + ;; Exit. + (with-current-buffer "*Messages*" (widen)) + (ignore-errors + (dolist (buf (list buf1 buf2)) + (with-current-buffer buf (set-buffer-modified-p nil)) + (kill-buffer buf))) + (ignore-errors (delete-directory tmpdir1 'recursive)) + (ignore-errors (delete-directory tmpdir2 'recursive))))) + +(ert-deftest auto-revert-test02-auto-revert-tail-mode () + "Check autorevert tail mode." + ;; `auto-revert-buffers' runs every 5". And we must wait, until the + ;; file has been reverted. + (let ((tmpfile (make-temp-file "auto-revert-test")) + buf) + (unwind-protect + (progn + (with-current-buffer (get-buffer-create "*Messages*") + (narrow-to-region (point-max) (point-max))) + (write-region "any text" nil tmpfile nil 'no-message) + (setq buf (find-file-noselect tmpfile)) + (with-current-buffer buf + ;; `buffer-stale--default-function' checks for + ;; `verify-visited-file-modtime'. We must ensure that it + ;; returns nil. + (sleep-for 1) + (auto-revert-tail-mode 1) + (should auto-revert-tail-mode) + (erase-buffer) + (insert "modified text\n") + (set-buffer-modified-p nil) + + ;; Modify file. We wait for a second, in order to have + ;; another timestamp. + (sleep-for 1) + (write-region "another text" nil tmpfile 'append 'no-message) + + ;; Check, that the buffer has been reverted. + (auto-revert--wait-for-revert buf) + (should + (string-match "modified text\nanother text" (buffer-string))))) + + ;; Exit. + (with-current-buffer "*Messages*" (widen)) + (ignore-errors (kill-buffer buf)) + (ignore-errors (delete-file tmpfile))))) + +(ert-deftest auto-revert-test03-auto-revert-mode-dired () + "Check autorevert for dired." + ;; `auto-revert-buffers' runs every 5". And we must wait, until the + ;; file has been reverted. + (let* ((tmpfile (make-temp-file "auto-revert-test")) + (name (file-name-nondirectory tmpfile)) + buf) + (unwind-protect + (progn + (setq buf (dired-noselect temporary-file-directory)) + (with-current-buffer buf + ;; `buffer-stale--default-function' checks for + ;; `verify-visited-file-modtime'. We must ensure that it + ;; returns nil. + (sleep-for 1) + (auto-revert-mode 1) + (should auto-revert-mode) + (should + (string-match name (substring-no-properties (buffer-string)))) + + ;; Delete file. We wait for a second, in order to have + ;; another timestamp. + (with-current-buffer (get-buffer-create "*Messages*") + (narrow-to-region (point-max) (point-max))) + (sleep-for 1) + (delete-file tmpfile) + + ;; Check, that the buffer has been reverted. + (auto-revert--wait-for-revert buf) + (should-not + (string-match name (substring-no-properties (buffer-string)))) + + ;; Make dired buffer modified. Check, that the buffer has + ;; been still reverted. + (with-current-buffer (get-buffer-create "*Messages*") + (narrow-to-region (point-max) (point-max))) + (set-buffer-modified-p t) + (sleep-for 1) + (write-region "any text" nil tmpfile nil 'no-message) + + ;; Check, that the buffer has been reverted. + (auto-revert--wait-for-revert buf) + (should + (string-match name (substring-no-properties (buffer-string)))))) + + ;; Exit. + (with-current-buffer "*Messages*" (widen)) + (ignore-errors + (with-current-buffer buf (set-buffer-modified-p nil)) + (kill-buffer buf)) + (ignore-errors (delete-file tmpfile))))) + +(defun auto-revert-test-all (&optional interactive) + "Run all tests for \\[auto-revert]." + (interactive "p") + (if interactive + (ert-run-tests-interactively "^auto-revert-") + (ert-run-tests-batch "^auto-revert-"))) + +(provide 'auto-revert-tests) +;;; auto-revert-tests.el ends here diff --git a/test/lisp/calc/calc-tests.el b/test/lisp/calc/calc-tests.el new file mode 100644 index 00000000000..c1fb1695c78 --- /dev/null +++ b/test/lisp/calc/calc-tests.el @@ -0,0 +1,94 @@ +;;; calc-tests.el --- tests for calc -*- lexical-binding: t; -*- + +;; Copyright (C) 2014-2016 Free Software Foundation, Inc. + +;; Author: Leo Liu <sdl.web@gmail.com> +;; Keywords: maint + +;; 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: + +;;; Code: + +(require 'cl-lib) +(require 'ert) +(require 'calc) +(require 'calc-ext) +(require 'calc-units) + +;; XXX The order in which calc libraries (in particular calc-units) +;; are loaded influences whether a calc integer in an expression +;; involving units is represented as a lisp integer or a calc float, +;; see bug#19582. Until this will be fixed the following function can +;; be used to compare such calc expressions. +(defun calc-tests-equal (a b) + "Like `equal' but allow for different representations of numbers. +For example: (calc-tests-equal 10 '(float 1 1)) => t. +A and B should be calc expressions." + (cond ((math-numberp a) + (and (math-numberp b) + (math-equal a b))) + ((atom a) + (equal a b)) + ((consp b) + ;; Can't be dotted or circular. + (and (= (length a) (length b)) + (equal (car a) (car b)) + (cl-every #'calc-tests-equal (cdr a) (cdr b)))))) + +(defun calc-tests-simple (fun string &rest args) + "Push STRING on the calc stack, then call FUN and return the new top. +The result is a calc (i.e., lisp) expression, not its string representation. +Also pop the entire stack afterwards. +An existing calc stack is reused, otherwise a new one is created." + (calc-eval string 'push) + (prog1 + (ignore-errors + (apply fun args) + (calc-top-n 1)) + (calc-pop 0))) + +(ert-deftest test-math-bignum () + ;; bug#17556 + (let ((n (math-bignum most-negative-fixnum))) + (should (math-negp n)) + (should (cl-notany #'cl-minusp (cdr n))))) + +(ert-deftest test-calc-remove-units () + (should (calc-tests-equal (calc-tests-simple #'calc-remove-units "-1 m") -1))) + +(ert-deftest test-calc-extract-units () + (should (calc-tests-equal (calc-tests-simple #'calc-extract-units "-1 m") + '(var m var-m))) + (should (calc-tests-equal (calc-tests-simple #'calc-extract-units "-1 m*cm") + '(* (float 1 -2) (^ (var m var-m) 2))))) + +(ert-deftest test-calc-convert-units () + ;; Used to ask for `(The expression is unitless when simplified) Old Units: '. + (should (calc-tests-equal (calc-tests-simple #'calc-convert-units "-1 m" nil "cm") + '(* -100 (var cm var-cm)))) + ;; Gave wrong result. + (should (calc-tests-equal (calc-tests-simple #'calc-convert-units "-1 m" + (math-read-expr "1m") "cm") + '(* -100 (var cm var-cm))))) + +(provide 'calc-tests) +;;; calc-tests.el ends here + +;; Local Variables: +;; bug-reference-url-format: "http://debbugs.gnu.org/%s" +;; End: diff --git a/test/lisp/calendar/icalendar-tests.el b/test/lisp/calendar/icalendar-tests.el new file mode 100644 index 00000000000..2c13a363213 --- /dev/null +++ b/test/lisp/calendar/icalendar-tests.el @@ -0,0 +1,2293 @@ +;; icalendar-tests.el --- Test suite for icalendar.el + +;; Copyright (C) 2005, 2008-2016 Free Software Foundation, Inc. + +;; Author: Ulf Jasper <ulf.jasper@web.de> +;; Created: March 2005 +;; Keywords: calendar +;; Human-Keywords: calendar, diary, iCalendar, vCalendar + +;; 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: + +;; TODO: +;; - Add more unit tests for functions, timezone etc. + +;; Note: Watch the trailing blank that is added on import. + +;;; Code: + +(require 'ert) +(require 'icalendar) + +;; ====================================================================== +;; Helpers +;; ====================================================================== + +(defun icalendar-tests--get-ical-event (ical-string) + "Return iCalendar event for ICAL-STRING." + (save-excursion + (with-temp-buffer + (insert ical-string) + (goto-char (point-min)) + (car (icalendar--read-element nil nil))))) + +(defun icalendar-tests--trim (string) + "Remove leading and trailing whitespace from STRING." + (replace-regexp-in-string "[ \t\n]+\\'" "" + (replace-regexp-in-string "\\`[ \t\n]+" "" string))) + +;; ====================================================================== +;; Tests of functions +;; ====================================================================== + +(ert-deftest icalendar--create-uid () + "Test for `icalendar--create-uid'." + (let* ((icalendar-uid-format "xxx-%t-%c-%h-%u-%s") + t-ct + (icalendar--uid-count 77) + (entry-full "30.06.1964 07:01 blahblah") + (hash (format "%d" (abs (sxhash entry-full)))) + (contents "DTSTART:19640630T070100\nblahblah") + (username (or user-login-name "UNKNOWN_USER")) + ) + (fset 't-ct (symbol-function 'current-time)) + (unwind-protect + (progn + (fset 'current-time (lambda () '(1 2 3))) + (should (= 77 icalendar--uid-count)) + (should (string= (concat "xxx-123-77-" hash "-" username "-19640630") + (icalendar--create-uid entry-full contents))) + (should (= 78 icalendar--uid-count))) + ;; restore 'current-time + (fset 'current-time (symbol-function 't-ct))) + (setq contents "blahblah") + (setq icalendar-uid-format "yyy%syyy") + (should (string= (concat "yyyDTSTARTyyy") + (icalendar--create-uid entry-full contents))))) + +(ert-deftest icalendar-convert-anniversary-to-ical () + "Test method for `icalendar--convert-anniversary-to-ical'." + (let* ((calendar-date-style 'iso) + result) + (setq result (icalendar--convert-anniversary-to-ical + "" "%%(diary-anniversary 1964 6 30) g")) + (should (consp result)) + (should (string= (concat + "\nDTSTART;VALUE=DATE:19640630" + "\nDTEND;VALUE=DATE:19640701" + "\nRRULE:FREQ=YEARLY;INTERVAL=1;BYMONTH=06;BYMONTHDAY=30") + (car result))) + (should (string= "g" (cdr result))))) + +(ert-deftest icalendar--convert-cyclic-to-ical () + "Test method for `icalendar--convert-cyclic-to-ical'." + (let* ((calendar-date-style 'iso) + result) + (setq result (icalendar--convert-block-to-ical + "" "%%(diary-block 2004 7 19 2004 8 27) Sommerferien")) + (should (consp result)) + (should (string= (concat + "\nDTSTART;VALUE=DATE:20040719" + "\nDTEND;VALUE=DATE:20040828") + (car result))) + (should (string= "Sommerferien" (cdr result))))) + +(ert-deftest icalendar--convert-block-to-ical () + "Test method for `icalendar--convert-block-to-ical'." + (let* ((calendar-date-style 'iso) + result) + (setq result (icalendar--convert-block-to-ical + "" "%%(diary-block 2004 7 19 2004 8 27) Sommerferien")) + (should (consp result)) + (should (string= (concat + "\nDTSTART;VALUE=DATE:20040719" + "\nDTEND;VALUE=DATE:20040828") + (car result))) + (should (string= "Sommerferien" (cdr result))))) + +(ert-deftest icalendar--convert-yearly-to-ical () + "Test method for `icalendar--convert-yearly-to-ical'." + (let* ((calendar-date-style 'iso) + result + (calendar-month-name-array + ["January" "February" "March" "April" "May" "June" "July" "August" + "September" "October" "November" "December"])) + (setq result (icalendar--convert-yearly-to-ical "" "May 1 Tag der Arbeit")) + (should (consp result)) + (should (string= (concat + "\nDTSTART;VALUE=DATE:19000501" + "\nDTEND;VALUE=DATE:19000502" + "\nRRULE:FREQ=YEARLY;INTERVAL=1;BYMONTH=5;BYMONTHDAY=1") + (car result))) + (should (string= "Tag der Arbeit" (cdr result))))) + +(ert-deftest icalendar--convert-weekly-to-ical () + "Test method for `icalendar--convert-weekly-to-ical'." + (let* ((calendar-date-style 'iso) + result + (calendar-day-name-array + ["Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" + "Saturday"])) + (setq result (icalendar--convert-weekly-to-ical "" "Monday 8:30 subject")) + (should (consp result)) + (should (string= (concat "\nDTSTART;VALUE=DATE-TIME:20050103T083000" + "\nDTEND;VALUE=DATE-TIME:20050103T093000" + "\nRRULE:FREQ=WEEKLY;INTERVAL=1;BYDAY=MO") + (car result))) + (should (string= "subject" (cdr result))))) + +(ert-deftest icalendar--convert-sexp-to-ical () + "Test method for `icalendar--convert-sexp-to-ical'." + (let* (result + (icalendar-export-sexp-enumeration-days 3)) + ;; test case %%(diary-hebrew-date) + (setq result (icalendar--convert-sexp-to-ical "" "%%(diary-hebrew-date)")) + (should (consp result)) + (should (eq icalendar-export-sexp-enumeration-days (length result))) + (mapc (lambda (i) + (should (consp i)) + (should (string-match "Hebrew date (until sunset): .*" (cdr i)))) + result))) + +(ert-deftest icalendar--convert-to-ical () + "Test method for `icalendar--convert-to-ical'." + (let* (result + (icalendar-export-sexp-enumerate-all t) + (icalendar-export-sexp-enumeration-days 3) + (calendar-date-style 'iso)) + ;; test case: %%(diary-anniversary 1642 12 25) Newton + ;; forced enumeration not matching the actual day --> empty + (setq result (icalendar--convert-sexp-to-ical + "" "%%(diary-anniversary 1642 12 25) Newton's birthday" + (encode-time 1 1 1 6 12 2014))) + (should (null result)) + ;; test case: %%(diary-anniversary 1642 12 25) Newton + ;; enumeration does match the actual day --> + (setq result (icalendar--convert-sexp-to-ical + "" "%%(diary-anniversary 1642 12 25) Newton's birthday" + (encode-time 1 1 1 24 12 2014))) + (should (= 1 (length result))) + (should (consp (car result))) + (should (string-match + "\nDTSTART;VALUE=DATE:20141225\nDTEND;VALUE=DATE:20141226" + (car (car result)))) + (should (string-match "Newton's birthday" (cdr (car result)))))) + +(ert-deftest icalendar--parse-vtimezone () + "Test method for `icalendar--parse-vtimezone'." + (let (vtimezone result) + (setq vtimezone (icalendar-tests--get-ical-event "BEGIN:VTIMEZONE +TZID:thename +BEGIN:STANDARD +DTSTART:16010101T040000 +TZOFFSETFROM:+0300 +TZOFFSETTO:+0200 +RRULE:FREQ=YEARLY;INTERVAL=1;BYDAY=-1SU;BYMONTH=10 +END:STANDARD +BEGIN:DAYLIGHT +DTSTART:16010101T030000 +TZOFFSETFROM:+0200 +TZOFFSETTO:+0300 +RRULE:FREQ=YEARLY;INTERVAL=1;BYDAY=-1SU;BYMONTH=3 +END:DAYLIGHT +END:VTIMEZONE +")) + (setq result (icalendar--parse-vtimezone vtimezone)) + (should (string= "thename" (car result))) + (message (cdr result)) + (should (string= "STD-02:00DST-03:00,M3.5.0/03:00:00,M10.5.0/04:00:00" + (cdr result))) + (setq vtimezone (icalendar-tests--get-ical-event "BEGIN:VTIMEZONE +TZID:anothername, with a comma +BEGIN:STANDARD +DTSTART:16010101T040000 +TZOFFSETFROM:+0300 +TZOFFSETTO:+0200 +RRULE:FREQ=YEARLY;INTERVAL=1;BYDAY=2MO;BYMONTH=10 +END:STANDARD +BEGIN:DAYLIGHT +DTSTART:16010101T030000 +TZOFFSETFROM:+0200 +TZOFFSETTO:+0300 +RRULE:FREQ=YEARLY;INTERVAL=1;BYDAY=2MO;BYMONTH=3 +END:DAYLIGHT +END:VTIMEZONE +")) + (setq result (icalendar--parse-vtimezone vtimezone)) + (should (string= "anothername, with a comma" (car result))) + (message (cdr result)) + (should (string= "STD-02:00DST-03:00,M3.2.1/03:00:00,M10.2.1/04:00:00" + (cdr result))) + ;; offsetfrom = offsetto + (setq vtimezone (icalendar-tests--get-ical-event "BEGIN:VTIMEZONE +TZID:Kolkata, Chennai, Mumbai, New Delhi +X-MICROSOFT-CDO-TZID:23 +BEGIN:STANDARD +DTSTART:16010101T000000 +TZOFFSETFROM:+0530 +TZOFFSETTO:+0530 +END:STANDARD +BEGIN:DAYLIGHT +DTSTART:16010101T000000 +TZOFFSETFROM:+0530 +TZOFFSETTO:+0530 +END:DAYLIGHT +END:VTIMEZONE +")) + (setq result (icalendar--parse-vtimezone vtimezone)) + (should (string= "Kolkata, Chennai, Mumbai, New Delhi" (car result))) + (message (cdr result)) + (should (string= "STD-05:30DST-05:30,M1.1.1/00:00:00,M1.1.1/00:00:00" + (cdr result))))) + +(ert-deftest icalendar--convert-ordinary-to-ical () + "Test method for `icalendar--convert-ordinary-to-ical'." + (let* ((calendar-date-style 'iso) + result) + ;; without time + (setq result (icalendar--convert-ordinary-to-ical "&?" "2010 2 15 subject")) + (should (consp result)) + (should (string= "\nDTSTART;VALUE=DATE:20100215\nDTEND;VALUE=DATE:20100216" + (car result))) + (should (string= "subject" (cdr result))) + + ;; with start time + (setq result (icalendar--convert-ordinary-to-ical + "&?" "&2010 2 15 12:34 s")) + (should (consp result)) + (should (string= (concat "\nDTSTART;VALUE=DATE-TIME:20100215T123400" + "\nDTEND;VALUE=DATE-TIME:20100215T133400") + (car result))) + (should (string= "s" (cdr result))) + + ;; with time + (setq result (icalendar--convert-ordinary-to-ical + "&?" "&2010 2 15 12:34-23:45 s")) + (should (consp result)) + (should (string= (concat "\nDTSTART;VALUE=DATE-TIME:20100215T123400" + "\nDTEND;VALUE=DATE-TIME:20100215T234500") + (car result))) + (should (string= "s" (cdr result))) + + ;; with time, again -- test bug#5549 + (setq result (icalendar--convert-ordinary-to-ical + "x?" "x2010 2 15 0:34-1:45 s")) + (should (consp result)) + (should (string= (concat "\nDTSTART;VALUE=DATE-TIME:20100215T003400" + "\nDTEND;VALUE=DATE-TIME:20100215T014500") + (car result))) + (should (string= "s" (cdr result))))) + +(ert-deftest icalendar--diarytime-to-isotime () + "Test method for `icalendar--diarytime-to-isotime'." + (should (string= "T011500" + (icalendar--diarytime-to-isotime "01:15" ""))) + (should (string= "T011500" + (icalendar--diarytime-to-isotime "1:15" ""))) + (should (string= "T000100" + (icalendar--diarytime-to-isotime "0:01" ""))) + (should (string= "T010000" + (icalendar--diarytime-to-isotime "0100" ""))) + (should (string= "T010000" + (icalendar--diarytime-to-isotime "0100" "am"))) + (should (string= "T130000" + (icalendar--diarytime-to-isotime "0100" "pm"))) + (should (string= "T120000" + (icalendar--diarytime-to-isotime "1200" ""))) + (should (string= "T171700" + (icalendar--diarytime-to-isotime "17:17" ""))) + (should (string= "T000000" + (icalendar--diarytime-to-isotime "1200" "am"))) + (should (string= "T000100" + (icalendar--diarytime-to-isotime "1201" "am"))) + (should (string= "T005900" + (icalendar--diarytime-to-isotime "1259" "am"))) + (should (string= "T120000" + (icalendar--diarytime-to-isotime "1200" "pm"))) + (should (string= "T120100" + (icalendar--diarytime-to-isotime "1201" "pm"))) + (should (string= "T125900" + (icalendar--diarytime-to-isotime "1259" "pm"))) + (should (string= "T150000" + (icalendar--diarytime-to-isotime "3" "pm")))) + +(ert-deftest icalendar--datetime-to-diary-date () + "Test method for `icalendar--datetime-to-diary-date'." + (let* ((datetime '(59 59 23 31 12 2008)) + (calendar-date-style 'iso)) + (should (string= "2008 12 31" + (icalendar--datetime-to-diary-date datetime))) + (setq calendar-date-style 'european) + (should (string= "31 12 2008" + (icalendar--datetime-to-diary-date datetime))) + (setq calendar-date-style 'american) + (should (string= "12 31 2008" + (icalendar--datetime-to-diary-date datetime))))) + +(ert-deftest icalendar--datestring-to-isodate () + "Test method for `icalendar--datestring-to-isodate'." + (let ((calendar-date-style 'iso)) + ;; numeric iso + (should (string= "20080511" + (icalendar--datestring-to-isodate "2008 05 11"))) + (should (string= "20080531" + (icalendar--datestring-to-isodate "2008 05 31"))) + (should (string= "20080602" + (icalendar--datestring-to-isodate "2008 05 31" 2))) + + ;; numeric european + (setq calendar-date-style 'european) + (should (string= "20080511" + (icalendar--datestring-to-isodate "11 05 2008"))) + (should (string= "20080531" + (icalendar--datestring-to-isodate "31 05 2008"))) + (should (string= "20080602" + (icalendar--datestring-to-isodate "31 05 2008" 2))) + + ;; numeric american + (setq calendar-date-style 'american) + (should (string= "20081105" + (icalendar--datestring-to-isodate "11 05 2008"))) + (should (string= "20081230" + (icalendar--datestring-to-isodate "12 30 2008"))) + (should (string= "20090101" + (icalendar--datestring-to-isodate "12 30 2008" 2))) + + ;; non-numeric + (setq calendar-date-style nil) ;not necessary for conversion + (should (string= "20081105" + (icalendar--datestring-to-isodate "Nov 05 2008"))) + (should (string= "20081105" + (icalendar--datestring-to-isodate "05 Nov 2008"))) + (should (string= "20081105" + (icalendar--datestring-to-isodate "2008 Nov 05"))))) + +(ert-deftest icalendar--first-weekday-of-year () + "Test method for `icalendar-first-weekday-of-year'." + (should (eq 1 (icalendar-first-weekday-of-year "TU" 2008))) + (should (eq 3 (icalendar-first-weekday-of-year "WE" 2007))) + (should (eq 5 (icalendar-first-weekday-of-year "TH" 2006))) + (should (eq 7 (icalendar-first-weekday-of-year "FR" 2005))) + (should (eq 3 (icalendar-first-weekday-of-year "SA" 2004))) + (should (eq 5 (icalendar-first-weekday-of-year "SU" 2003))) + (should (eq 7 (icalendar-first-weekday-of-year "MO" 2002))) + (should (eq 3 (icalendar-first-weekday-of-year "MO" 2000))) + (should (eq 1 (icalendar-first-weekday-of-year "TH" 1970)))) + +(ert-deftest icalendar--import-format-sample () + "Test method for `icalendar-import-format-sample'." + (should (string= (concat "SUMMARY='a' DESCRIPTION='b' LOCATION='c' " + "ORGANIZER='d' STATUS='' URL='' CLASS=''") + (icalendar-import-format-sample + (icalendar-tests--get-ical-event "BEGIN:VEVENT +DTSTAMP:20030509T043439Z +DTSTART:20030509T103000 +SUMMARY:a +ORGANIZER:d +LOCATION:c +DTEND:20030509T153000 +DESCRIPTION:b +END:VEVENT +"))))) + +(ert-deftest icalendar--format-ical-event () + "Test `icalendar--format-ical-event'." + (let ((icalendar-import-format "%s%d%l%o%t%u%c") + (icalendar-import-format-summary "SUM %s") + (icalendar-import-format-location " LOC %s") + (icalendar-import-format-description " DES %s") + (icalendar-import-format-organizer " ORG %s") + (icalendar-import-format-status " STA %s") + (icalendar-import-format-url " URL %s") + (icalendar-import-format-class " CLA %s") + (event (icalendar-tests--get-ical-event "BEGIN:VEVENT +DTSTAMP:20030509T043439Z +DTSTART:20030509T103000 +SUMMARY:sum +ORGANIZER:org +LOCATION:loc +DTEND:20030509T153000 +DESCRIPTION:des +END:VEVENT +"))) + (should (string= "SUM sum DES des LOC loc ORG org" + (icalendar--format-ical-event event))) + (setq icalendar-import-format (lambda (&rest ignore) + "helloworld")) + (should (string= "helloworld" (icalendar--format-ical-event event))) + (setq icalendar-import-format + (lambda (e) + (format "-%s-%s-%s-%s-%s-%s-%s-" + (icalendar--get-event-property event 'SUMMARY) + (icalendar--get-event-property event 'DESCRIPTION) + (icalendar--get-event-property event 'LOCATION) + (icalendar--get-event-property event 'ORGANIZER) + (icalendar--get-event-property event 'STATUS) + (icalendar--get-event-property event 'URL) + (icalendar--get-event-property event 'CLASS)))) + (should (string= "-sum-des-loc-org-nil-nil-nil-" + (icalendar--format-ical-event event))))) + +(ert-deftest icalendar--parse-summary-and-rest () + "Test `icalendar--parse-summary-and-rest'." + (let ((icalendar-import-format "%s%d%l%o%t%u%c") + (icalendar-import-format-summary "SUM %s") + (icalendar-import-format-location " LOC %s") + (icalendar-import-format-description " DES %s") + (icalendar-import-format-organizer " ORG %s") + (icalendar-import-format-status " STA %s") + (icalendar-import-format-url " URL %s") + (icalendar-import-format-class " CLA %s") + (result)) + (setq result (icalendar--parse-summary-and-rest "SUM sum ORG org")) + (should (string= "org" (cdr (assoc 'org result)))) + + (setq result (icalendar--parse-summary-and-rest + "SUM sum DES des LOC loc ORG org STA sta URL url CLA cla")) + (should (string= "des" (cdr (assoc 'des result)))) + (should (string= "loc" (cdr (assoc 'loc result)))) + (should (string= "org" (cdr (assoc 'org result)))) + (should (string= "sta" (cdr (assoc 'sta result)))) + (should (string= "cla" (cdr (assoc 'cla result)))) + + (setq icalendar-import-format (lambda () "Hello world")) + (setq result (icalendar--parse-summary-and-rest + "blah blah ")) + (should (not result)) + )) + +(ert-deftest icalendar--decode-isodatetime () + "Test `icalendar--decode-isodatetime'." + (let ((tz (getenv "TZ")) + result) + (unwind-protect + (progn + ;; Use Eastern European Time (UTC+2, UTC+3 daylight saving) + (setenv "TZ" "EET-2EEST,M3.5.0/3,M10.5.0/4") + + (message "%s" (current-time-zone (encode-time 0 0 10 1 1 2013 0))) + (message "%s" (current-time-zone (encode-time 0 0 10 1 8 2013 0))) + + ;; testcase: no time zone in input -> keep time as is + ;; 1 Jan 2013 10:00 + (should (equal '(0 0 10 1 1 2013 2 nil 7200) + (icalendar--decode-isodatetime "20130101T100000"))) + ;; 1 Aug 2013 10:00 (DST) + (should (equal '(0 0 10 1 8 2013 4 t 10800) + (icalendar--decode-isodatetime "20130801T100000"))) + + ;; testcase: UTC time zone specifier in input -> convert to local time + ;; 31 Dec 2013 23:00 UTC -> 1 Jan 2013 01:00 EET + (should (equal '(0 0 1 1 1 2014 3 nil 7200) + (icalendar--decode-isodatetime "20131231T230000Z"))) + ;; 1 Aug 2013 10:00 UTC -> 1 Aug 2013 13:00 EEST + (should (equal '(0 0 13 1 8 2013 4 t 10800) + (icalendar--decode-isodatetime "20130801T100000Z"))) + + ) + ;; restore time-zone even if something went terribly wrong + (setenv "TZ" tz))) ) + +;; ====================================================================== +;; Export tests +;; ====================================================================== + +(defun icalendar-tests--test-export (input-iso input-european input-american + expected-output &optional alarms) + "Perform an export test. +Argument INPUT-ISO iso style diary string. +Argument INPUT-EUROPEAN european style diary string. +Argument INPUT-AMERICAN american style diary string. +Argument EXPECTED-OUTPUT expected iCalendar result string. +Optional argument ALARMS the value of `icalendar-export-alarms' for this test. + +European style input data must use german month names. American +and ISO style input data must use english month names." + (let ((tz (getenv "TZ")) + (calendar-date-style 'iso) + (icalendar-recurring-start-year 2000) + (icalendar-export-alarms alarms)) + (unwind-protect + (progn +;;; (message "Current time zone: %s" (current-time-zone)) + ;; Use this form so as not to rely on system tz database. + ;; Eg hydra.nixos.org. + (setenv "TZ" "CET-1CEST,M3.5.0/2,M10.5.0/3") +;;; (message "Current time zone: %s" (current-time-zone)) + (when input-iso + (let ((calendar-month-name-array + ["January" "February" "March" "April" "May" "June" "July" "August" + "September" "October" "November" "December"]) + (calendar-day-name-array + ["Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" + "Saturday"])) + (setq calendar-date-style 'iso) + (icalendar-tests--do-test-export input-iso expected-output))) + (when input-european + (let ((calendar-month-name-array + ["Januar" "Februar" "März" "April" "Mai" "Juni" "Juli" "August" + "September" "Oktober" "November" "Dezember"]) + (calendar-day-name-array + ["Sonntag" "Montag" "Dienstag" "Mittwoch" "Donnerstag" "Freitag" + "Samstag"])) + (setq calendar-date-style 'european) + (icalendar-tests--do-test-export input-european expected-output))) + (when input-american + (let ((calendar-month-name-array + ["January" "February" "March" "April" "May" "June" "July" "August" + "September" "October" "November" "December"]) + (calendar-day-name-array + ["Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" + "Saturday"])) + (setq calendar-date-style 'american) + (icalendar-tests--do-test-export input-american expected-output)))) + ;; restore time-zone even if something went terribly wrong + (setenv "TZ" tz)))) + +(defun icalendar-tests--do-test-export (input expected-output) + "Actually perform export test. +Argument INPUT input diary string. +Argument EXPECTED-OUTPUT expected iCalendar result string." + (let ((temp-file (make-temp-file "icalendar-tests-ics"))) + (unwind-protect + (progn + (with-temp-buffer + (insert input) + (icalendar-export-region (point-min) (point-max) temp-file)) + (save-excursion + (find-file temp-file) + (goto-char (point-min)) + (cond (expected-output + (should (re-search-forward "^\\s-*BEGIN:VCALENDAR +PRODID:-//Emacs//NONSGML icalendar.el//EN +VERSION:2.0 +BEGIN:VEVENT +UID:emacs[0-9]+ +\\(\\(.\\|\n\\)+\\) +END:VEVENT +END:VCALENDAR +\\s-*$" + nil t)) + (should (string-match + (concat "^\\s-*" + (regexp-quote (buffer-substring-no-properties + (match-beginning 1) (match-end 1))) + "\\s-*$") + expected-output))) + (t + (should (re-search-forward "^\\s-*BEGIN:VCALENDAR +PRODID:-//Emacs//NONSGML icalendar.el//EN +VERSION:2.0 +END:VCALENDAR +\\s-*$" + nil t)))))) + ;; cleanup!! + (kill-buffer (find-buffer-visiting temp-file)) + (delete-file temp-file)))) + +(ert-deftest icalendar-export-ordinary-no-time () + "Perform export test." + + (let ((icalendar-export-hidden-diary-entries nil)) + (icalendar-tests--test-export + "&2000 Oct 3 ordinary no time " + "&3 Okt 2000 ordinary no time " + "&Oct 3 2000 ordinary no time " + nil)) + + (icalendar-tests--test-export + "2000 Oct 3 ordinary no time " + "3 Okt 2000 ordinary no time " + "Oct 3 2000 ordinary no time " + "DTSTART;VALUE=DATE:20001003 +DTEND;VALUE=DATE:20001004 +SUMMARY:ordinary no time +")) + +(ert-deftest icalendar-export-ordinary () + "Perform export test." + + (icalendar-tests--test-export + "2000 Oct 3 16:30 ordinary with time" + "3 Okt 2000 16:30 ordinary with time" + "Oct 3 2000 16:30 ordinary with time" + "DTSTART;VALUE=DATE-TIME:20001003T163000 +DTEND;VALUE=DATE-TIME:20001003T173000 +SUMMARY:ordinary with time +") + (icalendar-tests--test-export + "2000 10 3 16:30 ordinary with time 2" + "3 10 2000 16:30 ordinary with time 2" + "10 3 2000 16:30 ordinary with time 2" + "DTSTART;VALUE=DATE-TIME:20001003T163000 +DTEND;VALUE=DATE-TIME:20001003T173000 +SUMMARY:ordinary with time 2 +") + + (icalendar-tests--test-export + "2000/10/3 16:30 ordinary with time 3" + "3/10/2000 16:30 ordinary with time 3" + "10/3/2000 16:30 ordinary with time 3" + "DTSTART;VALUE=DATE-TIME:20001003T163000 +DTEND;VALUE=DATE-TIME:20001003T173000 +SUMMARY:ordinary with time 3 +")) + +(ert-deftest icalendar-export-multiline () + "Perform export test." + + ;; multiline -- FIXME!!! + (icalendar-tests--test-export + "2000 October 3 16:30 multiline + 17:30 multiline continued FIXME" + "3 Oktober 2000 16:30 multiline + 17:30 multiline continued FIXME" + "October 3 2000 16:30 multiline + 17:30 multiline continued FIXME" + "DTSTART;VALUE=DATE-TIME:20001003T163000 +DTEND;VALUE=DATE-TIME:20001003T173000 +SUMMARY:multiline +DESCRIPTION: + 17:30 multiline continued FIXME +")) + +(ert-deftest icalendar-export-weekly-by-day () + "Perform export test." + + ;; weekly by day + (icalendar-tests--test-export + "Monday 1:30pm weekly by day with start time" + "Montag 13:30 weekly by day with start time" + "Monday 1:30pm weekly by day with start time" + "DTSTART;VALUE=DATE-TIME:20000103T133000 +DTEND;VALUE=DATE-TIME:20000103T143000 +RRULE:FREQ=WEEKLY;INTERVAL=1;BYDAY=MO +SUMMARY:weekly by day with start time +") + + (icalendar-tests--test-export + "Monday 13:30-15:00 weekly by day with start and end time" + "Montag 13:30-15:00 weekly by day with start and end time" + "Monday 01:30pm-03:00pm weekly by day with start and end time" + "DTSTART;VALUE=DATE-TIME:20000103T133000 +DTEND;VALUE=DATE-TIME:20000103T150000 +RRULE:FREQ=WEEKLY;INTERVAL=1;BYDAY=MO +SUMMARY:weekly by day with start and end time +")) + +(ert-deftest icalendar-export-yearly () + "Perform export test." + ;; yearly + (icalendar-tests--test-export + "may 1 yearly no time" + "1 Mai yearly no time" + "may 1 yearly no time" + "DTSTART;VALUE=DATE:19000501 +DTEND;VALUE=DATE:19000502 +RRULE:FREQ=YEARLY;INTERVAL=1;BYMONTH=5;BYMONTHDAY=1 +SUMMARY:yearly no time +")) + +(ert-deftest icalendar-export-anniversary () + "Perform export test." + ;; anniversaries + (icalendar-tests--test-export + "%%(diary-anniversary 1989 10 3) anniversary no time" + "%%(diary-anniversary 3 10 1989) anniversary no time" + "%%(diary-anniversary 10 3 1989) anniversary no time" + "DTSTART;VALUE=DATE:19891003 +DTEND;VALUE=DATE:19891004 +RRULE:FREQ=YEARLY;INTERVAL=1;BYMONTH=10;BYMONTHDAY=03 +SUMMARY:anniversary no time +") + (icalendar-tests--test-export + "%%(diary-anniversary 1989 10 3) 19:00-20:00 anniversary with time" + "%%(diary-anniversary 3 10 1989) 19:00-20:00 anniversary with time" + "%%(diary-anniversary 10 3 1989) 19:00-20:00 anniversary with time" + "DTSTART;VALUE=DATE-TIME:19891003T190000 +DTEND;VALUE=DATE-TIME:19891004T200000 +RRULE:FREQ=YEARLY;INTERVAL=1;BYMONTH=10;BYMONTHDAY=03 +SUMMARY:anniversary with time +")) + +(ert-deftest icalendar-export-block () + "Perform export test." + ;; block + (icalendar-tests--test-export + "%%(diary-block 2001 6 18 2001 7 6) block no time" + "%%(diary-block 18 6 2001 6 7 2001) block no time" + "%%(diary-block 6 18 2001 7 6 2001) block no time" + "DTSTART;VALUE=DATE:20010618 +DTEND;VALUE=DATE:20010707 +SUMMARY:block no time +") + (icalendar-tests--test-export + "%%(diary-block 2001 6 18 2001 7 6) 13:00-17:00 block with time" + "%%(diary-block 18 6 2001 6 7 2001) 13:00-17:00 block with time" + "%%(diary-block 6 18 2001 7 6 2001) 13:00-17:00 block with time" + "DTSTART;VALUE=DATE-TIME:20010618T130000 +DTEND;VALUE=DATE-TIME:20010618T170000 +RRULE:FREQ=DAILY;INTERVAL=1;UNTIL=20010706 +SUMMARY:block with time +") + (icalendar-tests--test-export + "%%(diary-block 2001 6 18 2001 7 6) 13:00 block no end time" + "%%(diary-block 18 6 2001 6 7 2001) 13:00 block no end time" + "%%(diary-block 6 18 2001 7 6 2001) 13:00 block no end time" + "DTSTART;VALUE=DATE-TIME:20010618T130000 +DTEND;VALUE=DATE-TIME:20010618T140000 +RRULE:FREQ=DAILY;INTERVAL=1;UNTIL=20010706 +SUMMARY:block no end time +")) + +(ert-deftest icalendar-export-alarms () + "Perform export test with different settings for exporting alarms." + ;; no alarm + (icalendar-tests--test-export + "2014 Nov 17 19:30 no alarm" + "17 Nov 2014 19:30 no alarm" + "Nov 17 2014 19:30 no alarm" + "DTSTART;VALUE=DATE-TIME:20141117T193000 +DTEND;VALUE=DATE-TIME:20141117T203000 +SUMMARY:no alarm +" + nil) + + ;; 10 minutes in advance, audio + (icalendar-tests--test-export + "2014 Nov 17 19:30 audio alarm" + "17 Nov 2014 19:30 audio alarm" + "Nov 17 2014 19:30 audio alarm" + "DTSTART;VALUE=DATE-TIME:20141117T193000 +DTEND;VALUE=DATE-TIME:20141117T203000 +SUMMARY:audio alarm +BEGIN:VALARM +ACTION:AUDIO +TRIGGER:-PT10M +END:VALARM +" + '(10 ((audio)))) + + ;; 20 minutes in advance, display + (icalendar-tests--test-export + "2014 Nov 17 19:30 display alarm" + "17 Nov 2014 19:30 display alarm" + "Nov 17 2014 19:30 display alarm" + "DTSTART;VALUE=DATE-TIME:20141117T193000 +DTEND;VALUE=DATE-TIME:20141117T203000 +SUMMARY:display alarm +BEGIN:VALARM +ACTION:DISPLAY +TRIGGER:-PT20M +DESCRIPTION:display alarm +END:VALARM +" + '(20 ((display)))) + + ;; 66 minutes in advance, email + (icalendar-tests--test-export + "2014 Nov 17 19:30 email alarm" + "17 Nov 2014 19:30 email alarm" + "Nov 17 2014 19:30 email alarm" + "DTSTART;VALUE=DATE-TIME:20141117T193000 +DTEND;VALUE=DATE-TIME:20141117T203000 +SUMMARY:email alarm +BEGIN:VALARM +ACTION:EMAIL +TRIGGER:-PT66M +DESCRIPTION:email alarm +SUMMARY:email alarm +ATTENDEE:MAILTO:att.one@email.com +ATTENDEE:MAILTO:att.two@email.com +END:VALARM +" + '(66 ((email ("att.one@email.com" "att.two@email.com"))))) + + ;; 2 minutes in advance, all alarms + (icalendar-tests--test-export + "2014 Nov 17 19:30 all alarms" + "17 Nov 2014 19:30 all alarms" + "Nov 17 2014 19:30 all alarms" + "DTSTART;VALUE=DATE-TIME:20141117T193000 +DTEND;VALUE=DATE-TIME:20141117T203000 +SUMMARY:all alarms +BEGIN:VALARM +ACTION:EMAIL +TRIGGER:-PT2M +DESCRIPTION:all alarms +SUMMARY:all alarms +ATTENDEE:MAILTO:att.one@email.com +ATTENDEE:MAILTO:att.two@email.com +END:VALARM +BEGIN:VALARM +ACTION:AUDIO +TRIGGER:-PT2M +END:VALARM +BEGIN:VALARM +ACTION:DISPLAY +TRIGGER:-PT2M +DESCRIPTION:all alarms +END:VALARM +" + '(2 ((email ("att.one@email.com" "att.two@email.com")) (audio) (display))))) + +;; ====================================================================== +;; Import tests +;; ====================================================================== + +(defun icalendar-tests--test-import (input expected-iso expected-european + expected-american) + "Perform import test. +Argument INPUT icalendar event string. +Argument EXPECTED-ISO expected iso style diary string. +Argument EXPECTED-EUROPEAN expected european style diary string. +Argument EXPECTED-AMERICAN expected american style diary string. +During import test the timezone is set to Central European Time." + (let ((timezone (getenv "TZ"))) + (unwind-protect + (progn + ;; Use this form so as not to rely on system tz database. + ;; Eg hydra.nixos.org. + (setenv "TZ" "CET-1CEST,M3.5.0/2,M10.5.0/3") + (with-temp-buffer + (if (string-match "^BEGIN:VCALENDAR" input) + (insert input) + (insert "BEGIN:VCALENDAR\nPRODID:-//Emacs//NONSGML icalendar.el//EN\n") + (insert "VERSION:2.0\nBEGIN:VEVENT\n") + (insert input) + (unless (eq (char-before) ?\n) + (insert "\n")) + (insert "END:VEVENT\nEND:VCALENDAR\n")) + (let ((icalendar-import-format "%s%d%l%o%t%u%c%U") + (icalendar-import-format-summary "%s") + (icalendar-import-format-location "\n Location: %s") + (icalendar-import-format-description "\n Desc: %s") + (icalendar-import-format-organizer "\n Organizer: %s") + (icalendar-import-format-status "\n Status: %s") + (icalendar-import-format-url "\n URL: %s") + (icalendar-import-format-class "\n Class: %s") + (icalendar-import-format-uid "\n UID: %s") + calendar-date-style) + (when expected-iso + (setq calendar-date-style 'iso) + (icalendar-tests--do-test-import input expected-iso)) + (when expected-european + (setq calendar-date-style 'european) + (icalendar-tests--do-test-import input expected-european)) + (when expected-american + (setq calendar-date-style 'american) + (icalendar-tests--do-test-import input expected-american))))) + (setenv "TZ" timezone)))) + +(defun icalendar-tests--do-test-import (input expected-output) + "Actually perform import test. +Argument INPUT input icalendar string. +Argument EXPECTED-OUTPUT expected diary string." + (let ((temp-file (make-temp-file "icalendar-test-diary"))) + ;; Test the Catch-the-mysterious-coding-header logic below. + ;; Ruby-mode adds an after-save-hook which inserts the header! + ;; (save-excursion + ;; (find-file temp-file) + ;; (ruby-mode)) + (icalendar-import-buffer temp-file t t) + (save-excursion + (find-file temp-file) + ;; Check for the mysterious "# coding: ..." header, remove it + ;; and give a shout + (goto-char (point-min)) + (when (re-search-forward "# coding: .*?\n" nil t) + (message (concat "%s\n" + "Found mysterious \"# coding ...\" header! Removing it.\n" + "Current Modes: %s, %s\n" + "Current test: %s\n" + "%s") + (make-string 70 ?*) + major-mode + minor-mode-list + (ert-running-test) + (make-string 70 ?*)) + (buffer-disable-undo) + (replace-match "") + (set-buffer-modified-p nil)) + + (let ((result (buffer-substring-no-properties (point-min) (point-max)))) + (should (string= expected-output result))) + (kill-buffer (find-buffer-visiting temp-file)) + (delete-file temp-file)))) + +(ert-deftest icalendar-import-non-recurring () + "Perform standard import tests." + (icalendar-tests--test-import + "SUMMARY:non-recurring +DTSTART;VALUE=DATE-TIME:20030919T090000 +DTEND;VALUE=DATE-TIME:20030919T113000" + "&2003/9/19 09:00-11:30 non-recurring\n" + "&19/9/2003 09:00-11:30 non-recurring\n" + "&9/19/2003 09:00-11:30 non-recurring\n") + (icalendar-tests--test-import + "SUMMARY:non-recurring allday +DTSTART;VALUE=DATE-TIME:20030919" + "&2003/9/19 non-recurring allday\n" + "&19/9/2003 non-recurring allday\n" + "&9/19/2003 non-recurring allday\n") + (icalendar-tests--test-import + ;; Checkdoc removes trailing blanks. Therefore: format! + (format "%s\n%s\n%s" "SUMMARY:long " " summary" + "DTSTART;VALUE=DATE:20030919") + "&2003/9/19 long summary\n" + "&19/9/2003 long summary\n" + "&9/19/2003 long summary\n") + (icalendar-tests--test-import + "UID:748f2da0-0d9b-11d8-97af-b4ec8686ea61 +SUMMARY:Sommerferien +STATUS:TENTATIVE +CLASS:PRIVATE +X-MOZILLA-ALARM-DEFAULT-UNITS:Minuten +X-MOZILLA-RECUR-DEFAULT-INTERVAL:0 +DTSTART;VALUE=DATE:20040719 +DTEND;VALUE=DATE:20040828 +DTSTAMP:20031103T011641Z +" + "&%%(and (diary-block 2004 7 19 2004 8 27)) Sommerferien + Status: TENTATIVE + Class: PRIVATE + UID: 748f2da0-0d9b-11d8-97af-b4ec8686ea61 +" + "&%%(and (diary-block 19 7 2004 27 8 2004)) Sommerferien + Status: TENTATIVE + Class: PRIVATE + UID: 748f2da0-0d9b-11d8-97af-b4ec8686ea61 +" + "&%%(and (diary-block 7 19 2004 8 27 2004)) Sommerferien + Status: TENTATIVE + Class: PRIVATE + UID: 748f2da0-0d9b-11d8-97af-b4ec8686ea61 +") + (icalendar-tests--test-import + "UID + :04979712-3902-11d9-93dd-8f9f4afe08da +SUMMARY + :folded summary +STATUS + :TENTATIVE +CLASS + :PRIVATE +X-MOZILLA-ALARM-DEFAULT-LENGTH + :0 +DTSTART + :20041123T140000 +DTEND + :20041123T143000 +DTSTAMP + :20041118T013430Z +LAST-MODIFIED + :20041118T013640Z +" + "&2004/11/23 14:00-14:30 folded summary + Status: TENTATIVE + Class: PRIVATE + UID: 04979712-3902-11d9-93dd-8f9f4afe08da\n" + "&23/11/2004 14:00-14:30 folded summary + Status: TENTATIVE + Class: PRIVATE + UID: 04979712-3902-11d9-93dd-8f9f4afe08da\n" + "&11/23/2004 14:00-14:30 folded summary + Status: TENTATIVE + Class: PRIVATE + UID: 04979712-3902-11d9-93dd-8f9f4afe08da\n") + + (icalendar-tests--test-import + "UID + :6161a312-3902-11d9-b512-f764153bb28b +SUMMARY + :another example +STATUS + :TENTATIVE +CLASS + :PRIVATE +X-MOZILLA-ALARM-DEFAULT-LENGTH + :0 +DTSTART + :20041123T144500 +DTEND + :20041123T154500 +DTSTAMP + :20041118T013641Z +" + "&2004/11/23 14:45-15:45 another example + Status: TENTATIVE + Class: PRIVATE + UID: 6161a312-3902-11d9-b512-f764153bb28b\n" + "&23/11/2004 14:45-15:45 another example + Status: TENTATIVE + Class: PRIVATE + UID: 6161a312-3902-11d9-b512-f764153bb28b\n" + "&11/23/2004 14:45-15:45 another example + Status: TENTATIVE + Class: PRIVATE + UID: 6161a312-3902-11d9-b512-f764153bb28b\n")) + +(ert-deftest icalendar-import-rrule () + (icalendar-tests--test-import + "SUMMARY:rrule daily +DTSTART;VALUE=DATE-TIME:20030919T090000 +DTEND;VALUE=DATE-TIME:20030919T113000 +RRULE:FREQ=DAILY; +" + "&%%(and (diary-cyclic 1 2003 9 19)) 09:00-11:30 rrule daily\n" + "&%%(and (diary-cyclic 1 19 9 2003)) 09:00-11:30 rrule daily\n" + "&%%(and (diary-cyclic 1 9 19 2003)) 09:00-11:30 rrule daily\n") + ;; RRULE examples + (icalendar-tests--test-import + "SUMMARY:rrule daily +DTSTART;VALUE=DATE-TIME:20030919T090000 +DTEND;VALUE=DATE-TIME:20030919T113000 +RRULE:FREQ=DAILY;INTERVAL=2 +" + "&%%(and (diary-cyclic 2 2003 9 19)) 09:00-11:30 rrule daily\n" + "&%%(and (diary-cyclic 2 19 9 2003)) 09:00-11:30 rrule daily\n" + "&%%(and (diary-cyclic 2 9 19 2003)) 09:00-11:30 rrule daily\n") + (icalendar-tests--test-import + "SUMMARY:rrule daily with exceptions +DTSTART;VALUE=DATE-TIME:20030919T090000 +DTEND;VALUE=DATE-TIME:20030919T113000 +RRULE:FREQ=DAILY;INTERVAL=2 +EXDATE:20030921,20030925 +" + "&%%(and (not (diary-date 2003 9 25)) (not (diary-date 2003 9 21)) (diary-cyclic 2 2003 9 19)) 09:00-11:30 rrule daily with exceptions\n" + "&%%(and (not (diary-date 25 9 2003)) (not (diary-date 21 9 2003)) (diary-cyclic 2 19 9 2003)) 09:00-11:30 rrule daily with exceptions\n" + "&%%(and (not (diary-date 9 25 2003)) (not (diary-date 9 21 2003)) (diary-cyclic 2 9 19 2003)) 09:00-11:30 rrule daily with exceptions\n") + (icalendar-tests--test-import + "SUMMARY:rrule weekly +DTSTART;VALUE=DATE-TIME:20030919T090000 +DTEND;VALUE=DATE-TIME:20030919T113000 +RRULE:FREQ=WEEKLY; +" + "&%%(and (diary-cyclic 7 2003 9 19)) 09:00-11:30 rrule weekly\n" + "&%%(and (diary-cyclic 7 19 9 2003)) 09:00-11:30 rrule weekly\n" + "&%%(and (diary-cyclic 7 9 19 2003)) 09:00-11:30 rrule weekly\n") + (icalendar-tests--test-import + "SUMMARY:rrule monthly no end +DTSTART;VALUE=DATE-TIME:20030919T090000 +DTEND;VALUE=DATE-TIME:20030919T113000 +RRULE:FREQ=MONTHLY; +" + "&%%(and (diary-date t t 19) (diary-block 2003 9 19 9999 1 1)) 09:00-11:30 rrule monthly no end\n" + "&%%(and (diary-date 19 t t) (diary-block 19 9 2003 1 1 9999)) 09:00-11:30 rrule monthly no end\n" + "&%%(and (diary-date t 19 t) (diary-block 9 19 2003 1 1 9999)) 09:00-11:30 rrule monthly no end\n") + (icalendar-tests--test-import + "SUMMARY:rrule monthly with end +DTSTART;VALUE=DATE-TIME:20030919T090000 +DTEND;VALUE=DATE-TIME:20030919T113000 +RRULE:FREQ=MONTHLY;UNTIL=20050819; +" + "&%%(and (diary-date t t 19) (diary-block 2003 9 19 2005 8 19)) 09:00-11:30 rrule monthly with end\n" + "&%%(and (diary-date 19 t t) (diary-block 19 9 2003 19 8 2005)) 09:00-11:30 rrule monthly with end\n" + "&%%(and (diary-date t 19 t) (diary-block 9 19 2003 8 19 2005)) 09:00-11:30 rrule monthly with end\n") + (icalendar-tests--test-import + "DTSTART;VALUE=DATE:20040815 +DTEND;VALUE=DATE:20040816 +SUMMARY:Maria Himmelfahrt +RRULE:FREQ=YEARLY;INTERVAL=1;BYMONTH=8 +" + "&%%(and (diary-anniversary 2004 8 15)) Maria Himmelfahrt\n" + "&%%(and (diary-anniversary 15 8 2004)) Maria Himmelfahrt\n" + "&%%(and (diary-anniversary 8 15 2004)) Maria Himmelfahrt\n") + (icalendar-tests--test-import + "SUMMARY:rrule yearly +DTSTART;VALUE=DATE-TIME:20030919T090000 +DTEND;VALUE=DATE-TIME:20030919T113000 +RRULE:FREQ=YEARLY;INTERVAL=2 +" + "&%%(and (diary-anniversary 2003 9 19)) 09:00-11:30 rrule yearly\n" ;FIXME + "&%%(and (diary-anniversary 19 9 2003)) 09:00-11:30 rrule yearly\n" ;FIXME + "&%%(and (diary-anniversary 9 19 2003)) 09:00-11:30 rrule yearly\n") ;FIXME + (icalendar-tests--test-import + "SUMMARY:rrule count daily short +DTSTART;VALUE=DATE-TIME:20030919T090000 +DTEND;VALUE=DATE-TIME:20030919T113000 +RRULE:FREQ=DAILY;COUNT=1;INTERVAL=1 +" + "&%%(and (diary-cyclic 1 2003 9 19) (diary-block 2003 9 19 2003 9 19)) 09:00-11:30 rrule count daily short\n" + "&%%(and (diary-cyclic 1 19 9 2003) (diary-block 19 9 2003 19 9 2003)) 09:00-11:30 rrule count daily short\n" + "&%%(and (diary-cyclic 1 9 19 2003) (diary-block 9 19 2003 9 19 2003)) 09:00-11:30 rrule count daily short\n") + (icalendar-tests--test-import + "SUMMARY:rrule count daily long +DTSTART;VALUE=DATE-TIME:20030919T090000 +DTEND;VALUE=DATE-TIME:20030919T113000 +RRULE:FREQ=DAILY;COUNT=14;INTERVAL=1 +" + "&%%(and (diary-cyclic 1 2003 9 19) (diary-block 2003 9 19 2003 10 2)) 09:00-11:30 rrule count daily long\n" + "&%%(and (diary-cyclic 1 19 9 2003) (diary-block 19 9 2003 2 10 2003)) 09:00-11:30 rrule count daily long\n" + "&%%(and (diary-cyclic 1 9 19 2003) (diary-block 9 19 2003 10 2 2003)) 09:00-11:30 rrule count daily long\n") + (icalendar-tests--test-import + "SUMMARY:rrule count bi-weekly 3 times +DTSTART;VALUE=DATE-TIME:20030919T090000 +DTEND;VALUE=DATE-TIME:20030919T113000 +RRULE:FREQ=WEEKLY;COUNT=3;INTERVAL=2 +" + "&%%(and (diary-cyclic 14 2003 9 19) (diary-block 2003 9 19 2003 10 31)) 09:00-11:30 rrule count bi-weekly 3 times\n" + "&%%(and (diary-cyclic 14 19 9 2003) (diary-block 19 9 2003 31 10 2003)) 09:00-11:30 rrule count bi-weekly 3 times\n" + "&%%(and (diary-cyclic 14 9 19 2003) (diary-block 9 19 2003 10 31 2003)) 09:00-11:30 rrule count bi-weekly 3 times\n") + (icalendar-tests--test-import + "SUMMARY:rrule count monthly +DTSTART;VALUE=DATE-TIME:20030919T090000 +DTEND;VALUE=DATE-TIME:20030919T113000 +RRULE:FREQ=MONTHLY;INTERVAL=1;COUNT=5 +" + "&%%(and (diary-date t t 19) (diary-block 2003 9 19 2004 1 19)) 09:00-11:30 rrule count monthly\n" + "&%%(and (diary-date 19 t t) (diary-block 19 9 2003 19 1 2004)) 09:00-11:30 rrule count monthly\n" + "&%%(and (diary-date t 19 t) (diary-block 9 19 2003 1 19 2004)) 09:00-11:30 rrule count monthly\n") + (icalendar-tests--test-import + "SUMMARY:rrule count every second month +DTSTART;VALUE=DATE-TIME:20030919T090000 +DTEND;VALUE=DATE-TIME:20030919T113000 +RRULE:FREQ=MONTHLY;INTERVAL=2;COUNT=5 +" + "&%%(and (diary-date t t 19) (diary-block 2003 9 19 2004 5 19)) 09:00-11:30 rrule count every second month\n" ;FIXME + "&%%(and (diary-date 19 t t) (diary-block 19 9 2003 19 5 2004)) 09:00-11:30 rrule count every second month\n" ;FIXME + "&%%(and (diary-date t 19 t) (diary-block 9 19 2003 5 19 2004)) 09:00-11:30 rrule count every second month\n") ;FIXME + (icalendar-tests--test-import + "SUMMARY:rrule count yearly +DTSTART;VALUE=DATE-TIME:20030919T090000 +DTEND;VALUE=DATE-TIME:20030919T113000 +RRULE:FREQ=YEARLY;INTERVAL=1;COUNT=5 +" + "&%%(and (diary-date t 9 19) (diary-block 2003 9 19 2007 9 19)) 09:00-11:30 rrule count yearly\n" + "&%%(and (diary-date 19 9 t) (diary-block 19 9 2003 19 9 2007)) 09:00-11:30 rrule count yearly\n" + "&%%(and (diary-date 9 19 t) (diary-block 9 19 2003 9 19 2007)) 09:00-11:30 rrule count yearly\n") + (icalendar-tests--test-import + "SUMMARY:rrule count every second year +DTSTART;VALUE=DATE-TIME:20030919T090000 +DTEND;VALUE=DATE-TIME:20030919T113000 +RRULE:FREQ=YEARLY;INTERVAL=2;COUNT=5 +" + "&%%(and (diary-date t 9 19) (diary-block 2003 9 19 2011 9 19)) 09:00-11:30 rrule count every second year\n" ;FIXME!!! + "&%%(and (diary-date 19 9 t) (diary-block 19 9 2003 19 9 2011)) 09:00-11:30 rrule count every second year\n" ;FIXME!!! + "&%%(and (diary-date 9 19 t) (diary-block 9 19 2003 9 19 2011)) 09:00-11:30 rrule count every second year\n") ;FIXME!!! +) + +(ert-deftest icalendar-import-duration () + ;; duration + (icalendar-tests--test-import + "DTSTART;VALUE=DATE:20050217 +SUMMARY:duration +DURATION:P7D +" + "&%%(and (diary-block 2005 2 17 2005 2 23)) duration\n" + "&%%(and (diary-block 17 2 2005 23 2 2005)) duration\n" + "&%%(and (diary-block 2 17 2005 2 23 2005)) duration\n") + (icalendar-tests--test-import + "UID:20041127T183329Z-18215-1001-4536-49109@andromeda +DTSTAMP:20041127T183315Z +LAST-MODIFIED:20041127T183329 +SUMMARY:Urlaub +DTSTART;VALUE=DATE:20011221 +DTEND;VALUE=DATE:20011221 +RRULE:FREQ=DAILY;UNTIL=20011229;INTERVAL=1;WKST=SU +CLASS:PUBLIC +SEQUENCE:1 +CREATED:20041127T183329 +" + "&%%(and (diary-cyclic 1 2001 12 21) (diary-block 2001 12 21 2001 12 29)) Urlaub + Class: PUBLIC + UID: 20041127T183329Z-18215-1001-4536-49109@andromeda\n" + "&%%(and (diary-cyclic 1 21 12 2001) (diary-block 21 12 2001 29 12 2001)) Urlaub + Class: PUBLIC + UID: 20041127T183329Z-18215-1001-4536-49109@andromeda\n" + "&%%(and (diary-cyclic 1 12 21 2001) (diary-block 12 21 2001 12 29 2001)) Urlaub + Class: PUBLIC + UID: 20041127T183329Z-18215-1001-4536-49109@andromeda\n")) + +(ert-deftest icalendar-import-bug-6766 () + ;;bug#6766 -- multiple byday values in a weekly rrule + (icalendar-tests--test-import +"CLASS:PUBLIC +DTEND;TZID=America/New_York:20100421T120000 +DTSTAMP:20100525T141214Z +DTSTART;TZID=America/New_York:20100421T113000 +RRULE:FREQ=WEEKLY;INTERVAL=1;BYDAY=MO,WE,TH,FR +SEQUENCE:1 +STATUS:CONFIRMED +SUMMARY:Scrum +TRANSP:OPAQUE +UID:8814e3f9-7482-408f-996c-3bfe486a1262 +END:VEVENT +BEGIN:VEVENT +CLASS:PUBLIC +DTSTAMP:20100525T141214Z +DTSTART;VALUE=DATE:20100422 +DTEND;VALUE=DATE:20100423 +RRULE:FREQ=WEEKLY;INTERVAL=1;BYDAY=TU,TH +SEQUENCE:1 +SUMMARY:Tues + Thurs thinking +TRANSP:OPAQUE +UID:8814e3f9-7482-408f-996c-3bfe486a1263 +" +"&%%(and (memq (calendar-day-of-week date) '(1 3 4 5)) (diary-cyclic 1 2010 4 21)) 11:30-12:00 Scrum + Status: CONFIRMED + Class: PUBLIC + UID: 8814e3f9-7482-408f-996c-3bfe486a1262 +&%%(and (memq (calendar-day-of-week date) '(2 4)) (diary-cyclic 1 2010 4 22)) Tues + Thurs thinking + Class: PUBLIC + UID: 8814e3f9-7482-408f-996c-3bfe486a1263 +" +"&%%(and (memq (calendar-day-of-week date) '(1 3 4 5)) (diary-cyclic 1 21 4 2010)) 11:30-12:00 Scrum + Status: CONFIRMED + Class: PUBLIC + UID: 8814e3f9-7482-408f-996c-3bfe486a1262 +&%%(and (memq (calendar-day-of-week date) '(2 4)) (diary-cyclic 1 22 4 2010)) Tues + Thurs thinking + Class: PUBLIC + UID: 8814e3f9-7482-408f-996c-3bfe486a1263 +" +"&%%(and (memq (calendar-day-of-week date) '(1 3 4 5)) (diary-cyclic 1 4 21 2010)) 11:30-12:00 Scrum + Status: CONFIRMED + Class: PUBLIC + UID: 8814e3f9-7482-408f-996c-3bfe486a1262 +&%%(and (memq (calendar-day-of-week date) '(2 4)) (diary-cyclic 1 4 22 2010)) Tues + Thurs thinking + Class: PUBLIC + UID: 8814e3f9-7482-408f-996c-3bfe486a1263 +")) + +(ert-deftest icalendar-import-multiple-vcalendars () + (icalendar-tests--test-import + "DTSTART;VALUE=DATE:20110723 +SUMMARY:event-1 +" + "&2011/7/23 event-1\n" + "&23/7/2011 event-1\n" + "&7/23/2011 event-1\n") + + (icalendar-tests--test-import + "BEGIN:VCALENDAR +PRODID:-//Emacs//NONSGML icalendar.el//EN +VERSION:2.0\nBEGIN:VEVENT +DTSTART;VALUE=DATE:20110723 +SUMMARY:event-1 +END:VEVENT +END:VCALENDAR +BEGIN:VCALENDAR +PRODID:-//Emacs//NONSGML icalendar.el//EN +VERSION:2.0 +BEGIN:VEVENT +DTSTART;VALUE=DATE:20110724 +SUMMARY:event-2 +END:VEVENT +END:VCALENDAR +BEGIN:VCALENDAR +PRODID:-//Emacs//NONSGML icalendar.el//EN +VERSION:2.0 +BEGIN:VEVENT +DTSTART;VALUE=DATE:20110725 +SUMMARY:event-3a +END:VEVENT +BEGIN:VEVENT +DTSTART;VALUE=DATE:20110725 +SUMMARY:event-3b +END:VEVENT +END:VCALENDAR +" + "&2011/7/23 event-1\n&2011/7/24 event-2\n&2011/7/25 event-3a\n&2011/7/25 event-3b\n" + "&23/7/2011 event-1\n&24/7/2011 event-2\n&25/7/2011 event-3a\n&25/7/2011 event-3b\n" + "&7/23/2011 event-1\n&7/24/2011 event-2\n&7/25/2011 event-3a\n&7/25/2011 event-3b\n")) + +(ert-deftest icalendar-import-with-uid () + "Perform import test with uid." + (icalendar-tests--test-import + "UID:1234567890uid +SUMMARY:non-recurring +DTSTART;VALUE=DATE-TIME:20030919T090000 +DTEND;VALUE=DATE-TIME:20030919T113000" + "&2003/9/19 09:00-11:30 non-recurring\n UID: 1234567890uid\n" + "&19/9/2003 09:00-11:30 non-recurring\n UID: 1234567890uid\n" + "&9/19/2003 09:00-11:30 non-recurring\n UID: 1234567890uid\n")) + +(ert-deftest icalendar-import-with-timezone () + ;; This is known to fail on MS-Windows, because the test assumes + ;; Posix features of specifying DST rules. + :expected-result (if (memq system-type '(windows-nt ms-dos)) + :failed + :passed) + ;; bug#11473 + (icalendar-tests--test-import + "BEGIN:VCALENDAR +BEGIN:VTIMEZONE +TZID:fictional, nonexistent, arbitrary +BEGIN:STANDARD +DTSTART:20100101T000000 +TZOFFSETFROM:+0200 +TZOFFSETTO:-0200 +RRULE:FREQ=YEARLY;INTERVAL=1;BYDAY=1SU;BYMONTH=01 +END:STANDARD +BEGIN:DAYLIGHT +DTSTART:20101201T000000 +TZOFFSETFROM:-0200 +TZOFFSETTO:+0200 +RRULE:FREQ=YEARLY;INTERVAL=1;BYDAY=1SU;BYMONTH=11 +END:DAYLIGHT +END:VTIMEZONE +BEGIN:VEVENT +SUMMARY:standardtime +DTSTART;TZID=\"fictional, nonexistent, arbitrary\":20120115T120000 +DTEND;TZID=\"fictional, nonexistent, arbitrary\":20120115T123000 +END:VEVENT +BEGIN:VEVENT +SUMMARY:daylightsavingtime +DTSTART;TZID=\"fictional, nonexistent, arbitrary\":20121215T120000 +DTEND;TZID=\"fictional, nonexistent, arbitrary\":20121215T123000 +END:VEVENT +END:VCALENDAR" + ;; "standardtime" begins first sunday in january and is 4 hours behind CET + ;; "daylightsavingtime" begins first sunday in november and is 1 hour before CET + "&2012/1/15 15:00-15:30 standardtime +&2012/12/15 11:00-11:30 daylightsavingtime +" + nil + nil) + ) +;; ====================================================================== +;; Cycle +;; ====================================================================== +(defun icalendar-tests--test-cycle (input) + "Perform cycle test. +Argument INPUT icalendar event string." + (with-temp-buffer + (if (string-match "^BEGIN:VCALENDAR" input) + (insert input) + (insert "BEGIN:VCALENDAR\nPRODID:-//Emacs//NONSGML icalendar.el//EN\n") + (insert "VERSION:2.0\nBEGIN:VEVENT\n") + (insert input) + (unless (eq (char-before) ?\n) + (insert "\n")) + (insert "END:VEVENT\nEND:VCALENDAR\n")) + (let ((icalendar-import-format "%s%d%l%o%t%u%c%U") + (icalendar-import-format-summary "%s") + (icalendar-import-format-location "\n Location: %s") + (icalendar-import-format-description "\n Desc: %s") + (icalendar-import-format-organizer "\n Organizer: %s") + (icalendar-import-format-status "\n Status: %s") + (icalendar-import-format-url "\n URL: %s") + (icalendar-import-format-class "\n Class: %s") + (icalendar-import-format-class "\n UID: %s") + (icalendar-export-alarms nil)) + (dolist (calendar-date-style '(iso european american)) + (icalendar-tests--do-test-cycle))))) + +(defun icalendar-tests--do-test-cycle () + "Actually perform import/export cycle test." + (let ((temp-diary (make-temp-file "icalendar-test-diary")) + (temp-ics (make-temp-file "icalendar-test-ics")) + (org-input (buffer-substring-no-properties (point-min) (point-max)))) + + (unwind-protect + (progn + ;; step 1: import + (icalendar-import-buffer temp-diary t t) + + ;; step 2: export what was just imported + (save-excursion + (find-file temp-diary) + (icalendar-export-region (point-min) (point-max) temp-ics)) + + ;; compare the output of step 2 with the input of step 1 + (save-excursion + (find-file temp-ics) + (goto-char (point-min)) + ;;(when (re-search-forward "\nUID:.*\n" nil t) + ;;(replace-match "\n")) + (let ((cycled (buffer-substring-no-properties (point-min) (point-max)))) + (should (string= org-input cycled))))) + ;; clean up + (kill-buffer (find-buffer-visiting temp-diary)) + (with-current-buffer (find-buffer-visiting temp-ics) + (set-buffer-modified-p nil) + (kill-buffer (current-buffer))) + (delete-file temp-diary) + (delete-file temp-ics)))) + +(ert-deftest icalendar-cycle () + "Perform cycling tests. +Take care to avoid auto-generated UIDs here." + (icalendar-tests--test-cycle + "UID:dummyuid +DTSTART;VALUE=DATE-TIME:20030919T090000 +DTEND;VALUE=DATE-TIME:20030919T113000 +SUMMARY:Cycletest +") + (icalendar-tests--test-cycle + "UID:blah +DTSTART;VALUE=DATE-TIME:20030919T090000 +DTEND;VALUE=DATE-TIME:20030919T113000 +SUMMARY:Cycletest +DESCRIPTION:beschreibung! +LOCATION:nowhere +ORGANIZER:ulf +") + (icalendar-tests--test-cycle + "UID:4711 +DTSTART;VALUE=DATE:19190909 +DTEND;VALUE=DATE:19190910 +RRULE:FREQ=YEARLY;INTERVAL=1;BYMONTH=09;BYMONTHDAY=09 +SUMMARY:and diary-anniversary +")) + +;; ====================================================================== +;; Real world +;; ====================================================================== +(ert-deftest icalendar-real-world () + "Perform real-world tests, as gathered from problem reports." + ;; This is known to fail on MS-Windows, since it doesn't support DST + ;; specification with month and day. + :expected-result (if (memq system-type '(windows-nt ms-dos)) + :failed + :passed) + ;; 2003-05-29 + (icalendar-tests--test-import + "BEGIN:VCALENDAR +METHOD:REQUEST +PRODID:Microsoft CDO for Microsoft Exchange +VERSION:2.0 +BEGIN:VTIMEZONE +TZID:Kolkata, Chennai, Mumbai, New Delhi +X-MICROSOFT-CDO-TZID:23 +BEGIN:STANDARD +DTSTART:16010101T000000 +TZOFFSETFROM:+0530 +TZOFFSETTO:+0530 +END:STANDARD +BEGIN:DAYLIGHT +DTSTART:16010101T000000 +TZOFFSETFROM:+0530 +TZOFFSETTO:+0530 +END:DAYLIGHT +END:VTIMEZONE +BEGIN:VEVENT +DTSTAMP:20030509T043439Z +DTSTART;TZID=\"Kolkata, Chennai, Mumbai, New Delhi\":20030509T103000 +SUMMARY:On-Site Interview +UID:040000008200E00074C5B7101A82E0080000000080B6DE661216C301000000000000000 + 010000000DB823520692542408ED02D7023F9DFF9 +ATTENDEE;ROLE=REQ-PARTICIPANT;PARTSTAT=NEEDS-ACTION;RSVP=TRUE;CN=\"Xxxxx + xxx Xxxxxxxxxxxx\":MAILTO:xxxxxxxx@xxxxxxx.com +ATTENDEE;ROLE=REQ-PARTICIPANT;PARTSTAT=NEEDS-ACTION;RSVP=TRUE;CN=\"Yyyyyyy Y + yyyy\":MAILTO:yyyyyyy@yyyyyyy.com +ATTENDEE;ROLE=REQ-PARTICIPANT;PARTSTAT=NEEDS-ACTION;RSVP=TRUE;CN=\"Zzzz Zzzz + zz\":MAILTO:zzzzzz@zzzzzzz.com +ORGANIZER;CN=\"Aaaaaa Aaaaa\":MAILTO:aaaaaaa@aaaaaaa.com +LOCATION:Cccc +DTEND;TZID=\"Kolkata, Chennai, Mumbai, New Delhi\":20030509T153000 +DESCRIPTION:10:30am - Blah +SEQUENCE:0 +PRIORITY:5 +CLASS: +CREATED:20030509T043439Z +LAST-MODIFIED:20030509T043459Z +STATUS:CONFIRMED +TRANSP:OPAQUE +X-MICROSOFT-CDO-BUSYSTATUS:BUSY +X-MICROSOFT-CDO-INSTTYPE:0 +X-MICROSOFT-CDO-INTENDEDSTATUS:BUSY +X-MICROSOFT-CDO-ALLDAYEVENT:FALSE +X-MICROSOFT-CDO-IMPORTANCE:1 +X-MICROSOFT-CDO-OWNERAPPTID:126441427 +BEGIN:VALARM +ACTION:DISPLAY +DESCRIPTION:REMINDER +TRIGGER;RELATED=START:-PT00H15M00S +END:VALARM +END:VEVENT +END:VCALENDAR" + nil + "&9/5/2003 07:00-12:00 On-Site Interview + Desc: 10:30am - Blah + Location: Cccc + Organizer: MAILTO:aaaaaaa@aaaaaaa.com + Status: CONFIRMED + UID: 040000008200E00074C5B7101A82E0080000000080B6DE661216C301000000000000000010000000DB823520692542408ED02D7023F9DFF9 +" + "&5/9/2003 07:00-12:00 On-Site Interview + Desc: 10:30am - Blah + Location: Cccc + Organizer: MAILTO:aaaaaaa@aaaaaaa.com + Status: CONFIRMED + UID: 040000008200E00074C5B7101A82E0080000000080B6DE661216C301000000000000000010000000DB823520692542408ED02D7023F9DFF9 +") + + ;; created with http://apps.marudot.com/ical/ + (icalendar-tests--test-import + "BEGIN:VCALENDAR +VERSION:2.0 +PRODID:-//www.marudot.com//iCal Event Maker +X-WR-CALNAME:Test +CALSCALE:GREGORIAN +BEGIN:VTIMEZONE +TZID:Asia/Tehran +TZURL:http://tzurl.org/zoneinfo-outlook/Asia/Tehran +X-LIC-LOCATION:Asia/Tehran +BEGIN:STANDARD +TZOFFSETFROM:+0330 +TZOFFSETTO:+0330 +TZNAME:IRST +DTSTART:19700101T000000 +END:STANDARD +END:VTIMEZONE +BEGIN:VEVENT +DTSTAMP:20141116T171439Z +UID:20141116T171439Z-678877132@marudot.com +DTSTART;TZID=\"Asia/Tehran\":20141116T070000 +DTEND;TZID=\"Asia/Tehran\":20141116T080000 +SUMMARY:NoDST +DESCRIPTION:Test event from timezone without DST +LOCATION:Everywhere +END:VEVENT +END:VCALENDAR" + nil + "&16/11/2014 04:30-05:30 NoDST + Desc: Test event from timezone without DST + Location: Everywhere + UID: 20141116T171439Z-678877132@marudot.com +" + "&11/16/2014 04:30-05:30 NoDST + Desc: Test event from timezone without DST + Location: Everywhere + UID: 20141116T171439Z-678877132@marudot.com +") + + + ;; 2003-06-18 a + (icalendar-tests--test-import + "DTSTAMP:20030618T195512Z +DTSTART;TZID=\"Mountain Time (US & Canada)\":20030623T110000 +SUMMARY:Dress Rehearsal for XXXX-XXXX +UID:040000008200E00074C5B7101A82E00800000000608AA7DA9835C301000000000000000 + 0100000007C3A6D65EE726E40B7F3D69A23BD567E +ATTENDEE;ROLE=REQ-PARTICIPANT;PARTSTAT=NEEDS-ACTION;RSVP=TRUE;CN=\"AAAAA,AAA + AA (A-AAAAAAA,ex1)\":MAILTO:aaaaa_aaaaa@aaaaa.com +ORGANIZER;CN=\"ABCD,TECHTRAINING + (A-Americas,exgen1)\":MAILTO:xxx@xxxxx.com +LOCATION:555 or TN 555-5555 ID 5555 & NochWas (see below) +DTEND;TZID=\"Mountain Time (US & Canada)\":20030623T120000 +DESCRIPTION:753 Zeichen hier radiert +SEQUENCE:0 +PRIORITY:5 +CLASS: +CREATED:20030618T195518Z +LAST-MODIFIED:20030618T195527Z +STATUS:CONFIRMED +TRANSP:OPAQUE +X-MICROSOFT-CDO-BUSYSTATUS:BUSY +X-MICROSOFT-CDO-INSTTYPE:0 +X-MICROSOFT-CDO-INTENDEDSTATUS:BUSY +X-MICROSOFT-CDO-ALLDAYEVENT:FALSE +X-MICROSOFT-CDO-IMPORTANCE:1 +X-MICROSOFT-CDO-OWNERAPPTID:1022519251 +BEGIN:VALARM +ACTION:DISPLAY +DESCRIPTION:REMINDER +TRIGGER;RELATED=START:-PT00H15M00S +END:VALARM" + nil + "&23/6/2003 11:00-12:00 Dress Rehearsal for XXXX-XXXX + Desc: 753 Zeichen hier radiert + Location: 555 or TN 555-5555 ID 5555 & NochWas (see below) + Organizer: MAILTO:xxx@xxxxx.com + Status: CONFIRMED + UID: 040000008200E00074C5B7101A82E00800000000608AA7DA9835C3010000000000000000100000007C3A6D65EE726E40B7F3D69A23BD567E +" + "&6/23/2003 11:00-12:00 Dress Rehearsal for XXXX-XXXX + Desc: 753 Zeichen hier radiert + Location: 555 or TN 555-5555 ID 5555 & NochWas (see below) + Organizer: MAILTO:xxx@xxxxx.com + Status: CONFIRMED + UID: 040000008200E00074C5B7101A82E00800000000608AA7DA9835C3010000000000000000100000007C3A6D65EE726E40B7F3D69A23BD567E +") + ;; 2003-06-18 b -- uses timezone + (icalendar-tests--test-import + "BEGIN:VCALENDAR +METHOD:REQUEST +PRODID:Microsoft CDO for Microsoft Exchange +VERSION:2.0 +BEGIN:VTIMEZONE +TZID:Mountain Time (US & Canada) +X-MICROSOFT-CDO-TZID:12 +BEGIN:STANDARD +DTSTART:16010101T020000 +TZOFFSETFROM:-0600 +TZOFFSETTO:-0700 +RRULE:FREQ=YEARLY;WKST=MO;INTERVAL=1;BYMONTH=10;BYDAY=-1SU +END:STANDARD +BEGIN:DAYLIGHT +DTSTART:16010101T020000 +TZOFFSETFROM:-0700 +TZOFFSETTO:-0600 +RRULE:FREQ=YEARLY;WKST=MO;INTERVAL=1;BYMONTH=4;BYDAY=1SU +END:DAYLIGHT +END:VTIMEZONE +BEGIN:VEVENT +DTSTAMP:20030618T230323Z +DTSTART;TZID=\"Mountain Time (US & Canada)\":20030623T090000 +SUMMARY:Updated: Dress Rehearsal for ABC01-15 +UID:040000008200E00074C5B7101A82E00800000000608AA7DA9835C301000000000000000 + 0100000007C3A6D65EE726E40B7F3D69A23BD567E +ATTENDEE;ROLE=REQ-PARTICIPANT;PARTSTAT=NEEDS-ACTION;X-REPLYTIME=20030618T20 + 0700Z;RSVP=TRUE;CN=\"AAAAA,AAAAAA +\(A-AAAAAAA,ex1)\":MAILTO:aaaaaa_aaaaa@aaaaa + .com +ORGANIZER;CN=\"ABCD,TECHTRAINING +\(A-Americas,exgen1)\":MAILTO:bbb@bbbbb.com +LOCATION:123 or TN 123-1234 ID abcd & SonstWo (see below) +DTEND;TZID=\"Mountain Time (US & Canada)\":20030623T100000 +DESCRIPTION:Viele Zeichen standen hier früher +SEQUENCE:0 +PRIORITY:5 +CLASS: +CREATED:20030618T230326Z +LAST-MODIFIED:20030618T230335Z +STATUS:CONFIRMED +TRANSP:OPAQUE +X-MICROSOFT-CDO-BUSYSTATUS:BUSY +X-MICROSOFT-CDO-INSTTYPE:0 +X-MICROSOFT-CDO-INTENDEDSTATUS:BUSY +X-MICROSOFT-CDO-ALLDAYEVENT:FALSE +X-MICROSOFT-CDO-IMPORTANCE:1 +X-MICROSOFT-CDO-OWNERAPPTID:1022519251 +BEGIN:VALARM +ACTION:DISPLAY +DESCRIPTION:REMINDER +TRIGGER;RELATED=START:-PT00H15M00S +END:VALARM +END:VEVENT +END:VCALENDAR" + nil + "&23/6/2003 17:00-18:00 Updated: Dress Rehearsal for ABC01-15 + Desc: Viele Zeichen standen hier früher + Location: 123 or TN 123-1234 ID abcd & SonstWo (see below) + Organizer: MAILTO:bbb@bbbbb.com + Status: CONFIRMED + UID: 040000008200E00074C5B7101A82E00800000000608AA7DA9835C3010000000000000000100000007C3A6D65EE726E40B7F3D69A23BD567E +" + "&6/23/2003 17:00-18:00 Updated: Dress Rehearsal for ABC01-15 + Desc: Viele Zeichen standen hier früher + Location: 123 or TN 123-1234 ID abcd & SonstWo (see below) + Organizer: MAILTO:bbb@bbbbb.com + Status: CONFIRMED + UID: 040000008200E00074C5B7101A82E00800000000608AA7DA9835C3010000000000000000100000007C3A6D65EE726E40B7F3D69A23BD567E +") + ;; export 2004-10-28 block entries + (icalendar-tests--test-export + nil + nil + "-*- mode: text; fill-column: 256;-*- + +>>> block entries: + +%%(diary-block 11 8 2004 11 10 2004) Nov 8-10 aa +" + "DTSTART;VALUE=DATE:20041108 +DTEND;VALUE=DATE:20041111 +SUMMARY:Nov 8-10 aa") + + (icalendar-tests--test-export + nil + nil + "%%(diary-block 12 13 2004 12 17 2004) Dec 13-17 bb" + "DTSTART;VALUE=DATE:20041213 +DTEND;VALUE=DATE:20041218 +SUMMARY:Dec 13-17 bb") + + (icalendar-tests--test-export + nil + nil + "%%(diary-block 2 3 2005 2 4 2005) Feb 3-4 cc" + "DTSTART;VALUE=DATE:20050203 +DTEND;VALUE=DATE:20050205 +SUMMARY:Feb 3-4 cc") + + (icalendar-tests--test-export + nil + nil + "%%(diary-block 4 24 2005 4 29 2005) April 24-29 dd" + "DTSTART;VALUE=DATE:20050424 +DTEND;VALUE=DATE:20050430 +SUMMARY:April 24-29 dd +") + (icalendar-tests--test-export + nil + nil + "%%(diary-block 5 30 2005 6 1 2005) may 30 - June 1: ee" + "DTSTART;VALUE=DATE:20050530 +DTEND;VALUE=DATE:20050602 +SUMMARY:may 30 - June 1: ee") + + (icalendar-tests--test-export + nil + nil + "%%(diary-block 6 6 2005 6 8 2005) ff" + "DTSTART;VALUE=DATE:20050606 +DTEND;VALUE=DATE:20050609 +SUMMARY:ff") + + ;; export 2004-10-28 anniversary entries + (icalendar-tests--test-export + nil + nil + " +>>> anniversaries: + +%%(diary-anniversary 3 28 1991) aa birthday (%d years old)" + "DTSTART;VALUE=DATE:19910328 +DTEND;VALUE=DATE:19910329 +RRULE:FREQ=YEARLY;INTERVAL=1;BYMONTH=03;BYMONTHDAY=28 +SUMMARY:aa birthday (%d years old) +") + + (icalendar-tests--test-export + nil + nil + "%%(diary-anniversary 5 17 1957) bb birthday (%d years old)" + "DTSTART;VALUE=DATE:19570517 +DTEND;VALUE=DATE:19570518 +RRULE:FREQ=YEARLY;INTERVAL=1;BYMONTH=05;BYMONTHDAY=17 +SUMMARY:bb birthday (%d years old)") + + (icalendar-tests--test-export + nil + nil + "%%(diary-anniversary 6 8 1997) cc birthday (%d years old)" + "DTSTART;VALUE=DATE:19970608 +DTEND;VALUE=DATE:19970609 +RRULE:FREQ=YEARLY;INTERVAL=1;BYMONTH=06;BYMONTHDAY=08 +SUMMARY:cc birthday (%d years old)") + + (icalendar-tests--test-export + nil + nil + "%%(diary-anniversary 7 22 1983) dd (%d years ago...!)" + "DTSTART;VALUE=DATE:19830722 +DTEND;VALUE=DATE:19830723 +RRULE:FREQ=YEARLY;INTERVAL=1;BYMONTH=07;BYMONTHDAY=22 +SUMMARY:dd (%d years ago...!)") + + (icalendar-tests--test-export + nil + nil + "%%(diary-anniversary 8 1 1988) ee birthday (%d years old)" + "DTSTART;VALUE=DATE:19880801 +DTEND;VALUE=DATE:19880802 +RRULE:FREQ=YEARLY;INTERVAL=1;BYMONTH=08;BYMONTHDAY=01 +SUMMARY:ee birthday (%d years old)") + + (icalendar-tests--test-export + nil + nil + "%%(diary-anniversary 9 21 1957) ff birthday (%d years old)" + "DTSTART;VALUE=DATE:19570921 +DTEND;VALUE=DATE:19570922 +RRULE:FREQ=YEARLY;INTERVAL=1;BYMONTH=09;BYMONTHDAY=21 +SUMMARY:ff birthday (%d years old)") + + + ;; FIXME! + + ;; export 2004-10-28 monthly, weekly entries + + ;; (icalendar-tests--test-export + ;; nil + ;; " + ;; >>> ------------ monthly: + + ;; */27/* 10:00 blah blah" + ;; "xxx") + + (icalendar-tests--test-export + nil + nil + ">>> ------------ my week: + +Monday 13:00 MAC" + "DTSTART;VALUE=DATE-TIME:20000103T130000 +DTEND;VALUE=DATE-TIME:20000103T140000 +RRULE:FREQ=WEEKLY;INTERVAL=1;BYDAY=MO +SUMMARY:MAC") + + (icalendar-tests--test-export + nil + nil + "Monday 15:00 a1" + "DTSTART;VALUE=DATE-TIME:20000103T150000 +DTEND;VALUE=DATE-TIME:20000103T160000 +RRULE:FREQ=WEEKLY;INTERVAL=1;BYDAY=MO +SUMMARY:a1") + + + (icalendar-tests--test-export + nil + nil + "Monday 16:00-17:00 a2" + "DTSTART;VALUE=DATE-TIME:20000103T160000 +DTEND;VALUE=DATE-TIME:20000103T170000 +RRULE:FREQ=WEEKLY;INTERVAL=1;BYDAY=MO +SUMMARY:a2") + + (icalendar-tests--test-export + nil + nil + "Tuesday 11:30-13:00 a3" + "DTSTART;VALUE=DATE-TIME:20000104T113000 +DTEND;VALUE=DATE-TIME:20000104T130000 +RRULE:FREQ=WEEKLY;INTERVAL=1;BYDAY=TU +SUMMARY:a3") + + (icalendar-tests--test-export + nil + nil + "Tuesday 15:00 a4" + "DTSTART;VALUE=DATE-TIME:20000104T150000 +DTEND;VALUE=DATE-TIME:20000104T160000 +RRULE:FREQ=WEEKLY;INTERVAL=1;BYDAY=TU +SUMMARY:a4") + + (icalendar-tests--test-export + nil + nil + "Wednesday 13:00 a5" + "DTSTART;VALUE=DATE-TIME:20000105T130000 +DTEND;VALUE=DATE-TIME:20000105T140000 +RRULE:FREQ=WEEKLY;INTERVAL=1;BYDAY=WE +SUMMARY:a5") + + (icalendar-tests--test-export + nil + nil + "Wednesday 11:30-13:30 a6" + "DTSTART;VALUE=DATE-TIME:20000105T113000 +DTEND;VALUE=DATE-TIME:20000105T133000 +RRULE:FREQ=WEEKLY;INTERVAL=1;BYDAY=WE +SUMMARY:a6") + + (icalendar-tests--test-export + nil + nil + "Wednesday 15:00 s1" + "DTSTART;VALUE=DATE-TIME:20000105T150000 +DTEND;VALUE=DATE-TIME:20000105T160000 +RRULE:FREQ=WEEKLY;INTERVAL=1;BYDAY=WE +SUMMARY:s1") + + + ;; export 2004-10-28 regular entries + (icalendar-tests--test-export + nil + nil + " +>>> regular diary entries: + +Oct 12 2004, 14:00 Tue: [2004-10-12] q1" + "DTSTART;VALUE=DATE-TIME:20041012T140000 +DTEND;VALUE=DATE-TIME:20041012T150000 +SUMMARY:Tue: [2004-10-12] q1") + + ;; 2004-11-19 + (icalendar-tests--test-import + "BEGIN:VCALENDAR +VERSION + :2.0 +PRODID + :-//Mozilla.org/NONSGML Mozilla Calendar V1.0//EN +BEGIN:VEVENT +SUMMARY + :Jjjjj & Wwwww +STATUS + :TENTATIVE +CLASS + :PRIVATE +X-MOZILLA-ALARM-DEFAULT-LENGTH + :0 +DTSTART + :20041123T140000 +DTEND + :20041123T143000 +DTSTAMP + :20041118T013430Z +LAST-MODIFIED + :20041118T013640Z +END:VEVENT +BEGIN:VEVENT +SUMMARY + :BB Aaaaaaaa Bbbbb +STATUS + :TENTATIVE +CLASS + :PRIVATE +X-MOZILLA-ALARM-DEFAULT-LENGTH + :0 +DTSTART + :20041123T144500 +DTEND + :20041123T154500 +DTSTAMP + :20041118T013641Z +END:VEVENT +BEGIN:VEVENT +SUMMARY + :Hhhhhhhh +STATUS + :TENTATIVE +CLASS + :PRIVATE +X-MOZILLA-ALARM-DEFAULT-LENGTH + :0 +DTSTART + :20041123T110000 +DTEND + :20041123T120000 +DTSTAMP + :20041118T013831Z +END:VEVENT +BEGIN:VEVENT +SUMMARY + :MMM Aaaaaaaaa +STATUS + :TENTATIVE +CLASS + :PRIVATE +X-MOZILLA-ALARM-DEFAULT-LENGTH + :0 +X-MOZILLA-RECUR-DEFAULT-INTERVAL + :2 +RRULE + :FREQ=WEEKLY;INTERVAL=2;BYDAY=FR +DTSTART + :20041112T140000 +DTEND + :20041112T183000 +DTSTAMP + :20041118T014117Z +END:VEVENT +BEGIN:VEVENT +SUMMARY + :Rrrr/Cccccc ii Aaaaaaaa +DESCRIPTION + :Vvvvv Rrrr aaa Cccccc +STATUS + :TENTATIVE +CLASS + :PRIVATE +X-MOZILLA-ALARM-DEFAULT-LENGTH + :0 +DTSTART + ;VALUE=DATE + :20041119 +DTEND + ;VALUE=DATE + :20041120 +DTSTAMP + :20041118T013107Z +LAST-MODIFIED + :20041118T014203Z +END:VEVENT +BEGIN:VEVENT +SUMMARY + :Wwww aa hhhh +STATUS + :TENTATIVE +CLASS + :PRIVATE +X-MOZILLA-ALARM-DEFAULT-LENGTH + :0 +RRULE + :FREQ=WEEKLY;INTERVAL=1;BYDAY=MO +DTSTART + ;VALUE=DATE + :20041101 +DTEND + ;VALUE=DATE + :20041102 +DTSTAMP + :20041118T014045Z +LAST-MODIFIED + :20041118T023846Z +END:VEVENT +END:VCALENDAR +" + nil + "&23/11/2004 14:00-14:30 Jjjjj & Wwwww + Status: TENTATIVE + Class: PRIVATE +&23/11/2004 14:45-15:45 BB Aaaaaaaa Bbbbb + Status: TENTATIVE + Class: PRIVATE +&23/11/2004 11:00-12:00 Hhhhhhhh + Status: TENTATIVE + Class: PRIVATE +&%%(and (diary-cyclic 14 12 11 2004)) 14:00-18:30 MMM Aaaaaaaaa + Status: TENTATIVE + Class: PRIVATE +&%%(and (diary-block 19 11 2004 19 11 2004)) Rrrr/Cccccc ii Aaaaaaaa + Desc: Vvvvv Rrrr aaa Cccccc + Status: TENTATIVE + Class: PRIVATE +&%%(and (diary-cyclic 7 1 11 2004)) Wwww aa hhhh + Status: TENTATIVE + Class: PRIVATE +" + "&11/23/2004 14:00-14:30 Jjjjj & Wwwww + Status: TENTATIVE + Class: PRIVATE +&11/23/2004 14:45-15:45 BB Aaaaaaaa Bbbbb + Status: TENTATIVE + Class: PRIVATE +&11/23/2004 11:00-12:00 Hhhhhhhh + Status: TENTATIVE + Class: PRIVATE +&%%(and (diary-cyclic 14 11 12 2004)) 14:00-18:30 MMM Aaaaaaaaa + Status: TENTATIVE + Class: PRIVATE +&%%(and (diary-block 11 19 2004 11 19 2004)) Rrrr/Cccccc ii Aaaaaaaa + Desc: Vvvvv Rrrr aaa Cccccc + Status: TENTATIVE + Class: PRIVATE +&%%(and (diary-cyclic 7 11 1 2004)) Wwww aa hhhh + Status: TENTATIVE + Class: PRIVATE +") + + ;; 2004-09-09 pg + (icalendar-tests--test-export + "%%(diary-block 1 1 2004 4 1 2004) Urlaub" + nil + nil + "DTSTART;VALUE=DATE:20040101 +DTEND;VALUE=DATE:20040105 +SUMMARY:Urlaub") + + ;; 2004-10-25 pg + (icalendar-tests--test-export + nil + "5 11 2004 Bla Fasel" + nil + "DTSTART;VALUE=DATE:20041105 +DTEND;VALUE=DATE:20041106 +SUMMARY:Bla Fasel") + + ;; 2004-10-30 pg + (icalendar-tests--test-export + nil + "2 Nov 2004 15:00-16:30 Zahnarzt" + nil + "DTSTART;VALUE=DATE-TIME:20041102T150000 +DTEND;VALUE=DATE-TIME:20041102T163000 +SUMMARY:Zahnarzt") + + ;; 2005-02-07 lt + (icalendar-tests--test-import + "UID + :b60d398e-1dd1-11b2-a159-cf8cb05139f4 +SUMMARY + :Waitangi Day +DESCRIPTION + :abcdef +CATEGORIES + :Public Holiday +STATUS + :CONFIRMED +CLASS + :PRIVATE +DTSTART + ;VALUE=DATE + :20050206 +DTEND + ;VALUE=DATE + :20050207 +DTSTAMP + :20050128T011209Z" + nil + "&%%(and (diary-block 6 2 2005 6 2 2005)) Waitangi Day + Desc: abcdef + Status: CONFIRMED + Class: PRIVATE + UID: b60d398e-1dd1-11b2-a159-cf8cb05139f4 +" + "&%%(and (diary-block 2 6 2005 2 6 2005)) Waitangi Day + Desc: abcdef + Status: CONFIRMED + Class: PRIVATE + UID: b60d398e-1dd1-11b2-a159-cf8cb05139f4 +") + + ;; 2005-03-01 lt + (icalendar-tests--test-import + "DTSTART;VALUE=DATE:20050217 +SUMMARY:Hhhhhh Aaaaa ii Aaaaaaaa +UID:6AFA7558-6994-11D9-8A3A-000A95A0E830-RID +DTSTAMP:20050118T210335Z +DURATION:P7D" + nil + "&%%(and (diary-block 17 2 2005 23 2 2005)) Hhhhhh Aaaaa ii Aaaaaaaa + UID: 6AFA7558-6994-11D9-8A3A-000A95A0E830-RID\n" + "&%%(and (diary-block 2 17 2005 2 23 2005)) Hhhhhh Aaaaa ii Aaaaaaaa + UID: 6AFA7558-6994-11D9-8A3A-000A95A0E830-RID\n") + + ;; 2005-03-23 lt + (icalendar-tests--test-export + nil + "&%%(diary-cyclic 7 8 2 2005) 16:00-16:45 [WORK] Pppp" + nil + "DTSTART;VALUE=DATE-TIME:20050208T160000 +DTEND;VALUE=DATE-TIME:20050208T164500 +RRULE:FREQ=DAILY;INTERVAL=7 +SUMMARY:[WORK] Pppp +") + + ;; 2005-05-27 eu + (icalendar-tests--test-export + nil + nil + ;; FIXME: colon not allowed! + ;;"Nov 1: NNN Wwwwwwww Wwwww - Aaaaaa Pppppppp rrrrrr ddd oo Nnnnnnnn 30" + "Nov 1 NNN Wwwwwwww Wwwww - Aaaaaa Pppppppp rrrrrr ddd oo Nnnnnnnn 30" + "DTSTART;VALUE=DATE:19001101 +DTEND;VALUE=DATE:19001102 +RRULE:FREQ=YEARLY;INTERVAL=1;BYMONTH=11;BYMONTHDAY=1 +SUMMARY:NNN Wwwwwwww Wwwww - Aaaaaa Pppppppp rrrrrr ddd oo Nnnnnnnn 30 +") + + ;; bug#11473 + (icalendar-tests--test-import + "BEGIN:VCALENDAR +METHOD:REQUEST +PRODID:Microsoft Exchange Server 2007 +VERSION:2.0 +BEGIN:VTIMEZONE +TZID:(UTC+01:00) Amsterdam, Berlin, Bern, Rome, Stockholm, Vienna +BEGIN:STANDARD +DTSTART:16010101T030000 +TZOFFSETFROM:+0200 +TZOFFSETTO:+0100 +RRULE:FREQ=YEARLY;INTERVAL=1;BYDAY=-1SU;BYMONTH=10 +END:STANDARD +BEGIN:DAYLIGHT +DTSTART:16010101T020000 +TZOFFSETFROM:+0100 +TZOFFSETTO:+0200 +RRULE:FREQ=YEARLY;INTERVAL=1;BYDAY=-1SU;BYMONTH=3 +END:DAYLIGHT +END:VTIMEZONE +BEGIN:VEVENT +ORGANIZER;CN=\"A. Luser\":MAILTO:a.luser@foo.com +ATTENDEE;ROLE=REQ-PARTICIPANT;PARTSTAT=NEEDS-ACTION;RSVP=TRUE;CN=\"Luser, Oth + er\":MAILTO:other.luser@foo.com +DESCRIPTION;LANGUAGE=en-US:\nWhassup?\n\n +SUMMARY;LANGUAGE=en-US:Query +DTSTART;TZID=\"(UTC+01:00) Amsterdam, Berlin, Bern, Rome, Stockholm, Vienna\" + :20120515T150000 +DTEND;TZID=\"(UTC+01:00) Amsterdam, Berlin, Bern, Rome, Stockholm, Vienna\":2 + 0120515T153000 +UID:040000008200E00074C5B7101A82E0080000000020FFAED0CFEFCC01000000000000000 + 010000000575268034ECDB649A15349B1BF240F15 +RECURRENCE-ID;TZID=\"(UTC+01:00) Amsterdam, Berlin, Bern, Rome, Stockholm, V + ienna\":20120515T170000 +CLASS:PUBLIC +PRIORITY:5 +DTSTAMP:20120514T153645Z +TRANSP:OPAQUE +STATUS:CONFIRMED +SEQUENCE:15 +LOCATION;LANGUAGE=en-US:phone +X-MICROSOFT-CDO-APPT-SEQUENCE:15 +X-MICROSOFT-CDO-OWNERAPPTID:1907632092 +X-MICROSOFT-CDO-BUSYSTATUS:TENTATIVE +X-MICROSOFT-CDO-INTENDEDSTATUS:BUSY +X-MICROSOFT-CDO-ALLDAYEVENT:FALSE +X-MICROSOFT-CDO-IMPORTANCE:1 +X-MICROSOFT-CDO-INSTTYPE:3 +BEGIN:VALARM +ACTION:DISPLAY +DESCRIPTION:REMINDER +TRIGGER;RELATED=START:-PT15M +END:VALARM +END:VEVENT +END:VCALENDAR" + nil + "&15/5/2012 15:00-15:30 Query + Location: phone + Organizer: MAILTO:a.luser@foo.com + Status: CONFIRMED + Class: PUBLIC + UID: 040000008200E00074C5B7101A82E0080000000020FFAED0CFEFCC01000000000000000010000000575268034ECDB649A15349B1BF240F15 +" nil) + + ;; 2015-12-05, mixed line endings and empty lines, see Bug#22092. + (icalendar-tests--test-import + "BEGIN:VCALENDAR\r +PRODID:-//www.norwegian.no//iCalendar MIMEDIR//EN\r +VERSION:2.0\r +METHOD:REQUEST\r +BEGIN:VEVENT\r +UID:RFCALITEM1\r +SEQUENCE:1512040950\r +DTSTAMP:20141204T095043Z\r +ORGANIZER:noreply@norwegian.no\r +DTSTART:20141208T173000Z\r + +DTEND:20141208T215500Z\r + +LOCATION:Stavanger-Sola\r + +DESCRIPTION:Fly med Norwegian, reservasjon. Fra Stavanger til Tromsø 8. des 2014 18:30, DY545Fly med Norwegian, reservasjon . Fra Stavanger til Tromsø 8. des 2014 21:00, DY390\r + +X-ALT-DESC;FMTTYPE=text/html:<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 3.2//EN\"><html><head><META NAME=\"Generator\" CONTENT=\"MS Exchange Server version 08.00.0681.000\"><title></title></head><body><b><font face=\"Calibri\" size=\"3\">Reisereferanse</p></body></html> +SUMMARY:Norwegian til Tromsoe-Langnes -\r + +CATEGORIES:Appointment\r + + +PRIORITY:5\r + +CLASS:PUBLIC\r + +TRANSP:OPAQUE\r +END:VEVENT\r +END:VCALENDAR +" +"&2014/12/8 18:30-22:55 Norwegian til Tromsoe-Langnes - + Desc: Fly med Norwegian, reservasjon. Fra Stavanger til Tromsø 8. des 2014 18:30, DY545Fly med Norwegian, reservasjon . Fra Stavanger til Tromsø 8. des 2014 21:00, DY390 + Location: Stavanger-Sola + Organizer: noreply@norwegian.no + Class: PUBLIC + UID: RFCALITEM1 +" +"&8/12/2014 18:30-22:55 Norwegian til Tromsoe-Langnes - + Desc: Fly med Norwegian, reservasjon. Fra Stavanger til Tromsø 8. des 2014 18:30, DY545Fly med Norwegian, reservasjon . Fra Stavanger til Tromsø 8. des 2014 21:00, DY390 + Location: Stavanger-Sola + Organizer: noreply@norwegian.no + Class: PUBLIC + UID: RFCALITEM1 +" +"&12/8/2014 18:30-22:55 Norwegian til Tromsoe-Langnes - + Desc: Fly med Norwegian, reservasjon. Fra Stavanger til Tromsø 8. des 2014 18:30, DY545Fly med Norwegian, reservasjon . Fra Stavanger til Tromsø 8. des 2014 21:00, DY390 + Location: Stavanger-Sola + Organizer: noreply@norwegian.no + Class: PUBLIC + UID: RFCALITEM1 +" +) + ) + +(provide 'icalendar-tests) +;;; icalendar-tests.el ends here diff --git a/test/lisp/character-fold-tests.el b/test/lisp/character-fold-tests.el new file mode 100644 index 00000000000..c611217712e --- /dev/null +++ b/test/lisp/character-fold-tests.el @@ -0,0 +1,124 @@ +;;; character-fold-tests.el --- Tests for character-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 'character-fold) + +(defun character-fold--random-word (n) + (mapconcat (lambda (_) (string (+ 9 (random 117)))) + (make-list n nil) "")) + +(defun character-fold--test-search-with-contents (contents string) + (with-temp-buffer + (insert contents) + (goto-char (point-min)) + (should (search-forward-regexp (character-fold-to-regexp string) nil 'noerror)) + (goto-char (point-min)) + (should (character-fold-search-forward string nil 'noerror)) + (should (character-fold-search-backward string nil 'noerror)))) + + +(ert-deftest character-fold--test-consistency () + (dotimes (n 30) + (let ((w (character-fold--random-word n))) + ;; A folded string should always match the original string. + (character-fold--test-search-with-contents w w)))) + +(ert-deftest character-fold--test-lax-whitespace () + (dotimes (n 40) + (let ((w1 (character-fold--random-word n)) + (w2 (character-fold--random-word n)) + (search-spaces-regexp "\\s-+")) + (character-fold--test-search-with-contents + (concat w1 "\s\n\s\t\f\t\n\r\t" w2) + (concat w1 " " w2)) + (character-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 character-fold--test-match-exactly (string &rest strings-to-match) + (let ((re (concat "\\`" (character-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 character-fold--test-some-defaults () + (dolist (it '(("ffl" . "ffl") ("ffi" . "ffi") + ("fi" . "fi") ("ff" . "ff") + ("ä" . "ä"))) + (character-fold--test-search-with-contents (cdr it) (car it)) + (let ((multi (char-table-extra-slot character-fold-table 0)) + (character-fold-table (make-char-table 'character-fold-table))) + (set-char-table-extra-slot character-fold-table 0 multi) + (character-fold--test-match-exactly (car it) (cdr it))))) + +(ert-deftest character-fold--test-fold-to-regexp () + (let ((character-fold-table (make-char-table 'character-fold-table)) + (multi (make-char-table 'character-fold-table))) + (set-char-table-extra-slot character-fold-table 0 multi) + (aset character-fold-table ?a "xx") + (aset character-fold-table ?1 "44") + (aset character-fold-table ?\s "-!-") + (character-fold--test-match-exactly "a1a1" "xx44xx44") + (character-fold--test-match-exactly "a1 a 1" "xx44-!--!-xx-!-44") + (aset multi ?a '(("1" . "99") + ("2" . "88") + ("12" . "77"))) + (character-fold--test-match-exactly "a" "xx") + (character-fold--test-match-exactly "a1" "xx44" "99") + (character-fold--test-match-exactly "a12" "77" "xx442" "992") + (character-fold--test-match-exactly "a2" "88") + (aset multi ?1 '(("2" . "yy"))) + (character-fold--test-match-exactly "a1" "xx44" "99") + (character-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 + ;; (character-fold--test-match-exactly "a12" "xxyy") + )) + +(ert-deftest character-fold--speed-test () + (dolist (string (append '("tty-set-up-initial-frame-face" + "tty-set-up-initial-frame-face-frame-faceframe-faceframe-faceframe-face") + (mapcar #'character-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) + (character-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 (character-fold-search-forward (concat string "c") nil 'noerror)) + ;; Ensure it took less than a second. + (should (< (- (time-to-seconds (current-time)) + time) + 1)))))) + +(provide 'character-fold-tests) +;;; character-fold-tests.el ends here diff --git a/test/lisp/comint-tests.el b/test/lisp/comint-tests.el new file mode 100644 index 00000000000..576be238408 --- /dev/null +++ b/test/lisp/comint-tests.el @@ -0,0 +1,54 @@ +;;; comint-testsuite.el + +;; Copyright (C) 2010-2016 Free Software Foundation, Inc. + +;; 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: + +;; Tests for comint and related modes. + +;;; Code: + +(require 'comint) +(require 'ert) + +(defvar comint-testsuite-password-strings + '("foo@example.net's password: " ; ssh + "Password for foo@example.org: " ; kinit + "Please enter the password for foo@example.org: " ; kinit + "Kerberos password for devnull/root <at> GNU.ORG: " ; ksu + "Enter passphrase: " ; ssh-add + "Enter passphrase (empty for no passphrase): " ; ssh-keygen + "Enter same passphrase again: " ; ssh-keygen + "Passphrase for key root@GNU.ORG: " ; plink + "[sudo] password for user:" ; Ubuntu sudo + "Password (again):" + "Enter password:" + "Mot de Passe:" ; localized + "Passwort:") ; localized + "List of strings that should match `comint-password-prompt-regexp'.") + +(ert-deftest comint-test-password-regexp () + "Test `comint-password-prompt-regexp' against common password strings." + (dolist (str comint-testsuite-password-strings) + (should (string-match comint-password-prompt-regexp str)))) + +;; Local Variables: +;; no-byte-compile: t +;; End: + +;;; comint-testsuite.el ends here diff --git a/test/lisp/descr-text-tests.el b/test/lisp/descr-text-tests.el new file mode 100644 index 00000000000..9e851c3a119 --- /dev/null +++ b/test/lisp/descr-text-tests.el @@ -0,0 +1,94 @@ +;;; descr-text-test.el --- ERT tests for descr-text.el -*- lexical-binding: t -*- + +;; Copyright (C) 2014, 2016 Free Software Foundation, Inc. + +;; Author: Michal Nazarewicz <mina86@mina86.com> + +;; 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: + +;; This package defines regression tests for the descr-text package. + +;;; Code: + +(require 'ert) +(require 'descr-text) + + +(ert-deftest descr-text-test-truncate () + "Tests describe-char-eldoc--truncate function." + (should (equal "" + (describe-char-eldoc--truncate " \t \n" 100))) + (should (equal "foo" + (describe-char-eldoc--truncate "foo" 1))) + (should (equal "foo..." + (describe-char-eldoc--truncate "foo wilma fred" 0))) + (should (equal "foo..." + (describe-char-eldoc--truncate + "foo wilma fred" (length "foo wilma")))) + (should (equal "foo wilma..." + (describe-char-eldoc--truncate + "foo wilma fred" (+ 3 (length "foo wilma"))))) + (should (equal "foo wilma..." + (describe-char-eldoc--truncate + "foo wilma fred" (1- (length "foo wilma fred"))))) + (should (equal "foo wilma fred" + (describe-char-eldoc--truncate + "foo wilma fred" (length "foo wilma fred")))) + (should (equal "foo wilma fred" + (describe-char-eldoc--truncate + " foo\t wilma \nfred\t " (length "foo wilma fred"))))) + +(ert-deftest descr-text-test-format-desc () + "Tests describe-char-eldoc--format function." + (should (equal "U+2026: Horizontal ellipsis (Po: Punctuation, Other)" + (describe-char-eldoc--format ?…))) + (should (equal "U+2026: Horizontal ellipsis (Punctuation, Other)" + (describe-char-eldoc--format ?… 51))) + (should (equal "U+2026: Horizontal ellipsis (Po)" + (describe-char-eldoc--format ?… 40))) + (should (equal "Horizontal ellipsis (Po)" + (describe-char-eldoc--format ?… 30))) + (should (equal "Horizontal ellipsis" + (describe-char-eldoc--format ?… 20))) + (should (equal "Horizontal..." + (describe-char-eldoc--format ?… 10)))) + +(ert-deftest descr-text-test-desc () + "Tests describe-char-eldoc function." + (with-temp-buffer + (insert "a…") + (goto-char (point-min)) + (should (eq ?a (following-char))) ; make sure we are where we think we are + ;; Function should return nil for an ASCII character. + (should (not (describe-char-eldoc))) + + (goto-char (1+ (point))) + (should (eq ?… (following-char))) + (let ((eldoc-echo-area-use-multiline-p t)) + ;; Function should return description of an Unicode character. + (should (equal "U+2026: Horizontal ellipsis (Po: Punctuation, Other)" + (describe-char-eldoc)))) + + (goto-char (point-max)) + ;; At the end of the buffer, function should return nil and not blow up. + (should (not (describe-char-eldoc))))) + + +(provide 'descr-text-test) + +;;; descr-text-test.el ends here diff --git a/test/lisp/dired-tests.el b/test/lisp/dired-tests.el new file mode 100644 index 00000000000..ff6c88f80e7 --- /dev/null +++ b/test/lisp/dired-tests.el @@ -0,0 +1,35 @@ +;;; dired-tests.el --- Test suite. -*- lexical-binding: t -*- + +;; Copyright (C) 2015 Free Software Foundation, Inc. + +;; 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/>. + +;;; Code: +(require 'ert) +(require 'dired) + + +(ert-deftest dired-autoload () + "Tests to see whether dired-x has been autoloaded" + (should + (fboundp 'dired-jump)) + (should + (autoloadp + (symbol-function + 'dired-jump)))) + +(provide 'dired-tests) +;; dired-tests.el ends here diff --git a/test/lisp/electric-tests.el b/test/lisp/electric-tests.el new file mode 100644 index 00000000000..107b2e79fb6 --- /dev/null +++ b/test/lisp/electric-tests.el @@ -0,0 +1,588 @@ +;;; electric-tests.el --- tests for electric.el + +;; Copyright (C) 2013-2016 Free Software Foundation, Inc. + +;; Author: João Távora <joaotavora@gmail.com> +;; Keywords: + +;; 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/>. + +;;; Commentary: + +;; Tests for Electric Pair mode. +;; TODO: Add tests for other Electric-* functionality + +;;; Code: +(require 'ert) +(require 'ert-x) +(require 'electric) +(require 'elec-pair) +(require 'cl-lib) + +(defun call-with-saved-electric-modes (fn) + (let ((saved-electric (if electric-pair-mode 1 -1)) + (saved-layout (if electric-layout-mode 1 -1)) + (saved-indent (if electric-indent-mode 1 -1))) + (electric-pair-mode -1) + (electric-layout-mode -1) + (electric-indent-mode -1) + (unwind-protect + (funcall fn) + (electric-pair-mode saved-electric) + (electric-indent-mode saved-indent) + (electric-layout-mode saved-layout)))) + +(defmacro save-electric-modes (&rest body) + (declare (indent defun) (debug t)) + `(call-with-saved-electric-modes #'(lambda () ,@body))) + +(defun electric-pair-test-for (fixture where char expected-string + expected-point mode bindings fixture-fn) + (with-temp-buffer + (funcall mode) + (insert fixture) + (save-electric-modes + (let ((last-command-event char) + (transient-mark-mode 'lambda)) + (goto-char where) + (funcall fixture-fn) + (cl-progv + (mapcar #'car bindings) + (mapcar #'cdr bindings) + (call-interactively (key-binding `[,last-command-event]))))) + (should (equal (buffer-substring-no-properties (point-min) (point-max)) + expected-string)) + (should (equal (point) + expected-point)))) + +(eval-when-compile + (defun electric-pair-define-test-form (name fixture + char + pos + expected-string + expected-point + skip-pair-string + prefix + suffix + extra-desc + mode + bindings + fixture-fn) + (let* ((expected-string-and-point + (if skip-pair-string + (with-temp-buffer + (cl-progv + ;; FIXME: avoid `eval' + (mapcar #'car (eval bindings)) + (mapcar #'cdr (eval bindings)) + (funcall mode) + (insert fixture) + (goto-char (1+ pos)) + (insert char) + (cond ((eq (aref skip-pair-string pos) + ?p) + (insert (cadr (electric-pair-syntax-info char))) + (backward-char 1)) + ((eq (aref skip-pair-string pos) + ?s) + (delete-char -1) + (forward-char 1))) + (list + (buffer-substring-no-properties (point-min) (point-max)) + (point)))) + (list expected-string expected-point))) + (expected-string (car expected-string-and-point)) + (expected-point (cadr expected-string-and-point)) + (fixture (format "%s%s%s" prefix fixture suffix)) + (expected-string (format "%s%s%s" prefix expected-string suffix)) + (expected-point (+ (length prefix) expected-point)) + (pos (+ (length prefix) pos))) + `(ert-deftest ,(intern (format "electric-pair-%s-at-point-%s-in-%s%s" + name + (1+ pos) + mode + extra-desc)) + () + ,(format "With |%s|, try input %c at point %d. \ +Should %s |%s| and point at %d" + fixture + char + (1+ pos) + (if (string= fixture expected-string) + "stay" + "become") + (replace-regexp-in-string "\n" "\\\\n" expected-string) + expected-point) + (electric-pair-test-for ,fixture + ,(1+ pos) + ,char + ,expected-string + ,expected-point + ',mode + ,bindings + ,fixture-fn))))) + +(cl-defmacro define-electric-pair-test + (name fixture + input + &key + skip-pair-string + expected-string + expected-point + bindings + (modes '(quote (ruby-mode c++-mode))) + (test-in-comments t) + (test-in-strings t) + (test-in-code t) + (fixture-fn #'(lambda () + (electric-pair-mode 1)))) + `(progn + ,@(cl-loop + for mode in (eval modes) ;FIXME: avoid `eval' + append + (cl-loop + for (prefix suffix extra-desc) in + (append (if test-in-comments + `((,(with-temp-buffer + (funcall mode) + (insert "z") + (comment-region (point-min) (point-max)) + (buffer-substring-no-properties (point-min) + (1- (point-max)))) + "" + "-in-comments"))) + (if test-in-strings + `(("\"" "\"" "-in-strings"))) + (if test-in-code + `(("" "" "")))) + append + (cl-loop + for char across input + for pos from 0 + unless (eq char ?-) + collect (electric-pair-define-test-form + name + fixture + (aref input pos) + pos + expected-string + expected-point + skip-pair-string + prefix + suffix + extra-desc + mode + bindings + fixture-fn)))))) + +;;; Basic pairs and skips +;;; +(define-electric-pair-test balanced-situation + " (()) " "(((((((" :skip-pair-string "ppppppp" + :modes '(ruby-mode)) + +(define-electric-pair-test too-many-openings + " ((()) " "(((((((" :skip-pair-string "ppppppp") + +(define-electric-pair-test too-many-closings + " (())) " "(((((((" :skip-pair-string "------p") + +(define-electric-pair-test too-many-closings-2 + "() ) " "---(---" :skip-pair-string "-------") + +(define-electric-pair-test too-many-closings-3 + ")() " "(------" :skip-pair-string "-------") + +(define-electric-pair-test balanced-autoskipping + " (()) " "---))--" :skip-pair-string "---ss--") + +(define-electric-pair-test too-many-openings-autoskipping + " ((()) " "----))-" :skip-pair-string "-------") + +(define-electric-pair-test too-many-closings-autoskipping + " (())) " "---)))-" :skip-pair-string "---sss-") + + +;;; Mixed parens +;;; +(define-electric-pair-test mixed-paren-1 + " ()] " "-(-(---" :skip-pair-string "-p-p---") + +(define-electric-pair-test mixed-paren-2 + " [() " "-(-()--" :skip-pair-string "-p-ps--") + +(define-electric-pair-test mixed-paren-3 + " (]) " "-(-()--" :skip-pair-string "---ps--") + +(define-electric-pair-test mixed-paren-4 + " ()] " "---)]--" :skip-pair-string "---ss--") + +(define-electric-pair-test mixed-paren-5 + " [() " "----(--" :skip-pair-string "----p--") + +(define-electric-pair-test find-matching-different-paren-type + " ()] " "-[-----" :skip-pair-string "-------") + +(define-electric-pair-test find-matching-different-paren-type-inside-list + "( ()]) " "-[-----" :skip-pair-string "-------") + +(define-electric-pair-test ignore-different-nonmatching-paren-type + "( ()]) " "-(-----" :skip-pair-string "-p-----") + +(define-electric-pair-test autopair-keep-least-amount-of-mixed-unbalance + "( ()] " "-(-----" :skip-pair-string "-p-----") + +(define-electric-pair-test dont-autopair-to-resolve-mixed-unbalance + "( ()] " "-[-----" :skip-pair-string "-------") + +(define-electric-pair-test autopair-so-as-not-to-worsen-unbalance-situation + "( (]) " "-[-----" :skip-pair-string "-p-----") + +(define-electric-pair-test skip-over-partially-balanced + " [([]) " "-----)---" :skip-pair-string "-----s---") + +(define-electric-pair-test only-skip-over-at-least-partially-balanced-stuff + " [([()) " "-----))--" :skip-pair-string "-----s---") + + + + +;;; Quotes +;;; +(define-electric-pair-test pair-some-quotes-skip-others + " \"\" " "-\"\"-----" :skip-pair-string "-ps------" + :test-in-strings nil + :bindings `((electric-pair-text-syntax-table + . ,prog-mode-syntax-table))) + +(define-electric-pair-test skip-single-quotes-in-ruby-mode + " '' " "--'-" :skip-pair-string "--s-" + :modes '(ruby-mode) + :test-in-comments nil + :test-in-strings nil + :bindings `((electric-pair-text-syntax-table + . ,prog-mode-syntax-table))) + +(define-electric-pair-test leave-unbalanced-quotes-alone + " \"' " "-\"'-" :skip-pair-string "----" + :modes '(ruby-mode) + :test-in-strings nil + :bindings `((electric-pair-text-syntax-table + . ,prog-mode-syntax-table))) + +(define-electric-pair-test leave-unbalanced-quotes-alone-2 + " \"\\\"' " "-\"--'-" :skip-pair-string "------" + :modes '(ruby-mode) + :test-in-strings nil + :bindings `((electric-pair-text-syntax-table + . ,prog-mode-syntax-table))) + +(define-electric-pair-test leave-unbalanced-quotes-alone-3 + " foo\\''" "'------" :skip-pair-string "-------" + :modes '(ruby-mode) + :test-in-strings nil + :bindings `((electric-pair-text-syntax-table + . ,prog-mode-syntax-table))) + +(define-electric-pair-test inhibit-if-strings-mismatched + "\"foo\"\"bar" "\"" + :expected-string "\"\"foo\"\"bar" + :expected-point 2 + :test-in-strings nil + :bindings `((electric-pair-text-syntax-table + . ,prog-mode-syntax-table))) + +(define-electric-pair-test inhibit-in-mismatched-string-inside-ruby-comments + "foo\"\" +# +# \"bar\" +# \" \" +# \" +# +baz\"\"" + "\"" + :modes '(ruby-mode) + :test-in-strings nil + :test-in-comments nil + :expected-point 19 + :expected-string + "foo\"\" +# +# \"bar\"\" +# \" \" +# \" +# +baz\"\"" + :fixture-fn #'(lambda () (goto-char (point-min)) (search-forward "bar"))) + +(define-electric-pair-test inhibit-in-mismatched-string-inside-c-comments + "foo\"\"/* + \"bar\" + \" \" + \" +*/baz\"\"" + "\"" + :modes '(c-mode) + :test-in-strings nil + :test-in-comments nil + :expected-point 18 + :expected-string + "foo\"\"/* + \"bar\"\" + \" \" + \" +*/baz\"\"" + :fixture-fn #'(lambda () (goto-char (point-min)) (search-forward "bar"))) + + +;;; More quotes, but now don't bind `electric-pair-text-syntax-table' +;;; to `prog-mode-syntax-table'. Use the defaults for +;;; `electric-pair-pairs' and `electric-pair-text-pairs'. +;;; +(define-electric-pair-test pairing-skipping-quotes-in-code + " \"\" " "-\"\"-----" :skip-pair-string "-ps------" + :test-in-strings nil + :test-in-comments nil) + +(define-electric-pair-test skipping-quotes-in-comments + " \"\" " "--\"-----" :skip-pair-string "--s------" + :test-in-strings nil) + + +;;; Skipping over whitespace +;;; +(define-electric-pair-test whitespace-jumping + " ( ) " "--))))---" :expected-string " ( ) " :expected-point 8 + :bindings '((electric-pair-skip-whitespace . t))) + +(define-electric-pair-test whitespace-chomping + " ( ) " "--)------" :expected-string " () " :expected-point 4 + :bindings '((electric-pair-skip-whitespace . chomp))) + +(define-electric-pair-test whitespace-chomping-2 + " ( \n\t\t\n ) " "--)------" :expected-string " () " :expected-point 4 + :bindings '((electric-pair-skip-whitespace . chomp)) + :test-in-comments nil) + +(define-electric-pair-test whitespace-chomping-dont-cross-comments + " ( \n\t\t\n ) " "--)------" :expected-string " () \n\t\t\n ) " + :expected-point 4 + :bindings '((electric-pair-skip-whitespace . chomp)) + :test-in-strings nil + :test-in-code nil + :test-in-comments t) + +(define-electric-pair-test whitespace-skipping-for-quotes-not-outside + " \" \"" "\"-----" :expected-string "\"\" \" \"" + :expected-point 2 + :bindings '((electric-pair-skip-whitespace . chomp)) + :test-in-strings nil + :test-in-code t + :test-in-comments nil) + +(define-electric-pair-test whitespace-skipping-for-quotes-only-inside + " \" \"" "---\"--" :expected-string " \"\"" + :expected-point 5 + :bindings '((electric-pair-skip-whitespace . chomp)) + :test-in-strings nil + :test-in-code t + :test-in-comments nil) + +(define-electric-pair-test whitespace-skipping-quotes-not-without-proper-syntax + " \" \"" "---\"--" :expected-string " \"\"\" \"" + :expected-point 5 + :modes '(text-mode) + :bindings '((electric-pair-skip-whitespace . chomp)) + :test-in-strings nil + :test-in-code t + :test-in-comments nil) + + +;;; Pairing arbitrary characters +;;; +(define-electric-pair-test angle-brackets-everywhere + "<>" "<>" :skip-pair-string "ps" + :bindings '((electric-pair-pairs . ((?\< . ?\>))))) + +(define-electric-pair-test angle-brackets-everywhere-2 + "(<>" "-<>" :skip-pair-string "-ps" + :bindings '((electric-pair-pairs . ((?\< . ?\>))))) + +(defvar electric-pair-test-angle-brackets-table + (let ((table (make-syntax-table prog-mode-syntax-table))) + (modify-syntax-entry ?\< "(>" table) + (modify-syntax-entry ?\> ")<`" table) + table)) + +(define-electric-pair-test angle-brackets-pair + "<>" "<" :expected-string "<><>" :expected-point 2 + :test-in-code nil + :bindings `((electric-pair-text-syntax-table + . ,electric-pair-test-angle-brackets-table))) + +(define-electric-pair-test angle-brackets-skip + "<>" "->" :expected-string "<>" :expected-point 3 + :test-in-code nil + :bindings `((electric-pair-text-syntax-table + . ,electric-pair-test-angle-brackets-table))) + +(define-electric-pair-test pair-backtick-and-quote-in-comments + ";; " "---`" :expected-string ";; `'" :expected-point 5 + :test-in-comments nil + :test-in-strings nil + :modes '(emacs-lisp-mode) + :bindings '((electric-pair-text-pairs . ((?\` . ?\'))))) + +(define-electric-pair-test skip-backtick-and-quote-in-comments + ";; `foo'" "-------'" :expected-string ";; `foo'" :expected-point 9 + :test-in-comments nil + :test-in-strings nil + :modes '(emacs-lisp-mode) + :bindings '((electric-pair-text-pairs . ((?\` . ?\'))))) + +(define-electric-pair-test pair-backtick-and-quote-in-strings + "\"\"" "-`" :expected-string "\"`'\"" :expected-point 3 + :test-in-comments nil + :test-in-strings nil + :modes '(emacs-lisp-mode) + :bindings '((electric-pair-text-pairs . ((?\` . ?\'))))) + +(define-electric-pair-test skip-backtick-and-quote-in-strings + "\"`'\"" "--'" :expected-string "\"`'\"" :expected-point 4 + :test-in-comments nil + :test-in-strings nil + :modes '(emacs-lisp-mode) + :bindings '((electric-pair-text-pairs . ((?\` . ?\'))))) + +(define-electric-pair-test skip-backtick-and-quote-in-strings-2 + " \"`'\"" "----'" :expected-string " \"`'\"" :expected-point 6 + :test-in-comments nil + :test-in-strings nil + :modes '(emacs-lisp-mode) + :bindings '((electric-pair-text-pairs . ((?\` . ?\'))))) + + +;;; `js-mode' has `electric-layout-rules' for '{ and '} +;;; +(define-electric-pair-test js-mode-braces + "" "{" :expected-string "{}" :expected-point 2 + :modes '(js-mode) + :fixture-fn #'(lambda () + (electric-pair-mode 1))) + +(define-electric-pair-test js-mode-braces-with-layout + "" "{" :expected-string "{\n\n}" :expected-point 3 + :modes '(js-mode) + :test-in-comments nil + :test-in-strings nil + :fixture-fn #'(lambda () + (electric-layout-mode 1) + (electric-pair-mode 1))) + +(define-electric-pair-test js-mode-braces-with-layout-and-indent + "" "{" :expected-string "{\n \n}" :expected-point 7 + :modes '(js-mode) + :test-in-comments nil + :test-in-strings nil + :fixture-fn #'(lambda () + (electric-pair-mode 1) + (electric-indent-mode 1) + (electric-layout-mode 1))) + + +;;; Backspacing +;;; TODO: better tests +;;; +(ert-deftest electric-pair-backspace-1 () + (save-electric-modes + (with-temp-buffer + (insert "()") + (goto-char 2) + (electric-pair-delete-pair 1) + (should (equal "" (buffer-string)))))) + + +;;; Electric newlines between pairs +;;; TODO: better tests +(ert-deftest electric-pair-open-extra-newline () + (save-electric-modes + (with-temp-buffer + (c-mode) + (electric-pair-mode 1) + (electric-indent-mode 1) + (insert "int main {}") + (backward-char 1) + (let ((c-basic-offset 4)) + (newline 1 t) + (should (equal "int main {\n \n}" + (buffer-string))) + (should (equal (point) (- (point-max) 2))))))) + + + +;;; Autowrapping +;;; +(define-electric-pair-test autowrapping-1 + "foo" "(" :expected-string "(foo)" :expected-point 2 + :fixture-fn #'(lambda () + (electric-pair-mode 1) + (mark-sexp 1))) + +(define-electric-pair-test autowrapping-2 + "foo" ")" :expected-string "(foo)" :expected-point 6 + :fixture-fn #'(lambda () + (electric-pair-mode 1) + (mark-sexp 1))) + +(define-electric-pair-test autowrapping-3 + "foo" ")" :expected-string "(foo)" :expected-point 6 + :fixture-fn #'(lambda () + (electric-pair-mode 1) + (goto-char (point-max)) + (skip-chars-backward "\"") + (mark-sexp -1))) + +(define-electric-pair-test autowrapping-4 + "foo" "(" :expected-string "(foo)" :expected-point 2 + :fixture-fn #'(lambda () + (electric-pair-mode 1) + (goto-char (point-max)) + (skip-chars-backward "\"") + (mark-sexp -1))) + +(define-electric-pair-test autowrapping-5 + "foo" "\"" :expected-string "\"foo\"" :expected-point 2 + :fixture-fn #'(lambda () + (electric-pair-mode 1) + (mark-sexp 1))) + +(define-electric-pair-test autowrapping-6 + "foo" "\"" :expected-string "\"foo\"" :expected-point 6 + :fixture-fn #'(lambda () + (electric-pair-mode 1) + (goto-char (point-max)) + (skip-chars-backward "\"") + (mark-sexp -1))) + +(define-electric-pair-test autowrapping-7 + "foo" "\"" :expected-string "``foo''" :expected-point 8 + :modes '(tex-mode) + :fixture-fn #'(lambda () + (electric-pair-mode 1) + (goto-char (point-max)) + (skip-chars-backward "\"") + (mark-sexp -1))) + +(provide 'electric-tests) +;;; electric-tests.el ends here diff --git a/test/lisp/emacs-lisp/cl-generic-tests.el b/test/lisp/emacs-lisp/cl-generic-tests.el new file mode 100644 index 00000000000..dee10fe285e --- /dev/null +++ b/test/lisp/emacs-lisp/cl-generic-tests.el @@ -0,0 +1,223 @@ +;;; cl-generic-tests.el --- Tests for cl-generic.el functionality -*- lexical-binding: t; -*- + +;; Copyright (C) 2015-2016 Free Software Foundation, Inc. + +;; Author: Stefan Monnier <monnier@iro.umontreal.ca> + +;; 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: + +;;; Code: + +(eval-when-compile (require 'ert)) ;Don't indirectly require cl-lib at run-time. +(require 'cl-generic) + +(fmakunbound 'cl--generic-1) +(cl-defgeneric cl--generic-1 (x y)) +(cl-defgeneric (setf cl--generic-1) (v y z) "My generic doc.") + +(ert-deftest cl-generic-test-00 () + (fmakunbound 'cl--generic-1) + (cl-defgeneric cl--generic-1 (x y)) + (cl-defmethod cl--generic-1 ((x t) y) (cons x y)) + (should (equal (cl--generic-1 'a 'b) '(a . b)))) + +(ert-deftest cl-generic-test-01-eql () + (fmakunbound 'cl--generic-1) + (cl-defgeneric cl--generic-1 (x y)) + (cl-defmethod cl--generic-1 ((x t) y) (cons x y)) + (cl-defmethod cl--generic-1 ((_x (eql 4)) _y) + (cons "quatre" (cl-call-next-method))) + (cl-defmethod cl--generic-1 ((_x (eql 5)) _y) + (cons "cinq" (cl-call-next-method))) + (cl-defmethod cl--generic-1 ((_x (eql 6)) y) + (cons "six" (cl-call-next-method 'a y))) + (should (equal (cl--generic-1 'a nil) '(a))) + (should (equal (cl--generic-1 4 nil) '("quatre" 4))) + (should (equal (cl--generic-1 5 nil) '("cinq" 5))) + (should (equal (cl--generic-1 6 nil) '("six" a)))) + +(cl-defstruct cl-generic-struct-parent a b) +(cl-defstruct (cl-generic-struct-child1 (:include cl-generic-struct-parent)) c) +(cl-defstruct (cl-generic-struct-child11 (:include cl-generic-struct-child1)) d) +(cl-defstruct (cl-generic-struct-child2 (:include cl-generic-struct-parent)) e) + +(ert-deftest cl-generic-test-02-struct () + (fmakunbound 'cl--generic-1) + (cl-defgeneric cl--generic-1 (x y) "My doc.") + (cl-defmethod cl--generic-1 ((x t) y) "Doc 1." (cons x y)) + (cl-defmethod cl--generic-1 ((_x cl-generic-struct-parent) y) + "Doc 2." (cons "parent" (cl-call-next-method 'a y))) + (cl-defmethod cl--generic-1 ((_x cl-generic-struct-child1) _y) + (cons "child1" (cl-call-next-method))) + (cl-defmethod cl--generic-1 :around ((_x t) _y) + (cons "around" (cl-call-next-method))) + (cl-defmethod cl--generic-1 :around ((_x cl-generic-struct-child11) _y) + (cons "child11" (cl-call-next-method))) + (cl-defmethod cl--generic-1 ((_x cl-generic-struct-child2) _y) + (cons "child2" (cl-call-next-method))) + (should (equal (cl--generic-1 (make-cl-generic-struct-child1) nil) + '("around" "child1" "parent" a))) + (should (equal (cl--generic-1 (make-cl-generic-struct-child2) nil) + '("around""child2" "parent" a))) + (should (equal (cl--generic-1 (make-cl-generic-struct-child11) nil) + '("child11" "around""child1" "parent" a)))) + +;; I don't know how to put this inside an `ert-test'. This tests that `setf' +;; can be used directly inside the body of the setf method. +(cl-defmethod (setf cl--generic-2) (v (y integer) z) + (setf (cl--generic-2 (nth y z) z) v)) + +(ert-deftest cl-generic-test-03-setf () + (cl-defmethod (setf cl--generic-1) (v (y t) z) (list v y z)) + (cl-defmethod (setf cl--generic-1) (v (_y (eql 4)) z) (list v "four" z)) + (should (equal (setf (cl--generic-1 'a 'b) 'v) '(v a b))) + (should (equal (setf (cl--generic-1 4 'b) 'v) '(v "four" b))) + (let ((x ())) + (should (equal (setf (cl--generic-1 (progn (push 1 x) 'a) + (progn (push 2 x) 'b)) + (progn (push 3 x) 'v)) + '(v a b))) + (should (equal x '(3 2 1))))) + +(ert-deftest cl-generic-test-04-overlapping-tagcodes () + (fmakunbound 'cl--generic-1) + (cl-defgeneric cl--generic-1 (x y) "My doc.") + (cl-defmethod cl--generic-1 ((y t) z) (list y z)) + (cl-defmethod cl--generic-1 ((_y (eql 4)) _z) + (cons "four" (cl-call-next-method))) + (cl-defmethod cl--generic-1 ((_y integer) _z) + (cons "integer" (cl-call-next-method))) + (cl-defmethod cl--generic-1 ((_y number) _z) + (cons "number" (cl-call-next-method))) + (should (equal (cl--generic-1 'a 'b) '(a b))) + (should (equal (cl--generic-1 1 'b) '("integer" "number" 1 b))) + (should (equal (cl--generic-1 4 'b) '("four" "integer" "number" 4 b)))) + +(ert-deftest cl-generic-test-05-alias () + (fmakunbound 'cl--generic-1) + (cl-defgeneric cl--generic-1 (x y) "My doc.") + (defalias 'cl--generic-2 #'cl--generic-1) + (cl-defmethod cl--generic-1 ((y t) z) (list y z)) + (cl-defmethod cl--generic-2 ((_y (eql 4)) _z) + (cons "four" (cl-call-next-method))) + (should (equal (cl--generic-1 4 'b) '("four" 4 b)))) + +(ert-deftest cl-generic-test-06-multiple-dispatch () + (fmakunbound 'cl--generic-1) + (cl-defgeneric cl--generic-1 (x y) "My doc.") + (cl-defmethod cl--generic-1 (x y) (list x y)) + (cl-defmethod cl--generic-1 (_x (_y integer)) + (cons "y-int" (cl-call-next-method))) + (cl-defmethod cl--generic-1 ((_x integer) _y) + (cons "x-int" (cl-call-next-method))) + (cl-defmethod cl--generic-1 ((_x integer) (_y integer)) + (cons "x&y-int" (cl-call-next-method))) + (should (equal (cl--generic-1 1 2) '("x&y-int" "x-int" "y-int" 1 2)))) + +(ert-deftest cl-generic-test-07-apo () + (fmakunbound 'cl--generic-1) + (cl-defgeneric cl--generic-1 (x y) + (:documentation "My doc.") (:argument-precedence-order y x)) + (cl-defmethod cl--generic-1 (x y) (list x y)) + (cl-defmethod cl--generic-1 (_x (_y integer)) + (cons "y-int" (cl-call-next-method))) + (cl-defmethod cl--generic-1 ((_x integer) _y) + (cons "x-int" (cl-call-next-method))) + (cl-defmethod cl--generic-1 ((_x integer) (_y integer)) + (cons "x&y-int" (cl-call-next-method))) + (should (equal (cl--generic-1 1 2) '("x&y-int" "y-int" "x-int" 1 2)))) + +(ert-deftest cl-generic-test-08-after/before () + (let ((log ())) + (fmakunbound 'cl--generic-1) + (cl-defgeneric cl--generic-1 (x y)) + (cl-defmethod cl--generic-1 ((_x t) y) (cons y log)) + (cl-defmethod cl--generic-1 ((_x (eql 4)) _y) + (cons "quatre" (cl-call-next-method))) + (cl-defmethod cl--generic-1 :after (x _y) + (push (list :after x) log)) + (cl-defmethod cl--generic-1 :before (x _y) + (push (list :before x) log)) + (should (equal (cl--generic-1 4 6) '("quatre" 6 (:before 4)))) + (should (equal log '((:after 4) (:before 4)))))) + +(defun cl--generic-test-advice (&rest args) (cons "advice" (apply args))) + +(ert-deftest cl-generic-test-09-advice () + (fmakunbound 'cl--generic-1) + (cl-defgeneric cl--generic-1 (x y) "My doc.") + (cl-defmethod cl--generic-1 (x y) (list x y)) + (advice-add 'cl--generic-1 :around #'cl--generic-test-advice) + (should (equal (cl--generic-1 4 5) '("advice" 4 5))) + (cl-defmethod cl--generic-1 ((_x integer) _y) + (cons "integer" (cl-call-next-method))) + (should (equal (cl--generic-1 4 5) '("advice" "integer" 4 5))) + (advice-remove 'cl--generic-1 #'cl--generic-test-advice) + (should (equal (cl--generic-1 4 5) '("integer" 4 5)))) + +(ert-deftest cl-generic-test-10-weird () + (fmakunbound 'cl--generic-1) + (cl-defgeneric cl--generic-1 (x &rest r) "My doc.") + (cl-defmethod cl--generic-1 (x &rest r) (cons x r)) + ;; This kind of definition is not valid according to CLHS, but it does show + ;; up in EIEIO's tests for no-next-method, so we should either + ;; detect it and signal an error or do something meaningful with it. + (cl-defmethod cl--generic-1 (x (y integer) &rest r) + `("integer" ,y ,x ,@r)) + (should (equal (cl--generic-1 'a 'b) '(a b))) + (should (equal (cl--generic-1 1 2) '("integer" 2 1)))) + +(ert-deftest cl-generic-test-11-next-method-p () + (fmakunbound 'cl--generic-1) + (cl-defgeneric cl--generic-1 (x y)) + (cl-defmethod cl--generic-1 ((x t) y) + (list x y (cl-next-method-p))) + (cl-defmethod cl--generic-1 ((_x (eql 4)) _y) + (cl-list* "quatre" (cl-next-method-p) (cl-call-next-method))) + (should (equal (cl--generic-1 4 5) '("quatre" t 4 5 nil)))) + +(ert-deftest cl-generic-test-12-context () + (fmakunbound 'cl--generic-1) + (cl-defgeneric cl--generic-1 ()) + (cl-defmethod cl--generic-1 (&context (overwrite-mode (eql t))) + (list 'is-t (cl-call-next-method))) + (cl-defmethod cl--generic-1 (&context (overwrite-mode (eql nil))) + (list 'is-nil (cl-call-next-method))) + (cl-defmethod cl--generic-1 () 'any) + (should (equal (list (let ((overwrite-mode t)) (cl--generic-1)) + (let ((overwrite-mode nil)) (cl--generic-1)) + (let ((overwrite-mode 1)) (cl--generic-1))) + '((is-t any) (is-nil any) any)))) + +(ert-deftest cl-generic-test-13-head () + (fmakunbound 'cl--generic-1) + (cl-defgeneric cl--generic-1 (x y)) + (cl-defmethod cl--generic-1 ((x t) y) (cons x y)) + (cl-defmethod cl--generic-1 ((_x (head 4)) _y) + (cons "quatre" (cl-call-next-method))) + (cl-defmethod cl--generic-1 ((_x (head 5)) _y) + (cons "cinq" (cl-call-next-method))) + (cl-defmethod cl--generic-1 ((_x (head 6)) y) + (cons "six" (cl-call-next-method 'a y))) + (should (equal (cl--generic-1 'a nil) '(a))) + (should (equal (cl--generic-1 '(4) nil) '("quatre" (4)))) + (should (equal (cl--generic-1 '(5) nil) '("cinq" (5)))) + (should (equal (cl--generic-1 '(6) nil) '("six" a)))) + +(provide 'cl-generic-tests) +;;; cl-generic-tests.el ends here diff --git a/test/lisp/emacs-lisp/cl-lib-tests.el b/test/lisp/emacs-lisp/cl-lib-tests.el new file mode 100644 index 00000000000..cbaf70fc4bb --- /dev/null +++ b/test/lisp/emacs-lisp/cl-lib-tests.el @@ -0,0 +1,496 @@ +;;; cl-lib.el --- tests for emacs-lisp/cl-lib.el -*- lexical-binding:t -*- + +;; Copyright (C) 2013-2016 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; 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/'. + +;;; Commentary: + +;; Extracted from ert-tests.el, back when ert used to reimplement some +;; cl functions. + +;;; Code: + +(require 'cl-lib) +(require 'ert) + +(ert-deftest cl-lib-test-remprop () + (let ((x (cl-gensym))) + (should (equal (symbol-plist x) '())) + ;; Remove nonexistent property on empty plist. + (cl-remprop x 'b) + (should (equal (symbol-plist x) '())) + (put x 'a 1) + (should (equal (symbol-plist x) '(a 1))) + ;; Remove nonexistent property on nonempty plist. + (cl-remprop x 'b) + (should (equal (symbol-plist x) '(a 1))) + (put x 'b 2) + (put x 'c 3) + (put x 'd 4) + (should (equal (symbol-plist x) '(a 1 b 2 c 3 d 4))) + ;; Remove property that is neither first nor last. + (cl-remprop x 'c) + (should (equal (symbol-plist x) '(a 1 b 2 d 4))) + ;; Remove last property from a plist of length >1. + (cl-remprop x 'd) + (should (equal (symbol-plist x) '(a 1 b 2))) + ;; Remove first property from a plist of length >1. + (cl-remprop x 'a) + (should (equal (symbol-plist x) '(b 2))) + ;; Remove property when there is only one. + (cl-remprop x 'b) + (should (equal (symbol-plist x) '())))) + +(ert-deftest cl-lib-test-remove-if-not () + (let ((list (list 'a 'b 'c 'd)) + (i 0)) + (let ((result (cl-remove-if-not (lambda (x) + (should (eql x (nth i list))) + (cl-incf i) + (member i '(2 3))) + list))) + (should (equal i 4)) + (should (equal result '(b c))) + (should (equal list '(a b c d))))) + (should (equal '() + (cl-remove-if-not (lambda (_x) (should nil)) '())))) + +(ert-deftest cl-lib-test-remove () + (let ((list (list 'a 'b 'c 'd)) + (key-index 0) + (test-index 0)) + (let ((result + (cl-remove 'foo list + :key (lambda (x) + (should (eql x (nth key-index list))) + (prog1 + (list key-index x) + (cl-incf key-index))) + :test + (lambda (a b) + (should (eql a 'foo)) + (should (equal b (list test-index + (nth test-index list)))) + (cl-incf test-index) + (member test-index '(2 3)))))) + (should (equal key-index 4)) + (should (equal test-index 4)) + (should (equal result '(a d))) + (should (equal list '(a b c d))))) + (let ((x (cons nil nil)) + (y (cons nil nil))) + (should (equal (cl-remove x (list x y)) + ;; or (list x), since we use `equal' -- the + ;; important thing is that only one element got + ;; removed, this proves that the default test is + ;; `eql', not `equal' + (list y))))) + + +(ert-deftest cl-lib-test-set-functions () + (let ((c1 (cons nil nil)) + (c2 (cons nil nil)) + (sym (make-symbol "a"))) + (let ((e '()) + (a (list 'a 'b sym nil "" "x" c1 c2)) + (b (list c1 'y 'b sym 'x))) + (should (equal (cl-set-difference e e) e)) + (should (equal (cl-set-difference a e) a)) + (should (equal (cl-set-difference e a) e)) + (should (equal (cl-set-difference a a) e)) + (should (equal (cl-set-difference b e) b)) + (should (equal (cl-set-difference e b) e)) + (should (equal (cl-set-difference b b) e)) + ;; Note: this test (and others) is sensitive to the order of the + ;; result, which is not documented. + (should (equal (cl-set-difference a b) (list 'a nil "" "x" c2))) + (should (equal (cl-set-difference b a) (list 'y 'x))) + + ;; We aren't testing whether this is really using `eq' rather than `eql'. + (should (equal (cl-set-difference e e :test 'eq) e)) + (should (equal (cl-set-difference a e :test 'eq) a)) + (should (equal (cl-set-difference e a :test 'eq) e)) + (should (equal (cl-set-difference a a :test 'eq) e)) + (should (equal (cl-set-difference b e :test 'eq) b)) + (should (equal (cl-set-difference e b :test 'eq) e)) + (should (equal (cl-set-difference b b :test 'eq) e)) + (should (equal (cl-set-difference a b :test 'eq) (list 'a nil "" "x" c2))) + (should (equal (cl-set-difference b a :test 'eq) (list 'y 'x))) + + (should (equal (cl-union e e) e)) + (should (equal (cl-union a e) a)) + (should (equal (cl-union e a) a)) + (should (equal (cl-union a a) a)) + (should (equal (cl-union b e) b)) + (should (equal (cl-union e b) b)) + (should (equal (cl-union b b) b)) + (should (equal (cl-union a b) (list 'x 'y 'a 'b sym nil "" "x" c1 c2))) + + (should (equal (cl-union b a) (list 'x 'y 'a 'b sym nil "" "x" c1 c2))) + + (should (equal (cl-intersection e e) e)) + (should (equal (cl-intersection a e) e)) + (should (equal (cl-intersection e a) e)) + (should (equal (cl-intersection a a) a)) + (should (equal (cl-intersection b e) e)) + (should (equal (cl-intersection e b) e)) + (should (equal (cl-intersection b b) b)) + (should (equal (cl-intersection a b) (list sym 'b c1))) + (should (equal (cl-intersection b a) (list sym 'b c1)))))) + +(ert-deftest cl-lib-test-gensym () + ;; Since the expansion of `should' calls `cl-gensym' and thus has a + ;; side-effect on `cl--gensym-counter', we have to make sure all + ;; macros in our test body are expanded before we rebind + ;; `cl--gensym-counter' and run the body. Otherwise, the test would + ;; fail if run interpreted. + (let ((body (byte-compile + '(lambda () + (should (equal (symbol-name (cl-gensym)) "G0")) + (should (equal (symbol-name (cl-gensym)) "G1")) + (should (equal (symbol-name (cl-gensym)) "G2")) + (should (equal (symbol-name (cl-gensym "foo")) "foo3")) + (should (equal (symbol-name (cl-gensym "bar")) "bar4")) + (should (equal cl--gensym-counter 5)))))) + (let ((cl--gensym-counter 0)) + (funcall body)))) + +(ert-deftest cl-lib-test-coerce-to-vector () + (let* ((a (vector)) + (b (vector 1 a 3)) + (c (list)) + (d (list b a))) + (should (eql (cl-coerce a 'vector) a)) + (should (eql (cl-coerce b 'vector) b)) + (should (equal (cl-coerce c 'vector) (vector))) + (should (equal (cl-coerce d 'vector) (vector b a))))) + +(ert-deftest cl-lib-test-string-position () + (should (eql (cl-position ?x "") nil)) + (should (eql (cl-position ?a "abc") 0)) + (should (eql (cl-position ?b "abc") 1)) + (should (eql (cl-position ?c "abc") 2)) + (should (eql (cl-position ?d "abc") nil)) + (should (eql (cl-position ?A "abc") nil))) + +(ert-deftest cl-lib-test-mismatch () + (should (eql (cl-mismatch "" "") nil)) + (should (eql (cl-mismatch "" "a") 0)) + (should (eql (cl-mismatch "a" "a") nil)) + (should (eql (cl-mismatch "ab" "a") 1)) + (should (eql (cl-mismatch "Aa" "aA") 0)) + (should (eql (cl-mismatch '(a b c) '(a b d)) 2))) + +(ert-deftest cl-lib-test-loop () + (should (eql (cl-loop with (a b c) = '(1 2 3) return (+ a b c)) 6))) + +(ert-deftest cl-lib-keyword-names-versus-values () + (should (equal + (funcall (cl-function (lambda (&key a b) (list a b))) + :b :a :a 42) + '(42 :a)))) + +(cl-defstruct (mystruct + (:constructor cl-lib--con-1 (&aux (abc 1))) + (:constructor cl-lib--con-2 (&optional def) "Constructor docstring.")) + "General docstring." + (abc 5 :readonly t) (def nil)) +(ert-deftest cl-lib-struct-accessors () + (let ((x (make-mystruct :abc 1 :def 2))) + (should (eql (cl-struct-slot-value 'mystruct 'abc x) 1)) + (should (eql (cl-struct-slot-value 'mystruct 'def x) 2)) + (setf (cl-struct-slot-value 'mystruct 'def x) -1) + (should (eql (cl-struct-slot-value 'mystruct 'def x) -1)) + (should (eql (cl-struct-slot-offset 'mystruct 'abc) 1)) + (should-error (cl-struct-slot-offset 'mystruct 'marypoppins)) + (should (pcase (cl-struct-slot-info 'mystruct) + (`((cl-tag-slot) (abc 5 :readonly t) + (def . ,(or `nil `(nil)))) + t))))) +(ert-deftest cl-lib-struct-constructors () + (should (string-match "\\`Constructor docstring." + (documentation 'cl-lib--con-2 t))) + (should (mystruct-p (cl-lib--con-1))) + (should (mystruct-p (cl-lib--con-2)))) + +(ert-deftest cl-lib-arglist-performance () + ;; An `&aux' should not cause lambda's arglist to be turned into an &rest + ;; that's parsed by hand. + (should (equal () (help-function-arglist 'cl-lib--con-1))) + (should (pcase (help-function-arglist 'cl-lib--con-2) + (`(&optional ,_) t)))) + +(ert-deftest cl-the () + (should (eql (cl-the integer 42) 42)) + (should-error (cl-the integer "abc")) + (let ((side-effect 0)) + (should (= (cl-the integer (cl-incf side-effect)) 1)) + (should (= side-effect 1)))) + +(ert-deftest cl-lib-test-plusp () + (should-not (cl-plusp -1.0e+INF)) + (should-not (cl-plusp -1.5e2)) + (should-not (cl-plusp -3.14)) + (should-not (cl-plusp -1)) + (should-not (cl-plusp -0.0)) + (should-not (cl-plusp 0)) + (should-not (cl-plusp 0.0)) + (should-not (cl-plusp -0.0e+NaN)) + (should-not (cl-plusp 0.0e+NaN)) + (should (cl-plusp 1)) + (should (cl-plusp 3.14)) + (should (cl-plusp 1.5e2)) + (should (cl-plusp 1.0e+INF)) + (should-error (cl-plusp "42") :type 'wrong-type-argument)) + +(ert-deftest cl-lib-test-minusp () + (should (cl-minusp -1.0e+INF)) + (should (cl-minusp -1.5e2)) + (should (cl-minusp -3.14)) + (should (cl-minusp -1)) + (should-not (cl-minusp -0.0)) + (should-not (cl-minusp 0)) + (should-not (cl-minusp 0.0)) + (should-not (cl-minusp -0.0e+NaN)) + (should-not (cl-minusp 0.0e+NaN)) + (should-not (cl-minusp 1)) + (should-not (cl-minusp 3.14)) + (should-not (cl-minusp 1.5e2)) + (should-not (cl-minusp 1.0e+INF)) + (should-error (cl-minusp "-42") :type 'wrong-type-argument)) + +(ert-deftest cl-lib-test-oddp () + (should (cl-oddp -3)) + (should (cl-oddp 3)) + (should-not (cl-oddp -2)) + (should-not (cl-oddp 0)) + (should-not (cl-oddp 2)) + (should-error (cl-oddp 3.0e+NaN) :type 'wrong-type-argument) + (should-error (cl-oddp 3.0) :type 'wrong-type-argument) + (should-error (cl-oddp "3") :type 'wrong-type-argument)) + +(ert-deftest cl-lib-test-evenp () + (should (cl-evenp -2)) + (should (cl-evenp 0)) + (should (cl-evenp 2)) + (should-not (cl-evenp -3)) + (should-not (cl-evenp 3)) + (should-error (cl-evenp 2.0e+NaN) :type 'wrong-type-argument) + (should-error (cl-evenp 2.0) :type 'wrong-type-argument) + (should-error (cl-evenp "2") :type 'wrong-type-argument)) + +(ert-deftest cl-digit-char-p () + (should (eql 3 (cl-digit-char-p ?3))) + (should (eql 10 (cl-digit-char-p ?a 11))) + (should (eql 10 (cl-digit-char-p ?A 11))) + (should-not (cl-digit-char-p ?a)) + (should (eql 32 (cl-digit-char-p ?w 36))) + (should-error (cl-digit-char-p ?a 37) :type 'args-out-of-range) + (should-error (cl-digit-char-p ?a 1) :type 'args-out-of-range)) + +(ert-deftest cl-lib-test-first () + (should (null (cl-first '()))) + (should (= 4 (cl-first '(4)))) + (should (= 4 (cl-first '(4 2)))) + (should-error (cl-first "42") :type 'wrong-type-argument)) + +(ert-deftest cl-lib-test-second () + (should (null (cl-second '()))) + (should (null (cl-second '(4)))) + (should (= 2 (cl-second '(1 2)))) + (should (= 2 (cl-second '(1 2 3)))) + (should-error (cl-second "1 2 3") :type 'wrong-type-argument)) + +(ert-deftest cl-lib-test-third () + (should (null (cl-third '()))) + (should (null (cl-third '(1 2)))) + (should (= 3 (cl-third '(1 2 3)))) + (should (= 3 (cl-third '(1 2 3 4)))) + (should-error (cl-third "123") :type 'wrong-type-argument)) + +(ert-deftest cl-lib-test-fourth () + (should (null (cl-fourth '()))) + (should (null (cl-fourth '(1 2 3)))) + (should (= 4 (cl-fourth '(1 2 3 4)))) + (should (= 4 (cl-fourth '(1 2 3 4 5)))) + (should-error (cl-fourth "1234") :type 'wrong-type-argument)) + +(ert-deftest cl-lib-test-fifth () + (should (null (cl-fifth '()))) + (should (null (cl-fifth '(1 2 3 4)))) + (should (= 5 (cl-fifth '(1 2 3 4 5)))) + (should (= 5 (cl-fifth '(1 2 3 4 5 6)))) + (should-error (cl-fifth "12345") :type 'wrong-type-argument)) + +(ert-deftest cl-lib-test-fifth () + (should (null (cl-fifth '()))) + (should (null (cl-fifth '(1 2 3 4)))) + (should (= 5 (cl-fifth '(1 2 3 4 5)))) + (should (= 5 (cl-fifth '(1 2 3 4 5 6)))) + (should-error (cl-fifth "12345") :type 'wrong-type-argument)) + +(ert-deftest cl-lib-test-sixth () + (should (null (cl-sixth '()))) + (should (null (cl-sixth '(1 2 3 4 5)))) + (should (= 6 (cl-sixth '(1 2 3 4 5 6)))) + (should (= 6 (cl-sixth '(1 2 3 4 5 6 7)))) + (should-error (cl-sixth "123456") :type 'wrong-type-argument)) + +(ert-deftest cl-lib-test-seventh () + (should (null (cl-seventh '()))) + (should (null (cl-seventh '(1 2 3 4 5 6)))) + (should (= 7 (cl-seventh '(1 2 3 4 5 6 7)))) + (should (= 7 (cl-seventh '(1 2 3 4 5 6 7 8)))) + (should-error (cl-seventh "1234567") :type 'wrong-type-argument)) + +(ert-deftest cl-lib-test-eighth () + (should (null (cl-eighth '()))) + (should (null (cl-eighth '(1 2 3 4 5 6 7)))) + (should (= 8 (cl-eighth '(1 2 3 4 5 6 7 8)))) + (should (= 8 (cl-eighth '(1 2 3 4 5 6 7 8 9)))) + (should-error (cl-eighth "12345678") :type 'wrong-type-argument)) + +(ert-deftest cl-lib-test-ninth () + (should (null (cl-ninth '()))) + (should (null (cl-ninth '(1 2 3 4 5 6 7 8)))) + (should (= 9 (cl-ninth '(1 2 3 4 5 6 7 8 9)))) + (should (= 9 (cl-ninth '(1 2 3 4 5 6 7 8 9 10)))) + (should-error (cl-ninth "123456789") :type 'wrong-type-argument)) + +(ert-deftest cl-lib-test-tenth () + (should (null (cl-tenth '()))) + (should (null (cl-tenth '(1 2 3 4 5 6 7 8 9)))) + (should (= 10 (cl-tenth '(1 2 3 4 5 6 7 8 9 10)))) + (should (= 10 (cl-tenth '(1 2 3 4 5 6 7 8 9 10 11)))) + (should-error (cl-tenth "1234567890") :type 'wrong-type-argument)) + +(ert-deftest cl-lib-test-endp () + (should (cl-endp '())) + (should-not (cl-endp '(1))) + (should-error (cl-endp 1) :type 'wrong-type-argument) + (should-error (cl-endp [1]) :type 'wrong-type-argument)) + +(ert-deftest cl-lib-test-nth-value () + (let ((vals (cl-values 2 3))) + (should (= (cl-nth-value 0 vals) 2)) + (should (= (cl-nth-value 1 vals) 3)) + (should (null (cl-nth-value 2 vals))) + (should-error (cl-nth-value 0.0 vals) :type 'wrong-type-argument))) + +(ert-deftest cl-lib-nth-value-test-multiple-values () + "While CL multiple values are an alias to list, these won't work." + :expected-result :failed + (should (eq (cl-nth-value 0 '(2 3)) '(2 3))) + (should (= (cl-nth-value 0 1) 1)) + (should (null (cl-nth-value 1 1))) + (should-error (cl-nth-value -1 (cl-values 2 3)) :type 'args-out-of-range) + (should (string= (cl-nth-value 0 "only lists") "only lists"))) + +(ert-deftest cl-test-caaar () + (should (null (cl-caaar '()))) + (should (null (cl-caaar '(() (2))))) + (should (null (cl-caaar '((() (2)) (a b))))) + (should-error (cl-caaar '(1 2)) :type 'wrong-type-argument) + (should-error (cl-caaar '((1 2))) :type 'wrong-type-argument) + (should (= 1 (cl-caaar '(((1 2) (3 4)))))) + (should (null (cl-caaar '((() (3 4))))))) + +(ert-deftest cl-test-caadr () + (should (null (cl-caadr '()))) + (should (null (cl-caadr '(1)))) + (should-error (cl-caadr '(1 2)) :type 'wrong-type-argument) + (should (= 2 (cl-caadr '(1 (2 3))))) + (should (equal '((2) (3)) (cl-caadr '((1) (((2) (3))) (4)))))) + +(ert-deftest cl-test-ldiff () + (let ((l '(1 2 3))) + (should (null (cl-ldiff '() '()))) + (should (null (cl-ldiff '() l))) + (should (null (cl-ldiff l l))) + (should (equal l (cl-ldiff l '()))) + ;; must be part of the list + (should (equal l (cl-ldiff l '(2 3)))) + (should (equal '(1) (cl-ldiff l (nthcdr 1 l)))) + ;; should return a copy + (should-not (eq (cl-ldiff l '()) l)))) + +(ert-deftest cl-lib-adjoin-test () + (let ((nums '(1 2)) + (myfn-p '=)) + ;; add non-existing item to the front + (should (equal '(3 1 2) (cl-adjoin 3 nums))) + ;; just add - don't copy rest + (should (eq nums (cdr (cl-adjoin 3 nums)))) + ;; add only when not already there + (should (eq nums (cl-adjoin 2 nums))) + (should (equal '(2 1 (2)) (cl-adjoin 2 '(1 (2))))) + ;; default test function is eql + (should (equal '(1.0 1 2) (cl-adjoin 1.0 nums))) + ;; own :test function - returns true if match + (should (equal '(1.0 1 2) (cl-adjoin 1.0 nums :test nil))) ;defaults to eql + (should (eq nums (cl-adjoin 2 nums :test myfn-p))) ;match + (should (equal '(3 1 2) (cl-adjoin 3 nums :test myfn-p))) ;no match + ;; own :test-not function - returns false if match + (should (equal '(1.0 1 2) (cl-adjoin 1.0 nums :test-not nil))) ;defaults to eql + (should (equal '(2 2) (cl-adjoin 2 '(2) :test-not myfn-p))) ; no match + (should (eq nums (cl-adjoin 2 nums :test-not myfn-p))) ; 1 matches + (should (eq nums (cl-adjoin 3 nums :test-not myfn-p))) ; 1 and 2 matches + + ;; according to CLtL2 passing both :test and :test-not should signal error + ;;(should-error (cl-adjoin 3 nums :test 'myfn-p :test-not myfn-p)) + + ;; own :key fn + (should (eq nums (cl-adjoin 3 nums :key (lambda (x) (if (cl-evenp x) (1+ x) x))))) + (should (equal '(3 1 2) (cl-adjoin 3 nums :key (lambda (x) (if (cl-evenp x) (+ 2 x) x))))) + + ;; convert using :key, then compare with :test + (should (eq nums (cl-adjoin 1 nums :key 'int-to-string :test 'string=))) + (should (equal '(3 1 2) (cl-adjoin 3 nums :key 'int-to-string :test 'string=))) + (should-error (cl-adjoin 3 nums :key 'int-to-string :test myfn-p) + :type 'wrong-type-argument) + + ;; convert using :key, then compare with :test-not + (should (eq nums (cl-adjoin 3 nums :key 'int-to-string :test-not 'string=))) + (should (equal '(1 1) (cl-adjoin 1 '(1) :key 'int-to-string :test-not 'string=))) + (should-error (cl-adjoin 1 nums :key 'int-to-string :test-not myfn-p) + :type 'wrong-type-argument))) + +(ert-deftest cl-parse-integer () + (should-error (cl-parse-integer "abc")) + (should (null (cl-parse-integer "abc" :junk-allowed t))) + (should (null (cl-parse-integer "" :junk-allowed t))) + (should (= 342391 (cl-parse-integer "0123456789" :radix 8 :junk-allowed t))) + (should-error (cl-parse-integer "0123456789" :radix 8)) + (should (= -239 (cl-parse-integer "-efz" :radix 16 :junk-allowed t))) + (should-error (cl-parse-integer "efz" :radix 16)) + (should (= 239 (cl-parse-integer "zzef" :radix 16 :start 2))) + (should (= -123 (cl-parse-integer " -123 ")))) + +(ert-deftest cl-loop-destructuring-with () + (should (equal (cl-loop with (a b c) = '(1 2 3) return (+ a b c)) 6))) + +(ert-deftest cl-flet-test () + (should (equal (cl-flet ((f1 (x) x)) (let ((x #'f1)) (funcall x 5))) 5))) + +(ert-deftest cl-lib-test-typep () + (cl-deftype cl-lib-test-type (&optional x) `(member ,x)) + ;; Make sure we correctly implement the rule that deftype's optional args + ;; default to `*' rather than to nil. + (should (cl-typep '* 'cl-lib-test-type)) + (should-not (cl-typep 1 'cl-lib-test-type))) + +;;; cl-lib.el ends here diff --git a/test/lisp/emacs-lisp/eieio-tests/eieio-test-methodinvoke.el b/test/lisp/emacs-lisp/eieio-tests/eieio-test-methodinvoke.el new file mode 100644 index 00000000000..eb26047da2f --- /dev/null +++ b/test/lisp/emacs-lisp/eieio-tests/eieio-test-methodinvoke.el @@ -0,0 +1,402 @@ +;;; eieio-testsinvoke.el -- eieio tests for method invocation + +;; Copyright (C) 2005, 2008, 2010, 2013-2016 Free Software Foundation, +;; Inc. + +;; Author: Eric M. Ludlam <zappo@gnu.org> + +;; 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: +;; +;; Test method invocation order. From the common lisp reference +;; manual: +;; +;; QUOTE: +;; - All the :before methods are called, in most-specific-first +;; order. Their values are ignored. An error is signaled if +;; call-next-method is used in a :before method. +;; +;; - The most specific primary method is called. Inside the body of a +;; primary method, call-next-method may be used to call the next +;; most specific primary method. When that method returns, the +;; previous primary method can execute more code, perhaps based on +;; the returned value or values. The generic function no-next-method +;; is invoked if call-next-method is used and there are no more +;; applicable primary methods. The function next-method-p may be +;; used to determine whether a next method exists. If +;; call-next-method is not used, only the most specific primary +;; method is called. +;; +;; - All the :after methods are called, in most-specific-last order. +;; Their values are ignored. An error is signaled if +;; call-next-method is used in a :after method. +;; +;; +;; Also test behavior of `call-next-method'. From clos.org: +;; +;; QUOTE: +;; When call-next-method is called with no arguments, it passes the +;; current method's original arguments to the next method. + +(require 'eieio) +(require 'ert) + +(defvar eieio-test-method-order-list nil + "List of symbols stored during method invocation.") + +(defun eieio-test-method-store (&rest args) + "Store current invocation class symbol in the invocation order list." + (push args eieio-test-method-order-list)) + +(defun eieio-test-match (rightanswer) + "Do a test match." + (if (equal rightanswer eieio-test-method-order-list) + t + (error "eieio-test-methodinvoke.el: Test Failed: %S != %S" + rightanswer eieio-test-method-order-list))) + +(defvar eieio-test-call-next-method-arguments nil + "List of passed to methods during execution of `call-next-method'.") + +(defun eieio-test-arguments-for (class) + "Returns arguments passed to method of CLASS during `call-next-method'." + (cdr (assoc class eieio-test-call-next-method-arguments))) + +(defclass eitest-A () ()) +(defclass eitest-AA (eitest-A) ()) +(defclass eitest-AAA (eitest-AA) ()) +(defclass eitest-B-base1 () ()) +(defclass eitest-B-base2 () ()) +(defclass eitest-B (eitest-B-base1 eitest-B-base2) ()) + +(defmethod eitest-F :BEFORE ((p eitest-B-base1)) + (eieio-test-method-store :BEFORE 'eitest-B-base1)) + +(defmethod eitest-F :BEFORE ((p eitest-B-base2)) + (eieio-test-method-store :BEFORE 'eitest-B-base2)) + +(defmethod eitest-F :BEFORE ((p eitest-B)) + (eieio-test-method-store :BEFORE 'eitest-B)) + +(defmethod eitest-F ((p eitest-B)) + (eieio-test-method-store :PRIMARY 'eitest-B) + (call-next-method)) + +(defmethod eitest-F ((p eitest-B-base1)) + (eieio-test-method-store :PRIMARY 'eitest-B-base1) + (call-next-method)) + +(defmethod eitest-F ((p eitest-B-base2)) + (eieio-test-method-store :PRIMARY 'eitest-B-base2) + (when (next-method-p) + (call-next-method)) + ) + +(defmethod eitest-F :AFTER ((p eitest-B-base1)) + (eieio-test-method-store :AFTER 'eitest-B-base1)) + +(defmethod eitest-F :AFTER ((p eitest-B-base2)) + (eieio-test-method-store :AFTER 'eitest-B-base2)) + +(defmethod eitest-F :AFTER ((p eitest-B)) + (eieio-test-method-store :AFTER 'eitest-B)) + +(ert-deftest eieio-test-method-order-list-3 () + (let ((eieio-test-method-order-list nil) + (ans '( + (:BEFORE eitest-B) + (:BEFORE eitest-B-base1) + (:BEFORE eitest-B-base2) + + (:PRIMARY eitest-B) + (:PRIMARY eitest-B-base1) + (:PRIMARY eitest-B-base2) + + (:AFTER eitest-B-base2) + (:AFTER eitest-B-base1) + (:AFTER eitest-B) + ))) + (eitest-F (eitest-B nil)) + (setq eieio-test-method-order-list (nreverse eieio-test-method-order-list)) + (eieio-test-match ans))) + +;;; Test static invocation +;; +(defmethod eitest-H :STATIC ((class eitest-A)) + "No need to do work in here." + 'moose) + +(ert-deftest eieio-test-method-order-list-4 () + ;; Both of these situations should succeed. + (should (eitest-H 'eitest-A)) + (should (eitest-H (eitest-A nil)))) + +;;; Return value from :PRIMARY +;; +(defmethod eitest-I :BEFORE ((a eitest-A)) + (eieio-test-method-store :BEFORE 'eitest-A) + ":before") + +(defmethod eitest-I :PRIMARY ((a eitest-A)) + (eieio-test-method-store :PRIMARY 'eitest-A) + ":primary") + +(defmethod eitest-I :AFTER ((a eitest-A)) + (eieio-test-method-store :AFTER 'eitest-A) + ":after") + +(ert-deftest eieio-test-method-order-list-5 () + (let ((eieio-test-method-order-list nil) + (ans (eitest-I (eitest-A nil)))) + (should (string= ans ":primary")))) + +;;; Multiple inheritance and the 'constructor' method. +;; +;; Constructor is a static method, so this is really testing +;; static method invocation and multiple inheritance. +;; +(defclass C-base1 () ()) +(defclass C-base2 () ()) +(defclass C (C-base1 C-base2) ()) + +;; Just use the obsolete name once, to make sure it also works. +(defmethod constructor :STATIC ((p C-base1) &rest args) + (eieio-test-method-store :STATIC 'C-base1) + (if (next-method-p) (call-next-method)) + ) + +(defmethod make-instance :STATIC ((p C-base2) &rest args) + (eieio-test-method-store :STATIC 'C-base2) + (if (next-method-p) (call-next-method)) + ) + +(cl-defmethod make-instance ((p (subclass C)) &rest args) + (eieio-test-method-store :STATIC 'C) + (cl-call-next-method) + ) + +(ert-deftest eieio-test-method-order-list-6 () + (let ((eieio-test-method-order-list nil) + (ans '( + (:STATIC C) + (:STATIC C-base1) + (:STATIC C-base2) + ))) + (C nil) + (setq eieio-test-method-order-list (nreverse eieio-test-method-order-list)) + (eieio-test-match ans))) + +;;; Diamond Test +;; +;; For a diamond shaped inheritance structure, (call-next-method) can break. +;; As such, there are two possible orders. + +(defclass D-base0 () () :method-invocation-order :depth-first) +(defclass D-base1 (D-base0) () :method-invocation-order :depth-first) +(defclass D-base2 (D-base0) () :method-invocation-order :depth-first) +(defclass D (D-base1 D-base2) () :method-invocation-order :depth-first) + +(defmethod eitest-F ((p D)) + "D" + (eieio-test-method-store :PRIMARY 'D) + (call-next-method)) + +(defmethod eitest-F ((p D-base0)) + "D-base0" + (eieio-test-method-store :PRIMARY 'D-base0) + ;; This should have no next + ;; (when (next-method-p) (call-next-method)) + ) + +(defmethod eitest-F ((p D-base1)) + "D-base1" + (eieio-test-method-store :PRIMARY 'D-base1) + (call-next-method)) + +(defmethod eitest-F ((p D-base2)) + "D-base2" + (eieio-test-method-store :PRIMARY 'D-base2) + (when (next-method-p) + (call-next-method)) + ) + +(ert-deftest eieio-test-method-order-list-7 () + (let ((eieio-test-method-order-list nil) + (ans '( + (:PRIMARY D) + (:PRIMARY D-base1) + ;; (:PRIMARY D-base2) + (:PRIMARY D-base0) + ))) + (eitest-F (D nil)) + (setq eieio-test-method-order-list (nreverse eieio-test-method-order-list)) + (eieio-test-match ans))) + +;;; Other invocation order + +(defclass E-base0 () () :method-invocation-order :breadth-first) +(defclass E-base1 (E-base0) () :method-invocation-order :breadth-first) +(defclass E-base2 (E-base0) () :method-invocation-order :breadth-first) +(defclass E (E-base1 E-base2) () :method-invocation-order :breadth-first) + +(defmethod eitest-F ((p E)) + (eieio-test-method-store :PRIMARY 'E) + (call-next-method)) + +(defmethod eitest-F ((p E-base0)) + (eieio-test-method-store :PRIMARY 'E-base0) + ;; This should have no next + ;; (when (next-method-p) (call-next-method)) + ) + +(defmethod eitest-F ((p E-base1)) + (eieio-test-method-store :PRIMARY 'E-base1) + (call-next-method)) + +(defmethod eitest-F ((p E-base2)) + (eieio-test-method-store :PRIMARY 'E-base2) + (when (next-method-p) + (call-next-method)) + ) + +(ert-deftest eieio-test-method-order-list-8 () + (let ((eieio-test-method-order-list nil) + (ans '( + (:PRIMARY E) + (:PRIMARY E-base1) + (:PRIMARY E-base2) + (:PRIMARY E-base0) + ))) + (eitest-F (E nil)) + (setq eieio-test-method-order-list (nreverse eieio-test-method-order-list)) + (eieio-test-match ans))) + +;;; Jan's methodinvoke order w/ multiple inheritance and :after methods. +;; +(defclass eitest-Ja () + ()) + +(defmethod initialize-instance :after ((this eitest-Ja) &rest slots) + ;(message "+Ja") + ;; FIXME: Using next-method-p in an after-method is invalid! + (when (next-method-p) + (call-next-method)) + ;(message "-Ja") + ) + +(defclass eitest-Jb () + ()) + +(defmethod initialize-instance :after ((this eitest-Jb) &rest slots) + ;(message "+Jb") + ;; FIXME: Using next-method-p in an after-method is invalid! + (when (next-method-p) + (call-next-method)) + ;(message "-Jb") + ) + +(defclass eitest-Jc (eitest-Jb) + ()) + +(defclass eitest-Jd (eitest-Jc eitest-Ja) + ()) + +(defmethod initialize-instance ((this eitest-Jd) &rest slots) + ;(message "+Jd") + (when (next-method-p) + (call-next-method)) + ;(message "-Jd") + ) + +(ert-deftest eieio-test-method-order-list-9 () + (should (eitest-Jd "test"))) + +;;; call-next-method with replacement arguments across a simple class hierarchy. +;; + +(defclass CNM-0 () + ()) + +(defclass CNM-1-1 (CNM-0) + ()) + +(defclass CNM-1-2 (CNM-0) + ()) + +(defclass CNM-2 (CNM-1-1 CNM-1-2) + ()) + +(defmethod CNM-M ((this CNM-0) args) + (push (cons 'CNM-0 (copy-sequence args)) + eieio-test-call-next-method-arguments) + (when (next-method-p) + (call-next-method + this (cons 'CNM-0 args)))) + +(defmethod CNM-M ((this CNM-1-1) args) + (push (cons 'CNM-1-1 (copy-sequence args)) + eieio-test-call-next-method-arguments) + (when (next-method-p) + (call-next-method + this (cons 'CNM-1-1 args)))) + +(defmethod CNM-M ((this CNM-1-2) args) + (push (cons 'CNM-1-2 (copy-sequence args)) + eieio-test-call-next-method-arguments) + (when (next-method-p) + (call-next-method))) + +(defmethod CNM-M ((this CNM-2) args) + (push (cons 'CNM-2 (copy-sequence args)) + eieio-test-call-next-method-arguments) + (when (next-method-p) + (call-next-method + this (cons 'CNM-2 args)))) + +(ert-deftest eieio-test-method-order-list-10 () + (let ((eieio-test-call-next-method-arguments nil)) + (CNM-M (CNM-2 "") '(INIT)) + (should (equal (eieio-test-arguments-for 'CNM-0) + '(CNM-1-1 CNM-2 INIT))) + (should (equal (eieio-test-arguments-for 'CNM-1-1) + '(CNM-2 INIT))) + (should (equal (eieio-test-arguments-for 'CNM-1-2) + '(CNM-1-1 CNM-2 INIT))) + (should (equal (eieio-test-arguments-for 'CNM-2) + '(INIT))))) + +;;; Check cl-generic integration. + +(cl-defgeneric eieio-test--1 (x y)) + +(ert-deftest eieio-test-cl-generic-1 () + (cl-defgeneric eieio-test--1 (x y)) + (cl-defmethod eieio-test--1 (x y) (list x y)) + (cl-defmethod eieio-test--1 ((_x CNM-0) y) + (cons "CNM-0" (cl-call-next-method 7 y))) + (cl-defmethod eieio-test--1 ((_x CNM-1-1) _y) + (cons "CNM-1-1" (cl-call-next-method))) + (cl-defmethod eieio-test--1 ((_x CNM-1-2) _y) + (cons "CNM-1-2" (cl-call-next-method))) + (cl-defmethod eieio-test--1 ((_x (subclass CNM-1-2)) _y) + (cons "subclass CNM-1-2" (cl-call-next-method))) + (should (equal (eieio-test--1 4 5) '(4 5))) + (should (equal (eieio-test--1 (make-instance 'CNM-0) 5) + '("CNM-0" 7 5))) + (should (equal (eieio-test--1 (make-instance 'CNM-2) 5) + '("CNM-1-1" "CNM-1-2" "CNM-0" 7 5))) + (should (equal (eieio-test--1 'CNM-2 6) '("subclass CNM-1-2" CNM-2 6)))) diff --git a/test/lisp/emacs-lisp/eieio-tests/eieio-test-persist.el b/test/lisp/emacs-lisp/eieio-tests/eieio-test-persist.el new file mode 100644 index 00000000000..2f8d65e512e --- /dev/null +++ b/test/lisp/emacs-lisp/eieio-tests/eieio-test-persist.el @@ -0,0 +1,219 @@ +;;; eieio-persist.el --- Tests for eieio-persistent class + +;; Copyright (C) 2011-2016 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <eric@siege-engine.com> + +;; 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: +;; +;; The eieio-persistent base-class provides a vital service, that +;; could be used to accidentally load in malicious code. As such, +;; something as simple as calling eval on the generated code can't be +;; used. These tests exercises various flavors of data that might be +;; in a persistent object, and tries to save/load them. + +;;; Code: +(require 'eieio) +(require 'eieio-base) +(require 'ert) + +(defun eieio--attribute-to-initarg (class attribute) + "In CLASS, convert the ATTRIBUTE into the corresponding init argument tag. +This is usually a symbol that starts with `:'." + (let ((tuple (rassoc attribute (eieio--class-initarg-tuples class)))) + (if tuple + (car tuple) + nil))) + +(defun persist-test-save-and-compare (original) + "Compare the object ORIGINAL against the one read fromdisk." + + (eieio-persistent-save original) + + (let* ((file (oref original file)) + (class (eieio-object-class original)) + (fromdisk (eieio-persistent-read file class)) + (cv (cl--find-class class)) + (slots (eieio--class-slots cv)) + ) + (unless (object-of-class-p fromdisk class) + (error "Persistent class %S != original class %S" + (eieio-object-class fromdisk) + class)) + + (dotimes (i (length slots)) + (let* ((slot (aref slots i)) + (oneslot (cl--slot-descriptor-name slot)) + (origvalue (eieio-oref original oneslot)) + (fromdiskvalue (eieio-oref fromdisk oneslot)) + (initarg-p (eieio--attribute-to-initarg + (cl--find-class class) oneslot)) + ) + + (if initarg-p + (unless (equal origvalue fromdiskvalue) + (error "Slot %S Original Val %S != Persistent Val %S" + oneslot origvalue fromdiskvalue)) + ;; Else !initarg-p + (unless (equal (cl--slot-descriptor-initform slot) fromdiskvalue) + (error "Slot %S Persistent Val %S != Default Value %S" + oneslot fromdiskvalue (cl--slot-descriptor-initform slot)))) + )))) + +;;; Simple Case +;; +;; Simplest case is a mix of slots with and without initargs. + +(defclass persist-simple (eieio-persistent) + ((slot1 :initarg :slot1 + :type symbol + :initform moose) + (slot2 :initarg :slot2 + :initform "foo") + (slot3 :initform 2)) + "A Persistent object with two initializable slots, and one not.") + +(ert-deftest eieio-test-persist-simple-1 () + (let ((persist-simple-1 + (persist-simple "simple 1" :slot1 'goose :slot2 "testing" + :file (concat default-directory "test-ps1.pt")))) + (should persist-simple-1) + + ;; When the slot w/out an initarg has not been changed + (persist-test-save-and-compare persist-simple-1) + + ;; When the slot w/out an initarg HAS been changed + (oset persist-simple-1 slot3 3) + (persist-test-save-and-compare persist-simple-1) + (delete-file (oref persist-simple-1 file)))) + +;;; Slot Writers +;; +;; Replica of the test in eieio-tests.el - + +(defclass persist-:printer (eieio-persistent) + ((slot1 :initarg :slot1 + :initform 'moose + :printer PO-slot1-printer) + (slot2 :initarg :slot2 + :initform "foo")) + "A Persistent object with two initializable slots.") + +(defun PO-slot1-printer (slotvalue) + "Print the slot value SLOTVALUE to stdout. +Assume SLOTVALUE is a symbol of some sort." + (princ "'") + (princ (symbol-name slotvalue)) + (princ " ;; RAN PRINTER") + nil) + +(ert-deftest eieio-test-persist-printer () + (let ((persist-:printer-1 + (persist-:printer "persist" :slot1 'goose :slot2 "testing" + :file (concat default-directory "test-ps2.pt")))) + (should persist-:printer-1) + (persist-test-save-and-compare persist-:printer-1) + + (let* ((find-file-hook nil) + (tbuff (find-file-noselect "test-ps2.pt")) + ) + (condition-case nil + (unwind-protect + (with-current-buffer tbuff + (goto-char (point-min)) + (re-search-forward "RAN PRINTER")) + (kill-buffer tbuff)) + (error "persist-:printer-1's Slot1 printer function didn't work."))) + (delete-file (oref persist-:printer-1 file)))) + +;;; Slot with Object +;; +;; A slot that contains another object that isn't persistent +(defclass persist-not-persistent () + ((slot1 :initarg :slot1 + :initform 1) + (slot2 :initform 2)) + "Class for testing persistent saving of an object that isn't +persistent. This class is instead used as a slot value in a +persistent class.") + +(defclass persistent-with-objs-slot (eieio-persistent) + ((pnp :initarg :pnp + :type (or null persist-not-persistent) + :initform nil)) + "Class for testing the saving of slots with objects in them.") + +(ert-deftest eieio-test-non-persistent-as-slot () + (let ((persist-wos + (persistent-with-objs-slot + "persist wos 1" + :pnp (persist-not-persistent "pnp 1" :slot1 3) + :file (concat default-directory "test-ps3.pt")))) + + (persist-test-save-and-compare persist-wos) + (delete-file (oref persist-wos file)))) + +;;; Slot with Object child of :type +;; +;; A slot that contains another object that isn't persistent +(defclass persist-not-persistent-subclass (persist-not-persistent) + ((slot3 :initarg :slot1 + :initform 1) + (slot4 :initform 2)) + "Class for testing persistent saving of an object subclass that isn't +persistent. This class is instead used as a slot value in a +persistent class.") + +(defclass persistent-with-objs-slot-subs (eieio-persistent) + ((pnp :initarg :pnp + :type (or null persist-not-persistent) + :initform nil)) + "Class for testing the saving of slots with objects in them.") + +(ert-deftest eieio-test-non-persistent-as-slot-child () + (let ((persist-woss + (persistent-with-objs-slot-subs + "persist woss 1" + :pnp (persist-not-persistent-subclass "pnps 1" :slot1 3) + :file (concat default-directory "test-ps4.pt")))) + + (persist-test-save-and-compare persist-woss) + (delete-file (oref persist-woss file)))) + +;;; Slot with a list of Objects +;; +;; A slot that contains another object that isn't persistent +(defclass persistent-with-objs-list-slot (eieio-persistent) + ((pnp :initarg :pnp + :type (list-of persist-not-persistent) + :initform nil)) + "Class for testing the saving of slots with objects in them.") + +(ert-deftest eieio-test-slot-with-list-of-objects () + (let ((persist-wols + (persistent-with-objs-list-slot + "persist wols 1" + :pnp (list (persist-not-persistent "pnp 1" :slot1 3) + (persist-not-persistent "pnp 2" :slot1 4) + (persist-not-persistent "pnp 3" :slot1 5)) + :file (concat default-directory "test-ps5.pt")))) + + (persist-test-save-and-compare persist-wols) + (delete-file (oref persist-wols file)))) + +;;; eieio-test-persist.el ends here diff --git a/test/lisp/emacs-lisp/eieio-tests/eieio-tests.el b/test/lisp/emacs-lisp/eieio-tests/eieio-tests.el new file mode 100644 index 00000000000..9665beb490e --- /dev/null +++ b/test/lisp/emacs-lisp/eieio-tests/eieio-tests.el @@ -0,0 +1,906 @@ +;;; eieio-tests.el -- eieio tests routines + +;; Copyright (C) 1999-2003, 2005-2010, 2012-2016 Free Software +;; Foundation, Inc. + +;; Author: Eric M. Ludlam <zappo@gnu.org> + +;; 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: +;; +;; Test the various features of EIEIO. + +(require 'ert) +(require 'eieio) +(require 'eieio-base) +(require 'eieio-opt) + +(eval-when-compile (require 'cl-lib)) + +;;; Code: +;; Set up some test classes +(defclass class-a () + ((water :initarg :water + :initform h20 + :type symbol + :documentation "Detail about water.") + (classslot :initform penguin + :type symbol + :documentation "A class allocated slot." + :allocation :class) + (test-tag :initform nil + :documentation "Used to make sure methods are called.") + (self :initform nil + :type (or null class-a) + :documentation "Test self referencing types.") + ) + "Class A") + +(defclass class-b () + ((land :initform "Sc" + :type string + :documentation "Detail about land.")) + "Class B") + +(defclass class-ab (class-a class-b) + ((amphibian :initform "frog" + :documentation "Detail about amphibian on land and water.")) + "Class A and B combined.") + +(defclass class-c () + ((slot-1 :initarg :moose + :initform moose + :type symbol + :allocation :instance + :documentation "First slot testing slot arguments." + :custom symbol + :label "Wild Animal" + :group borg + :protection :public) + (slot-2 :initarg :penguin + :initform "penguin" + :type string + :allocation :instance + :documentation "Second slot testing slot arguments." + :custom string + :label "Wild bird" + :group vorlon + :accessor get-slot-2 + :protection :private) + (slot-3 :initarg :emu + :initform emu + :type symbol + :allocation :class + :documentation "Third slot test class allocated accessor" + :custom symbol + :label "Fuzz" + :group tokra + :accessor get-slot-3 + :protection :private) + ) + (:custom-groups (foo)) + "A class for testing slot arguments." + ) + +(defclass class-subc (class-c) + ((slot-1 ;; :initform moose - don't override this + ) + (slot-2 :initform "linux" ;; Do override this one + :protection :private + )) + "A class for testing slot arguments.") + +;;; Defining a class with a slot tag error +;; +;; Temporarily disable this test because of macro expansion changes in +;; current Emacs trunk. It can be re-enabled when we have moved +;; `eieio-defclass' into the `defclass' macro and the +;; `eval-and-compile' there is removed. + +;; (let ((eieio-error-unsupported-class-tags t)) +;; (condition-case nil +;; (progn +;; (defclass class-error () +;; ((error-slot :initarg :error-slot +;; :badslottag 1)) +;; "A class with a bad slot tag.") +;; (error "No error was thrown for badslottag")) +;; (invalid-slot-type nil))) + +;; (let ((eieio-error-unsupported-class-tags nil)) +;; (condition-case nil +;; (progn +;; (defclass class-error () +;; ((error-slot :initarg :error-slot +;; :badslottag 1)) +;; "A class with a bad slot tag.")) +;; (invalid-slot-type +;; (error "invalid-slot-type thrown when eieio-error-unsupported-class-tags is nil") +;; ))) + +(ert-deftest eieio-test-01-mix-alloc-initarg () + ;; Only run this test if the message framework thingy works. + (when (and (message "foo") (string= "foo" (current-message))) + + ;; Defining this class should generate a warning(!) message that + ;; you should not mix :initarg with class allocated slots. + (defclass class-alloc-initarg () + ((throwwarning :initarg :throwwarning + :allocation :class)) + "Throw a warning mixing allocation class and an initarg.") + + ;; Check that message is there + (should (current-message)) + (should (string-match "Class allocated slots do not need :initarg" + (current-message))))) + +(defclass abstract-class () + ((some-slot :initarg :some-slot + :initform nil + :documentation "A slot.")) + :documentation "An abstract class." + :abstract t) + +(ert-deftest eieio-test-02-abstract-class () + ;; Abstract classes cannot be instantiated, so this should throw an + ;; error + (should-error (abstract-class))) + +(defgeneric generic1 () "First generic function") + +(ert-deftest eieio-test-03-generics () + (defun anormalfunction () "A plain function for error testing." nil) + (should-error + (progn + (defgeneric anormalfunction () + "Attempt to turn it into a generic."))) + + ;; Check that generic-p works + (should (generic-p 'generic1)) + + (defmethod generic1 ((c class-a)) + "Method on generic1." + 'monkey) + + (defmethod generic1 (not-an-object) + "Method generic1 that can take a non-object." + not-an-object) + + (let ((ans-obj (generic1 (class-a))) + (ans-num (generic1 666))) + (should (eq ans-obj 'monkey)) + (should (eq ans-num 666)))) + +(defclass static-method-class () + ((some-slot :initform nil + :allocation :class + :documentation "A slot.")) + :documentation "A class used for testing static methods.") + +(defmethod static-method-class-method :STATIC ((c static-method-class) value) + "Test static methods. +Argument C is the class bound to this static method." + (if (eieio-object-p c) (setq c (eieio-object-class c))) + (oset-default c some-slot value)) + +(ert-deftest eieio-test-04-static-method () + ;; Call static method on a class and see if it worked + (static-method-class-method 'static-method-class 'class) + (should (eq (oref-default 'static-method-class some-slot) 'class)) + (static-method-class-method (static-method-class) 'object) + (should (eq (oref-default 'static-method-class some-slot) 'object))) + +(ert-deftest eieio-test-05-static-method-2 () + (defclass static-method-class-2 (static-method-class) + () + "A second class after the previous for static methods.") + + (defmethod static-method-class-method :STATIC ((c static-method-class-2) value) + "Test static methods. +Argument C is the class bound to this static method." + (if (eieio-object-p c) (setq c (eieio-object-class c))) + (oset-default c some-slot (intern (concat "moose-" (symbol-name value))))) + + (static-method-class-method 'static-method-class-2 'class) + (should (eq (oref-default 'static-method-class-2 some-slot) 'moose-class)) + (static-method-class-method (static-method-class-2) 'object) + (should (eq (oref-default 'static-method-class-2 some-slot) 'moose-object))) + + +;;; Perform method testing +;; + +;;; Multiple Inheritance, and method signal testing +;; +(defvar eitest-ab nil) +(defvar eitest-a nil) +(defvar eitest-b nil) +(ert-deftest eieio-test-06-allocate-objects () + ;; allocate an object to use + (should (setq eitest-ab (class-ab))) + (should (setq eitest-a (class-a))) + (should (setq eitest-b (class-b)))) + +(ert-deftest eieio-test-07-make-instance () + (should (make-instance 'class-ab)) + (should (make-instance 'class-a :water 'cho)) + (should (make-instance 'class-b))) + +(defmethod class-cn ((a class-a)) + "Try calling `call-next-method' when there isn't one. +Argument A is object of type symbol `class-a'." + (call-next-method)) + +(defmethod no-next-method ((a class-a) &rest args) + "Override signal throwing for variable `class-a'. +Argument A is the object of class variable `class-a'." + 'moose) + +(ert-deftest eieio-test-08-call-next-method () + ;; Play with call-next-method + (should (eq (class-cn eitest-ab) 'moose))) + +(defmethod no-applicable-method ((b class-b) method &rest args) + "No need. +Argument B is for booger. +METHOD is the method that was attempting to be called." + 'moose) + +(ert-deftest eieio-test-09-no-applicable-method () + ;; Non-existing methods. + (should (eq (class-cn eitest-b) 'moose))) + +(defmethod class-fun ((a class-a)) + "Fun with class A." + 'moose) + +(defmethod class-fun ((b class-b)) + "Fun with class B." + (error "Class B fun should not be called") + ) + +(defmethod class-fun-foo ((b class-b)) + "Foo Fun with class B." + 'moose) + +(defmethod class-fun2 ((a class-a)) + "More fun with class A." + 'moose) + +(defmethod class-fun2 ((b class-b)) + "More fun with class B." + (error "Class B fun2 should not be called") + ) + +(defmethod class-fun2 ((ab class-ab)) + "More fun with class AB." + (call-next-method)) + +;; How about if B is the only slot? +(defmethod class-fun3 ((b class-b)) + "Even More fun with class B." + 'moose) + +(defmethod class-fun3 ((ab class-ab)) + "Even More fun with class AB." + (call-next-method)) + +(ert-deftest eieio-test-10-multiple-inheritance () + ;; play with methods and mi + (should (eq (class-fun eitest-ab) 'moose)) + (should (eq (class-fun-foo eitest-ab) 'moose)) + ;; Play with next-method and mi + (should (eq (class-fun2 eitest-ab) 'moose)) + (should (eq (class-fun3 eitest-ab) 'moose))) + +(ert-deftest eieio-test-11-self () + ;; Try the self referencing test + (should (oset eitest-a self eitest-a)) + (should (oset eitest-ab self eitest-ab))) + + +(defvar class-fun-value-seq '()) +(defmethod class-fun-value :BEFORE ((a class-a)) + "Return `before', and push `before' in `class-fun-value-seq'." + (push 'before class-fun-value-seq) + 'before) + +(defmethod class-fun-value :PRIMARY ((a class-a)) + "Return `primary', and push `primary' in `class-fun-value-seq'." + (push 'primary class-fun-value-seq) + 'primary) + +(defmethod class-fun-value :AFTER ((a class-a)) + "Return `after', and push `after' in `class-fun-value-seq'." + (push 'after class-fun-value-seq) + 'after) + +(ert-deftest eieio-test-12-generic-function-call () + ;; Test value of a generic function call + ;; + (let* ((class-fun-value-seq nil) + (value (class-fun-value eitest-a))) + ;; Test if generic function call returns the primary method's value + (should (eq value 'primary)) + ;; Make sure :before and :after methods were run + (should (equal class-fun-value-seq '(after primary before))))) + +;;; Test initialization methods +;; + +(ert-deftest eieio-test-13-init-methods () + (defmethod initialize-instance ((a class-a) &rest slots) + "Initialize the slots of class-a." + (call-next-method) + (if (/= (oref a test-tag) 1) + (error "shared-initialize test failed.")) + (oset a test-tag 2)) + + (defmethod shared-initialize ((a class-a) &rest slots) + "Shared initialize method for class-a." + (call-next-method) + (oset a test-tag 1)) + + (let ((ca (class-a))) + (should-not (/= (oref ca test-tag) 2)))) + + +;;; Perform slot testing +;; +(ert-deftest eieio-test-14-slots () + ;; Check slot existence + (should (oref eitest-ab water)) + (should (oref eitest-ab land)) + (should (oref eitest-ab amphibian))) + +(ert-deftest eieio-test-15-slot-missing () + + (defmethod slot-missing ((ab class-ab) &rest foo) + "If a slot in AB is unbound, return something cool. FOO." + 'moose) + + (should (eq (oref eitest-ab ooga-booga) 'moose)) + (should-error (oref eitest-a ooga-booga) :type 'invalid-slot-name)) + +(ert-deftest eieio-test-16-slot-makeunbound () + (slot-makeunbound eitest-a 'water) + ;; Should now be unbound + (should-not (slot-boundp eitest-a 'water)) + ;; But should still exist + (should (slot-exists-p eitest-a 'water)) + (should-not (slot-exists-p eitest-a 'moose)) + ;; oref of unbound slot must fail + (should-error (oref eitest-a water) :type 'unbound-slot)) + +(defvar eitest-vsca nil) +(defvar eitest-vscb nil) +(defclass virtual-slot-class () + ((base-value :initarg :base-value)) + "Class has real slot :base-value and simulated slot :derived-value.") +(defmethod slot-missing ((vsc virtual-slot-class) + slot-name operation &optional new-value) + "Simulate virtual slot derived-value." + (cond + ((or (eq slot-name :derived-value) + (eq slot-name 'derived-value)) + (with-slots (base-value) vsc + (if (eq operation 'oref) + (+ base-value 1) + (setq base-value (- new-value 1))))) + (t (call-next-method)))) + +(ert-deftest eieio-test-17-virtual-slot () + (setq eitest-vsca (virtual-slot-class :base-value 1)) + ;; Check slot values + (should (= (oref eitest-vsca base-value) 1)) + (should (= (oref eitest-vsca :derived-value) 2)) + + (oset eitest-vsca derived-value 3) + (should (= (oref eitest-vsca base-value) 2)) + (should (= (oref eitest-vsca :derived-value) 3)) + + (oset eitest-vsca base-value 3) + (should (= (oref eitest-vsca base-value) 3)) + (should (= (oref eitest-vsca :derived-value) 4)) + + ;; should also be possible to initialize instance using virtual slot + + (setq eitest-vscb (virtual-slot-class :derived-value 5)) + (should (= (oref eitest-vscb base-value) 4)) + (should (= (oref eitest-vscb :derived-value) 5))) + +(ert-deftest eieio-test-18-slot-unbound () + + (defmethod slot-unbound ((a class-a) &rest foo) + "If a slot in A is unbound, ignore FOO." + 'moose) + + (should (eq (oref eitest-a water) 'moose)) + + ;; Check if oset of unbound works + (oset eitest-a water 'moose) + (should (eq (oref eitest-a water) 'moose)) + + ;; oref/oref-default comparison + (should-not (eq (oref eitest-a water) (oref-default eitest-a water))) + + ;; oset-default -> oref/oref-default comparison + (oset-default (eieio-object-class eitest-a) water 'moose) + (should (eq (oref eitest-a water) (oref-default eitest-a water))) + + ;; After setting 'water to 'moose, make sure a new object has + ;; the right stuff. + (oset-default (eieio-object-class eitest-a) water 'penguin) + (should (eq (oref (class-a) water) 'penguin)) + + ;; Revert the above + (defmethod slot-unbound ((a class-a) &rest foo) + "If a slot in A is unbound, ignore FOO." + ;; Disable the old slot-unbound so we can run this test + ;; more than once + (call-next-method))) + +(ert-deftest eieio-test-19-slot-type-checking () + ;; Slot type checking + ;; We should not be able to set a string here + (should-error (oset eitest-ab water "a string, not a symbol") :type 'invalid-slot-type) + (should-error (oset eitest-ab classslot "a string, not a symbol") :type 'invalid-slot-type) + (should-error (class-a :water "a string not a symbol") :type 'invalid-slot-type)) + +(ert-deftest eieio-test-20-class-allocated-slots () + ;; Test out class allocated slots + (defvar eitest-aa nil) + (setq eitest-aa (class-a)) + + ;; Make sure class slots do not track between objects + (let ((newval 'moose)) + (oset eitest-aa classslot newval) + (should (eq (oref eitest-a classslot) newval)) + (should (eq (oref eitest-aa classslot) newval))) + + ;; Slot should be bound + (should (slot-boundp eitest-a 'classslot)) + (should (slot-boundp 'class-a 'classslot)) + + (slot-makeunbound eitest-a 'classslot) + + (should-not (slot-boundp eitest-a 'classslot)) + (should-not (slot-boundp 'class-a 'classslot))) + + +(defvar eieio-test-permuting-value nil) +(defvar eitest-pvinit nil) +(eval-and-compile + (setq eieio-test-permuting-value 1)) + +(defclass inittest nil + ((staticval :initform 1) + (symval :initform eieio-test-permuting-value) + (evalval :initform (symbol-value 'eieio-test-permuting-value)) + (evalnow :initform (symbol-value 'eieio-test-permuting-value) + :allocation :class) + ) + "Test initforms that eval.") + +(ert-deftest eieio-test-21-eval-at-construction-time () + ;; initforms that need to be evalled at construction time. + (setq eieio-test-permuting-value 2) + (setq eitest-pvinit (inittest)) + + (should (eq (oref eitest-pvinit staticval) 1)) + (should (eq (oref eitest-pvinit symval) 'eieio-test-permuting-value)) + (should (eq (oref eitest-pvinit evalval) 2)) + (should (eq (oref eitest-pvinit evalnow) 1))) + +(defvar eitest-tests nil) + +(ert-deftest eieio-test-22-init-forms-dont-match-runnable () + ;; Init forms with types that don't match the runnable. + (defclass eitest-subordinate nil + ((text :initform "" :type string)) + "Test class that will be a calculated value.") + + (defclass eitest-superior nil + ((sub :initform (eitest-subordinate) + :type eitest-subordinate)) + "A class with an initform that creates a class.") + + (should (setq eitest-tests (eitest-superior))) + + (should-error + (eval + '(defclass broken-init nil + ((broken :initform 1 + :type string)) + "This class should break.")) + :type 'invalid-slot-type)) + +(ert-deftest eieio-test-23-inheritance-check () + (should (child-of-class-p 'class-ab 'class-a)) + (should (child-of-class-p 'class-ab 'class-b)) + (should (object-of-class-p eitest-a 'class-a)) + (should (object-of-class-p eitest-ab 'class-a)) + (should (object-of-class-p eitest-ab 'class-b)) + (should (object-of-class-p eitest-ab 'class-ab)) + (should (eq (eieio-class-parents 'class-a) nil)) + (should (equal (eieio-class-parents 'class-ab) + (mapcar #'find-class '(class-a class-b)))) + (should (same-class-p eitest-a 'class-a)) + (should (class-a-p eitest-a)) + (should (not (class-a-p eitest-ab))) + (should (cl-typep eitest-a 'class-a)) + (should (cl-typep eitest-ab 'class-a)) + (should (not (class-a-p "foo"))) + (should (not (cl-typep "foo" 'class-a)))) + +(ert-deftest eieio-test-24-object-predicates () + (let ((listooa (list (class-ab) (class-a))) + (listoob (list (class-ab) (class-b)))) + (should (cl-typep listooa '(list-of class-a))) + (should (cl-typep listoob '(list-of class-b))) + (should-not (cl-typep listooa '(list-of class-b))) + (should-not (cl-typep listoob '(list-of class-a))))) + +(defvar eitest-t1 nil) +(ert-deftest eieio-test-25-slot-tests () + (setq eitest-t1 (class-c)) + ;; Slot initialization + (should (eq (oref eitest-t1 slot-1) 'moose)) + ;; Accessing via the initarg name is deprecated! + ;; (should (eq (oref eitest-t1 :moose) 'moose)) + ;; Don't pass reference of private slot + ;;PRIVATE (should-error (oref eitest-t1 slot-2) :type 'invalid-slot-name) + ;; Check private slot accessor + (should (string= (get-slot-2 eitest-t1) "penguin")) + ;; Pass string instead of symbol + (should-error (class-c :moose "not a symbol") :type 'invalid-slot-type) + (should (eq (get-slot-3 eitest-t1) 'emu)) + (should (eq (get-slot-3 'class-c) 'emu)) + ;; Check setf + (setf (get-slot-3 eitest-t1) 'setf-emu) + (should (eq (get-slot-3 eitest-t1) 'setf-emu)) + ;; Roll back + (setf (get-slot-3 eitest-t1) 'emu)) + +(defvar eitest-t2 nil) +(ert-deftest eieio-test-26-default-inheritance () + ;; See previous test, nor for subclass + (setq eitest-t2 (class-subc)) + (should (eq (oref eitest-t2 slot-1) 'moose)) + ;; Accessing via the initarg name is deprecated! + ;;(should (eq (oref eitest-t2 :moose) 'moose)) + (should (string= (get-slot-2 eitest-t2) "linux")) + ;;PRIVATE (should-error (oref eitest-t2 slot-2) :type 'invalid-slot-name) + (should (string= (get-slot-2 eitest-t2) "linux")) + (should-error (class-subc :moose "not a symbol") :type 'invalid-slot-type)) + +;;(ert-deftest eieio-test-27-inherited-new-value () + ;;; HACK ALERT: The new value of a class slot is inherited by the + ;; subclass! This is probably a bug. We should either share the slot + ;; so sets on the baseclass change the subclass, or we should inherit + ;; the original value. +;; (should (eq (get-slot-3 eitest-t2) 'emu)) +;; (should (eq (get-slot-3 class-subc) 'emu)) +;; (setf (get-slot-3 eitest-t2) 'setf-emu) +;; (should (eq (get-slot-3 eitest-t2) 'setf-emu))) + +;; Slot protection +(defclass prot-0 () + () + "Protection testing baseclass.") + +(defmethod prot0-slot-2 ((s2 prot-0)) + "Try to access slot-2 from this class which doesn't have it. +The object S2 passed in will be of class prot-1, which does have +the slot. This could be allowed, and currently is in EIEIO. +Needed by the eieio persistent base class." + (oref s2 slot-2)) + +(defclass prot-1 (prot-0) + ((slot-1 :initarg :slot-1 + :initform nil + :protection :public) + (slot-2 :initarg :slot-2 + :initform nil + :protection :protected) + (slot-3 :initarg :slot-3 + :initform nil + :protection :private)) + "A class for testing the :protection option.") + +(defclass prot-2 (prot-1) + nil + "A class for testing the :protection option.") + +(defmethod prot1-slot-2 ((s2 prot-1)) + "Try to access slot-2 in S2." + (oref s2 slot-2)) + +(defmethod prot1-slot-2 ((s2 prot-2)) + "Try to access slot-2 in S2." + (oref s2 slot-2)) + +(defmethod prot1-slot-3-only ((s2 prot-1)) + "Try to access slot-3 in S2. +Do not override for `prot-2'." + (oref s2 slot-3)) + +(defmethod prot1-slot-3 ((s2 prot-1)) + "Try to access slot-3 in S2." + (oref s2 slot-3)) + +(defmethod prot1-slot-3 ((s2 prot-2)) + "Try to access slot-3 in S2." + (oref s2 slot-3)) + +(defvar eitest-p1 nil) +(defvar eitest-p2 nil) +(ert-deftest eieio-test-28-slot-protection () + (setq eitest-p1 (prot-1)) + (setq eitest-p2 (prot-2)) + ;; Access public slots + (oref eitest-p1 slot-1) + (oref eitest-p2 slot-1) + ;; Accessing protected slot out of context used to fail, but we dropped this + ;; feature, since it was underused and no one noticed that the check was + ;; incorrect (much too loose). + ;;PROTECTED (should-error (oref eitest-p1 slot-2) :type 'invalid-slot-name) + ;; Access protected slot in method + (prot1-slot-2 eitest-p1) + ;; Protected slot in subclass method + (prot1-slot-2 eitest-p2) + ;; Protected slot from parent class method + (prot0-slot-2 eitest-p1) + ;; Accessing private slot out of context used to fail, but we dropped this + ;; feature, since it was not used. + ;;PRIVATE (should-error (oref eitest-p1 slot-3) :type 'invalid-slot-name) + ;; Access private slot in method + (prot1-slot-3 eitest-p1) + ;; Access private slot in subclass method must fail + ;;PRIVATE (should-error (prot1-slot-3 eitest-p2) :type 'invalid-slot-name) + ;; Access private slot by same class + (prot1-slot-3-only eitest-p1) + ;; Access private slot by subclass in sameclass method + (prot1-slot-3-only eitest-p2)) + +;;; eieio-instance-inheritor +;; Test to make sure this works. +(defclass II (eieio-instance-inheritor) + ((slot1 :initform 1) + (slot2) + (slot3)) + "Instance Inheritor test class.") + +(defvar eitest-II1 nil) +(defvar eitest-II2 nil) +(defvar eitest-II3 nil) +(ert-deftest eieio-test-29-instance-inheritor () + (setq eitest-II1 (II "II Test.")) + (oset eitest-II1 slot2 'cat) + (setq eitest-II2 (clone eitest-II1 "eitest-II2 Test.")) + (oset eitest-II2 slot1 'moose) + (setq eitest-II3 (clone eitest-II2 "eitest-II3 Test.")) + (oset eitest-II3 slot3 'penguin) + + ;; Test level 1 inheritance + (should (eq (oref eitest-II3 slot1) 'moose)) + ;; Test level 2 inheritance + (should (eq (oref eitest-II3 slot2) 'cat)) + ;; Test level 0 inheritance + (should (eq (oref eitest-II3 slot3) 'penguin))) + +(defclass slotattr-base () + ((initform :initform init) + (type :type list) + (initarg :initarg :initarg) + (protection :protection :private) + (custom :custom (repeat string) + :label "Custom Strings" + :group moose) + (docstring :documentation + "Replace the doc-string for this property.") + (printer :printer printer1) + ) + "Baseclass we will attempt to subclass. +Subclasses to override slot attributes.") + +(defclass slotattr-ok (slotattr-base) + ((initform :initform no-init) + (initarg :initarg :initblarg) + (custom :custom string + :label "One String" + :group cow) + (docstring :documentation + "A better doc string for this class.") + (printer :printer printer2) + ) + "This class should allow overriding of various slot attributes.") + + +(ert-deftest eieio-test-30-slot-attribute-override () + ;; Subclass should not override :protection slot attribute + ;;PROTECTION is gone. + ;;(should-error + ;; (eval + ;; '(defclass slotattr-fail (slotattr-base) + ;; ((protection :protection :public) + ;; ) + ;; "This class should throw an error."))) + + ;; Subclass should not override :type slot attribute + (should-error + (eval + '(defclass slotattr-fail (slotattr-base) + ((type :type string) + ) + "This class should throw an error."))) + + ;; Initform should override instance allocation + (let ((obj (slotattr-ok))) + (should (eq (oref obj initform) 'no-init)))) + +(defclass slotattr-class-base () + ((initform :allocation :class + :initform init) + (type :allocation :class + :type list) + (initarg :allocation :class + :initarg :initarg) + (protection :allocation :class + :protection :private) + (custom :allocation :class + :custom (repeat string) + :label "Custom Strings" + :group moose) + (docstring :allocation :class + :documentation + "Replace the doc-string for this property.") + ) + "Baseclass we will attempt to subclass. +Subclasses to override slot attributes.") + +(defclass slotattr-class-ok (slotattr-class-base) + ((initform :initform no-init) + (initarg :initarg :initblarg) + (custom :custom string + :label "One String" + :group cow) + (docstring :documentation + "A better doc string for this class.") + ) + "This class should allow overriding of various slot attributes.") + + +(ert-deftest eieio-test-31-slot-attribute-override-class-allocation () + ;; Same as test-30, but with class allocation + ;;PROTECTION is gone. + ;;(should-error + ;; (eval + ;; '(defclass slotattr-fail (slotattr-class-base) + ;; ((protection :protection :public) + ;; ) + ;; "This class should throw an error."))) + (should-error + (eval + '(defclass slotattr-fail (slotattr-class-base) + ((type :type string) + ) + "This class should throw an error."))) + (should (eq (oref-default 'slotattr-class-ok initform) 'no-init))) + +(ert-deftest eieio-test-32-slot-attribute-override-2 () + (let* ((cv (cl--find-class 'slotattr-ok)) + (slots (eieio--class-slots cv)) + (args (eieio--class-initarg-tuples cv))) + ;; :initarg should override for subclass + (should (assoc :initblarg args)) + + (dotimes (i (length slots)) + (let* ((slot (aref slots i)) + (props (cl--slot-descriptor-props slot))) + (cond + ((eq (cl--slot-descriptor-name slot) 'custom) + ;; Custom slot attributes must override + (should (eq (alist-get :custom props) 'string)) + ;; Custom label slot attribute must override + (should (string= (alist-get :label props) "One String")) + (let ((grp (alist-get :group props))) + ;; Custom group slot attribute must combine + (should (and (memq 'moose grp) (memq 'cow grp))))) + (t nil)))))) + +(defvar eitest-CLONETEST1 nil) +(defvar eitest-CLONETEST2 nil) + +(ert-deftest eieio-test-32-test-clone-boring-objects () + ;; A simple make instance with EIEIO extension + (should (setq eitest-CLONETEST1 (make-instance 'class-a))) + (should (setq eitest-CLONETEST2 (clone eitest-CLONETEST1))) + + ;; CLOS form of make-instance + (should (setq eitest-CLONETEST1 (make-instance 'class-a))) + (should (setq eitest-CLONETEST2 (clone eitest-CLONETEST1)))) + +(defclass IT (eieio-instance-tracker) + ((tracking-symbol :initform IT-list) + (slot1 :initform 'die)) + "Instance Tracker test object.") + +(ert-deftest eieio-test-33-instance-tracker () + (let (IT-list IT1) + (should (setq IT1 (IT))) + ;; The instance tracker must find this + (should (eieio-instance-tracker-find 'die 'slot1 'IT-list)) + ;; Test deletion + (delete-instance IT1) + (should-not (eieio-instance-tracker-find 'die 'slot1 'IT-list)))) + +(defclass SINGLE (eieio-singleton) + ((a-slot :initarg :a-slot :initform t)) + "A Singleton test object.") + +(ert-deftest eieio-test-34-singletons () + (let ((obj1 (SINGLE)) + (obj2 (SINGLE))) + (should (eieio-object-p obj1)) + (should (eieio-object-p obj2)) + (should (eq obj1 obj2)) + (should (oref obj1 a-slot)))) + +(defclass NAMED (eieio-named) + ((some-slot :initform nil) + ) + "A class inheriting from eieio-named.") + +(ert-deftest eieio-test-35-named-object () + (let (N) + (should (setq N (NAMED :object-name "Foo"))) + (should (string= "Foo" (oref N object-name))) + (should-error (oref N missing-slot) :type 'invalid-slot-name) + (oset N object-name "NewName") + (should (string= "NewName" (oref N object-name))))) + +(defclass opt-test1 () + () + "Abstract base class" + :abstract t) + +(defclass opt-test2 (opt-test1) + () + "Instantiable child") + +(ert-deftest eieio-test-36-build-class-alist () + (should (= (length (eieio-build-class-alist 'opt-test1 nil)) 2)) + (should (= (length (eieio-build-class-alist 'opt-test1 t)) 1))) + +(defclass eieio--testing () ()) + +(defmethod constructor :static ((_x eieio--testing) newname &rest _args) + (list newname 2)) + +(ert-deftest eieio-test-37-obsolete-name-in-constructor () + (should (equal (eieio--testing "toto") '("toto" 2)))) + +(ert-deftest eieio-autoload () + "Tests to see whether reftex-auc has been autoloaded" + (should + (fboundp 'eieio--defalias))) + + +(provide 'eieio-tests) + +;;; eieio-tests.el ends here diff --git a/test/lisp/emacs-lisp/ert-tests.el b/test/lisp/emacs-lisp/ert-tests.el new file mode 100644 index 00000000000..5d3675553d7 --- /dev/null +++ b/test/lisp/emacs-lisp/ert-tests.el @@ -0,0 +1,843 @@ +;;; ert-tests.el --- ERT's self-tests -*- lexical-binding: t -*- + +;; Copyright (C) 2007-2008, 2010-2016 Free Software Foundation, Inc. + +;; Author: Christian Ohler <ohler@gnu.org> + +;; This file is part of GNU Emacs. + +;; 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/'. + +;;; Commentary: + +;; This file is part of ERT, the Emacs Lisp Regression Testing tool. +;; See ert.el or the texinfo manual for more details. + +;;; Code: + +(require 'cl-lib) +(require 'ert) + +;;; Self-test that doesn't rely on ERT, for bootstrapping. + +;; This is used to test that bodies actually run. +(defvar ert--test-body-was-run) +(ert-deftest ert-test-body-runs () + (setq ert--test-body-was-run t)) + +(defun ert-self-test () + "Run ERT's self-tests and make sure they actually ran." + (let ((window-configuration (current-window-configuration))) + (let ((ert--test-body-was-run nil)) + ;; The buffer name chosen here should not compete with the default + ;; results buffer name for completion in `switch-to-buffer'. + (let ((stats (ert-run-tests-interactively "^ert-" " *ert self-tests*"))) + (cl-assert ert--test-body-was-run) + (if (zerop (ert-stats-completed-unexpected stats)) + ;; Hide results window only when everything went well. + (set-window-configuration window-configuration) + (error "ERT self-test failed")))))) + +(defun ert-self-test-and-exit () + "Run ERT's self-tests and exit Emacs. + +The exit code will be zero if the tests passed, nonzero if they +failed or if there was a problem." + (unwind-protect + (progn + (ert-self-test) + (kill-emacs 0)) + (unwind-protect + (progn + (message "Error running tests") + (backtrace)) + (kill-emacs 1)))) + + +;;; Further tests are defined using ERT. + +(ert-deftest ert-test-nested-test-body-runs () + "Test that nested test bodies run." + (let ((was-run nil)) + (let ((test (make-ert-test :body (lambda () + (setq was-run t))))) + (cl-assert (not was-run)) + (ert-run-test test) + (cl-assert was-run)))) + + +;;; Test that pass/fail works. +(ert-deftest ert-test-pass () + (let ((test (make-ert-test :body (lambda ())))) + (let ((result (ert-run-test test))) + (cl-assert (ert-test-passed-p result))))) + +(ert-deftest ert-test-fail () + (let ((test (make-ert-test :body (lambda () (ert-fail "failure message"))))) + (let ((result (let ((ert-debug-on-error nil)) + (ert-run-test test)))) + (cl-assert (ert-test-failed-p result) t) + (cl-assert (equal (ert-test-result-with-condition-condition result) + '(ert-test-failed "failure message")) + t)))) + +(ert-deftest ert-test-fail-debug-with-condition-case () + (let ((test (make-ert-test :body (lambda () (ert-fail "failure message"))))) + (condition-case condition + (progn + (let ((ert-debug-on-error t)) + (ert-run-test test)) + (cl-assert nil)) + ((error) + (cl-assert (equal condition '(ert-test-failed "failure message")) t))))) + +(ert-deftest ert-test-fail-debug-with-debugger-1 () + (let ((test (make-ert-test :body (lambda () (ert-fail "failure message"))))) + (let ((debugger (lambda (&rest _args) + (cl-assert nil)))) + (let ((ert-debug-on-error nil)) + (ert-run-test test))))) + +(ert-deftest ert-test-fail-debug-with-debugger-2 () + (let ((test (make-ert-test :body (lambda () (ert-fail "failure message"))))) + (cl-block nil + (let ((debugger (lambda (&rest _args) + (cl-return-from nil nil)))) + (let ((ert-debug-on-error t)) + (ert-run-test test)) + (cl-assert nil))))) + +(ert-deftest ert-test-fail-debug-nested-with-debugger () + (let ((test (make-ert-test :body (lambda () + (let ((ert-debug-on-error t)) + (ert-fail "failure message")))))) + (let ((debugger (lambda (&rest _args) + (cl-assert nil nil "Assertion a")))) + (let ((ert-debug-on-error nil)) + (ert-run-test test)))) + (let ((test (make-ert-test :body (lambda () + (let ((ert-debug-on-error nil)) + (ert-fail "failure message")))))) + (cl-block nil + (let ((debugger (lambda (&rest _args) + (cl-return-from nil nil)))) + (let ((ert-debug-on-error t)) + (ert-run-test test)) + (cl-assert nil nil "Assertion b"))))) + +(ert-deftest ert-test-error () + (let ((test (make-ert-test :body (lambda () (error "Error message"))))) + (let ((result (let ((ert-debug-on-error nil)) + (ert-run-test test)))) + (cl-assert (ert-test-failed-p result) t) + (cl-assert (equal (ert-test-result-with-condition-condition result) + '(error "Error message")) + t)))) + +(ert-deftest ert-test-error-debug () + (let ((test (make-ert-test :body (lambda () (error "Error message"))))) + (condition-case condition + (progn + (let ((ert-debug-on-error t)) + (ert-run-test test)) + (cl-assert nil)) + ((error) + (cl-assert (equal condition '(error "Error message")) t))))) + + +;;; Test that `should' works. +(ert-deftest ert-test-should () + (let ((test (make-ert-test :body (lambda () (should nil))))) + (let ((result (let ((ert-debug-on-error nil)) + (ert-run-test test)))) + (cl-assert (ert-test-failed-p result) t) + (cl-assert (equal (ert-test-result-with-condition-condition result) + '(ert-test-failed ((should nil) :form nil :value nil))) + t))) + (let ((test (make-ert-test :body (lambda () (should t))))) + (let ((result (ert-run-test test))) + (cl-assert (ert-test-passed-p result) t)))) + +(ert-deftest ert-test-should-value () + (should (eql (should 'foo) 'foo)) + (should (eql (should 'bar) 'bar))) + +(ert-deftest ert-test-should-not () + (let ((test (make-ert-test :body (lambda () (should-not t))))) + (let ((result (let ((ert-debug-on-error nil)) + (ert-run-test test)))) + (cl-assert (ert-test-failed-p result) t) + (cl-assert (equal (ert-test-result-with-condition-condition result) + '(ert-test-failed ((should-not t) :form t :value t))) + t))) + (let ((test (make-ert-test :body (lambda () (should-not nil))))) + (let ((result (ert-run-test test))) + (cl-assert (ert-test-passed-p result))))) + + +(ert-deftest ert-test-should-with-macrolet () + (let ((test (make-ert-test :body (lambda () + (cl-macrolet ((foo () `(progn t nil))) + (should (foo))))))) + (let ((result (let ((ert-debug-on-error nil)) + (ert-run-test test)))) + (should (ert-test-failed-p result)) + (should (equal + (ert-test-result-with-condition-condition result) + '(ert-test-failed ((should (foo)) + :form (progn t nil) + :value nil))))))) + +(ert-deftest ert-test-should-error () + ;; No error. + (let ((test (make-ert-test :body (lambda () (should-error (progn)))))) + (let ((result (let ((ert-debug-on-error nil)) + (ert-run-test test)))) + (should (ert-test-failed-p result)) + (should (equal (ert-test-result-with-condition-condition result) + '(ert-test-failed + ((should-error (progn)) + :form (progn) + :value nil + :fail-reason "did not signal an error")))))) + ;; A simple error. + (should (equal (should-error (error "Foo")) + '(error "Foo"))) + ;; Error of unexpected type. + (let ((test (make-ert-test :body (lambda () + (should-error (error "Foo") + :type 'singularity-error))))) + (let ((result (ert-run-test test))) + (should (ert-test-failed-p result)) + (should (equal + (ert-test-result-with-condition-condition result) + '(ert-test-failed + ((should-error (error "Foo") :type 'singularity-error) + :form (error "Foo") + :condition (error "Foo") + :fail-reason + "the error signaled did not have the expected type")))))) + ;; Error of the expected type. + (let* ((error nil) + (test (make-ert-test + :body (lambda () + (setq error + (should-error (signal 'singularity-error nil) + :type 'singularity-error)))))) + (let ((result (ert-run-test test))) + (should (ert-test-passed-p result)) + (should (equal error '(singularity-error)))))) + +(ert-deftest ert-test-should-error-subtypes () + (should-error (signal 'singularity-error nil) + :type 'singularity-error + :exclude-subtypes t) + (let ((test (make-ert-test + :body (lambda () + (should-error (signal 'arith-error nil) + :type 'singularity-error))))) + (let ((result (ert-run-test test))) + (should (ert-test-failed-p result)) + (should (equal + (ert-test-result-with-condition-condition result) + '(ert-test-failed + ((should-error (signal 'arith-error nil) + :type 'singularity-error) + :form (signal arith-error nil) + :condition (arith-error) + :fail-reason + "the error signaled did not have the expected type")))))) + (let ((test (make-ert-test + :body (lambda () + (should-error (signal 'arith-error nil) + :type 'singularity-error + :exclude-subtypes t))))) + (let ((result (ert-run-test test))) + (should (ert-test-failed-p result)) + (should (equal + (ert-test-result-with-condition-condition result) + '(ert-test-failed + ((should-error (signal 'arith-error nil) + :type 'singularity-error + :exclude-subtypes t) + :form (signal arith-error nil) + :condition (arith-error) + :fail-reason + "the error signaled did not have the expected type")))))) + (let ((test (make-ert-test + :body (lambda () + (should-error (signal 'singularity-error nil) + :type 'arith-error + :exclude-subtypes t))))) + (let ((result (ert-run-test test))) + (should (ert-test-failed-p result)) + (should (equal + (ert-test-result-with-condition-condition result) + '(ert-test-failed + ((should-error (signal 'singularity-error nil) + :type 'arith-error + :exclude-subtypes t) + :form (signal singularity-error nil) + :condition (singularity-error) + :fail-reason + "the error signaled was a subtype of the expected type"))))) + )) + +(ert-deftest ert-test-skip-unless () + ;; Don't skip. + (let ((test (make-ert-test :body (lambda () (skip-unless t))))) + (let ((result (ert-run-test test))) + (should (ert-test-passed-p result)))) + ;; Skip. + (let ((test (make-ert-test :body (lambda () (skip-unless nil))))) + (let ((result (ert-run-test test))) + (should (ert-test-skipped-p result)))) + ;; Skip in case of error. + (let ((test (make-ert-test :body (lambda () (skip-unless (error "Foo")))))) + (let ((result (ert-run-test test))) + (should (ert-test-skipped-p result))))) + +(defmacro ert--test-my-list (&rest args) + "Don't use this. Instead, call `list' with ARGS, it does the same thing. + +This macro is used to test if macroexpansion in `should' works." + `(list ,@args)) + +(ert-deftest ert-test-should-failure-debugging () + "Test that `should' errors contain the information we expect them to." + (cl-loop + for (body expected-condition) in + `((,(lambda () (let ((x nil)) (should x))) + (ert-test-failed ((should x) :form x :value nil))) + (,(lambda () (let ((x t)) (should-not x))) + (ert-test-failed ((should-not x) :form x :value t))) + (,(lambda () (let ((x t)) (should (not x)))) + (ert-test-failed ((should (not x)) :form (not t) :value nil))) + (,(lambda () (let ((x nil)) (should-not (not x)))) + (ert-test-failed ((should-not (not x)) :form (not nil) :value t))) + (,(lambda () (let ((x t) (y nil)) (should-not + (ert--test-my-list x y)))) + (ert-test-failed + ((should-not (ert--test-my-list x y)) + :form (list t nil) + :value (t nil)))) + (,(lambda () (let ((_x t)) (should (error "Foo")))) + (error "Foo"))) + do + (let ((test (make-ert-test :body body))) + (condition-case actual-condition + (progn + (let ((ert-debug-on-error t)) + (ert-run-test test)) + (cl-assert nil)) + ((error) + (should (equal actual-condition expected-condition))))))) + +(ert-deftest ert-test-deftest () + ;; FIXME: These tests don't look very good. What is their intent, i.e. what + ;; are they really testing? The precise generated code shouldn't matter, so + ;; we should either test the behavior of the code, or else try to express the + ;; kind of efficiency guarantees we're looking for. + (should (equal (macroexpand '(ert-deftest abc () "foo" :tags '(bar))) + '(progn + (ert-set-test 'abc + (progn + "Constructor for objects of type `ert-test'." + (vector 'cl-struct-ert-test 'abc "foo" + #'(lambda nil) + nil ':passed + '(bar)))) + (setq current-load-list + (cons + '(ert-deftest . abc) + current-load-list)) + 'abc))) + (should (equal (macroexpand '(ert-deftest def () + :expected-result ':passed)) + '(progn + (ert-set-test 'def + (progn + "Constructor for objects of type `ert-test'." + (vector 'cl-struct-ert-test 'def nil + #'(lambda nil) + nil ':passed 'nil))) + (setq current-load-list + (cons + '(ert-deftest . def) + current-load-list)) + 'def))) + ;; :documentation keyword is forbidden + (should-error (macroexpand '(ert-deftest ghi () + :documentation "foo")))) + +(ert-deftest ert-test-record-backtrace () + (let ((test (make-ert-test :body (lambda () (ert-fail "foo"))))) + (let ((result (ert-run-test test))) + (should (ert-test-failed-p result)) + (with-temp-buffer + (ert--print-backtrace (ert-test-failed-backtrace result)) + (goto-char (point-min)) + (end-of-line) + (let ((first-line (buffer-substring-no-properties (point-min) (point)))) + (should (equal first-line " (closure (ert--test-body-was-run t) nil (ert-fail \"foo\"))()"))))))) + +(ert-deftest ert-test-messages () + :tags '(:causes-redisplay) + (let* ((message-string "Test message") + (messages-buffer (get-buffer-create "*Messages*")) + (test (make-ert-test :body (lambda () (message "%s" message-string))))) + (with-current-buffer messages-buffer + (let ((result (ert-run-test test))) + (should (equal (concat message-string "\n") + (ert-test-result-messages result))))))) + +(ert-deftest ert-test-running-tests () + (let ((outer-test (ert-get-test 'ert-test-running-tests))) + (should (equal (ert-running-test) outer-test)) + (let (test1 test2 test3) + (setq test1 (make-ert-test + :name "1" + :body (lambda () + (should (equal (ert-running-test) outer-test)) + (should (equal ert--running-tests + (list test1 test2 test3 + outer-test))))) + test2 (make-ert-test + :name "2" + :body (lambda () + (should (equal (ert-running-test) outer-test)) + (should (equal ert--running-tests + (list test3 test2 outer-test))) + (ert-run-test test1))) + test3 (make-ert-test + :name "3" + :body (lambda () + (should (equal (ert-running-test) outer-test)) + (should (equal ert--running-tests + (list test3 outer-test))) + (ert-run-test test2)))) + (should (ert-test-passed-p (ert-run-test test3)))))) + +(ert-deftest ert-test-test-result-expected-p () + "Test `ert-test-result-expected-p' and (implicitly) `ert-test-result-type-p'." + ;; passing test + (let ((test (make-ert-test :body (lambda ())))) + (should (ert-test-result-expected-p test (ert-run-test test)))) + ;; unexpected failure + (let ((test (make-ert-test :body (lambda () (ert-fail "failed"))))) + (should-not (ert-test-result-expected-p test (ert-run-test test)))) + ;; expected failure + (let ((test (make-ert-test :body (lambda () (ert-fail "failed")) + :expected-result-type ':failed))) + (should (ert-test-result-expected-p test (ert-run-test test)))) + ;; `not' expected type + (let ((test (make-ert-test :body (lambda ()) + :expected-result-type '(not :failed)))) + (should (ert-test-result-expected-p test (ert-run-test test)))) + (let ((test (make-ert-test :body (lambda ()) + :expected-result-type '(not :passed)))) + (should-not (ert-test-result-expected-p test (ert-run-test test)))) + ;; `and' expected type + (let ((test (make-ert-test :body (lambda ()) + :expected-result-type '(and :passed :failed)))) + (should-not (ert-test-result-expected-p test (ert-run-test test)))) + (let ((test (make-ert-test :body (lambda ()) + :expected-result-type '(and :passed + (not :failed))))) + (should (ert-test-result-expected-p test (ert-run-test test)))) + ;; `or' expected type + (let ((test (make-ert-test :body (lambda ()) + :expected-result-type '(or (and :passed :failed) + :passed)))) + (should (ert-test-result-expected-p test (ert-run-test test)))) + (let ((test (make-ert-test :body (lambda ()) + :expected-result-type '(or (and :passed :failed) + nil (not t))))) + (should-not (ert-test-result-expected-p test (ert-run-test test))))) + +;;; Test `ert-select-tests'. +(ert-deftest ert-test-select-regexp () + (should (equal (ert-select-tests "^ert-test-select-regexp$" t) + (list (ert-get-test 'ert-test-select-regexp))))) + +(ert-deftest ert-test-test-boundp () + (should (ert-test-boundp 'ert-test-test-boundp)) + (should-not (ert-test-boundp (make-symbol "ert-not-a-test")))) + +(ert-deftest ert-test-select-member () + (should (equal (ert-select-tests '(member ert-test-select-member) t) + (list (ert-get-test 'ert-test-select-member))))) + +(ert-deftest ert-test-select-test () + (should (equal (ert-select-tests (ert-get-test 'ert-test-select-test) t) + (list (ert-get-test 'ert-test-select-test))))) + +(ert-deftest ert-test-select-symbol () + (should (equal (ert-select-tests 'ert-test-select-symbol t) + (list (ert-get-test 'ert-test-select-symbol))))) + +(ert-deftest ert-test-select-and () + (let ((test (make-ert-test + :name nil + :body nil + :most-recent-result (make-ert-test-failed + :condition nil + :backtrace nil + :infos nil)))) + (should (equal (ert-select-tests `(and (member ,test) :failed) t) + (list test))))) + +(ert-deftest ert-test-select-tag () + (let ((test (make-ert-test + :name nil + :body nil + :tags '(a b)))) + (should (equal (ert-select-tests `(tag a) (list test)) (list test))) + (should (equal (ert-select-tests `(tag b) (list test)) (list test))) + (should (equal (ert-select-tests `(tag c) (list test)) '())))) + + +;;; Tests for utility functions. +(ert-deftest ert-test-proper-list-p () + (should (ert--proper-list-p '())) + (should (ert--proper-list-p '(1))) + (should (ert--proper-list-p '(1 2))) + (should (ert--proper-list-p '(1 2 3))) + (should (ert--proper-list-p '(1 2 3 4))) + (should (not (ert--proper-list-p 'a))) + (should (not (ert--proper-list-p '(1 . a)))) + (should (not (ert--proper-list-p '(1 2 . a)))) + (should (not (ert--proper-list-p '(1 2 3 . a)))) + (should (not (ert--proper-list-p '(1 2 3 4 . a)))) + (let ((a (list 1))) + (setf (cdr (last a)) a) + (should (not (ert--proper-list-p a)))) + (let ((a (list 1 2))) + (setf (cdr (last a)) a) + (should (not (ert--proper-list-p a)))) + (let ((a (list 1 2 3))) + (setf (cdr (last a)) a) + (should (not (ert--proper-list-p a)))) + (let ((a (list 1 2 3 4))) + (setf (cdr (last a)) a) + (should (not (ert--proper-list-p a)))) + (let ((a (list 1 2))) + (setf (cdr (last a)) (cdr a)) + (should (not (ert--proper-list-p a)))) + (let ((a (list 1 2 3))) + (setf (cdr (last a)) (cdr a)) + (should (not (ert--proper-list-p a)))) + (let ((a (list 1 2 3 4))) + (setf (cdr (last a)) (cdr a)) + (should (not (ert--proper-list-p a)))) + (let ((a (list 1 2 3))) + (setf (cdr (last a)) (cddr a)) + (should (not (ert--proper-list-p a)))) + (let ((a (list 1 2 3 4))) + (setf (cdr (last a)) (cddr a)) + (should (not (ert--proper-list-p a)))) + (let ((a (list 1 2 3 4))) + (setf (cdr (last a)) (cl-cdddr a)) + (should (not (ert--proper-list-p a))))) + +(ert-deftest ert-test-parse-keys-and-body () + (should (equal (ert--parse-keys-and-body '(foo)) '(nil (foo)))) + (should (equal (ert--parse-keys-and-body '(:bar foo)) '((:bar foo) nil))) + (should (equal (ert--parse-keys-and-body '(:bar foo a (b))) + '((:bar foo) (a (b))))) + (should (equal (ert--parse-keys-and-body '(:bar foo :a (b))) + '((:bar foo :a (b)) nil))) + (should (equal (ert--parse-keys-and-body '(bar foo :a (b))) + '(nil (bar foo :a (b))))) + (should-error (ert--parse-keys-and-body '(:bar foo :a)))) + + +(ert-deftest ert-test-run-tests-interactively () + :tags '(:causes-redisplay) + (let ((passing-test (make-ert-test :name 'passing-test + :body (lambda () (ert-pass)))) + (failing-test (make-ert-test :name 'failing-test + :body (lambda () (ert-fail + "failure message")))) + (skipped-test (make-ert-test :name 'skipped-test + :body (lambda () (ert-skip + "skip message"))))) + (let ((ert-debug-on-error nil)) + (let* ((buffer-name (generate-new-buffer-name " *ert-test-run-tests*")) + (messages nil) + (mock-message-fn + (lambda (format-string &rest args) + (push (apply #'format format-string args) messages)))) + (save-window-excursion + (unwind-protect + (let ((case-fold-search nil)) + (ert-run-tests-interactively + `(member ,passing-test ,failing-test, skipped-test) buffer-name + mock-message-fn) + (should (equal messages `(,(concat + "Ran 3 tests, 1 results were " + "as expected, 1 unexpected, " + "1 skipped")))) + (with-current-buffer buffer-name + (goto-char (point-min)) + (should (equal + (buffer-substring (point-min) + (save-excursion + (forward-line 5) + (point))) + (concat + "Selector: (member <passing-test> <failing-test> " + "<skipped-test>)\n" + "Passed: 1\n" + "Failed: 1 (1 unexpected)\n" + "Skipped: 1\n" + "Total: 3/3\n"))))) + (when (get-buffer buffer-name) + (kill-buffer buffer-name)))))))) + +(ert-deftest ert-test-special-operator-p () + (should (ert--special-operator-p 'if)) + (should-not (ert--special-operator-p 'car)) + (should-not (ert--special-operator-p 'ert--special-operator-p)) + (let ((b (cl-gensym))) + (should-not (ert--special-operator-p b)) + (fset b 'if) + (should (ert--special-operator-p b)))) + +(ert-deftest ert-test-list-of-should-forms () + (let ((test (make-ert-test :body (lambda () + (should t) + (should (null '())) + (should nil) + (should t))))) + (let ((result (let ((ert-debug-on-error nil)) + (ert-run-test test)))) + (should (equal (ert-test-result-should-forms result) + '(((should t) :form t :value t) + ((should (null '())) :form (null nil) :value t) + ((should nil) :form nil :value nil))))))) + +(ert-deftest ert-test-list-of-should-forms-observers-should-not-stack () + (let ((test (make-ert-test + :body (lambda () + (let ((test2 (make-ert-test + :body (lambda () + (should t))))) + (let ((result (ert-run-test test2))) + (should (ert-test-passed-p result)))))))) + (let ((result (let ((ert-debug-on-error nil)) + (ert-run-test test)))) + (should (ert-test-passed-p result)) + (should (eql (length (ert-test-result-should-forms result)) + 1))))) + +(ert-deftest ert-test-list-of-should-forms-no-deep-copy () + (let ((test (make-ert-test :body (lambda () + (let ((obj (list 'a))) + (should (equal obj '(a))) + (setf (car obj) 'b) + (should (equal obj '(b)))))))) + (let ((result (let ((ert-debug-on-error nil)) + (ert-run-test test)))) + (should (ert-test-passed-p result)) + (should (equal (ert-test-result-should-forms result) + '(((should (equal obj '(a))) :form (equal (b) (a)) :value t + :explanation nil) + ((should (equal obj '(b))) :form (equal (b) (b)) :value t + :explanation nil) + )))))) + +(ert-deftest ert-test-string-first-line () + (should (equal (ert--string-first-line "") "")) + (should (equal (ert--string-first-line "abc") "abc")) + (should (equal (ert--string-first-line "abc\n") "abc")) + (should (equal (ert--string-first-line "foo\nbar") "foo")) + (should (equal (ert--string-first-line " foo\nbar\nbaz\n") " foo"))) + +(ert-deftest ert-test-explain-equal () + (should (equal (ert--explain-equal nil 'foo) + '(different-atoms nil foo))) + (should (equal (ert--explain-equal '(a a) '(a b)) + '(list-elt 1 (different-atoms a b)))) + (should (equal (ert--explain-equal '(1 48) '(1 49)) + '(list-elt 1 (different-atoms (48 "#x30" "?0") + (49 "#x31" "?1"))))) + (should (equal (ert--explain-equal 'nil '(a)) + '(different-types nil (a)))) + (should (equal (ert--explain-equal '(a b c) '(a b c d)) + '(proper-lists-of-different-length 3 4 (a b c) (a b c d) + first-mismatch-at 3))) + (let ((sym (make-symbol "a"))) + (should (equal (ert--explain-equal 'a sym) + `(different-symbols-with-the-same-name a ,sym))))) + +(ert-deftest ert-test-explain-equal-improper-list () + (should (equal (ert--explain-equal '(a . b) '(a . c)) + '(cdr (different-atoms b c))))) + +(ert-deftest ert-test-explain-equal-keymaps () + ;; This used to be very slow. + (should (equal (make-keymap) (make-keymap))) + (should (equal (make-sparse-keymap) (make-sparse-keymap)))) + +(ert-deftest ert-test-significant-plist-keys () + (should (equal (ert--significant-plist-keys '()) '())) + (should (equal (ert--significant-plist-keys '(a b c d e f c g p q r nil s t)) + '(a c e p s)))) + +(ert-deftest ert-test-plist-difference-explanation () + (should (equal (ert--plist-difference-explanation + '(a b c nil) '(a b)) + nil)) + (should (equal (ert--plist-difference-explanation + '(a b c t) '(a b)) + '(different-properties-for-key c (different-atoms t nil)))) + (should (equal (ert--plist-difference-explanation + '(a b c t) '(c nil a b)) + '(different-properties-for-key c (different-atoms t nil)))) + (should (equal (ert--plist-difference-explanation + '(a b c (foo . bar)) '(c (foo . baz) a b)) + '(different-properties-for-key c + (cdr + (different-atoms bar baz)))))) + +(ert-deftest ert-test-abbreviate-string () + (should (equal (ert--abbreviate-string "foo" 4 nil) "foo")) + (should (equal (ert--abbreviate-string "foo" 3 nil) "foo")) + (should (equal (ert--abbreviate-string "foo" 3 nil) "foo")) + (should (equal (ert--abbreviate-string "foo" 2 nil) "fo")) + (should (equal (ert--abbreviate-string "foo" 1 nil) "f")) + (should (equal (ert--abbreviate-string "foo" 0 nil) "")) + (should (equal (ert--abbreviate-string "bar" 4 t) "bar")) + (should (equal (ert--abbreviate-string "bar" 3 t) "bar")) + (should (equal (ert--abbreviate-string "bar" 3 t) "bar")) + (should (equal (ert--abbreviate-string "bar" 2 t) "ar")) + (should (equal (ert--abbreviate-string "bar" 1 t) "r")) + (should (equal (ert--abbreviate-string "bar" 0 t) ""))) + +(ert-deftest ert-test-explain-equal-string-properties () + (should + (equal (ert--explain-equal-including-properties #("foo" 0 1 (a b)) + "foo") + '(char 0 "f" + (different-properties-for-key a (different-atoms b nil)) + context-before "" + context-after "oo"))) + (should (equal (ert--explain-equal-including-properties + #("foo" 1 3 (a b)) + #("goo" 0 1 (c d))) + '(array-elt 0 (different-atoms (?f "#x66" "?f") + (?g "#x67" "?g"))))) + (should + (equal (ert--explain-equal-including-properties + #("foo" 0 1 (a b c d) 1 3 (a b)) + #("foo" 0 1 (c d a b) 1 2 (a foo))) + '(char 1 "o" (different-properties-for-key a (different-atoms b foo)) + context-before "f" context-after "o")))) + +(ert-deftest ert-test-equal-including-properties () + (should (equal-including-properties "foo" "foo")) + (should (ert-equal-including-properties "foo" "foo")) + + (should (equal-including-properties #("foo" 0 3 (a b)) + (propertize "foo" 'a 'b))) + (should (ert-equal-including-properties #("foo" 0 3 (a b)) + (propertize "foo" 'a 'b))) + + (should (equal-including-properties #("foo" 0 3 (a b c d)) + (propertize "foo" 'a 'b 'c 'd))) + (should (ert-equal-including-properties #("foo" 0 3 (a b c d)) + (propertize "foo" 'a 'b 'c 'd))) + + (should-not (equal-including-properties #("foo" 0 3 (a b c e)) + (propertize "foo" 'a 'b 'c 'd))) + (should-not (ert-equal-including-properties #("foo" 0 3 (a b c e)) + (propertize "foo" 'a 'b 'c 'd))) + + ;; This is bug 6581. + (should-not (equal-including-properties #("foo" 0 3 (a (t))) + (propertize "foo" 'a (list t)))) + (should (ert-equal-including-properties #("foo" 0 3 (a (t))) + (propertize "foo" 'a (list t))))) + +(ert-deftest ert-test-stats-set-test-and-result () + (let* ((test-1 (make-ert-test :name 'test-1 + :body (lambda () nil))) + (test-2 (make-ert-test :name 'test-2 + :body (lambda () nil))) + (test-3 (make-ert-test :name 'test-2 + :body (lambda () nil))) + (stats (ert--make-stats (list test-1 test-2) 't)) + (failed (make-ert-test-failed :condition nil + :backtrace nil + :infos nil)) + (skipped (make-ert-test-skipped :condition nil + :backtrace nil + :infos nil))) + (should (eql 2 (ert-stats-total stats))) + (should (eql 0 (ert-stats-completed stats))) + (should (eql 0 (ert-stats-completed-expected stats))) + (should (eql 0 (ert-stats-completed-unexpected stats))) + (should (eql 0 (ert-stats-skipped stats))) + (ert--stats-set-test-and-result stats 0 test-1 (make-ert-test-passed)) + (should (eql 2 (ert-stats-total stats))) + (should (eql 1 (ert-stats-completed stats))) + (should (eql 1 (ert-stats-completed-expected stats))) + (should (eql 0 (ert-stats-completed-unexpected stats))) + (should (eql 0 (ert-stats-skipped stats))) + (ert--stats-set-test-and-result stats 0 test-1 failed) + (should (eql 2 (ert-stats-total stats))) + (should (eql 1 (ert-stats-completed stats))) + (should (eql 0 (ert-stats-completed-expected stats))) + (should (eql 1 (ert-stats-completed-unexpected stats))) + (should (eql 0 (ert-stats-skipped stats))) + (ert--stats-set-test-and-result stats 0 test-1 nil) + (should (eql 2 (ert-stats-total stats))) + (should (eql 0 (ert-stats-completed stats))) + (should (eql 0 (ert-stats-completed-expected stats))) + (should (eql 0 (ert-stats-completed-unexpected stats))) + (should (eql 0 (ert-stats-skipped stats))) + (ert--stats-set-test-and-result stats 0 test-3 failed) + (should (eql 2 (ert-stats-total stats))) + (should (eql 1 (ert-stats-completed stats))) + (should (eql 0 (ert-stats-completed-expected stats))) + (should (eql 1 (ert-stats-completed-unexpected stats))) + (should (eql 0 (ert-stats-skipped stats))) + (ert--stats-set-test-and-result stats 1 test-2 (make-ert-test-passed)) + (should (eql 2 (ert-stats-total stats))) + (should (eql 2 (ert-stats-completed stats))) + (should (eql 1 (ert-stats-completed-expected stats))) + (should (eql 1 (ert-stats-completed-unexpected stats))) + (should (eql 0 (ert-stats-skipped stats))) + (ert--stats-set-test-and-result stats 0 test-1 (make-ert-test-passed)) + (should (eql 2 (ert-stats-total stats))) + (should (eql 2 (ert-stats-completed stats))) + (should (eql 2 (ert-stats-completed-expected stats))) + (should (eql 0 (ert-stats-completed-unexpected stats))) + (should (eql 0 (ert-stats-skipped stats))) + (ert--stats-set-test-and-result stats 0 test-1 skipped) + (should (eql 2 (ert-stats-total stats))) + (should (eql 2 (ert-stats-completed stats))) + (should (eql 1 (ert-stats-completed-expected stats))) + (should (eql 0 (ert-stats-completed-unexpected stats))) + (should (eql 1 (ert-stats-skipped stats))))) + + +(provide 'ert-tests) + +;;; ert-tests.el ends here + +;; Local Variables: +;; no-byte-compile: t +;; End: diff --git a/test/lisp/emacs-lisp/ert-x-tests.el b/test/lisp/emacs-lisp/ert-x-tests.el new file mode 100644 index 00000000000..ef8642aebfb --- /dev/null +++ b/test/lisp/emacs-lisp/ert-x-tests.el @@ -0,0 +1,280 @@ +;;; ert-x-tests.el --- Tests for ert-x.el + +;; Copyright (C) 2008, 2010-2016 Free Software Foundation, Inc. + +;; Author: Phil Hagelberg +;; Christian Ohler <ohler@gnu.org> + +;; This file is part of GNU Emacs. + +;; 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/'. + +;;; Commentary: + +;; This file is part of ERT, the Emacs Lisp Regression Testing tool. +;; See ert.el or the texinfo manual for more details. + +;;; Code: + +(eval-when-compile + (require 'cl-lib)) +(require 'ert) +(require 'ert-x) + +;;; Utilities + +(ert-deftest ert-test-buffer-string-reindented () + (ert-with-test-buffer (:name "well-indented") + (insert (concat "(hello (world\n" + " 'elisp)\n")) + (emacs-lisp-mode) + (should (equal (ert-buffer-string-reindented) (buffer-string)))) + (ert-with-test-buffer (:name "badly-indented") + (insert (concat "(hello\n" + " world)")) + (emacs-lisp-mode) + (should-not (equal (ert-buffer-string-reindented) (buffer-string))))) + +(defun ert--hash-table-to-alist (table) + (let ((accu nil)) + (maphash (lambda (key value) + (push (cons key value) accu)) + table) + (nreverse accu))) + +(ert-deftest ert-test-test-buffers () + (let (buffer-1 + buffer-2) + (let ((test-1 + (make-ert-test + :name 'test-1 + :body (lambda () + (ert-with-test-buffer (:name "foo") + (should (string-match + "[*]Test buffer (ert-test-test-buffers): foo[*]" + (buffer-name))) + (setq buffer-1 (current-buffer)))))) + (test-2 + (make-ert-test + :name 'test-2 + :body (lambda () + (ert-with-test-buffer (:name "bar") + (should (string-match + "[*]Test buffer (ert-test-test-buffers): bar[*]" + (buffer-name))) + (setq buffer-2 (current-buffer)) + (ert-fail "fail for test")))))) + (let ((ert--test-buffers (make-hash-table :weakness t))) + (ert-run-tests `(member ,test-1 ,test-2) #'ignore) + (should (equal (ert--hash-table-to-alist ert--test-buffers) + `((,buffer-2 . t)))) + (should-not (buffer-live-p buffer-1)) + (should (buffer-live-p buffer-2)))))) + + +(ert-deftest ert-filter-string () + (should (equal (ert-filter-string "foo bar baz" "quux") + "foo bar baz")) + (should (equal (ert-filter-string "foo bar baz" "bar") + "foo baz"))) + +(ert-deftest ert-propertized-string () + (should (ert-equal-including-properties + (ert-propertized-string "a" '(a b) "b" '(c t) "cd") + #("abcd" 1 2 (a b) 2 4 (c t)))) + (should (ert-equal-including-properties + (ert-propertized-string "foo " '(face italic) "bar" " baz" nil + " quux") + #("foo bar baz quux" 4 11 (face italic))))) + + +;;; Tests for ERT itself that require test features from ert-x.el. + +(ert-deftest ert-test-run-tests-interactively-2 () + :tags '(:causes-redisplay) + (let* ((passing-test (make-ert-test :name 'passing-test + :body (lambda () (ert-pass)))) + (failing-test (make-ert-test :name 'failing-test + :body (lambda () + (ert-info ((propertize "foo\nbar" + 'a 'b)) + (ert-fail + "failure message"))))) + (skipped-test (make-ert-test :name 'skipped-test + :body (lambda () (ert-skip + "skip message")))) + (ert-debug-on-error nil) + (buffer-name (generate-new-buffer-name "*ert-test-run-tests*")) + (messages nil) + (mock-message-fn + (lambda (format-string &rest args) + (push (apply #'format format-string args) messages)))) + (cl-flet ((expected-string (with-font-lock-p) + (ert-propertized-string + "Selector: (member <passing-test> <failing-test> " + "<skipped-test>)\n" + "Passed: 1\n" + "Failed: 1 (1 unexpected)\n" + "Skipped: 1\n" + "Total: 3/3\n\n" + "Started at:\n" + "Finished.\n" + "Finished at:\n\n" + `(category ,(button-category-symbol + 'ert--results-progress-bar-button) + button (t) + face ,(if with-font-lock-p + 'ert-test-result-unexpected + 'button)) + ".Fs" nil "\n\n" + `(category ,(button-category-symbol + 'ert--results-expand-collapse-button) + button (t) + face ,(if with-font-lock-p + 'ert-test-result-unexpected + 'button)) + "F" nil " " + `(category ,(button-category-symbol + 'ert--test-name-button) + button (t) + ert-test-name failing-test) + "failing-test" + nil "\n Info: " '(a b) "foo\n" + nil " " '(a b) "bar" + nil "\n (ert-test-failed \"failure message\")\n\n\n" + ))) + (save-window-excursion + (unwind-protect + (let ((case-fold-search nil)) + (ert-run-tests-interactively + `(member ,passing-test ,failing-test ,skipped-test) buffer-name + mock-message-fn) + (should (equal messages `(,(concat + "Ran 3 tests, 1 results were " + "as expected, 1 unexpected, " + "1 skipped")))) + (with-current-buffer buffer-name + (font-lock-mode 0) + (should (ert-equal-including-properties + (ert-filter-string (buffer-string) + '("Started at:\\(.*\\)$" 1) + '("Finished at:\\(.*\\)$" 1)) + (expected-string nil))) + ;; `font-lock-mode' only works if interactive, so + ;; pretend we are. + (let ((noninteractive nil)) + (font-lock-mode 1)) + (should (ert-equal-including-properties + (ert-filter-string (buffer-string) + '("Started at:\\(.*\\)$" 1) + '("Finished at:\\(.*\\)$" 1)) + (expected-string t))))) + (when (get-buffer buffer-name) + (kill-buffer buffer-name))))))) + +(ert-deftest ert-test-describe-test () + "Tests `ert-describe-test'." + (save-window-excursion + (ert-with-buffer-renamed ("*Help*") + (if (< emacs-major-version 24) + (should (equal (should-error (ert-describe-test 'ert-describe-test)) + '(error "Requires Emacs 24"))) + (ert-describe-test 'ert-test-describe-test) + (with-current-buffer "*Help*" + (let ((case-fold-search nil)) + (should (string-match (concat + "\\`ert-test-describe-test is a test" + " defined in" + " ['`‘]ert-x-tests.elc?['’]\\.\n\n" + "Tests ['`‘]ert-describe-test['’]\\.\n\\'") + (buffer-string))))))))) + +(ert-deftest ert-test-message-log-truncation () + :tags '(:causes-redisplay) + (let ((test (make-ert-test + :body (lambda () + ;; Emacs would combine messages if we + ;; generate the same message multiple + ;; times. + (message "a") + (message "b") + (message "c") + (message "d"))))) + (let (result) + (ert-with-buffer-renamed ("*Messages*") + (let ((message-log-max 2)) + (setq result (ert-run-test test))) + (should (equal (with-current-buffer "*Messages*" + (buffer-string)) + "c\nd\n"))) + (should (equal (ert-test-result-messages result) "a\nb\nc\nd\n"))))) + +(ert-deftest ert-test-builtin-message-log-flushing () + "This test attempts to demonstrate that there is no way to +force immediate truncation of the *Messages* buffer from Lisp +\(and hence justifies the existence of +`ert--force-message-log-buffer-truncation'): The only way that +came to my mind was \(message \"\"), which doesn't have the +desired effect." + :tags '(:causes-redisplay) + (ert-with-buffer-renamed ("*Messages*") + (with-current-buffer "*Messages*" + (should (equal (buffer-string) "")) + ;; We used to get sporadic failures in this test that involved + ;; a spurious newline at the beginning of the buffer, before + ;; the first message. Below, we print a message and erase the + ;; buffer since this seems to eliminate the sporadic failures. + (message "foo") + (erase-buffer) + (should (equal (buffer-string) "")) + (let ((message-log-max 2)) + (let ((message-log-max t)) + (cl-loop for i below 4 do + (message "%s" i)) + (should (equal (buffer-string) "0\n1\n2\n3\n"))) + (should (equal (buffer-string) "0\n1\n2\n3\n")) + (message "") + (should (equal (buffer-string) "0\n1\n2\n3\n")) + (message "Test message") + (should (equal (buffer-string) "3\nTest message\n")))))) + +(ert-deftest ert-test-force-message-log-buffer-truncation () + :tags '(:causes-redisplay) + (cl-labels ((body () + (cl-loop for i below 3 do + (message "%s" i))) + ;; Uses the implicit messages buffer truncation implemented + ;; in Emacs' C core. + (c (x) + (ert-with-buffer-renamed ("*Messages*") + (let ((message-log-max x)) + (body)) + (with-current-buffer "*Messages*" + (buffer-string)))) + ;; Uses our lisp reimplementation. + (lisp (x) + (ert-with-buffer-renamed ("*Messages*") + (let ((message-log-max t)) + (body)) + (let ((message-log-max x)) + (ert--force-message-log-buffer-truncation)) + (with-current-buffer "*Messages*" + (buffer-string))))) + (cl-loop for x in '(0 1 2 3 4 t) do + (should (equal (c x) (lisp x)))))) + + +(provide 'ert-x-tests) + +;;; ert-x-tests.el ends here diff --git a/test/lisp/emacs-lisp/generator-tests.el b/test/lisp/emacs-lisp/generator-tests.el new file mode 100644 index 00000000000..8ed0f2a240d --- /dev/null +++ b/test/lisp/emacs-lisp/generator-tests.el @@ -0,0 +1,284 @@ +;;; generator-tests.el --- Testing generators -*- lexical-binding: t -*- + +;; Copyright (C) 2015-2016 Free Software Foundation, Inc. + +;; Author: Daniel Colascione <dancol@dancol.org> +;; Keywords: + +;; 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: + +(require 'generator) +(require 'ert) +(require 'cl-lib) + +(defun generator-list-subrs () + (cl-loop for x being the symbols + when (and (fboundp x) + (cps--special-form-p (symbol-function x))) + collect x)) + +(defmacro cps-testcase (name &rest body) + "Perform a simple test of the continuation-transforming code. + +`cps-testcase' defines an ERT testcase called NAME that evaluates +BODY twice: once using ordinary `eval' and once using +lambda-generators. The test ensures that the two forms produce +identical output. +" + `(progn + (ert-deftest ,name () + (should + (equal + (funcall (lambda () ,@body)) + (iter-next + (funcall + (iter-lambda () (iter-yield (progn ,@body)))))))) + (ert-deftest ,(intern (format "%s-noopt" name)) () + (should + (equal + (funcall (lambda () ,@body)) + (iter-next + (funcall + (let ((cps-inhibit-atomic-optimization t)) + (iter-lambda () (iter-yield (progn ,@body))))))))))) + +(put 'cps-testcase 'lisp-indent-function 1) + +(defvar *cps-test-i* nil) +(defun cps-get-test-i () + *cps-test-i*) + +(cps-testcase cps-simple-1 (progn 1 2 3)) +(cps-testcase cps-empty-progn (progn)) +(cps-testcase cps-inline-not-progn (inline 1 2 3)) +(cps-testcase cps-prog1-a (prog1 1 2 3)) +(cps-testcase cps-prog1-b (prog1 1)) +(cps-testcase cps-prog1-c (prog2 1 2 3)) +(cps-testcase cps-quote (progn 'hello)) +(cps-testcase cps-function (progn #'hello)) + +(cps-testcase cps-and-fail (and 1 nil 2)) +(cps-testcase cps-and-succeed (and 1 2 3)) +(cps-testcase cps-and-empty (and)) + +(cps-testcase cps-or-fallthrough (or nil 1 2)) +(cps-testcase cps-or-alltrue (or 1 2 3)) +(cps-testcase cps-or-empty (or)) + +(cps-testcase cps-let* (let* ((i 10)) i)) +(cps-testcase cps-let*-shadow-empty (let* ((i 10)) (let (i) i))) +(cps-testcase cps-let (let ((i 10)) i)) +(cps-testcase cps-let-shadow-empty (let ((i 10)) (let (i) i))) +(cps-testcase cps-let-novars (let nil 42)) +(cps-testcase cps-let*-novars (let* nil 42)) + +(cps-testcase cps-let-parallel + (let ((a 5) (b 6)) (let ((a b) (b a)) (list a b)))) + +(cps-testcase cps-let*-parallel + (let* ((a 5) (b 6)) (let* ((a b) (b a)) (list a b)))) + +(cps-testcase cps-while-dynamic + (setq *cps-test-i* 0) + (while (< *cps-test-i* 10) + (setf *cps-test-i* (+ *cps-test-i* 1))) + *cps-test-i*) + +(cps-testcase cps-while-lexical + (let* ((i 0) (j 10)) + (while (< i 10) + (setf i (+ i 1)) + (setf j (+ j (* i 10)))) + j)) + +(cps-testcase cps-while-incf + (let* ((i 0) (j 10)) + (while (< i 10) + (cl-incf i) + (setf j (+ j (* i 10)))) + j)) + +(cps-testcase cps-dynbind + (setf *cps-test-i* 0) + (let* ((*cps-test-i* 5)) + (cps-get-test-i))) + +(cps-testcase cps-nested-application + (+ (+ 3 5) 1)) + +(cps-testcase cps-unwind-protect + (setf *cps-test-i* 0) + (unwind-protect + (setf *cps-test-i* 1) + (setf *cps-test-i* 2)) + *cps-test-i*) + +(cps-testcase cps-catch-unused + (catch 'mytag 42)) + +(cps-testcase cps-catch-thrown + (1+ (catch 'mytag + (throw 'mytag (+ 2 2))))) + +(cps-testcase cps-loop + (cl-loop for x from 1 to 10 collect x)) + +(cps-testcase cps-loop-backquote + `(a b ,(cl-loop for x from 1 to 10 collect x) -1)) + +(cps-testcase cps-if-branch-a + (if t 'abc)) + +(cps-testcase cps-if-branch-b + (if t 'abc 'def)) + +(cps-testcase cps-if-condition-fail + (if nil 'abc 'def)) + +(cps-testcase cps-cond-empty + (cond)) + +(cps-testcase cps-cond-atomi + (cond (42))) + +(cps-testcase cps-cond-complex + (cond (nil 22) ((1+ 1) 42) (t 'bad))) + +(put 'cps-test-error 'error-conditions '(cps-test-condition)) + +(cps-testcase cps-condition-case + (condition-case + condvar + (signal 'cps-test-error 'test-data) + (cps-test-condition condvar))) + +(cps-testcase cps-condition-case-no-error + (condition-case + condvar + 42 + (cps-test-condition condvar))) + +(ert-deftest cps-generator-basic () + (let* ((gen (iter-lambda () + (iter-yield 1) + (iter-yield 2) + (iter-yield 3) + 4)) + (gen-inst (funcall gen))) + (should (eql (iter-next gen-inst) 1)) + (should (eql (iter-next gen-inst) 2)) + (should (eql (iter-next gen-inst) 3)) + + ;; should-error doesn't catch the generator-end condition (which + ;; isn't an error), so we write our own. + (let (errored) + (condition-case x + (iter-next gen-inst) + (iter-end-of-sequence + (setf errored (cdr x)))) + (should (eql errored 4))))) + +(iter-defun mygenerator (i) + (iter-yield 1) + (iter-yield i) + (iter-yield 2)) + +(ert-deftest cps-test-iter-do () + (let (mylist) + (iter-do (x (mygenerator 4)) + (push x mylist)) + (should (equal mylist '(2 4 1))))) + +(iter-defun gen-using-yield-value () + (let (f) + (setf f (iter-yield 42)) + (iter-yield f) + -8)) + +(ert-deftest cps-yield-value () + (let ((it (gen-using-yield-value))) + (should (eql (iter-next it -1) 42)) + (should (eql (iter-next it -1) -1)))) + +(ert-deftest cps-loop () + (should + (equal (cl-loop for x iter-by (mygenerator 42) + collect x) + '(1 42 2)))) + +(iter-defun gen-using-yield-from () + (let ((sub-iter (gen-using-yield-value))) + (iter-yield (1+ (iter-yield-from sub-iter))))) + +(ert-deftest cps-test-yield-from-works () + (let ((it (gen-using-yield-from))) + (should (eql (iter-next it -1) 42)) + (should (eql (iter-next it -1) -1)) + (should (eql (iter-next it -1) -7)))) + +(defvar cps-test-closed-flag nil) + +(ert-deftest cps-test-iter-close () + (garbage-collect) + (let ((cps-test-closed-flag nil)) + (let ((iter (funcall + (iter-lambda () + (unwind-protect (iter-yield 1) + (setf cps-test-closed-flag t)))))) + (should (equal (iter-next iter) 1)) + (should (not cps-test-closed-flag)) + (iter-close iter) + (should cps-test-closed-flag)))) + +(ert-deftest cps-test-iter-close-idempotent () + (garbage-collect) + (let ((cps-test-closed-flag nil)) + (let ((iter (funcall + (iter-lambda () + (unwind-protect (iter-yield 1) + (setf cps-test-closed-flag t)))))) + (should (equal (iter-next iter) 1)) + (should (not cps-test-closed-flag)) + (iter-close iter) + (should cps-test-closed-flag) + (setf cps-test-closed-flag nil) + (iter-close iter) + (should (not cps-test-closed-flag))))) + +(ert-deftest cps-test-iter-cleanup-once-only () + (let* ((nr-unwound 0) + (iter + (funcall (iter-lambda () + (unwind-protect + (progn + (iter-yield 1) + (error "test") + (iter-yield 2)) + (cl-incf nr-unwound)))))) + (should (equal (iter-next iter) 1)) + (should-error (iter-next iter)) + (should (equal nr-unwound 1)))) + +(iter-defun generator-with-docstring () + "Documentation!" + (declare (indent 5)) + nil) + +(ert-deftest cps-test-declarations-preserved () + (should (equal (documentation 'generator-with-docstring) "Documentation!")) + (should (equal (get 'generator-with-docstring 'lisp-indent-function) 5))) diff --git a/test/lisp/emacs-lisp/let-alist-tests.el b/test/lisp/emacs-lisp/let-alist-tests.el new file mode 100644 index 00000000000..80d418cabbe --- /dev/null +++ b/test/lisp/emacs-lisp/let-alist-tests.el @@ -0,0 +1,91 @@ +;;; let-alist.el --- tests for file handling. -*- lexical-binding: t; -*- + +;; Copyright (C) 2012-2016 Free Software Foundation, Inc. + +;; 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/>. + +;;; Code: + +(require 'ert) +(require 'cl-lib) +(require 'let-alist) + +(ert-deftest let-alist-surface-test () + "Tests basic macro expansion for `let-alist'." + (should + (equal '(let ((symbol data)) + (let ((.test-one (cdr (assq 'test-one symbol))) + (.test-two (cdr (assq 'test-two symbol)))) + (list .test-one .test-two + .test-two .test-two))) + (cl-letf (((symbol-function #'make-symbol) (lambda (x) 'symbol))) + (macroexpand + '(let-alist data (list .test-one .test-two + .test-two .test-two)))))) + (should + (equal + (let ((.external "ext") + (.external.too "et")) + (let-alist '((test-two . 0) + (test-three . 1) + (sublist . ((foo . 2) + (bar . 3)))) + (list .test-one .test-two .test-three + .sublist.foo .sublist.bar + ..external ..external.too))) + (list nil 0 1 2 3 "ext" "et")))) + +(ert-deftest let-alist-cons () + (should + (equal + (let ((.external "ext") + (.external.too "et")) + (let-alist '((test-two . 0) + (test-three . 1) + (sublist . ((foo . 2) + (bar . 3)))) + (list `(, .test-one . , .test-two) + .sublist.bar ..external))) + (list '(nil . 0) 3 "ext")))) + +(defvar let-alist--test-counter 0 + "Used to count number of times a function is called.") + +(ert-deftest let-alist-evaluate-once () + "Check that the alist argument is only evaluated once." + (let ((let-alist--test-counter 0)) + (should + (equal + (let-alist (list + (cons 'test-two (cl-incf let-alist--test-counter)) + (cons 'test-three (cl-incf let-alist--test-counter))) + (list .test-one .test-two .test-two .test-three .cl-incf)) + '(nil 1 1 2 nil))))) + +(ert-deftest let-alist-remove-dot () + "Remove first dot from symbol." + (should (equal (let-alist--remove-dot 'hi) 'hi)) + (should (equal (let-alist--remove-dot '.hi) 'hi)) + (should (equal (let-alist--remove-dot '..hi) '.hi))) + +(ert-deftest let-alist-list-to-sexp () + "Check that multiple dots are handled correctly." + (should (= 1 (eval (let-alist--list-to-sexp '(a b c d) ''((d (c (b (a . 1))))))))) + (should (equal (let-alist--access-sexp '.foo.bar.baz 'var) + '(cdr (assq 'baz (cdr (assq 'bar (cdr (assq 'foo var)))))))) + (should (equal (let-alist--access-sexp '..foo.bar.baz 'var) '.foo.bar.baz))) + +;;; let-alist.el ends here diff --git a/test/lisp/emacs-lisp/map-tests.el b/test/lisp/emacs-lisp/map-tests.el new file mode 100644 index 00000000000..d145c197a4e --- /dev/null +++ b/test/lisp/emacs-lisp/map-tests.el @@ -0,0 +1,331 @@ +;;; map-tests.el --- Tests for map.el -*- lexical-binding:t -*- + +;; Copyright (C) 2015-2016 Free Software Foundation, Inc. + +;; Author: Nicolas Petton <nicolas@petton.fr> +;; Maintainer: emacs-devel@gnu.org + +;; 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: + +;; Tests for map.el + +;;; Code: + +(require 'ert) +(require 'map) + +(defmacro with-maps-do (var &rest body) + "Successively bind VAR to an alist, vector and hash-table. +Each map is built from the following alist data: +'((0 . 3) (1 . 4) (2 . 5)). +Evaluate BODY for each created map. + +\(fn (var map) body)" + (declare (indent 1) (debug t)) + (let ((alist (make-symbol "alist")) + (vec (make-symbol "vec")) + (ht (make-symbol "ht"))) + `(let ((,alist (list (cons 0 3) + (cons 1 4) + (cons 2 5))) + (,vec (vector 3 4 5)) + (,ht (make-hash-table))) + (puthash 0 3 ,ht) + (puthash 1 4 ,ht) + (puthash 2 5 ,ht) + (dolist (,var (list ,alist ,vec ,ht)) + ,@body)))) + +(ert-deftest test-map-elt () + (with-maps-do map + (should (= 3 (map-elt map 0))) + (should (= 4 (map-elt map 1))) + (should (= 5 (map-elt map 2))) + (should (null (map-elt map -1))) + (should (null (map-elt map 4))))) + +(ert-deftest test-map-elt-default () + (with-maps-do map + (should (= 5 (map-elt map 7 5))))) + +(ert-deftest test-map-elt-with-nil-value () + (should (null (map-elt '((a . 1) + (b)) + 'b + '2)))) + +(ert-deftest test-map-put () + (with-maps-do map + (setf (map-elt map 2) 'hello) + (should (eq (map-elt map 2) 'hello))) + (with-maps-do map + (map-put map 2 'hello) + (should (eq (map-elt map 2) 'hello))) + (let ((ht (make-hash-table))) + (setf (map-elt ht 2) 'a) + (should (eq (map-elt ht 2) + 'a))) + (let ((alist '((0 . a) (1 . b) (2 . c)))) + (setf (map-elt alist 2) 'a) + (should (eq (map-elt alist 2) + 'a))) + (let ((vec [3 4 5])) + (should-error (setf (map-elt vec 3) 6)))) + +(ert-deftest test-map-put-return-value () + (let ((ht (make-hash-table))) + (should (eq (map-put ht 'a 'hello) ht)))) + +(ert-deftest test-map-delete () + (with-maps-do map + (map-delete map 1) + (should (null (map-elt map 1)))) + (with-maps-do map + (map-delete map -2) + (should (null (map-elt map -2))))) + +(ert-deftest test-map-delete-return-value () + (let ((ht (make-hash-table))) + (should (eq (map-delete ht 'a) ht)))) + +(ert-deftest test-map-nested-elt () + (let ((vec [a b [c d [e f]]])) + (should (eq (map-nested-elt vec '(2 2 0)) 'e))) + (let ((alist '((a . 1) + (b . ((c . 2) + (d . 3) + (e . ((f . 4) + (g . 5)))))))) + (should (eq (map-nested-elt alist '(b e f)) + 4))) + (let ((ht (make-hash-table))) + (setf (map-elt ht 'a) 1) + (setf (map-elt ht 'b) (make-hash-table)) + (setf (map-elt (map-elt ht 'b) 'c) 2) + (should (eq (map-nested-elt ht '(b c)) + 2)))) + +(ert-deftest test-map-nested-elt-default () + (let ((vec [a b [c d]])) + (should (null (map-nested-elt vec '(2 3)))) + (should (null (map-nested-elt vec '(2 1 1)))) + (should (= 4 (map-nested-elt vec '(2 1 1) 4))))) + +(ert-deftest test-mapp () + (should (mapp nil)) + (should (mapp '((a . b) (c . d)))) + (should (mapp '(a b c d))) + (should (mapp [])) + (should (mapp [1 2 3])) + (should (mapp (make-hash-table))) + (should (mapp "hello")) + (should (not (mapp 1))) + (should (not (mapp 'hello)))) + +(ert-deftest test-map-keys () + (with-maps-do map + (should (equal (map-keys map) '(0 1 2)))) + (should (null (map-keys nil))) + (should (null (map-keys [])))) + +(ert-deftest test-map-values () + (with-maps-do map + (should (equal (map-values map) '(3 4 5))))) + +(ert-deftest test-map-pairs () + (with-maps-do map + (should (equal (map-pairs map) '((0 . 3) + (1 . 4) + (2 . 5)))))) + +(ert-deftest test-map-length () + (let ((ht (make-hash-table))) + (puthash 'a 1 ht) + (puthash 'b 2 ht) + (puthash 'c 3 ht) + (puthash 'd 4 ht) + (should (= 0 (map-length nil))) + (should (= 0 (map-length []))) + (should (= 0 (map-length (make-hash-table)))) + (should (= 5 (map-length [0 1 2 3 4]))) + (should (= 2 (map-length '((a . 1) (b . 2))))) + (should (= 4 (map-length ht))))) + +(ert-deftest test-map-copy () + (with-maps-do map + (let ((copy (map-copy map))) + (should (equal (map-keys map) (map-keys copy))) + (should (equal (map-values map) (map-values copy))) + (should (not (eq map copy)))))) + +(ert-deftest test-map-apply () + (with-maps-do map + (should (equal (map-apply (lambda (k v) (cons (int-to-string k) v)) + map) + '(("0" . 3) ("1" . 4) ("2" . 5))))) + (let ((vec [a b c])) + (should (equal (map-apply (lambda (k v) (cons (1+ k) v)) + vec) + '((1 . a) + (2 . b) + (3 . c)))))) + +(ert-deftest test-map-keys-apply () + (with-maps-do map + (should (equal (map-keys-apply (lambda (k) (int-to-string k)) + map) + '("0" "1" "2")))) + (let ((vec [a b c])) + (should (equal (map-keys-apply (lambda (k) (1+ k)) + vec) + '(1 2 3))))) + +(ert-deftest test-map-values-apply () + (with-maps-do map + (should (equal (map-values-apply (lambda (v) (1+ v)) + map) + '(4 5 6)))) + (let ((vec [a b c])) + (should (equal (map-values-apply (lambda (v) (symbol-name v)) + vec) + '("a" "b" "c"))))) + +(ert-deftest test-map-filter () + (with-maps-do map + (should (equal (map-keys (map-filter (lambda (_k v) + (<= 4 v)) + map)) + '(1 2))) + (should (null (map-filter (lambda (k _v) + (eq 'd k)) + map)))) + (should (null (map-filter (lambda (_k v) + (eq 3 v)) + [1 2 4 5]))) + (should (equal (map-filter (lambda (k _v) + (eq 3 k)) + [1 2 4 5]) + '((3 . 5))))) + +(ert-deftest test-map-remove () + (with-maps-do map + (should (equal (map-keys (map-remove (lambda (_k v) + (>= v 4)) + map)) + '(0))) + (should (equal (map-keys (map-remove (lambda (k _v) + (eq 'd k)) + map)) + (map-keys map)))) + (should (equal (map-remove (lambda (_k v) + (eq 3 v)) + [1 2 4 5]) + '((0 . 1) + (1 . 2) + (2 . 4) + (3 . 5)))) + (should (null (map-remove (lambda (k _v) + (>= k 0)) + [1 2 4 5])))) + +(ert-deftest test-map-empty-p () + (should (map-empty-p nil)) + (should (not (map-empty-p '((a . b) (c . d))))) + (should (map-empty-p [])) + (should (not (map-empty-p [1 2 3]))) + (should (map-empty-p (make-hash-table))) + (should (not (map-empty-p "hello"))) + (should (map-empty-p ""))) + +(ert-deftest test-map-contains-key () + (should (map-contains-key '((a . 1) (b . 2)) 'a)) + (should (not (map-contains-key '((a . 1) (b . 2)) 'c))) + (should (map-contains-key '(("a" . 1)) "a")) + (should (not (map-contains-key '(("a" . 1)) "a" #'eq))) + (should (map-contains-key [a b c] 2)) + (should (not (map-contains-key [a b c] 3)))) + +(ert-deftest test-map-some () + (with-maps-do map + (should (map-some (lambda (k _v) + (eq 1 k)) + map)) + (should-not (map-some (lambda (k _v) + (eq 'd k)) + map))) + (let ((vec [a b c])) + (should (map-some (lambda (k _v) + (> k 1)) + vec)) + (should-not (map-some (lambda (k _v) + (> k 3)) + vec)))) + +(ert-deftest test-map-every-p () + (with-maps-do map + (should (map-every-p (lambda (k _v) + k) + map)) + (should (not (map-every-p (lambda (_k _v) + nil) + map)))) + (let ((vec [a b c])) + (should (map-every-p (lambda (k _v) + (>= k 0)) + vec)) + (should (not (map-every-p (lambda (k _v) + (> k 3)) + vec))))) + +(ert-deftest test-map-into () + (let* ((alist '((a . 1) (b . 2))) + (ht (map-into alist 'hash-table))) + (should (hash-table-p ht)) + (should (equal (map-into (map-into alist 'hash-table) 'list) + alist)) + (should (listp (map-into ht 'list))) + (should (equal (map-keys (map-into (map-into ht 'list) 'hash-table)) + (map-keys ht))) + (should (equal (map-values (map-into (map-into ht 'list) 'hash-table)) + (map-values ht))) + (should (null (map-into nil 'list))) + (should (map-empty-p (map-into nil 'hash-table))) + (should-error (map-into [1 2 3] 'string)))) + +(ert-deftest test-map-let () + (map-let (foo bar baz) '((foo . 1) (bar . 2)) + (should (= foo 1)) + (should (= bar 2)) + (should (null baz))) + (map-let (('foo a) + ('bar b) + ('baz c)) + '((foo . 1) (bar . 2)) + (should (= a 1)) + (should (= b 2)) + (should (null c)))) + +(ert-deftest test-map-merge-with () + (should (equal (map-merge-with 'list #'+ + '((1 . 2)) + '((1 . 3) (2 . 4)) + '((1 . 1) (2 . 5) (3 . 0))) + '((3 . 0) (2 . 9) (1 . 6))))) + +(provide 'map-tests) +;;; map-tests.el ends here diff --git a/test/lisp/emacs-lisp/nadvice-tests.el b/test/lisp/emacs-lisp/nadvice-tests.el new file mode 100644 index 00000000000..cd51599b86a --- /dev/null +++ b/test/lisp/emacs-lisp/nadvice-tests.el @@ -0,0 +1,211 @@ +;;; advice-tests.el --- Test suite for the new advice thingy. + +;; Copyright (C) 2012-2016 Free Software Foundation, Inc. + +;; 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: + +;;; Code: + +(require 'ert) + +(ert-deftest advice-tests-nadvice () + "Test nadvice code." + (advice-add 'sm-test1 :around (lambda (f y) (* (funcall f y) 5))) + (advice-add 'sm-test1 :around (lambda (f y) (* (funcall f y) 2))) + (advice-remove 'sm-test1 (lambda (f y) (* (funcall f y) 5))) + (defun sm-test1 (x) (+ x 4)) + (should (equal (sm-test1 6) 20)) + (advice-remove 'sm-test1 (lambda (f y) (* (funcall f y) 2))) + (should (equal (sm-test1 6) 10)) + (advice-add 'sm-test1 :around (lambda (f y) (* (funcall f y) 5))) + (should (equal (sm-test1 6) 50)) + (defun sm-test1 (x) (+ x 14)) + (should (equal (sm-test1 6) 100)) + (should (equal (null (get 'sm-test1 'defalias-fset-function)) nil)) + (advice-remove 'sm-test1 (lambda (f y) (* (funcall f y) 5))) + (should (equal (sm-test1 6) 20)) + (should (equal (get 'sm-test1 'defalias-fset-function) nil)) + + (advice-add 'sm-test3 :around + (lambda (f &rest args) `(toto ,(apply f args))) + '((name . wrap-with-toto))) + (defmacro sm-test3 (x) `(call-test3 ,x)) + (should (equal (macroexpand '(sm-test3 56)) '(toto (call-test3 56))))) + +(ert-deftest advice-tests-macroaliases () + "Test nadvice code on aliases to macros." + (defmacro sm-test1 (a) `(list ',a)) + (defalias 'sm-test1-alias 'sm-test1) + (should (equal (macroexpand '(sm-test1-alias 5)) '(list '5))) + (advice-add 'sm-test1-alias :around + (lambda (f &rest args) `(cons 1 ,(apply f args)))) + (should (equal (macroexpand '(sm-test1-alias 5)) '(cons 1 (list '5)))) + (defmacro sm-test1 (a) `(list 0 ',a)) + (should (equal (macroexpand '(sm-test1-alias 5)) '(cons 1 (list 0 '5))))) + + +(ert-deftest advice-tests-advice () + "Test advice code." + (defun sm-test2 (x) (+ x 4)) + (should (equal (sm-test2 6) 10)) + (defadvice sm-test2 (around sm-test activate) + ad-do-it (setq ad-return-value (* ad-return-value 5))) + (should (equal (sm-test2 6) 50)) + (ad-deactivate 'sm-test2) + (should (equal (sm-test2 6) 10)) + (ad-activate 'sm-test2) + (should (equal (sm-test2 6) 50)) + (defun sm-test2 (x) (+ x 14)) + (should (equal (sm-test2 6) 100)) + (should (equal (null (get 'sm-test2 'defalias-fset-function)) nil)) + (ad-remove-advice 'sm-test2 'around 'sm-test) + (should (equal (sm-test2 6) 100)) + (ad-activate 'sm-test2) + (should (equal (sm-test2 6) 20)) + (should (equal (null (get 'sm-test2 'defalias-fset-function)) t)) + + (defadvice sm-test4 (around wrap-with-toto activate) + ad-do-it (setq ad-return-value `(toto ,ad-return-value))) + (defmacro sm-test4 (x) `(call-test4 ,x)) + (should (equal (macroexpand '(sm-test4 56)) '(toto (call-test4 56)))) + (defmacro sm-test4 (x) `(call-testq ,x)) + (should (equal (macroexpand '(sm-test4 56)) '(toto (call-testq 56)))) + + ;; This used to signal an error (bug#12858). + (autoload 'sm-test6 "foo") + (defadvice sm-test6 (around test activate) + ad-do-it)) + +(ert-deftest advice-tests-combination () + "Combining old style and new style advices." + (defun sm-test5 (x) (+ x 4)) + (should (equal (sm-test5 6) 10)) + (advice-add 'sm-test5 :around (lambda (f y) (* (funcall f y) 5))) + (should (equal (sm-test5 6) 50)) + (defadvice sm-test5 (around test activate) + ad-do-it (setq ad-return-value (+ ad-return-value 0.1))) + (should (equal (sm-test5 5) 45.1)) + (ad-deactivate 'sm-test5) + (should (equal (sm-test5 6) 50)) + (ad-activate 'sm-test5) + (should (equal (sm-test5 6) 50.1)) + (defun sm-test5 (x) (+ x 14)) + (should (equal (sm-test5 6) 100.1)) + (advice-remove 'sm-test5 (lambda (f y) (* (funcall f y) 5))) + (should (equal (sm-test5 6) 20.1))) + +(ert-deftest advice-test-called-interactively-p () + "Check interaction between advice and called-interactively-p." + (defun sm-test7 (&optional x) (interactive) (+ (or x 7) 4)) + (advice-add 'sm-test7 :around + (lambda (f &rest args) + (list (cons 1 (called-interactively-p)) (apply f args)))) + (should (equal (sm-test7) '((1 . nil) 11))) + (should (equal (call-interactively 'sm-test7) '((1 . t) 11))) + (let ((smi 7)) + (advice-add 'sm-test7 :before + (lambda (&rest args) + (setq smi (called-interactively-p)))) + (should (equal (list (sm-test7) smi) + '(((1 . nil) 11) nil))) + (should (equal (list (call-interactively 'sm-test7) smi) + '(((1 . t) 11) t)))) + (advice-add 'sm-test7 :around + (lambda (f &rest args) + (cons (cons 2 (called-interactively-p)) (apply f args)))) + (should (equal (call-interactively 'sm-test7) '((2 . t) (1 . t) 11)))) + +(ert-deftest advice-test-called-interactively-p-around () + "Check interaction between around advice and called-interactively-p. + +This tests the currently broken case of the innermost advice to a +function being an around advice." + :expected-result :failed + (defun sm-test7.2 () (interactive) (cons 1 (called-interactively-p))) + (advice-add 'sm-test7.2 :around + (lambda (f &rest args) + (list (cons 1 (called-interactively-p)) (apply f args)))) + (should (equal (sm-test7.2) '((1 . nil) (1 . nil)))) + (should (equal (call-interactively 'sm-test7.2) '((1 . t) (1 . t))))) + +(ert-deftest advice-test-called-interactively-p-filter-args () + "Check interaction between filter-args advice and called-interactively-p." + :expected-result :failed + (defun sm-test7.3 () (interactive) (cons 1 (called-interactively-p))) + (advice-add 'sm-test7.3 :filter-args #'list) + (should (equal (sm-test7.3) '(1 . nil))) + (should (equal (call-interactively 'sm-test7.3) '(1 . t)))) + +(ert-deftest advice-test-call-interactively () + "Check interaction between advice on call-interactively and called-interactively-p." + (defun sm-test7.4 () (interactive) (cons 1 (called-interactively-p))) + (let ((old (symbol-function 'call-interactively))) + (unwind-protect + (progn + (advice-add 'call-interactively :before #'ignore) + (should (equal (sm-test7.4) '(1 . nil))) + (should (equal (call-interactively 'sm-test7.4) '(1 . t)))) + (advice-remove 'call-interactively #'ignore) + (should (eq (symbol-function 'call-interactively) old))))) + +(ert-deftest advice-test-interactive () + "Check handling of interactive spec." + (defun sm-test8 (a) (interactive "p") a) + (defadvice sm-test8 (before adv1 activate) nil) + (defadvice sm-test8 (before adv2 activate) (interactive "P") nil) + (should (equal (interactive-form 'sm-test8) '(interactive "P")))) + +(ert-deftest advice-test-preactivate () + (should (equal (null (get 'sm-test9 'defalias-fset-function)) t)) + (defun sm-test9 (a) (interactive "p") a) + (should (equal (null (get 'sm-test9 'defalias-fset-function)) t)) + (defadvice sm-test9 (before adv1 pre act protect compile) nil) + (should (equal (null (get 'sm-test9 'defalias-fset-function)) nil)) + (defadvice sm-test9 (before adv2 pre act protect compile) + (interactive "P") nil) + (should (equal (interactive-form 'sm-test9) '(interactive "P")))) + +(ert-deftest advice-test-multiples () + (let ((sm-test10 (lambda (a) (+ a 10))) + (sm-advice (lambda (x) (if (consp x) (list (* 5 (car x))) (* 4 x))))) + (should (equal (funcall sm-test10 5) 15)) + (add-function :filter-args (var sm-test10) sm-advice) + (should (advice-function-member-p sm-advice sm-test10)) + (should (equal (funcall sm-test10 5) 35)) + (add-function :filter-return (var sm-test10) sm-advice) + (should (equal (funcall sm-test10 5) 60)) + ;; Make sure we can add multiple times the same function, under the + ;; condition that they have different `name' properties. + (add-function :filter-args (var sm-test10) sm-advice '((name . "args"))) + (should (equal (funcall sm-test10 5) 140)) + (remove-function (var sm-test10) "args") + (should (equal (funcall sm-test10 5) 60)) + (add-function :filter-args (var sm-test10) sm-advice '((name . "args"))) + (add-function :filter-return (var sm-test10) sm-advice '((name . "ret"))) + (should (equal (funcall sm-test10 5) 560)) + ;; Make sure that if we specify to remove a function that was added + ;; multiple times, they are all removed, rather than removing only some + ;; arbitrary subset of them. + (remove-function (var sm-test10) sm-advice) + (should (equal (funcall sm-test10 5) 15)))) + +;; Local Variables: +;; no-byte-compile: t +;; End: + +;;; advice-tests.el ends here. diff --git a/test/lisp/emacs-lisp/package-resources/archive-contents b/test/lisp/emacs-lisp/package-resources/archive-contents new file mode 100644 index 00000000000..e2f92304f86 --- /dev/null +++ b/test/lisp/emacs-lisp/package-resources/archive-contents @@ -0,0 +1,17 @@ +(1 + (simple-single . + [(1 3) + nil "A single-file package with no dependencies" single + ((:url . "http://doodles.au") + (:keywords quote ("frobnicate")))]) + (simple-depend . + [(1 0) + ((simple-single (1 3))) "A single-file package with a dependency." single]) + (simple-two-depend . + [(1 1) + ((simple-depend (1 0)) (simple-single (1 3))) + "A single-file package with two dependencies." single]) + (multi-file . + [(0 2 3) + nil "Example of a multi-file tar package" tar + ((:url . "http://puddles.li"))])) diff --git a/test/lisp/emacs-lisp/package-resources/key.pub b/test/lisp/emacs-lisp/package-resources/key.pub new file mode 100644 index 00000000000..a326d34e54f --- /dev/null +++ b/test/lisp/emacs-lisp/package-resources/key.pub @@ -0,0 +1,18 @@ +-----BEGIN PGP PUBLIC KEY BLOCK----- +Version: GnuPG v1.4.14 (GNU/Linux) + +mQENBFJNB8gBCACfbtpvYrM8V1HM0KFlIwatcEJugHqwOHpr/Z9mrCW0fxyQAW/d +2L+3QVNsN9Tz/K9lLcBUgeR7rhVEzHNqhmhNj/HnikwGqXbIofhp+QbZmBKnAlCz +d77kg8K9lozHtfTkm1gX/7DdPzQKmgi7WOzzi2395wGubeqJLvYaEcqVbI0Eob+E +3CzRjNy/e/Tf3TJRW5etTcdZN6LVuIY7tNCHqlQZTwyycON/hfLTX6cLCnzDsqm/ +NxCuwn9aqP9aGRGfIu7Y+If3zTymvrXEPUN98OEID814bOKdx0uVTZRiSMbvuTGI +8uMa/kpGX/78rqI61gbZV51RFoU7pT2tzwY/ABEBAAG0HkouIFIuIEhhY2tlciA8 +anJoQGV4YW1wbGUuY29tPokBOAQTAQIAIgUCUk0HyAIbAwYLCQgHAwIGFQgCCQoL +BBYCAwECHgECF4AACgkQtpVAhgkYletuhQf+JAyHYhTZNxjq0UYlikuLX8EtYbXX +PB+03J0B73SMzEai5XsiTU2ADxqxwr7pveVK1INf+IGLiiXBlQq+4DSOvQY4xLfp +58jTOYRV1ECvlXK/JtvVOwufXREADaydf9l/MUxA5G2PPBWIuQknh3ysPSsx68OJ +SzNHFwklLn0DKc4WloE/GLDpTzimnCg7QGzuUo3Iilpjdy8EvTdI5d3jx/mGJIwI +goB+YZgyxSPM+GjDwh5DEwD7OexNqqa7RynnmU0epmlYyi9UufCHLwgiiEIzjpWi +6+iF+CQ45ZAKncovByenIUv73J3ImOudrsskeAHBmahljv1he6uV9Egj2Q== +=b5Kg +-----END PGP PUBLIC KEY BLOCK----- diff --git a/test/lisp/emacs-lisp/package-resources/key.sec b/test/lisp/emacs-lisp/package-resources/key.sec new file mode 100644 index 00000000000..d21e6ae9a45 --- /dev/null +++ b/test/lisp/emacs-lisp/package-resources/key.sec @@ -0,0 +1,33 @@ +-----BEGIN PGP PRIVATE KEY BLOCK----- +Version: GnuPG v1.4.14 (GNU/Linux) + +lQO+BFJNB8gBCACfbtpvYrM8V1HM0KFlIwatcEJugHqwOHpr/Z9mrCW0fxyQAW/d +2L+3QVNsN9Tz/K9lLcBUgeR7rhVEzHNqhmhNj/HnikwGqXbIofhp+QbZmBKnAlCz +d77kg8K9lozHtfTkm1gX/7DdPzQKmgi7WOzzi2395wGubeqJLvYaEcqVbI0Eob+E +3CzRjNy/e/Tf3TJRW5etTcdZN6LVuIY7tNCHqlQZTwyycON/hfLTX6cLCnzDsqm/ +NxCuwn9aqP9aGRGfIu7Y+If3zTymvrXEPUN98OEID814bOKdx0uVTZRiSMbvuTGI +8uMa/kpGX/78rqI61gbZV51RFoU7pT2tzwY/ABEBAAH+AwMCKCCpPNXkXuVgF7cz +eByuvgIO7wImDYGOdJqsASSzV4q0u1acnGtlxg7WphKDF9RnC5+1ZZ1ZcrBcv2uJ +xZm2jHdjqM3FmgQTN70GVzO1nKEur2wxlKotG4Q+8BtaRDwHdKpQFk+QW9aInH3C +BkNWTK97iFwZaoUGxKuRJb35qjMe3SsDE7kdbtOqO+tOeppRVeOOZCn7F33ir/6i +j2gmIME6LFDzvBi6YAyMBSh90Ak70HJINt0QfXlZf5MtX1NaxaEcnsRmwwcNqxh9 +JvcC9q4WrR92NhHCHI+lOsAe7hbwo/VkwRjSSx0HdKkx6kvdcNj/9LeX/jykzLvg +kEqvAqT4Jmk57W2seqvpNcAO+eUVrJ5D1OR6khsUtikPp2pQH5MDXJDGcie+ZAFb +w6BwoWBDBjooKtfuP0LKqrdtJG2JLe6yhBhWvfqHPBlUU1SsA7a5aTCLo8FiqgEI +Kyy60zMx/2Mi48oN1a/mAoV1MTWLhOVUWJlIHM7nVLj1OaX0316LcLX/uTLTq40p +apHKwERanzY7f8ROiv/Fa/J+9cCsfOLKfjFAjpBVUVoOb39HsyS/vvkGMY4kgaD6 +K6r9JPdsaoYvsLkxk5HyHF7Mk2uS1z1EIArD2/3lRiX6ag+IU1Nl3XDkgfZj06K3 +juS84dGF8CmN49uOEjzAJAQZH9jTs5OKzUuZhGJF+gt0L78vLOoKRr8bu1N1GPqU +wnS908HWruXzjJl1CAhnuCa8FnDaU+tmEKjYpWuelx85kolpMW7LT5gOFZr84MIj +Kq3Rt2hU6qQ7Cdy1ep531YKkmyh9Y4l/Tgir1OtnQQqtNuwHI497l7qAUnKZBBHZ +guApjS9BoHsRXkw2mgDssZ+khOwj/xJm876nFSiQeCD0aIbU/4zJ9e2HUOJAZI1r +d7QeSi4gUi4gSGFja2VyIDxqcmhAZXhhbXBsZS5jb20+iQE4BBMBAgAiBQJSTQfI +AhsDBgsJCAcDAgYVCAIJCgsEFgIDAQIeAQIXgAAKCRC2lUCGCRiV626FB/4kDIdi +FNk3GOrRRiWKS4tfwS1htdc8H7TcnQHvdIzMRqLleyJNTYAPGrHCvum95UrUg1/4 +gYuKJcGVCr7gNI69BjjEt+nnyNM5hFXUQK+Vcr8m29U7C59dEQANrJ1/2X8xTEDk +bY88FYi5CSeHfKw9KzHrw4lLM0cXCSUufQMpzhaWgT8YsOlPOKacKDtAbO5SjciK +WmN3LwS9N0jl3ePH+YYkjAiCgH5hmDLFI8z4aMPCHkMTAPs57E2qprtHKeeZTR6m +aVjKL1S58IcvCCKIQjOOlaLr6IX4JDjlkAqdyi8HJ6chS/vcnciY652uyyR4AcGZ +qGWO/WF7q5X0SCPZ +=5FZK +-----END PGP PRIVATE KEY BLOCK----- diff --git a/test/lisp/emacs-lisp/package-resources/macro-problem-package-1.0/macro-aux.el b/test/lisp/emacs-lisp/package-resources/macro-problem-package-1.0/macro-aux.el new file mode 100644 index 00000000000..f43232224af --- /dev/null +++ b/test/lisp/emacs-lisp/package-resources/macro-problem-package-1.0/macro-aux.el @@ -0,0 +1,12 @@ +;;; macro-aux.el --- laksd -*- lexical-binding: t; -*- + +;; Author: Artur Malabarba <emacs@endlessparentheses.com> + +;;; Code: + +(defun macro-aux-1 ( &rest forms) + "Description" + `(progn ,@forms)) + +(provide 'macro-aux) +;;; macro-aux.el ends here diff --git a/test/lisp/emacs-lisp/package-resources/macro-problem-package-1.0/macro-problem.el b/test/lisp/emacs-lisp/package-resources/macro-problem-package-1.0/macro-problem.el new file mode 100644 index 00000000000..0533b1bd9c4 --- /dev/null +++ b/test/lisp/emacs-lisp/package-resources/macro-problem-package-1.0/macro-problem.el @@ -0,0 +1,21 @@ +;;; macro-problem.el --- laksd -*- lexical-binding: t; -*- + +;; Author: Artur Malabarba <emacs@endlessparentheses.com> +;; Keywords: tools +;; Version: 1.0 + +;;; Code: + +(require 'macro-aux) + +(defmacro macro-problem-1 ( &rest forms) + "Description" + `(progn ,@forms)) + +(defun macro-problem-func () + "" + (macro-problem-1 'a 'b) + (macro-aux-1 'a 'b)) + +(provide 'macro-problem) +;;; macro-problem.el ends here diff --git a/test/lisp/emacs-lisp/package-resources/macro-problem-package-2.0/macro-aux.el b/test/lisp/emacs-lisp/package-resources/macro-problem-package-2.0/macro-aux.el new file mode 100644 index 00000000000..6a55a40e3b4 --- /dev/null +++ b/test/lisp/emacs-lisp/package-resources/macro-problem-package-2.0/macro-aux.el @@ -0,0 +1,16 @@ +;;; macro-aux.el --- laksd -*- lexical-binding: t; -*- + +;; Author: Artur Malabarba <emacs@endlessparentheses.com> + +;;; Code: + +(defmacro macro-aux-1 ( &rest forms) + "Description" + `(progn ,@forms)) + +(defmacro macro-aux-3 ( &rest _) + "Description" + 90) + +(provide 'macro-aux) +;;; macro-aux.el ends here diff --git a/test/lisp/emacs-lisp/package-resources/macro-problem-package-2.0/macro-problem.el b/test/lisp/emacs-lisp/package-resources/macro-problem-package-2.0/macro-problem.el new file mode 100644 index 00000000000..cad4ed93f19 --- /dev/null +++ b/test/lisp/emacs-lisp/package-resources/macro-problem-package-2.0/macro-problem.el @@ -0,0 +1,30 @@ +;;; macro-problem.el --- laksd -*- lexical-binding: t; -*- + +;; Author: Artur Malabarba <emacs@endlessparentheses.com> +;; Keywords: tools +;; Version: 2.0 + +;;; Code: + +(require 'macro-aux) + +(defmacro macro-problem-1 ( &rest forms) + "Description" + `(progn ,(cadr (car forms)))) + + +(defun macro-problem-func () + "" + (list (macro-problem-1 '1 'b) + (macro-aux-1 'a 'b))) + +(defmacro macro-problem-3 (&rest _) + "Description" + 10) + +(defun macro-problem-10-and-90 () + "" + (list (macro-problem-3 haha) (macro-aux-3 hehe))) + +(provide 'macro-problem) +;;; macro-problem.el ends here diff --git a/test/lisp/emacs-lisp/package-resources/multi-file-0.2.3.tar b/test/lisp/emacs-lisp/package-resources/multi-file-0.2.3.tar Binary files differnew file mode 100644 index 00000000000..2f1c5e93df1 --- /dev/null +++ b/test/lisp/emacs-lisp/package-resources/multi-file-0.2.3.tar diff --git a/test/lisp/emacs-lisp/package-resources/multi-file-readme.txt b/test/lisp/emacs-lisp/package-resources/multi-file-readme.txt new file mode 100644 index 00000000000..affd2e96fb0 --- /dev/null +++ b/test/lisp/emacs-lisp/package-resources/multi-file-readme.txt @@ -0,0 +1 @@ +This is a bare-bones readme file for the multi-file package. diff --git a/test/lisp/emacs-lisp/package-resources/newer-versions/archive-contents b/test/lisp/emacs-lisp/package-resources/newer-versions/archive-contents new file mode 100644 index 00000000000..add5f2909d0 --- /dev/null +++ b/test/lisp/emacs-lisp/package-resources/newer-versions/archive-contents @@ -0,0 +1,13 @@ +(1 + (simple-single . + [(1 4) + nil "A single-file package with no dependencies" single]) + (simple-depend . + [(1 0) + ((simple-single (1 3))) "A single-file package with a dependency." single]) + (new-pkg . + [(1 0) + nil "A package only seen after "updating" archive-contents" single]) + (multi-file . + [(0 2 3) + nil "Example of a multi-file tar package" tar])) diff --git a/test/lisp/emacs-lisp/package-resources/newer-versions/new-pkg-1.0.el b/test/lisp/emacs-lisp/package-resources/newer-versions/new-pkg-1.0.el new file mode 100644 index 00000000000..7251622fa59 --- /dev/null +++ b/test/lisp/emacs-lisp/package-resources/newer-versions/new-pkg-1.0.el @@ -0,0 +1,18 @@ +;;; new-pkg.el --- A package only seen after "updating" archive-contents + +;; Author: J. R. Hacker <jrh@example.com> +;; Version: 1.0 + +;;; Commentary: + +;; This will only show up after updating "archive-contents". + +;;; Code: + +(defun new-pkg-frob () + "Ignore me." + (ignore)) + +(provide 'new-pkg) + +;;; new-pkg.el ends here diff --git a/test/lisp/emacs-lisp/package-resources/newer-versions/simple-single-1.4.el b/test/lisp/emacs-lisp/package-resources/newer-versions/simple-single-1.4.el new file mode 100644 index 00000000000..7b1c00c06db --- /dev/null +++ b/test/lisp/emacs-lisp/package-resources/newer-versions/simple-single-1.4.el @@ -0,0 +1,36 @@ +;;; simple-single.el --- A single-file package with no dependencies + +;; Author: J. R. Hacker <jrh@example.com> +;; Version: 1.4 +;; Keywords: frobnicate + +;;; Commentary: + +;; This package provides a minor mode to frobnicate and/or bifurcate +;; any flanges you desire. To activate it, type "C-M-r M-3 butterfly" +;; and all your dreams will come true. +;; +;; This is a new, updated version. + +;;; Code: + +(defgroup simple-single nil "Simply a file" + :group 'lisp) + +(defcustom simple-single-super-sunday nil + "How great is this? +Default changed to nil." + :type 'boolean + :group 'simple-single + :package-version "1.4") + +(defvar simple-single-sudo-sandwich nil + "Make a sandwich?") + +;;;###autoload +(define-minor-mode simple-single-mode + "It does good things to stuff") + +(provide 'simple-single) + +;;; simple-single.el ends here diff --git a/test/lisp/emacs-lisp/package-resources/package-test-server.py b/test/lisp/emacs-lisp/package-resources/package-test-server.py new file mode 100644 index 00000000000..35ca820f31f --- /dev/null +++ b/test/lisp/emacs-lisp/package-resources/package-test-server.py @@ -0,0 +1,21 @@ +import sys +import BaseHTTPServer +from SimpleHTTPServer import SimpleHTTPRequestHandler + + +HandlerClass = SimpleHTTPRequestHandler +ServerClass = BaseHTTPServer.HTTPServer +Protocol = "HTTP/1.0" + +if sys.argv[1:]: + port = int(sys.argv[1]) +else: + port = 8000 + server_address = ('127.0.0.1', port) + +HandlerClass.protocol_version = Protocol +httpd = ServerClass(server_address, HandlerClass) + +sa = httpd.socket.getsockname() +print "Serving HTTP on", sa[0], "port", sa[1], "..." +httpd.serve_forever() diff --git a/test/lisp/emacs-lisp/package-resources/signed/archive-contents b/test/lisp/emacs-lisp/package-resources/signed/archive-contents new file mode 100644 index 00000000000..2a773ecba6a --- /dev/null +++ b/test/lisp/emacs-lisp/package-resources/signed/archive-contents @@ -0,0 +1,7 @@ +(1 + (signed-good . + [(1 0) + nil "A package with good signature" single]) + (signed-bad . + [(1 0) + nil "A package with bad signature" single])) diff --git a/test/lisp/emacs-lisp/package-resources/signed/archive-contents.sig b/test/lisp/emacs-lisp/package-resources/signed/archive-contents.sig Binary files differnew file mode 100644 index 00000000000..658edd3f60e --- /dev/null +++ b/test/lisp/emacs-lisp/package-resources/signed/archive-contents.sig diff --git a/test/lisp/emacs-lisp/package-resources/signed/signed-bad-1.0.el b/test/lisp/emacs-lisp/package-resources/signed/signed-bad-1.0.el new file mode 100644 index 00000000000..3734823876e --- /dev/null +++ b/test/lisp/emacs-lisp/package-resources/signed/signed-bad-1.0.el @@ -0,0 +1,33 @@ +;;; signed-bad.el --- A single-file package with bad signature + +;; Author: J. R. Hacker <jrh@example.com> +;; Version: 1.0 +;; Keywords: frobnicate +;; URL: http://doodles.au + +;;; Commentary: + +;; This package provides a minor mode to frobnicate and/or bifurcate +;; any flanges you desire. To activate it, type "C-M-r M-3 butterfly" +;; and all your dreams will come true. + +;;; Code: + +(defgroup signed-bad nil "Simply a file" + :group 'lisp) + +(defcustom signed-bad-super-sunday t + "How great is this?" + :type 'boolean + :group 'signed-bad) + +(defvar signed-bad-sudo-sandwich nil + "Make a sandwich?") + +;;;###autoload +(define-minor-mode signed-bad-mode + "It does good things to stuff") + +(provide 'signed-bad) + +;;; signed-bad.el ends here diff --git a/test/lisp/emacs-lisp/package-resources/signed/signed-bad-1.0.el.sig b/test/lisp/emacs-lisp/package-resources/signed/signed-bad-1.0.el.sig Binary files differnew file mode 100644 index 00000000000..747918794ca --- /dev/null +++ b/test/lisp/emacs-lisp/package-resources/signed/signed-bad-1.0.el.sig diff --git a/test/lisp/emacs-lisp/package-resources/signed/signed-good-1.0.el b/test/lisp/emacs-lisp/package-resources/signed/signed-good-1.0.el new file mode 100644 index 00000000000..22718df2763 --- /dev/null +++ b/test/lisp/emacs-lisp/package-resources/signed/signed-good-1.0.el @@ -0,0 +1,33 @@ +;;; signed-good.el --- A single-file package with good signature + +;; Author: J. R. Hacker <jrh@example.com> +;; Version: 1.0 +;; Keywords: frobnicate +;; URL: http://doodles.au + +;;; Commentary: + +;; This package provides a minor mode to frobnicate and/or bifurcate +;; any flanges you desire. To activate it, type "C-M-r M-3 butterfly" +;; and all your dreams will come true. + +;;; Code: + +(defgroup signed-good nil "Simply a file" + :group 'lisp) + +(defcustom signed-good-super-sunday t + "How great is this?" + :type 'boolean + :group 'signed-good) + +(defvar signed-good-sudo-sandwich nil + "Make a sandwich?") + +;;;###autoload +(define-minor-mode signed-good-mode + "It does good things to stuff") + +(provide 'signed-good) + +;;; signed-good.el ends here diff --git a/test/lisp/emacs-lisp/package-resources/signed/signed-good-1.0.el.sig b/test/lisp/emacs-lisp/package-resources/signed/signed-good-1.0.el.sig Binary files differnew file mode 100644 index 00000000000..747918794ca --- /dev/null +++ b/test/lisp/emacs-lisp/package-resources/signed/signed-good-1.0.el.sig diff --git a/test/lisp/emacs-lisp/package-resources/simple-depend-1.0.el b/test/lisp/emacs-lisp/package-resources/simple-depend-1.0.el new file mode 100644 index 00000000000..b58b658d024 --- /dev/null +++ b/test/lisp/emacs-lisp/package-resources/simple-depend-1.0.el @@ -0,0 +1,17 @@ +;;; simple-depend.el --- A single-file package with a dependency. + +;; Author: J. R. Hacker <jrh@example.com> +;; Version: 1.0 +;; Keywords: frobnicate +;; Package-Requires: ((simple-single "1.3")) + +;;; Commentary: + +;; Depends on another package. + +;;; Code: + +(defvar simple-depend "Value" + "Some trivial code") + +;;; simple-depend.el ends here diff --git a/test/lisp/emacs-lisp/package-resources/simple-single-1.3.el b/test/lisp/emacs-lisp/package-resources/simple-single-1.3.el new file mode 100644 index 00000000000..6756a28080b --- /dev/null +++ b/test/lisp/emacs-lisp/package-resources/simple-single-1.3.el @@ -0,0 +1,33 @@ +;;; simple-single.el --- A single-file package with no dependencies + +;; Author: J. R. Hacker <jrh@example.com> +;; Version: 1.3 +;; Keywords: frobnicate +;; URL: http://doodles.au + +;;; Commentary: + +;; This package provides a minor mode to frobnicate and/or bifurcate +;; any flanges you desire. To activate it, type "C-M-r M-3 butterfly" +;; and all your dreams will come true. + +;;; Code: + +(defgroup simple-single nil "Simply a file" + :group 'lisp) + +(defcustom simple-single-super-sunday t + "How great is this?" + :type 'boolean + :group 'simple-single) + +(defvar simple-single-sudo-sandwich nil + "Make a sandwich?") + +;;;###autoload +(define-minor-mode simple-single-mode + "It does good things to stuff") + +(provide 'simple-single) + +;;; simple-single.el ends here diff --git a/test/lisp/emacs-lisp/package-resources/simple-single-readme.txt b/test/lisp/emacs-lisp/package-resources/simple-single-readme.txt new file mode 100644 index 00000000000..25d3034032b --- /dev/null +++ b/test/lisp/emacs-lisp/package-resources/simple-single-readme.txt @@ -0,0 +1,3 @@ +This package provides a minor mode to frobnicate and/or bifurcate +any flanges you desire. To activate it, type "C-M-r M-3 butterfly" +and all your dreams will come true. diff --git a/test/lisp/emacs-lisp/package-resources/simple-two-depend-1.1.el b/test/lisp/emacs-lisp/package-resources/simple-two-depend-1.1.el new file mode 100644 index 00000000000..9cfe5c0d4e2 --- /dev/null +++ b/test/lisp/emacs-lisp/package-resources/simple-two-depend-1.1.el @@ -0,0 +1,17 @@ +;;; simple-two-depend.el --- A single-file package with two dependencies. + +;; Author: J. R. Hacker <jrh@example.com> +;; Version: 1.1 +;; Keywords: frobnicate +;; Package-Requires: ((simple-depend "1.0") (simple-single "1.3")) + +;;; Commentary: + +;; Depends on two another packages. + +;;; Code: + +(defvar simple-two-depend "Value" + "Some trivial code") + +;;; simple-two-depend.el ends here diff --git a/test/lisp/emacs-lisp/package-tests.el b/test/lisp/emacs-lisp/package-tests.el new file mode 100644 index 00000000000..9afdfe67c26 --- /dev/null +++ b/test/lisp/emacs-lisp/package-tests.el @@ -0,0 +1,626 @@ +;;; 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)) + t) + (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) + (should (package-install 'signed-good)) + (should-error (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)))))) + + + +;;; 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 diff --git a/test/lisp/emacs-lisp/pcase-tests.el b/test/lisp/emacs-lisp/pcase-tests.el new file mode 100644 index 00000000000..a428e4092f1 --- /dev/null +++ b/test/lisp/emacs-lisp/pcase-tests.el @@ -0,0 +1,74 @@ +;;; pcase-tests.el --- Test suite for pcase macro. + +;; Copyright (C) 2012-2016 Free Software Foundation, Inc. + +;; 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: + +;;; Code: + +(require 'ert) +(require 'cl-lib) + +(ert-deftest pcase-tests-base () + "Test pcase code." + (should (equal (pcase '(1 . 2) ((app car '2) 6) ((app car '1) 5)) 5))) + +(ert-deftest pcase-tests-bugs () + (should (equal (pcase '(2 . 3) ;bug#18554 + (`(,hd . ,(and (pred atom) tl)) (list hd tl)) + ((pred consp) nil)) + '(2 3)))) + +(pcase-defmacro pcase-tests-plus (pat n) + `(app (lambda (v) (- v ,n)) ,pat)) + +(ert-deftest pcase-tests-macro () + (should (equal (pcase 5 ((pcase-tests-plus x 3) x)) 2))) + +(defun pcase-tests-grep (fname exp) + (when (consp exp) + (or (eq fname (car exp)) + (cl-some (lambda (exp) (pcase-tests-grep fname exp)) (cdr exp))))) + +(ert-deftest pcase-tests-tests () + (should (pcase-tests-grep 'memq '(or (+ 2 3) (memq x y)))) + (should-not (pcase-tests-grep 'memq '(or (+ 2 3) (- x y))))) + +(ert-deftest pcase-tests-member () + (should (pcase-tests-grep + 'memq (macroexpand-all '(pcase x ((or 1 2 3) body))))) + (should (pcase-tests-grep + 'member (macroexpand-all '(pcase x ((or '"a" '2 '3) body))))) + (should-not (pcase-tests-grep + 'memq (macroexpand-all '(pcase x ((or "a" 2 3) body))))) + (let ((exp (macroexpand-all + '(pcase x + ("a" body1) + (2 body2) + ((or "a" 2 3) body))))) + (should-not (pcase-tests-grep 'memq exp)) + (should-not (pcase-tests-grep 'member exp)))) + +(ert-deftest pcase-tests-vectors () + (should (equal (pcase [1 2] (`[,x] 1) (`[,x ,y] (+ x y))) 3))) + +;; Local Variables: +;; no-byte-compile: t +;; End: + +;;; pcase-tests.el ends here. diff --git a/test/lisp/emacs-lisp/regexp-opt-tests.el b/test/lisp/emacs-lisp/regexp-opt-tests.el new file mode 100644 index 00000000000..01119a3374f --- /dev/null +++ b/test/lisp/emacs-lisp/regexp-opt-tests.el @@ -0,0 +1,33 @@ +;;; regexp-tests.el --- Test suite for regular expression handling. + +;; Copyright (C) 2013-2016 Free Software Foundation, Inc. + +;; Author: Stefan Monnier <monnier@iro.umontreal.ca> +;; Keywords: internal +;; Human-Keywords: internal + +;; 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/>. + +;;; Code: + +(require 'regexp-opt) + +(ert-deftest regexp-test-regexp-opt () + "Test the `compilation-error-regexp-alist' regexps. +The test data is in `compile-tests--test-regexps-data'." + (should (string-match (regexp-opt-charset '(?^)) "a^b"))) + +;;; regexp-tests.el ends here. diff --git a/test/lisp/emacs-lisp/seq-tests.el b/test/lisp/emacs-lisp/seq-tests.el new file mode 100644 index 00000000000..a8ca48b1328 --- /dev/null +++ b/test/lisp/emacs-lisp/seq-tests.el @@ -0,0 +1,341 @@ +;;; seq-tests.el --- Tests for sequences.el + +;; Copyright (C) 2014-2016 Free Software Foundation, Inc. + +;; Author: Nicolas Petton <nicolas@petton.fr> +;; Maintainer: emacs-devel@gnu.org + +;; 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: + +;; Tests for sequences.el + +;;; Code: + +(require 'ert) +(require 'seq) + +(defmacro with-test-sequences (spec &rest body) + "Successively bind VAR to a list, vector, and string built from SEQ. +Evaluate BODY for each created sequence. + +\(fn (var seq) body)" + (declare (indent 1) (debug ((symbolp form) body))) + (let ((initial-seq (make-symbol "initial-seq"))) + `(let ((,initial-seq ,(cadr spec))) + ,@(mapcar (lambda (s) + `(let ((,(car spec) (apply (function ,s) ,initial-seq))) + ,@body)) + '(list vector string))))) + +(defun same-contents-p (seq1 seq2) + "Return t if SEQ1 and SEQ2 have the same contents, nil otherwise." + (equal (append seq1 '()) (append seq2 '()))) + +(defun test-sequences-evenp (integer) + "Return t if INTEGER is even." + (eq (logand integer 1) 0)) + +(defun test-sequences-oddp (integer) + "Return t if INTEGER is odd." + (not (test-sequences-evenp integer))) + +(ert-deftest test-setf-seq-elt () + (with-test-sequences (seq '(1 2 3)) + (setf (seq-elt seq 1) 4) + (should (= 4 (seq-elt seq 1))))) + +(ert-deftest test-seq-drop () + (with-test-sequences (seq '(1 2 3 4)) + (should (equal (seq-drop seq 0) seq)) + (should (equal (seq-drop seq 1) (seq-subseq seq 1))) + (should (equal (seq-drop seq 2) (seq-subseq seq 2))) + (should (seq-empty-p (seq-drop seq 4))) + (should (seq-empty-p (seq-drop seq 10)))) + (with-test-sequences (seq '()) + (should (seq-empty-p (seq-drop seq 0))) + (should (seq-empty-p (seq-drop seq 1))))) + +(ert-deftest test-seq-take () + (with-test-sequences (seq '(2 3 4 5)) + (should (seq-empty-p (seq-take seq 0))) + (should (= (seq-length (seq-take seq 1)) 1)) + (should (= (seq-elt (seq-take seq 1) 0) 2)) + (should (same-contents-p (seq-take seq 3) '(2 3 4))) + (should (equal (seq-take seq 10) seq)))) + +(ert-deftest test-seq-drop-while () + (with-test-sequences (seq '(1 3 2 4)) + (should (equal (seq-drop-while #'test-sequences-oddp seq) + (seq-drop seq 2))) + (should (equal (seq-drop-while #'test-sequences-evenp seq) + seq)) + (should (seq-empty-p (seq-drop-while #'numberp seq)))) + (with-test-sequences (seq '()) + (should (seq-empty-p (seq-drop-while #'test-sequences-oddp seq))))) + +(ert-deftest test-seq-take-while () + (with-test-sequences (seq '(1 3 2 4)) + (should (equal (seq-take-while #'test-sequences-oddp seq) + (seq-take seq 2))) + (should (seq-empty-p (seq-take-while #'test-sequences-evenp seq))) + (should (equal (seq-take-while #'numberp seq) seq))) + (with-test-sequences (seq '()) + (should (seq-empty-p (seq-take-while #'test-sequences-oddp seq))))) + +(ert-deftest test-seq-filter () + (with-test-sequences (seq '(6 7 8 9 10)) + (should (equal (seq-filter #'test-sequences-evenp seq) '(6 8 10))) + (should (equal (seq-filter #'test-sequences-oddp seq) '(7 9))) + (should (equal (seq-filter (lambda (elt) nil) seq) '()))) + (with-test-sequences (seq '()) + (should (equal (seq-filter #'test-sequences-evenp seq) '())))) + +(ert-deftest test-seq-remove () + (with-test-sequences (seq '(6 7 8 9 10)) + (should (equal (seq-remove #'test-sequences-evenp seq) '(7 9))) + (should (equal (seq-remove #'test-sequences-oddp seq) '(6 8 10))) + (should (same-contents-p (seq-remove (lambda (elt) nil) seq) seq))) + (with-test-sequences (seq '()) + (should (equal (seq-remove #'test-sequences-evenp seq) '())))) + +(ert-deftest test-seq-count () + (with-test-sequences (seq '(6 7 8 9 10)) + (should (equal (seq-count #'test-sequences-evenp seq) 3)) + (should (equal (seq-count #'test-sequences-oddp seq) 2)) + (should (equal (seq-count (lambda (elt) nil) seq) 0))) + (with-test-sequences (seq '()) + (should (equal (seq-count #'test-sequences-evenp seq) 0)))) + +(ert-deftest test-seq-reduce () + (with-test-sequences (seq '(1 2 3 4)) + (should (= (seq-reduce #'+ seq 0) 10)) + (should (= (seq-reduce #'+ seq 5) 15))) + (with-test-sequences (seq '()) + (should (eq (seq-reduce #'+ seq 0) 0)) + (should (eq (seq-reduce #'+ seq 7) 7)))) + +(ert-deftest test-seq-some () + (with-test-sequences (seq '(4 3 2 1)) + (should (seq-some #'test-sequences-evenp seq)) + (should (seq-some #'test-sequences-oddp seq)) + (should-not (seq-some (lambda (elt) (> elt 10)) seq))) + (with-test-sequences (seq '()) + (should-not (seq-some #'test-sequences-oddp seq))) + (should (seq-some #'null '(1 nil 2)))) + +(ert-deftest test-seq-find () + (with-test-sequences (seq '(4 3 2 1)) + (should (= 4 (seq-find #'test-sequences-evenp seq))) + (should (= 3 (seq-find #'test-sequences-oddp seq))) + (should-not (seq-find (lambda (elt) (> elt 10)) seq))) + (should-not (seq-find #'null '(1 nil 2))) + (should-not (seq-find #'null '(1 nil 2) t)) + (should-not (seq-find #'null '(1 2 3))) + (should (seq-find #'null '(1 2 3) 'sentinel))) + +(ert-deftest test-seq-contains () + (with-test-sequences (seq '(3 4 5 6)) + (should (seq-contains seq 3)) + (should-not (seq-contains seq 7))) + (with-test-sequences (seq '()) + (should-not (seq-contains seq 3)) + (should-not (seq-contains seq nil)))) + +(ert-deftest test-seq-every-p () + (with-test-sequences (seq '(43 54 22 1)) + (should (seq-every-p (lambda (elt) t) seq)) + (should-not (seq-every-p #'test-sequences-oddp seq)) + (should-not (seq-every-p #'test-sequences-evenp seq))) + (with-test-sequences (seq '(42 54 22 2)) + (should (seq-every-p #'test-sequences-evenp seq)) + (should-not (seq-every-p #'test-sequences-oddp seq))) + (with-test-sequences (seq '()) + (should (seq-every-p #'identity seq)) + (should (seq-every-p #'test-sequences-evenp seq)))) + +(ert-deftest test-seq-empty-p () + (with-test-sequences (seq '(0)) + (should-not (seq-empty-p seq))) + (with-test-sequences (seq '(0 1 2)) + (should-not (seq-empty-p seq))) + (with-test-sequences (seq '()) + (should (seq-empty-p seq)))) + +(ert-deftest test-seq-sort () + (should (equal (seq-sort #'< "cbaf") "abcf")) + (should (equal (seq-sort #'< '(2 1 9 4)) '(1 2 4 9))) + (should (equal (seq-sort #'< [2 1 9 4]) [1 2 4 9])) + (should (equal (seq-sort #'< "") ""))) + +(ert-deftest test-seq-uniq () + (with-test-sequences (seq '(2 4 6 8 6 4 3)) + (should (equal (seq-uniq seq) '(2 4 6 8 3)))) + (with-test-sequences (seq '(3 3 3 3 3)) + (should (equal (seq-uniq seq) '(3)))) + (with-test-sequences (seq '()) + (should (equal (seq-uniq seq) '())))) + +(ert-deftest test-seq-subseq () + (with-test-sequences (seq '(2 3 4 5)) + (should (equal (seq-subseq seq 0 4) seq)) + (should (same-contents-p (seq-subseq seq 2 4) '(4 5))) + (should (same-contents-p (seq-subseq seq 1 3) '(3 4))) + (should (same-contents-p (seq-subseq seq 1 -1) '(3 4)))) + (should (vectorp (seq-subseq [2 3 4 5] 2))) + (should (stringp (seq-subseq "foo" 2 3))) + (should (listp (seq-subseq '(2 3 4 4) 2 3))) + (should-error (seq-subseq '(1 2 3) 4)) + (should-not (seq-subseq '(1 2 3) 3)) + (should (seq-subseq '(1 2 3) -3)) + (should-error (seq-subseq '(1 2 3) 1 4)) + (should (seq-subseq '(1 2 3) 1 3)) + (should-error (seq-subseq '() -1)) + (should-error (seq-subseq [] -1)) + (should-error (seq-subseq "" -1)) + (should-not (seq-subseq '() 0)) + (should-error (seq-subseq '() 0 -1))) + +(ert-deftest test-seq-concatenate () + (with-test-sequences (seq '(2 4 6)) + (should (equal (seq-concatenate 'string seq [8]) (string 2 4 6 8))) + (should (equal (seq-concatenate 'list seq '(8 10)) '(2 4 6 8 10))) + (should (equal (seq-concatenate 'vector seq '(8 10)) [2 4 6 8 10])) + (should (equal (seq-concatenate 'vector nil '(8 10)) [8 10])) + (should (equal (seq-concatenate 'vector seq nil) [2 4 6])))) + +(ert-deftest test-seq-mapcat () + (should (equal (seq-mapcat #'seq-reverse '((3 2 1) (6 5 4))) + '(1 2 3 4 5 6))) + (should (equal (seq-mapcat #'seq-reverse '[(3 2 1) (6 5 4)]) + '(1 2 3 4 5 6))) + (should (equal (seq-mapcat #'seq-reverse '((3 2 1) (6 5 4)) 'vector) + '[1 2 3 4 5 6]))) + +(ert-deftest test-seq-partition () + (should (same-contents-p (seq-partition '(0 1 2 3 4 5 6 7) 3) + '((0 1 2) (3 4 5) (6 7)))) + (should (same-contents-p (seq-partition '[0 1 2 3 4 5 6 7] 3) + '([0 1 2] [3 4 5] [6 7]))) + (should (same-contents-p (seq-partition "Hello world" 2) + '("He" "ll" "o " "wo" "rl" "d"))) + (should (equal (seq-partition '() 2) '())) + (should (equal (seq-partition '(1 2 3) -1) '()))) + +(ert-deftest test-seq-group-by () + (with-test-sequences (seq '(1 2 3 4)) + (should (equal (seq-group-by #'test-sequences-oddp seq) + '((t 1 3) (nil 2 4))))) + (should (equal (seq-group-by #'car '((a 1) (b 3) (c 4) (a 2))) + '((b (b 3)) (c (c 4)) (a (a 1) (a 2)))))) + +(ert-deftest test-seq-reverse () + (with-test-sequences (seq '(1 2 3 4)) + (should (same-contents-p (seq-reverse seq) '(4 3 2 1))) + (should (equal (type-of (seq-reverse seq)) + (type-of seq))))) + +(ert-deftest test-seq-into () + (let* ((vector [1 2 3]) + (list (seq-into vector 'list))) + (should (same-contents-p vector list)) + (should (listp list))) + (let* ((list '(hello world)) + (vector (seq-into list 'vector))) + (should (same-contents-p vector list)) + (should (vectorp vector))) + (let* ((string "hello") + (list (seq-into string 'list))) + (should (same-contents-p string list)) + (should (stringp string))) + (let* ((string "hello") + (vector (seq-into string 'vector))) + (should (same-contents-p string vector)) + (should (stringp string))) + (let* ((list nil) + (vector (seq-into list 'vector))) + (should (same-contents-p list vector)) + (should (vectorp vector)))) + +(ert-deftest test-seq-intersection () + (let ((v1 [2 3 4 5]) + (v2 [1 3 5 6 7])) + (should (same-contents-p (seq-intersection v1 v2) + '(3 5)))) + (let ((l1 '(2 3 4 5)) + (l2 '(1 3 5 6 7))) + (should (same-contents-p (seq-intersection l1 l2) + '(3 5)))) + (let ((v1 [2 4 6]) + (v2 [1 3 5])) + (should (seq-empty-p (seq-intersection v1 v2))))) + +(ert-deftest test-seq-difference () + (let ((v1 [2 3 4 5]) + (v2 [1 3 5 6 7])) + (should (same-contents-p (seq-difference v1 v2) + '(2 4)))) + (let ((l1 '(2 3 4 5)) + (l2 '(1 3 5 6 7))) + (should (same-contents-p (seq-difference l1 l2) + '(2 4)))) + (let ((v1 [2 4 6]) + (v2 [2 4 6])) + (should (seq-empty-p (seq-difference v1 v2))))) + +(ert-deftest test-seq-let () + (with-test-sequences (seq '(1 2 3 4)) + (seq-let (a b c d e) seq + (should (= a 1)) + (should (= b 2)) + (should (= c 3)) + (should (= d 4)) + (should (null e))) + (seq-let (a b &rest others) seq + (should (= a 1)) + (should (= b 2)) + (should (same-contents-p others (seq-drop seq 2))))) + (let ((seq '(1 (2 (3 (4)))))) + (seq-let (_ (_ (_ (a)))) seq + (should (= a 4)))) + (let (seq) + (seq-let (a b c) seq + (should (null a)) + (should (null b)) + (should (null c))))) + +(ert-deftest test-seq-min-max () + (with-test-sequences (seq '(4 5 3 2 0 4)) + (should (= (seq-min seq) 0)) + (should (= (seq-max seq) 5)))) + +(ert-deftest test-seq-into-sequence () + (with-test-sequences (seq '(1 2 3)) + (should (eq seq (seq-into-sequence seq))) + (should-error (seq-into-sequence 2)))) + +(ert-deftest test-seq-position () + (with-test-sequences (seq '(2 4 6)) + (should (null (seq-position seq 1))) + (should (= (seq-position seq 4) 1))) + (let ((seq '(a b c))) + (should (null (seq-position seq 'd #'eq))) + (should (= (seq-position seq 'a #'eq) 0)) + (should (null (seq-position seq (make-symbol "a") #'eq))))) + +(provide 'seq-tests) +;;; seq-tests.el ends here diff --git a/test/lisp/emacs-lisp/subr-x-tests.el b/test/lisp/emacs-lisp/subr-x-tests.el new file mode 100644 index 00000000000..e30b5d8f549 --- /dev/null +++ b/test/lisp/emacs-lisp/subr-x-tests.el @@ -0,0 +1,526 @@ +;;; subr-x-tests.el --- Testing the extended lisp routines + +;; Copyright (C) 2014-2016 Free Software Foundation, Inc. + +;; Author: Fabián E. Gallina <fgallina@gnu.org> +;; Keywords: + +;; 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/>. + +;;; Commentary: + +;; + +;;; Code: + +(require 'ert) +(require 'subr-x) + + +;; if-let tests + +(ert-deftest subr-x-test-if-let-single-binding-expansion () + "Test single bindings are expanded properly." + (should (equal + (macroexpand + '(if-let (a 1) + (- a) + "no")) + '(let* ((a (and t 1))) + (if a + (- a) + "no")))) + (should (equal + (macroexpand + '(if-let (a) + (- a) + "no")) + '(let* ((a (and t nil))) + (if a + (- a) + "no"))))) + +(ert-deftest subr-x-test-if-let-single-symbol-expansion () + "Test single symbol bindings are expanded properly." + (should (equal + (macroexpand + '(if-let (a) + (- a) + "no")) + '(let* ((a (and t nil))) + (if a + (- a) + "no")))) + (should (equal + (macroexpand + '(if-let (a b c) + (- a) + "no")) + '(let* ((a (and t nil)) + (b (and a nil)) + (c (and b nil))) + (if c + (- a) + "no")))) + (should (equal + (macroexpand + '(if-let (a (b 2) c) + (- a) + "no")) + '(let* ((a (and t nil)) + (b (and a 2)) + (c (and b nil))) + (if c + (- a) + "no"))))) + +(ert-deftest subr-x-test-if-let-nil-related-expansion () + "Test nil is processed properly." + (should (equal + (macroexpand + '(if-let (nil) + (- a) + "no")) + '(let* ((nil (and t nil))) + (if nil + (- a) + "no")))) + (should (equal + (macroexpand + '(if-let ((nil)) + (- a) + "no")) + '(let* ((nil (and t nil))) + (if nil + (- a) + "no")))) + (should (equal + (macroexpand + '(if-let ((a 1) (nil) (b 2)) + (- a) + "no")) + '(let* ((a (and t 1)) + (nil (and a nil)) + (b (and nil 2))) + (if b + (- a) + "no")))) + (should (equal + (macroexpand + '(if-let ((a 1) nil (b 2)) + (- a) + "no")) + '(let* ((a (and t 1)) + (nil (and a nil)) + (b (and nil 2))) + (if b + (- a) + "no"))))) + +(ert-deftest subr-x-test-if-let-malformed-binding () + "Test malformed bindings trigger errors." + (should-error (macroexpand + '(if-let (_ (a 1 1) (b 2) (c 3) d) + (- a) + "no")) + :type 'error) + (should-error (macroexpand + '(if-let (_ (a 1) (b 2 2) (c 3) d) + (- a) + "no")) + :type 'error) + (should-error (macroexpand + '(if-let (_ (a 1) (b 2) (c 3 3) d) + (- a) + "no")) + :type 'error) + (should-error (macroexpand + '(if-let ((a 1 1)) + (- a) + "no")) + :type 'error)) + +(ert-deftest subr-x-test-if-let-true () + "Test `if-let' with truthy bindings." + (should (equal + (if-let (a 1) + a + "no") + 1)) + (should (equal + (if-let ((a 1) (b 2) (c 3)) + (list a b c) + "no") + (list 1 2 3)))) + +(ert-deftest subr-x-test-if-let-false () + "Test `if-let' with falsie bindings." + (should (equal + (if-let (a nil) + (list a b c) + "no") + "no")) + (should (equal + (if-let ((a nil) (b 2) (c 3)) + (list a b c) + "no") + "no")) + (should (equal + (if-let ((a 1) (b nil) (c 3)) + (list a b c) + "no") + "no")) + (should (equal + (if-let ((a 1) (b 2) (c nil)) + (list a b c) + "no") + "no")) + (should (equal + (if-let (z (a 1) (b 2) (c 3)) + (list a b c) + "no") + "no")) + (should (equal + (if-let ((a 1) (b 2) (c 3) d) + (list a b c) + "no") + "no"))) + +(ert-deftest subr-x-test-if-let-bound-references () + "Test `if-let' bindings can refer to already bound symbols." + (should (equal + (if-let ((a (1+ 0)) (b (1+ a)) (c (1+ b))) + (list a b c) + "no") + (list 1 2 3)))) + +(ert-deftest subr-x-test-if-let-and-laziness-is-preserved () + "Test `if-let' respects `and' laziness." + (let (a-called b-called c-called) + (should (equal + (if-let ((a nil) + (b (setq b-called t)) + (c (setq c-called t))) + "yes" + (list a-called b-called c-called)) + (list nil nil nil)))) + (let (a-called b-called c-called) + (should (equal + (if-let ((a (setq a-called t)) + (b nil) + (c (setq c-called t))) + "yes" + (list a-called b-called c-called)) + (list t nil nil)))) + (let (a-called b-called c-called) + (should (equal + (if-let ((a (setq a-called t)) + (b (setq b-called t)) + (c nil) + (d (setq c-called t))) + "yes" + (list a-called b-called c-called)) + (list t t nil))))) + + +;; when-let tests + +(ert-deftest subr-x-test-when-let-body-expansion () + "Test body allows for multiple sexps wrapping with progn." + (should (equal + (macroexpand + '(when-let (a 1) + (message "opposite") + (- a))) + '(let* ((a (and t 1))) + (if a + (progn + (message "opposite") + (- a))))))) + +(ert-deftest subr-x-test-when-let-single-binding-expansion () + "Test single bindings are expanded properly." + (should (equal + (macroexpand + '(when-let (a 1) + (- a))) + '(let* ((a (and t 1))) + (if a + (- a))))) + (should (equal + (macroexpand + '(when-let (a) + (- a))) + '(let* ((a (and t nil))) + (if a + (- a)))))) + +(ert-deftest subr-x-test-when-let-single-symbol-expansion () + "Test single symbol bindings are expanded properly." + (should (equal + (macroexpand + '(when-let (a) + (- a))) + '(let* ((a (and t nil))) + (if a + (- a))))) + (should (equal + (macroexpand + '(when-let (a b c) + (- a))) + '(let* ((a (and t nil)) + (b (and a nil)) + (c (and b nil))) + (if c + (- a))))) + (should (equal + (macroexpand + '(when-let (a (b 2) c) + (- a))) + '(let* ((a (and t nil)) + (b (and a 2)) + (c (and b nil))) + (if c + (- a)))))) + +(ert-deftest subr-x-test-when-let-nil-related-expansion () + "Test nil is processed properly." + (should (equal + (macroexpand + '(when-let (nil) + (- a))) + '(let* ((nil (and t nil))) + (if nil + (- a))))) + (should (equal + (macroexpand + '(when-let ((nil)) + (- a))) + '(let* ((nil (and t nil))) + (if nil + (- a))))) + (should (equal + (macroexpand + '(when-let ((a 1) (nil) (b 2)) + (- a))) + '(let* ((a (and t 1)) + (nil (and a nil)) + (b (and nil 2))) + (if b + (- a))))) + (should (equal + (macroexpand + '(when-let ((a 1) nil (b 2)) + (- a))) + '(let* ((a (and t 1)) + (nil (and a nil)) + (b (and nil 2))) + (if b + (- a)))))) + +(ert-deftest subr-x-test-when-let-malformed-binding () + "Test malformed bindings trigger errors." + (should-error (macroexpand + '(when-let (_ (a 1 1) (b 2) (c 3) d) + (- a))) + :type 'error) + (should-error (macroexpand + '(when-let (_ (a 1) (b 2 2) (c 3) d) + (- a))) + :type 'error) + (should-error (macroexpand + '(when-let (_ (a 1) (b 2) (c 3 3) d) + (- a))) + :type 'error) + (should-error (macroexpand + '(when-let ((a 1 1)) + (- a))) + :type 'error)) + +(ert-deftest subr-x-test-when-let-true () + "Test `when-let' with truthy bindings." + (should (equal + (when-let (a 1) + a) + 1)) + (should (equal + (when-let ((a 1) (b 2) (c 3)) + (list a b c)) + (list 1 2 3)))) + +(ert-deftest subr-x-test-when-let-false () + "Test `when-let' with falsie bindings." + (should (equal + (when-let (a nil) + (list a b c) + "no") + nil)) + (should (equal + (when-let ((a nil) (b 2) (c 3)) + (list a b c) + "no") + nil)) + (should (equal + (when-let ((a 1) (b nil) (c 3)) + (list a b c) + "no") + nil)) + (should (equal + (when-let ((a 1) (b 2) (c nil)) + (list a b c) + "no") + nil)) + (should (equal + (when-let (z (a 1) (b 2) (c 3)) + (list a b c) + "no") + nil)) + (should (equal + (when-let ((a 1) (b 2) (c 3) d) + (list a b c) + "no") + nil))) + +(ert-deftest subr-x-test-when-let-bound-references () + "Test `when-let' bindings can refer to already bound symbols." + (should (equal + (when-let ((a (1+ 0)) (b (1+ a)) (c (1+ b))) + (list a b c)) + (list 1 2 3)))) + +(ert-deftest subr-x-test-when-let-and-laziness-is-preserved () + "Test `when-let' respects `and' laziness." + (let (a-called b-called c-called) + (should (equal + (progn + (when-let ((a nil) + (b (setq b-called t)) + (c (setq c-called t))) + "yes") + (list a-called b-called c-called)) + (list nil nil nil)))) + (let (a-called b-called c-called) + (should (equal + (progn + (when-let ((a (setq a-called t)) + (b nil) + (c (setq c-called t))) + "yes") + (list a-called b-called c-called)) + (list t nil nil)))) + (let (a-called b-called c-called) + (should (equal + (progn + (when-let ((a (setq a-called t)) + (b (setq b-called t)) + (c nil) + (d (setq c-called t))) + "yes") + (list a-called b-called c-called)) + (list t t nil))))) + + +;; Thread first tests + +(ert-deftest subr-x-test-thread-first-no-forms () + "Test `thread-first' with no forms expands to the first form." + (should (equal (macroexpand '(thread-first 5)) 5)) + (should (equal (macroexpand '(thread-first (+ 1 2))) '(+ 1 2)))) + +(ert-deftest subr-x-test-thread-first-function-names-are-threaded () + "Test `thread-first' wraps single function names." + (should (equal (macroexpand + '(thread-first 5 + -)) + '(- 5))) + (should (equal (macroexpand + '(thread-first (+ 1 2) + -)) + '(- (+ 1 2))))) + +(ert-deftest subr-x-test-thread-first-expansion () + "Test `thread-first' expands correctly." + (should (equal + (macroexpand '(thread-first + 5 + (+ 20) + (/ 25) + - + (+ 40))) + '(+ (- (/ (+ 5 20) 25)) 40)))) + +(ert-deftest subr-x-test-thread-first-examples () + "Test several `thread-first' examples." + (should (equal (thread-first (+ 40 2)) 42)) + (should (equal (thread-first + 5 + (+ 20) + (/ 25) + - + (+ 40)) 39)) + (should (equal (thread-first + "this-is-a-string" + (split-string "-") + (nbutlast 2) + (append (list "good"))) + (list "this" "is" "good")))) + +;; Thread last tests + +(ert-deftest subr-x-test-thread-last-no-forms () + "Test `thread-last' with no forms expands to the first form." + (should (equal (macroexpand '(thread-last 5)) 5)) + (should (equal (macroexpand '(thread-last (+ 1 2))) '(+ 1 2)))) + +(ert-deftest subr-x-test-thread-last-function-names-are-threaded () + "Test `thread-last' wraps single function names." + (should (equal (macroexpand + '(thread-last 5 + -)) + '(- 5))) + (should (equal (macroexpand + '(thread-last (+ 1 2) + -)) + '(- (+ 1 2))))) + +(ert-deftest subr-x-test-thread-last-expansion () + "Test `thread-last' expands correctly." + (should (equal + (macroexpand '(thread-last + 5 + (+ 20) + (/ 25) + - + (+ 40))) + '(+ 40 (- (/ 25 (+ 20 5))))))) + +(ert-deftest subr-x-test-thread-last-examples () + "Test several `thread-last' examples." + (should (equal (thread-last (+ 40 2)) 42)) + (should (equal (thread-last + 5 + (+ 20) + (/ 25) + - + (+ 40)) 39)) + (should (equal (thread-last + (list 1 -2 3 -4 5) + (mapcar #'abs) + (cl-reduce #'+) + (format "abs sum is: %s")) + "abs sum is: 15"))) + + +(provide 'subr-x-tests) +;;; subr-x-tests.el ends here diff --git a/test/lisp/emacs-lisp/tabulated-list-test.el b/test/lisp/emacs-lisp/tabulated-list-test.el new file mode 100644 index 00000000000..0fb8dee7fd1 --- /dev/null +++ b/test/lisp/emacs-lisp/tabulated-list-test.el @@ -0,0 +1,118 @@ +;;; tabulated-list-test.el --- Tests for emacs-lisp/tabulated-list.el -*- lexical-binding: t; -*- + +;; Copyright (C) 2015-2016 Free Software Foundation, Inc. + +;; Author: Artur Malabarba <bruce.connor.am@gmail.com> + +;; 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/>. + +;;; Code: + +(require 'tabulated-list) +(require 'ert) + +(defconst tabulated-list--test-entries + '(("zzzz-game" ["zzzz-game" "zzzz-game" "2113" "installed" " play zzzz in Emacs"]) + ("4clojure" ["4clojure" "4clojure" "1507" "obsolete" " Open and evaluate 4clojure.com questions"]) + ("abc-mode" ["abc-mode" "abc-mode" "944" "available" " Major mode for editing abc music files"]) + ("mode" ["mode" "mode" "1128" "installed" " A simple mode for editing Actionscript 3 files"]))) + +(defun tabulated-list--test-sort-car (a b) + (string< (car a) (car b))) + +(defconst tabulated-list--test-format + [("name" 10 tabulated-list--test-sort-car) + ("name-2" 10 t) + ("Version" 9 nil) + ("Status" 10 ) + ("Description" 0 nil)]) + +(defmacro tabulated-list--test-with-buffer (&rest body) + `(with-temp-buffer + (tabulated-list-mode) + (setq tabulated-list-entries (copy-alist tabulated-list--test-entries)) + (setq tabulated-list-format tabulated-list--test-format) + (setq tabulated-list-padding 7) + (tabulated-list-init-header) + (tabulated-list-print) + ,@body)) + + +;;; Tests +(ert-deftest tabulated-list-print () + (tabulated-list--test-with-buffer + ;; Basic printing. + (should (string= (buffer-substring-no-properties (point-min) (point-max)) + " zzzz-game zzzz-game 2113 installed play zzzz in Emacs + 4clojure 4clojure 1507 obsolete Open and evaluate 4clojure.com questions + abc-mode abc-mode 944 available Major mode for editing abc music files + mode mode 1128 installed A simple mode for editing Actionscript 3 files\n")) + ;; Preserve position. + (forward-line 3) + (let ((pos (thing-at-point 'line))) + (pop tabulated-list-entries) + (tabulated-list-print t) + (should (equal (thing-at-point 'line) pos)) + (should (string= (buffer-substring-no-properties (point-min) (point-max)) + " 4clojure 4clojure 1507 obsolete Open and evaluate 4clojure.com questions + abc-mode abc-mode 944 available Major mode for editing abc music files + mode mode 1128 installed A simple mode for editing Actionscript 3 files\n")) + ;; Check the UPDATE argument + (pop tabulated-list-entries) + (setf (cdr (car tabulated-list-entries)) (list ["x" "x" "944" "available" " XX"])) + (tabulated-list-print t t) + (should (string= (buffer-substring-no-properties (point-min) (point-max)) + " x x 944 available XX + mode mode 1128 installed A simple mode for editing Actionscript 3 files\n")) + (should (equal (thing-at-point 'line) pos))))) + +(ert-deftest tabulated-list-sort () + (tabulated-list--test-with-buffer + ;; Basic sorting + (goto-char (point-min)) + (skip-chars-forward "[:blank:]") + (tabulated-list-sort) + (let ((text (buffer-substring-no-properties (point-min) (point-max)))) + (should (string= text " 4clojure 4clojure 1507 obsolete Open and evaluate 4clojure.com questions + abc-mode abc-mode 944 available Major mode for editing abc music files + mode mode 1128 installed A simple mode for editing Actionscript 3 files + zzzz-game zzzz-game 2113 installed play zzzz in Emacs\n")) + + (skip-chars-forward "^[:blank:]") + (skip-chars-forward "[:blank:]") + (should (equal (get-text-property (point) 'tabulated-list-column-name) + "name-2")) + (tabulated-list-sort) + ;; Check a `t' as the sorting predicate. + (should (string= text (buffer-substring-no-properties (point-min) (point-max)))) + ;; Invert. + (tabulated-list-sort 1) + (should (string= (buffer-substring-no-properties (point-min) (point-max)) + " zzzz-game zzzz-game 2113 installed play zzzz in Emacs + mode mode 1128 installed A simple mode for editing Actionscript 3 files + abc-mode abc-mode 944 available Major mode for editing abc music files + 4clojure 4clojure 1507 obsolete Open and evaluate 4clojure.com questions\n")) + ;; Again + (tabulated-list-sort 1) + (should (string= text (buffer-substring-no-properties (point-min) (point-max))))) + ;; Check that you can't sort some cols. + (skip-chars-forward "^[:blank:]") + (skip-chars-forward "[:blank:]") + (should-error (tabulated-list-sort) :type 'user-error) + (should-error (tabulated-list-sort 4) :type 'user-error))) + +(provide 'tabulated-list-test) +;;; tabulated-list-test.el ends here diff --git a/test/lisp/emacs-lisp/thunk-tests.el b/test/lisp/emacs-lisp/thunk-tests.el new file mode 100644 index 00000000000..f995d362c7d --- /dev/null +++ b/test/lisp/emacs-lisp/thunk-tests.el @@ -0,0 +1,55 @@ +;;; thunk-tests.el --- Tests for thunk.el -*- lexical-binding: t -*- + +;; Copyright (C) 2015-2016 Free Software Foundation, Inc. + +;; Author: Nicolas Petton <nicolas@petton.fr> +;; Maintainer: emacs-devel@gnu.org + +;; 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: + +;; Tests for thunk.el + +;;; Code: + +(require 'ert) +(require 'thunk) + +(ert-deftest thunk-should-be-lazy () + (let (x) + (thunk-delay (setq x t)) + (should (null x)))) + +(ert-deftest thunk-can-be-evaluated () + (let* (x + (thunk (thunk-delay (setq x t)))) + (should-not (thunk-evaluated-p thunk)) + (should (null x)) + (thunk-force thunk) + (should (thunk-evaluated-p thunk)) + (should x))) + +(ert-deftest thunk-evaluation-is-cached () + (let* ((x 0) + (thunk (thunk-delay (setq x (1+ x))))) + (thunk-force thunk) + (should (= x 1)) + (thunk-force thunk) + (should (= x 1)))) + +(provide 'thunk-tests) +;;; thunk-tests.el ends here diff --git a/test/lisp/emacs-lisp/timer-tests.el b/test/lisp/emacs-lisp/timer-tests.el new file mode 100644 index 00000000000..e3cdec73232 --- /dev/null +++ b/test/lisp/emacs-lisp/timer-tests.el @@ -0,0 +1,42 @@ +;;; timer-tests.el --- tests for timers -*- lexical-binding:t -*- + +;; Copyright (C) 2013-2016 Free Software Foundation, Inc. + +;; 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: + +;;; Code: + +(ert-deftest timer-tests-sit-for () + (let ((timer-ran nil) + ;; Want sit-for behavior when interactive + (noninteractive nil)) + (run-at-time '(0 0 0 0) + nil + (lambda () (setq timer-ran t))) + ;; The test assumes run-at-time didn't take the liberty of firing + ;; the timer, so assert the test's assumption + (should (not timer-ran)) + (sit-for 0 t) + (should timer-ran))) + +(ert-deftest timer-tests-debug-timer-check () + ;; This function exists only if --enable-checking. + (if (fboundp 'debug-timer-check) + (should (debug-timer-check)) t)) + +;;; timer-tests.el ends here diff --git a/test/lisp/epg-tests.el b/test/lisp/epg-tests.el new file mode 100644 index 00000000000..4a317974ef5 --- /dev/null +++ b/test/lisp/epg-tests.el @@ -0,0 +1,172 @@ +;;; epg-tests.el --- Test suite for epg.el -*- lexical-binding: t -*- + +;; Copyright (C) 2013-2016 Free Software Foundation, Inc. + +;; 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: + +;;; Code: + +(require 'ert) +(require 'epg) + +(defvar epg-tests-context nil) + +(defvar epg-tests-data-directory + (expand-file-name "data/epg" (getenv "EMACS_TEST_DIRECTORY")) + "Directory containing epg test data.") + +(defun epg-tests-gpg-usable (&optional require-passphrase) + (and (executable-find epg-gpg-program) + (condition-case nil + (progn + (epg-check-configuration (epg-configuration)) + (if require-passphrase + (string-match "\\`1\\." + (cdr (assq 'version (epg-configuration)))) + t)) + (error nil)))) + +(defun epg-tests-passphrase-callback (_c _k _d) + ;; Need to create a copy here, since the string will be wiped out + ;; after the use. + (copy-sequence "test0123456789")) + +(cl-defmacro with-epg-tests ((&optional &key require-passphrase + require-public-key + require-secret-key) + &rest body) + "Set up temporary locations and variables for testing." + (declare (indent 1)) + `(let* ((epg-tests-home-directory (make-temp-file "epg-tests-homedir" t))) + (unwind-protect + (let ((context (epg-make-context 'OpenPGP))) + (setf (epg-context-home-directory context) + epg-tests-home-directory) + (setenv "GPG_AGENT_INFO") + ,(if require-passphrase + `(epg-context-set-passphrase-callback + context + #'epg-tests-passphrase-callback)) + ,(if require-public-key + `(epg-import-keys-from-file + context + (expand-file-name "pubkey.asc" epg-tests-data-directory))) + ,(if require-secret-key + `(epg-import-keys-from-file + context + (expand-file-name "seckey.asc" epg-tests-data-directory))) + (with-temp-buffer + (make-local-variable 'epg-tests-context) + (setq epg-tests-context context) + ,@body)) + (when (file-directory-p epg-tests-home-directory) + (delete-directory epg-tests-home-directory t))))) + +(ert-deftest epg-decrypt-1 () + (skip-unless (epg-tests-gpg-usable 'require-passphrase)) + (with-epg-tests (:require-passphrase t) + (should (equal "test" + (epg-decrypt-string epg-tests-context "\ +-----BEGIN PGP MESSAGE----- +Version: GnuPG v2 + +jA0EAwMCE19JBLTvvmhgyRrGGglRbnKkK9PJG8fDwO5ccjysrR7IcdNcnA== +=U8z7 +-----END PGP MESSAGE-----"))))) + +(ert-deftest epg-roundtrip-1 () + (skip-unless (epg-tests-gpg-usable 'require-passphrase)) + (with-epg-tests (:require-passphrase t) + (let ((cipher (epg-encrypt-string epg-tests-context "symmetric" nil))) + (should (equal "symmetric" + (epg-decrypt-string epg-tests-context cipher)))))) + +(ert-deftest epg-roundtrip-2 () + (skip-unless (epg-tests-gpg-usable 'require-passphrase)) + (with-epg-tests (:require-passphrase t + :require-public-key t + :require-secret-key t) + (let* ((recipients (epg-list-keys epg-tests-context "joe@example.com")) + (cipher (epg-encrypt-string epg-tests-context "public key" + recipients nil t))) + (should (equal "public key" + (epg-decrypt-string epg-tests-context cipher)))))) + +(ert-deftest epg-sign-verify-1 () + (skip-unless (epg-tests-gpg-usable 'require-passphrase)) + (with-epg-tests (:require-passphrase t + :require-public-key t + :require-secret-key t) + (let (signature verify-result) + (setf (epg-context-signers epg-tests-context) + (epg-list-keys epg-tests-context "joe@example.com")) + (setq signature (epg-sign-string epg-tests-context "signed" t)) + (epg-verify-string epg-tests-context signature "signed") + (setq verify-result (epg-context-result-for context 'verify)) + (should (= 1 (length verify-result))) + (should (eq 'good (epg-signature-status (car verify-result))))))) + +(ert-deftest epg-sign-verify-2 () + (skip-unless (epg-tests-gpg-usable 'require-passphrase)) + (with-epg-tests (:require-passphrase t + :require-public-key t + :require-secret-key t) + (let (signature verify-result) + (setf (epg-context-signers epg-tests-context) + (epg-list-keys epg-tests-context "joe@example.com")) + (setq signature (epg-sign-string epg-tests-context "clearsigned" 'clear)) + ;; Clearsign signature always ends with a new line. + (should (equal "clearsigned\n" + (epg-verify-string epg-tests-context signature))) + (setq verify-result (epg-context-result-for context 'verify)) + (should (= 1 (length verify-result))) + (should (eq 'good (epg-signature-status (car verify-result))))))) + +(ert-deftest epg-sign-verify-3 () + (skip-unless (epg-tests-gpg-usable 'require-passphrase)) + (with-epg-tests (:require-passphrase t + :require-public-key t + :require-secret-key t) + (let (signature verify-result) + (setf (epg-context-signers epg-tests-context) + (epg-list-keys epg-tests-context "joe@example.com")) + (setq signature (epg-sign-string epg-tests-context "normal signed")) + (should (equal "normal signed" + (epg-verify-string epg-tests-context signature))) + (setq verify-result (epg-context-result-for context 'verify)) + (should (= 1 (length verify-result))) + (should (eq 'good (epg-signature-status (car verify-result))))))) + +(ert-deftest epg-import-1 () + (skip-unless (epg-tests-gpg-usable 'require-passphrase)) + (with-epg-tests (:require-passphrase nil) + (should (= 0 (length (epg-list-keys epg-tests-context)))) + (should (= 0 (length (epg-list-keys epg-tests-context nil t))))) + (with-epg-tests (:require-passphrase nil + :require-public-key t) + (should (= 1 (length (epg-list-keys epg-tests-context)))) + (should (= 0 (length (epg-list-keys epg-tests-context nil t))))) + (with-epg-tests (:require-public-key nil + :require-public-key t + :require-secret-key t) + (should (= 1 (length (epg-list-keys epg-tests-context)))) + (should (= 1 (length (epg-list-keys epg-tests-context nil t)))))) + +(provide 'epg-tests) + +;;; epg-tests.el ends here diff --git a/test/lisp/eshell/eshell.el b/test/lisp/eshell/eshell.el new file mode 100644 index 00000000000..d5676dd1daf --- /dev/null +++ b/test/lisp/eshell/eshell.el @@ -0,0 +1,252 @@ +;;; tests/eshell.el --- Eshell test suite + +;; Copyright (C) 1999-2016 Free Software Foundation, Inc. + +;; Author: John Wiegley <johnw@gnu.org> + +;; 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: + +;; Eshell test suite. + +;;; Code: + +(require 'ert) +(require 'eshell) + +(defmacro with-temp-eshell (&rest body) + "Evaluate BODY in a temporary Eshell buffer." + `(let* ((eshell-directory-name (make-temp-file "eshell" t)) + (eshell-history-file-name nil) + (eshell-buffer (eshell t))) + (unwind-protect + (with-current-buffer eshell-buffer + ,@body) + (let (kill-buffer-query-functions) + (kill-buffer eshell-buffer) + (delete-directory eshell-directory-name t))))) + +(defun eshell-insert-command (text &optional func) + "Insert a command at the end of the buffer." + (goto-char eshell-last-output-end) + (insert-and-inherit text) + (funcall (or func 'eshell-send-input))) + +(defun eshell-match-result (regexp) + "Check that text after `eshell-last-input-end' matches REGEXP." + (goto-char eshell-last-input-end) + (should (string-match-p regexp (buffer-substring-no-properties + (point) (point-max))))) + +(defun eshell-command-result-p (text regexp &optional func) + "Insert a command at the end of the buffer." + (eshell-insert-command text func) + (eshell-match-result regexp)) + +(defun eshell-test-command-result (command) + "Like `eshell-command-result', but not using HOME." + (let ((eshell-directory-name (make-temp-file "eshell" t)) + (eshell-history-file-name nil)) + (unwind-protect + (eshell-command-result command) + (delete-directory eshell-directory-name t)))) + +;;; Tests: + +(ert-deftest eshell-test/simple-command-result () + "Test `eshell-command-result' with a simple command." + (should (equal (eshell-test-command-result "+ 1 2") 3))) + +(ert-deftest eshell-test/lisp-command () + "Test `eshell-command-result' with an elisp command." + (should (equal (eshell-test-command-result "(+ 1 2)") 3))) + +(ert-deftest eshell-test/for-loop () + "Test `eshell-command-result' with a for loop.." + (let ((process-environment (cons "foo" process-environment))) + (should (equal (eshell-test-command-result + "for foo in 5 { echo $foo }") 5)))) + +(ert-deftest eshell-test/for-name-loop () ;Bug#15231 + "Test `eshell-command-result' with a for loop using `name'." + (let ((process-environment (cons "name" process-environment))) + (should (equal (eshell-test-command-result + "for name in 3 { echo $name }") 3)))) + +(ert-deftest eshell-test/for-name-shadow-loop () ; bug#15372 + "Test `eshell-command-result' with a for loop using an env-var." + (let ((process-environment (cons "name=env-value" process-environment))) + (with-temp-eshell + (eshell-command-result-p "echo $name; for name in 3 { echo $name }; echo $name" + "env-value\n3\nenv-value\n")))) + +(ert-deftest eshell-test/lisp-command-args () + "Test `eshell-command-result' with elisp and trailing args. +Test that trailing arguments outside the S-expression are +ignored. e.g. \"(+ 1 2) 3\" => 3" + (should (equal (eshell-test-command-result "(+ 1 2) 3") 3))) + +(ert-deftest eshell-test/subcommand () + "Test `eshell-command-result' with a simple subcommand." + (should (equal (eshell-test-command-result "{+ 1 2}") 3))) + +(ert-deftest eshell-test/subcommand-args () + "Test `eshell-command-result' with a subcommand and trailing args. +Test that trailing arguments outside the subcommand are ignored. +e.g. \"{+ 1 2} 3\" => 3" + (should (equal (eshell-test-command-result "{+ 1 2} 3") 3))) + +(ert-deftest eshell-test/subcommand-lisp () + "Test `eshell-command-result' with an elisp subcommand and trailing args. +Test that trailing arguments outside the subcommand are ignored. +e.g. \"{(+ 1 2)} 3\" => 3" + (should (equal (eshell-test-command-result "{(+ 1 2)} 3") 3))) + +(ert-deftest eshell-test/interp-cmd () + "Interpolate command result" + (should (equal (eshell-test-command-result "+ ${+ 1 2} 3") 6))) + +(ert-deftest eshell-test/interp-lisp () + "Interpolate Lisp form evaluation" + (should (equal (eshell-test-command-result "+ $(+ 1 2) 3") 6))) + +(ert-deftest eshell-test/interp-concat () + "Interpolate and concat command" + (should (equal (eshell-test-command-result "+ ${+ 1 2}3 3") 36))) + +(ert-deftest eshell-test/interp-concat-lisp () + "Interpolate and concat Lisp form" + (should (equal (eshell-test-command-result "+ $(+ 1 2)3 3") 36))) + +(ert-deftest eshell-test/interp-concat2 () + "Interpolate and concat two commands" + (should (equal (eshell-test-command-result "+ ${+ 1 2}${+ 1 2} 3") 36))) + +(ert-deftest eshell-test/interp-concat-lisp2 () + "Interpolate and concat two Lisp forms" + (should (equal (eshell-test-command-result "+ $(+ 1 2)$(+ 1 2) 3") 36))) + +(ert-deftest eshell-test/window-height () + "$LINES should equal (window-height)" + (should (eshell-test-command-result "= $LINES (window-height)"))) + +(ert-deftest eshell-test/window-width () + "$COLUMNS should equal (window-width)" + (should (eshell-test-command-result "= $COLUMNS (window-width)"))) + +(ert-deftest eshell-test/last-result-var () + "Test using the \"last result\" ($$) variable" + (with-temp-eshell + (eshell-command-result-p "+ 1 2; + $$ 2" + "3\n5\n"))) + +(ert-deftest eshell-test/last-result-var2 () + "Test using the \"last result\" ($$) variable twice" + (with-temp-eshell + (eshell-command-result-p "+ 1 2; + $$ $$" + "3\n6\n"))) + +(ert-deftest eshell-test/last-arg-var () + "Test using the \"last arg\" ($_) variable" + (with-temp-eshell + (eshell-command-result-p "+ 1 2; + $_ 4" + "3\n6\n"))) + +(ert-deftest eshell-test/escape-nonspecial () + "Test that \"\\c\" and \"c\" are equivalent when \"c\" is not a +special character." + (with-temp-eshell + (eshell-command-result-p "echo he\\llo" + "hello\n"))) + +(ert-deftest eshell-test/escape-nonspecial-unicode () + "Test that \"\\c\" and \"c\" are equivalent when \"c\" is a +unicode character (unicode characters are nonspecial by +definition)." + (with-temp-eshell + (eshell-command-result-p "echo Vid\\éos" + "Vidéos\n"))) + +(ert-deftest eshell-test/escape-nonspecial-quoted () + "Test that the backslash is preserved for escaped nonspecial +chars" + (with-temp-eshell + (eshell-command-result-p "echo \"h\\i\"" + ;; Backslashes are doubled for regexp. + "h\\\\i\n"))) + +(ert-deftest eshell-test/escape-special-quoted () + "Test that the backslash is not preserved for escaped special +chars" + (with-temp-eshell + (eshell-command-result-p "echo \"h\\\\i\"" + ;; Backslashes are doubled for regexp. + "h\\\\i\n"))) + +(ert-deftest eshell-test/command-running-p () + "Modeline should show no command running" + (with-temp-eshell + (let ((eshell-status-in-mode-line t)) + (should (memq 'eshell-command-running-string mode-line-format)) + (should (equal eshell-command-running-string "--"))))) + +(ert-deftest eshell-test/forward-arg () + "Test moving across command arguments" + (with-temp-eshell + (eshell-insert-command "echo $(+ 1 (- 4 3)) \"alpha beta\" file" 'ignore) + (let ((here (point)) begin valid) + (eshell-bol) + (setq begin (point)) + (eshell-forward-argument 4) + (setq valid (= here (point))) + (eshell-backward-argument 4) + (prog1 + (and valid (= begin (point))) + (eshell-bol) + (delete-region (point) (point-max)))))) + +(ert-deftest eshell-test/queue-input () + "Test queuing command input" + (with-temp-eshell + (eshell-insert-command "sleep 2") + (eshell-insert-command "echo alpha" 'eshell-queue-input) + (let ((count 10)) + (while (and eshell-current-command + (> count 0)) + (sit-for 1) + (setq count (1- count)))) + (eshell-match-result "alpha\n"))) + +(ert-deftest eshell-test/flush-output () + "Test flushing of previous output" + (with-temp-eshell + (eshell-insert-command "echo alpha") + (eshell-kill-output) + (eshell-match-result (regexp-quote "*** output flushed ***\n")) + (should (forward-line)) + (should (= (point) eshell-last-output-start)))) + +(ert-deftest eshell-test/run-old-command () + "Re-run an old command" + (with-temp-eshell + (eshell-insert-command "echo alpha") + (goto-char eshell-last-input-start) + (string= (eshell-get-old-input) "echo alpha"))) + +(provide 'esh-test) + +;;; tests/eshell.el ends here diff --git a/test/lisp/faces-tests.el b/test/lisp/faces-tests.el new file mode 100644 index 00000000000..809ba24d210 --- /dev/null +++ b/test/lisp/faces-tests.el @@ -0,0 +1,59 @@ +;;; faces-tests.el --- Tests for faces.el -*- lexical-binding: t; -*- + +;; Copyright (C) 2013-2016 Free Software Foundation, Inc. + +;; Author: Artur Malabarba <bruce.connor.am@gmail.com> +;; Keywords: + +;; 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 'faces) + +(defface faces--test1 + '((t :background "black" :foreground "black")) + "") + +(defface faces--test2 + '((t :box 1)) + "") + +(ert-deftest faces--test-color-at-point () + (with-temp-buffer + (insert (propertize "STRING" 'face '(faces--test2 faces--test1))) + (goto-char (point-min)) + (should (equal (background-color-at-point) "black")) + (should (equal (foreground-color-at-point) "black"))) + (with-temp-buffer + (insert (propertize "STRING" 'face '(:foreground "black" :background "black"))) + (goto-char (point-min)) + (should (equal (background-color-at-point) "black")) + (should (equal (foreground-color-at-point) "black"))) + (with-temp-buffer + (emacs-lisp-mode) + (setq-local font-lock-comment-face 'faces--test1) + (setq-local font-lock-constant-face 'faces--test2) + (insert ";; `symbol'") + (font-lock-fontify-region (point-min) (point-max)) + (goto-char (point-min)) + (should (equal (background-color-at-point) "black")) + (should (equal (foreground-color-at-point) "black")) + (goto-char 6) + (should (equal (background-color-at-point) "black")) + (should (equal (foreground-color-at-point) "black")))) + +(provide 'faces-tests) +;;; faces-tests.el ends here diff --git a/test/lisp/filenotify-tests.el b/test/lisp/filenotify-tests.el new file mode 100644 index 00000000000..4cde86c8eee --- /dev/null +++ b/test/lisp/filenotify-tests.el @@ -0,0 +1,852 @@ +;;; file-notify-tests.el --- Tests of file notifications -*- lexical-binding: t; -*- + +;; Copyright (C) 2013-2016 Free Software Foundation, Inc. + +;; Author: Michael Albinus <michael.albinus@gmx.de> + +;; 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/'. + +;;; Commentary: + +;; Some of the tests require access to a remote host files. Since +;; this could be problematic, a mock-up connection method "mock" is +;; used. Emulating a remote connection, it simply calls "sh -i". +;; Tramp's file name handlers still run, so this test is sufficient +;; except for connection establishing. + +;; If you want to test a real Tramp connection, set +;; $REMOTE_TEMPORARY_FILE_DIRECTORY to a suitable value in order to +;; overwrite the default value. If you want to skip tests accessing a +;; remote host, set this environment variable to "/dev/null" or +;; whatever is appropriate on your system. + +;; A whole test run can be performed calling the command `file-notify-test-all'. + +;;; Code: + +(require 'ert) +(require 'filenotify) +(require 'tramp) + +;; There is no default value on w32 systems, which could work out of the box. +(defconst file-notify-test-remote-temporary-file-directory + (cond + ((getenv "REMOTE_TEMPORARY_FILE_DIRECTORY")) + ((eq system-type 'windows-nt) null-device) + (t (add-to-list + 'tramp-methods + '("mock" + (tramp-login-program "sh") + (tramp-login-args (("-i"))) + (tramp-remote-shell "/bin/sh") + (tramp-remote-shell-args ("-c")) + (tramp-connection-timeout 10))) + (format "/mock::%s" temporary-file-directory))) + "Temporary directory for Tramp tests.") + +(defvar file-notify--test-tmpfile nil) +(defvar file-notify--test-tmpfile1 nil) +(defvar file-notify--test-desc nil) +(defvar file-notify--test-results nil) +(defvar file-notify--test-event nil) +(defvar file-notify--test-events nil) + +(defun file-notify--test-timeout () + "Timeout to wait for arriving events, in seconds." + (cond + ((file-remote-p temporary-file-directory) 6) + ((string-equal (file-notify--test-library) "w32notify") 20) + ((eq system-type 'cygwin) 10) + (t 3))) + +(defun file-notify--test-cleanup () + "Cleanup after a test." + (file-notify-rm-watch file-notify--test-desc) + + (when (and file-notify--test-tmpfile + (file-exists-p file-notify--test-tmpfile)) + (if (file-directory-p file-notify--test-tmpfile) + (delete-directory file-notify--test-tmpfile 'recursive) + (delete-file file-notify--test-tmpfile))) + (when (and file-notify--test-tmpfile1 + (file-exists-p file-notify--test-tmpfile1)) + (if (file-directory-p file-notify--test-tmpfile1) + (delete-directory file-notify--test-tmpfile1 'recursive) + (delete-file file-notify--test-tmpfile1))) + (when (file-remote-p temporary-file-directory) + (tramp-cleanup-connection + (tramp-dissect-file-name temporary-file-directory) nil 'keep-password)) + + (setq file-notify--test-tmpfile nil + file-notify--test-tmpfile1 nil + file-notify--test-desc nil + file-notify--test-results nil + file-notify--test-events nil) + (when file-notify--test-event + (error "file-notify--test-event should not be set but bound dynamically"))) + +(setq password-cache-expiry nil + tramp-verbose 0 + tramp-message-show-message nil) + +;; This shall happen on hydra only. +(when (getenv "NIX_STORE") + (add-to-list 'tramp-remote-path 'tramp-own-remote-path)) + +;; We do not want to try and fail `file-notify-add-watch'. +(defun file-notify--test-local-enabled () + "Whether local file notification is enabled. +This is needed for local `temporary-file-directory' only, in the +remote case we return always t." + (or file-notify--library + (file-remote-p temporary-file-directory))) + +(defvar file-notify--test-remote-enabled-checked nil + "Cached result of `file-notify--test-remote-enabled'. +If the function did run, the value is a cons cell, the `cdr' +being the result.") + +(defun file-notify--test-remote-enabled () + "Whether remote file notification is enabled." + (unless (consp file-notify--test-remote-enabled-checked) + (let (desc) + (ignore-errors + (and + (file-remote-p file-notify-test-remote-temporary-file-directory) + (file-directory-p file-notify-test-remote-temporary-file-directory) + (file-writable-p file-notify-test-remote-temporary-file-directory) + (setq desc + (file-notify-add-watch + file-notify-test-remote-temporary-file-directory + '(change) 'ignore)))) + (setq file-notify--test-remote-enabled-checked (cons t desc)) + (when desc (file-notify-rm-watch desc)))) + ;; Return result. + (cdr file-notify--test-remote-enabled-checked)) + +(defun file-notify--test-library () + "The used library for the test, as a string. +In the remote case, it is the process name which runs on the +remote host, or nil." + (if (null (file-remote-p temporary-file-directory)) + (symbol-name file-notify--library) + (and (consp file-notify--test-remote-enabled-checked) + (processp (cdr file-notify--test-remote-enabled-checked)) + (replace-regexp-in-string + "<[[:digit:]]+>\\'" "" + (process-name (cdr file-notify--test-remote-enabled-checked)))))) + +(defmacro file-notify--deftest-remote (test docstring) + "Define ert `TEST-remote' for remote files." + (declare (indent 1)) + `(ert-deftest ,(intern (concat (symbol-name test) "-remote")) () + ,docstring + (let* ((temporary-file-directory + file-notify-test-remote-temporary-file-directory) + (ert-test (ert-get-test ',test))) + (skip-unless (file-notify--test-remote-enabled)) + (tramp-cleanup-connection + (tramp-dissect-file-name temporary-file-directory) nil 'keep-password) + (funcall (ert-test-body ert-test))))) + +(ert-deftest file-notify-test00-availability () + "Test availability of `file-notify'." + (skip-unless (file-notify--test-local-enabled)) + ;; Report the native library which has been used. + (message "Library: `%s'" (file-notify--test-library)) + (should + (setq file-notify--test-desc + (file-notify-add-watch temporary-file-directory '(change) 'ignore))) + + ;; Cleanup. + (file-notify--test-cleanup)) + +(file-notify--deftest-remote file-notify-test00-availability + "Test availability of `file-notify' for remote files.") + +(ert-deftest file-notify-test01-add-watch () + "Check `file-notify-add-watch'." + (skip-unless (file-notify--test-local-enabled)) + + (setq file-notify--test-tmpfile (file-notify--test-make-temp-name) + file-notify--test-tmpfile1 + (format "%s/%s" file-notify--test-tmpfile (md5 (current-time-string)))) + + ;; Check, that different valid parameters are accepted. + (should + (setq file-notify--test-desc + (file-notify-add-watch temporary-file-directory '(change) 'ignore))) + (file-notify-rm-watch file-notify--test-desc) + (should + (setq file-notify--test-desc + (file-notify-add-watch + temporary-file-directory '(attribute-change) 'ignore))) + (file-notify-rm-watch file-notify--test-desc) + (should + (setq file-notify--test-desc + (file-notify-add-watch + temporary-file-directory '(change attribute-change) 'ignore))) + (file-notify-rm-watch file-notify--test-desc) + (write-region "any text" nil file-notify--test-tmpfile nil 'no-message) + (should + (setq file-notify--test-desc + (file-notify-add-watch + file-notify--test-tmpfile '(change attribute-change) 'ignore))) + (file-notify-rm-watch file-notify--test-desc) + (delete-file file-notify--test-tmpfile) + + ;; Check error handling. + (should-error (file-notify-add-watch 1 2 3 4) + :type 'wrong-number-of-arguments) + (should + (equal (should-error + (file-notify-add-watch 1 2 3)) + '(wrong-type-argument 1))) + (should + (equal (should-error + (file-notify-add-watch temporary-file-directory 2 3)) + '(wrong-type-argument 2))) + (should + (equal (should-error + (file-notify-add-watch temporary-file-directory '(change) 3)) + '(wrong-type-argument 3))) + ;; The upper directory of a file must exist. + (should + (equal (should-error + (file-notify-add-watch + file-notify--test-tmpfile1 '(change attribute-change) 'ignore)) + `(file-notify-error + "Directory does not exist" ,file-notify--test-tmpfile))) + + ;; Cleanup. + (file-notify--test-cleanup)) + +(file-notify--deftest-remote file-notify-test01-add-watch + "Check `file-notify-add-watch' for remote files.") + +(defun file-notify--test-event-test () + "Ert test function to be called by `file-notify--test-event-handler'. +We cannot pass arguments, so we assume that `file-notify--test-event' +is bound somewhere." + ;; Check the descriptor. + (should (equal (car file-notify--test-event) file-notify--test-desc)) + ;; Check the file name. + (should + (or (string-equal (file-notify--event-file-name file-notify--test-event) + file-notify--test-tmpfile) + (string-equal (file-notify--event-file-name file-notify--test-event) + file-notify--test-tmpfile1) + (string-equal (file-notify--event-file-name file-notify--test-event) + temporary-file-directory))) + ;; Check the second file name if exists. + (when (eq (nth 1 file-notify--test-event) 'renamed) + (should + (or (string-equal (file-notify--event-file1-name file-notify--test-event) + file-notify--test-tmpfile1) + (string-equal (file-notify--event-file1-name file-notify--test-event) + temporary-file-directory))))) + +(defun file-notify--test-event-handler (event) + "Run a test over FILE-NOTIFY--TEST-EVENT. +For later analysis, append the test result to `file-notify--test-results' +and the event to `file-notify--test-events'." + (let* ((file-notify--test-event event) + (result + (ert-run-test (make-ert-test :body 'file-notify--test-event-test)))) + ;; Do not add lock files, this would confuse the checks. + (unless (string-match + (regexp-quote ".#") + (file-notify--event-file-name file-notify--test-event)) + ;;(message "file-notify--test-event-handler %S" file-notify--test-event) + (setq file-notify--test-events + (append file-notify--test-events `(,file-notify--test-event)) + file-notify--test-results + (append file-notify--test-results `(,result)))))) + +(defun file-notify--test-make-temp-name () + "Create a temporary file name for test." + (expand-file-name + (make-temp-name "file-notify-test") temporary-file-directory)) + +(defmacro file-notify--wait-for-events (timeout until) + "Wait for and return file notification events until form UNTIL is true. +TIMEOUT is the maximum time to wait for, in seconds." + `(with-timeout (,timeout (ignore)) + (while (null ,until) + (read-event nil nil 0.1)))) + +(defmacro file-notify--test-with-events (events &rest body) + "Run BODY collecting events and then compare with EVENTS. +EVENTS is either a simple list of events, or a list of lists of +events, which represent different possible results. Don't wait +longer than timeout seconds for the events to be delivered." + (declare (indent 1)) + (let ((outer (make-symbol "outer"))) + `(let* ((,outer file-notify--test-events) + (events (if (consp (car ,events)) ,events (list ,events))) + (max-length (apply 'max (mapcar 'length events))) + create-lockfiles result) + ;; Flush pending events. + (file-notify--wait-for-events + (file-notify--test-timeout) + (input-pending-p)) + (let (file-notify--test-events) + ,@body + (file-notify--wait-for-events + ;; More events need more time. Use some fudge factor. + (* (ceiling max-length 100) (file-notify--test-timeout)) + (= max-length (length file-notify--test-events))) + ;; One of the possible results shall match. + (should + (dolist (elt events result) + (setq result + (or result + (equal elt (mapcar #'cadr file-notify--test-events)))))) + (setq ,outer (append ,outer file-notify--test-events))) + (setq file-notify--test-events ,outer)))) + +(ert-deftest file-notify-test02-events () + "Check file creation/change/removal notifications." + (skip-unless (file-notify--test-local-enabled)) + + (unwind-protect + (progn + ;; Check file creation, change and deletion. It doesn't work + ;; for cygwin and kqueue, because we don't use an implicit + ;; directory monitor (kqueue), or the timings are too bad (cygwin). + (unless (or (eq system-type 'cygwin) + (string-equal (file-notify--test-library) "kqueue")) + (setq file-notify--test-tmpfile (file-notify--test-make-temp-name)) + (should + (setq file-notify--test-desc + (file-notify-add-watch + file-notify--test-tmpfile + '(change) 'file-notify--test-event-handler))) + (file-notify--test-with-events + (cond + ;; cygwin recognizes only `deleted' and `stopped' events. + ((eq system-type 'cygwin) + '(deleted stopped)) + (t '(created changed deleted stopped))) + (write-region + "another text" nil file-notify--test-tmpfile nil 'no-message) + (read-event nil nil 0.1) + (delete-file file-notify--test-tmpfile)) + ;; `file-notify-rm-watch' fires the `stopped' event. Suppress it. + (let (file-notify--test-events) + (file-notify-rm-watch file-notify--test-desc))) + + ;; Check file change and deletion. + (setq file-notify--test-tmpfile (file-notify--test-make-temp-name)) + (write-region "any text" nil file-notify--test-tmpfile nil 'no-message) + (should + (setq file-notify--test-desc + (file-notify-add-watch + file-notify--test-tmpfile + '(change) 'file-notify--test-event-handler))) + (file-notify--test-with-events + (cond + ;; cygwin recognizes only `deleted' and `stopped' events. + ((eq system-type 'cygwin) + '(deleted stopped)) + ;; inotify and kqueue raise just one `changed' event. + ((or (string-equal "inotify" (file-notify--test-library)) + (string-equal "kqueue" (file-notify--test-library))) + '(changed deleted stopped)) + ;; gfilenotify raises one or two `changed' events + ;; randomly, no chance to test. So we accept both cases. + ((string-equal "gfilenotify" (file-notify--test-library)) + '((changed deleted stopped) + (changed changed deleted stopped))) + (t '(changed changed deleted stopped))) + (read-event nil nil 0.1) + (write-region + "another text" nil file-notify--test-tmpfile nil 'no-message) + (read-event nil nil 0.1) + (delete-file file-notify--test-tmpfile)) + ;; `file-notify-rm-watch' fires the `stopped' event. Suppress it. + (let (file-notify--test-events) + (file-notify-rm-watch file-notify--test-desc)) + + ;; Check file creation, change and deletion when watching a + ;; directory. There must be a `stopped' event when deleting + ;; the directory. + (let ((temporary-file-directory + (make-temp-file "file-notify-test-parent" t))) + (should + (setq file-notify--test-tmpfile (file-notify--test-make-temp-name) + file-notify--test-desc + (file-notify-add-watch + temporary-file-directory + '(change) 'file-notify--test-event-handler))) + (file-notify--test-with-events + (cond + ;; w32notify does raise a `stopped' event when a + ;; watched directory is deleted. + ((string-equal (file-notify--test-library) "w32notify") + '(created changed deleted)) + ;; cygwin recognizes only `deleted' and `stopped' events. + ((eq system-type 'cygwin) + '(deleted stopped)) + ;; There are two `deleted' events, for the file and for + ;; the directory. Except for kqueue. + ((string-equal (file-notify--test-library) "kqueue") + '(created changed deleted stopped)) + (t '(created changed deleted deleted stopped))) + (read-event nil nil 0.1) + (write-region + "any text" nil file-notify--test-tmpfile nil 'no-message) + (read-event nil nil 0.1) + (delete-directory temporary-file-directory 'recursive)) + ;; `file-notify-rm-watch' fires the `stopped' event. Suppress it. + (let (file-notify--test-events) + (file-notify-rm-watch file-notify--test-desc))) + + ;; Check copy of files inside a directory. + (let ((temporary-file-directory + (make-temp-file "file-notify-test-parent" t))) + (should + (setq file-notify--test-tmpfile (file-notify--test-make-temp-name) + file-notify--test-tmpfile1 (file-notify--test-make-temp-name) + file-notify--test-desc + (file-notify-add-watch + temporary-file-directory + '(change) 'file-notify--test-event-handler))) + (file-notify--test-with-events + (cond + ;; w32notify does not distinguish between `changed' and + ;; `attribute-changed'. + ((string-equal (file-notify--test-library) "w32notify") + '(created changed created changed changed changed changed + deleted deleted)) + ;; cygwin recognizes only `deleted' and `stopped' events. + ((eq system-type 'cygwin) + '(deleted stopped)) + ;; There are three `deleted' events, for two files and + ;; for the directory. Except for kqueue. + ((string-equal (file-notify--test-library) "kqueue") + '(created changed created changed deleted stopped)) + (t '(created changed created changed + deleted deleted deleted stopped))) + (read-event nil nil 0.1) + (write-region + "any text" nil file-notify--test-tmpfile nil 'no-message) + (read-event nil nil 0.1) + (copy-file file-notify--test-tmpfile file-notify--test-tmpfile1) + ;; The next two events shall not be visible. + (read-event nil nil 0.1) + (set-file-modes file-notify--test-tmpfile 000) + (read-event nil nil 0.1) + (set-file-times file-notify--test-tmpfile '(0 0)) + (read-event nil nil 0.1) + (delete-directory temporary-file-directory 'recursive)) + ;; `file-notify-rm-watch' fires the `stopped' event. Suppress it. + (let (file-notify--test-events) + (file-notify-rm-watch file-notify--test-desc))) + + ;; Check rename of files inside a directory. + (let ((temporary-file-directory + (make-temp-file "file-notify-test-parent" t))) + (should + (setq file-notify--test-tmpfile (file-notify--test-make-temp-name) + file-notify--test-tmpfile1 (file-notify--test-make-temp-name) + file-notify--test-desc + (file-notify-add-watch + temporary-file-directory + '(change) 'file-notify--test-event-handler))) + (file-notify--test-with-events + (cond + ;; w32notify does not distinguish between `changed' and + ;; `attribute-changed'. + ((string-equal (file-notify--test-library) "w32notify") + '(created changed renamed deleted)) + ;; cygwin recognizes only `deleted' and `stopped' events. + ((eq system-type 'cygwin) + '(deleted stopped)) + ;; There are two `deleted' events, for the file and for + ;; the directory. Except for kqueue. + ((string-equal (file-notify--test-library) "kqueue") + '(created changed renamed deleted stopped)) + (t '(created changed renamed deleted deleted stopped))) + (read-event nil nil 0.1) + (write-region + "any text" nil file-notify--test-tmpfile nil 'no-message) + (read-event nil nil 0.1) + (rename-file file-notify--test-tmpfile file-notify--test-tmpfile1) + ;; After the rename, we won't get events anymore. + (read-event nil nil 0.1) + (delete-directory temporary-file-directory 'recursive)) + ;; `file-notify-rm-watch' fires the `stopped' event. Suppress it. + (let (file-notify--test-events) + (file-notify-rm-watch file-notify--test-desc))) + + ;; Check attribute change. Does not work for cygwin. + (unless (eq system-type 'cygwin) + (setq file-notify--test-tmpfile (file-notify--test-make-temp-name)) + (write-region + "any text" nil file-notify--test-tmpfile nil 'no-message) + (should + (setq file-notify--test-desc + (file-notify-add-watch + file-notify--test-tmpfile + '(attribute-change) 'file-notify--test-event-handler))) + (file-notify--test-with-events + (cond + ;; w32notify does not distinguish between `changed' and + ;; `attribute-changed'. + ((string-equal (file-notify--test-library) "w32notify") + '(changed changed changed changed)) + ;; For kqueue and in the remote case, `write-region' + ;; raises also an `attribute-changed' event. + ((or (string-equal (file-notify--test-library) "kqueue") + (file-remote-p temporary-file-directory)) + '(attribute-changed attribute-changed attribute-changed)) + (t '(attribute-changed attribute-changed))) + (read-event nil nil 0.1) + (write-region + "any text" nil file-notify--test-tmpfile nil 'no-message) + (read-event nil nil 0.1) + (set-file-modes file-notify--test-tmpfile 000) + (read-event nil nil 0.1) + (set-file-times file-notify--test-tmpfile '(0 0)) + (read-event nil nil 0.1) + (delete-file file-notify--test-tmpfile)) + ;; `file-notify-rm-watch' fires the `stopped' event. Suppress it. + (let (file-notify--test-events) + (file-notify-rm-watch file-notify--test-desc))) + + ;; Check the global sequence again just to make sure that + ;; `file-notify--test-events' has been set correctly. + (should file-notify--test-results) + (dolist (result file-notify--test-results) + (when (ert-test-failed-p result) + (ert-fail + (cadr (ert-test-result-with-condition-condition result)))))) + + ;; Cleanup. + (file-notify--test-cleanup))) + +(file-notify--deftest-remote file-notify-test02-events + "Check file creation/change/removal notifications for remote files.") + +(require 'autorevert) +(setq auto-revert-notify-exclude-dir-regexp "nothing-to-be-excluded" + auto-revert-remote-files t + auto-revert-stop-on-user-input nil) + +(ert-deftest file-notify-test03-autorevert () + "Check autorevert via file notification." + (skip-unless (file-notify--test-local-enabled)) + ;; `auto-revert-buffers' runs every 5". And we must wait, until the + ;; file has been reverted. + (let ((timeout (if (file-remote-p temporary-file-directory) 60 10)) + buf) + (unwind-protect + (progn + (setq file-notify--test-tmpfile (file-notify--test-make-temp-name)) + + (write-region + "any text" nil file-notify--test-tmpfile nil 'no-message) + (setq buf (find-file-noselect file-notify--test-tmpfile)) + (with-current-buffer buf + (should (string-equal (buffer-string) "any text")) + ;; `buffer-stale--default-function' checks for + ;; `verify-visited-file-modtime'. We must ensure that it + ;; returns nil. + (sleep-for 1) + (auto-revert-mode 1) + + ;; `auto-revert-buffers' runs every 5". + (with-timeout (timeout (ignore)) + (while (null auto-revert-notify-watch-descriptor) + (sleep-for 1))) + + ;; Check, that file notification has been used. + (should auto-revert-mode) + (should auto-revert-use-notify) + (should auto-revert-notify-watch-descriptor) + + ;; Modify file. We wait for a second, in order to have + ;; another timestamp. + (with-current-buffer (get-buffer-create "*Messages*") + (narrow-to-region (point-max) (point-max))) + (sleep-for 1) + (write-region + "another text" nil file-notify--test-tmpfile nil 'no-message) + + ;; Check, that the buffer has been reverted. + (with-current-buffer (get-buffer-create "*Messages*") + (file-notify--wait-for-events + timeout + (string-match + (format-message "Reverting buffer `%s'." (buffer-name buf)) + (buffer-string)))) + (should (string-match "another text" (buffer-string))) + + ;; Stop file notification. Autorevert shall still work via polling. + ;; It doesn't work for `w32notify'. + (unless (string-equal (file-notify--test-library) "w32notify") + (file-notify-rm-watch auto-revert-notify-watch-descriptor) + (file-notify--wait-for-events + timeout (null auto-revert-use-notify)) + (should-not auto-revert-use-notify) + (should-not auto-revert-notify-watch-descriptor) + + ;; Modify file. We wait for two seconds, in order to + ;; have another timestamp. One second seems to be too + ;; short. + (with-current-buffer (get-buffer-create "*Messages*") + (narrow-to-region (point-max) (point-max))) + (sleep-for 2) + (write-region + "foo bla" nil file-notify--test-tmpfile nil 'no-message) + + ;; Check, that the buffer has been reverted. + (with-current-buffer (get-buffer-create "*Messages*") + (file-notify--wait-for-events + timeout + (string-match + (format-message "Reverting buffer `%s'." (buffer-name buf)) + (buffer-string)))) + (should (string-match "foo bla" (buffer-string)))))) + + ;; Cleanup. + (with-current-buffer "*Messages*" (widen)) + (ignore-errors (kill-buffer buf)) + (file-notify--test-cleanup)))) + +(file-notify--deftest-remote file-notify-test03-autorevert + "Check autorevert via file notification for remote files.") + +(ert-deftest file-notify-test04-file-validity () + "Check `file-notify-valid-p' for files." + (skip-unless (file-notify--test-local-enabled)) + + (unwind-protect + (progn + (setq file-notify--test-tmpfile (file-notify--test-make-temp-name)) + (write-region "any text" nil file-notify--test-tmpfile nil 'no-message) + (should + (setq file-notify--test-desc + (file-notify-add-watch + file-notify--test-tmpfile + '(change) #'file-notify--test-event-handler))) + (should (file-notify-valid-p file-notify--test-desc)) + ;; After calling `file-notify-rm-watch', the descriptor is not + ;; valid anymore. + (file-notify-rm-watch file-notify--test-desc) + (should-not (file-notify-valid-p file-notify--test-desc)) + (delete-file file-notify--test-tmpfile)) + + ;; Cleanup. + (file-notify--test-cleanup)) + + (unwind-protect + (progn + (setq file-notify--test-tmpfile (file-notify--test-make-temp-name)) + (write-region "any text" nil file-notify--test-tmpfile nil 'no-message) + (should + (setq file-notify--test-desc + (file-notify-add-watch + file-notify--test-tmpfile + '(change) #'file-notify--test-event-handler))) + (file-notify--test-with-events + (cond + ;; cygwin recognizes only `deleted' and `stopped' events. + ((eq system-type 'cygwin) + '(deleted stopped)) + ;; inotify and kqueue raise just one `changed' event. + ((or (string-equal "inotify" (file-notify--test-library)) + (string-equal "kqueue" (file-notify--test-library))) + '(changed deleted stopped)) + ;; gfilenotify raises one or two `changed' events + ;; randomly, no chance to test. So we accept both cases. + ((string-equal "gfilenotify" (file-notify--test-library)) + '((changed deleted stopped) + (changed changed deleted stopped))) + (t '(changed changed deleted stopped))) + (should (file-notify-valid-p file-notify--test-desc)) + (read-event nil nil 0.1) + (write-region + "another text" nil file-notify--test-tmpfile nil 'no-message) + (read-event nil nil 0.1) + (delete-file file-notify--test-tmpfile)) + ;; After deleting the file, the descriptor is not valid anymore. + (should-not (file-notify-valid-p file-notify--test-desc)) + (file-notify-rm-watch file-notify--test-desc)) + + ;; Cleanup. + (file-notify--test-cleanup)) + + (unwind-protect + ;; w32notify does not send a `stopped' event when deleting a + ;; directory. The test does not work, therefore. + (unless (string-equal (file-notify--test-library) "w32notify") + (let ((temporary-file-directory + (make-temp-file "file-notify-test-parent" t))) + (should + (setq file-notify--test-tmpfile (file-notify--test-make-temp-name) + file-notify--test-desc + (file-notify-add-watch + temporary-file-directory + '(change) #'file-notify--test-event-handler))) + (file-notify--test-with-events + (cond + ;; cygwin recognizes only `deleted' and `stopped' events. + ((eq system-type 'cygwin) + '(deleted stopped)) + ;; There are two `deleted' events, for the file and for + ;; the directory. Except for kqueue. + ((string-equal (file-notify--test-library) "kqueue") + '(created changed deleted stopped)) + (t '(created changed deleted deleted stopped))) + (should (file-notify-valid-p file-notify--test-desc)) + (read-event nil nil 0.1) + (write-region + "any text" nil file-notify--test-tmpfile nil 'no-message) + (read-event nil nil 0.1) + (delete-directory temporary-file-directory t)) + ;; After deleting the parent directory, the descriptor must + ;; not be valid anymore. + (should-not (file-notify-valid-p file-notify--test-desc)))) + + ;; Cleanup. + (file-notify--test-cleanup))) + +(file-notify--deftest-remote file-notify-test04-file-validity + "Check `file-notify-valid-p' via file notification for remote files.") + +(ert-deftest file-notify-test05-dir-validity () + "Check `file-notify-valid-p' for directories." + (skip-unless (file-notify--test-local-enabled)) + + (unwind-protect + (progn + (setq file-notify--test-tmpfile + (file-name-as-directory (file-notify--test-make-temp-name))) + (make-directory file-notify--test-tmpfile) + (should + (setq file-notify--test-desc + (file-notify-add-watch + file-notify--test-tmpfile + '(change) #'file-notify--test-event-handler))) + (should (file-notify-valid-p file-notify--test-desc)) + ;; After removing the watch, the descriptor must not be valid + ;; anymore. + (file-notify-rm-watch file-notify--test-desc) + (file-notify--wait-for-events + (file-notify--test-timeout) + (not (file-notify-valid-p file-notify--test-desc))) + (should-not (file-notify-valid-p file-notify--test-desc))) + + ;; Cleanup. + (file-notify--test-cleanup)) + + (unwind-protect + ;; The batch-mode operation of w32notify is fragile (there's no + ;; input threads to send the message to). + (unless (and noninteractive + (string-equal (file-notify--test-library) "w32notify")) + (setq file-notify--test-tmpfile + (file-name-as-directory (file-notify--test-make-temp-name))) + (make-directory file-notify--test-tmpfile) + (should + (setq file-notify--test-desc + (file-notify-add-watch + file-notify--test-tmpfile + '(change) #'file-notify--test-event-handler))) + (should (file-notify-valid-p file-notify--test-desc)) + ;; After deleting the directory, the descriptor must not be + ;; valid anymore. + (delete-directory file-notify--test-tmpfile t) + (file-notify--wait-for-events + (file-notify--test-timeout) + (not (file-notify-valid-p file-notify--test-desc))) + (should-not (file-notify-valid-p file-notify--test-desc))) + + ;; Cleanup. + (file-notify--test-cleanup))) + +(file-notify--deftest-remote file-notify-test05-dir-validity + "Check `file-notify-valid-p' via file notification for remote directories.") + +(ert-deftest file-notify-test06-many-events () + "Check that events are not dropped." + (skip-unless (file-notify--test-local-enabled)) + ;; Under cygwin events arrive in random order. Impossible to define a test. + (skip-unless (not (eq system-type 'cygwin))) + + (setq file-notify--test-tmpfile (file-notify--test-make-temp-name)) + (make-directory file-notify--test-tmpfile) + (should + (setq file-notify--test-desc + (file-notify-add-watch + file-notify--test-tmpfile + '(change) 'file-notify--test-event-handler))) + (unwind-protect + (let ((n 1000) + source-file-list target-file-list + (default-directory file-notify--test-tmpfile)) + (dotimes (i n) + ;; It matters which direction we rename, at least for + ;; kqueue. This backend parses directories in alphabetic + ;; order (x%d before y%d). So we rename both directions. + (if (zerop (mod i 2)) + (progn + (push (expand-file-name (format "x%d" i)) source-file-list) + (push (expand-file-name (format "y%d" i)) target-file-list)) + (push (expand-file-name (format "y%d" i)) source-file-list) + (push (expand-file-name (format "x%d" i)) target-file-list))) + (file-notify--test-with-events (make-list (+ n n) 'created) + (let ((source-file-list source-file-list) + (target-file-list target-file-list)) + (while (and source-file-list target-file-list) + (read-event nil nil 0.1) + (write-region "" nil (pop source-file-list) nil 'no-message) + (read-event nil nil 0.1) + (write-region "" nil (pop target-file-list) nil 'no-message)))) + (file-notify--test-with-events + (cond + ;; w32notify fires both `deleted' and `renamed' events. + ((string-equal (file-notify--test-library) "w32notify") + (let (r) + (dotimes (_i n r) + (setq r (append '(deleted renamed) r))))) + (t (make-list n 'renamed))) + (let ((source-file-list source-file-list) + (target-file-list target-file-list)) + (while (and source-file-list target-file-list) + (rename-file (pop source-file-list) (pop target-file-list) t)))) + (file-notify--test-with-events (make-list n 'deleted) + (dolist (file target-file-list) + (delete-file file)))) + (file-notify--test-cleanup))) + +(file-notify--deftest-remote file-notify-test06-many-events + "Check that events are not dropped for remote directories.") + +(defun file-notify-test-all (&optional interactive) + "Run all tests for \\[file-notify]." + (interactive "p") + (if interactive + (ert-run-tests-interactively "^file-notify-") + (ert-run-tests-batch "^file-notify-"))) + +;; TODO: + +;; * For w32notify, no stopped events arrive when a directory is removed. +;; * Check, why cygwin recognizes only `deleted' and `stopped' events. + +(provide 'file-notify-tests) +;;; file-notify-tests.el ends here diff --git a/test/lisp/gnus/auth-source-tests.el b/test/lisp/gnus/auth-source-tests.el new file mode 100644 index 00000000000..5faa1fe20bf --- /dev/null +++ b/test/lisp/gnus/auth-source-tests.el @@ -0,0 +1,223 @@ +;;; auth-source-tests.el --- Tests for auth-source.el -*- lexical-binding: t; -*- + +;; Copyright (C) 2015-2016 Free Software Foundation, Inc. + +;; Author: Damien Cassou <damien@cassou.me>, +;; Nicolas Petton <nicolas@petton.fr> + +;; 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: + +;; + +;;; Code: + +(require 'ert) +(require 'auth-source) + +(defvar secrets-enabled t + "Enable the secrets backend to test its features.") + +(defun auth-source-validate-backend (source validation-alist) + (let ((backend (auth-source-backend-parse source))) + (should (auth-source-backend-p backend)) + (dolist (pair validation-alist) + (should (equal (eieio-oref backend (car pair)) (cdr pair)))))) + +(ert-deftest auth-source-backend-parse-macos-keychain () + (auth-source-validate-backend '(:source (:macos-keychain-generic foobar)) + '((:source . "foobar") + (:type . macos-keychain-generic) + (:search-function . auth-source-macos-keychain-search) + (:create-function . auth-source-macos-keychain-create)))) + +(ert-deftest auth-source-backend-parse-macos-keychain-generic-string () + (auth-source-validate-backend "macos-keychain-generic:foobar" + '((:source . "foobar") + (:type . macos-keychain-generic) + (:search-function . auth-source-macos-keychain-search) + (:create-function . auth-source-macos-keychain-create)))) + +(ert-deftest auth-source-backend-parse-macos-keychain-internet-string () + (auth-source-validate-backend "macos-keychain-internet:foobar" + '((:source . "foobar") + (:type . macos-keychain-internet) + (:search-function . auth-source-macos-keychain-search) + (:create-function . auth-source-macos-keychain-create)))) + +(ert-deftest auth-source-backend-parse-macos-keychain-internet-symbol () + (auth-source-validate-backend 'macos-keychain-internet + '((:source . "default") + (:type . macos-keychain-internet) + (:search-function . auth-source-macos-keychain-search) + (:create-function . auth-source-macos-keychain-create)))) + +(ert-deftest auth-source-backend-parse-macos-keychain-generic-symbol () + (auth-source-validate-backend 'macos-keychain-generic + '((:source . "default") + (:type . macos-keychain-generic) + (:search-function . auth-source-macos-keychain-search) + (:create-function . auth-source-macos-keychain-create)))) + +(ert-deftest auth-source-backend-parse-macos-keychain-internet-default-string () + (auth-source-validate-backend 'macos-keychain-internet + '((:source . "default") + (:type . macos-keychain-internet) + (:search-function . auth-source-macos-keychain-search) + (:create-function . auth-source-macos-keychain-create)))) + +(ert-deftest auth-source-backend-parse-plstore () + (auth-source-validate-backend '(:source "foo.plist") + '((:source . "foo.plist") + (:type . plstore) + (:search-function . auth-source-plstore-search) + (:create-function . auth-source-plstore-create)))) + +(ert-deftest auth-source-backend-parse-netrc () + (auth-source-validate-backend '(:source "foo") + '((:source . "foo") + (:type . netrc) + (:search-function . auth-source-netrc-search) + (:create-function . auth-source-netrc-create)))) + +(ert-deftest auth-source-backend-parse-netrc-string () + (auth-source-validate-backend "foo" + '((:source . "foo") + (:type . netrc) + (:search-function . auth-source-netrc-search) + (:create-function . auth-source-netrc-create)))) + +(ert-deftest auth-source-backend-parse-secrets () + (provide 'secrets) ; simulates the presence of the `secrets' package + (let ((secrets-enabled t)) + (auth-source-validate-backend '(:source (:secrets "foo")) + '((:source . "foo") + (:type . secrets) + (:search-function . auth-source-secrets-search) + (:create-function . auth-source-secrets-create))))) + +(ert-deftest auth-source-backend-parse-secrets-strings () + (provide 'secrets) ; simulates the presence of the `secrets' package + (let ((secrets-enabled t)) + (auth-source-validate-backend "secrets:foo" + '((:source . "foo") + (:type . secrets) + (:search-function . auth-source-secrets-search) + (:create-function . auth-source-secrets-create))))) + +(ert-deftest auth-source-backend-parse-secrets-nil-source () + (provide 'secrets) ; simulates the presence of the `secrets' package + (let ((secrets-enabled t)) + (auth-source-validate-backend '(:source (:secrets nil)) + '((:source . "session") + (:type . secrets) + (:search-function . auth-source-secrets-search) + (:create-function . auth-source-secrets-create))))) + +(ert-deftest auth-source-backend-parse-secrets-alias () + (provide 'secrets) ; simulates the presence of the `secrets' package + (let ((secrets-enabled t)) + ;; Redefine `secrets-get-alias' to map 'foo to "foo" + (cl-letf (((symbol-function 'secrets-get-alias) (lambda (_) "foo"))) + (auth-source-validate-backend '(:source (:secrets foo)) + '((:source . "foo") + (:type . secrets) + (:search-function . auth-source-secrets-search) + (:create-function . auth-source-secrets-create)))))) + +(ert-deftest auth-source-backend-parse-secrets-symbol () + (provide 'secrets) ; simulates the presence of the `secrets' package + (let ((secrets-enabled t)) + ;; Redefine `secrets-get-alias' to map 'default to "foo" + (cl-letf (((symbol-function 'secrets-get-alias) (lambda (_) "foo"))) + (auth-source-validate-backend 'default + '((:source . "foo") + (:type . secrets) + (:search-function . auth-source-secrets-search) + (:create-function . auth-source-secrets-create)))))) + +(ert-deftest auth-source-backend-parse-secrets-no-alias () + (provide 'secrets) ; simulates the presence of the `secrets' package + (let ((secrets-enabled t)) + ;; Redefine `secrets-get-alias' to map 'foo to nil (so that + ;; "Login" is used by default + (cl-letf (((symbol-function 'secrets-get-alias) (lambda (_) nil))) + (auth-source-validate-backend '(:source (:secrets foo)) + '((:source . "Login") + (:type . secrets) + (:search-function . auth-source-secrets-search) + (:create-function . auth-source-secrets-create)))))) + +;; TODO This test shows suspicious behavior of auth-source: the +;; "secrets" source is used even though nothing in the input indicates +;; that is what we want +(ert-deftest auth-source-backend-parse-secrets-no-source () + (provide 'secrets) ; simulates the presence of the `secrets' package + (let ((secrets-enabled t)) + (auth-source-validate-backend '(:source '(foo)) + '((:source . "session") + (:type . secrets) + (:search-function . auth-source-secrets-search) + (:create-function . auth-source-secrets-create))))) + +(defun auth-source--test-netrc-parse-entry (entry host user port) + "Parse a netrc entry from buffer." + (auth-source-forget-all-cached) + (setq port (auth-source-ensure-strings port)) + (with-temp-buffer + (insert entry) + (goto-char (point-min)) + (let* ((check (lambda(alist) + (and alist + (auth-source-search-collection + host + (or + (auth-source--aget alist "machine") + (auth-source--aget alist "host") + t)) + (auth-source-search-collection + user + (or + (auth-source--aget alist "login") + (auth-source--aget alist "account") + (auth-source--aget alist "user") + t)) + (auth-source-search-collection + port + (or + (auth-source--aget alist "port") + (auth-source--aget alist "protocol") + t))))) + (entries (auth-source-netrc-parse-entries check 1))) + entries))) + +(ert-deftest auth-source-test-netrc-parse-entry () + (should (equal (auth-source--test-netrc-parse-entry + "machine mymachine1 login user1 password pass1\n" t t t) + '((("password" . "pass1") + ("login" . "user1") + ("machine" . "mymachine1"))))) + (should (equal (auth-source--test-netrc-parse-entry + "machine mymachine1 login user1 password pass1 port 100\n" + t t t) + '((("port" . "100") + ("password" . "pass1") + ("login" . "user1") + ("machine" . "mymachine1")))))) + +(provide 'auth-source-tests) +;;; auth-source-tests.el ends here diff --git a/test/lisp/gnus/gnus-tests.el b/test/lisp/gnus/gnus-tests.el new file mode 100644 index 00000000000..6801ce69a3e --- /dev/null +++ b/test/lisp/gnus/gnus-tests.el @@ -0,0 +1,35 @@ +;;; gnus-tests.el --- Wrapper for the Gnus tests + +;; Copyright (C) 2011-2016 Free Software Foundation, Inc. + +;; Author: Teodor Zlatanov <tzz@lifelogs.com> + +;; 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: + +;; This file should contain nothing but requires for all the Gnus +;; tests that are not standalone. + +;;; Code: +;; registry.el is required by gnus-registry.el but this way we're explicit. +(eval-when-compile (require 'cl)) + +(require 'registry) +(require 'gnus-registry) + +(provide 'gnus-tests) +;;; gnus-tests.el ends here diff --git a/test/lisp/gnus/message-tests.el b/test/lisp/gnus/message-tests.el new file mode 100644 index 00000000000..3afa1569f64 --- /dev/null +++ b/test/lisp/gnus/message-tests.el @@ -0,0 +1,60 @@ +;;; message-mode-tests.el --- Tests for message-mode -*- lexical-binding: t; -*- + +;; Copyright (C) 2015-2016 Free Software Foundation, Inc. + +;; Author: João Távora <joaotavora@gmail.com> + +;; 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: + +;; This file contains tests for message-mode. + +;;; Code: + +(require 'message) +(require 'ert) +(require 'ert-x) + +(ert-deftest message-mode-propertize () + (with-temp-buffer + (unwind-protect + (let (message-auto-save-directory) + (message-mode) + (insert "here's an opener (\n" + "here's a sad face :-(\n" + "> here's citing someone with an opener (\n" + "and here's a closer ") + (let ((last-command-event ?\))) + (ert-simulate-command '(self-insert-command 1))) + ;; Auto syntax propertization doesn't kick in until + ;; parse-sexp-lookup-properties is set. + (setq-local parse-sexp-lookup-properties t) + (backward-sexp) + (should (string= "here's an opener " + (buffer-substring-no-properties + (line-beginning-position) + (point)))) + (forward-sexp) + (should (string= "and here's a closer )" + (buffer-substring-no-properties + (line-beginning-position) + (point))))) + (set-buffer-modified-p nil)))) + +(provide 'message-mode-tests) + +;;; message-mode-tests.el ends here diff --git a/test/lisp/help-fns-tests.el b/test/lisp/help-fns-tests.el new file mode 100644 index 00000000000..babba1a68fc --- /dev/null +++ b/test/lisp/help-fns-tests.el @@ -0,0 +1,70 @@ +;;; help-fns.el --- tests for help-fns.el + +;; Copyright (C) 2014-2016 Free Software Foundation, Inc. + +;; Maintainer: emacs-devel@gnu.org + +;; 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: + +;;; Code: + +(require 'ert) + +(autoload 'help-fns-test--macro "help-fns" nil nil t) + +(ert-deftest help-fns-test-bug17410 () + "Test for http://debbugs.gnu.org/17410 ." + (describe-function 'help-fns-test--macro) + (with-current-buffer "*Help*" + (goto-char (point-min)) + (should (search-forward "autoloaded Lisp macro" (line-end-position))))) + +(defun abc\\\[universal-argument\]b\`c\'d\\e\"f (x) + "A function with a funny name. + +\(fn XYZZY)" + x) + +(defun defgh\\\[universal-argument\]b\`c\'d\\e\"f (x) + "Another function with a funny name." + x) + +(ert-deftest help-fns-test-funny-names () + "Test for help with functions with funny names." + (describe-function 'abc\\\[universal-argument\]b\`c\'d\\e\"f) + (with-current-buffer "*Help*" + (goto-char (point-min)) + (should (search-forward + "(abc\\\\\\[universal-argument\\]b\\`c\\'d\\\\e\\\"f XYZZY)"))) + (describe-function 'defgh\\\[universal-argument\]b\`c\'d\\e\"f) + (with-current-buffer "*Help*" + (goto-char (point-min)) + (should (search-forward + "(defgh\\\\\\[universal-argument\\]b\\`c\\'d\\\\e\\\"f X)")))) + +(ert-deftest help-fns-test-describe-symbol () + "Test the `describe-symbol' function." + ;; 'describe-symbol' would originally signal an error for + ;; 'font-lock-comment-face'. + (describe-symbol 'font-lock-comment-face) + (with-current-buffer "*Help*" + (should (> (point-max) 1)) + (goto-char (point-min)) + (should (looking-at "^font-lock-comment-face is ")))) + +;;; help-fns.el ends here diff --git a/test/lisp/htmlfontify-tests.el b/test/lisp/htmlfontify-tests.el new file mode 100644 index 00000000000..a5a92fa8fac --- /dev/null +++ b/test/lisp/htmlfontify-tests.el @@ -0,0 +1,34 @@ +;;; htmlfontify-tests.el --- Test suite. -*- lexical-binding: t -*- + +;; Copyright (C) 2015 Free Software Foundation, Inc. + +;; 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/>. + +;;; Code: +(require 'ert) +(require 'htmlfontify) + +(ert-deftest htmlfontify-autoload () + "Tests to see whether reftex-auc has been autoloaded" + (should + (fboundp 'htmlfontify-load-rgb-file)) + (should + (autoloadp + (symbol-function + 'htmlfontify-load-rgb-file)))) + +(provide 'htmlfontify-tests) +;; htmlfontify-tests.el ends here diff --git a/test/lisp/ibuffer-tests.el b/test/lisp/ibuffer-tests.el new file mode 100644 index 00000000000..c813e717c9f --- /dev/null +++ b/test/lisp/ibuffer-tests.el @@ -0,0 +1,34 @@ +;;; ibuffer-tests.el --- Test suite. -*- lexical-binding: t -*- + +;; Copyright (C) 2015 Free Software Foundation, Inc. + +;; 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/>. + +;;; Code: +(require 'ert) +(require 'ibuffer) + +(ert-deftest ibuffer-autoload () + "Tests to see whether reftex-auc has been autoloaded" + (should + (fboundp 'ibuffer-mark-unsaved-buffers)) + (should + (autoloadp + (symbol-function + 'ibuffer-mark-unsaved-buffers)))) + +(provide 'ibuffer-tests) +;; ibuffer-tests.el ends here diff --git a/test/lisp/imenu-tests.el b/test/lisp/imenu-tests.el new file mode 100644 index 00000000000..b6e0f604d0e --- /dev/null +++ b/test/lisp/imenu-tests.el @@ -0,0 +1,88 @@ +;;; imenu-tests.el --- Test suite for imenu. + +;; Copyright (C) 2013-2016 Free Software Foundation, Inc. + +;; Author: Masatake YAMATO <yamato@redhat.com> +;; Keywords: tools convenience + +;; 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/>. + +;;; Code: + +(require 'ert) +(require 'imenu) + +;; (imenu-simple-scan-deftest-gather-strings-from-list +;; '(nil t 'a (0 . "x") ("c" . "d") ("a" 0 "b") )) +;; => ("b" "a" "d" "c" "x") +(defun imenu-simple-scan-deftest-gather-strings-from-list(input) + "Gather strings from INPUT, a list." + (let ((result ())) + (while input + (cond + ((stringp input) + (setq result (cons input result) + input nil)) + ((atom input) + (setq input nil)) + ((listp (car input)) + (setq result (append + (imenu-simple-scan-deftest-gather-strings-from-list (car input)) + result) + input (cdr input))) + ((stringp (car input)) + (setq result (cons (car input) result) + input (cdr input))) + (t + (setq input (cdr input))))) + result)) + +(defmacro imenu-simple-scan-deftest (name doc major-mode content expected-items) + "Generate an ert test for mode-own imenu expression. +Run `imenu-create-index-function' at the buffer which content is +CONTENT with MAJOR-MODE. A generated test runs `imenu-create-index-function' +at the buffer which content is CONTENT with MAJOR-MODE. Then it compares a list +of strings which are picked up from the result with EXPECTED-ITEMS." + (let ((xname (intern (concat "imenu-simple-scan-deftest-" (symbol-name name))))) + `(ert-deftest ,xname () + ,doc + (with-temp-buffer + (insert ,content) + (funcall ',major-mode) + (let ((result-items (sort (imenu-simple-scan-deftest-gather-strings-from-list + (funcall imenu-create-index-function)) + #'string-lessp)) + (expected-items (sort (copy-sequence ,expected-items) #'string-lessp))) + (should (equal result-items expected-items)) + ))))) + +(imenu-simple-scan-deftest sh "Test imenu expression for sh-mode." sh-mode "a() +{ +} +function b +{ +} +function c() +{ +} +function ABC_D() +{ +} +" '("a" "b" "c" "ABC_D")) + +(provide 'imenu-tests) + +;;; imenu-tests.el ends here diff --git a/test/lisp/info-xref-tests.el b/test/lisp/info-xref-tests.el new file mode 100644 index 00000000000..bc3115042bc --- /dev/null +++ b/test/lisp/info-xref-tests.el @@ -0,0 +1,147 @@ +;;; info-xref.el --- tests for info-xref.el + +;; Copyright (C) 2013-2016 Free Software Foundation, Inc. + +;; 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: + +;;; Code: + +(require 'ert) +(require 'info-xref) + +(defun info-xref-test-internal (body result) + "Body of a basic info-xref ert test. +BODY is a string from an info buffer. +RESULT is a list (NBAD NGOOD NUNAVAIL)." + (get-buffer-create info-xref-output-buffer) + (setq info-xref-xfile-alist nil) + (require 'info) + (let ((Info-directory-list '(".")) + Info-additional-directory-list) + (info-xref-with-output + (with-temp-buffer + (insert body) + (info-xref-check-buffer)))) + (should (equal result (list info-xref-bad info-xref-good info-xref-unavail))) + ;; If there was an error, we can leave this around. + (kill-buffer info-xref-output-buffer)) + +(ert-deftest info-xref-test-node-crossref () + "Test parsing of @xref{node,crossref,,manual} with Texinfo 4/5." + (info-xref-test-internal " +*Note crossref: (manual-foo)node. Texinfo 4/5 format with crossref. +" '(0 0 1))) + +(ert-deftest info-xref-test-node-4 () + "Test parsing of @xref{node,,,manual} with Texinfo 4." + (info-xref-test-internal " +*Note node: (manual-foo)node. Texinfo 4 format with no crossref. +" '(0 0 1))) + +(ert-deftest info-xref-test-node-5 () + "Test parsing of @xref{node,,,manual} with Texinfo 5." + (info-xref-test-internal " +*Note (manual-foo)node::. Texinfo 5 format with no crossref. +" '(0 0 1))) + +;; TODO Easier to have static data files in the repo? +(defun info-xref-test-write-file (file body) + "Write BODY to texi FILE." + (with-temp-buffer + (insert "\ +\\input texinfo +@setfilename " + (format "%s.info\n" (file-name-sans-extension file)) + "\ +@settitle test + +@ifnottex +@node Top +@top test +@end ifnottex + +@menu +* Chapter One:: +@end menu + +@node Chapter One +@chapter Chapter One + +text. + +" + body + "\ +@bye +" + ) + (write-region nil nil file nil 'silent)) + (should (equal 0 (call-process "makeinfo" file)))) + +(ert-deftest info-xref-test-makeinfo () + "Test that info-xref can parse basic makeinfo output." + (skip-unless (executable-find "makeinfo")) + (let ((tempfile (make-temp-file "info-xref-test" nil ".texi")) + (tempfile2 (make-temp-file "info-xref-test2" nil ".texi")) + (errflag t)) + (unwind-protect + (progn + ;; tempfile contains xrefs to various things, including tempfile2. + (info-xref-test-write-file + tempfile + (concat "\ +@xref{nodename,,,missing,Missing Manual}. + +@xref{nodename,crossref,title,missing,Missing Manual}. + +@xref{Chapter One}. + +@xref{Chapter One,Something}. + +" + (format "@xref{Chapter One,,,%s,Present Manual}.\n" + (file-name-sans-extension (file-name-nondirectory + tempfile2))))) + ;; Something for tempfile to xref to. + (info-xref-test-write-file tempfile2 "") + (require 'info) + (save-window-excursion + (let ((Info-directory-list + (list + (or (file-name-directory tempfile) "."))) + Info-additional-directory-list) + (info-xref-check (format "%s.info" (file-name-sans-extension + tempfile)))) + (should (equal (list info-xref-bad info-xref-good + info-xref-unavail) + '(0 1 2))) + (setq errflag nil) + ;; If there was an error, we can leave this around. + (kill-buffer info-xref-output-buffer))) + ;; Useful diagnostic in case of problems. + (if errflag + (with-temp-buffer + (call-process "makeinfo" nil t nil "--version") + (message "%s" (buffer-string)))) + (mapc 'delete-file (list tempfile tempfile2 + (format "%s.info" (file-name-sans-extension + tempfile)) + (format "%s.info" (file-name-sans-extension + tempfile2))))))) + +;;; info-xref.el ends here diff --git a/test/lisp/international/mule-util-tests.el b/test/lisp/international/mule-util-tests.el new file mode 100644 index 00000000000..9846aa13295 --- /dev/null +++ b/test/lisp/international/mule-util-tests.el @@ -0,0 +1,84 @@ +;;; mule-util --- tests for international/mule-util.el + +;; Copyright (C) 2002-2016 Free Software Foundation, Inc. + +;; 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: + +;;; Code: + +(require 'ert) +(require 'mule-util) + +(defconst mule-util-test-truncate-data + '((("" 0) . "") + (("x" 1) . "x") + (("xy" 1) . "x") + (("xy" 2 1) . "y") + (("xy" 0) . "") + (("xy" 3) . "xy") + (("中" 0) . "") + (("中" 1) . "") + (("中" 2) . "中") + (("中" 1 nil ? ) . " ") + (("中文" 3 1 ? ) . " ") + (("x中x" 2) . "x") + (("x中x" 3) . "x中") + (("x中x" 3) . "x中") + (("x中x" 4 1) . "中x") + (("kor한e글an" 8 1 ? ) . "or한e글") + (("kor한e글an" 7 2 ? ) . "r한e ") + (("" 0 nil nil "...") . "") + (("x" 3 nil nil "...") . "x") + (("中" 3 nil nil "...") . "中") + (("foo" 3 nil nil "...") . "foo") + (("foo" 2 nil nil "...") . "fo") ;; XEmacs failure? + (("foobar" 6 0 nil "...") . "foobar") + (("foobarbaz" 6 nil nil "...") . "foo...") + (("foobarbaz" 7 2 nil "...") . "ob...") + (("foobarbaz" 9 3 nil "...") . "barbaz") + (("こhんeにlちlはo" 15 1 ? t) . " hんeにlちlはo") + (("こhんeにlちlはo" 14 1 ? t) . " hんeにlち...") + (("x" 3 nil nil "粵語") . "x") + (("中" 2 nil nil "粵語") . "中") + (("中" 1 nil ?x "粵語") . "x") ;; XEmacs error + (("中文" 3 nil ? "粵語") . "中 ") ;; XEmacs error + (("foobarbaz" 4 nil nil "粵語") . "粵語") + (("foobarbaz" 5 nil nil "粵語") . "f粵語") + (("foobarbaz" 6 nil nil "粵語") . "fo粵語") + (("foobarbaz" 8 3 nil "粵語") . "b粵語") + (("こhんeにlちlはo" 14 4 ?x "日本語") . "xeに日本語") + (("こhんeにlちlはo" 13 4 ?x "日本語") . "xex日本語") + ) + "Test data for `truncate-string-to-width'.") + +(defun mule-util-test-truncate-create (n) + "Create a test for element N of the `mule-util-test-truncate-data' constant." + (let ((testname (intern (format "mule-util-test-truncate-%.2d" n))) + (testdoc (format "Test element %d of `mule-util-test-truncate-data'." + n)) + (testdata (nth n mule-util-test-truncate-data))) + (eval + `(ert-deftest ,testname () + ,testdoc + (should (equal (apply 'truncate-string-to-width ',(car testdata)) + ,(cdr testdata))))))) + +(dotimes (i (length mule-util-test-truncate-data)) + (mule-util-test-truncate-create i)) + +;;; mule-util.el ends here diff --git a/test/lisp/isearch-tests.el b/test/lisp/isearch-tests.el new file mode 100644 index 00000000000..48c342403c9 --- /dev/null +++ b/test/lisp/isearch-tests.el @@ -0,0 +1,32 @@ +;;; isearch-tests.el --- Tests for isearch.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) + +(ert-deftest isearch--test-update () + (with-temp-buffer + (setq isearch--current-buffer (current-buffer))) + (with-temp-buffer + (isearch-update) + (should (equal isearch--current-buffer (current-buffer))))) + +(provide 'isearch-tests) +;;; isearch-tests.el ends here diff --git a/test/lisp/json-tests.el b/test/lisp/json-tests.el new file mode 100644 index 00000000000..78cebb45eed --- /dev/null +++ b/test/lisp/json-tests.el @@ -0,0 +1,320 @@ +;;; json-tests.el --- Test suite for json.el + +;; Copyright (C) 2015-2016 Free Software Foundation, Inc. + +;; Author: Dmitry Gutov <dgutov@yandex.ru> + +;; 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 'json) + +(defmacro json-tests--with-temp-buffer (content &rest body) + "Create a temporary buffer with CONTENT and evaluate BODY there. +Point is moved to beginning of the buffer." + (declare (indent 1)) + `(with-temp-buffer + (insert ,content) + (goto-char (point-min)) + ,@body)) + +;;; Utilities + +(ert-deftest test-json-join () + (should (equal (json-join '() ", ") "")) + (should (equal (json-join '("a" "b" "c") ", ") "a, b, c"))) + +(ert-deftest test-json-alist-p () + (should (json-alist-p '())) + (should (json-alist-p '((a 1) (b 2) (c 3)))) + (should (json-alist-p '((:a 1) (:b 2) (:c 3)))) + (should (json-alist-p '(("a" 1) ("b" 2) ("c" 3)))) + (should-not (json-alist-p '(:a :b :c))) + (should-not (json-alist-p '(:a 1 :b 2 :c 3))) + (should-not (json-alist-p '((:a 1) (:b 2) 3)))) + +(ert-deftest test-json-plist-p () + (should (json-plist-p '())) + (should (json-plist-p '(:a 1 :b 2 :c 3))) + (should-not (json-plist-p '(a 1 b 2 c 3))) + (should-not (json-plist-p '("a" 1 "b" 2 "c" 3))) + (should-not (json-plist-p '(:a :b :c))) + (should-not (json-plist-p '((:a 1) (:b 2) (:c 3))))) + +(ert-deftest test-json-plist-reverse () + (should (equal (json--plist-reverse '()) '())) + (should (equal (json--plist-reverse '(:a 1)) '(:a 1))) + (should (equal (json--plist-reverse '(:a 1 :b 2 :c 3)) + '(:c 3 :b 2 :a 1)))) + +(ert-deftest test-json-plist-to-alist () + (should (equal (json--plist-to-alist '()) '())) + (should (equal (json--plist-to-alist '(:a 1)) '((:a . 1)))) + (should (equal (json--plist-to-alist '(:a 1 :b 2 :c 3)) + '((:a . 1) (:b . 2) (:c . 3))))) + +(ert-deftest test-json-advance () + (json-tests--with-temp-buffer "{ \"a\": 1 }" + (json-advance 0) + (should (= (point) (point-min))) + (json-advance 3) + (should (= (point) (+ (point-min) 3))))) + +(ert-deftest test-json-peek () + (json-tests--with-temp-buffer "" + (should (eq (json-peek) :json-eof))) + (json-tests--with-temp-buffer "{ \"a\": 1 }" + (should (equal (json-peek) ?{)))) + +(ert-deftest test-json-pop () + (json-tests--with-temp-buffer "" + (should-error (json-pop) :type 'json-end-of-file)) + (json-tests--with-temp-buffer "{ \"a\": 1 }" + (should (equal (json-pop) ?{)) + (should (= (point) (+ (point-min) 1))))) + +(ert-deftest test-json-skip-whitespace () + (json-tests--with-temp-buffer "\t\r\n\f\b { \"a\": 1 }" + (json-skip-whitespace) + (should (equal (char-after (point)) ?{)))) + +;;; Paths + +(ert-deftest test-json-path-to-position-with-objects () + (let* ((json-string "{\"foo\": {\"bar\": {\"baz\": \"value\"}}}") + (matched-path (json-path-to-position 32 json-string))) + (should (equal (plist-get matched-path :path) '("foo" "bar" "baz"))) + (should (equal (plist-get matched-path :match-start) 25)) + (should (equal (plist-get matched-path :match-end) 32)))) + +(ert-deftest test-json-path-to-position-with-arrays () + (let* ((json-string "{\"foo\": [\"bar\", [\"baz\"]]}") + (matched-path (json-path-to-position 20 json-string))) + (should (equal (plist-get matched-path :path) '("foo" 1 0))) + (should (equal (plist-get matched-path :match-start) 18)) + (should (equal (plist-get matched-path :match-end) 23)))) + +(ert-deftest test-json-path-to-position-no-match () + (let* ((json-string "{\"foo\": {\"bar\": \"baz\"}}") + (matched-path (json-path-to-position 5 json-string))) + (should (null matched-path)))) + +;;; Keywords + +(ert-deftest test-json-read-keyword () + (json-tests--with-temp-buffer "true" + (should (json-read-keyword "true"))) + (json-tests--with-temp-buffer "true" + (should-error + (json-read-keyword "false") :type 'json-unknown-keyword)) + (json-tests--with-temp-buffer "foo" + (should-error + (json-read-keyword "foo") :type 'json-unknown-keyword))) + +(ert-deftest test-json-encode-keyword () + (should (equal (json-encode-keyword t) "true")) + (should (equal (json-encode-keyword json-false) "false")) + (should (equal (json-encode-keyword json-null) "null"))) + +;;; Numbers + +(ert-deftest test-json-read-number () + (json-tests--with-temp-buffer "3" + (should (= (json-read-number) 3))) + (json-tests--with-temp-buffer "-5" + (should (= (json-read-number) -5))) + (json-tests--with-temp-buffer "123.456" + (should (= (json-read-number) 123.456))) + (json-tests--with-temp-buffer "1e3" + (should (= (json-read-number) 1e3))) + (json-tests--with-temp-buffer "2e+3" + (should (= (json-read-number) 2e3))) + (json-tests--with-temp-buffer "3E3" + (should (= (json-read-number) 3e3))) + (json-tests--with-temp-buffer "1e-7" + (should (= (json-read-number) 1e-7))) + (json-tests--with-temp-buffer "abc" + (should-error (json-read-number) :type 'json-number-format))) + +(ert-deftest test-json-encode-number () + (should (equal (json-encode-number 3) "3")) + (should (equal (json-encode-number -5) "-5")) + (should (equal (json-encode-number 123.456) "123.456"))) + +;; Strings + +(ert-deftest test-json-read-escaped-char () + (json-tests--with-temp-buffer "\\\"" + (should (equal (json-read-escaped-char) ?\")))) + +(ert-deftest test-json-read-string () + (json-tests--with-temp-buffer "\"foo \\\"bar\\\"\"" + (should (equal (json-read-string) "foo \"bar\""))) + (json-tests--with-temp-buffer "\"abcαβγ\"" + (should (equal (json-read-string) "abcαβγ"))) + (json-tests--with-temp-buffer "\"\\nasd\\u0444\\u044b\\u0432fgh\\t\"" + (should (equal (json-read-string) "\nasdфывfgh\t"))) + (json-tests--with-temp-buffer "foo" + (should-error (json-read-string) :type 'json-string-format))) + +(ert-deftest test-json-encode-string () + (should (equal (json-encode-string "foo") "\"foo\"")) + (should (equal (json-encode-string "a\n\fb") "\"a\\n\\fb\"")) + (should (equal (json-encode-string "\nasdфыв\u001f\u007ffgh\t") + "\"\\nasdфыв\\u001f\u007ffgh\\t\""))) + +(ert-deftest test-json-encode-key () + (should (equal (json-encode-key "foo") "\"foo\"")) + (should (equal (json-encode-key 'foo) "\"foo\"")) + (should (equal (json-encode-key :foo) "\"foo\"")) + (should-error (json-encode-key 5) :type 'json-key-format) + (should-error (json-encode-key ["foo"]) :type 'json-key-format) + (should-error (json-encode-key '("foo")) :type 'json-key-format)) + +;;; Objects + +(ert-deftest test-json-new-object () + (let ((json-object-type 'alist)) + (should (equal (json-new-object) '()))) + (let ((json-object-type 'plist)) + (should (equal (json-new-object) '()))) + (let* ((json-object-type 'hash-table) + (json-object (json-new-object))) + (should (hash-table-p json-object)) + (should (= (hash-table-count json-object) 0)))) + +(ert-deftest test-json-add-to-object () + (let* ((json-object-type 'alist) + (json-key-type nil) + (obj (json-new-object))) + (setq obj (json-add-to-object obj "a" 1)) + (setq obj (json-add-to-object obj "b" 2)) + (should (equal (assq 'a obj) '(a . 1))) + (should (equal (assq 'b obj) '(b . 2)))) + (let* ((json-object-type 'plist) + (json-key-type nil) + (obj (json-new-object))) + (setq obj (json-add-to-object obj "a" 1)) + (setq obj (json-add-to-object obj "b" 2)) + (should (= (plist-get obj :a) 1)) + (should (= (plist-get obj :b) 2))) + (let* ((json-object-type 'hash-table) + (json-key-type nil) + (obj (json-new-object))) + (setq obj (json-add-to-object obj "a" 1)) + (setq obj (json-add-to-object obj "b" 2)) + (should (= (gethash "a" obj) 1)) + (should (= (gethash "b" obj) 2)))) + +(ert-deftest test-json-read-object () + (json-tests--with-temp-buffer "{ \"a\": 1, \"b\": 2 }" + (let ((json-object-type 'alist)) + (should (equal (json-read-object) '((a . 1) (b . 2)))))) + (json-tests--with-temp-buffer "{ \"a\": 1, \"b\": 2 }" + (let ((json-object-type 'plist)) + (should (equal (json-read-object) '(:a 1 :b 2))))) + (json-tests--with-temp-buffer "{ \"a\": 1, \"b\": 2 }" + (let* ((json-object-type 'hash-table) + (hash-table (json-read-object))) + (should (= (gethash "a" hash-table) 1)) + (should (= (gethash "b" hash-table) 2)))) + (json-tests--with-temp-buffer "{ \"a\": 1 \"b\": 2 }" + (should-error (json-read-object) :type 'json-object-format))) + +(ert-deftest test-json-encode-hash-table () + (let ((hash-table (make-hash-table)) + (json-encoding-object-sort-predicate 'string<) + (json-encoding-pretty-print nil)) + (puthash :a 1 hash-table) + (puthash :b 2 hash-table) + (puthash :c 3 hash-table) + (should (equal (json-encode hash-table) + "{\"a\":1,\"b\":2,\"c\":3}")))) + +(ert-deftest json-encode-simple-alist () + (let ((json-encoding-pretty-print nil)) + (should (equal (json-encode '((a . 1) (b . 2))) + "{\"a\":1,\"b\":2}")))) + +(ert-deftest test-json-encode-plist () + (let ((plist '(:a 1 :b 2)) + (json-encoding-pretty-print nil)) + (should (equal (json-encode plist) "{\"a\":1,\"b\":2}")))) + +(ert-deftest test-json-encode-plist-with-sort-predicate () + (let ((plist '(:c 3 :a 1 :b 2)) + (json-encoding-object-sort-predicate 'string<) + (json-encoding-pretty-print nil)) + (should (equal (json-encode plist) "{\"a\":1,\"b\":2,\"c\":3}")))) + +(ert-deftest test-json-encode-alist-with-sort-predicate () + (let ((alist '((:c . 3) (:a . 1) (:b . 2))) + (json-encoding-object-sort-predicate 'string<) + (json-encoding-pretty-print nil)) + (should (equal (json-encode alist) "{\"a\":1,\"b\":2,\"c\":3}")))) + +(ert-deftest test-json-encode-list () + (let ((json-encoding-pretty-print nil)) + (should (equal (json-encode-list '(:a 1 :b 2)) + "{\"a\":1,\"b\":2}")) + (should (equal (json-encode-list '((:a . 1) (:b . 2))) + "{\"a\":1,\"b\":2}")) + (should (equal (json-encode-list '(1 2 3 4)) "[1,2,3,4]")))) + +;;; Arrays + +(ert-deftest test-json-read-array () + (let ((json-array-type 'vector)) + (json-tests--with-temp-buffer "[1, 2, \"a\", \"b\"]" + (should (equal (json-read-array) [1 2 "a" "b"])))) + (let ((json-array-type 'list)) + (json-tests--with-temp-buffer "[1, 2, \"a\", \"b\"]" + (should (equal (json-read-array) '(1 2 "a" "b"))))) + (json-tests--with-temp-buffer "[1 2]" + (should-error (json-read-array) :type 'json-error))) + +(ert-deftest test-json-encode-array () + (let ((json-encoding-pretty-print nil)) + (should (equal (json-encode-array [1 2 "a" "b"]) + "[1,2,\"a\",\"b\"]")))) + +;;; Reader + +(ert-deftest test-json-read () + (json-tests--with-temp-buffer "{ \"a\": 1 }" + ;; We don't care exactly what the return value is (that is tested + ;; in `test-json-read-object'), but it should parse without error. + (should (json-read))) + (json-tests--with-temp-buffer "" + (should-error (json-read) :type 'json-end-of-file)) + (json-tests--with-temp-buffer "xxx" + (should-error (json-read) :type 'json-readtable-error))) + +(ert-deftest test-json-read-from-string () + (let ((json-string "{ \"a\": 1 }")) + (json-tests--with-temp-buffer json-string + (should (equal (json-read-from-string json-string) + (json-read)))))) + +;;; JSON encoder + +(ert-deftest test-json-encode () + (should (equal (json-encode "foo") "\"foo\"")) + (with-temp-buffer + (should-error (json-encode (current-buffer)) :type 'json-error))) + +(provide 'json-tests) +;;; json-tests.el ends here diff --git a/test/lisp/legacy/bytecomp-tests.el b/test/lisp/legacy/bytecomp-tests.el new file mode 100644 index 00000000000..48211f03ba4 --- /dev/null +++ b/test/lisp/legacy/bytecomp-tests.el @@ -0,0 +1,429 @@ +;;; bytecomp-testsuite.el + +;; Copyright (C) 2008-2016 Free Software Foundation, Inc. + +;; Author: Shigeru Fukaya <shigeru.fukaya@gmail.com> +;; Created: November 2008 +;; Keywords: internal +;; Human-Keywords: internal + +;; 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: + +(require 'ert) + +;;; Code: +(defconst byte-opt-testsuite-arith-data + '( + ;; some functional tests + (let ((a most-positive-fixnum) (b 1) (c 1.0)) (+ a b c)) + (let ((a most-positive-fixnum) (b -2) (c 1.0)) (- a b c)) + (let ((a most-positive-fixnum) (b 2) (c 1.0)) (* a b c)) + (let ((a 3) (b 2) (c 1.0)) (/ a b c)) + (let ((a (+ 1 (expt 2 -64))) (b (expt 2 -65))) (+ a -1 b)) + (let ((a (+ 1 (expt 2 -64))) (b (expt 2 -65))) (- a 1 (- b))) + ;; This fails. Should it be a bug? + ;; (let ((a (expt 2 -1074)) (b 0.125)) (* a 8 b)) + (let ((a 1.0)) (* a 0)) + (let ((a 1.0)) (* a 2.0 0)) + (let ((a 1.0)) (/ 0 a)) + (let ((a 1.0)) (/ 3 a 2)) + (let ((a most-positive-fixnum) (b 2.0)) (* a 2 b)) + (let ((a 3) (b 2)) (/ a b 1.0)) + (/ 3 -1) + (+ 4 3 2 1) + (+ 4 3 2.0 1) + (- 4 3 2 1) ; not new, for reference + (- 4 3 2.0 1) ; not new, for reference + (* 4 3 2 1) + (* 4 3 2.0 1) + (/ 4 3 2 1) + (/ 4 3 2.0 1) + (let ((a 3) (b 2)) (+ a b 1)) + (let ((a 3) (b 2)) (+ a b -1)) + (let ((a 3) (b 2)) (- a b 1)) + (let ((a 3) (b 2)) (- a b -1)) + (let ((a 3) (b 2)) (+ a b a 1)) + (let ((a 3) (b 2)) (+ a b a -1)) + (let ((a 3) (b 2)) (- a b a 1)) + (let ((a 3) (b 2)) (- a b a -1)) + (let ((a 3) (b 2)) (* a b -1)) + (let ((a 3) (b 2)) (* a -1)) + (let ((a 3) (b 2)) (/ a b 1)) + (let ((a 3) (b 2)) (/ (+ a b) 1)) + + ;; coverage test + (let ((a 3) (b 2) (c 1.0)) (+)) + (let ((a 3) (b 2) (c 1.0)) (+ 2)) + (let ((a 3) (b 2) (c 1.0)) (+ 2 0)) + (let ((a 3) (b 2) (c 1.0)) (+ 2 0.0)) + (let ((a 3) (b 2) (c 1.0)) (+ 2.0)) + (let ((a 3) (b 2) (c 1.0)) (+ 2.0 0)) + (let ((a 3) (b 2) (c 1.0)) (+ 2.0 0.0)) + (let ((a 3) (b 2) (c 1.0)) (+ 0 2)) + (let ((a 3) (b 2) (c 1.0)) (+ 0 2.0)) + (let ((a 3) (b 2) (c 1.0)) (+ 0.0 2)) + (let ((a 3) (b 2) (c 1.0)) (+ 0.0 2.0)) + (let ((a 3) (b 2) (c 1.0)) (+ a)) + (let ((a 3) (b 2) (c 1.0)) (+ a 0)) + (let ((a 3) (b 2) (c 1.0)) (+ a 0.0)) + (let ((a 3) (b 2) (c 1.0)) (+ 0 a)) + (let ((a 3) (b 2) (c 1.0)) (+ 0.0 a)) + (let ((a 3) (b 2) (c 1.0)) (+ c 0)) + (let ((a 3) (b 2) (c 1.0)) (+ c 0.0)) + (let ((a 3) (b 2) (c 1.0)) (+ 0 c)) + (let ((a 3) (b 2) (c 1.0)) (+ 0.0 c)) + (let ((a 3) (b 2) (c 1.0)) (+ a b 0 c 0)) + (let ((a 3) (b 2) (c 1.0)) (+ 0 a)) + (let ((a 3) (b 2) (c 1.0)) (+ 0 a b)) + (let ((a 3) (b 2) (c 1.0)) (+ 0 a b c)) + (let ((a 3) (b 2) (c 1.0)) (+ 1 2 3)) + (let ((a 3) (b 2) (c 1.0)) (+ 3.0 2.0 1)) + (let ((a 3) (b 2) (c 1.0)) (+ 3.0 2.0 1 4)) + (let ((a 3) (b 2) (c 1.0)) (+ a 1)) + (let ((a 3) (b 2) (c 1.0)) (+ a -1)) + (let ((a 3) (b 2) (c 1.0)) (+ 1 a)) + (let ((a 3) (b 2) (c 1.0)) (+ -1 a)) + (let ((a 3) (b 2) (c 1.0)) (+ c 1)) + (let ((a 3) (b 2) (c 1.0)) (+ c -1)) + (let ((a 3) (b 2) (c 1.0)) (+ 1 c)) + (let ((a 3) (b 2) (c 1.0)) (+ -1 c)) + (let ((a 3) (b 2) (c 1.0)) (+ a b 0)) + (let ((a 3) (b 2) (c 1.0)) (+ a b 1)) + (let ((a 3) (b 2) (c 1.0)) (+ a b -1)) + (let ((a 3) (b 2) (c 1.0)) (+ a b 2)) + (let ((a 3) (b 2) (c 1.0)) (+ 1 a b c)) + (let ((a 3) (b 2) (c 1.0)) (+ a b c 0)) + (let ((a 3) (b 2) (c 1.0)) (+ a b c 1)) + (let ((a 3) (b 2) (c 1.0)) (+ a b c -1)) + + (let ((a 3) (b 2) (c 1.0)) (-)) + (let ((a 3) (b 2) (c 1.0)) (- 2)) + (let ((a 3) (b 2) (c 1.0)) (- 2 0)) + (let ((a 3) (b 2) (c 1.0)) (- 2 0.0)) + (let ((a 3) (b 2) (c 1.0)) (- 2.0)) + (let ((a 3) (b 2) (c 1.0)) (- 2.0 0)) + (let ((a 3) (b 2) (c 1.0)) (- 2.0 0.0)) + (let ((a 3) (b 2) (c 1.0)) (- 0 2)) + (let ((a 3) (b 2) (c 1.0)) (- 0 2.0)) + (let ((a 3) (b 2) (c 1.0)) (- 0.0 2)) + (let ((a 3) (b 2) (c 1.0)) (- 0.0 2.0)) + (let ((a 3) (b 2) (c 1.0)) (- a)) + (let ((a 3) (b 2) (c 1.0)) (- a 0)) + (let ((a 3) (b 2) (c 1.0)) (- a 0.0)) + (let ((a 3) (b 2) (c 1.0)) (- 0 a)) + (let ((a 3) (b 2) (c 1.0)) (- 0.0 a)) + (let ((a 3) (b 2) (c 1.0)) (- c 0)) + (let ((a 3) (b 2) (c 1.0)) (- c 0.0)) + (let ((a 3) (b 2) (c 1.0)) (- 0 c)) + (let ((a 3) (b 2) (c 1.0)) (- 0.0 c)) + (let ((a 3) (b 2) (c 1.0)) (- a b 0 c 0)) + (let ((a 3) (b 2) (c 1.0)) (- 0 a)) + (let ((a 3) (b 2) (c 1.0)) (- 0 a b)) + (let ((a 3) (b 2) (c 1.0)) (- 0 a b c)) + (let ((a 3) (b 2) (c 1.0)) (- 1 2 3)) + (let ((a 3) (b 2) (c 1.0)) (- 3.0 2.0 1)) + (let ((a 3) (b 2) (c 1.0)) (- 3.0 2.0 1 4)) + (let ((a 3) (b 2) (c 1.0)) (- a 1)) + (let ((a 3) (b 2) (c 1.0)) (- a -1)) + (let ((a 3) (b 2) (c 1.0)) (- 1 a)) + (let ((a 3) (b 2) (c 1.0)) (- -1 a)) + (let ((a 3) (b 2) (c 1.0)) (- c 1)) + (let ((a 3) (b 2) (c 1.0)) (- c -1)) + (let ((a 3) (b 2) (c 1.0)) (- 1 c)) + (let ((a 3) (b 2) (c 1.0)) (- -1 c)) + (let ((a 3) (b 2) (c 1.0)) (- a b 0)) + (let ((a 3) (b 2) (c 1.0)) (- a b 1)) + (let ((a 3) (b 2) (c 1.0)) (- a b -1)) + (let ((a 3) (b 2) (c 1.0)) (- a b 2)) + (let ((a 3) (b 2) (c 1.0)) (- 1 a b c)) + (let ((a 3) (b 2) (c 1.0)) (- a b c 0)) + (let ((a 3) (b 2) (c 1.0)) (- a b c 1)) + (let ((a 3) (b 2) (c 1.0)) (- a b c -1)) + + (let ((a 3) (b 2) (c 1.0)) (*)) + (let ((a 3) (b 2) (c 1.0)) (* 2)) + (let ((a 3) (b 2) (c 1.0)) (* 2 0)) + (let ((a 3) (b 2) (c 1.0)) (* 2 0.0)) + (let ((a 3) (b 2) (c 1.0)) (* 2.0)) + (let ((a 3) (b 2) (c 1.0)) (* 2.0 0)) + (let ((a 3) (b 2) (c 1.0)) (* 2.0 0.0)) + (let ((a 3) (b 2) (c 1.0)) (* 0 2)) + (let ((a 3) (b 2) (c 1.0)) (* 0 2.0)) + (let ((a 3) (b 2) (c 1.0)) (* 0.0 2)) + (let ((a 3) (b 2) (c 1.0)) (* 0.0 2.0)) + (let ((a 3) (b 2) (c 1.0)) (* a)) + (let ((a 3) (b 2) (c 1.0)) (* a 0)) + (let ((a 3) (b 2) (c 1.0)) (* a 0.0)) + (let ((a 3) (b 2) (c 1.0)) (* 0 a)) + (let ((a 3) (b 2) (c 1.0)) (* 0.0 a)) + (let ((a 3) (b 2) (c 1.0)) (* c 0)) + (let ((a 3) (b 2) (c 1.0)) (* c 0.0)) + (let ((a 3) (b 2) (c 1.0)) (* 0 c)) + (let ((a 3) (b 2) (c 1.0)) (* 0.0 c)) + (let ((a 3) (b 2) (c 1.0)) (* a b 0 c 0)) + (let ((a 3) (b 2) (c 1.0)) (* 0 a)) + (let ((a 3) (b 2) (c 1.0)) (* 0 a b)) + (let ((a 3) (b 2) (c 1.0)) (* 0 a b c)) + (let ((a 3) (b 2) (c 1.0)) (* 1 2 3)) + (let ((a 3) (b 2) (c 1.0)) (* 3.0 2.0 1)) + (let ((a 3) (b 2) (c 1.0)) (* 3.0 2.0 1 4)) + (let ((a 3) (b 2) (c 1.0)) (* a 1)) + (let ((a 3) (b 2) (c 1.0)) (* a -1)) + (let ((a 3) (b 2) (c 1.0)) (* 1 a)) + (let ((a 3) (b 2) (c 1.0)) (* -1 a)) + (let ((a 3) (b 2) (c 1.0)) (* c 1)) + (let ((a 3) (b 2) (c 1.0)) (* c -1)) + (let ((a 3) (b 2) (c 1.0)) (* 1 c)) + (let ((a 3) (b 2) (c 1.0)) (* -1 c)) + (let ((a 3) (b 2) (c 1.0)) (* a b 0)) + (let ((a 3) (b 2) (c 1.0)) (* a b 1)) + (let ((a 3) (b 2) (c 1.0)) (* a b -1)) + (let ((a 3) (b 2) (c 1.0)) (* a b 2)) + (let ((a 3) (b 2) (c 1.0)) (* 1 a b c)) + (let ((a 3) (b 2) (c 1.0)) (* a b c 0)) + (let ((a 3) (b 2) (c 1.0)) (* a b c 1)) + (let ((a 3) (b 2) (c 1.0)) (* a b c -1)) + + (let ((a 3) (b 2) (c 1.0)) (/)) + (let ((a 3) (b 2) (c 1.0)) (/ 2)) + (let ((a 3) (b 2) (c 1.0)) (/ 2 0)) + (let ((a 3) (b 2) (c 1.0)) (/ 2 0.0)) + (let ((a 3) (b 2) (c 1.0)) (/ 2.0)) + (let ((a 3) (b 2) (c 1.0)) (/ 2.0 0)) + (let ((a 3) (b 2) (c 1.0)) (/ 2.0 0.0)) + (let ((a 3) (b 2) (c 1.0)) (/ 0 2)) + (let ((a 3) (b 2) (c 1.0)) (/ 0 2.0)) + (let ((a 3) (b 2) (c 1.0)) (/ 0.0 2)) + (let ((a 3) (b 2) (c 1.0)) (/ 0.0 2.0)) + (let ((a 3) (b 2) (c 1.0)) (/ a)) + (let ((a 3) (b 2) (c 1.0)) (/ a 0)) + (let ((a 3) (b 2) (c 1.0)) (/ a 0.0)) + (let ((a 3) (b 2) (c 1.0)) (/ 0 a)) + (let ((a 3) (b 2) (c 1.0)) (/ 0.0 a)) + (let ((a 3) (b 2) (c 1.0)) (/ c 0)) + (let ((a 3) (b 2) (c 1.0)) (/ c 0.0)) + (let ((a 3) (b 2) (c 1.0)) (/ 0 c)) + (let ((a 3) (b 2) (c 1.0)) (/ 0.0 c)) + (let ((a 3) (b 2) (c 1.0)) (/ a b 0 c 0)) + (let ((a 3) (b 2) (c 1.0)) (/ 0 a)) + (let ((a 3) (b 2) (c 1.0)) (/ 0 a b)) + (let ((a 3) (b 2) (c 1.0)) (/ 0 a b c)) + (let ((a 3) (b 2) (c 1.0)) (/ 1 2 3)) + (let ((a 3) (b 2) (c 1.0)) (/ 3.0 2.0 1)) + (let ((a 3) (b 2) (c 1.0)) (/ 3.0 2.0 1 4)) + (let ((a 3) (b 2) (c 1.0)) (/ a 1)) + (let ((a 3) (b 2) (c 1.0)) (/ a -1)) + (let ((a 3) (b 2) (c 1.0)) (/ 1 a)) + (let ((a 3) (b 2) (c 1.0)) (/ -1 a)) + (let ((a 3) (b 2) (c 1.0)) (/ c 1)) + (let ((a 3) (b 2) (c 1.0)) (/ c -1)) + (let ((a 3) (b 2) (c 1.0)) (/ 1 c)) + (let ((a 3) (b 2) (c 1.0)) (/ -1 c)) + (let ((a 3) (b 2) (c 1.0)) (/ a b 0)) + (let ((a 3) (b 2) (c 1.0)) (/ a b 1)) + (let ((a 3) (b 2) (c 1.0)) (/ a b -1)) + (let ((a 3) (b 2) (c 1.0)) (/ a b 2)) + (let ((a 3) (b 2) (c 1.0)) (/ 1 a b c)) + (let ((a 3) (b 2) (c 1.0)) (/ a b c 0)) + (let ((a 3) (b 2) (c 1.0)) (/ a b c 1)) + (let ((a 3) (b 2) (c 1.0)) (/ a b c -1))) + "List of expression for test. +Each element will be executed by interpreter and with +bytecompiled code, and their results compared.") + +(defun bytecomp-check-1 (pat) + "Return non-nil if PAT is the same whether directly evalled or compiled." + (let ((warning-minimum-log-level :emergency) + (byte-compile-warnings nil) + (v0 (condition-case nil + (eval pat) + (error nil))) + (v1 (condition-case nil + (funcall (byte-compile (list 'lambda nil pat))) + (error nil)))) + (equal v0 v1))) + +(put 'bytecomp-check-1 'ert-explainer 'bytecomp-explain-1) + +(defun bytecomp-explain-1 (pat) + (let ((v0 (condition-case nil + (eval pat) + (error nil))) + (v1 (condition-case nil + (funcall (byte-compile (list 'lambda nil pat))) + (error nil)))) + (format "Expression `%s' gives `%s' if directly evalled, `%s' if compiled." + pat v0 v1))) + +(ert-deftest bytecomp-tests () + "Test the Emacs byte compiler." + (dolist (pat byte-opt-testsuite-arith-data) + (should (bytecomp-check-1 pat)))) + +(defun test-byte-opt-arithmetic (&optional arg) + "Unit test for byte-opt arithmetic operations. +Subtests signal errors if something goes wrong." + (interactive "P") + (switch-to-buffer (generate-new-buffer "*Font Pase Test*")) + (let ((warning-minimum-log-level :emergency) + (byte-compile-warnings nil) + (pass-face '((t :foreground "green"))) + (fail-face '((t :foreground "red"))) + (print-escape-nonascii t) + (print-escape-newlines t) + (print-quoted t) + v0 v1) + (dolist (pat byte-opt-testsuite-arith-data) + (condition-case nil + (setq v0 (eval pat)) + (error (setq v0 nil))) + (condition-case nil + (setq v1 (funcall (byte-compile (list 'lambda nil pat)))) + (error (setq v1 nil))) + (insert (format "%s" pat)) + (indent-to-column 65) + (if (equal v0 v1) + (insert (propertize "OK" 'face pass-face)) + (insert (propertize "FAIL\n" 'face fail-face)) + (indent-to-column 55) + (insert (propertize (format "[%s] vs [%s]" v0 v1) + 'face fail-face))) + (insert "\n")))) + +(defun test-byte-comp-compile-and-load (compile &rest forms) + (let ((elfile nil) + (elcfile nil)) + (unwind-protect + (progn + (setf elfile (make-temp-file "test-bytecomp" nil ".el")) + (when compile + (setf elcfile (make-temp-file "test-bytecomp" nil ".elc"))) + (with-temp-buffer + (dolist (form forms) + (print form (current-buffer))) + (write-region (point-min) (point-max) elfile nil 'silent)) + (if compile + (let ((byte-compile-dest-file-function + (lambda (e) elcfile))) + (byte-compile-file elfile t)) + (load elfile nil 'nomessage))) + (when elfile (delete-file elfile)) + (when elcfile (delete-file elcfile))))) +(put 'test-byte-comp-compile-and-load 'lisp-indent-function 1) + +(ert-deftest test-byte-comp-macro-expansion () + (test-byte-comp-compile-and-load t + '(progn (defmacro abc (arg) 1) (defun def () (abc 2)))) + (should (equal (funcall 'def) 1))) + +(ert-deftest test-byte-comp-macro-expansion-eval-and-compile () + (test-byte-comp-compile-and-load t + '(eval-and-compile (defmacro abc (arg) -1) (defun def () (abc 2)))) + (should (equal (funcall 'def) -1))) + +(ert-deftest test-byte-comp-macro-expansion-eval-when-compile () + ;; Make sure we interpret eval-when-compile forms properly. CLISP + ;; and SBCL interpreter eval-when-compile (well, the CL equivalent) + ;; in the same way. + (test-byte-comp-compile-and-load t + '(eval-when-compile + (defmacro abc (arg) -10) + (defun abc-1 () (abc 2))) + '(defmacro abc-2 () (abc-1)) + '(defun def () (abc-2))) + (should (equal (funcall 'def) -10))) + +(ert-deftest test-byte-comp-macro-expand-lexical-override () + ;; Intuitively, one might expect the defmacro to override the + ;; macrolet since macrolet's is explicitly called out as being + ;; equivalent to toplevel, but CLISP and SBCL both evaluate the form + ;; this way, so we should too. + (test-byte-comp-compile-and-load t + '(require 'cl-lib) + '(cl-macrolet ((m () 4)) + (defmacro m () 5) + (defun def () (m)))) + (should (equal (funcall 'def) 4))) + +(ert-deftest bytecomp-tests--warnings () + (with-current-buffer (get-buffer-create "*Compile-Log*") + (let ((inhibit-read-only t)) (erase-buffer))) + (test-byte-comp-compile-and-load t + '(progn + (defun my-test0 () + (my--test11 3) + (my--test12 3) + (my--test2 5)) + (defmacro my--test11 (arg) (+ arg 1)) + (eval-and-compile + (defmacro my--test12 (arg) (+ arg 1)) + (defun my--test2 (arg) (+ arg 1))))) + (with-current-buffer (get-buffer-create "*Compile-Log*") + (goto-char (point-min)) + ;; Should warn that mt--test1[12] are first used as functions. + ;; The second alternative is for when the file name is so long + ;; that pretty-printing starts the message on the next line. + (should (or (re-search-forward "my--test11:\n.*macro" nil t) + (re-search-forward "my--test11:\n.*:\n.*macro" nil t))) + (should (or (re-search-forward "my--test12:\n.*macro" nil t) + (re-search-forward "my--test12:\n.*:\n.*macro" nil t))) + (goto-char (point-min)) + ;; Should not warn that mt--test2 is not known to be defined. + (should-not (re-search-forward "my--test2" nil t)))) + +(ert-deftest test-eager-load-macro-expansion () + (test-byte-comp-compile-and-load nil + '(progn (defmacro abc (arg) 1) (defun def () (abc 2)))) + (should (equal (funcall 'def) 1))) + +(ert-deftest test-eager-load-macro-expansion-eval-and-compile () + (test-byte-comp-compile-and-load nil + '(eval-and-compile (defmacro abc (arg) -1) (defun def () (abc 2)))) + (should (equal (funcall 'def) -1))) + +(ert-deftest test-eager-load-macro-expansion-eval-when-compile () + ;; Make sure we interpret eval-when-compile forms properly. CLISP + ;; and SBCL interpreter eval-when-compile (well, the CL equivalent) + ;; in the same way. + (test-byte-comp-compile-and-load nil + '(eval-when-compile + (defmacro abc (arg) -10) + (defun abc-1 () (abc 2))) + '(defmacro abc-2 () (abc-1)) + '(defun def () (abc-2))) + (should (equal (funcall 'def) -10))) + +(ert-deftest test-eager-load-macro-expand-lexical-override () + ;; Intuitively, one might expect the defmacro to override the + ;; macrolet since macrolet's is explicitly called out as being + ;; equivalent to toplevel, but CLISP and SBCL both evaluate the form + ;; this way, so we should too. + (test-byte-comp-compile-and-load nil + '(require 'cl-lib) + '(cl-macrolet ((m () 4)) + (defmacro m () 5) + (defun def () (m)))) + (should (equal (funcall 'def) 4))) + + +;; Local Variables: +;; no-byte-compile: t +;; End: + +(provide 'byte-opt-testsuite) + diff --git a/test/lisp/legacy/coding-tests.el b/test/lisp/legacy/coding-tests.el new file mode 100644 index 00000000000..cba8c7bc25f --- /dev/null +++ b/test/lisp/legacy/coding-tests.el @@ -0,0 +1,50 @@ +;;; coding-tests.el --- tests for text encoding and decoding + +;; Copyright (C) 2015-2016 Free Software Foundation, Inc. + +;; Author: Eli Zaretskii <eliz@gnu.org> + +;; 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/>. + +;;; Code: + +(require 'ert) + +;; Directory to hold test data files. +(defvar coding-tests-workdir + (expand-file-name "coding-tests" temporary-file-directory)) + +;; Remove all generated test files. +(defun coding-tests-remove-files () + (delete-directory coding-tests-workdir t)) + +(ert-deftest ert-test-coding-bogus-coding-systems () + (unwind-protect + (let (test-file) + (or (file-directory-p coding-tests-workdir) + (mkdir coding-tests-workdir t)) + (setq test-file (expand-file-name "nonexistent" coding-tests-workdir)) + (if (file-exists-p test-file) + (delete-file test-file)) + (should-error + (let ((coding-system-for-read 'bogus)) + (insert-file-contents test-file))) + ;; See bug #21602. + (setq test-file (expand-file-name "writing" coding-tests-workdir)) + (should-error + (let ((coding-system-for-write (intern "\"us-ascii\""))) + (write-region "some text" nil test-file)))) + (coding-tests-remove-files))) diff --git a/test/lisp/legacy/core-elisp-tests.el b/test/lisp/legacy/core-elisp-tests.el new file mode 100644 index 00000000000..76985331566 --- /dev/null +++ b/test/lisp/legacy/core-elisp-tests.el @@ -0,0 +1,52 @@ +;;; core-elisp-tests.el --- Testing some core Elisp rules + +;; Copyright (C) 2013-2016 Free Software Foundation, Inc. + +;; Author: Stefan Monnier <monnier@iro.umontreal.ca> +;; Keywords: + +;; 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/>. + +;;; Commentary: + +;; + +;;; Code: + +(ert-deftest core-elisp-tests-1-defvar-in-let () + "Test some core Elisp rules." + (with-temp-buffer + ;; Check that when defvar is run within a let-binding, the toplevel default + ;; is properly initialized. + (should (equal (list (let ((c-e-x 1)) (defvar c-e-x 2) c-e-x) c-e-x) + '(1 2))) + (should (equal (list (let ((c-e-x 1)) + (defcustom c-e-x 2 "doc" :group 'blah) c-e-x) + c-e-x) + '(1 2))))) + +(ert-deftest core-elisp-tests-2-window-configurations () + "Test properties of window-configurations." + (let ((wc (current-window-configuration))) + (with-current-buffer (window-buffer (frame-selected-window)) + (push-mark) + (activate-mark)) + (set-window-configuration wc) + (should (or (not mark-active) (mark))))) + +(ert-deftest core-elisp-tests-3-backquote () + (should (eq 3 (eval ``,,'(+ 1 2))))) + +(provide 'core-elisp-tests) +;;; core-elisp-tests.el ends here diff --git a/test/lisp/legacy/decoder-tests.el b/test/lisp/legacy/decoder-tests.el new file mode 100644 index 00000000000..5699fec7d17 --- /dev/null +++ b/test/lisp/legacy/decoder-tests.el @@ -0,0 +1,349 @@ +;;; decoder-tests.el --- test for text decoder + +;; Copyright (C) 2013-2016 Free Software Foundation, Inc. + +;; Author: Kenichi Handa <handa@gnu.org> + +;; 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/>. + +;;; Code: + +(require 'ert) + +;; Directory to hold test data files. +(defvar decoder-tests-workdir + (expand-file-name "decoder-tests" temporary-file-directory)) + +;; Remove all generated test files. +(defun decoder-tests-remove-files () + (delete-directory decoder-tests-workdir t)) + +;; Return the contents (specified by CONTENT-TYPE; ascii, latin, or +;; binary) of a test file. +(defun decoder-tests-file-contents (content-type) + (let* ((ascii "ABCDEFGHIJKLMNOPQRSTUVWXYZ\n") + (latin (concat ascii "ÀÁÂÃÄÅÆÇÈÉÊËÌÍÎÏ\n")) + (binary (string-to-multibyte + (concat (string-as-unibyte latin) + (unibyte-string #xC0 #xC1 ?\n))))) + (cond ((eq content-type 'ascii) ascii) + ((eq content-type 'latin) latin) + ((eq content-type 'binary) binary) + (t + (error "Invalid file content type: %s" content-type))))) + +;; Generate FILE with CONTENTS encoded by CODING-SYSTEM. +;; whose encoding specified by CODING-SYSTEM. +(defun decoder-tests-gen-file (file contents coding-system) + (or (file-directory-p decoder-tests-workdir) + (mkdir decoder-tests-workdir t)) + (setq file (expand-file-name file decoder-tests-workdir)) + (with-temp-file file + (set-buffer-file-coding-system coding-system) + (insert contents)) + file) + +;;; The following three functions are filters for contents of a test +;;; file. + +;; Convert all LFs to CR LF sequences in the string STR. +(defun decoder-tests-lf-to-crlf (str) + (with-temp-buffer + (insert str) + (goto-char (point-min)) + (while (search-forward "\n" nil t) + (delete-char -1) + (insert "\r\n")) + (buffer-string))) + +;; Convert all LFs to CRs in the string STR. +(defun decoder-tests-lf-to-cr (str) + (with-temp-buffer + (insert str) + (subst-char-in-region (point-min) (point-max) ?\n ?\r) + (buffer-string))) + +;; Convert all LFs to LF LF sequences in the string STR. +(defun decoder-tests-lf-to-lflf (str) + (with-temp-buffer + (insert str) + (goto-char (point-min)) + (while (search-forward "\n" nil t) + (insert "\n")) + (buffer-string))) + +;; Prepend the UTF-8 BOM to STR. +(defun decoder-tests-add-bom (str) + (concat "\xfeff" str)) + +;; Return the name of test file whose contents specified by +;; CONTENT-TYPE and whose encoding specified by CODING-SYSTEM. +(defun decoder-tests-filename (content-type coding-system &optional ext) + (if ext + (expand-file-name (format "%s-%s.%s" content-type coding-system ext) + decoder-tests-workdir) + (expand-file-name (format "%s-%s" content-type coding-system) + decoder-tests-workdir))) + + +;;; Check ASCII optimizing decoder + +;; Generate a test file whose contents specified by CONTENT-TYPE and +;; whose encoding specified by CODING-SYSTEM. +(defun decoder-tests-ao-gen-file (content-type coding-system) + (let ((file (decoder-tests-filename content-type coding-system))) + (decoder-tests-gen-file file + (decoder-tests-file-contents content-type) + coding-system))) + +;; Test the decoding of a file whose contents and encoding are +;; specified by CONTENT-TYPE and WRITE-CODING. The test passes if the +;; file is read by READ-CODING and detected as DETECTED-CODING and the +;; contents is correctly decoded. +;; Optional 5th arg TRANSLATOR is a function to translate the original +;; file contents to match with the expected result of decoding. For +;; instance, when a file of dos eol-type is read by unix eol-type, +;; `decode-test-lf-to-crlf' must be specified. + +(defun decoder-tests (content-type write-coding read-coding detected-coding + &optional translator) + (prefer-coding-system 'utf-8-auto) + (let ((filename (decoder-tests-filename content-type write-coding))) + (with-temp-buffer + (let ((coding-system-for-read read-coding) + (contents (decoder-tests-file-contents content-type)) + (disable-ascii-optimization nil)) + (if translator + (setq contents (funcall translator contents))) + (insert-file-contents filename) + (if (and (coding-system-equal buffer-file-coding-system detected-coding) + (string= (buffer-string) contents)) + nil + (list buffer-file-coding-system + (string-to-list (buffer-string)) + (string-to-list contents))))))) + +(ert-deftest ert-test-decoder-ascii () + (unwind-protect + (progn + (dolist (eol-type '(unix dos mac)) + (decoder-tests-ao-gen-file 'ascii eol-type)) + (should-not (decoder-tests 'ascii 'unix 'undecided 'unix)) + (should-not (decoder-tests 'ascii 'dos 'undecided 'dos)) + (should-not (decoder-tests 'ascii 'dos 'dos 'dos)) + (should-not (decoder-tests 'ascii 'mac 'undecided 'mac)) + (should-not (decoder-tests 'ascii 'mac 'mac 'mac)) + (should-not (decoder-tests 'ascii 'dos 'utf-8 'utf-8-dos)) + (should-not (decoder-tests 'ascii 'dos 'unix 'unix + 'decoder-tests-lf-to-crlf)) + (should-not (decoder-tests 'ascii 'mac 'dos 'dos + 'decoder-tests-lf-to-cr)) + (should-not (decoder-tests 'ascii 'dos 'mac 'mac + 'decoder-tests-lf-to-lflf))) + (decoder-tests-remove-files))) + +(ert-deftest ert-test-decoder-latin () + (unwind-protect + (progn + (dolist (coding '("utf-8" "utf-8-with-signature")) + (dolist (eol-type '("unix" "dos" "mac")) + (decoder-tests-ao-gen-file 'latin + (intern (concat coding "-" eol-type))))) + (should-not (decoder-tests 'latin 'utf-8-unix 'undecided 'utf-8-unix)) + (should-not (decoder-tests 'latin 'utf-8-unix 'utf-8-unix 'utf-8-unix)) + (should-not (decoder-tests 'latin 'utf-8-dos 'undecided 'utf-8-dos)) + (should-not (decoder-tests 'latin 'utf-8-dos 'utf-8-dos 'utf-8-dos)) + (should-not (decoder-tests 'latin 'utf-8-mac 'undecided 'utf-8-mac)) + (should-not (decoder-tests 'latin 'utf-8-mac 'utf-8-mac 'utf-8-mac)) + (should-not (decoder-tests 'latin 'utf-8-dos 'unix 'utf-8-unix + 'decoder-tests-lf-to-crlf)) + (should-not (decoder-tests 'latin 'utf-8-mac 'dos 'utf-8-dos + 'decoder-tests-lf-to-cr)) + (should-not (decoder-tests 'latin 'utf-8-dos 'mac 'utf-8-mac + 'decoder-tests-lf-to-lflf)) + (should-not (decoder-tests 'latin 'utf-8-with-signature-unix 'undecided + 'utf-8-with-signature-unix)) + (should-not (decoder-tests 'latin 'utf-8-with-signature-unix 'utf-8-auto + 'utf-8-with-signature-unix)) + (should-not (decoder-tests 'latin 'utf-8-with-signature-dos 'undecided + 'utf-8-with-signature-dos)) + (should-not (decoder-tests 'latin 'utf-8-with-signature-unix 'utf-8 + 'utf-8-unix 'decoder-tests-add-bom)) + (should-not (decoder-tests 'latin 'utf-8-with-signature-unix 'utf-8 + 'utf-8-unix 'decoder-tests-add-bom))) + (decoder-tests-remove-files))) + +(ert-deftest ert-test-decoder-binary () + (unwind-protect + (progn + (dolist (eol-type '("unix" "dos" "mac")) + (decoder-tests-ao-gen-file 'binary + (intern (concat "raw-text" "-" eol-type)))) + (should-not (decoder-tests 'binary 'raw-text-unix 'undecided + 'raw-text-unix)) + (should-not (decoder-tests 'binary 'raw-text-dos 'undecided + 'raw-text-dos)) + (should-not (decoder-tests 'binary 'raw-text-mac 'undecided + 'raw-text-mac)) + (should-not (decoder-tests 'binary 'raw-text-dos 'unix + 'raw-text-unix 'decoder-tests-lf-to-crlf)) + (should-not (decoder-tests 'binary 'raw-text-mac 'dos + 'raw-text-dos 'decoder-tests-lf-to-cr)) + (should-not (decoder-tests 'binary 'raw-text-dos 'mac + 'raw-text-mac 'decoder-tests-lf-to-lflf))) + (decoder-tests-remove-files))) + + +;;; Check the coding system `prefer-utf-8'. + +;; Read FILE. Check if the encoding was detected as DETECT. If +;; PREFER is non-nil, prefer that coding system before reading. + +(defun decoder-tests-prefer-utf-8-read (file detect prefer) + (with-temp-buffer + (with-coding-priority (if prefer (list prefer)) + (insert-file-contents file)) + (if (eq buffer-file-coding-system detect) + nil + (format "Invalid detection: %s" buffer-file-coding-system)))) + +;; Read FILE, modify it, and write it. Check if the coding system +;; used for writing was CODING. If CODING-TAG is non-nil, insert +;; coding tag with it before writing. If STR is non-nil, insert it +;; before writing. + +(defun decoder-tests-prefer-utf-8-write (file coding-tag coding + &optional str) + (with-temp-buffer + (insert-file-contents file) + (goto-char (point-min)) + (if coding-tag + (insert (format ";; -*- coding: %s; -*-\n" coding-tag)) + (insert ";;\n")) + (if str + (insert str)) + (write-file (decoder-tests-filename 'test 'test "el")) + (if (coding-system-equal buffer-file-coding-system coding) + nil + (format "Incorrect encoding: %s" last-coding-system-used)))) + +(ert-deftest ert-test-decoder-prefer-utf-8 () + (unwind-protect + (let ((ascii (decoder-tests-gen-file "ascii.el" + (decoder-tests-file-contents 'ascii) + 'unix)) + (latin (decoder-tests-gen-file "utf-8.el" + (decoder-tests-file-contents 'latin) + 'utf-8-unix))) + (should-not (decoder-tests-prefer-utf-8-read + ascii 'prefer-utf-8-unix nil)) + (should-not (decoder-tests-prefer-utf-8-read + latin 'utf-8-unix nil)) + (should-not (decoder-tests-prefer-utf-8-read + latin 'utf-8-unix 'iso-8859-1)) + (should-not (decoder-tests-prefer-utf-8-read + latin 'utf-8-unix 'sjis)) + (should-not (decoder-tests-prefer-utf-8-write + ascii nil 'prefer-utf-8-unix)) + (should-not (decoder-tests-prefer-utf-8-write + ascii 'iso-8859-1 'iso-8859-1-unix)) + (should-not (decoder-tests-prefer-utf-8-write + ascii nil 'utf-8-unix "À"))) + (decoder-tests-remove-files))) + + +;;; The following is for benchmark testing of the new optimized +;;; decoder, not for regression testing. + +(defun generate-ascii-file () + (dotimes (i 100000) + (insert-char ?a 80) + (insert "\n"))) + +(defun generate-rarely-nonascii-file () + (dotimes (i 100000) + (if (/= i 50000) + (insert-char ?a 80) + (insert ?À) + (insert-char ?a 79)) + (insert "\n"))) + +(defun generate-mostly-nonascii-file () + (dotimes (i 30000) + (insert-char ?a 80) + (insert "\n")) + (dotimes (i 20000) + (insert-char ?À 80) + (insert "\n")) + (dotimes (i 10000) + (insert-char ?あ 80) + (insert "\n"))) + + +(defvar test-file-list + '((generate-ascii-file + ("~/ascii-tag-utf-8-unix.unix" ";; -*- coding: utf-8-unix; -*-" unix) + ("~/ascii-tag-utf-8.unix" ";; -*- coding: utf-8; -*-" unix) + ("~/ascii-tag-none.unix" "" unix) + ("~/ascii-tag-utf-8-dos.dos" ";; -*- coding: utf-8-dos; -*-" dos) + ("~/ascii-tag-utf-8.dos" ";; -*- coding: utf-8; -*-" dos) + ("~/ascii-tag-none.dos" "" dos)) + (generate-rarely-nonascii-file + ("~/utf-8-r-tag-utf-8-unix.unix" ";; -*- coding: utf-8-unix; -*-" utf-8-unix) + ("~/utf-8-r-tag-utf-8.unix" ";; -*- coding: utf-8; -*-" utf-8-unix) + ("~/utf-8-r-tag-none.unix" "" utf-8-unix) + ("~/utf-8-r-tag-utf-8-dos.dos" ";; -*- coding: utf-8-dos; -*-" utf-8-dos) + ("~/utf-8-r-tag-utf-8.dos" ";; -*- coding: utf-8; -*-" utf-8-dos) + ("~/utf-8-r-tag-none.dos" "" utf-8-dos)) + (generate-mostly-nonascii-file + ("~/utf-8-m-tag-utf-8-unix.unix" ";; -*- coding: utf-8-unix; -*-" utf-8-unix) + ("~/utf-8-m-tag-utf-8.unix" ";; -*- coding: utf-8; -*-" utf-8-unix) + ("~/utf-8-m-tag-none.unix" "" utf-8-unix) + ("~/utf-8-m-tag-utf-8-dos.dos" ";; -*- coding: utf-8-dos; -*-" utf-8-dos) + ("~/utf-8-m-tag-utf-8.dos" ";; -*- coding: utf-8; -*-" utf-8-dos) + ("~/utf-8-m-tag-none.dos" "" utf-8-dos)))) + +(defun generate-benchmark-test-file () + (interactive) + (with-temp-buffer + (message "Generating data...") + (dolist (files test-file-list) + (delete-region (point-min) (point-max)) + (funcall (car files)) + (dolist (file (cdr files)) + (message "Writing %s..." (car file)) + (goto-char (point-min)) + (insert (nth 1 file) "\n") + (let ((coding-system-for-write (nth 2 file))) + (write-region (point-min) (point-max) (car file))) + (delete-region (point-min) (point)))))) + +(defun benchmark-decoder () + (let ((gc-cons-threshold 4000000)) + (insert "Without optimization:\n") + (dolist (files test-file-list) + (dolist (file (cdr files)) + (let* ((disable-ascii-optimization t) + (result (benchmark-run 10 + (with-temp-buffer (insert-file-contents (car file)))))) + (insert (format "%s: %s\n" (car file) result))))) + (insert "With optimization:\n") + (dolist (files test-file-list) + (dolist (file (cdr files)) + (let* ((disable-ascii-optimization nil) + (result (benchmark-run 10 + (with-temp-buffer (insert-file-contents (car file)))))) + (insert (format "%s: %s\n" (car file) result))))))) diff --git a/test/lisp/legacy/files-tests.el b/test/lisp/legacy/files-tests.el new file mode 100644 index 00000000000..3c6f61b792c --- /dev/null +++ b/test/lisp/legacy/files-tests.el @@ -0,0 +1,172 @@ +;;; files.el --- tests for file handling. + +;; Copyright (C) 2012-2016 Free Software Foundation, Inc. + +;; 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/>. + +;;; Code: + +(require 'ert) + +;; Set to t if the local variable was set, `query' if the query was +;; triggered. +(defvar files-test-result nil) + +(defvar files-test-safe-result nil) +(put 'files-test-safe-result 'safe-local-variable 'booleanp) + +(defun files-test-fun1 () + (setq files-test-result t)) + +;; Test combinations: +;; `enable-local-variables' t, nil, :safe, :all, or something else. +;; `enable-local-eval' t, nil, or something else. + +(defvar files-test-local-variable-data + ;; Unsafe eval form + '((("eval: (files-test-fun1)") + (t t (eq files-test-result t)) + (t nil (eq files-test-result nil)) + (t maybe (eq files-test-result 'query)) + (nil t (eq files-test-result nil)) + (nil nil (eq files-test-result nil)) + (nil maybe (eq files-test-result nil)) + (:safe t (eq files-test-result nil)) + (:safe nil (eq files-test-result nil)) + (:safe maybe (eq files-test-result nil)) + (:all t (eq files-test-result t)) + (:all nil (eq files-test-result nil)) + (:all maybe (eq files-test-result t)) ; This combination is ambiguous. + (maybe t (eq files-test-result 'query)) + (maybe nil (eq files-test-result nil)) + (maybe maybe (eq files-test-result 'query))) + ;; Unsafe local variable value + (("files-test-result: t") + (t t (eq files-test-result 'query)) + (t nil (eq files-test-result 'query)) + (t maybe (eq files-test-result 'query)) + (nil t (eq files-test-result nil)) + (nil nil (eq files-test-result nil)) + (nil maybe (eq files-test-result nil)) + (:safe t (eq files-test-result nil)) + (:safe nil (eq files-test-result nil)) + (:safe maybe (eq files-test-result nil)) + (:all t (eq files-test-result t)) + (:all nil (eq files-test-result t)) + (:all maybe (eq files-test-result t)) + (maybe t (eq files-test-result 'query)) + (maybe nil (eq files-test-result 'query)) + (maybe maybe (eq files-test-result 'query))) + ;; Safe local variable + (("files-test-safe-result: t") + (t t (eq files-test-safe-result t)) + (t nil (eq files-test-safe-result t)) + (t maybe (eq files-test-safe-result t)) + (nil t (eq files-test-safe-result nil)) + (nil nil (eq files-test-safe-result nil)) + (nil maybe (eq files-test-safe-result nil)) + (:safe t (eq files-test-safe-result t)) + (:safe nil (eq files-test-safe-result t)) + (:safe maybe (eq files-test-safe-result t)) + (:all t (eq files-test-safe-result t)) + (:all nil (eq files-test-safe-result t)) + (:all maybe (eq files-test-safe-result t)) + (maybe t (eq files-test-result 'query)) + (maybe nil (eq files-test-result 'query)) + (maybe maybe (eq files-test-result 'query))) + ;; Safe local variable with unsafe value + (("files-test-safe-result: 1") + (t t (eq files-test-result 'query)) + (t nil (eq files-test-result 'query)) + (t maybe (eq files-test-result 'query)) + (nil t (eq files-test-safe-result nil)) + (nil nil (eq files-test-safe-result nil)) + (nil maybe (eq files-test-safe-result nil)) + (:safe t (eq files-test-safe-result nil)) + (:safe nil (eq files-test-safe-result nil)) + (:safe maybe (eq files-test-safe-result nil)) + (:all t (eq files-test-safe-result 1)) + (:all nil (eq files-test-safe-result 1)) + (:all maybe (eq files-test-safe-result 1)) + (maybe t (eq files-test-result 'query)) + (maybe nil (eq files-test-result 'query)) + (maybe maybe (eq files-test-result 'query)))) + "List of file-local variable tests. +Each list element should have the form + + (LOCAL-VARS-LIST . TEST-LIST) + +where LOCAL-VARS-LISTS should be a list of local variable +definitions (strings) and TEST-LIST is a list of tests to +perform. Each entry of TEST-LIST should have the form + + (ENABLE-LOCAL-VARIABLES ENABLE-LOCAL-EVAL FORM) + +where ENABLE-LOCAL-VARIABLES is the value to assign to +`enable-local-variables', ENABLE-LOCAL-EVAL is the value to +assign to `enable-local-eval', and FORM is a desired `should' +form.") + +(defun file-test--do-local-variables-test (str test-settings) + (with-temp-buffer + (insert str) + (setq files-test-result nil + files-test-safe-result nil) + (let ((enable-local-variables (nth 0 test-settings)) + (enable-local-eval (nth 1 test-settings)) + ;; Prevent any dir-locals file interfering with the tests. + (enable-dir-local-variables nil) + (files-test-queried nil)) + (hack-local-variables) + (eval (nth 2 test-settings))))) + +(ert-deftest files-test-local-variables () + "Test the file-local variables implementation." + (unwind-protect + (progn + (defadvice hack-local-variables-confirm (around files-test activate) + (setq files-test-result 'query) + nil) + (dolist (test files-test-local-variable-data) + (let ((str (concat "text\n\n;; Local Variables:\n;; " + (mapconcat 'identity (car test) "\n;; ") + "\n;; End:\n"))) + (dolist (subtest (cdr test)) + (should (file-test--do-local-variables-test str subtest)))))) + (ad-disable-advice 'hack-local-variables-confirm 'around 'files-test))) + +(defvar files-test-bug-18141-file + (expand-file-name "data/files-bug18141.el.gz" (getenv "EMACS_TEST_DIRECTORY")) + "Test file for bug#18141.") + +(ert-deftest files-test-bug-18141 () + "Test for http://debbugs.gnu.org/18141 ." + (skip-unless (executable-find "gzip")) + (let ((tempfile (make-temp-file "files-test-bug-18141" nil ".gz"))) + (unwind-protect + (progn + (copy-file files-test-bug-18141-file tempfile t) + (with-current-buffer (find-file-noselect tempfile) + (set-buffer-modified-p t) + (save-buffer) + (should (eq buffer-file-coding-system 'iso-2022-7bit-unix)))) + (delete-file tempfile)))) + + +;; Stop the above "Local Var..." confusing Emacs. + + +;;; files.el ends here diff --git a/test/lisp/legacy/font-parse-tests.el b/test/lisp/legacy/font-parse-tests.el new file mode 100644 index 00000000000..6274253360f --- /dev/null +++ b/test/lisp/legacy/font-parse-tests.el @@ -0,0 +1,165 @@ +;;; font-parse-tests.el --- Test suite for font parsing. + +;; Copyright (C) 2011-2016 Free Software Foundation, Inc. + +;; Author: Chong Yidong <cyd@stupidchicken.com> +;; Keywords: internal +;; Human-Keywords: internal + +;; 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: + +;; Type M-x test-font-parse RET to generate the test buffer. + +;;; Code: + +(require 'ert) + +(defvar font-parse-tests--data + `((" " ,(intern " ") nil nil nil nil) + ("Monospace" Monospace nil nil nil nil) + ("Foo1" Foo1 nil nil nil nil) + ("12" nil 12.0 nil nil nil) + ("12 " ,(intern "12 ") nil nil nil nil) + ;; Fontconfig format + ("Foo:" Foo nil nil nil nil) + ("Foo-8" Foo 8.0 nil nil nil) + ("Foo-18:" Foo 18.0 nil nil nil) + ("Foo-18:light" Foo 18.0 light nil nil) + ("Foo 10:weight=bold" ,(intern "Foo 10") nil bold nil nil) + ("Foo-12:weight=bold" Foo 12.0 bold nil nil) + ("Foo 8-20:slant=oblique" ,(intern "Foo 8") 20.0 nil oblique nil) + ("Foo:light:roman" Foo nil light roman nil) + ("Foo:italic:roman" Foo nil nil roman nil) + ("Foo 12:light:oblique" ,(intern "Foo 12") nil light oblique nil) + ("Foo-12:demibold:oblique" Foo 12.0 demibold oblique nil) + ("Foo:black:proportional" Foo nil black nil 0) + ("Foo-10:black:proportional" Foo 10.0 black nil 0) + ("Foo:weight=normal" Foo nil normal nil nil) + ("Foo:weight=bold" Foo nil bold nil nil) + ("Foo:weight=bold:slant=italic" Foo nil bold italic) + ("Foo:weight=bold:slant=italic:mono" Foo nil bold italic 100) + ("Foo-10:demibold:slant=normal" Foo 10.0 demibold normal nil) + ("Foo 11-16:oblique:weight=bold" ,(intern "Foo 11") 16.0 bold oblique nil) + ("Foo:oblique:randomprop=randomtag:weight=bold" Foo nil bold oblique nil) + ("Foo:randomprop=randomtag:bar=baz" Foo nil nil nil nil) + ("Foo Book Light:bar=baz" ,(intern "Foo Book Light") nil nil nil nil) + ("Foo Book Light 10:bar=baz" ,(intern "Foo Book Light 10") nil nil nil nil) + ("Foo Book Light-10:bar=baz" ,(intern "Foo Book Light") 10.0 nil nil nil) + ;; GTK format + ("Oblique" nil nil nil oblique nil) + ("Bold 17" nil 17.0 bold nil nil) + ("17 Bold" ,(intern "17") nil bold nil nil) + ("Book Oblique 2" nil 2.0 book oblique nil) + ("Bar 7" Bar 7.0 nil nil nil) + ("Bar Ultra-Light" Bar nil ultra-light nil nil) + ("Bar Light 8" Bar 8.0 light nil nil) + ("Bar Book Medium 9" Bar 9.0 medium nil nil) + ("Bar Semi-Bold Italic 10" Bar 10.0 semi-bold italic nil) + ("Bar Semi-Condensed Bold Italic 11" Bar 11.0 bold italic nil) + ("Foo 10 11" ,(intern "Foo 10") 11.0 nil nil nil) + ("Foo 1985 Book" ,(intern "Foo 1985") nil book nil nil) + ("Foo 1985 A Book" ,(intern "Foo 1985 A") nil book nil nil) + ("Foo 1 Book 12" ,(intern "Foo 1") 12.0 book nil nil) + ("Foo A Book 12 A" ,(intern "Foo A Book 12 A") nil nil nil nil) + ("Foo 1985 Book 12 Oblique" ,(intern "Foo 1985 Book 12") nil nil oblique nil) + ("Foo 1985 Book 12 Italic 10" ,(intern "Foo 1985 Book 12") 10.0 nil italic nil) + ("Foo Book Bar 6 Italic" ,(intern "Foo Book Bar 6") nil nil italic nil) + ("Foo Book Bar Bold" ,(intern "Foo Book Bar") nil bold nil nil)) + "List of font names parse data. +Each element should have the form + (NAME FAMILY SIZE WEIGHT SLANT SPACING) +where NAME is the name to parse, and the remainder are the +expected font properties from parsing NAME.") + +(defun font-parse-check (name prop expected) + (let ((result (font-get (font-spec :name name) prop))) + (if (and (symbolp result) (symbolp expected)) + (eq result expected) + (equal result expected)))) + +(put 'font-parse-check 'ert-explainer 'font-parse-explain) + +(defun font-parse-explain (name prop expected) + (let ((result (font-get (font-spec :name name) prop)) + (propname (symbol-name prop))) + (format "Parsing `%s': expected %s `%s', got `%s'." + name (substring propname 1) expected + (font-get (font-spec :name name) prop)))) + +(ert-deftest font-parse-tests () + "Test parsing of Fontconfig-style and GTK-style font names." + (dolist (test font-parse-tests--data) + (let* ((name (nth 0 test))) + (should (font-parse-check name :family (nth 1 test))) + (should (font-parse-check name :size (nth 2 test))) + (should (font-parse-check name :weight (nth 3 test))) + (should (font-parse-check name :slant (nth 4 test))) + (should (font-parse-check name :spacing (nth 5 test)))))) + + +(defun test-font-parse () + "Test font name parsing." + (interactive) + (switch-to-buffer (generate-new-buffer "*Font Pase Test*")) + (setq show-trailing-whitespace nil) + (let ((pass-face '((t :foreground "green"))) + (fail-face '((t :foreground "red")))) + (dolist (test font-parse-tests--data) + (let* ((name (nth 0 test)) + (fs (font-spec :name name)) + (family (font-get fs :family)) + (size (font-get fs :size)) + (weight (font-get fs :weight)) + (slant (font-get fs :slant)) + (spacing (font-get fs :spacing))) + (insert name) + (if (> (current-column) 20) + (insert "\n")) + (indent-to-column 21) + (insert (propertize (symbol-name family) + 'face (if (eq family (nth 1 test)) + pass-face + fail-face))) + (indent-to-column 40) + (insert (propertize (format "%s" size) + 'face (if (equal size (nth 2 test)) + pass-face + fail-face))) + (indent-to-column 48) + (insert (propertize (format "%s" weight) + 'face (if (eq weight (nth 3 test)) + pass-face + fail-face))) + (indent-to-column 60) + (insert (propertize (format "%s" slant) + 'face (if (eq slant (nth 4 test)) + pass-face + fail-face))) + (indent-to-column 69) + (insert (propertize (format "%s" spacing) + 'face (if (eq spacing (nth 5 test)) + pass-face + fail-face))) + (insert "\n")))) + (goto-char (point-min))) + +;; Local Variables: +;; no-byte-compile: t +;; End: + +;;; font-parse-tests.el ends here. diff --git a/test/lisp/legacy/lexbind-tests.el b/test/lisp/legacy/lexbind-tests.el new file mode 100644 index 00000000000..3bf8c1361ad --- /dev/null +++ b/test/lisp/legacy/lexbind-tests.el @@ -0,0 +1,75 @@ +;;; lexbind-tests.el --- Testing the lexbind byte-compiler + +;; Copyright (C) 2011-2016 Free Software Foundation, Inc. + +;; Author: Stefan Monnier <monnier@iro.umontreal.ca> +;; Keywords: + +;; 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/>. + +;;; Commentary: + +;; + +;;; Code: + +(require 'ert) + +(defconst lexbind-tests + `( + (let ((f #'car)) + (let ((f (lambda (x) (cons (funcall f x) (cdr x))))) + (funcall f '(1 . 2)))) + ) + "List of expression for test. +Each element will be executed by interpreter and with +bytecompiled code, and their results compared.") + + + +(defun lexbind-check-1 (pat) + "Return non-nil if PAT is the same whether directly evalled or compiled." + (let ((warning-minimum-log-level :emergency) + (byte-compile-warnings nil) + (v0 (condition-case nil + (eval pat t) + (error nil))) + (v1 (condition-case nil + (funcall (let ((lexical-binding t)) + (byte-compile `(lambda nil ,pat)))) + (error nil)))) + (equal v0 v1))) + +(put 'lexbind-check-1 'ert-explainer 'lexbind-explain-1) + +(defun lexbind-explain-1 (pat) + (let ((v0 (condition-case nil + (eval pat t) + (error nil))) + (v1 (condition-case nil + (funcall (let ((lexical-binding t)) + (byte-compile (list 'lambda nil pat)))) + (error nil)))) + (format "Expression `%s' gives `%s' if directly evalled, `%s' if compiled." + pat v0 v1))) + +(ert-deftest lexbind-tests () + "Test the Emacs byte compiler lexbind handling." + (dolist (pat lexbind-tests) + (should (lexbind-check-1 pat)))) + + + +(provide 'lexbind-tests) +;;; lexbind-tests.el ends here diff --git a/test/lisp/legacy/occur-tests.el b/test/lisp/legacy/occur-tests.el new file mode 100644 index 00000000000..da45d5f6502 --- /dev/null +++ b/test/lisp/legacy/occur-tests.el @@ -0,0 +1,352 @@ +;;; occur-tests.el --- Test suite for occur. + +;; Copyright (C) 2010-2016 Free Software Foundation, Inc. + +;; Author: Juri Linkov <juri@jurta.org> +;; Keywords: matching, internal + +;; 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/>. + +;;; Code: + +(require 'ert) + +(defconst occur-tests + '( + ;; * Test one-line matches (at bob, eob, bol, eol). + ("x" 0 "\ +xa +b +cx +xd +xex +fx +" "\ +6 matches in 5 lines for \"x\" in buffer: *test-occur* + 1:xa + 3:cx + 4:xd + 5:xex + 6:fx +") + ;; * Test multi-line matches, this is the first test from + ;; http://lists.gnu.org/archive/html/emacs-devel/2005-06/msg01008.html + ;; where numbers are replaced with letters. + ("a\na" 0 "\ +a +a +a +a +a +" "\ +2 matches for \"a\na\" in buffer: *test-occur* + 1:a + :a + 3:a + :a +") + ;; * Test multi-line matches, this is the second test from + ;; http://lists.gnu.org/archive/html/emacs-devel/2005-06/msg01008.html + ;; where numbers are replaced with letters. + ("a\nb" 0 "\ +a +b +c +a +b +" "\ +2 matches for \"a\nb\" in buffer: *test-occur* + 1:a + :b + 4:a + :b +") + ;; * Test line numbers for multi-line matches with empty last match line. + ("a\n" 0 "\ +a + +c +a + +" "\ +2 matches for \"a\n\" in buffer: *test-occur* + 1:a + : + 4:a + : +") + ;; * Test multi-line matches with 3 match lines. + ("x\n.x\n" 0 "\ +ax +bx +c +d +ex +fx +" "\ +2 matches for \"x\n.x\n\" in buffer: *test-occur* + 1:ax + :bx + :c + 5:ex + :fx + : +") + ;; * Test non-overlapping context lines with matches at bob/eob. + ("x" 1 "\ +ax +b +c +d +ex +f +g +hx +" "\ +3 matches for \"x\" in buffer: *test-occur* + 1:ax + :b +------- + :d + 5:ex + :f +------- + :g + 8:hx +") + ;; * Test non-overlapping context lines with matches not at bob/eob. + ("x" 1 "\ +a +bx +c +d +ex +f +" "\ +2 matches for \"x\" in buffer: *test-occur* + :a + 2:bx + :c +------- + :d + 5:ex + :f +") + ;; * Test overlapping context lines with matches at bob/eob. + ("x" 2 "\ +ax +bx +c +dx +e +f +gx +h +i +j +kx +" "\ +5 matches for \"x\" in buffer: *test-occur* + 1:ax + 2:bx + :c + 4:dx + :e + :f + 7:gx + :h + :i + :j + 11:kx +") + ;; * Test overlapping context lines with matches not at bob/eob. + ("x" 2 "\ +a +b +cx +d +e +f +gx +h +i +" "\ +2 matches for \"x\" in buffer: *test-occur* + :a + :b + 3:cx + :d + :e + :f + 7:gx + :h + :i +") + ;; * Test overlapping context lines with empty first and last line.. + ("x" 2 "\ + +b +cx +d +e +f +gx +h + +" "\ +2 matches for \"x\" in buffer: *test-occur* + : + :b + 3:cx + :d + :e + :f + 7:gx + :h + : +") + ;; * Test multi-line overlapping context lines. + ("x\n.x" 2 "\ +ax +bx +c +d +ex +fx +g +h +i +jx +kx +" "\ +3 matches for \"x\n.x\" in buffer: *test-occur* + 1:ax + :bx + :c + :d + 5:ex + :fx + :g + :h + :i + 10:jx + :kx +") + ;; * Test multi-line non-overlapping context lines. + ("x\n.x" 2 "\ +ax +bx +c +d +e +f +gx +hx +" "\ +2 matches for \"x\n.x\" in buffer: *test-occur* + 1:ax + :bx + :c + :d +------- + :e + :f + 7:gx + :hx +") + ;; * Test non-overlapping negative (before-context) lines. + ("x" -2 "\ +a +bx +c +d +e +fx +g +h +ix +" "\ +3 matches for \"x\" in buffer: *test-occur* + :a + 2:bx +------- + :d + :e + 6:fx +------- + :g + :h + 9:ix +") + ;; * Test overlapping negative (before-context) lines. + ("x" -3 "\ +a +bx +c +dx +e +f +gx +h +" "\ +3 matches for \"x\" in buffer: *test-occur* + :a + 2:bx + :c + 4:dx + :e + :f + 7:gx +") + +) + "List of tests for `occur'. +Each element has the format: +\(REGEXP NLINES INPUT-BUFFER-STRING OUTPUT-BUFFER-STRING).") + +(defun occur-test-case (test) + (let ((regexp (nth 0 test)) + (nlines (nth 1 test)) + (input-buffer-string (nth 2 test)) + (temp-buffer (get-buffer-create " *test-occur*"))) + (unwind-protect + (save-window-excursion + (with-current-buffer temp-buffer + (erase-buffer) + (insert input-buffer-string) + (occur regexp nlines) + (with-current-buffer "*Occur*" + (buffer-substring-no-properties (point-min) (point-max))))) + (and (buffer-name temp-buffer) + (kill-buffer temp-buffer))))) + +(defun occur-test-create (n) + "Create a test for element N of the `occur-tests' constant." + (let ((testname (intern (format "occur-test-%.2d" n))) + (testdoc (format "Test element %d of `occur-tests'." n))) + (eval + `(ert-deftest ,testname () + ,testdoc + (let (occur-hook) + (should (equal (occur-test-case (nth ,n occur-tests)) + (nth 3 (nth ,n occur-tests))))))))) + +(dotimes (i (length occur-tests)) + (occur-test-create i)) + +(provide 'occur-tests) + +;;; occur-tests.el ends here diff --git a/test/lisp/legacy/process-tests.el b/test/lisp/legacy/process-tests.el new file mode 100644 index 00000000000..8554a287ccd --- /dev/null +++ b/test/lisp/legacy/process-tests.el @@ -0,0 +1,165 @@ +;;; process-tests.el --- Testing the process facilities + +;; Copyright (C) 2013-2016 Free Software Foundation, Inc. + +;; 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/>. + +;;; Commentary: + +;; + +;;; Code: + +(require 'ert) + +;; Timeout in seconds; the test fails if the timeout is reached. +(defvar process-test-sentinel-wait-timeout 2.0) + +;; Start a process that exits immediately. Call WAIT-FUNCTION, +;; possibly multiple times, to wait for the process to complete. +(defun process-test-sentinel-wait-function-working-p (wait-function) + (let ((proc (start-process "test" nil "bash" "-c" "exit 20")) + (sentinel-called nil) + (start-time (float-time))) + (set-process-sentinel proc (lambda (proc msg) + (setq sentinel-called t))) + (while (not (or sentinel-called + (> (- (float-time) start-time) + process-test-sentinel-wait-timeout))) + (funcall wait-function)) + (cl-assert (eq (process-status proc) 'exit)) + (cl-assert (= (process-exit-status proc) 20)) + sentinel-called)) + +(ert-deftest process-test-sentinel-accept-process-output () + (skip-unless (executable-find "bash")) + (should (process-test-sentinel-wait-function-working-p + #'accept-process-output))) + +(ert-deftest process-test-sentinel-sit-for () + (skip-unless (executable-find "bash")) + (should + (process-test-sentinel-wait-function-working-p (lambda () (sit-for 0.01 t))))) + +(when (eq system-type 'windows-nt) + (ert-deftest process-test-quoted-batfile () + "Check that Emacs hides CreateProcess deficiency (bug#18745)." + (let (batfile) + (unwind-protect + (progn + ;; CreateProcess will fail when both the bat file and 1st + ;; argument are quoted, so include spaces in both of those + ;; to force quoting. + (setq batfile (make-temp-file "echo args" nil ".bat")) + (with-temp-file batfile + (insert "@echo arg1=%1, arg2=%2\n")) + (with-temp-buffer + (call-process batfile nil '(t t) t "x &y") + (should (string= (buffer-string) "arg1=\"x &y\", arg2=\n"))) + (with-temp-buffer + (call-process-shell-command + (mapconcat #'shell-quote-argument (list batfile "x &y") " ") + nil '(t t) t) + (should (string= (buffer-string) "arg1=\"x &y\", arg2=\n")))) + (when batfile (delete-file batfile)))))) + +(ert-deftest process-test-stderr-buffer () + (skip-unless (executable-find "bash")) + (let* ((stdout-buffer (generate-new-buffer "*stdout*")) + (stderr-buffer (generate-new-buffer "*stderr*")) + (proc (make-process :name "test" + :command (list "bash" "-c" + (concat "echo hello stdout!; " + "echo hello stderr! >&2; " + "exit 20")) + :buffer stdout-buffer + :stderr stderr-buffer)) + (sentinel-called nil) + (start-time (float-time))) + (set-process-sentinel proc (lambda (proc msg) + (setq sentinel-called t))) + (while (not (or sentinel-called + (> (- (float-time) start-time) + process-test-sentinel-wait-timeout))) + (accept-process-output)) + (cl-assert (eq (process-status proc) 'exit)) + (cl-assert (= (process-exit-status proc) 20)) + (should (with-current-buffer stdout-buffer + (goto-char (point-min)) + (looking-at "hello stdout!"))) + (should (with-current-buffer stderr-buffer + (goto-char (point-min)) + (looking-at "hello stderr!"))))) + +(ert-deftest process-test-stderr-filter () + (skip-unless (executable-find "bash")) + (let* ((sentinel-called nil) + (stderr-sentinel-called nil) + (stdout-output nil) + (stderr-output nil) + (stdout-buffer (generate-new-buffer "*stdout*")) + (stderr-buffer (generate-new-buffer "*stderr*")) + (stderr-proc (make-pipe-process :name "stderr" + :buffer stderr-buffer)) + (proc (make-process :name "test" :buffer stdout-buffer + :command (list "bash" "-c" + (concat "echo hello stdout!; " + "echo hello stderr! >&2; " + "exit 20")) + :stderr stderr-proc)) + (start-time (float-time))) + (set-process-filter proc (lambda (proc input) + (push input stdout-output))) + (set-process-sentinel proc (lambda (proc msg) + (setq sentinel-called t))) + (set-process-filter stderr-proc (lambda (proc input) + (push input stderr-output))) + (set-process-sentinel stderr-proc (lambda (proc input) + (setq stderr-sentinel-called t))) + (while (not (or sentinel-called + (> (- (float-time) start-time) + process-test-sentinel-wait-timeout))) + (accept-process-output)) + (cl-assert (eq (process-status proc) 'exit)) + (cl-assert (= (process-exit-status proc) 20)) + (should sentinel-called) + (should (equal 1 (with-current-buffer stdout-buffer + (point-max)))) + (should (equal "hello stdout!\n" + (mapconcat #'identity (nreverse stdout-output) ""))) + (should stderr-sentinel-called) + (should (equal 1 (with-current-buffer stderr-buffer + (point-max)))) + (should (equal "hello stderr!\n" + (mapconcat #'identity (nreverse stderr-output) ""))))) + +(ert-deftest start-process-should-not-modify-arguments () + "`start-process' must not modify its arguments in-place." + ;; See bug#21831. + (let* ((path (pcase system-type + ((or 'windows-nt 'ms-dos) + ;; Make sure the file name uses forward slashes. + ;; The original bug was that 'start-process' would + ;; convert forward slashes to backslashes. + (expand-file-name (executable-find "attrib.exe"))) + (_ "/bin//sh"))) + (samepath (copy-sequence path))) + ;; Make sure 'start-process' actually goes all the way and invokes + ;; the program. + (should (process-live-p (condition-case nil + (start-process "" nil path) + (error nil)))) + (should (equal path samepath)))) + +(provide 'process-tests) diff --git a/test/lisp/legacy/syntax-tests.el b/test/lisp/legacy/syntax-tests.el new file mode 100644 index 00000000000..d4af80e8ebe --- /dev/null +++ b/test/lisp/legacy/syntax-tests.el @@ -0,0 +1,97 @@ +;;; syntax-tests.el --- Testing syntax rules and basic movement -*- lexical-binding: t -*- + +;; Copyright (C) 2014-2016 Free Software Foundation, Inc. + +;; Author: Daniel Colascione <dancol@dancol.org> +;; Keywords: + +;; 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/>. + +;;; Commentary: + +;; + +;;; Code: +(require 'ert) +(require 'cl-lib) + +(defun run-up-list-test (fn data start instructions) + (cl-labels ((posof (thing) + (and (symbolp thing) + (= (length (symbol-name thing)) 1) + (- (aref (symbol-name thing) 0) ?a -1)))) + (with-temp-buffer + (set-syntax-table (make-syntax-table)) + ;; Use a syntax table in which single quote is a string + ;; character so that we can embed the test data in a lisp string + ;; literal. + (modify-syntax-entry ?\' "\"") + (insert data) + (goto-char (posof start)) + (dolist (instruction instructions) + (cond ((posof instruction) + (funcall fn) + (should (eql (point) (posof instruction)))) + ((symbolp instruction) + (should-error (funcall fn) + :type instruction)) + (t (cl-assert nil nil "unknown ins"))))))) + +(defmacro define-up-list-test (name fn data start &rest expected) + `(ert-deftest ,name () + (run-up-list-test ,fn ,data ',start ',expected))) + +(define-up-list-test up-list-basic + (lambda () (up-list)) + (or "(1 1 (1 1) 1 (1 1) 1)") + ;; abcdefghijklmnopqrstuv + i k v scan-error) + +(define-up-list-test up-list-with-forward-sexp-function + (lambda () + (let ((forward-sexp-function + (lambda (&optional arg) + (let ((forward-sexp-function nil)) + (forward-sexp arg))))) + (up-list))) + (or "(1 1 (1 1) 1 (1 1) 1)") + ;; abcdefghijklmnopqrstuv + i k v scan-error) + +(define-up-list-test up-list-out-of-string + (lambda () (up-list 1 t)) + (or "1 (1 '2 2 (2 2 2' 1) 1") + ;; abcdefghijklmnopqrstuvwxy + o r u scan-error) + +(define-up-list-test up-list-cross-string + (lambda () (up-list 1 t)) + (or "(1 '2 ( 2' 1 '2 ) 2' 1)") + ;; abcdefghijklmnopqrstuvwxy + i r u x scan-error) + +(define-up-list-test up-list-no-cross-string + (lambda () (up-list 1 t t)) + (or "(1 '2 ( 2' 1 '2 ) 2' 1)") + ;; abcdefghijklmnopqrstuvwxy + i k x scan-error) + +(define-up-list-test backward-up-list-basic + (lambda () (backward-up-list)) + (or "(1 1 (1 1) 1 (1 1) 1)") + ;; abcdefghijklmnopqrstuv + i f a scan-error) + +(provide 'syntax-tests) +;;; syntax-tests.el ends here diff --git a/test/lisp/legacy/textprop-tests.el b/test/lisp/legacy/textprop-tests.el new file mode 100644 index 00000000000..397ef28c035 --- /dev/null +++ b/test/lisp/legacy/textprop-tests.el @@ -0,0 +1,69 @@ +;;; textprop-tests.el --- Test suite for text properties. + +;; Copyright (C) 2015-2016 Free Software Foundation, Inc. + +;; Author: Wolfgang Jenkner <wjenkner@inode.at> +;; Keywords: internal + +;; 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/>. + +;;; Code: + +(require 'ert) + +(ert-deftest textprop-tests-format () + "Test `format' with text properties." + ;; See Bug#21351. + (should (equal-including-properties + (format #("mouse-1, RET: %s -- w: copy %s" + 12 20 (face minibuffer-prompt) + 21 30 (face minibuffer-prompt)) + "visit" "link") + #("mouse-1, RET: visit -- w: copy link" + 12 23 (face minibuffer-prompt) + 24 35 (face minibuffer-prompt))))) + +(ert-deftest textprop-tests-font-lock--remove-face-from-text-property () + "Test `font-lock--remove-face-from-text-property'." + (let* ((string "foobar") + (stack (list string)) + (faces '(bold (:foreground "red") underline))) + ;; Build each string in `stack' by adding a face to the previous + ;; string. + (let ((faces (reverse faces))) + (push (copy-sequence (car stack)) stack) + (put-text-property 0 3 'font-lock-face (pop faces) (car stack)) + (push (copy-sequence (car stack)) stack) + (put-text-property 3 6 'font-lock-face (pop faces) (car stack)) + (push (copy-sequence (car stack)) stack) + (font-lock-prepend-text-property 2 5 + 'font-lock-face (pop faces) (car stack))) + ;; Check that removing the corresponding face from each string + ;; yields the previous string in `stack'. + (while faces + ;; (message "%S" (car stack)) + (should (equal-including-properties + (progn + (font-lock--remove-face-from-text-property 0 6 + 'font-lock-face + (pop faces) + (car stack)) + (pop stack)) + (car stack)))) + ;; Sanity check. + ;; (message "%S" (car stack)) + (should (and (equal-including-properties (pop stack) string) + (null stack))))) diff --git a/test/lisp/legacy/undo-tests.el b/test/lisp/legacy/undo-tests.el new file mode 100644 index 00000000000..b1c786993e8 --- /dev/null +++ b/test/lisp/legacy/undo-tests.el @@ -0,0 +1,448 @@ +;;; undo-tests.el --- Tests of primitive-undo + +;; Copyright (C) 2012-2016 Free Software Foundation, Inc. + +;; Author: Aaron S. Hawley <aaron.s.hawley@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/'. + +;;; Commentary: + +;; Profiling when the code was translate from C to Lisp on 2012-12-24. + +;;; C + +;; (elp-instrument-function 'primitive-undo) +;; (load-file "undo-test.elc") +;; (benchmark 100 '(let ((undo-test5-error nil)) (undo-test-all))) +;; Elapsed time: 305.218000s (104.841000s in 14804 GCs) +;; M-x elp-results +;; Function Name Call Count Elapsed Time Average Time +;; primitive-undo 2600 3.4889999999 0.0013419230 + +;;; Lisp + +;; (load-file "primundo.elc") +;; (elp-instrument-function 'primitive-undo) +;; (benchmark 100 '(undo-test-all)) +;; Elapsed time: 295.974000s (104.582000s in 14704 GCs) +;; M-x elp-results +;; Function Name Call Count Elapsed Time Average Time +;; primitive-undo 2700 3.6869999999 0.0013655555 + +;;; Code: + +(require 'ert) + +(ert-deftest undo-test0 () + "Test basics of \\[undo]." + (with-temp-buffer + (buffer-enable-undo) + (condition-case err + (undo) + (error + (unless (string= "No further undo information" + (cadr err)) + (error err)))) + (undo-boundary) + (insert "This") + (undo-boundary) + (erase-buffer) + (undo-boundary) + (insert "That") + (undo-boundary) + (forward-word -1) + (undo-boundary) + (insert "With ") + (undo-boundary) + (forward-word -1) + (undo-boundary) + (kill-word 1) + (undo-boundary) + (put-text-property (point-min) (point-max) 'face 'bold) + (undo-boundary) + (remove-text-properties (point-min) (point-max) '(face default)) + (undo-boundary) + (set-buffer-multibyte (not enable-multibyte-characters)) + (undo-boundary) + (undo) + (should + (equal (should-error (undo-more nil)) + '(wrong-type-argument number-or-marker-p nil))) + (undo-more 7) + (should (string-equal "" (buffer-string))))) + +(ert-deftest undo-test1 () + "Test undo of \\[undo] command (redo)." + (with-temp-buffer + (buffer-enable-undo) + (undo-boundary) + (insert "This") + (undo-boundary) + (erase-buffer) + (undo-boundary) + (insert "That") + (undo-boundary) + (forward-word -1) + (undo-boundary) + (insert "With ") + (undo-boundary) + (forward-word -1) + (undo-boundary) + (kill-word 1) + (undo-boundary) + (facemenu-add-face 'bold (point-min) (point-max)) + (undo-boundary) + (set-buffer-multibyte (not enable-multibyte-characters)) + (undo-boundary) + (should + (string-equal (buffer-string) + (progn + (undo) + (undo-more 4) + (undo) + ;(undo-more -4) + (buffer-string)))))) + +(ert-deftest undo-test2 () + "Test basic redoing with \\[undo] command." + (with-temp-buffer + (buffer-enable-undo) + (undo-boundary) + (insert "One") + (undo-boundary) + (insert " Zero") + (undo-boundary) + (push-mark nil t) + (delete-region (save-excursion + (forward-word -1) + (point)) (point)) + (undo-boundary) + (beginning-of-line) + (insert "Zero") + (undo-boundary) + (undo) + (should + (string-equal (buffer-string) + (progn + (undo-more 2) + (undo) + (buffer-string)))))) + +(ert-deftest undo-test4 () + "Test \\[undo] of \\[flush-lines]." + (with-temp-buffer + (buffer-enable-undo) + (dotimes (i 1048576) + (if (zerop (% i 2)) + (insert "Evenses") + (insert "Oddses"))) + (undo-boundary) + (should + ;; Avoid string-equal because ERT will save the `buffer-string' + ;; to the explanation. Using `not' will record nil or non-nil. + (not + (null + (string-equal (buffer-string) + (progn + (flush-lines "oddses" (point-min) (point-max)) + (undo-boundary) + (undo) + (undo) + (buffer-string)))))))) + +(ert-deftest undo-test5 () + "Test basic redoing with \\[undo] command." + (with-temp-buffer + (buffer-enable-undo) + (undo-boundary) + (insert "AYE") + (undo-boundary) + (insert " BEE") + (undo-boundary) + (setq buffer-undo-list (cons '(0.0 bogus) buffer-undo-list)) + (push-mark nil t) + (delete-region (save-excursion + (forward-word -1) + (point)) (point)) + (undo-boundary) + (beginning-of-line) + (insert "CEE") + (undo-boundary) + (undo) + (setq buffer-undo-list (cons "bogus" buffer-undo-list)) + (should + (string-equal + (buffer-string) + (progn + (if (and (boundp 'undo-test5-error) (not undo-test5-error)) + (progn + (should (null (undo-more 2))) + (should (undo))) + ;; Errors are generated by new Lisp version of + ;; `primitive-undo' not by built-in C version. + (should + (equal (should-error (undo-more 2)) + '(error "Unrecognized entry in undo list (0.0 bogus)"))) + (should + (equal (should-error (undo)) + '(error "Unrecognized entry in undo list \"bogus\"")))) + (buffer-string)))))) + +;; http://debbugs.gnu.org/14824 +(ert-deftest undo-test-buffer-modified () + "Test undoing marks buffer unmodified." + (with-temp-buffer + (buffer-enable-undo) + (insert "1") + (undo-boundary) + (set-buffer-modified-p nil) + (insert "2") + (undo) + (should-not (buffer-modified-p)))) + +(ert-deftest undo-test-file-modified () + "Test undoing marks buffer visiting file unmodified." + (let ((tempfile (make-temp-file "undo-test"))) + (unwind-protect + (progn + (with-current-buffer (find-file-noselect tempfile) + (insert "1") + (undo-boundary) + (set-buffer-modified-p nil) + (insert "2") + (undo) + (should-not (buffer-modified-p)))) + (delete-file tempfile)))) + +(ert-deftest undo-test-region-not-most-recent () + "Test undo in region of an edit not the most recent." + (with-temp-buffer + (buffer-enable-undo) + (transient-mark-mode 1) + (insert "1111") + (undo-boundary) + (goto-char 2) + (insert "2") + (forward-char 2) + (undo-boundary) + (insert "3") + (undo-boundary) + ;; Highlight around "2", not "3" + (push-mark (+ 3 (point-min)) t t) + (setq mark-active t) + (goto-char (point-min)) + (undo) + (should (string= (buffer-string) + "11131")))) + +(ert-deftest undo-test-region-deletion () + "Test undoing a deletion to demonstrate bug 17235." + (with-temp-buffer + (buffer-enable-undo) + (transient-mark-mode 1) + (insert "12345") + (search-backward "4") + (undo-boundary) + (delete-forward-char 1) + (search-backward "1") + (undo-boundary) + (insert "xxxx") + (undo-boundary) + (insert "yy") + (search-forward "35") + (undo-boundary) + ;; Select "35" + (push-mark (point) t t) + (setq mark-active t) + (forward-char -2) + (undo) ; Expect "4" to come back + (should (string= (buffer-string) + "xxxxyy12345")))) + +(ert-deftest undo-test-region-example () + "The same example test case described in comments for +undo-make-selective-list." + ;; buf pos: + ;; 123456789 buffer-undo-list undo-deltas + ;; --------- ---------------- ----------- + ;; aaa (1 . 4) (1 . -3) + ;; aaba (3 . 4) N/A (in region) + ;; ccaaba (1 . 3) (1 . -2) + ;; ccaabaddd (7 . 10) (7 . -3) + ;; ccaabdd ("ad" . 6) (6 . 2) + ;; ccaabaddd (6 . 8) (6 . -2) + ;; | |<-- region: "caab", from 2 to 6 + (with-temp-buffer + (buffer-enable-undo) + (transient-mark-mode 1) + (insert "aaa") + (goto-char 3) + (undo-boundary) + (insert "b") + (goto-char 1) + (undo-boundary) + (insert "cc") + (goto-char 7) + (undo-boundary) + (insert "ddd") + (search-backward "ad") + (undo-boundary) + (delete-forward-char 2) + (undo-boundary) + ;; Select "dd" + (push-mark (point) t t) + (setq mark-active t) + (goto-char (point-max)) + (undo) + (undo-boundary) + (should (string= (buffer-string) + "ccaabaddd")) + ;; Select "caab" + (push-mark 2 t t) + (setq mark-active t) + (goto-char 6) + (undo) + (undo-boundary) + (should (string= (buffer-string) + "ccaaaddd")))) + +(ert-deftest undo-test-region-eob () + "Test undo in region of a deletion at EOB, demonstrating bug 16411." + (with-temp-buffer + (buffer-enable-undo) + (transient-mark-mode 1) + (insert "This sentence corrupted?") + (undo-boundary) + ;; Same as recipe at + ;; http://debbugs.gnu.org/cgi/bugreport.cgi?bug=16411 + (insert "aaa") + (undo-boundary) + (undo) + ;; Select entire buffer + (push-mark (point) t t) + (setq mark-active t) + (goto-char (point-min)) + ;; Should undo the undo of "aaa", ie restore it. + (undo) + (should (string= (buffer-string) + "This sentence corrupted?aaa")))) + +(ert-deftest undo-test-marker-adjustment-nominal () + "Test nominal behavior of marker adjustments." + (with-temp-buffer + (buffer-enable-undo) + (insert "abcdefg") + (undo-boundary) + (let ((m (make-marker))) + (set-marker m 2 (current-buffer)) + (goto-char (point-min)) + (delete-forward-char 3) + (undo-boundary) + (should (= (point-min) (marker-position m))) + (undo) + (undo-boundary) + (should (= 2 (marker-position m)))))) + +(ert-deftest undo-test-region-t-marker () + "Test undo in region containing marker with t insertion-type." + (with-temp-buffer + (buffer-enable-undo) + (transient-mark-mode 1) + (insert "abcdefg") + (undo-boundary) + (let ((m (make-marker))) + (set-marker-insertion-type m t) + (set-marker m (point-min) (current-buffer)) ; m at a + (goto-char (+ 2 (point-min))) + (push-mark (point) t t) + (setq mark-active t) + (goto-char (point-min)) + (delete-forward-char 1) ;; delete region covering "ab" + (undo-boundary) + (should (= (point-min) (marker-position m))) + ;; Resurrect "ab". m's insertion type means the reinsertion + ;; moves it forward 2, and then the marker adjustment returns it + ;; to its rightful place. + (undo) + (undo-boundary) + (should (= (point-min) (marker-position m)))))) + +(ert-deftest undo-test-marker-adjustment-moved () + "Test marker adjustment behavior when the marker moves. +Demonstrates bug 16818." + (with-temp-buffer + (buffer-enable-undo) + (insert "abcdefghijk") + (undo-boundary) + (let ((m (make-marker))) + (set-marker m 2 (current-buffer)) ; m at b + (goto-char (point-min)) + (delete-forward-char 3) ; m at d + (undo-boundary) + (set-marker m 4) ; m at g + (undo) + (undo-boundary) + ;; m still at g, but shifted 3 because deletion undone + (should (= 7 (marker-position m)))))) + +(ert-deftest undo-test-region-mark-adjustment () + "Test that the mark's marker adjustment in undo history doesn't +obstruct undo in region from finding the correct change group. +Demonstrates bug 16818." + (with-temp-buffer + (buffer-enable-undo) + (transient-mark-mode 1) + (insert "First line\n") + (insert "Second line\n") + (undo-boundary) + + (goto-char (point-min)) + (insert "aaa") + (undo-boundary) + + (undo) + (undo-boundary) + + (goto-char (point-max)) + (insert "bbb") + (undo-boundary) + + (push-mark (point) t t) + (setq mark-active t) + (goto-char (- (point) 3)) + (delete-forward-char 1) + (undo-boundary) + + (insert "bbb") + (undo-boundary) + + (goto-char (point-min)) + (push-mark (point) t t) + (setq mark-active t) + (goto-char (+ (point) 3)) + (undo) + (undo-boundary) + + (should (string= (buffer-string) "aaaFirst line\nSecond line\nbbb")))) + +(defun undo-test-all (&optional interactive) + "Run all tests for \\[undo]." + (interactive "p") + (if interactive + (ert-run-tests-interactively "^undo-") + (ert-run-tests-batch "^undo-"))) + +(provide 'undo-tests) +;;; undo-tests.el ends here diff --git a/test/lisp/mail/rmail-tests.el b/test/lisp/mail/rmail-tests.el new file mode 100644 index 00000000000..ed481d05b8a --- /dev/null +++ b/test/lisp/mail/rmail-tests.el @@ -0,0 +1,35 @@ +;;; rmail-tests.el --- Test suite. -*- lexical-binding: t -*- + +;; Copyright (C) 2015 Free Software Foundation, Inc. + +;; 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/>. + +;;; Code: +(require 'ert) +(require 'rmail) + + +(ert-deftest rmail-autoload () + "Tests to see whether reftex-auc has been autoloaded" + (should + (fboundp 'rmail-edit-current-message)) + (should + (autoloadp + (symbol-function + 'rmail-edit-current-message)))) + +(provide 'rmail-tests) +;; rmail-tests.el ends here diff --git a/test/lisp/man-tests.el b/test/lisp/man-tests.el new file mode 100644 index 00000000000..b1cc4437256 --- /dev/null +++ b/test/lisp/man-tests.el @@ -0,0 +1,118 @@ +;;; man-tests.el --- Test suite for man. + +;; Copyright (C) 2013-2016 Free Software Foundation, Inc. + +;; Author: Wolfgang Jenkner <wjenkner@inode.at> +;; Keywords: help, internal, unix + +;; 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/>. + +;;; Code: + +(require 'ert) +(require 'man) + +(defconst man-tests-parse-man-k-tests + '(;; GNU/Linux: man-db-2.6.1 + ("\ +sin (3) - sine function +sinf (3) - sine function +sinl (3) - sine function" + . (#("sin(3)" 0 6 (help-echo "sine function")) #("sinf(3)" 0 7 (help-echo "sine function")) #("sinl(3)" 0 7 (help-echo "sine function")))) + ;; GNU/Linux: man-1.6g + ("\ +sin (3) - sine function +sinf [sin] (3) - sine function +sinl [sin] (3) - sine function" + . (#("sin(3)" 0 6 (help-echo "sine function")) #("sinf(3)" 0 7 (help-echo "sine function")) #("sinl(3)" 0 7 (help-echo "sine function")))) + ;; FreeBSD 9 + ("\ +sin(3), sinf(3), sinl(3) - sine functions" + . (#("sin(3)" 0 6 (help-echo "sine functions")) #("sinf(3)" 0 7 (help-echo "sine functions")) #("sinl(3)" 0 7 (help-echo "sine functions")))) + ;; SunOS, Solaris + ;; http://docs.oracle.com/cd/E19455-01/805-6331/usradm-7/index.html + ;; SunOS 4 + ("\ +tset, reset (1) - establish or restore terminal characteristics" + . (#("tset(1)" 0 7 (help-echo "establish or restore terminal characteristics")) #("reset(1)" 0 8 (help-echo "establish or restore terminal characteristics")))) + ;; SunOS 5.7, Solaris + ("\ +reset tset (1b) - establish or restore terminal characteristics +tset tset (1b) - establish or restore terminal characteristics" + . (#("reset(1b)" 0 8 (help-echo "establish or restore terminal characteristics")) #("tset(1b)" 0 7 (help-echo "establish or restore terminal characteristics")))) + ;; Minix 3 + ;; http://www.minix3.org/manpages/html5/whatis.html + ("\ +cawf, nroff (1) - C version of the nroff-like, Amazingly Workable (text) Formatter +whatis (5) - database of online manual pages" + . (#("cawf(1)" 0 7 (help-echo "C version of the nroff-like, Amazingly Workable (text) Formatter")) #("nroff(1)" 0 8 (help-echo "C version of the nroff-like, Amazingly Workable (text) Formatter")) #("whatis(5)" 0 9 (help-echo "database of online manual pages")))) + ;; HP-UX + ;; http://docstore.mik.ua/manuals/hp-ux/en/B2355-60130/man.1.html + ;; Assuming that the line break in the zgrep description was + ;; introduced by the man page formatting. + ("\ +grep, egrep, fgrep (1) - search a file for a pattern +zgrep(1) - search possibly compressed files for a regular expression" + . (#("grep(1)" 0 7 (help-echo "search a file for a pattern")) #("egrep(1)" 0 8 (help-echo "search a file for a pattern")) #("fgrep(1)" 0 8 (help-echo "search a file for a pattern")) #("zgrep(1)" 0 8 (help-echo "search possibly compressed files for a regular expression")))) + ;; AIX + ;; http://pic.dhe.ibm.com/infocenter/aix/v7r1/topic/com.ibm.aix.cmds/doc/aixcmds6/whatis.htm + ("\ +ls(1) -Displays the contents of a directory." + . (#("ls(1)" 0 5 (help-echo "Displays the contents of a directory.")))) + ;; https://www.ibm.com/developerworks/mydeveloperworks/blogs/cgaix/entry/catman_0703_102_usr_lbin_mkwhatis_the_error_number_is_1?lang=en + ("\ +loopmount(1) - Associate an image file to a loopback device." + . (#("loopmount(1)" 0 12 (help-echo "Associate an image file to a loopback device.")))) + ) + "List of tests for `Man-parse-man-k'. +Each element is a cons cell whose car is a string containing +man -k output. That should result in the table which is stored +in the cdr of the element.") + +(defun man-tests-name-equal-p (name description string) + (and (equal name string) + (not (next-single-property-change 0 'help-echo string)) + (equal (get-text-property 0 'help-echo string) description))) + +(defun man-tests-parse-man-k-test-case (test) + (let ((temp-buffer (get-buffer-create " *test-man*")) + (man-k-output (car test))) + (unwind-protect + (save-window-excursion + (with-current-buffer temp-buffer + (erase-buffer) + (insert man-k-output) + (let ((result (Man-parse-man-k)) + (checklist (cdr test))) + (while (and checklist result + (man-tests-name-equal-p + (car checklist) + (get-text-property 0 'help-echo + (car checklist)) + (pop result))) + (pop checklist)) + (and (null checklist) (null result))))) + (and (buffer-name temp-buffer) + (kill-buffer temp-buffer))))) + +(ert-deftest man-tests () + "Test man." + (dolist (test man-tests-parse-man-k-tests) + (should (man-tests-parse-man-k-test-case test)))) + +(provide 'man-tests) + +;;; man-tests.el ends here diff --git a/test/lisp/minibuffer-tests.el b/test/lisp/minibuffer-tests.el new file mode 100644 index 00000000000..0f2abf45673 --- /dev/null +++ b/test/lisp/minibuffer-tests.el @@ -0,0 +1,46 @@ +;;; completion-tests.el --- Tests for completion functions -*- lexical-binding: t; -*- + +;; Copyright (C) 2013-2016 Free Software Foundation, Inc. + +;; Author: Stefan Monnier <monnier@iro.umontreal.ca> +;; Keywords: + +;; 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/>. + +;;; Commentary: + +;; + +;;; Code: + +(eval-when-compile (require 'cl-lib)) + +(ert-deftest completion-test1 () + (with-temp-buffer + (cl-flet* ((test/completion-table (string pred action) + (if (eq action 'lambda) + nil + "test: ")) + (test/completion-at-point () + (list (copy-marker (point-min)) + (copy-marker (point)) + #'test/completion-table))) + (let ((completion-at-point-functions (list #'test/completion-at-point))) + (insert "TEST") + (completion-at-point) + (should (equal (buffer-string) + "test: ")))))) + +(provide 'completion-tests) +;;; completion-tests.el ends here diff --git a/test/lisp/net/dbus-tests.el b/test/lisp/net/dbus-tests.el new file mode 100644 index 00000000000..12be1637109 --- /dev/null +++ b/test/lisp/net/dbus-tests.el @@ -0,0 +1,182 @@ +;;; dbus-tests.el --- Tests of D-Bus integration into Emacs + +;; Copyright (C) 2013-2016 Free Software Foundation, Inc. + +;; Author: Michael Albinus <michael.albinus@gmx.de> + +;; 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 'dbus) + +(setq dbus-debug nil) + +(defvar dbus--test-enabled-session-bus + (and (featurep 'dbusbind) + (dbus-ignore-errors (dbus-get-unique-name :session))) + "Check, whether we are registered at the session bus.") + +(defvar dbus--test-enabled-system-bus + (and (featurep 'dbusbind) + (dbus-ignore-errors (dbus-get-unique-name :system))) + "Check, whether we are registered at the system bus.") + +(defun dbus--test-availability (bus) + "Test availability of D-Bus BUS." + (should (dbus-list-names bus)) + (should (dbus-list-activatable-names bus)) + (should (dbus-list-known-names bus)) + (should (dbus-get-unique-name bus))) + +(ert-deftest dbus-test00-availability-session () + "Test availability of D-Bus `:session'." + :expected-result (if dbus--test-enabled-session-bus :passed :failed) + (dbus--test-availability :session)) + +(ert-deftest dbus-test00-availability-system () + "Test availability of D-Bus `:system'." + :expected-result (if dbus--test-enabled-system-bus :passed :failed) + (dbus--test-availability :system)) + +(ert-deftest dbus-test01-type-conversion () + "Check type conversion functions." + (let ((ustr "0123abc_xyz\x01\xff") + (mstr "Grüß Göttin")) + (should + (string-equal + (dbus-byte-array-to-string (dbus-string-to-byte-array "")) "")) + (should + (string-equal + (dbus-byte-array-to-string (dbus-string-to-byte-array ustr)) ustr)) + (should + (string-equal + (dbus-byte-array-to-string (dbus-string-to-byte-array mstr) 'multibyte) + mstr)) + ;; Should not work for multibyte strings. + (should-not + (string-equal + (dbus-byte-array-to-string (dbus-string-to-byte-array mstr)) mstr)) + + (should + (string-equal + (dbus-unescape-from-identifier (dbus-escape-as-identifier "")) "")) + (should + (string-equal + (dbus-unescape-from-identifier (dbus-escape-as-identifier ustr)) ustr)) + ;; Should not work for multibyte strings. + (should-not + (string-equal + (dbus-unescape-from-identifier (dbus-escape-as-identifier mstr)) mstr)))) + +(defun dbus--test-register-service (bus) + "Check service registration at BUS." + ;; Cleanup. + (dbus-ignore-errors (dbus-unregister-service bus dbus-service-emacs)) + + ;; Register an own service. + (should (eq (dbus-register-service bus dbus-service-emacs) :primary-owner)) + (should (member dbus-service-emacs (dbus-list-known-names bus))) + (should (eq (dbus-register-service bus dbus-service-emacs) :already-owner)) + (should (member dbus-service-emacs (dbus-list-known-names bus))) + + ;; Unregister the service. + (should (eq (dbus-unregister-service bus dbus-service-emacs) :released)) + (should-not (member dbus-service-emacs (dbus-list-known-names bus))) + (should (eq (dbus-unregister-service bus dbus-service-emacs) :non-existent)) + (should-not (member dbus-service-emacs (dbus-list-known-names bus))) + + ;; `dbus-service-dbus' is reserved for the BUS itself. + (should-error (dbus-register-service bus dbus-service-dbus)) + (should-error (dbus-unregister-service bus dbus-service-dbus))) + +(ert-deftest dbus-test02-register-service-session () + "Check service registration at `:session' bus." + (skip-unless (and dbus--test-enabled-session-bus + (dbus-register-service :session dbus-service-emacs))) + (dbus--test-register-service :session) + + (let ((service "org.freedesktop.Notifications")) + (when (member service (dbus-list-known-names :session)) + ;; Cleanup. + (dbus-ignore-errors (dbus-unregister-service :session service)) + + (should (eq (dbus-register-service :session service) :in-queue)) + (should (eq (dbus-unregister-service :session service) :released)) + + (should + (eq (dbus-register-service :session service :do-not-queue) :exists)) + (should (eq (dbus-unregister-service :session service) :not-owner))))) + +(ert-deftest dbus-test02-register-service-system () + "Check service registration at `:system' bus." + (skip-unless (and dbus--test-enabled-system-bus + (dbus-register-service :system dbus-service-emacs))) + (dbus--test-register-service :system)) + +(ert-deftest dbus-test02-register-service-own-bus () + "Check service registration with an own bus. +This includes initialization and closing the bus." + ;; Start bus. + (let ((output + (ignore-errors + (shell-command-to-string "dbus-launch --sh-syntax"))) + bus pid) + (skip-unless (stringp output)) + (when (string-match "DBUS_SESSION_BUS_ADDRESS='\\(.+\\)';" output) + (setq bus (match-string 1 output))) + (when (string-match "DBUS_SESSION_BUS_PID=\\([[:digit:]]+\\);" output) + (setq pid (match-string 1 output))) + (unwind-protect + (progn + (skip-unless + (dbus-ignore-errors + (and bus pid + (featurep 'dbusbind) + (dbus-init-bus bus) + (dbus-get-unique-name bus) + (dbus-register-service bus dbus-service-emacs)))) + ;; Run the test. + (dbus--test-register-service bus)) + + ;; Save exit. + (when pid (call-process "kill" nil nil nil pid))))) + +(ert-deftest dbus-test03-peer-interface () + "Check `dbus-interface-peer' methods." + (skip-unless + (and dbus--test-enabled-session-bus + (dbus-register-service :session dbus-service-emacs) + ;; "GetMachineId" is not implemented (yet). When it returns a + ;; value, another D-Bus client like dbus-monitor is reacting + ;; on `dbus-interface-peer'. We cannot test then. + (not + (dbus-ignore-errors + (dbus-call-method + :session dbus-service-emacs dbus-path-dbus + dbus-interface-peer "GetMachineId" :timeout 100))))) + + (should (dbus-ping :session dbus-service-emacs 100)) + (dbus-unregister-service :session dbus-service-emacs) + (should-not (dbus-ping :session dbus-service-emacs 100))) + +(defun dbus-test-all (&optional interactive) + "Run all tests for \\[dbus]." + (interactive "p") + (funcall + (if interactive 'ert-run-tests-interactively 'ert-run-tests-batch) "^dbus")) + +(provide 'dbus-tests) +;;; dbus-tests.el ends here diff --git a/test/lisp/net/newsticker-tests.el b/test/lisp/net/newsticker-tests.el new file mode 100644 index 00000000000..d8531083e60 --- /dev/null +++ b/test/lisp/net/newsticker-tests.el @@ -0,0 +1,168 @@ +;;; newsticker-testsuite.el --- Test suite for newsticker. + +;; Copyright (C) 2003-2016 Free Software Foundation, Inc. + +;; Author: Ulf Jasper <ulf.jasper@web.de> +;; Keywords: News, RSS, Atom + +;; 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: + +;;; Code: + +(require 'ert) +(require 'newsticker) + +;; ====================================================================== +;; Tests for newsticker-backend +;; ====================================================================== +(ert-deftest newsticker--guid () + "Test for `newsticker--guid-*'. +Signals an error if something goes wrong." + (should (string= "blah" (newsticker--guid-to-string "blah"))) + (should (string= "myguid" (newsticker--guid '("title1" "description1" "link1" + nil 'new 42 nil nil + ((guid () "myguid"))))))) + +(ert-deftest newsticker--cache-contains () + "Test for `newsticker--cache-contains'." + (let ((newsticker--cache '((feed1 + ("title1" "description1" "link1" nil 'new 42 + nil nil ((guid () "myguid"))))))) + (newsticker--guid-to-string + (assoc 'guid (newsticker--extra '("title1" "description1" + "link1" nil 'new 42 nil nil + ((guid "myguid")))))) + (should (newsticker--cache-contains newsticker--cache 'feed1 "WRONGTITLE" + "description1" "link1" 'new "myguid")) + (should (not (newsticker--cache-contains newsticker--cache 'feed1 "title1" + "description1" "link1" 'new + "WRONG GUID"))) + (should (newsticker--cache-contains newsticker--cache 'feed1 "title1" + "description1" "link1" 'new "myguid"))) + (let ((newsticker--cache '((feed1 + ("title1" "description1" "link1" nil 'new 42 + nil nil ((guid () "myguid1"))) + ("title1" "description1" "link1" nil 'new 42 + nil nil ((guid () "myguid2"))))))) + (should (not (newsticker--cache-contains newsticker--cache 'feed1 "title1" + "description1" "link1" 'new + "myguid"))) + (should (string= "myguid1" + (newsticker--guid (newsticker--cache-contains + newsticker--cache 'feed1 "title1" + "description1" "link1" 'new + "myguid1")))) + (should (string= "myguid2" + (newsticker--guid (newsticker--cache-contains + newsticker--cache 'feed1 "title1" + "description1" "link1" 'new + "myguid2")))))) + +(defun newsticker-tests--decode-iso8601-date (input expected) + "Actually test `newsticker--decode-iso8601-date'. +Apply to INPUT and compare with EXPECTED." + (let ((result (format-time-string "%Y-%m-%dT%H:%M:%S" + (newsticker--decode-iso8601-date input) + t))) + (should (string= result expected)))) + +(ert-deftest newsticker--decode-iso8601-date () + "Test `newsticker--decode-iso8601-date'." + (newsticker-tests--decode-iso8601-date "2004" + "2004-01-01T00:00:00") + (newsticker-tests--decode-iso8601-date "2004-09" + "2004-09-01T00:00:00") + (newsticker-tests--decode-iso8601-date "2004-09-17" + "2004-09-17T00:00:00") + (newsticker-tests--decode-iso8601-date "2004-09-17T05:09" + "2004-09-17T05:09:00") + (newsticker-tests--decode-iso8601-date "2004-09-17T05:09:49" + "2004-09-17T05:09:49") + (newsticker-tests--decode-iso8601-date "2004-09-17T05:09:49.123" + "2004-09-17T05:09:49") + (newsticker-tests--decode-iso8601-date "2004-09-17T05:09+01:00" + "2004-09-17T04:09:00") + (newsticker-tests--decode-iso8601-date "2004-09-17T05:09-02:00" + "2004-09-17T07:09:00")) + +(defun newsticker--do-test--decode-rfc822-date (input expected) + "Actually test `newsticker--decode-rfc822-date'. +Apply to INPUT and compare with EXPECTED." + (let ((result (format-time-string "%Y-%m-%dT%H:%M:%S" + (newsticker--decode-rfc822-date input) + t))) + (should (string= result expected)))) + +(ert-deftest newsticker--decode-rfc822-date () + "Test `newsticker--decode-rfc822-date'." + (newsticker--do-test--decode-rfc822-date "Mon, 10 Mar 2008 19:27:52 +0100" + "2008-03-10T18:27:52") + ;;(format-time-string "%d.%m.%y, %H:%M %T%z" + ;;(newsticker--decode-rfc822-date "Mon, 10 Mar 2008 19:27:52 +0200")) + + (newsticker--do-test--decode-rfc822-date "Mon, 10 Mar 2008 19:27:52" + "2008-03-10T19:27:52") + (newsticker--do-test--decode-rfc822-date "Mon, 10 Mar 2008 19:27" + "2008-03-10T19:27:00") + (newsticker--do-test--decode-rfc822-date "10 Mar 2008 19:27" + "2008-03-10T19:27:00") + (newsticker--do-test--decode-rfc822-date "Mon, 10 Mar 2008" + "2008-03-10T00:00:00") + (newsticker--do-test--decode-rfc822-date "10 Mar 2008" + "2008-03-10T00:00:00") + (newsticker--do-test--decode-rfc822-date "Sat, 01 Dec 2007 00:05:00 +0100" + "2007-11-30T23:05:00") + (newsticker--do-test--decode-rfc822-date "Sun, 30 Dec 2007 18:58:13 +0100" + "2007-12-30T17:58:13")) + +;; ====================================================================== +;; Tests for newsticker-treeview +;; ====================================================================== +(ert-deftest newsticker--group-manage-orphan-feeds () + "Test `newsticker--group-manage-orphan-feeds'. +Signals an error if something goes wrong." + (let ((newsticker-groups '("Feeds")) + (newsticker-url-list-defaults nil) + (newsticker-url-list '(("feed1") ("feed2") ("feed3")))) + (newsticker--group-manage-orphan-feeds) + (should (equal '("Feeds" "feed3" "feed2" "feed1") + newsticker-groups)))) + +(ert-deftest newsticker--group-find-parent-group () + "Test `newsticker--group-find-parent-group'." + (let ((newsticker-groups '("g1" "f1a" ("g2" "f2" ("g3" "f3a" "f3b")) "f1b"))) + ;; feeds + (should (equal "g1" (car (newsticker--group-find-parent-group "f1a")))) + (should (equal "g1" (car (newsticker--group-find-parent-group "f1b")))) + (should (equal "g2" (car (newsticker--group-find-parent-group "f2")))) + (should (equal "g3" (car (newsticker--group-find-parent-group "f3b")))) + ;; groups + (should (equal "g1" (car (newsticker--group-find-parent-group "g2")))) + (should (equal "g2" (car (newsticker--group-find-parent-group "g3")))))) + +(ert-deftest newsticker--group-do-rename-group () + "Test `newsticker--group-do-rename-group'." + (let ((newsticker-groups '("g1" "f1a" ("g2" "f2" ("g3" "f3a" "f3b")) "f1b"))) + (should (equal '("g1" "f1a" ("h2" "f2" ("g3" "f3a" "f3b")) "f1b") + (newsticker--group-do-rename-group "g2" "h2"))) + )) + + +(provide 'newsticker-tests) + +;;; newsticker-tests.el ends here diff --git a/test/lisp/net/sasl-scram-rfc-tests.el b/test/lisp/net/sasl-scram-rfc-tests.el new file mode 100644 index 00000000000..130de240481 --- /dev/null +++ b/test/lisp/net/sasl-scram-rfc-tests.el @@ -0,0 +1,50 @@ +;;; sasl-scram-rfc-tests.el --- tests for SCRAM-SHA-1 -*- lexical-binding: t; -*- + +;; Copyright (C) 2014-2016 Free Software Foundation, Inc. + +;; Author: Magnus Henoch <magnus.henoch@gmail.com> + +;; 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: + +;; Test cases from RFC 5802. + +;;; Code: + +(require 'sasl) +(require 'sasl-scram-rfc) + +(ert-deftest sasl-scram-sha-1-test () + ;; The following strings are taken from section 5 of RFC 5802. + (let ((client + (sasl-make-client (sasl-find-mechanism '("SCRAM-SHA-1")) + "user" + "imap" + "localhost")) + (data "r=fyko+d2lbbFgONRv9qkxdawL3rfcNHYJY1ZVvWVs7j,s=QSXCR+Q6sek8bf92,i=4096") + (c-nonce "fyko+d2lbbFgONRv9qkxdawL") + (sasl-read-passphrase + (lambda (_prompt) (copy-sequence "pencil")))) + (sasl-client-set-property client 'c-nonce c-nonce) + (should + (equal + (sasl-scram-sha-1-client-final-message client (vector nil data)) + "c=biws,r=fyko+d2lbbFgONRv9qkxdawL3rfcNHYJY1ZVvWVs7j,p=v0X8v3Bz2T0CJGbJQyF0X+HI4Ts=")) + + ;; This should not throw an error: + (sasl-scram-sha-1-authenticate-server client (vector nil "v=rmF9pqV8S7suAoZWja4dJRkFsKQ= +")))) + +;;; sasl-scram-rfc-tests.el ends here diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el new file mode 100644 index 00000000000..5938ada8486 --- /dev/null +++ b/test/lisp/net/tramp-tests.el @@ -0,0 +1,2280 @@ +;;; tramp-tests.el --- Tests of remote file access + +;; Copyright (C) 2013-2016 Free Software Foundation, Inc. + +;; Author: Michael Albinus <michael.albinus@gmx.de> + +;; 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/'. + +;;; Commentary: + +;; The tests require a recent ert.el from Emacs 24.4. + +;; Some of the tests require access to a remote host files. Since +;; this could be problematic, a mock-up connection method "mock" is +;; used. Emulating a remote connection, it simply calls "sh -i". +;; Tramp's file name handlers still run, so this test is sufficient +;; except for connection establishing. + +;; If you want to test a real Tramp connection, set +;; $REMOTE_TEMPORARY_FILE_DIRECTORY to a suitable value in order to +;; overwrite the default value. If you want to skip tests accessing a +;; remote host, set this environment variable to "/dev/null" or +;; whatever is appropriate on your system. + +;; A whole test run can be performed calling the command `tramp-test-all'. + +;;; Code: + +(require 'ert) +(require 'tramp) +(require 'vc) +(require 'vc-bzr) +(require 'vc-git) +(require 'vc-hg) + +(declare-function tramp-find-executable "tramp-sh") +(declare-function tramp-get-remote-path "tramp-sh") +(declare-function tramp-get-remote-stat "tramp-sh") +(declare-function tramp-get-remote-perl "tramp-sh") +(defvar tramp-copy-size-limit) +(defvar tramp-persistency-file-name) +(defvar tramp-remote-process-environment) + +;; There is no default value on w32 systems, which could work out of the box. +(defconst tramp-test-temporary-file-directory + (cond + ((getenv "REMOTE_TEMPORARY_FILE_DIRECTORY")) + ((eq system-type 'windows-nt) null-device) + (t (add-to-list + 'tramp-methods + '("mock" + (tramp-login-program "sh") + (tramp-login-args (("-i"))) + (tramp-remote-shell "/bin/sh") + (tramp-remote-shell-args ("-c")) + (tramp-connection-timeout 10))) + (format "/mock::%s" temporary-file-directory))) + "Temporary directory for Tramp tests.") + +(setq password-cache-expiry nil + tramp-verbose 0 + tramp-copy-size-limit nil + tramp-message-show-message nil + tramp-persistency-file-name nil) + +;; This shall happen on hydra only. +(when (getenv "NIX_STORE") + (add-to-list 'tramp-remote-path 'tramp-own-remote-path)) + +(defvar tramp--test-enabled-checked nil + "Cached result of `tramp--test-enabled'. +If the function did run, the value is a cons cell, the `cdr' +being the result.") + +(defun tramp--test-enabled () + "Whether remote file access is enabled." + (unless (consp tramp--test-enabled-checked) + (setq + tramp--test-enabled-checked + (cons + t (ignore-errors + (and + (file-remote-p tramp-test-temporary-file-directory) + (file-directory-p tramp-test-temporary-file-directory) + (file-writable-p tramp-test-temporary-file-directory)))))) + + (when (cdr tramp--test-enabled-checked) + ;; Cleanup connection. + (ignore-errors + (tramp-cleanup-connection + (tramp-dissect-file-name tramp-test-temporary-file-directory) + nil 'keep-password))) + + ;; Return result. + (cdr tramp--test-enabled-checked)) + +(defun tramp--test-make-temp-name (&optional local) + "Create a temporary file name for test." + (expand-file-name + (make-temp-name "tramp-test") + (if local temporary-file-directory tramp-test-temporary-file-directory))) + +(defmacro tramp--instrument-test-case (verbose &rest body) + "Run BODY with `tramp-verbose' equal VERBOSE. +Print the the content of the Tramp debug buffer, if BODY does not +eval properly in `should', `should-not' or `should-error'. BODY +shall not contain a timeout." + (declare (indent 1) (debug (natnump body))) + `(let ((tramp-verbose ,verbose) + (tramp-message-show-message t) + (tramp-debug-on-error t) + (debug-ignored-errors + (cons "^make-symbolic-link not supported$" debug-ignored-errors))) + (unwind-protect + (progn ,@body) + (when (> tramp-verbose 3) + (with-parsed-tramp-file-name tramp-test-temporary-file-directory nil + (with-current-buffer (tramp-get-connection-buffer v) + (message "%s" (buffer-string))) + (with-current-buffer (tramp-get-debug-buffer v) + (message "%s" (buffer-string)))))))) + +(ert-deftest tramp-test00-availability () + "Test availability of Tramp functions." + :expected-result (if (tramp--test-enabled) :passed :failed) + (message "Remote directory: `%s'" tramp-test-temporary-file-directory) + (should (ignore-errors + (and + (file-remote-p tramp-test-temporary-file-directory) + (file-directory-p tramp-test-temporary-file-directory) + (file-writable-p tramp-test-temporary-file-directory))))) + +(ert-deftest tramp-test01-file-name-syntax () + "Check remote file name syntax." + ;; Simple cases. + (should (tramp-tramp-file-p "/method::")) + (should (tramp-tramp-file-p "/host:")) + (should (tramp-tramp-file-p "/user@:")) + (should (tramp-tramp-file-p "/user@host:")) + (should (tramp-tramp-file-p "/method:host:")) + (should (tramp-tramp-file-p "/method:user@:")) + (should (tramp-tramp-file-p "/method:user@host:")) + (should (tramp-tramp-file-p "/method:user@email@host:")) + + ;; Using a port. + (should (tramp-tramp-file-p "/host#1234:")) + (should (tramp-tramp-file-p "/user@host#1234:")) + (should (tramp-tramp-file-p "/method:host#1234:")) + (should (tramp-tramp-file-p "/method:user@host#1234:")) + + ;; Using an IPv4 address. + (should (tramp-tramp-file-p "/1.2.3.4:")) + (should (tramp-tramp-file-p "/user@1.2.3.4:")) + (should (tramp-tramp-file-p "/method:1.2.3.4:")) + (should (tramp-tramp-file-p "/method:user@1.2.3.4:")) + + ;; Using an IPv6 address. + (should (tramp-tramp-file-p "/[]:")) + (should (tramp-tramp-file-p "/[::1]:")) + (should (tramp-tramp-file-p "/user@[::1]:")) + (should (tramp-tramp-file-p "/method:[::1]:")) + (should (tramp-tramp-file-p "/method:user@[::1]:")) + + ;; Local file name part. + (should (tramp-tramp-file-p "/host:/:")) + (should (tramp-tramp-file-p "/method:::")) + (should (tramp-tramp-file-p "/method::/path/to/file")) + (should (tramp-tramp-file-p "/method::file")) + + ;; Multihop. + (should (tramp-tramp-file-p "/method1:|method2::")) + (should (tramp-tramp-file-p "/method1:host1|host2:")) + (should (tramp-tramp-file-p "/method1:host1|method2:host2:")) + (should (tramp-tramp-file-p "/method1:user1@host1|method2:user2@host2:")) + (should (tramp-tramp-file-p + "/method1:user1@host1|method2:user2@host2|method3:user3@host3:")) + + ;; No strings. + (should-not (tramp-tramp-file-p nil)) + (should-not (tramp-tramp-file-p 'symbol)) + ;; "/:" suppresses file name handlers. + (should-not (tramp-tramp-file-p "/::")) + (should-not (tramp-tramp-file-p "/:@:")) + (should-not (tramp-tramp-file-p "/:[]:")) + ;; Multihops require a method. + (should-not (tramp-tramp-file-p "/host1|host2:")) + ;; Methods or hostnames shall be at least two characters on MS Windows. + (when (memq system-type '(cygwin windows-nt)) + (should-not (tramp-tramp-file-p "/c:/path/to/file")) + (should-not (tramp-tramp-file-p "/c::/path/to/file")))) + +(ert-deftest tramp-test02-file-name-dissect () + "Check remote file name components." + (let ((tramp-default-method "default-method") + (tramp-default-user "default-user") + (tramp-default-host "default-host")) + ;; Expand `tramp-default-user' and `tramp-default-host'. + (should (string-equal + (file-remote-p "/method::") + (format "/%s:%s@%s:" "method" "default-user" "default-host"))) + (should (string-equal (file-remote-p "/method::" 'method) "method")) + (should (string-equal (file-remote-p "/method::" 'user) "default-user")) + (should (string-equal (file-remote-p "/method::" 'host) "default-host")) + (should (string-equal (file-remote-p "/method::" 'localname) "")) + (should (string-equal (file-remote-p "/method::" 'hop) nil)) + + ;; Expand `tramp-default-method' and `tramp-default-user'. + (should (string-equal + (file-remote-p "/host:") + (format "/%s:%s@%s:" "default-method" "default-user" "host"))) + (should (string-equal (file-remote-p "/host:" 'method) "default-method")) + (should (string-equal (file-remote-p "/host:" 'user) "default-user")) + (should (string-equal (file-remote-p "/host:" 'host) "host")) + (should (string-equal (file-remote-p "/host:" 'localname) "")) + (should (string-equal (file-remote-p "/host:" 'hop) nil)) + + ;; Expand `tramp-default-method' and `tramp-default-host'. + (should (string-equal + (file-remote-p "/user@:") + (format "/%s:%s@%s:" "default-method""user" "default-host"))) + (should (string-equal (file-remote-p "/user@:" 'method) "default-method")) + (should (string-equal (file-remote-p "/user@:" 'user) "user")) + (should (string-equal (file-remote-p "/user@:" 'host) "default-host")) + (should (string-equal (file-remote-p "/user@:" 'localname) "")) + (should (string-equal (file-remote-p "/user@:" 'hop) nil)) + + ;; Expand `tramp-default-method'. + (should (string-equal + (file-remote-p "/user@host:") + (format "/%s:%s@%s:" "default-method" "user" "host"))) + (should (string-equal + (file-remote-p "/user@host:" 'method) "default-method")) + (should (string-equal (file-remote-p "/user@host:" 'user) "user")) + (should (string-equal (file-remote-p "/user@host:" 'host) "host")) + (should (string-equal (file-remote-p "/user@host:" 'localname) "")) + (should (string-equal (file-remote-p "/user@host:" 'hop) nil)) + + ;; Expand `tramp-default-user'. + (should (string-equal + (file-remote-p "/method:host:") + (format "/%s:%s@%s:" "method" "default-user" "host"))) + (should (string-equal (file-remote-p "/method:host:" 'method) "method")) + (should (string-equal (file-remote-p "/method:host:" 'user) "default-user")) + (should (string-equal (file-remote-p "/method:host:" 'host) "host")) + (should (string-equal (file-remote-p "/method:host:" 'localname) "")) + (should (string-equal (file-remote-p "/method:host:" 'hop) nil)) + + ;; Expand `tramp-default-host'. + (should (string-equal + (file-remote-p "/method:user@:") + (format "/%s:%s@%s:" "method" "user" "default-host"))) + (should (string-equal (file-remote-p "/method:user@:" 'method) "method")) + (should (string-equal (file-remote-p "/method:user@:" 'user) "user")) + (should (string-equal (file-remote-p "/method:user@:" 'host) + "default-host")) + (should (string-equal (file-remote-p "/method:user@:" 'localname) "")) + (should (string-equal (file-remote-p "/method:user@:" 'hop) nil)) + + ;; No expansion. + (should (string-equal + (file-remote-p "/method:user@host:") + (format "/%s:%s@%s:" "method" "user" "host"))) + (should (string-equal + (file-remote-p "/method:user@host:" 'method) "method")) + (should (string-equal (file-remote-p "/method:user@host:" 'user) "user")) + (should (string-equal (file-remote-p "/method:user@host:" 'host) "host")) + (should (string-equal (file-remote-p "/method:user@host:" 'localname) "")) + (should (string-equal (file-remote-p "/method:user@host:" 'hop) nil)) + + ;; No expansion. + (should (string-equal + (file-remote-p "/method:user@email@host:") + (format "/%s:%s@%s:" "method" "user@email" "host"))) + (should (string-equal + (file-remote-p "/method:user@email@host:" 'method) "method")) + (should (string-equal + (file-remote-p "/method:user@email@host:" 'user) "user@email")) + (should (string-equal + (file-remote-p "/method:user@email@host:" 'host) "host")) + (should (string-equal + (file-remote-p "/method:user@email@host:" 'localname) "")) + (should (string-equal + (file-remote-p "/method:user@email@host:" 'hop) nil)) + + ;; Expand `tramp-default-method' and `tramp-default-user'. + (should (string-equal + (file-remote-p "/host#1234:") + (format "/%s:%s@%s:" "default-method" "default-user" "host#1234"))) + (should (string-equal + (file-remote-p "/host#1234:" 'method) "default-method")) + (should (string-equal (file-remote-p "/host#1234:" 'user) "default-user")) + (should (string-equal (file-remote-p "/host#1234:" 'host) "host#1234")) + (should (string-equal (file-remote-p "/host#1234:" 'localname) "")) + (should (string-equal (file-remote-p "/host#1234:" 'hop) nil)) + + ;; Expand `tramp-default-method'. + (should (string-equal + (file-remote-p "/user@host#1234:") + (format "/%s:%s@%s:" "default-method" "user" "host#1234"))) + (should (string-equal + (file-remote-p "/user@host#1234:" 'method) "default-method")) + (should (string-equal (file-remote-p "/user@host#1234:" 'user) "user")) + (should (string-equal (file-remote-p "/user@host#1234:" 'host) "host#1234")) + (should (string-equal (file-remote-p "/user@host#1234:" 'localname) "")) + (should (string-equal (file-remote-p "/user@host#1234:" 'hop) nil)) + + ;; Expand `tramp-default-user'. + (should (string-equal + (file-remote-p "/method:host#1234:") + (format "/%s:%s@%s:" "method" "default-user" "host#1234"))) + (should (string-equal + (file-remote-p "/method:host#1234:" 'method) "method")) + (should (string-equal + (file-remote-p "/method:host#1234:" 'user) "default-user")) + (should (string-equal + (file-remote-p "/method:host#1234:" 'host) "host#1234")) + (should (string-equal (file-remote-p "/method:host#1234:" 'localname) "")) + (should (string-equal (file-remote-p "/method:host#1234:" 'hop) nil)) + + ;; No expansion. + (should (string-equal + (file-remote-p "/method:user@host#1234:") + (format "/%s:%s@%s:" "method" "user" "host#1234"))) + (should (string-equal + (file-remote-p "/method:user@host#1234:" 'method) "method")) + (should (string-equal + (file-remote-p "/method:user@host#1234:" 'user) "user")) + (should (string-equal + (file-remote-p "/method:user@host#1234:" 'host) "host#1234")) + (should (string-equal + (file-remote-p "/method:user@host#1234:" 'localname) "")) + (should (string-equal + (file-remote-p "/method:user@host#1234:" 'hop) nil)) + + ;; Expand `tramp-default-method' and `tramp-default-user'. + (should (string-equal + (file-remote-p "/1.2.3.4:") + (format "/%s:%s@%s:" "default-method" "default-user" "1.2.3.4"))) + (should (string-equal (file-remote-p "/1.2.3.4:" 'method) "default-method")) + (should (string-equal (file-remote-p "/1.2.3.4:" 'user) "default-user")) + (should (string-equal (file-remote-p "/1.2.3.4:" 'host) "1.2.3.4")) + (should (string-equal (file-remote-p "/1.2.3.4:" 'localname) "")) + (should (string-equal (file-remote-p "/1.2.3.4:" 'hop) nil)) + + ;; Expand `tramp-default-method'. + (should (string-equal + (file-remote-p "/user@1.2.3.4:") + (format "/%s:%s@%s:" "default-method" "user" "1.2.3.4"))) + (should (string-equal + (file-remote-p "/user@1.2.3.4:" 'method) "default-method")) + (should (string-equal (file-remote-p "/user@1.2.3.4:" 'user) "user")) + (should (string-equal (file-remote-p "/user@1.2.3.4:" 'host) "1.2.3.4")) + (should (string-equal (file-remote-p "/user@1.2.3.4:" 'localname) "")) + (should (string-equal (file-remote-p "/user@1.2.3.4:" 'hop) nil)) + + ;; Expand `tramp-default-user'. + (should (string-equal + (file-remote-p "/method:1.2.3.4:") + (format "/%s:%s@%s:" "method" "default-user" "1.2.3.4"))) + (should (string-equal (file-remote-p "/method:1.2.3.4:" 'method) "method")) + (should (string-equal + (file-remote-p "/method:1.2.3.4:" 'user) "default-user")) + (should (string-equal (file-remote-p "/method:1.2.3.4:" 'host) "1.2.3.4")) + (should (string-equal (file-remote-p "/method:1.2.3.4:" 'localname) "")) + (should (string-equal (file-remote-p "/method:1.2.3.4:" 'hop) nil)) + + ;; No expansion. + (should (string-equal + (file-remote-p "/method:user@1.2.3.4:") + (format "/%s:%s@%s:" "method" "user" "1.2.3.4"))) + (should (string-equal + (file-remote-p "/method:user@1.2.3.4:" 'method) "method")) + (should (string-equal (file-remote-p "/method:user@1.2.3.4:" 'user) "user")) + (should (string-equal + (file-remote-p "/method:user@1.2.3.4:" 'host) "1.2.3.4")) + (should (string-equal + (file-remote-p "/method:user@1.2.3.4:" 'localname) "")) + (should (string-equal + (file-remote-p "/method:user@1.2.3.4:" 'hop) nil)) + + ;; Expand `tramp-default-method', `tramp-default-user' and + ;; `tramp-default-host'. + (should (string-equal + (file-remote-p "/[]:") + (format + "/%s:%s@%s:" "default-method" "default-user" "default-host"))) + (should (string-equal (file-remote-p "/[]:" 'method) "default-method")) + (should (string-equal (file-remote-p "/[]:" 'user) "default-user")) + (should (string-equal (file-remote-p "/[]:" 'host) "default-host")) + (should (string-equal (file-remote-p "/[]:" 'localname) "")) + (should (string-equal (file-remote-p "/[]:" 'hop) nil)) + + ;; Expand `tramp-default-method' and `tramp-default-user'. + (let ((tramp-default-host "::1")) + (should (string-equal + (file-remote-p "/[]:") + (format "/%s:%s@%s:" "default-method" "default-user" "[::1]"))) + (should (string-equal (file-remote-p "/[]:" 'method) "default-method")) + (should (string-equal (file-remote-p "/[]:" 'user) "default-user")) + (should (string-equal (file-remote-p "/[]:" 'host) "::1")) + (should (string-equal (file-remote-p "/[]:" 'localname) "")) + (should (string-equal (file-remote-p "/[]:" 'hop) nil))) + + ;; Expand `tramp-default-method' and `tramp-default-user'. + (should (string-equal + (file-remote-p "/[::1]:") + (format "/%s:%s@%s:" "default-method" "default-user" "[::1]"))) + (should (string-equal (file-remote-p "/[::1]:" 'method) "default-method")) + (should (string-equal (file-remote-p "/[::1]:" 'user) "default-user")) + (should (string-equal (file-remote-p "/[::1]:" 'host) "::1")) + (should (string-equal (file-remote-p "/[::1]:" 'localname) "")) + (should (string-equal (file-remote-p "/[::1]:" 'hop) nil)) + + ;; Expand `tramp-default-method'. + (should (string-equal + (file-remote-p "/user@[::1]:") + (format "/%s:%s@%s:" "default-method" "user" "[::1]"))) + (should (string-equal + (file-remote-p "/user@[::1]:" 'method) "default-method")) + (should (string-equal (file-remote-p "/user@[::1]:" 'user) "user")) + (should (string-equal (file-remote-p "/user@[::1]:" 'host) "::1")) + (should (string-equal (file-remote-p "/user@[::1]:" 'localname) "")) + (should (string-equal (file-remote-p "/user@[::1]:" 'hop) nil)) + + ;; Expand `tramp-default-user'. + (should (string-equal + (file-remote-p "/method:[::1]:") + (format "/%s:%s@%s:" "method" "default-user" "[::1]"))) + (should (string-equal (file-remote-p "/method:[::1]:" 'method) "method")) + (should (string-equal + (file-remote-p "/method:[::1]:" 'user) "default-user")) + (should (string-equal (file-remote-p "/method:[::1]:" 'host) "::1")) + (should (string-equal (file-remote-p "/method:[::1]:" 'localname) "")) + (should (string-equal (file-remote-p "/method:[::1]:" 'hop) nil)) + + ;; No expansion. + (should (string-equal + (file-remote-p "/method:user@[::1]:") + (format "/%s:%s@%s:" "method" "user" "[::1]"))) + (should (string-equal + (file-remote-p "/method:user@[::1]:" 'method) "method")) + (should (string-equal (file-remote-p "/method:user@[::1]:" 'user) "user")) + (should (string-equal (file-remote-p "/method:user@[::1]:" 'host) "::1")) + (should (string-equal + (file-remote-p "/method:user@[::1]:" 'localname) "")) + (should (string-equal (file-remote-p "/method:user@[::1]:" 'hop) nil)) + + ;; Local file name part. + (should (string-equal (file-remote-p "/host:/:" 'localname) "/:")) + (should (string-equal (file-remote-p "/method:::" 'localname) ":")) + (should (string-equal (file-remote-p "/method:: " 'localname) " ")) + (should (string-equal (file-remote-p "/method::file" 'localname) "file")) + (should (string-equal + (file-remote-p "/method::/path/to/file" 'localname) + "/path/to/file")) + + ;; Multihop. + (should + (string-equal + (file-remote-p "/method1:user1@host1|method2:user2@host2:/path/to/file") + (format "/%s:%s@%s|%s:%s@%s:" + "method1" "user1" "host1" "method2" "user2" "host2"))) + (should + (string-equal + (file-remote-p + "/method1:user1@host1|method2:user2@host2:/path/to/file" 'method) + "method2")) + (should + (string-equal + (file-remote-p + "/method1:user1@host1|method2:user2@host2:/path/to/file" 'user) + "user2")) + (should + (string-equal + (file-remote-p + "/method1:user1@host1|method2:user2@host2:/path/to/file" 'host) + "host2")) + (should + (string-equal + (file-remote-p + "/method1:user1@host1|method2:user2@host2:/path/to/file" 'localname) + "/path/to/file")) + (should + (string-equal + (file-remote-p + "/method1:user1@host1|method2:user2@host2:/path/to/file" 'hop) + (format "%s:%s@%s|" + "method1" "user1" "host1"))) + + (should + (string-equal + (file-remote-p + "/method1:user1@host1|method2:user2@host2|method3:user3@host3:/path/to/file") + (format "/%s:%s@%s|%s:%s@%s|%s:%s@%s:" + "method1" "user1" "host1" + "method2" "user2" "host2" + "method3" "user3" "host3"))) + (should + (string-equal + (file-remote-p + "/method1:user1@host1|method2:user2@host2|method3:user3@host3:/path/to/file" + 'method) + "method3")) + (should + (string-equal + (file-remote-p + "/method1:user1@host1|method2:user2@host2|method3:user3@host3:/path/to/file" + 'user) + "user3")) + (should + (string-equal + (file-remote-p + "/method1:user1@host1|method2:user2@host2|method3:user3@host3:/path/to/file" + 'host) + "host3")) + (should + (string-equal + (file-remote-p + "/method1:user1@host1|method2:user2@host2|method3:user3@host3:/path/to/file" + 'localname) + "/path/to/file")) + (should + (string-equal + (file-remote-p + "/method1:user1@host1|method2:user2@host2|method3:user3@host3:/path/to/file" + 'hop) + (format "%s:%s@%s|%s:%s@%s|" + "method1" "user1" "host1" "method2" "user2" "host2"))))) + +(ert-deftest tramp-test03-file-name-defaults () + "Check default values for some methods." + ;; Default values in tramp-adb.el. + (should (string-equal (file-remote-p "/adb::" 'host) "")) + ;; Default values in tramp-ftp.el. + (should (string-equal (file-remote-p "/ftp.host:" 'method) "ftp")) + (dolist (u '("ftp" "anonymous")) + (should (string-equal (file-remote-p (format "/%s@:" u) 'method) "ftp"))) + ;; Default values in tramp-gvfs.el. + (when (and (load "tramp-gvfs" 'noerror 'nomessage) + (symbol-value 'tramp-gvfs-enabled)) + (should (string-equal (file-remote-p "/synce::" 'user) nil))) + ;; Default values in tramp-gw.el. + (dolist (m '("tunnel" "socks")) + (should + (string-equal (file-remote-p (format "/%s::" m) 'user) (user-login-name)))) + ;; Default values in tramp-sh.el. + (dolist (h `("127.0.0.1" "[::1]" "localhost" "localhost6" ,(system-name))) + (should (string-equal (file-remote-p (format "/root@%s:" h) 'method) "su"))) + (dolist (m '("su" "sudo" "ksu")) + (should (string-equal (file-remote-p (format "/%s::" m) 'user) "root"))) + (dolist (m '("rcp" "remcp" "rsh" "telnet" "krlogin" "fcp")) + (should + (string-equal (file-remote-p (format "/%s::" m) 'user) (user-login-name)))) + ;; Default values in tramp-smb.el. + (should (string-equal (file-remote-p "/user%domain@host:" 'method) "smb")) + (should (string-equal (file-remote-p "/smb::" 'user) nil))) + +(ert-deftest tramp-test04-substitute-in-file-name () + "Check `substitute-in-file-name'." + (should (string-equal (substitute-in-file-name "/method:host://foo") "/foo")) + (should + (string-equal + (substitute-in-file-name "/method:host:/path//foo") "/method:host:/foo")) + (should + (string-equal (substitute-in-file-name "/method:host:/path///foo") "/foo")) + (should + (string-equal + (substitute-in-file-name "/method:host:/path/~/foo") "/method:host:~/foo")) + (should + (string-equal (substitute-in-file-name "/method:host:/path//~/foo") "~/foo")) + (let (process-environment) + (should + (string-equal + (substitute-in-file-name "/method:host:/path/$FOO") + "/method:host:/path/$FOO")) + (setenv "FOO" "bla") + (should + (string-equal + (substitute-in-file-name "/method:host:/path/$FOO") + "/method:host:/path/bla")) + (should + (string-equal + (substitute-in-file-name "/method:host:/path/$$FOO") + "/method:host:/path/$FOO")))) + +(ert-deftest tramp-test05-expand-file-name () + "Check `expand-file-name'." + (should + (string-equal + (expand-file-name "/method:host:/path/./file") "/method:host:/path/file")) + (should + (string-equal + (expand-file-name "/method:host:/path/../file") "/method:host:/file"))) + +(ert-deftest tramp-test06-directory-file-name () + "Check `directory-file-name'. +This checks also `file-name-as-directory', `file-name-directory', +`file-name-nondirectory' and `unhandled-file-name-directory'." + (should + (string-equal + (directory-file-name "/method:host:/path/to/file") + "/method:host:/path/to/file")) + (should + (string-equal + (directory-file-name "/method:host:/path/to/file/") + "/method:host:/path/to/file")) + (should + (string-equal + (file-name-as-directory "/method:host:/path/to/file") + "/method:host:/path/to/file/")) + (should + (string-equal + (file-name-as-directory "/method:host:/path/to/file/") + "/method:host:/path/to/file/")) + (should + (string-equal + (file-name-directory "/method:host:/path/to/file") + "/method:host:/path/to/")) + (should + (string-equal + (file-name-directory "/method:host:/path/to/file/") + "/method:host:/path/to/file/")) + (should + (string-equal (file-name-nondirectory "/method:host:/path/to/file") "file")) + (should + (string-equal (file-name-nondirectory "/method:host:/path/to/file/") "")) + (should-not + (unhandled-file-name-directory "/method:host:/path/to/file"))) + +(ert-deftest tramp-test07-file-exists-p () + "Check `file-exist-p', `write-region' and `delete-file'." + (skip-unless (tramp--test-enabled)) + + (let ((tmp-name (tramp--test-make-temp-name))) + (should-not (file-exists-p tmp-name)) + (write-region "foo" nil tmp-name) + (should (file-exists-p tmp-name)) + (delete-file tmp-name) + (should-not (file-exists-p tmp-name)))) + +(ert-deftest tramp-test08-file-local-copy () + "Check `file-local-copy'." + (skip-unless (tramp--test-enabled)) + + (let ((tmp-name1 (tramp--test-make-temp-name)) + tmp-name2) + (unwind-protect + (progn + (write-region "foo" nil tmp-name1) + (should (setq tmp-name2 (file-local-copy tmp-name1))) + (with-temp-buffer + (insert-file-contents tmp-name2) + (should (string-equal (buffer-string) "foo"))) + ;; Check also that a file transfer with compression works. + (let ((default-directory tramp-test-temporary-file-directory) + (tramp-copy-size-limit 4) + (tramp-inline-compress-start-size 2)) + (delete-file tmp-name2) + (should (setq tmp-name2 (file-local-copy tmp-name1))))) + + ;; Cleanup. + (ignore-errors + (delete-file tmp-name1) + (delete-file tmp-name2))))) + +(ert-deftest tramp-test09-insert-file-contents () + "Check `insert-file-contents'." + (skip-unless (tramp--test-enabled)) + + (let ((tmp-name (tramp--test-make-temp-name))) + (unwind-protect + (progn + (write-region "foo" nil tmp-name) + (with-temp-buffer + (insert-file-contents tmp-name) + (should (string-equal (buffer-string) "foo")) + (insert-file-contents tmp-name) + (should (string-equal (buffer-string) "foofoo")) + ;; Insert partly. + (insert-file-contents tmp-name nil 1 3) + (should (string-equal (buffer-string) "oofoofoo")) + ;; Replace. + (insert-file-contents tmp-name nil nil nil 'replace) + (should (string-equal (buffer-string) "foo")))) + + ;; Cleanup. + (ignore-errors (delete-file tmp-name))))) + +(ert-deftest tramp-test10-write-region () + "Check `write-region'." + (skip-unless (tramp--test-enabled)) + + (let ((tmp-name (tramp--test-make-temp-name))) + (unwind-protect + (progn + (with-temp-buffer + (insert "foo") + (write-region nil nil tmp-name)) + (with-temp-buffer + (insert-file-contents tmp-name) + (should (string-equal (buffer-string) "foo"))) + ;; Append. + (with-temp-buffer + (insert "bla") + (write-region nil nil tmp-name 'append)) + (with-temp-buffer + (insert-file-contents tmp-name) + (should (string-equal (buffer-string) "foobla"))) + ;; Write string. + (write-region "foo" nil tmp-name) + (with-temp-buffer + (insert-file-contents tmp-name) + (should (string-equal (buffer-string) "foo"))) + ;; Write partly. + (with-temp-buffer + (insert "123456789") + (write-region 3 5 tmp-name)) + (with-temp-buffer + (insert-file-contents tmp-name) + (should (string-equal (buffer-string) "34")))) + + ;; Cleanup. + (ignore-errors (delete-file tmp-name))))) + +(ert-deftest tramp-test11-copy-file () + "Check `copy-file'." + (skip-unless (tramp--test-enabled)) + + (let ((tmp-name1 (tramp--test-make-temp-name)) + (tmp-name2 (tramp--test-make-temp-name)) + (tmp-name3 (tramp--test-make-temp-name)) + (tmp-name4 (tramp--test-make-temp-name 'local)) + (tmp-name5 (tramp--test-make-temp-name 'local))) + + ;; Copy on remote side. + (unwind-protect + (progn + (write-region "foo" nil tmp-name1) + (copy-file tmp-name1 tmp-name2) + (should (file-exists-p tmp-name2)) + (with-temp-buffer + (insert-file-contents tmp-name2) + (should (string-equal (buffer-string) "foo"))) + (should-error (copy-file tmp-name1 tmp-name2)) + (copy-file tmp-name1 tmp-name2 'ok) + (make-directory tmp-name3) + (copy-file tmp-name1 tmp-name3) + (should + (file-exists-p + (expand-file-name (file-name-nondirectory tmp-name1) tmp-name3)))) + + ;; Cleanup. + (ignore-errors (delete-file tmp-name1)) + (ignore-errors (delete-file tmp-name2)) + (ignore-errors (delete-directory tmp-name3 'recursive))) + + ;; Copy from remote side to local side. + (unwind-protect + (progn + (write-region "foo" nil tmp-name1) + (copy-file tmp-name1 tmp-name4) + (should (file-exists-p tmp-name4)) + (with-temp-buffer + (insert-file-contents tmp-name4) + (should (string-equal (buffer-string) "foo"))) + (should-error (copy-file tmp-name1 tmp-name4)) + (copy-file tmp-name1 tmp-name4 'ok) + (make-directory tmp-name5) + (copy-file tmp-name1 tmp-name5) + (should + (file-exists-p + (expand-file-name (file-name-nondirectory tmp-name1) tmp-name5)))) + + ;; Cleanup. + (ignore-errors (delete-file tmp-name1)) + (ignore-errors (delete-file tmp-name4)) + (ignore-errors (delete-directory tmp-name5 'recursive))) + + ;; Copy from local side to remote side. + (unwind-protect + (progn + (write-region "foo" nil tmp-name4 nil 'nomessage) + (copy-file tmp-name4 tmp-name1) + (should (file-exists-p tmp-name1)) + (with-temp-buffer + (insert-file-contents tmp-name1) + (should (string-equal (buffer-string) "foo"))) + (should-error (copy-file tmp-name4 tmp-name1)) + (copy-file tmp-name4 tmp-name1 'ok) + (make-directory tmp-name3) + (copy-file tmp-name4 tmp-name3) + (should + (file-exists-p + (expand-file-name (file-name-nondirectory tmp-name4) tmp-name3)))) + + ;; Cleanup. + (ignore-errors (delete-file tmp-name1)) + (ignore-errors (delete-file tmp-name4)) + (ignore-errors (delete-directory tmp-name3 'recursive))))) + +(ert-deftest tramp-test12-rename-file () + "Check `rename-file'." + (skip-unless (tramp--test-enabled)) + + (let ((tmp-name1 (tramp--test-make-temp-name)) + (tmp-name2 (tramp--test-make-temp-name)) + (tmp-name3 (tramp--test-make-temp-name)) + (tmp-name4 (tramp--test-make-temp-name 'local)) + (tmp-name5 (tramp--test-make-temp-name 'local))) + + ;; Rename on remote side. + (unwind-protect + (progn + (write-region "foo" nil tmp-name1) + (rename-file tmp-name1 tmp-name2) + (should-not (file-exists-p tmp-name1)) + (should (file-exists-p tmp-name2)) + (with-temp-buffer + (insert-file-contents tmp-name2) + (should (string-equal (buffer-string) "foo"))) + (write-region "foo" nil tmp-name1) + (should-error (rename-file tmp-name1 tmp-name2)) + (rename-file tmp-name1 tmp-name2 'ok) + (should-not (file-exists-p tmp-name1)) + (write-region "foo" nil tmp-name1) + (make-directory tmp-name3) + (rename-file tmp-name1 tmp-name3) + (should-not (file-exists-p tmp-name1)) + (should + (file-exists-p + (expand-file-name (file-name-nondirectory tmp-name1) tmp-name3)))) + + ;; Cleanup. + (ignore-errors (delete-file tmp-name1)) + (ignore-errors (delete-file tmp-name2)) + (ignore-errors (delete-directory tmp-name3 'recursive))) + + ;; Rename from remote side to local side. + (unwind-protect + (progn + (write-region "foo" nil tmp-name1) + (rename-file tmp-name1 tmp-name4) + (should-not (file-exists-p tmp-name1)) + (should (file-exists-p tmp-name4)) + (with-temp-buffer + (insert-file-contents tmp-name4) + (should (string-equal (buffer-string) "foo"))) + (write-region "foo" nil tmp-name1) + (should-error (rename-file tmp-name1 tmp-name4)) + (rename-file tmp-name1 tmp-name4 'ok) + (should-not (file-exists-p tmp-name1)) + (write-region "foo" nil tmp-name1) + (make-directory tmp-name5) + (rename-file tmp-name1 tmp-name5) + (should-not (file-exists-p tmp-name1)) + (should + (file-exists-p + (expand-file-name (file-name-nondirectory tmp-name1) tmp-name5)))) + + ;; Cleanup. + (ignore-errors (delete-file tmp-name1)) + (ignore-errors (delete-file tmp-name4)) + (ignore-errors (delete-directory tmp-name5 'recursive))) + + ;; Rename from local side to remote side. + (unwind-protect + (progn + (write-region "foo" nil tmp-name4 nil 'nomessage) + (rename-file tmp-name4 tmp-name1) + (should-not (file-exists-p tmp-name4)) + (should (file-exists-p tmp-name1)) + (with-temp-buffer + (insert-file-contents tmp-name1) + (should (string-equal (buffer-string) "foo"))) + (write-region "foo" nil tmp-name4 nil 'nomessage) + (should-error (rename-file tmp-name4 tmp-name1)) + (rename-file tmp-name4 tmp-name1 'ok) + (should-not (file-exists-p tmp-name4)) + (write-region "foo" nil tmp-name4 nil 'nomessage) + (make-directory tmp-name3) + (rename-file tmp-name4 tmp-name3) + (should-not (file-exists-p tmp-name4)) + (should + (file-exists-p + (expand-file-name (file-name-nondirectory tmp-name4) tmp-name3)))) + + ;; Cleanup. + (ignore-errors (delete-file tmp-name1)) + (ignore-errors (delete-file tmp-name4)) + (ignore-errors (delete-directory tmp-name3 'recursive))))) + +(ert-deftest tramp-test13-make-directory () + "Check `make-directory'. +This tests also `file-directory-p' and `file-accessible-directory-p'." + (skip-unless (tramp--test-enabled)) + + (let* ((tmp-name1 (tramp--test-make-temp-name)) + (tmp-name2 (expand-file-name "foo/bar" tmp-name1))) + (unwind-protect + (progn + (make-directory tmp-name1) + (should (file-directory-p tmp-name1)) + (should (file-accessible-directory-p tmp-name1)) + (should-error (make-directory tmp-name2) :type 'file-error) + (make-directory tmp-name2 'parents) + (should (file-directory-p tmp-name2)) + (should (file-accessible-directory-p tmp-name2))) + + ;; Cleanup. + (ignore-errors (delete-directory tmp-name1 'recursive))))) + +(ert-deftest tramp-test14-delete-directory () + "Check `delete-directory'." + (skip-unless (tramp--test-enabled)) + + (let ((tmp-name (tramp--test-make-temp-name))) + ;; Delete empty directory. + (make-directory tmp-name) + (should (file-directory-p tmp-name)) + (delete-directory tmp-name) + (should-not (file-directory-p tmp-name)) + ;; Delete non-empty directory. + (make-directory tmp-name) + (write-region "foo" nil (expand-file-name "bla" tmp-name)) + (should-error (delete-directory tmp-name) :type 'file-error) + (delete-directory tmp-name 'recursive) + (should-not (file-directory-p tmp-name)))) + +(ert-deftest tramp-test15-copy-directory () + "Check `copy-directory'." + (skip-unless (tramp--test-enabled)) + (skip-unless + (not + (eq + (tramp-find-foreign-file-name-handler tramp-test-temporary-file-directory) + 'tramp-smb-file-name-handler))) + + (let* ((tmp-name1 (tramp--test-make-temp-name)) + (tmp-name2 (tramp--test-make-temp-name)) + (tmp-name3 (expand-file-name + (file-name-nondirectory tmp-name1) tmp-name2)) + (tmp-name4 (expand-file-name "foo" tmp-name1)) + (tmp-name5 (expand-file-name "foo" tmp-name2)) + (tmp-name6 (expand-file-name "foo" tmp-name3))) + (unwind-protect + (progn + ;; Copy empty directory. + (make-directory tmp-name1) + (write-region "foo" nil tmp-name4) + (should (file-directory-p tmp-name1)) + (should (file-exists-p tmp-name4)) + (copy-directory tmp-name1 tmp-name2) + (should (file-directory-p tmp-name2)) + (should (file-exists-p tmp-name5)) + ;; Target directory does exist already. + (copy-directory tmp-name1 tmp-name2) + (should (file-directory-p tmp-name3)) + (should (file-exists-p tmp-name6))) + + ;; Cleanup. + (ignore-errors + (delete-directory tmp-name1 'recursive) + (delete-directory tmp-name2 'recursive))))) + +(ert-deftest tramp-test16-directory-files () + "Check `directory-files'." + (skip-unless (tramp--test-enabled)) + + (let* ((tmp-name1 (tramp--test-make-temp-name)) + (tmp-name2 (expand-file-name "bla" tmp-name1)) + (tmp-name3 (expand-file-name "foo" tmp-name1))) + (unwind-protect + (progn + (make-directory tmp-name1) + (write-region "foo" nil tmp-name2) + (write-region "bla" nil tmp-name3) + (should (file-directory-p tmp-name1)) + (should (file-exists-p tmp-name2)) + (should (file-exists-p tmp-name3)) + (should (equal (directory-files tmp-name1) '("." ".." "bla" "foo"))) + (should (equal (directory-files tmp-name1 'full) + `(,(concat tmp-name1 "/.") + ,(concat tmp-name1 "/..") + ,tmp-name2 ,tmp-name3))) + (should (equal (directory-files + tmp-name1 nil directory-files-no-dot-files-regexp) + '("bla" "foo"))) + (should (equal (directory-files + tmp-name1 'full directory-files-no-dot-files-regexp) + `(,tmp-name2 ,tmp-name3)))) + + ;; Cleanup. + (ignore-errors (delete-directory tmp-name1 'recursive))))) + +(ert-deftest tramp-test17-insert-directory () + "Check `insert-directory'." + (skip-unless (tramp--test-enabled)) + + (let* ((tmp-name1 (tramp--test-make-temp-name)) + (tmp-name2 (expand-file-name "foo" tmp-name1)) + ;; We test for the summary line. Keyword "total" could be localized. + (process-environment + (append '("LANG=C" "LANGUAGE=C" "LC_ALL=C") process-environment))) + (unwind-protect + (progn + (make-directory tmp-name1) + (write-region "foo" nil tmp-name2) + (should (file-directory-p tmp-name1)) + (should (file-exists-p tmp-name2)) + (with-temp-buffer + (insert-directory tmp-name1 nil) + (goto-char (point-min)) + (should (looking-at-p (regexp-quote tmp-name1)))) + (with-temp-buffer + (insert-directory tmp-name1 "-al") + (goto-char (point-min)) + (should (looking-at-p (format "^.+ %s$" (regexp-quote tmp-name1))))) + (with-temp-buffer + (insert-directory (file-name-as-directory tmp-name1) "-al") + (goto-char (point-min)) + (should + (looking-at-p (format "^.+ %s/$" (regexp-quote tmp-name1))))) + (with-temp-buffer + (insert-directory + (file-name-as-directory tmp-name1) "-al" nil 'full-directory-p) + (goto-char (point-min)) + (should + (looking-at-p + (concat + ;; There might be a summary line. + "\\(total.+[[:digit:]]+\n\\)?" + ;; We don't know in which order ".", ".." and "foo" appear. + "\\(.+ \\(\\.?\\.\\|foo\\)\n\\)\\{3\\}"))))) + + ;; Cleanup. + (ignore-errors (delete-directory tmp-name1 'recursive))))) + +(ert-deftest tramp-test18-file-attributes () + "Check `file-attributes'. +This tests also `file-readable-p' and `file-regular-p'." + (skip-unless (tramp--test-enabled)) + + ;; We must use `file-truename' for the temporary directory, because + ;; it could be located on a symlinked directory. This would let the + ;; test fail. + (let* ((tramp-test-temporary-file-directory + (file-truename tramp-test-temporary-file-directory)) + (tmp-name1 (tramp--test-make-temp-name)) + (tmp-name2 (tramp--test-make-temp-name)) + ;; File name with "//". + (tmp-name3 + (format + "%s%s" + (file-remote-p tmp-name1) + (replace-regexp-in-string + "/" "//" (file-remote-p tmp-name1 'localname)))) + attr) + (unwind-protect + (progn + (write-region "foo" nil tmp-name1) + (should (file-exists-p tmp-name1)) + (setq attr (file-attributes tmp-name1)) + (should (consp attr)) + (should (file-exists-p tmp-name1)) + (should (file-readable-p tmp-name1)) + (should (file-regular-p tmp-name1)) + ;; We do not test inodes and device numbers. + (should (null (car attr))) + (should (numberp (nth 1 attr))) ;; Link. + (should (numberp (nth 2 attr))) ;; Uid. + (should (numberp (nth 3 attr))) ;; Gid. + ;; Last access time. + (should (stringp (current-time-string (nth 4 attr)))) + ;; Last modification time. + (should (stringp (current-time-string (nth 5 attr)))) + ;; Last status change time. + (should (stringp (current-time-string (nth 6 attr)))) + (should (numberp (nth 7 attr))) ;; Size. + (should (stringp (nth 8 attr))) ;; Modes. + + (setq attr (file-attributes tmp-name1 'string)) + (should (stringp (nth 2 attr))) ;; Uid. + (should (stringp (nth 3 attr))) ;; Gid. + + (condition-case err + (progn + (make-symbolic-link tmp-name1 tmp-name2) + (should (file-exists-p tmp-name2)) + (should (file-symlink-p tmp-name2)) + (setq attr (file-attributes tmp-name2)) + (should (string-equal + (car attr) + (file-remote-p (file-truename tmp-name1) 'localname))) + (delete-file tmp-name2)) + (file-error + (should (string-equal (error-message-string err) + "make-symbolic-link not supported")))) + + ;; Check, that "//" in symlinks are handled properly. + (with-temp-buffer + (let ((default-directory tramp-test-temporary-file-directory)) + (shell-command + (format + "ln -s %s %s" + (tramp-file-name-localname (tramp-dissect-file-name tmp-name3)) + (tramp-file-name-localname (tramp-dissect-file-name tmp-name2))) + t))) + (when (file-symlink-p tmp-name2) + (setq attr (file-attributes tmp-name2)) + (should + (string-equal + (car attr) + (tramp-file-name-localname (tramp-dissect-file-name tmp-name3)))) + (delete-file tmp-name2)) + + (delete-file tmp-name1) + (make-directory tmp-name1) + (should (file-exists-p tmp-name1)) + (should (file-readable-p tmp-name1)) + (should-not (file-regular-p tmp-name1)) + (setq attr (file-attributes tmp-name1)) + (should (eq (car attr) t))) + + ;; Cleanup. + (ignore-errors (delete-directory tmp-name1)) + (ignore-errors (delete-file tmp-name1)) + (ignore-errors (delete-file tmp-name2))))) + +(ert-deftest tramp-test19-directory-files-and-attributes () + "Check `directory-files-and-attributes'." + (skip-unless (tramp--test-enabled)) + + ;; `directory-files-and-attributes' contains also values for "../". + ;; Ensure that this doesn't change during tests, for + ;; example due to handling temporary files. + (let* ((tmp-name1 (tramp--test-make-temp-name)) + (tmp-name2 (expand-file-name "bla" tmp-name1)) + attr) + (unwind-protect + (progn + (make-directory tmp-name1) + (should (file-directory-p tmp-name1)) + (make-directory tmp-name2) + (should (file-directory-p tmp-name2)) + (write-region "foo" nil (expand-file-name "foo" tmp-name2)) + (write-region "bar" nil (expand-file-name "bar" tmp-name2)) + (write-region "boz" nil (expand-file-name "boz" tmp-name2)) + (setq attr (directory-files-and-attributes tmp-name2)) + (should (consp attr)) + ;; Dumb remote shells without perl(1) or stat(1) are not + ;; able to return the date correctly. They say "don't know". + (dolist (elt attr) + (unless + (equal + (nth 5 + (file-attributes (expand-file-name (car elt) tmp-name2))) + '(0 0)) + (should + (equal (file-attributes (expand-file-name (car elt) tmp-name2)) + (cdr elt))))) + (setq attr (directory-files-and-attributes tmp-name2 'full)) + (dolist (elt attr) + (unless (equal (nth 5 (file-attributes (car elt))) '(0 0)) + (should + (equal (file-attributes (car elt)) (cdr elt))))) + (setq attr (directory-files-and-attributes tmp-name2 nil "^b")) + (should (equal (mapcar 'car attr) '("bar" "boz")))) + + ;; Cleanup. + (ignore-errors (delete-directory tmp-name1 'recursive))))) + +(ert-deftest tramp-test20-file-modes () + "Check `file-modes'. +This tests also `file-executable-p', `file-writable-p' and `set-file-modes'." + (skip-unless (tramp--test-enabled)) + (skip-unless + (not + (memq + (tramp-find-foreign-file-name-handler tramp-test-temporary-file-directory) + '(tramp-adb-file-name-handler + tramp-gvfs-file-name-handler + tramp-smb-file-name-handler)))) + + (let ((tmp-name (tramp--test-make-temp-name))) + (unwind-protect + (progn + (write-region "foo" nil tmp-name) + (should (file-exists-p tmp-name)) + (set-file-modes tmp-name #o777) + (should (= (file-modes tmp-name) #o777)) + (should (file-executable-p tmp-name)) + (should (file-writable-p tmp-name)) + (set-file-modes tmp-name #o444) + (should (= (file-modes tmp-name) #o444)) + (should-not (file-executable-p tmp-name)) + ;; A file is always writable for user "root". + (unless (zerop (nth 2 (file-attributes tmp-name))) + (should-not (file-writable-p tmp-name)))) + + ;; Cleanup. + (ignore-errors (delete-file tmp-name))))) + +(ert-deftest tramp-test21-file-links () + "Check `file-symlink-p'. +This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." + (skip-unless (tramp--test-enabled)) + + ;; We must use `file-truename' for the temporary directory, because + ;; it could be located on a symlinked directory. This would let the + ;; test fail. + (let* ((tramp-test-temporary-file-directory + (file-truename tramp-test-temporary-file-directory)) + (tmp-name1 (tramp--test-make-temp-name)) + (tmp-name2 (tramp--test-make-temp-name)) + (tmp-name3 (tramp--test-make-temp-name 'local))) + + ;; Check `make-symbolic-link'. + (unwind-protect + (progn + (write-region "foo" nil tmp-name1) + (should (file-exists-p tmp-name1)) + ;; Method "smb" supports `make-symbolic-link' only if the + ;; remote host has CIFS capabilities. tramp-adb.el and + ;; tramp-gvfs.el do not support symbolic links at all. + (condition-case err + (make-symbolic-link tmp-name1 tmp-name2) + (file-error + (skip-unless + (not (string-equal (error-message-string err) + "make-symbolic-link not supported"))))) + (should (file-symlink-p tmp-name2)) + (should-error (make-symbolic-link tmp-name1 tmp-name2)) + (make-symbolic-link tmp-name1 tmp-name2 'ok-if-already-exists) + (should (file-symlink-p tmp-name2)) + ;; `tmp-name3' is a local file name. + (should-error (make-symbolic-link tmp-name1 tmp-name3))) + + ;; Cleanup. + (ignore-errors + (delete-file tmp-name1) + (delete-file tmp-name2))) + + ;; Check `add-name-to-file'. + (unwind-protect + (progn + (write-region "foo" nil tmp-name1) + (should (file-exists-p tmp-name1)) + (add-name-to-file tmp-name1 tmp-name2) + (should-not (file-symlink-p tmp-name2)) + (should-error (add-name-to-file tmp-name1 tmp-name2)) + (add-name-to-file tmp-name1 tmp-name2 'ok-if-already-exists) + (should-not (file-symlink-p tmp-name2)) + ;; `tmp-name3' is a local file name. + (should-error (add-name-to-file tmp-name1 tmp-name3))) + + ;; Cleanup. + (ignore-errors + (delete-file tmp-name1) + (delete-file tmp-name2))) + + ;; Check `file-truename'. + (unwind-protect + (progn + (write-region "foo" nil tmp-name1) + (should (file-exists-p tmp-name1)) + (make-symbolic-link tmp-name1 tmp-name2) + (should (file-symlink-p tmp-name2)) + (should-not (string-equal tmp-name2 (file-truename tmp-name2))) + (should + (string-equal (file-truename tmp-name1) (file-truename tmp-name2))) + (should (file-equal-p tmp-name1 tmp-name2))) + (ignore-errors + (delete-file tmp-name1) + (delete-file tmp-name2))) + + ;; `file-truename' shall preserve trailing link of directories. + (unless (file-symlink-p tramp-test-temporary-file-directory) + (let* ((dir1 (directory-file-name tramp-test-temporary-file-directory)) + (dir2 (file-name-as-directory dir1))) + (should (string-equal (file-truename dir1) (expand-file-name dir1))) + (should (string-equal (file-truename dir2) (expand-file-name dir2))))))) + +(ert-deftest tramp-test22-file-times () + "Check `set-file-times' and `file-newer-than-file-p'." + (skip-unless (tramp--test-enabled)) + (skip-unless + (not + (memq + (tramp-find-foreign-file-name-handler tramp-test-temporary-file-directory) + '(tramp-gvfs-file-name-handler tramp-smb-file-name-handler)))) + + (let ((tmp-name1 (tramp--test-make-temp-name)) + (tmp-name2 (tramp--test-make-temp-name)) + (tmp-name3 (tramp--test-make-temp-name))) + (unwind-protect + (progn + (write-region "foo" nil tmp-name1) + (should (file-exists-p tmp-name1)) + (should (consp (nth 5 (file-attributes tmp-name1)))) + ;; '(0 0) means don't know, and will be replaced by + ;; `current-time'. Therefore, we use '(0 1). + ;; We skip the test, if the remote handler is not able to + ;; set the correct time. + (skip-unless (set-file-times tmp-name1 '(0 1))) + ;; Dumb remote shells without perl(1) or stat(1) are not + ;; able to return the date correctly. They say "don't know". + (unless (equal (nth 5 (file-attributes tmp-name1)) '(0 0)) + (should (equal (nth 5 (file-attributes tmp-name1)) '(0 1))) + (write-region "bla" nil tmp-name2) + (should (file-exists-p tmp-name2)) + (should (file-newer-than-file-p tmp-name2 tmp-name1)) + ;; `tmp-name3' does not exist. + (should (file-newer-than-file-p tmp-name2 tmp-name3)) + (should-not (file-newer-than-file-p tmp-name3 tmp-name1)))) + + ;; Cleanup. + (ignore-errors + (delete-file tmp-name1) + (delete-file tmp-name2))))) + +(ert-deftest tramp-test23-visited-file-modtime () + "Check `set-visited-file-modtime' and `verify-visited-file-modtime'." + (skip-unless (tramp--test-enabled)) + + (let ((tmp-name (tramp--test-make-temp-name))) + (unwind-protect + (progn + (write-region "foo" nil tmp-name) + (should (file-exists-p tmp-name)) + (with-temp-buffer + (insert-file-contents tmp-name) + (should (verify-visited-file-modtime)) + (set-visited-file-modtime '(0 1)) + (should (verify-visited-file-modtime)) + (should (equal (visited-file-modtime) '(0 1 0 0))))) + + ;; Cleanup. + (ignore-errors (delete-file tmp-name))))) + +(ert-deftest tramp-test24-file-name-completion () + "Check `file-name-completion' and `file-name-all-completions'." + (skip-unless (tramp--test-enabled)) + + (let ((tmp-name (tramp--test-make-temp-name))) + (unwind-protect + (progn + (make-directory tmp-name) + (should (file-directory-p tmp-name)) + (write-region "foo" nil (expand-file-name "foo" tmp-name)) + (write-region "bar" nil (expand-file-name "bold" tmp-name)) + (make-directory (expand-file-name "boz" tmp-name)) + (should (equal (file-name-completion "fo" tmp-name) "foo")) + (should (equal (file-name-completion "b" tmp-name) "bo")) + (should + (equal (file-name-completion "b" tmp-name 'file-directory-p) "boz/")) + (should (equal (file-name-all-completions "fo" tmp-name) '("foo"))) + (should + (equal (sort (file-name-all-completions "b" tmp-name) 'string-lessp) + '("bold" "boz/")))) + + ;; Cleanup. + (ignore-errors (delete-directory tmp-name 'recursive))))) + +(ert-deftest tramp-test25-load () + "Check `load'." + (skip-unless (tramp--test-enabled)) + + (let ((tmp-name (tramp--test-make-temp-name))) + (unwind-protect + (progn + (load tmp-name 'noerror 'nomessage) + (should-not (featurep 'tramp-test-load)) + (write-region "(provide 'tramp-test-load)" nil tmp-name) + ;; `load' in lread.c does not pass `must-suffix'. Why? + ;(should-error (load tmp-name nil 'nomessage 'nosuffix 'must-suffix)) + (load tmp-name nil 'nomessage 'nosuffix) + (should (featurep 'tramp-test-load))) + + ;; Cleanup. + (ignore-errors + (and (featurep 'tramp-test-load) (unload-feature 'tramp-test-load)) + (delete-file tmp-name))))) + +(ert-deftest tramp-test26-process-file () + "Check `process-file'." + (skip-unless (tramp--test-enabled)) + (skip-unless + (not + (memq + (tramp-find-foreign-file-name-handler tramp-test-temporary-file-directory) + '(tramp-gvfs-file-name-handler tramp-smb-file-name-handler)))) + + (let* ((tmp-name (tramp--test-make-temp-name)) + (fnnd (file-name-nondirectory tmp-name)) + (default-directory tramp-test-temporary-file-directory) + kill-buffer-query-functions) + (unwind-protect + (progn + ;; We cannot use "/bin/true" and "/bin/false"; those paths + ;; do not exist on hydra. + (should (zerop (process-file "true"))) + (should-not (zerop (process-file "false"))) + (should-not (zerop (process-file "binary-does-not-exist"))) + (with-temp-buffer + (write-region "foo" nil tmp-name) + (should (file-exists-p tmp-name)) + (should (zerop (process-file "ls" nil t nil fnnd))) + ;; `ls' could produce colorized output. + (goto-char (point-min)) + (while (re-search-forward tramp-color-escape-sequence-regexp nil t) + (replace-match "" nil nil)) + (should (string-equal (format "%s\n" fnnd) (buffer-string))) + (should-not (get-buffer-window (current-buffer) t)) + + ;; Second run. The output must be appended. + (should (zerop (process-file "ls" nil t t fnnd))) + ;; `ls' could produce colorized output. + (goto-char (point-min)) + (while (re-search-forward tramp-color-escape-sequence-regexp nil t) + (replace-match "" nil nil)) + (should + (string-equal (format "%s\n%s\n" fnnd fnnd) (buffer-string))) + ;; A non-nil DISPLAY must not raise the buffer. + (should-not (get-buffer-window (current-buffer) t)))) + + ;; Cleanup. + (ignore-errors (delete-file tmp-name))))) + +(ert-deftest tramp-test27-start-file-process () + "Check `start-file-process'." + (skip-unless (tramp--test-enabled)) + (skip-unless + (not + (memq + (tramp-find-foreign-file-name-handler tramp-test-temporary-file-directory) + '(tramp-adb-file-name-handler + tramp-gvfs-file-name-handler + tramp-smb-file-name-handler)))) + + (let ((default-directory tramp-test-temporary-file-directory) + (tmp-name (tramp--test-make-temp-name)) + kill-buffer-query-functions proc) + (unwind-protect + (with-temp-buffer + (setq proc (start-file-process "test1" (current-buffer) "cat")) + (should (processp proc)) + (should (equal (process-status proc) 'run)) + (process-send-string proc "foo") + (process-send-eof proc) + ;; Read output. + (with-timeout (10 (ert-fail "`start-file-process' timed out")) + (while (< (- (point-max) (point-min)) (length "foo")) + (accept-process-output proc 1))) + (should (string-equal (buffer-string) "foo"))) + + ;; Cleanup. + (ignore-errors (delete-process proc))) + + (unwind-protect + (with-temp-buffer + (write-region "foo" nil tmp-name) + (should (file-exists-p tmp-name)) + (setq proc + (start-file-process + "test2" (current-buffer) + "cat" (file-name-nondirectory tmp-name))) + (should (processp proc)) + ;; Read output. + (with-timeout (10 (ert-fail "`start-file-process' timed out")) + (while (< (- (point-max) (point-min)) (length "foo")) + (accept-process-output proc 1))) + (should (string-equal (buffer-string) "foo"))) + + ;; Cleanup. + (ignore-errors + (delete-process proc) + (delete-file tmp-name))) + + (unwind-protect + (with-temp-buffer + (setq proc (start-file-process "test3" (current-buffer) "cat")) + (should (processp proc)) + (should (equal (process-status proc) 'run)) + (set-process-filter + proc + (lambda (p s) (with-current-buffer (process-buffer p) (insert s)))) + (process-send-string proc "foo") + (process-send-eof proc) + ;; Read output. + (with-timeout (10 (ert-fail "`start-file-process' timed out")) + (while (< (- (point-max) (point-min)) (length "foo")) + (accept-process-output proc 1))) + (should (string-equal (buffer-string) "foo"))) + + ;; Cleanup. + (ignore-errors (delete-process proc))))) + +(ert-deftest tramp-test28-shell-command () + "Check `shell-command'." + (skip-unless (tramp--test-enabled)) + (skip-unless + (not + (memq + (tramp-find-foreign-file-name-handler tramp-test-temporary-file-directory) + '(tramp-adb-file-name-handler + tramp-gvfs-file-name-handler + tramp-smb-file-name-handler)))) + + (let ((tmp-name (tramp--test-make-temp-name)) + (default-directory tramp-test-temporary-file-directory) + kill-buffer-query-functions) + (unwind-protect + (with-temp-buffer + (write-region "foo" nil tmp-name) + (should (file-exists-p tmp-name)) + (shell-command + (format "ls %s" (file-name-nondirectory tmp-name)) (current-buffer)) + ;; `ls' could produce colorized output. + (goto-char (point-min)) + (while (re-search-forward tramp-color-escape-sequence-regexp nil t) + (replace-match "" nil nil)) + (should + (string-equal + (format "%s\n" (file-name-nondirectory tmp-name)) (buffer-string)))) + + ;; Cleanup. + (ignore-errors (delete-file tmp-name))) + + (unwind-protect + (with-temp-buffer + (write-region "foo" nil tmp-name) + (should (file-exists-p tmp-name)) + (async-shell-command + (format "ls %s" (file-name-nondirectory tmp-name)) (current-buffer)) + (set-process-sentinel (get-buffer-process (current-buffer)) nil) + ;; Read output. + (with-timeout (10 (ert-fail "`async-shell-command' timed out")) + (while (< (- (point-max) (point-min)) + (1+ (length (file-name-nondirectory tmp-name)))) + (accept-process-output (get-buffer-process (current-buffer)) 1))) + ;; `ls' could produce colorized output. + (goto-char (point-min)) + (while (re-search-forward tramp-color-escape-sequence-regexp nil t) + (replace-match "" nil nil)) + ;; There might be a nasty "Process *Async Shell* finished" message. + (goto-char (point-min)) + (forward-line) + (narrow-to-region (point-min) (point)) + (should + (string-equal + (format "%s\n" (file-name-nondirectory tmp-name)) (buffer-string)))) + + ;; Cleanup. + (ignore-errors (delete-file tmp-name))) + + (unwind-protect + (with-temp-buffer + (write-region "foo" nil tmp-name) + (should (file-exists-p tmp-name)) + (async-shell-command "read line; ls $line" (current-buffer)) + (set-process-sentinel (get-buffer-process (current-buffer)) nil) + (process-send-string + (get-buffer-process (current-buffer)) + (format "%s\n" (file-name-nondirectory tmp-name))) + ;; Read output. + (with-timeout (10 (ert-fail "`async-shell-command' timed out")) + (while (< (- (point-max) (point-min)) + (1+ (length (file-name-nondirectory tmp-name)))) + (accept-process-output (get-buffer-process (current-buffer)) 1))) + ;; `ls' could produce colorized output. + (goto-char (point-min)) + (while (re-search-forward tramp-color-escape-sequence-regexp nil t) + (replace-match "" nil nil)) + ;; There might be a nasty "Process *Async Shell* finished" message. + (goto-char (point-min)) + (forward-line) + (narrow-to-region (point-min) (point)) + (should + (string-equal + (format "%s\n" (file-name-nondirectory tmp-name)) (buffer-string)))) + + ;; Cleanup. + (ignore-errors (delete-file tmp-name))))) + +(ert-deftest tramp-test29-vc-registered () + "Check `vc-registered'." + (skip-unless (tramp--test-enabled)) + (skip-unless + (eq + (tramp-find-foreign-file-name-handler tramp-test-temporary-file-directory) + 'tramp-sh-file-name-handler)) + + (let* ((default-directory tramp-test-temporary-file-directory) + (tmp-name1 (tramp--test-make-temp-name)) + (tmp-name2 (expand-file-name "foo" tmp-name1)) + (tramp-remote-process-environment tramp-remote-process-environment) + (vc-handled-backends + (with-parsed-tramp-file-name tramp-test-temporary-file-directory nil + (cond + ((tramp-find-executable v vc-git-program (tramp-get-remote-path v)) + '(Git)) + ((tramp-find-executable v vc-hg-program (tramp-get-remote-path v)) + '(Hg)) + ((tramp-find-executable v vc-bzr-program (tramp-get-remote-path v)) + (setq tramp-remote-process-environment + (cons (format "BZR_HOME=%s" + (file-remote-p tmp-name1 'localname)) + tramp-remote-process-environment)) + ;; We must force a reconnect, in order to activate $BZR_HOME. + (tramp-cleanup-connection + (tramp-dissect-file-name tramp-test-temporary-file-directory) + nil 'keep-password) + '(Bzr)) + (t nil))))) + (skip-unless vc-handled-backends) + (message "%s" vc-handled-backends) + + (unwind-protect + (progn + (make-directory tmp-name1) + (write-region "foo" nil tmp-name2) + (should (file-directory-p tmp-name1)) + (should (file-exists-p tmp-name2)) + (should-not (vc-registered tmp-name1)) + (should-not (vc-registered tmp-name2)) + + (let ((default-directory tmp-name1)) + ;; Create empty repository, and register the file. + ;; Sometimes, creation of repository fails (bzr!); we skip + ;; the test then. + (condition-case nil + (vc-create-repo (car vc-handled-backends)) + (error (skip-unless nil))) + ;; The structure of VC-FILESET is not documented. Let's + ;; hope it won't change. + (condition-case nil + (vc-register + (list (car vc-handled-backends) + (list (file-name-nondirectory tmp-name2)))) + ;; `vc-register' has changed its arguments in Emacs 25.1. + (error + (vc-register + nil (list (car vc-handled-backends) + (list (file-name-nondirectory tmp-name2))))))) + (should (vc-registered tmp-name2))) + + ;; Cleanup. + (ignore-errors (delete-directory tmp-name1 'recursive))))) + +(ert-deftest tramp-test30-make-auto-save-file-name () + "Check `make-auto-save-file-name'." + (skip-unless (tramp--test-enabled)) + + (let ((tmp-name1 (tramp--test-make-temp-name)) + (tmp-name2 (tramp--test-make-temp-name))) + + (unwind-protect + (progn + ;; Use default `auto-save-file-name-transforms' mechanism. + (let (tramp-auto-save-directory) + (with-temp-buffer + (setq buffer-file-name tmp-name1) + (should + (string-equal + (make-auto-save-file-name) + ;; This is taken from original `make-auto-save-file-name'. + (expand-file-name + (format + "#%s#" + (subst-char-in-string + ?/ ?! (replace-regexp-in-string "!" "!!" tmp-name1))) + temporary-file-directory))))) + + ;; No mapping. + (let (tramp-auto-save-directory auto-save-file-name-transforms) + (with-temp-buffer + (setq buffer-file-name tmp-name1) + (should + (string-equal + (make-auto-save-file-name) + (expand-file-name + (format "#%s#" (file-name-nondirectory tmp-name1)) + tramp-test-temporary-file-directory))))) + + ;; Use default `tramp-auto-save-directory' mechanism. + (let ((tramp-auto-save-directory tmp-name2)) + (with-temp-buffer + (setq buffer-file-name tmp-name1) + (should + (string-equal + (make-auto-save-file-name) + ;; This is taken from Tramp. + (expand-file-name + (format + "#%s#" + (tramp-subst-strs-in-string + '(("_" . "|") + ("/" . "_a") + (":" . "_b") + ("|" . "__") + ("[" . "_l") + ("]" . "_r")) + tmp-name1)) + tmp-name2))) + (should (file-directory-p tmp-name2)))) + + ;; Relative file names shall work, too. + (let ((tramp-auto-save-directory ".")) + (with-temp-buffer + (setq buffer-file-name tmp-name1 + default-directory tmp-name2) + (should + (string-equal + (make-auto-save-file-name) + ;; This is taken from Tramp. + (expand-file-name + (format + "#%s#" + (tramp-subst-strs-in-string + '(("_" . "|") + ("/" . "_a") + (":" . "_b") + ("|" . "__") + ("[" . "_l") + ("]" . "_r")) + tmp-name1)) + tmp-name2))) + (should (file-directory-p tmp-name2))))) + + ;; Cleanup. + (ignore-errors (delete-file tmp-name1)) + (ignore-errors (delete-directory tmp-name2 'recursive))))) + +(defun tramp--test-adb-p () + "Check, whether the remote host runs Android. +This requires restrictions of file name syntax." + (tramp-adb-file-name-p tramp-test-temporary-file-directory)) + +(defun tramp--test-ftp-p () + "Check, whether an FTP-like method is used. +This does not support globbing characters in file names (yet)." + ;; Globbing characters are ??, ?* and ?\[. + (and (eq (tramp-find-foreign-file-name-handler + tramp-test-temporary-file-directory) + 'tramp-sh-file-name-handler) + (string-match + "ftp$" (file-remote-p tramp-test-temporary-file-directory 'method)))) + +(defun tramp--test-gvfs-p () + "Check, whether the remote host runs a GVFS based method. +This requires restrictions of file name syntax." + (tramp-gvfs-file-name-p tramp-test-temporary-file-directory)) + +(defun tramp--test-smb-or-windows-nt-p () + "Check, whether the locale or remote host runs MS Windows. +This requires restrictions of file name syntax." + (or (eq system-type 'windows-nt) + (tramp-smb-file-name-p tramp-test-temporary-file-directory))) + +(defun tramp--test-hpux-p () + "Check, whether the remote host runs HP-UX. +Several special characters do not work properly there." + ;; We must refill the cache. `file-truename' does it. + (with-parsed-tramp-file-name + (file-truename tramp-test-temporary-file-directory) nil + (string-match "^HP-UX" (tramp-get-connection-property v "uname" "")))) + +(defun tramp--test-darwin-p () + "Check, whether the remote host runs Mac OS X. +Several special characters do not work properly there." + ;; We must refill the cache. `file-truename' does it. + (with-parsed-tramp-file-name + (file-truename tramp-test-temporary-file-directory) nil + (string-match "^Darwin" (tramp-get-connection-property v "uname" "")))) + +(defun tramp--test-check-files (&rest files) + "Run a simple but comprehensive test over every file in FILES." + ;; We must use `file-truename' for the temporary directory, because + ;; it could be located on a symlinked directory. This would let the + ;; test fail. + (let* ((tramp-test-temporary-file-directory + (file-truename tramp-test-temporary-file-directory)) + (tmp-name1 (tramp--test-make-temp-name)) + (tmp-name2 (tramp--test-make-temp-name 'local)) + (files (delq nil files))) + (unwind-protect + (progn + (make-directory tmp-name1) + (make-directory tmp-name2) + (dolist (elt files) + (let* ((file1 (expand-file-name elt tmp-name1)) + (file2 (expand-file-name elt tmp-name2)) + (file3 (expand-file-name (concat elt "foo") tmp-name1))) + (write-region elt nil file1) + (should (file-exists-p file1)) + + ;; Check file contents. + (with-temp-buffer + (insert-file-contents file1) + (should (string-equal (buffer-string) elt))) + + ;; Copy file both directions. + (copy-file file1 tmp-name2) + (should (file-exists-p file2)) + (delete-file file1) + (should-not (file-exists-p file1)) + (copy-file file2 tmp-name1) + (should (file-exists-p file1)) + + ;; Method "smb" supports `make-symbolic-link' only if the + ;; remote host has CIFS capabilities. tramp-adb.el and + ;; tramp-gvfs.el do not support symbolic links at all. + (condition-case err + (progn + (make-symbolic-link file1 file3) + (should (file-symlink-p file3)) + (should + (string-equal + (expand-file-name file1) (file-truename file3))) + (should + (string-equal + (car (file-attributes file3)) + (file-remote-p (file-truename file1) 'localname))) + ;; Check file contents. + (with-temp-buffer + (insert-file-contents file3) + (should (string-equal (buffer-string) elt))) + (delete-file file3)) + (file-error + (should (string-equal (error-message-string err) + "make-symbolic-link not supported")))))) + + ;; Check file names. + (should (equal (directory-files + tmp-name1 nil directory-files-no-dot-files-regexp) + (sort (copy-sequence files) 'string-lessp))) + (should (equal (directory-files + tmp-name2 nil directory-files-no-dot-files-regexp) + (sort (copy-sequence files) 'string-lessp))) + + ;; `substitute-in-file-name' could return different values. + ;; For `adb', there could be strange file permissions + ;; preventing overwriting a file. We don't care in this + ;; testcase. + (dolist (elt files) + (let ((file1 + (substitute-in-file-name (expand-file-name elt tmp-name1))) + (file2 + (substitute-in-file-name (expand-file-name elt tmp-name2)))) + (ignore-errors (write-region elt nil file1)) + (should (file-exists-p file1)) + (ignore-errors (write-region elt nil file2 nil 'nomessage)) + (should (file-exists-p file2)))) + + (should (equal (directory-files + tmp-name1 nil directory-files-no-dot-files-regexp) + (directory-files + tmp-name2 nil directory-files-no-dot-files-regexp))) + + ;; Check directory creation. We use a subdirectory "foo" + ;; in order to avoid conflicts with previous file name tests. + (dolist (elt files) + (let* ((elt1 (concat elt "foo")) + (file1 (expand-file-name (concat "foo/" elt) tmp-name1)) + (file2 (expand-file-name elt file1)) + (file3 (expand-file-name elt1 file1))) + (make-directory file1 'parents) + (should (file-directory-p file1)) + (write-region elt nil file2) + (should (file-exists-p file2)) + (should + (equal + (directory-files file1 nil directory-files-no-dot-files-regexp) + `(,elt))) + (should + (equal + (caar (directory-files-and-attributes + file1 nil directory-files-no-dot-files-regexp)) + elt)) + + ;; Check symlink in `directory-files-and-attributes'. + (condition-case err + (progn + (make-symbolic-link file2 file3) + (should (file-symlink-p file3)) + (should + (string-equal + (caar (directory-files-and-attributes + file1 nil (regexp-quote elt1))) + elt1)) + (should + (string-equal + (cadr (car (directory-files-and-attributes + file1 nil (regexp-quote elt1)))) + (file-remote-p (file-truename file2) 'localname))) + (delete-file file3) + (should-not (file-exists-p file3))) + (file-error + (should (string-equal (error-message-string err) + "make-symbolic-link not supported")))) + + (delete-file file2) + (should-not (file-exists-p file2)) + (delete-directory file1) + (should-not (file-exists-p file1))))) + + ;; Cleanup. + (ignore-errors (delete-directory tmp-name1 'recursive)) + (ignore-errors (delete-directory tmp-name2 'recursive))))) + +(defun tramp--test-special-characters () + "Perform the test in `tramp-test31-special-characters*'." + ;; Newlines, slashes and backslashes in file names are not + ;; supported. So we don't test. And we don't test the tab + ;; character on Windows or Cygwin, because the backslash is + ;; interpreted as a path separator, preventing "\t" from being + ;; expanded to <TAB>. + (tramp--test-check-files + (if (or (tramp--test-gvfs-p) (tramp--test-smb-or-windows-nt-p)) + "foo bar baz" + (if (or (tramp--test-adb-p) (eq system-type 'cygwin)) + " foo bar baz " + " foo\tbar baz\t")) + "$foo$bar$$baz$" + "-foo-bar-baz-" + "%foo%bar%baz%" + "&foo&bar&baz&" + (unless (or (tramp--test-ftp-p) + (tramp--test-gvfs-p) + (tramp--test-smb-or-windows-nt-p)) + "?foo?bar?baz?") + (unless (or (tramp--test-ftp-p) + (tramp--test-gvfs-p) + (tramp--test-smb-or-windows-nt-p)) + "*foo*bar*baz*") + (if (or (tramp--test-gvfs-p) (tramp--test-smb-or-windows-nt-p)) + "'foo'bar'baz'" + "'foo\"bar'baz\"") + "#foo~bar#baz~" + (if (or (tramp--test-gvfs-p) (tramp--test-smb-or-windows-nt-p)) + "!foo!bar!baz!" + "!foo|bar!baz|") + (if (or (tramp--test-gvfs-p) (tramp--test-smb-or-windows-nt-p)) + ";foo;bar;baz;" + ":foo;bar:baz;") + (unless (or (tramp--test-gvfs-p) (tramp--test-smb-or-windows-nt-p)) + "<foo>bar<baz>") + "(foo)bar(baz)" + (unless (or (tramp--test-ftp-p) (tramp--test-gvfs-p)) "[foo]bar[baz]") + "{foo}bar{baz}")) + +;; These tests are inspired by Bug#17238. +(ert-deftest tramp-test31-special-characters () + "Check special characters in file names." + (skip-unless (tramp--test-enabled)) + + (tramp--test-special-characters)) + +(ert-deftest tramp-test31-special-characters-with-stat () + "Check special characters in file names. +Use the `stat' command." + (skip-unless (tramp--test-enabled)) + (skip-unless + (eq + (tramp-find-foreign-file-name-handler tramp-test-temporary-file-directory) + 'tramp-sh-file-name-handler)) + (with-parsed-tramp-file-name tramp-test-temporary-file-directory nil + (skip-unless (tramp-get-remote-stat v))) + + (let ((tramp-connection-properties + (append + `((,(regexp-quote (file-remote-p tramp-test-temporary-file-directory)) + "perl" nil)) + tramp-connection-properties))) + (tramp--test-special-characters))) + +(ert-deftest tramp-test31-special-characters-with-perl () + "Check special characters in file names. +Use the `perl' command." + (skip-unless (tramp--test-enabled)) + (skip-unless + (eq + (tramp-find-foreign-file-name-handler tramp-test-temporary-file-directory) + 'tramp-sh-file-name-handler)) + (with-parsed-tramp-file-name tramp-test-temporary-file-directory nil + (skip-unless (tramp-get-remote-perl v))) + + (let ((tramp-connection-properties + (append + `((,(regexp-quote (file-remote-p tramp-test-temporary-file-directory)) + "stat" nil) + ;; See `tramp-sh-handle-file-truename'. + (,(regexp-quote (file-remote-p tramp-test-temporary-file-directory)) + "readlink" nil)) + tramp-connection-properties))) + (tramp--test-special-characters))) + +(ert-deftest tramp-test31-special-characters-with-ls () + "Check special characters in file names. +Use the `ls' command." + (skip-unless (tramp--test-enabled)) + (skip-unless + (eq + (tramp-find-foreign-file-name-handler tramp-test-temporary-file-directory) + 'tramp-sh-file-name-handler)) + + (let ((tramp-connection-properties + (append + `((,(regexp-quote (file-remote-p tramp-test-temporary-file-directory)) + "perl" nil) + (,(regexp-quote (file-remote-p tramp-test-temporary-file-directory)) + "stat" nil) + ;; See `tramp-sh-handle-file-truename'. + (,(regexp-quote (file-remote-p tramp-test-temporary-file-directory)) + "readlink" nil)) + tramp-connection-properties))) + (tramp--test-special-characters))) + +(defun tramp--test-utf8 () + "Perform the test in `tramp-test32-utf8*'." + (tramp--instrument-test-case 10 + (let ((coding-system-for-read 'utf-8) + (coding-system-for-write 'utf-8) + (file-name-coding-system 'utf-8)) + (tramp--test-check-files + (unless (tramp--test-hpux-p) "Γυρίστε το Γαλαξία με Ώτο Στοπ") + (unless (or (tramp--test-hpux-p) (tramp--test-darwin-p)) + "أصبح بوسعك الآن تنزيل نسخة كاملة من موسوعة ويكيبيديا العربية لتصفحها بلا اتصال بالإنترنت") + "银河系漫游指南系列" + "Автостопом по гала́ктике")))) + +(ert-deftest tramp-test32-utf8 () + "Check UTF8 encoding in file names and file contents." + (skip-unless (tramp--test-enabled)) + + (tramp--test-utf8)) + +(ert-deftest tramp-test32-utf8-with-stat () + "Check UTF8 encoding in file names and file contents. +Use the `stat' command." + (skip-unless (tramp--test-enabled)) + (skip-unless + (eq + (tramp-find-foreign-file-name-handler tramp-test-temporary-file-directory) + 'tramp-sh-file-name-handler)) + (with-parsed-tramp-file-name tramp-test-temporary-file-directory nil + (skip-unless (tramp-get-remote-stat v))) + + (let ((tramp-connection-properties + (append + `((,(regexp-quote (file-remote-p tramp-test-temporary-file-directory)) + "perl" nil)) + tramp-connection-properties))) + (tramp--test-utf8))) + +(ert-deftest tramp-test32-utf8-with-perl () + "Check UTF8 encoding in file names and file contents. +Use the `perl' command." + (skip-unless (tramp--test-enabled)) + (skip-unless + (eq + (tramp-find-foreign-file-name-handler tramp-test-temporary-file-directory) + 'tramp-sh-file-name-handler)) + (with-parsed-tramp-file-name tramp-test-temporary-file-directory nil + (skip-unless (tramp-get-remote-perl v))) + + (let ((tramp-connection-properties + (append + `((,(regexp-quote (file-remote-p tramp-test-temporary-file-directory)) + "stat" nil) + ;; See `tramp-sh-handle-file-truename'. + (,(regexp-quote (file-remote-p tramp-test-temporary-file-directory)) + "readlink" nil)) + tramp-connection-properties))) + (tramp--test-utf8))) + +(ert-deftest tramp-test32-utf8-with-ls () + "Check UTF8 encoding in file names and file contents. +Use the `ls' command." + (skip-unless (tramp--test-enabled)) + (skip-unless + (eq + (tramp-find-foreign-file-name-handler tramp-test-temporary-file-directory) + 'tramp-sh-file-name-handler)) + + (let ((tramp-connection-properties + (append + `((,(regexp-quote (file-remote-p tramp-test-temporary-file-directory)) + "perl" nil) + (,(regexp-quote (file-remote-p tramp-test-temporary-file-directory)) + "stat" nil) + ;; See `tramp-sh-handle-file-truename'. + (,(regexp-quote (file-remote-p tramp-test-temporary-file-directory)) + "readlink" nil)) + tramp-connection-properties))) + (tramp--test-utf8))) + +;; This test is inspired by Bug#16928. +(ert-deftest tramp-test33-asynchronous-requests () + "Check parallel asynchronous requests. +Such requests could arrive from timers, process filters and +process sentinels. They shall not disturb each other." + ;; Mark as failed until bug has been fixed. + :expected-result :failed + (skip-unless (tramp--test-enabled)) + (skip-unless + (eq + (tramp-find-foreign-file-name-handler tramp-test-temporary-file-directory) + 'tramp-sh-file-name-handler)) + + ;; Keep instrumentation verbosity 0 until Tramp bug is fixed. This + ;; has the side effect, that this test fails instead to abort. Good + ;; for hydra. + (tramp--instrument-test-case 0 + (let* ((tmp-name (tramp--test-make-temp-name)) + (default-directory tmp-name) + (remote-file-name-inhibit-cache t) + timer buffers kill-buffer-query-functions) + + (unwind-protect + (progn + (make-directory tmp-name) + + ;; Setup a timer in order to raise an ordinary command again + ;; and again. `vc-registered' is well suited, because there + ;; are many checks. + (setq + timer + (run-at-time + 0 1 + (lambda () + (when buffers + (vc-registered + (buffer-name (nth (random (length buffers)) buffers))))))) + + ;; Create temporary buffers. The number of buffers + ;; corresponds to the number of processes; it could be + ;; increased in order to make pressure on Tramp. + (dotimes (i 5) + (add-to-list 'buffers (generate-new-buffer "*temp*"))) + + ;; Open asynchronous processes. Set process sentinel. + (dolist (buf buffers) + (async-shell-command "read line; touch $line; echo $line" buf) + (set-process-sentinel + (get-buffer-process buf) + (lambda (proc _state) + (delete-file (buffer-name (process-buffer proc)))))) + + ;; Send a string. Use a random order of the buffers. Mix + ;; with regular operation. + (let ((buffers (copy-sequence buffers)) + buf) + (while buffers + (setq buf (nth (random (length buffers)) buffers)) + (process-send-string + (get-buffer-process buf) (format "'%s'\n" buf)) + (file-attributes (buffer-name buf)) + (setq buffers (delq buf buffers)))) + + ;; Wait until the whole output has been read. + (with-timeout ((* 10 (length buffers)) + (ert-fail "`async-shell-command' timed out")) + (let ((buffers (copy-sequence buffers)) + buf) + (while buffers + (setq buf (nth (random (length buffers)) buffers)) + (if (ignore-errors + (memq (process-status (get-buffer-process buf)) + '(run open))) + (accept-process-output (get-buffer-process buf) 0.1) + (setq buffers (delq buf buffers)))))) + + ;; Check. + (dolist (buf buffers) + (with-current-buffer buf + (should + (string-equal (format "'%s'\n" buf) (buffer-string))))) + (should-not + (directory-files tmp-name nil directory-files-no-dot-files-regexp))) + + ;; Cleanup. + (ignore-errors (cancel-timer timer)) + (ignore-errors (delete-directory tmp-name 'recursive)) + (dolist (buf buffers) + (ignore-errors (kill-buffer buf))))))) + +(ert-deftest tramp-test34-recursive-load () + "Check that Tramp does not fail due to recursive load." + (skip-unless (tramp--test-enabled)) + + (dolist (code + (list + (format + "(expand-file-name %S)" + tramp-test-temporary-file-directory) + (format + "(let ((default-directory %S)) (expand-file-name %S))" + tramp-test-temporary-file-directory + temporary-file-directory))) + (should-not + (string-match + "Recursive load" + (shell-command-to-string + (format + "%s -batch -Q -L %s --eval %s" + (expand-file-name invocation-name invocation-directory) + (mapconcat 'shell-quote-argument load-path " -L ") + (shell-quote-argument code))))))) + +(ert-deftest tramp-test35-unload () + "Check that Tramp and its subpackages unload completely. +Since it unloads Tramp, it shall be the last test to run." + ;; Mark as failed until all symbols are unbound. + :expected-result (if (featurep 'tramp) :failed :passed) + (when (featurep 'tramp) + (unload-feature 'tramp 'force) + ;; No Tramp feature must be left. + (should-not (featurep 'tramp)) + (should-not (all-completions "tramp" (delq 'tramp-tests features))) + ;; `file-name-handler-alist' must be clean. + (should-not (all-completions "tramp" (mapcar 'cdr file-name-handler-alist))) + ;; There shouldn't be left a bound symbol. We do not regard our + ;; test symbols, and the Tramp unload hooks. + (mapatoms + (lambda (x) + (and (or (boundp x) (functionp x)) + (string-match "^tramp" (symbol-name x)) + (not (string-match "^tramp--?test" (symbol-name x))) + (not (string-match "unload-hook$" (symbol-name x))) + (ert-fail (format "`%s' still bound" x))))) + ;; There shouldn't be left a hook function containing a Tramp + ;; function. We do not regard the Tramp unload hooks. + (mapatoms + (lambda (x) + (and (boundp x) + (string-match "-hooks?$" (symbol-name x)) + (not (string-match "unload-hook$" (symbol-name x))) + (consp (symbol-value x)) + (ignore-errors (all-completions "tramp" (symbol-value x))) + (ert-fail (format "Hook `%s' still contains Tramp function" x))))))) + +;; TODO: + +;; * dired-compress-file +;; * dired-uncache +;; * file-acl +;; * file-ownership-preserved-p +;; * file-selinux-context +;; * find-backup-file-name +;; * set-file-acl +;; * set-file-selinux-context + +;; * Work on skipped tests. Make a comment, when it is impossible. +;; * Fix `tramp-test15-copy-directory' for `smb'. Using tar in a pipe +;; doesn't work well when an interactive password must be provided. +;; * Fix `tramp-test27-start-file-process' on MS Windows (`process-send-eof'?). +;; * Fix Bug#16928. Set expected error of `tramp-test33-asynchronous-requests'. +;; * Fix `tramp-test35-unload' (Not all symbols are unbound). Set +;; expected error. + +(defun tramp-test-all (&optional interactive) + "Run all tests for \\[tramp]." + (interactive "p") + (funcall + (if interactive 'ert-run-tests-interactively 'ert-run-tests-batch) "^tramp")) + +(provide 'tramp-tests) +;;; tramp-tests.el ends here diff --git a/test/lisp/obarray-tests.el b/test/lisp/obarray-tests.el new file mode 100644 index 00000000000..92345b7198e --- /dev/null +++ b/test/lisp/obarray-tests.el @@ -0,0 +1,90 @@ +;;; obarray-tests.el --- Tests for obarray -*- lexical-binding: t; -*- + +;; Copyright (C) 2015-2016 Free Software Foundation, Inc. + +;; Author: Przemysław Wojnowski <esperanto@cumego.com> + +;; 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: + +;;; Code: + +(require 'obarray) +(require 'ert) + +(ert-deftest obarrayp-test () + "Should assert that given object is an obarray." + (should-not (obarrayp 42)) + (should-not (obarrayp "aoeu")) + (should-not (obarrayp '())) + (should-not (obarrayp [])) + (should (obarrayp (make-vector 7 0)))) + +(ert-deftest obarrayp-unchecked-content-test () + "Should fail to check content of passed obarray." + :expected-result :failed + (should-not (obarrayp ["a" "b" "c"])) + (should-not (obarrayp [1 2 3]))) + +(ert-deftest obarray-make-default-test () + (let ((table (obarray-make))) + (should (obarrayp table)) + (should (equal (make-vector 59 0) table)))) + +(ert-deftest obarray-make-with-size-test () + (should-error (obarray-make -1) :type 'wrong-type-argument) + (should-error (obarray-make 0) :type 'wrong-type-argument) + (let ((table (obarray-make 1))) + (should (obarrayp table)) + (should (equal (make-vector 1 0) table)))) + +(ert-deftest obarray-get-test () + (let ((table (obarray-make 3))) + (should-not (obarray-get table "aoeu")) + (intern "aoeu" table) + (should (string= "aoeu" (obarray-get table "aoeu"))))) + +(ert-deftest obarray-put-test () + (let ((table (obarray-make 3))) + (should-not (obarray-get table "aoeu")) + (should (string= "aoeu" (obarray-put table "aoeu"))) + (should (string= "aoeu" (obarray-get table "aoeu"))))) + +(ert-deftest obarray-remove-test () + (let ((table (obarray-make 3))) + (should-not (obarray-get table "aoeu")) + (should-not (obarray-remove table "aoeu")) + (should (string= "aoeu" (obarray-put table "aoeu"))) + (should (string= "aoeu" (obarray-get table "aoeu"))) + (should (obarray-remove table "aoeu")) + (should-not (obarray-get table "aoeu")))) + +(ert-deftest obarray-map-test () + "Should execute function on all elements of obarray." + (let* ((table (obarray-make 3)) + (syms '()) + (collect-names (lambda (sym) (push (symbol-name sym) syms)))) + (obarray-map collect-names table) + (should (null syms)) + (obarray-put table "a") + (obarray-put table "b") + (obarray-put table "c") + (obarray-map collect-names table) + (should (equal (sort syms #'string<) '("a" "b" "c"))))) + +(provide 'obarray-tests) +;;; obarray-tests.el ends here diff --git a/test/lisp/progmodes/compile-tests.el b/test/lisp/progmodes/compile-tests.el new file mode 100644 index 00000000000..6821a6bfae5 --- /dev/null +++ b/test/lisp/progmodes/compile-tests.el @@ -0,0 +1,366 @@ +;;; compile-tests.el --- Test suite for font parsing. + +;; Copyright (C) 2011-2016 Free Software Foundation, Inc. + +;; Author: Chong Yidong <cyd@stupidchicken.com> +;; Keywords: internal +;; Human-Keywords: internal + +;; 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/>. + +;;; Code: + +(require 'ert) +(require 'compile) + +(defvar compile-tests--test-regexps-data + ;; The computed column numbers are zero-indexed, so subtract 1 from + ;; what's reported in the string. The end column numbers are for + ;; the character after, so it matches what's reported in the string. + '(;; absoft + ("Error on line 3 of t.f: Execution error unclassifiable statement" + 1 nil 3 "t.f") + ("Line 45 of \"foo.c\": bloofle undefined" + 1 nil 45 "foo.c") + ("error on line 19 of fplot.f: spelling error?" + 1 nil 19 "fplot.f") + ("warning on line 17 of fplot.f: data type is undefined for variable d" + 1 nil 17 "fplot.f") + ;; Ada & Mpatrol + ("foo.adb:61:11: [...] in call to size declared at foo.ads:11" + 1 11 61 "foo.adb") + ("foo.adb:61:11: [...] in call to size declared at foo.ads:11" + 52 nil 11 "foo.ads") + (" 0x8008621 main+16 at error.c:17" + 23 nil 17 "error.c") + ;; aix + ("****** Error number 140 in line 8 of file errors.c ******" + 25 nil 8 "errors.c") + ;; ant + ("[javac] /src/DataBaseTestCase.java:27: unreported exception ..." + 13 nil 27 "/src/DataBaseTestCase.java") + ("[javac] /src/DataBaseTestCase.java:49: warning: finally clause cannot complete normally" + 13 nil 49 "/src/DataBaseTestCase.java") + ("[jikes] foo.java:3:5:7:9: blah blah" + 14 (5 . 10) (3 . 7) "foo.java") + ;; bash + ("a.sh: line 1: ls-l: command not found" + 1 nil 1 "a.sh") + ;; borland + ("Error ping.c 15: Unable to open include file 'sys/types.h'" + 1 nil 15 "ping.c") + ("Warning pong.c 68: Call to function 'func' with no prototype" + 1 nil 68 "pong.c") + ("Error E2010 ping.c 15: Unable to open include file 'sys/types.h'" + 1 nil 15 "ping.c") + ("Warning W1022 pong.c 68: Call to function 'func' with no prototype" + 1 nil 68 "pong.c") + ;; caml + ("File \"foobar.ml\", lines 5-8, characters 20-155: blah blah" + 1 (20 . 156) (5 . 8) "foobar.ml") + ("File \"F:\\ocaml\\sorting.ml\", line 65, characters 2-145:\nWarning 26: unused variable equ." + 1 (2 . 146) 65 "F:\\ocaml\\sorting.ml") + ("File \"/usr/share/gdesklets/display/TargetGauge.py\", line 41, in add_children" + 1 nil 41 "/usr/share/gdesklets/display/TargetGauge.py") + ("File \\lib\\python\\Products\\PythonScripts\\PythonScript.py, line 302, in _exec" + 1 nil 302 "\\lib\\python\\Products\\PythonScripts\\PythonScript.py") + ("File \"/tmp/foo.py\", line 10" + 1 nil 10 "/tmp/foo.py") + ;; comma + ("\"foo.f\", line 3: Error: syntax error near end of statement" + 1 nil 3 "foo.f") + ("\"vvouch.c\", line 19.5: 1506-046 (S) Syntax error." + 1 5 19 "vvouch.c") + ("\"foo.c\", line 32 pos 1; (E) syntax error; unexpected symbol: \"lossage\"" + 1 1 32 "foo.c") + ("\"foo.adb\", line 2(11): warning: file name does not match ..." + 1 11 2 "foo.adb") + ("\"src/swapping.c\", line 30.34: 1506-342 (W) \"/*\" detected in comment." + 1 34 30 "src/swapping.c") + ;; cucumber + ("Scenario: undefined step # features/cucumber.feature:3" + 29 nil 3 "features/cucumber.feature") + (" /home/gusev/.rvm/foo/bar.rb:500:in `_wrap_assertion'" + 1 nil 500 "/home/gusev/.rvm/foo/bar.rb") + ;; edg-1 edg-2 + ("build/intel/debug/../../../struct.cpp(42): error: identifier \"foo\" is undefined" + 1 nil 42 "build/intel/debug/../../../struct.cpp") + ("build/intel/debug/struct.cpp(44): warning #1011: missing return statement at end of" + 1 nil 44 "build/intel/debug/struct.cpp") + ("build/intel/debug/iptr.h(302): remark #981: operands are evaluated in unspecified order" + 1 nil 302 "build/intel/debug/iptr.h") + (" detected during ... at line 62 of \"build/intel/debug/../../../trace.h\"" + 31 nil 62 "build/intel/debug/../../../trace.h") + ;; epc + ("Error 24 at (2:progran.f90) : syntax error" + 1 nil 2 "progran.f90") + ;; ftnchek + (" Dummy arg W in module SUBA line 8 file arrayclash.f is array" + 32 nil 8 "arrayclash.f") + (" L4 used at line 55 file test/assign.f; never set" + 16 nil 55 "test/assign.f") + ("Warning near line 10 file arrayclash.f: Module contains no executable" + 1 nil 10 "arrayclash.f") + ("Nonportable usage near line 31 col 9 file assign.f: mixed default and explicit" + 24 9 31 "assign.f") + ;; iar + ("\"foo.c\",3 Error[32]: Error message" + 1 nil 3 "foo.c") + ("\"foo.c\",3 Warning[32]: Error message" + 1 nil 3 "foo.c") + ;; ibm + ("foo.c(2:0) : informational EDC0804: Function foo is not referenced." + 1 0 2 "foo.c") + ("foo.c(3:8) : warning EDC0833: Implicit return statement encountered." + 1 8 3 "foo.c") + ("foo.c(5:5) : error EDC0350: Syntax error." + 1 5 5 "foo.c") + ;; irix + ("ccom: Error: foo.c, line 2: syntax error" + 1 nil 2 "foo.c") + ("cc: Severe: /src/Python-2.3.3/Modules/_curses_panel.c, line 17: Cannot find file <panel.h> ..." + 1 nil 17 "/src/Python-2.3.3/Modules/_curses_panel.c") + ("cc: Info: foo.c, line 27: ..." + 1 nil 27 "foo.c") + ("cfe: Warning 712: foo.c, line 2: illegal combination of pointer and ..." + 1 nil 2 "foo.c") + ("cfe: Warning 600: xfe.c: 170: Not in a conditional directive while ..." + 1 nil 170 "xfe.c") + ("/usr/lib/cmplrs/cc/cfe: Error: foo.c: 1: blah blah" + 1 nil 1 "foo.c") + ("/usr/lib/cmplrs/cc/cfe: warning: foo.c: 1: blah blah" + 1 nil 1 "foo.c") + ("foo bar: baz.f, line 27: ..." + 1 nil 27 "baz.f") + ;; java + ("\tat org.foo.ComponentGateway.doGet(ComponentGateway.java:172)" + 5 nil 172 "ComponentGateway.java") + ("\tat javax.servlet.http.HttpServlet.service(HttpServlet.java:740)" + 5 nil 740 "HttpServlet.java") + ("==1332== at 0x4040743C: System::getErrorString() (../src/Lib/System.cpp:217)" + 13 nil 217 "../src/Lib/System.cpp") + ("==1332== by 0x8008621: main (vtest.c:180)" + 13 nil 180 "vtest.c") + ;; jikes-file jikes-line + ("Found 2 semantic errors compiling \"../javax/swing/BorderFactory.java\":" + 1 nil nil "../javax/swing/BorderFactory.java") + ("Issued 1 semantic warning compiling \"java/awt/Toolkit.java\":" + 1 nil nil "java/awt/Toolkit.java") + ;; gcc-include + ("In file included from /usr/include/c++/3.3/backward/warn.h:4," + 1 nil 4 "/usr/include/c++/3.3/backward/warn.h") + (" from /usr/include/c++/3.3/backward/iostream.h:31:0," + 1 0 31 "/usr/include/c++/3.3/backward/iostream.h") + (" from test_clt.cc:1:" + 1 nil 1 "test_clt.cc") + ;; gnu + ("foo.c:8: message" 1 nil 8 "foo.c") + ("../foo.c:8: W: message" 1 nil 8 "../foo.c") + ("/tmp/foo.c:8:warning message" 1 nil 8 "/tmp/foo.c") + ("foo/bar.py:8: FutureWarning message" 1 nil 8 "foo/bar.py") + ("foo.py:8: RuntimeWarning message" 1 nil 8 "foo.py") + ("foo.c:8:I: message" 1 nil 8 "foo.c") + ("foo.c:8.23: note: message" 1 23 8 "foo.c") + ("foo.c:8.23: info: message" 1 23 8 "foo.c") + ("foo.c:8:23:information: message" 1 23 8 "foo.c") + ("foo.c:8.23-45: Informational: message" 1 (23 . 46) (8 . nil) "foo.c") + ("foo.c:8-23: message" 1 nil (8 . 23) "foo.c") + ;; The next one is not in the GNU standards AFAICS. + ;; Here we seem to interpret it as LINE1-LINE2.COL2. + ("foo.c:8-45.3: message" 1 (nil . 4) (8 . 45) "foo.c") + ("foo.c:8.23-9.1: message" 1 (23 . 2) (8 . 9) "foo.c") + ("jade:dbcommon.dsl:133:17:E: missing argument for function call" + 1 17 133 "dbcommon.dsl") + ("G:/cygwin/dev/build-myproj.xml:54: Compiler Adapter 'javac' can't be found." + 1 nil 54 "G:/cygwin/dev/build-myproj.xml") + ("file:G:/cygwin/dev/build-myproj.xml:54: Compiler Adapter 'javac' can't be found." + 1 nil 54 "G:/cygwin/dev/build-myproj.xml") + ("{standard input}:27041: Warning: end of file not at end of a line; newline inserted" + 1 nil 27041 "{standard input}") + ;; Guile + ("In foo.scm:\n" 1 nil nil "foo.scm") + (" 63:4 [call-with-prompt prompt0 ...]" 1 4 63 nil) + ("1038: 1 [main (\"gud-break.scm\")]" 1 1 1038 nil) + ;; lcc + ("E, file.cc(35,52) Illegal operation on pointers" 1 52 35 "file.cc") + ("W, file.cc(36,52) blah blah" 1 52 36 "file.cc") + ;; makepp + ("makepp: Scanning `/foo/bar.c'" 19 nil nil "/foo/bar.c") + ("makepp: warning: bla bla `/foo/bar.c' and `/foo/bar.h'" 27 nil nil "/foo/bar.c") + ("makepp: bla bla `/foo/Makeppfile:12' bla" 18 nil 12 "/foo/Makeppfile") + ("makepp: bla bla `/foo/bar.c' and `/foo/bar.h'" 35 nil nil "/foo/bar.h") + ;; maven + ("FooBar.java:[111,53] no interface expected here" + 1 53 111 "FooBar.java" 2) + (" [ERROR] /Users/cinsk/hello.java:[651,96] ';' expected" + 15 96 651 "/Users/cinsk/hello.java" 2) ;Bug#11517. + ("[WARNING] /foo/bar/Test.java:[27,43] unchecked conversion" + 11 43 27 "/foo/bar/Test.java" 1) ;Bug#20556 + ;; mips-1 mips-2 + ("TrimMask (255) in solomon.c may be indistinguishable from TrimMasks (93) in solomo.c due to truncation" + 11 nil 255 "solomon.c") + ("TrimMask (255) in solomon.c may be indistinguishable from TrimMasks (93) in solomo.c due to truncation" + 70 nil 93 "solomo.c") + ("name defined but never used: LinInt in cmap_calc.c(199)" + 40 nil 199 "cmap_calc.c") + ;; msft + ("keyboard handler.c(537) : warning C4005: 'min' : macro redefinition" + 1 nil 537 "keyboard handler.c") + ("d:\\tmp\\test.c(23) : error C2143: syntax error : missing ';' before 'if'" + 1 nil 23 "d:\\tmp\\test.c") + ("d:\\tmp\\test.c(1145) : see declaration of 'nsRefPtr'" + 1 nil 1145 "d:\\tmp\\test.c") + ("1>test_main.cpp(29): error C2144: syntax error : 'int' should be preceded by ';'" + 3 nil 29 "test_main.cpp") + ("1>test_main.cpp(29): error C4430: missing type specifier - int assumed. Note: C++ does not support default-int" + 3 nil 29 "test_main.cpp") + ;; watcom + ("..\\src\\ctrl\\lister.c(109): Error! E1009: Expecting ';' but found '{'" + 1 nil 109 "..\\src\\ctrl\\lister.c") + ("..\\src\\ctrl\\lister.c(120): Warning! W201: Unreachable code" + 1 nil 120 "..\\src\\ctrl\\lister.c") + ;; oracle + ("Semantic error at line 528, column 5, file erosacqdb.pc:" + 1 5 528 "erosacqdb.pc") + ("Error at line 41, column 10 in file /usr/src/sb/ODBI_BHP.hpp" + 1 10 41 "/usr/src/sb/ODBI_BHP.hpp") + ("PCC-02150: error at line 49, column 27 in file /usr/src/sb/ODBI_dxfgh.pc" + 1 27 49 "/usr/src/sb/ODBI_dxfgh.pc") + ("PCC-00003: invalid SQL Identifier at column name in line 12 of file /usr/src/sb/ODBI_BHP.hpp" + 1 nil 12 "/usr/src/sb/ODBI_BHP.hpp") + ("PCC-00004: mismatched IF/ELSE/ENDIF block at line 27 in file /usr/src/sb/ODBI_BHP.hpp" + 1 nil 27 "/usr/src/sb/ODBI_BHP.hpp") + ("PCC-02151: line 21 column 40 file /usr/src/sb/ODBI_BHP.hpp:" + 1 40 21 "/usr/src/sb/ODBI_BHP.hpp") + ;; perl + ("syntax error at automake line 922, near \"':'\"" + 14 nil 922 "automake") + ("Died at test.pl line 27." + 6 nil 27 "test.pl") + ("store::odrecall('File_A', 'x2') called at store.pm line 90" + 40 nil 90 "store.pm") + ("\t(in cleanup) something bad at foo.pl line 3 during global destruction." + 29 nil 3 "foo.pl") + ("GLib-GObject-WARNING **: /build/buildd/glib2.0-2.14.5/gobject/gsignal.c:1741: instance `0x8206790' has no handler with id `1234' at t-compilation-perl-gtk.pl line 3." + 130 nil 3 "t-compilation-perl-gtk.pl") + ;; php + ("Parse error: parse error, unexpected $ in main.php on line 59" + 1 nil 59 "main.php") + ("Fatal error: Call to undefined function: mysql_pconnect() in db.inc on line 66" + 1 nil 66 "db.inc") + ;; ruby + ("plain-exception.rb:7:in `fun': unhandled exception" + 1 nil 7 "plain-exception.rb") + ("\tfrom plain-exception.rb:3:in `proxy'" 2 nil 3 "plain-exception.rb") + ("\tfrom plain-exception.rb:12" 2 nil 12 "plain-exception.rb") + ;; ruby-Test::Unit + ;; FIXME + (" [examples/test-unit.rb:28:in `here_is_a_deep_assert'" + 5 nil 28 "examples/test-unit.rb") + (" examples/test-unit.rb:19:in `test_a_deep_assert']:" + 6 nil 19 "examples/test-unit.rb") + ("examples/test-unit.rb:10:in `test_assert_raise'" + 1 nil 10 "examples/test-unit.rb") + ;; rxp + ("Error: Mismatched end tag: expected </geroup>, got </group>\nin unnamed entity at line 71 char 8 of file:///home/reto/test/group.xml" + 1 8 71 "/home/reto/test/group.xml") + ("Warning: Start tag for undeclared element geroup\nin unnamed entity at line 4 char 8 of file:///home/reto/test/group.xml" + 1 8 4 "/home/reto/test/group.xml") + ;; sparc-pascal-file sparc-pascal-line sparc-pascal-example + ("Thu May 14 10:46:12 1992 mom3.p:" + 1 nil nil "mom3.p") + ;; sun + ("cc-1020 CC: REMARK File = CUI_App.h, Line = 735" + 13 nil 735 "CUI_App.h") + ("cc-1070 cc: WARNING File = linkl.c, Line = 38" + 13 nil 38 "linkl.c") + ("cf90-113 f90comp: ERROR NSE, File = Hoved.f90, Line = 16, Column = 3" + 18 3 16 "Hoved.f90") + ;; sun-ada + ("/home3/xdhar/rcds_rc/main.a, line 361, char 6:syntax error: \",\" inserted" + 1 6 361 "/home3/xdhar/rcds_rc/main.a") + ;; 4bsd + ("/usr/src/foo/foo.c(8): warning: w may be used before set" + 1 nil 8 "/usr/src/foo/foo.c") + ("/usr/src/foo/foo.c(9): error: w is used before set" + 1 nil 9 "/usr/src/foo/foo.c") + ("strcmp: variable # of args. llib-lc(359) :: /usr/src/foo/foo.c(8)" + 44 nil 8 "/usr/src/foo/foo.c") + ("bloofle defined( /users/wolfgang/foo.c(4) ), but never used" + 18 nil 4 "/users/wolfgang/foo.c") + ;; perl--Pod::Checker + ;; FIXME + ;; *** ERROR: Spurious text after =cut at line 193 in file foo.pm + ;; *** ERROR: =over on line 37 without closing =back at line EOF in file bar.pm + ;; *** ERROR: =over on line 1 without closing =back (at head1) at line 3 in file x.pod + ;; perl--Test + ("# Failed test 1 in foo.t at line 6" + 1 nil 6 "foo.t") + ;; perl--Test::Harness + ("NOK 1# Test 1 got: \"1234\" (t/foo.t at line 46)" + 1 nil 46 "t/foo.t") + ;; weblint + ("index.html (13:1) Unknown element <fdjsk>" + 1 1 13 "index.html")) + "List of tests for `compilation-error-regexp-alist'. +Each element has the form (STR POS COLUMN LINE FILENAME), where +STR is an error string, POS is the position of the error in STR, +COLUMN and LINE are the reported column and line numbers (or nil) +for that error, and FILENAME is the reported filename. + +LINE can also be of the form (LINE . END-LINE) meaning a range of +lines. COLUMN can also be of the form (COLUMN . END-COLUMN) +meaning a range of columns starting on LINE and ending on +END-LINE, if that matched.") + +(defun compile--test-error-line (test) + (erase-buffer) + (setq compilation-locs (make-hash-table)) + (insert (car test)) + (compilation-parse-errors (point-min) (point-max)) + (let ((msg (get-text-property (nth 1 test) 'compilation-message))) + (when msg + (let ((loc (compilation--message->loc msg)) + (col (nth 2 test)) + (line (nth 3 test)) + (file (nth 4 test)) + (type (nth 5 test)) + end-col end-line) + (if (consp col) + (setq end-col (cdr col) col (car col))) + (if (consp line) + (setq end-line (cdr line) line (car line))) + (and (equal (compilation--loc->col loc) col) + (equal (compilation--loc->line loc) line) + (or (not file) + (equal (caar (compilation--loc->file-struct loc)) file)) + (or (null end-col) + (equal (car (cadr (nth 2 (compilation--loc->file-struct loc)))) + end-col)) + (equal (car (nth 2 (compilation--loc->file-struct loc))) + (or end-line line)) + (or (null type) + (equal type (compilation--message->type msg)))))))) + +(ert-deftest compile-test-error-regexps () + "Test the `compilation-error-regexp-alist' regexps. +The test data is in `compile-tests--test-regexps-data'." + (with-temp-buffer + (font-lock-mode -1) + (dolist (test compile-tests--test-regexps-data) + (should (compile--test-error-line test))))) + +;;; compile-tests.el ends here. diff --git a/test/lisp/progmodes/elisp-mode-tests.el b/test/lisp/progmodes/elisp-mode-tests.el new file mode 100644 index 00000000000..1679af30821 --- /dev/null +++ b/test/lisp/progmodes/elisp-mode-tests.el @@ -0,0 +1,645 @@ +;;; elisp-mode-tests.el --- Tests for emacs-lisp-mode -*- lexical-binding: t; -*- + +;; Copyright (C) 2015-2016 Free Software Foundation, Inc. + +;; Author: Dmitry Gutov <dgutov@yandex.ru> +;; Author: Stephen Leake <stephen_leake@member.fsf.org> + +;; 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/>. + +;;; Code: + +(require 'ert) +(require 'xref) + +;;; Completion + +(defun elisp--test-completions () + (let ((data (elisp-completion-at-point))) + (all-completions (buffer-substring (nth 0 data) (nth 1 data)) + (nth 2 data) + (plist-get (nthcdr 3 data) :predicate)))) + +(ert-deftest elisp-completes-functions () + (with-temp-buffer + (emacs-lisp-mode) + (insert "(ba") + (let ((comps (elisp--test-completions))) + (should (member "backup-buffer" comps)) + (should-not (member "backup-inhibited" comps))))) + +(ert-deftest elisp-completes-variables () + (with-temp-buffer + (emacs-lisp-mode) + (insert "(foo ba") + (let ((comps (elisp--test-completions))) + (should (member "backup-inhibited" comps)) + (should-not (member "backup-buffer" comps))))) + +(ert-deftest elisp-completes-anything-quoted () + (dolist (text '("`(foo ba" "(foo 'ba" + "`(,foo ba" "`,(foo `ba" + "'(foo (ba")) + (with-temp-buffer + (emacs-lisp-mode) + (insert text) + (let ((comps (elisp--test-completions))) + (should (member "backup-inhibited" comps)) + (should (member "backup-buffer" comps)) + (should (member "backup" comps)))))) + +(ert-deftest elisp-completes-variables-unquoted () + (dolist (text '("`(foo ,ba" "`(,(foo ba" "`(,ba")) + (with-temp-buffer + (emacs-lisp-mode) + (insert text) + (let ((comps (elisp--test-completions))) + (should (member "backup-inhibited" comps)) + (should-not (member "backup-buffer" comps)))))) + +(ert-deftest elisp-completes-functions-in-special-macros () + (dolist (text '("(declare-function ba" "(cl-callf2 ba")) + (with-temp-buffer + (emacs-lisp-mode) + (insert text) + (let ((comps (elisp--test-completions))) + (should (member "backup-buffer" comps)) + (should-not (member "backup-inhibited" comps)))))) + +(ert-deftest elisp-completes-functions-after-hash-quote () + (ert-deftest elisp-completes-functions-after-let-bindings () + (with-temp-buffer + (emacs-lisp-mode) + (insert "#'ba") + (let ((comps (elisp--test-completions))) + (should (member "backup-buffer" comps)) + (should-not (member "backup-inhibited" comps)))))) + +(ert-deftest elisp-completes-local-variables () + (with-temp-buffer + (emacs-lisp-mode) + (insert "(let ((bar 1) baz) (foo ba") + (let ((comps (elisp--test-completions))) + (should (member "backup-inhibited" comps)) + (should (member "bar" comps)) + (should (member "baz" comps))))) + +(ert-deftest elisp-completest-variables-in-let-bindings () + (dolist (text '("(let (ba" "(let* ((ba")) + (with-temp-buffer + (emacs-lisp-mode) + (insert text) + (let ((comps (elisp--test-completions))) + (should (member "backup-inhibited" comps)) + (should-not (member "backup-buffer" comps)))))) + +(ert-deftest elisp-completes-functions-after-let-bindings () + (with-temp-buffer + (emacs-lisp-mode) + (insert "(let ((bar 1) (baz 2)) (ba") + (let ((comps (elisp--test-completions))) + (should (member "backup-buffer" comps)) + (should-not (member "backup-inhibited" comps))))) + +;;; xref + +(defun xref-elisp-test-descr-to-target (xref) + "Return an appropriate `looking-at' match string for XREF." + (let* ((loc (xref-item-location xref)) + (type (or (xref-elisp-location-type loc) + 'defun))) + + (cl-case type + (defalias + ;; summary: "(defalias xref)" + ;; target : "(defalias 'xref" + (concat "(defalias '" (substring (xref-item-summary xref) 10 -1))) + + (defun + (let ((summary (xref-item-summary xref)) + (file (xref-elisp-location-file loc))) + (cond + ((string= "c" (file-name-extension file)) + ;; summary: "(defun buffer-live-p)" + ;; target : "DEFUN (buffer-live-p" + (concat + (upcase (substring summary 1 6)) + " (\"" + (substring summary 7 -1) + "\"")) + + (t + (substring summary 0 -1)) + ))) + + (defvar + (let ((summary (xref-item-summary xref)) + (file (xref-elisp-location-file loc))) + (cond + ((string= "c" (file-name-extension file)) + ;; summary: "(defvar system-name)" + ;; target : "DEFVAR_LISP ("system-name", " + ;; summary: "(defvar abbrev-mode)" + ;; target : DEFVAR_PER_BUFFER ("abbrev-mode" + (concat + (upcase (substring summary 1 7)) + (if (bufferp (variable-binding-locus (xref-elisp-location-symbol loc))) + "_PER_BUFFER (\"" + "_LISP (\"") + (substring summary 8 -1) + "\"")) + + (t + (substring summary 0 -1)) + ))) + + (feature + ;; summary: "(feature xref)" + ;; target : "(provide 'xref)" + (concat "(provide '" (substring (xref-item-summary xref) 9 -1))) + + (otherwise + (substring (xref-item-summary xref) 0 -1)) + ))) + + +(defun xref-elisp-test-run (xrefs expected-xrefs) + (should (= (length xrefs) (length expected-xrefs))) + (while xrefs + (let* ((xref (pop xrefs)) + (expected (pop expected-xrefs)) + (expected-xref (or (when (consp expected) (car expected)) expected)) + (expected-source (when (consp expected) (cdr expected)))) + + ;; Downcase the filenames for case-insensitive file systems. + (setf (xref-elisp-location-file (oref xref location)) + (downcase (xref-elisp-location-file (oref xref location)))) + + (setf (xref-elisp-location-file (oref expected-xref location)) + (downcase (xref-elisp-location-file (oref expected-xref location)))) + + (should (equal xref expected-xref)) + + (xref--goto-location (xref-item-location xref)) + (back-to-indentation) + (should (looking-at (or expected-source + (xref-elisp-test-descr-to-target expected))))) + )) + +(defmacro xref-elisp-deftest (name computed-xrefs expected-xrefs) + "Define an ert test for an xref-elisp feature. +COMPUTED-XREFS and EXPECTED-XREFS are lists of xrefs, except if +an element of EXPECTED-XREFS is a cons (XREF . TARGET), TARGET is +matched to the found location; otherwise, match +to (xref-elisp-test-descr-to-target xref)." + (declare (indent defun) + (debug (symbolp "name"))) + `(ert-deftest ,(intern (concat "xref-elisp-test-" (symbol-name name))) () + (let ((find-file-suppress-same-file-warnings t)) + (xref-elisp-test-run ,computed-xrefs ,expected-xrefs) + ))) + +;; When tests are run from the Makefile, 'default-directory' is $HOME, +;; so we must provide this dir to expand-file-name in the expected +;; results. This also allows running these tests from other +;; directories. +;; +;; We add 'downcase' here to deliberately cause a potential problem on +;; case-insensitive file systems. On such systems, `load-file-name' +;; may not have the same case as the real file system, since the user +;; can set `load-path' to have the wrong case (on my Windows system, +;; `load-path' has the correct case, so this causes the expected test +;; values to have the wrong case). This is handled in +;; `xref-elisp-test-run'. +(defconst emacs-test-dir (downcase (file-name-directory (or load-file-name (buffer-file-name))))) + + +;; alphabetical by test name + +;; Autoloads require no special support; they are handled as functions. + +;; FIXME: defalias-defun-c cmpl-prefix-entry-head +;; FIXME: defalias-defvar-el allout-mode-map + +(xref-elisp-deftest find-defs-constructor + (elisp--xref-find-definitions 'xref-make-elisp-location) + ;; 'xref-make-elisp-location' is just a name for the default + ;; constructor created by the cl-defstruct, so the location is the + ;; cl-defstruct location. + (list + (cons + (xref-make "(cl-defstruct (xref-elisp-location (:constructor xref-make-elisp-location)))" + (xref-make-elisp-location + 'xref-elisp-location 'define-type + (expand-file-name "../../../lisp/progmodes/elisp-mode.el" emacs-test-dir))) + ;; It's not worth adding another special case to `xref-elisp-test-descr-to-target' for this + "(cl-defstruct (xref-elisp-location") + )) + +(xref-elisp-deftest find-defs-defalias-defun-el + (elisp--xref-find-definitions 'Buffer-menu-sort) + (list + (xref-make "(defalias Buffer-menu-sort)" + (xref-make-elisp-location + 'Buffer-menu-sort 'defalias + (expand-file-name "../../../lisp/buff-menu.elc" emacs-test-dir))) + (xref-make "(defun tabulated-list-sort)" + (xref-make-elisp-location + 'tabulated-list-sort nil + (expand-file-name "../../../lisp/emacs-lisp/tabulated-list.el" emacs-test-dir))) + )) + +;; FIXME: defconst + +;; FIXME: eieio defclass + +;; Possible ways of defining the default method implementation for a +;; generic function. We declare these here, so we know we cover all +;; cases, and we don't rely on other code not changing. +;; +;; When the generic and default method are declared in the same place, +;; elisp--xref-find-definitions only returns one. + +(cl-defstruct (xref-elisp-root-type) + slot-1) + +(cl-defgeneric xref-elisp-generic-no-methods (arg1 arg2) + "doc string generic no-methods" + ;; No default implementation, no methods, but fboundp is true for + ;; this symbol; it calls cl-no-applicable-method + ) + +;; WORKAROUND: ‘this’ is unused, and the byte compiler complains, so +;; it should be spelled ‘_this’. But for some unknown reason, that +;; causes the batch mode test to fail; the symbol shows up as +;; ‘this’. It passes in interactive tests, so I haven't been able to +;; track down the problem. +(cl-defmethod xref-elisp-generic-no-default ((this xref-elisp-root-type) arg2) + "doc string generic no-default xref-elisp-root-type" + "non-default for no-default") + +;; defgeneric after defmethod in file to ensure the fallback search +;; method of just looking for the function name will fail. +(cl-defgeneric xref-elisp-generic-no-default (arg1 arg2) + "doc string generic no-default generic" + ;; No default implementation; this function calls the cl-generic + ;; dispatching code. + ) + +(cl-defgeneric xref-elisp-generic-co-located-default (arg1 arg2) + "doc string generic co-located-default" + "co-located default") + +(cl-defmethod xref-elisp-generic-co-located-default ((this xref-elisp-root-type) arg2) + "doc string generic co-located-default xref-elisp-root-type" + "non-default for co-located-default") + +(cl-defgeneric xref-elisp-generic-separate-default (arg1 arg2) + "doc string generic separate-default" + ;; default implementation provided separately + ) + +(cl-defmethod xref-elisp-generic-separate-default (arg1 arg2) + "doc string generic separate-default default" + "separate default") + +(cl-defmethod xref-elisp-generic-separate-default ((this xref-elisp-root-type) arg2) + "doc string generic separate-default xref-elisp-root-type" + "non-default for separate-default") + +(cl-defmethod xref-elisp-generic-implicit-generic (arg1 arg2) + "doc string generic implicit-generic default" + "default for implicit generic") + +(cl-defmethod xref-elisp-generic-implicit-generic ((this xref-elisp-root-type) arg2) + "doc string generic implicit-generic xref-elisp-root-type" + "non-default for implicit generic") + + +(xref-elisp-deftest find-defs-defgeneric-no-methods + (elisp--xref-find-definitions 'xref-elisp-generic-no-methods) + (list + (xref-make "(cl-defgeneric xref-elisp-generic-no-methods)" + (xref-make-elisp-location + 'xref-elisp-generic-no-methods 'cl-defgeneric + (expand-file-name "elisp-mode-tests.el" emacs-test-dir))) + )) + +(xref-elisp-deftest find-defs-defgeneric-no-default + (elisp--xref-find-definitions 'xref-elisp-generic-no-default) + (list + (xref-make "(cl-defgeneric xref-elisp-generic-no-default)" + (xref-make-elisp-location + 'xref-elisp-generic-no-default 'cl-defgeneric + (expand-file-name "elisp-mode-tests.el" emacs-test-dir))) + (xref-make "(cl-defmethod xref-elisp-generic-no-default ((this xref-elisp-root-type) arg2))" + (xref-make-elisp-location + '(xref-elisp-generic-no-default xref-elisp-root-type t) 'cl-defmethod + (expand-file-name "elisp-mode-tests.el" emacs-test-dir))) + )) + +(xref-elisp-deftest find-defs-defgeneric-co-located-default + (elisp--xref-find-definitions 'xref-elisp-generic-co-located-default) + (list + (xref-make "(cl-defgeneric xref-elisp-generic-co-located-default)" + (xref-make-elisp-location + 'xref-elisp-generic-co-located-default 'cl-defgeneric + (expand-file-name "elisp-mode-tests.el" emacs-test-dir))) + (xref-make "(cl-defmethod xref-elisp-generic-co-located-default ((this xref-elisp-root-type) arg2))" + (xref-make-elisp-location + '(xref-elisp-generic-co-located-default xref-elisp-root-type t) 'cl-defmethod + (expand-file-name "elisp-mode-tests.el" emacs-test-dir))) + )) + +(xref-elisp-deftest find-defs-defgeneric-separate-default + (elisp--xref-find-definitions 'xref-elisp-generic-separate-default) + (list + (xref-make "(cl-defgeneric xref-elisp-generic-separate-default)" + (xref-make-elisp-location + 'xref-elisp-generic-separate-default 'cl-defgeneric + (expand-file-name "elisp-mode-tests.el" emacs-test-dir))) + (xref-make "(cl-defmethod xref-elisp-generic-separate-default (arg1 arg2))" + (xref-make-elisp-location + '(xref-elisp-generic-separate-default t t) 'cl-defmethod + (expand-file-name "elisp-mode-tests.el" emacs-test-dir))) + (xref-make "(cl-defmethod xref-elisp-generic-separate-default ((this xref-elisp-root-type) arg2))" + (xref-make-elisp-location + '(xref-elisp-generic-separate-default xref-elisp-root-type t) 'cl-defmethod + (expand-file-name "elisp-mode-tests.el" emacs-test-dir))) + )) + +(xref-elisp-deftest find-defs-defgeneric-implicit-generic + (elisp--xref-find-definitions 'xref-elisp-generic-implicit-generic) + (list + (xref-make "(cl-defmethod xref-elisp-generic-implicit-generic (arg1 arg2))" + (xref-make-elisp-location + '(xref-elisp-generic-implicit-generic t t) 'cl-defmethod + (expand-file-name "elisp-mode-tests.el" emacs-test-dir))) + (xref-make "(cl-defmethod xref-elisp-generic-implicit-generic ((this xref-elisp-root-type) arg2))" + (xref-make-elisp-location + '(xref-elisp-generic-implicit-generic xref-elisp-root-type t) 'cl-defmethod + (expand-file-name "elisp-mode-tests.el" emacs-test-dir))) + )) + +;; Test that we handle more than one method + +;; When run from the Makefile, etags is not loaded at compile time, +;; but it is by the time this test is run. interactively; don't fail +;; for that. +(require 'etags) +(xref-elisp-deftest find-defs-defgeneric-el + (elisp--xref-find-definitions 'xref-location-marker) + (list + (xref-make "(cl-defgeneric xref-location-marker)" + (xref-make-elisp-location + 'xref-location-marker 'cl-defgeneric + (expand-file-name "../../../lisp/progmodes/xref.el" emacs-test-dir))) + (xref-make "(cl-defmethod xref-location-marker ((l xref-elisp-location)))" + (xref-make-elisp-location + '(xref-location-marker xref-elisp-location) 'cl-defmethod + (expand-file-name "../../../lisp/progmodes/elisp-mode.el" emacs-test-dir))) + (xref-make "(cl-defmethod xref-location-marker ((l xref-file-location)))" + (xref-make-elisp-location + '(xref-location-marker xref-file-location) 'cl-defmethod + (expand-file-name "../../../lisp/progmodes/xref.el" emacs-test-dir))) + (xref-make "(cl-defmethod xref-location-marker ((l xref-buffer-location)))" + (xref-make-elisp-location + '(xref-location-marker xref-buffer-location) 'cl-defmethod + (expand-file-name "../../../lisp/progmodes/xref.el" emacs-test-dir))) + (xref-make "(cl-defmethod xref-location-marker ((l xref-bogus-location)))" + (xref-make-elisp-location + '(xref-location-marker xref-bogus-location) 'cl-defmethod + (expand-file-name "../../../lisp/progmodes/xref.el" emacs-test-dir))) + (xref-make "(cl-defmethod xref-location-marker ((l xref-etags-location)))" + (xref-make-elisp-location + '(xref-location-marker xref-etags-location) 'cl-defmethod + (expand-file-name "../../../lisp/progmodes/etags.el" emacs-test-dir))) + )) + +(xref-elisp-deftest find-defs-defgeneric-eval + (elisp--xref-find-definitions (eval '(cl-defgeneric stephe-leake-cl-defgeneric ()))) + nil) + +;; Define some mode-local overloadable/overridden functions for xref to find +(require 'mode-local) + +(define-overloadable-function xref-elisp-overloadable-no-methods () + "doc string overloadable no-methods") + +(define-overloadable-function xref-elisp-overloadable-no-default () + "doc string overloadable no-default") + +;; FIXME: byte compiler complains about unused lexical arguments +;; generated by this macro. +(define-mode-local-override xref-elisp-overloadable-no-default c-mode + (start end &optional nonterminal depth returnonerror) + "doc string overloadable no-default c-mode." + "result overloadable no-default c-mode.") + +(define-overloadable-function xref-elisp-overloadable-co-located-default () + "doc string overloadable co-located-default" + "result overloadable co-located-default.") + +(define-mode-local-override xref-elisp-overloadable-co-located-default c-mode + (start end &optional nonterminal depth returnonerror) + "doc string overloadable co-located-default c-mode." + "result overloadable co-located-default c-mode.") + +(define-overloadable-function xref-elisp-overloadable-separate-default () + "doc string overloadable separate-default.") + +(defun xref-elisp-overloadable-separate-default-default () + "doc string overloadable separate-default default" + "result overloadable separate-default.") + +(define-mode-local-override xref-elisp-overloadable-separate-default c-mode + (start end &optional nonterminal depth returnonerror) + "doc string overloadable separate-default c-mode." + "result overloadable separate-default c-mode.") + +(xref-elisp-deftest find-defs-define-overload-no-methods + (elisp--xref-find-definitions 'xref-elisp-overloadable-no-methods) + (list + (xref-make "(define-overloadable-function xref-elisp-overloadable-no-methods)" + (xref-make-elisp-location + 'xref-elisp-overloadable-no-methods 'define-overloadable-function + (expand-file-name "elisp-mode-tests.el" emacs-test-dir))) + )) + +(xref-elisp-deftest find-defs-define-overload-no-default + (elisp--xref-find-definitions 'xref-elisp-overloadable-no-default) + (list + (xref-make "(define-overloadable-function xref-elisp-overloadable-no-default)" + (xref-make-elisp-location + 'xref-elisp-overloadable-no-default 'define-overloadable-function + (expand-file-name "elisp-mode-tests.el" emacs-test-dir))) + (xref-make "(define-mode-local-override xref-elisp-overloadable-no-default c-mode)" + (xref-make-elisp-location + '(xref-elisp-overloadable-no-default-c-mode . c-mode) 'define-mode-local-override + (expand-file-name "elisp-mode-tests.el" emacs-test-dir))) + )) + +(xref-elisp-deftest find-defs-define-overload-co-located-default + (elisp--xref-find-definitions 'xref-elisp-overloadable-co-located-default) + (list + (xref-make "(define-overloadable-function xref-elisp-overloadable-co-located-default)" + (xref-make-elisp-location + 'xref-elisp-overloadable-co-located-default 'define-overloadable-function + (expand-file-name "elisp-mode-tests.el" emacs-test-dir))) + (xref-make "(define-mode-local-override xref-elisp-overloadable-co-located-default c-mode)" + (xref-make-elisp-location + '(xref-elisp-overloadable-co-located-default-c-mode . c-mode) 'define-mode-local-override + (expand-file-name "elisp-mode-tests.el" emacs-test-dir))) + )) + +(xref-elisp-deftest find-defs-define-overload-separate-default + (elisp--xref-find-definitions 'xref-elisp-overloadable-separate-default) + (list + (xref-make "(define-overloadable-function xref-elisp-overloadable-separate-default)" + (xref-make-elisp-location + 'xref-elisp-overloadable-separate-default 'define-overloadable-function + (expand-file-name "elisp-mode-tests.el" emacs-test-dir))) + (xref-make "(defun xref-elisp-overloadable-separate-default-default)" + (xref-make-elisp-location + 'xref-elisp-overloadable-separate-default-default nil + (expand-file-name "elisp-mode-tests.el" emacs-test-dir))) + (xref-make "(define-mode-local-override xref-elisp-overloadable-separate-default c-mode)" + (xref-make-elisp-location + '(xref-elisp-overloadable-separate-default-c-mode . c-mode) 'define-mode-local-override + (expand-file-name "elisp-mode-tests.el" emacs-test-dir))) + )) + +(xref-elisp-deftest find-defs-defun-el + (elisp--xref-find-definitions 'xref-find-definitions) + (list + (xref-make "(defun xref-find-definitions)" + (xref-make-elisp-location + 'xref-find-definitions nil + (expand-file-name "../../../lisp/progmodes/xref.el" emacs-test-dir))))) + +(xref-elisp-deftest find-defs-defun-eval + (elisp--xref-find-definitions (eval '(defun stephe-leake-defun ()))) + nil) + +(xref-elisp-deftest find-defs-defun-c + (elisp--xref-find-definitions 'buffer-live-p) + (list + (xref-make "(defun buffer-live-p)" + (xref-make-elisp-location 'buffer-live-p nil "src/buffer.c")))) + +;; FIXME: deftype + +(xref-elisp-deftest find-defs-defun-c-defvar-c + (xref-backend-definitions 'elisp "system-name") + (list + (xref-make "(defvar system-name)" + (xref-make-elisp-location 'system-name 'defvar "src/editfns.c")) + (xref-make "(defun system-name)" + (xref-make-elisp-location 'system-name nil "src/editfns.c"))) + ) + +(xref-elisp-deftest find-defs-defun-el-defvar-c + (xref-backend-definitions 'elisp "abbrev-mode") + ;; It's a minor mode, but the variable is defined in buffer.c + (list + (xref-make "(defvar abbrev-mode)" + (xref-make-elisp-location 'abbrev-mode 'defvar "src/buffer.c")) + (cons + (xref-make "(defun abbrev-mode)" + (xref-make-elisp-location + 'abbrev-mode nil + (expand-file-name "../../../lisp/abbrev.el" emacs-test-dir))) + "(define-minor-mode abbrev-mode")) + ) + +;; Source for both variable and defun is "(define-minor-mode +;; compilation-minor-mode". There is no way to tell that directly from +;; the symbol, but we can use (memq sym minor-mode-list) to detect +;; that the symbol is a minor mode. See `elisp--xref-find-definitions' +;; for more comments. +;; +;; IMPROVEME: return defvar instead of defun if source near starting +;; point indicates the user is searching for a variable, not a +;; function. +(require 'compile) ;; not loaded by default at test time +(xref-elisp-deftest find-defs-defun-defvar-el + (elisp--xref-find-definitions 'compilation-minor-mode) + (list + (cons + (xref-make "(defun compilation-minor-mode)" + (xref-make-elisp-location + 'compilation-minor-mode nil + (expand-file-name "../../../lisp/progmodes/compile.el" emacs-test-dir))) + "(define-minor-mode compilation-minor-mode") + )) + +(xref-elisp-deftest find-defs-defvar-el + (elisp--xref-find-definitions 'xref--marker-ring) + (list + (xref-make "(defvar xref--marker-ring)" + (xref-make-elisp-location + 'xref--marker-ring 'defvar + (expand-file-name "../../../lisp/progmodes/xref.el" emacs-test-dir))) + )) + +(xref-elisp-deftest find-defs-defvar-c + (elisp--xref-find-definitions 'default-directory) + (list + (cons + (xref-make "(defvar default-directory)" + (xref-make-elisp-location 'default-directory 'defvar "src/buffer.c")) + ;; IMPROVEME: we might be able to compute this target + "DEFVAR_PER_BUFFER (\"default-directory\""))) + +(xref-elisp-deftest find-defs-defvar-eval + (elisp--xref-find-definitions (eval '(defvar stephe-leake-defvar nil))) + nil) + +(xref-elisp-deftest find-defs-face-el + (elisp--xref-find-definitions 'font-lock-keyword-face) + ;; 'font-lock-keyword-face is both a face and a var + (list + (xref-make "(defvar font-lock-keyword-face)" + (xref-make-elisp-location + 'font-lock-keyword-face 'defvar + (expand-file-name "../../../lisp/font-lock.el" emacs-test-dir))) + (xref-make "(defface font-lock-keyword-face)" + (xref-make-elisp-location + 'font-lock-keyword-face 'defface + (expand-file-name "../../../lisp/font-lock.el" emacs-test-dir))) + )) + +(xref-elisp-deftest find-defs-face-eval + (elisp--xref-find-definitions (eval '(defface stephe-leake-defface nil ""))) + nil) + +(xref-elisp-deftest find-defs-feature-el + (elisp--xref-find-definitions 'xref) + (list + (cons + (xref-make "(feature xref)" + (xref-make-elisp-location + 'xref 'feature + (expand-file-name "../../../lisp/progmodes/xref.el" emacs-test-dir))) + ";;; Code:") + )) + +(xref-elisp-deftest find-defs-feature-eval + (elisp--xref-find-definitions (eval '(provide 'stephe-leake-feature))) + nil) + +(provide 'elisp-mode-tests) +;;; elisp-mode-tests.el ends here diff --git a/test/lisp/progmodes/f90.el b/test/lisp/progmodes/f90.el new file mode 100644 index 00000000000..fece86ca1d8 --- /dev/null +++ b/test/lisp/progmodes/f90.el @@ -0,0 +1,258 @@ +;;; f90.el --- tests for progmodes/f90.el + +;; Copyright (C) 2011-2016 Free Software Foundation, Inc. + +;; Author: Glenn Morris <rgm@gnu.org> + +;; 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: + +;; This file does not have "test" in the name, because it lives under +;; a test/ directory, so that would be superfluous. + +;;; Code: + +(require 'ert) +(require 'f90) + +(defconst f90-test-indent "\ +!! Comment before code. +!!! Comments before code. +#preprocessor before code + +program progname + + implicit none + + integer :: i + + !! Comment. + + do i = 1, 10 + +#preprocessor + + !! Comment. + if ( i % 2 == 0 ) then + !! Comment. + cycle + else + write(*,*) i + end if + end do + +!!! Comment. + +end program progname +" + "Test string for F90 indentation.") + +(ert-deftest f90-test-indent () + "Test F90 indentation." + (with-temp-buffer + (f90-mode) + (insert f90-test-indent) + (indent-rigidly (point-min) (point-max) -999) + (f90-indent-region (point-min) (point-max)) + (should (string-equal (buffer-string) f90-test-indent)))) + +(ert-deftest f90-test-bug3729 () + "Test for http://debbugs.gnu.org/3729 ." + :expected-result :failed + (with-temp-buffer + (f90-mode) + (insert "!! Comment + +include \"file.f90\" + +subroutine test (x) + real x + x = x+1. + return +end subroutine test") + (goto-char (point-min)) + (forward-line 2) + (f90-indent-subprogram) + (should (= 0 (current-indentation))))) + +(ert-deftest f90-test-bug3730 () + "Test for http://debbugs.gnu.org/3730 ." + (with-temp-buffer + (f90-mode) + (insert "a" ) + (move-to-column 68 t) + (insert "(/ x /)") + (f90-do-auto-fill) + (beginning-of-line) + (skip-chars-forward "[ \t]") + (should (equal "&(/" (buffer-substring (point) (+ 3 (point))))))) + +;; TODO bug#5593 + +(ert-deftest f90-test-bug8691 () + "Test for http://debbugs.gnu.org/8691 ." + (with-temp-buffer + (f90-mode) + (insert "module modname +type, bind(c) :: type1 +integer :: part1 +end type type1 +end module modname") + (f90-indent-subprogram) + (forward-line -1) + (should (= 2 (current-indentation))))) + +;; TODO bug#8812 + +(ert-deftest f90-test-bug8820 () + "Test for http://debbugs.gnu.org/8820 ." + (with-temp-buffer + (f90-mode) + (should (eq (char-syntax ?%) (string-to-char "."))))) + +(ert-deftest f90-test-bug9553a () + "Test for http://debbugs.gnu.org/9553 ." + (with-temp-buffer + (f90-mode) + (insert "!!!") + (dotimes (_i 20) (insert " aaaa")) + (f90-do-auto-fill) + (beginning-of-line) + ;; This gives a more informative failure than looking-at. + (should (equal "!!! a" (buffer-substring (point) (+ 5 (point))))))) + +(ert-deftest f90-test-bug9553b () + "Test for http://debbugs.gnu.org/9553 ." + (with-temp-buffer + (f90-mode) + (insert "!!!") + (dotimes (_i 13) (insert " aaaa")) + (insert "a, aaaa") + (f90-do-auto-fill) + (beginning-of-line) + (should (equal "!!! a" (buffer-substring (point) (+ 5 (point))))))) + +(ert-deftest f90-test-bug9690 () + "Test for http://debbugs.gnu.org/9690 ." + (with-temp-buffer + (f90-mode) + (insert "#include \"foo.h\"") + (f90-indent-line) + (should (= 0 (current-indentation))))) + +(ert-deftest f90-test-bug13138 () + "Test for http://debbugs.gnu.org/13138 ." + (with-temp-buffer + (f90-mode) + (insert "program prog + integer :: i = & +#ifdef foo + & 1 +#else + & 2 +#endif + + write(*,*) i +end program prog") + (goto-char (point-min)) + (forward-line 2) + (f90-indent-subprogram) + (should (= 0 (current-indentation))))) + +(ert-deftest f90-test-bug-19809 () + "Test for http://debbugs.gnu.org/19809 ." + (with-temp-buffer + (f90-mode) + ;; The Fortran standard says that continued strings should have + ;; '&' at the start of continuation lines, but it seems gfortran + ;; allows them to be absent (albeit with a warning). + (insert "program prog + write (*,*), '& +end program prog' +end program prog") + (goto-char (point-min)) + (f90-end-of-subprogram) + (should (= (point) (point-max))))) + +(ert-deftest f90-test-bug20680 () + "Test for http://debbugs.gnu.org/20680 ." + (with-temp-buffer + (f90-mode) + (insert "module modname +type, extends ( sometype ) :: type1 +integer :: part1 +end type type1 +end module modname") + (f90-indent-subprogram) + (forward-line -1) + (should (= 2 (current-indentation))))) + +(ert-deftest f90-test-bug20680b () + "Test for http://debbugs.gnu.org/20680 ." + (with-temp-buffer + (f90-mode) + (insert "module modname +enum, bind(c) +enumerator :: e1 = 0 +end enum +end module modname") + (f90-indent-subprogram) + (forward-line -1) + (should (= 2 (current-indentation))))) + +(ert-deftest f90-test-bug20969 () + "Test for http://debbugs.gnu.org/20969 ." + (with-temp-buffer + (f90-mode) + (insert "module modname +type, extends ( sometype ), private :: type1 +integer :: part1 +end type type1 +end module modname") + (f90-indent-subprogram) + (forward-line -1) + (should (= 2 (current-indentation))))) + +(ert-deftest f90-test-bug20969b () + "Test for http://debbugs.gnu.org/20969 ." + (with-temp-buffer + (f90-mode) + (insert "module modname +type, private, extends ( sometype ) :: type1 +integer :: part1 +end type type1 +end module modname") + (f90-indent-subprogram) + (forward-line -1) + (should (= 2 (current-indentation))))) + +(ert-deftest f90-test-bug21794 () + "Test for http://debbugs.gnu.org/21794 ." + (with-temp-buffer + (f90-mode) + (insert "program prog +do i=1,10 +associate (x => xa(i), y => ya(i)) +a(x,y,i) = fun(x,y,i) +end associate +end do +end program prog") + (f90-indent-subprogram) + (forward-line -2) + (should (= 5 (current-indentation))))) + +;;; f90.el ends here diff --git a/test/lisp/progmodes/flymake-resources/Makefile b/test/lisp/progmodes/flymake-resources/Makefile new file mode 100644 index 00000000000..0f3f39791c8 --- /dev/null +++ b/test/lisp/progmodes/flymake-resources/Makefile @@ -0,0 +1,13 @@ +# Makefile for flymake tests + +CC_OPTS = -Wall + +## Recent gcc (e.g. 4.8.2 on RHEL7) can automatically colorize their output, +## which can confuse flymake. Set GCC_COLORS to disable that. +## This only seems to be an issue in batch mode, where you would not +## normally use flymake, so it seems like just avoiding the issue +## in this test is fine. Set flymake-log-level to 3 to investigate. +check-syntax: + GCC_COLORS= $(CC) $(CC_OPTS) ${CHK_SOURCES} + +# eof diff --git a/test/lisp/progmodes/flymake-resources/test.c b/test/lisp/progmodes/flymake-resources/test.c new file mode 100644 index 00000000000..3a3926131f5 --- /dev/null +++ b/test/lisp/progmodes/flymake-resources/test.c @@ -0,0 +1,5 @@ +int main() +{ + char c = 1000; + return c; +} diff --git a/test/lisp/progmodes/flymake-resources/test.pl b/test/lisp/progmodes/flymake-resources/test.pl new file mode 100644 index 00000000000..d5abcb47e7f --- /dev/null +++ b/test/lisp/progmodes/flymake-resources/test.pl @@ -0,0 +1,2 @@ +@arr = [1,2,3,4]; +my $b = @arr[1]; diff --git a/test/lisp/progmodes/flymake-tests.el b/test/lisp/progmodes/flymake-tests.el new file mode 100644 index 00000000000..386516190bb --- /dev/null +++ b/test/lisp/progmodes/flymake-tests.el @@ -0,0 +1,80 @@ +;;; flymake-tests.el --- Test suite for flymake + +;; Copyright (C) 2011-2016 Free Software Foundation, Inc. + +;; Author: Eduard Wiebe <usenet@pusto.de> + +;; 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: + +;;; Code: +(require 'ert) +(require 'flymake) + +(defvar flymake-tests-data-directory + (expand-file-name "lisp/progmodes/flymake-resources" (getenv "EMACS_TEST_DIRECTORY")) + "Directory containing flymake test data.") + + +;; Warning predicate +(defun flymake-tests--current-face (file predicate) + (let ((buffer (find-file-noselect + (expand-file-name file flymake-tests-data-directory))) + (process-environment (cons "LC_ALL=C" process-environment)) + (i 0)) + (unwind-protect + (with-current-buffer buffer + (setq-local flymake-warning-predicate predicate) + (goto-char (point-min)) + (flymake-mode 1) + ;; Weirdness here... http://debbugs.gnu.org/17647#25 + (while (and flymake-is-running (< (setq i (1+ i)) 10)) + (sleep-for (+ 0.5 flymake-no-changes-timeout))) + (flymake-goto-next-error) + (face-at-point)) + (and buffer (let (kill-buffer-query-functions) (kill-buffer buffer)))))) + +(ert-deftest warning-predicate-rx-gcc () + "Test GCC warning via regexp predicate." + (skip-unless (and (executable-find "gcc") (executable-find "make"))) + (should (eq 'flymake-warnline + (flymake-tests--current-face "test.c" "^[Ww]arning")))) + +(ert-deftest warning-predicate-function-gcc () + "Test GCC warning via function predicate." + (skip-unless (and (executable-find "gcc") (executable-find "make"))) + (should (eq 'flymake-warnline + (flymake-tests--current-face "test.c" + (lambda (msg) (string-match "^[Ww]arning" msg)))))) + +(ert-deftest warning-predicate-rx-perl () + "Test perl warning via regular expression predicate." + (skip-unless (executable-find "perl")) + (should (eq 'flymake-warnline + (flymake-tests--current-face "test.pl" "^Scalar value")))) + +(ert-deftest warning-predicate-function-perl () + "Test perl warning via function predicate." + (skip-unless (executable-find "perl")) + (should (eq 'flymake-warnline + (flymake-tests--current-face + "test.pl" + (lambda (msg) (string-match "^Scalar value" msg)))))) + +(provide 'flymake-tests) + +;;; flymake.el ends here diff --git a/test/lisp/progmodes/python-tests.el b/test/lisp/progmodes/python-tests.el new file mode 100644 index 00000000000..ec93c01059c --- /dev/null +++ b/test/lisp/progmodes/python-tests.el @@ -0,0 +1,5232 @@ +;;; python-tests.el --- Test suite for python.el + +;; Copyright (C) 2013-2016 Free Software Foundation, Inc. + +;; 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: + +;;; Code: + +(require 'ert) +(require 'python) + +;; Dependencies for testing: +(require 'electric) +(require 'hideshow) +(require 'tramp-sh) + + +(defmacro python-tests-with-temp-buffer (contents &rest body) + "Create a `python-mode' enabled temp buffer with CONTENTS. +BODY is code to be executed within the temp buffer. Point is +always located at the beginning of buffer." + (declare (indent 1) (debug t)) + `(with-temp-buffer + (let ((python-indent-guess-indent-offset nil)) + (python-mode) + (insert ,contents) + (goto-char (point-min)) + ,@body))) + +(defmacro python-tests-with-temp-file (contents &rest body) + "Create a `python-mode' enabled file with CONTENTS. +BODY is code to be executed within the temp buffer. Point is +always located at the beginning of buffer." + (declare (indent 1) (debug t)) + ;; temp-file never actually used for anything? + `(let* ((temp-file (make-temp-file "python-tests" nil ".py")) + (buffer (find-file-noselect temp-file)) + (python-indent-guess-indent-offset nil)) + (unwind-protect + (with-current-buffer buffer + (python-mode) + (insert ,contents) + (goto-char (point-min)) + ,@body) + (and buffer (kill-buffer buffer)) + (delete-file temp-file)))) + +(defun python-tests-look-at (string &optional num restore-point) + "Move point at beginning of STRING in the current buffer. +Optional argument NUM defaults to 1 and is an integer indicating +how many occurrences must be found, when positive the search is +done forwards, otherwise backwards. When RESTORE-POINT is +non-nil the point is not moved but the position found is still +returned. When searching forward and point is already looking at +STRING, it is skipped so the next STRING occurrence is selected." + (let* ((num (or num 1)) + (starting-point (point)) + (string (regexp-quote string)) + (search-fn (if (> num 0) #'re-search-forward #'re-search-backward)) + (deinc-fn (if (> num 0) #'1- #'1+)) + (found-point)) + (prog2 + (catch 'exit + (while (not (= num 0)) + (when (and (> num 0) + (looking-at string)) + ;; Moving forward and already looking at STRING, skip it. + (forward-char (length (match-string-no-properties 0)))) + (and (not (funcall search-fn string nil t)) + (throw 'exit t)) + (when (> num 0) + ;; `re-search-forward' leaves point at the end of the + ;; occurrence, move back so point is at the beginning + ;; instead. + (forward-char (- (length (match-string-no-properties 0))))) + (setq + num (funcall deinc-fn num) + found-point (point)))) + found-point + (and restore-point (goto-char starting-point))))) + +(defun python-tests-self-insert (char-or-str) + "Call `self-insert-command' for chars in CHAR-OR-STR." + (let ((chars + (cond + ((characterp char-or-str) + (list char-or-str)) + ((stringp char-or-str) + (string-to-list char-or-str)) + ((not + (cl-remove-if #'characterp char-or-str)) + char-or-str) + (t (error "CHAR-OR-STR must be a char, string, or list of char"))))) + (mapc + (lambda (char) + (let ((last-command-event char)) + (call-interactively 'self-insert-command))) + chars))) + +(defun python-tests-visible-string (&optional min max) + "Return the buffer string excluding invisible overlays. +Argument MIN and MAX delimit the region to be returned and +default to `point-min' and `point-max' respectively." + (let* ((min (or min (point-min))) + (max (or max (point-max))) + (buffer (current-buffer)) + (buffer-contents (buffer-substring-no-properties min max)) + (overlays + (sort (overlays-in min max) + (lambda (a b) + (let ((overlay-end-a (overlay-end a)) + (overlay-end-b (overlay-end b))) + (> overlay-end-a overlay-end-b)))))) + (with-temp-buffer + (insert buffer-contents) + (dolist (overlay overlays) + (if (overlay-get overlay 'invisible) + (delete-region (overlay-start overlay) + (overlay-end overlay)))) + (buffer-substring-no-properties (point-min) (point-max))))) + + +;;; Tests for your tests, so you can test while you test. + +(ert-deftest python-tests-look-at-1 () + "Test forward movement." + (python-tests-with-temp-buffer + "Lorem ipsum dolor sit amet, consectetur adipisicing elit, +sed do eiusmod tempor incididunt ut labore et dolore magna +aliqua." + (let ((expected (save-excursion + (dotimes (i 3) + (re-search-forward "et" nil t)) + (forward-char -2) + (point)))) + (should (= (python-tests-look-at "et" 3 t) expected)) + ;; Even if NUM is bigger than found occurrences the point of last + ;; one should be returned. + (should (= (python-tests-look-at "et" 6 t) expected)) + ;; If already looking at STRING, it should skip it. + (dotimes (i 2) (re-search-forward "et")) + (forward-char -2) + (should (= (python-tests-look-at "et") expected))))) + +(ert-deftest python-tests-look-at-2 () + "Test backward movement." + (python-tests-with-temp-buffer + "Lorem ipsum dolor sit amet, consectetur adipisicing elit, +sed do eiusmod tempor incididunt ut labore et dolore magna +aliqua." + (let ((expected + (save-excursion + (re-search-forward "et" nil t) + (forward-char -2) + (point)))) + (dotimes (i 3) + (re-search-forward "et" nil t)) + (should (= (python-tests-look-at "et" -3 t) expected)) + (should (= (python-tests-look-at "et" -6 t) expected))))) + + +;;; Bindings + + +;;; Python specialized rx + + +;;; Font-lock and syntax + +(ert-deftest python-syntax-after-python-backspace () + ;; `python-indent-dedent-line-backspace' garbles syntax + :expected-result :failed + (python-tests-with-temp-buffer + "\"\"\"" + (goto-char (point-max)) + (python-indent-dedent-line-backspace 1) + (should (string= (buffer-string) "\"\"")) + (should (null (nth 3 (syntax-ppss)))))) + + +;;; Indentation + +;; See: http://www.python.org/dev/peps/pep-0008/#indentation + +(ert-deftest python-indent-pep8-1 () + "First pep8 case." + (python-tests-with-temp-buffer + "# Aligned with opening delimiter +foo = long_function_name(var_one, var_two, + var_three, var_four) +" + (should (eq (car (python-indent-context)) :no-indent)) + (should (= (python-indent-calculate-indentation) 0)) + (python-tests-look-at "foo = long_function_name(var_one, var_two,") + (should (eq (car (python-indent-context)) :after-comment)) + (should (= (python-indent-calculate-indentation) 0)) + (python-tests-look-at "var_three, var_four)") + (should (eq (car (python-indent-context)) :inside-paren)) + (should (= (python-indent-calculate-indentation) 25)))) + +(ert-deftest python-indent-pep8-2 () + "Second pep8 case." + (python-tests-with-temp-buffer + "# More indentation included to distinguish this from the rest. +def long_function_name( + var_one, var_two, var_three, + var_four): + print (var_one) +" + (should (eq (car (python-indent-context)) :no-indent)) + (should (= (python-indent-calculate-indentation) 0)) + (python-tests-look-at "def long_function_name(") + (should (eq (car (python-indent-context)) :after-comment)) + (should (= (python-indent-calculate-indentation) 0)) + (python-tests-look-at "var_one, var_two, var_three,") + (should (eq (car (python-indent-context)) + :inside-paren-newline-start-from-block)) + (should (= (python-indent-calculate-indentation) 8)) + (python-tests-look-at "var_four):") + (should (eq (car (python-indent-context)) + :inside-paren-newline-start-from-block)) + (should (= (python-indent-calculate-indentation) 8)) + (python-tests-look-at "print (var_one)") + (should (eq (car (python-indent-context)) + :after-block-start)) + (should (= (python-indent-calculate-indentation) 4)))) + +(ert-deftest python-indent-pep8-3 () + "Third pep8 case." + (python-tests-with-temp-buffer + "# Extra indentation is not necessary. +foo = long_function_name( + var_one, var_two, + var_three, var_four) +" + (should (eq (car (python-indent-context)) :no-indent)) + (should (= (python-indent-calculate-indentation) 0)) + (python-tests-look-at "foo = long_function_name(") + (should (eq (car (python-indent-context)) :after-comment)) + (should (= (python-indent-calculate-indentation) 0)) + (python-tests-look-at "var_one, var_two,") + (should (eq (car (python-indent-context)) :inside-paren-newline-start)) + (should (= (python-indent-calculate-indentation) 4)) + (python-tests-look-at "var_three, var_four)") + (should (eq (car (python-indent-context)) :inside-paren-newline-start)) + (should (= (python-indent-calculate-indentation) 4)))) + +(ert-deftest python-indent-base-case () + "Check base case does not trigger errors." + (python-tests-with-temp-buffer + " + +" + (goto-char (point-min)) + (should (eq (car (python-indent-context)) :no-indent)) + (should (= (python-indent-calculate-indentation) 0)) + (forward-line 1) + (should (eq (car (python-indent-context)) :no-indent)) + (should (= (python-indent-calculate-indentation) 0)) + (forward-line 1) + (should (eq (car (python-indent-context)) :no-indent)) + (should (= (python-indent-calculate-indentation) 0)))) + +(ert-deftest python-indent-after-comment-1 () + "The most simple after-comment case that shouldn't fail." + (python-tests-with-temp-buffer + "# Contents will be modified to correct indentation +class Blag(object): + def _on_child_complete(self, child_future): + if self.in_terminal_state(): + pass + # We only complete when all our async children have entered a + # terminal state. At that point, if any child failed, we fail +# with the exception with which the first child failed. +" + (python-tests-look-at "# We only complete") + (should (eq (car (python-indent-context)) :after-block-end)) + (should (= (python-indent-calculate-indentation) 8)) + (python-tests-look-at "# terminal state") + (should (eq (car (python-indent-context)) :after-comment)) + (should (= (python-indent-calculate-indentation) 8)) + (python-tests-look-at "# with the exception") + (should (eq (car (python-indent-context)) :after-comment)) + ;; This one indents relative to previous block, even given the fact + ;; that it was under-indented. + (should (= (python-indent-calculate-indentation) 4)) + (python-tests-look-at "# terminal state" -1) + ;; It doesn't hurt to check again. + (should (eq (car (python-indent-context)) :after-comment)) + (python-indent-line) + (should (= (current-indentation) 8)) + (python-tests-look-at "# with the exception") + (should (eq (car (python-indent-context)) :after-comment)) + ;; Now everything should be lined up. + (should (= (python-indent-calculate-indentation) 8)))) + +(ert-deftest python-indent-after-comment-2 () + "Test after-comment in weird cases." + (python-tests-with-temp-buffer + "# Contents will be modified to correct indentation +def func(arg): + # I don't do much + return arg + # This comment is badly indented because the user forced so. + # At this line python.el wont dedent, user is always right. + +comment_wins_over_ender = True + +# yeah, that. +" + (python-tests-look-at "# I don't do much") + (should (eq (car (python-indent-context)) :after-block-start)) + (should (= (python-indent-calculate-indentation) 4)) + (python-tests-look-at "return arg") + ;; Comment here just gets ignored, this line is not a comment so + ;; the rules won't apply here. + (should (eq (car (python-indent-context)) :after-block-start)) + (should (= (python-indent-calculate-indentation) 4)) + (python-tests-look-at "# This comment is badly indented") + (should (eq (car (python-indent-context)) :after-block-end)) + ;; The return keyword do make indentation lose a level... + (should (= (python-indent-calculate-indentation) 0)) + ;; ...but the current indentation was forced by the user. + (python-tests-look-at "# At this line python.el wont dedent") + (should (eq (car (python-indent-context)) :after-comment)) + (should (= (python-indent-calculate-indentation) 4)) + ;; Should behave the same for blank lines: potentially a comment. + (forward-line 1) + (should (eq (car (python-indent-context)) :after-comment)) + (should (= (python-indent-calculate-indentation) 4)) + (python-tests-look-at "comment_wins_over_ender") + ;; The comment won over the ender because the user said so. + (should (eq (car (python-indent-context)) :after-comment)) + (should (= (python-indent-calculate-indentation) 4)) + ;; The indentation calculated fine for the assignment, but the user + ;; choose to force it back to the first column. Next line should + ;; be aware of that. + (python-tests-look-at "# yeah, that.") + (should (eq (car (python-indent-context)) :after-line)) + (should (= (python-indent-calculate-indentation) 0)))) + +(ert-deftest python-indent-after-comment-3 () + "Test after-comment in buggy case." + (python-tests-with-temp-buffer + " +class A(object): + + def something(self, arg): + if True: + return arg + + # A comment + + @adecorator + def method(self, a, b): + pass +" + (python-tests-look-at "@adecorator") + (should (eq (car (python-indent-context)) :after-comment)) + (should (= (python-indent-calculate-indentation) 4)))) + +(ert-deftest python-indent-inside-paren-1 () + "The most simple inside-paren case that shouldn't fail." + (python-tests-with-temp-buffer + " +data = { + 'key': + { + 'objlist': [ + { + 'pk': 1, + 'name': 'first', + }, + { + 'pk': 2, + 'name': 'second', + } + ] + } +} +" + (python-tests-look-at "data = {") + (should (eq (car (python-indent-context)) :no-indent)) + (should (= (python-indent-calculate-indentation) 0)) + (python-tests-look-at "'key':") + (should (eq (car (python-indent-context)) :inside-paren-newline-start)) + (should (= (python-indent-calculate-indentation) 4)) + (python-tests-look-at "{") + (should (eq (car (python-indent-context)) :inside-paren-newline-start)) + (should (= (python-indent-calculate-indentation) 4)) + (python-tests-look-at "'objlist': [") + (should (eq (car (python-indent-context)) :inside-paren-newline-start)) + (should (= (python-indent-calculate-indentation) 8)) + (python-tests-look-at "{") + (should (eq (car (python-indent-context)) :inside-paren-newline-start)) + (should (= (python-indent-calculate-indentation) 12)) + (python-tests-look-at "'pk': 1,") + (should (eq (car (python-indent-context)) :inside-paren-newline-start)) + (should (= (python-indent-calculate-indentation) 16)) + (python-tests-look-at "'name': 'first',") + (should (eq (car (python-indent-context)) :inside-paren-newline-start)) + (should (= (python-indent-calculate-indentation) 16)) + (python-tests-look-at "},") + (should (eq (car (python-indent-context)) + :inside-paren-at-closing-nested-paren)) + (should (= (python-indent-calculate-indentation) 12)) + (python-tests-look-at "{") + (should (eq (car (python-indent-context)) :inside-paren-newline-start)) + (should (= (python-indent-calculate-indentation) 12)) + (python-tests-look-at "'pk': 2,") + (should (eq (car (python-indent-context)) :inside-paren-newline-start)) + (should (= (python-indent-calculate-indentation) 16)) + (python-tests-look-at "'name': 'second',") + (should (eq (car (python-indent-context)) :inside-paren-newline-start)) + (should (= (python-indent-calculate-indentation) 16)) + (python-tests-look-at "}") + (should (eq (car (python-indent-context)) + :inside-paren-at-closing-nested-paren)) + (should (= (python-indent-calculate-indentation) 12)) + (python-tests-look-at "]") + (should (eq (car (python-indent-context)) + :inside-paren-at-closing-nested-paren)) + (should (= (python-indent-calculate-indentation) 8)) + (python-tests-look-at "}") + (should (eq (car (python-indent-context)) + :inside-paren-at-closing-nested-paren)) + (should (= (python-indent-calculate-indentation) 4)) + (python-tests-look-at "}") + (should (eq (car (python-indent-context)) :inside-paren-at-closing-paren)) + (should (= (python-indent-calculate-indentation) 0)))) + +(ert-deftest python-indent-inside-paren-2 () + "Another more compact paren group style." + (python-tests-with-temp-buffer + " +data = {'key': { + 'objlist': [ + {'pk': 1, + 'name': 'first'}, + {'pk': 2, + 'name': 'second'} + ] +}} +" + (python-tests-look-at "data = {") + (should (eq (car (python-indent-context)) :no-indent)) + (should (= (python-indent-calculate-indentation) 0)) + (python-tests-look-at "'objlist': [") + (should (eq (car (python-indent-context)) :inside-paren-newline-start)) + (should (= (python-indent-calculate-indentation) 4)) + (python-tests-look-at "{'pk': 1,") + (should (eq (car (python-indent-context)) :inside-paren-newline-start)) + (should (= (python-indent-calculate-indentation) 8)) + (python-tests-look-at "'name': 'first'},") + (should (eq (car (python-indent-context)) :inside-paren)) + (should (= (python-indent-calculate-indentation) 9)) + (python-tests-look-at "{'pk': 2,") + (should (eq (car (python-indent-context)) :inside-paren-newline-start)) + (should (= (python-indent-calculate-indentation) 8)) + (python-tests-look-at "'name': 'second'}") + (should (eq (car (python-indent-context)) :inside-paren)) + (should (= (python-indent-calculate-indentation) 9)) + (python-tests-look-at "]") + (should (eq (car (python-indent-context)) + :inside-paren-at-closing-nested-paren)) + (should (= (python-indent-calculate-indentation) 4)) + (python-tests-look-at "}}") + (should (eq (car (python-indent-context)) + :inside-paren-at-closing-nested-paren)) + (should (= (python-indent-calculate-indentation) 0)) + (python-tests-look-at "}") + (should (eq (car (python-indent-context)) :inside-paren-at-closing-paren)) + (should (= (python-indent-calculate-indentation) 0)))) + +(ert-deftest python-indent-inside-paren-3 () + "The simplest case possible." + (python-tests-with-temp-buffer + " +data = ('these', + 'are', + 'the', + 'tokens') +" + (python-tests-look-at "data = ('these',") + (should (eq (car (python-indent-context)) :no-indent)) + (should (= (python-indent-calculate-indentation) 0)) + (forward-line 1) + (should (eq (car (python-indent-context)) :inside-paren)) + (should (= (python-indent-calculate-indentation) 8)) + (forward-line 1) + (should (eq (car (python-indent-context)) :inside-paren)) + (should (= (python-indent-calculate-indentation) 8)) + (forward-line 1) + (should (eq (car (python-indent-context)) :inside-paren)) + (should (= (python-indent-calculate-indentation) 8)))) + +(ert-deftest python-indent-inside-paren-4 () + "Respect indentation of first column." + (python-tests-with-temp-buffer + " +data = [ [ 'these', 'are'], + ['the', 'tokens' ] ] +" + (python-tests-look-at "data = [ [ 'these', 'are'],") + (should (eq (car (python-indent-context)) :no-indent)) + (should (= (python-indent-calculate-indentation) 0)) + (forward-line 1) + (should (eq (car (python-indent-context)) :inside-paren)) + (should (= (python-indent-calculate-indentation) 9)))) + +(ert-deftest python-indent-inside-paren-5 () + "Test when :inside-paren initial parens are skipped in context start." + (python-tests-with-temp-buffer + " +while ((not some_condition) and + another_condition): + do_something_interesting( + with_some_arg) +" + (python-tests-look-at "while ((not some_condition) and") + (should (eq (car (python-indent-context)) :no-indent)) + (should (= (python-indent-calculate-indentation) 0)) + (forward-line 1) + (should (eq (car (python-indent-context)) :inside-paren)) + (should (= (python-indent-calculate-indentation) 7)) + (forward-line 1) + (should (eq (car (python-indent-context)) :after-block-start)) + (should (= (python-indent-calculate-indentation) 4)) + (forward-line 1) + (should (eq (car (python-indent-context)) :inside-paren-newline-start)) + (should (= (python-indent-calculate-indentation) 8)))) + +(ert-deftest python-indent-inside-paren-6 () + "This should be aligned.." + (python-tests-with-temp-buffer + " +CHOICES = (('some', 'choice'), + ('another', 'choice'), + ('more', 'choices')) +" + (python-tests-look-at "CHOICES = (('some', 'choice'),") + (should (eq (car (python-indent-context)) :no-indent)) + (should (= (python-indent-calculate-indentation) 0)) + (forward-line 1) + (should (eq (car (python-indent-context)) :inside-paren)) + (should (= (python-indent-calculate-indentation) 11)) + (forward-line 1) + (should (eq (car (python-indent-context)) :inside-paren)) + (should (= (python-indent-calculate-indentation) 11)))) + +(ert-deftest python-indent-inside-paren-7 () + "Test for Bug#21762." + (python-tests-with-temp-buffer + "import re as myre\nvar = [\n" + (goto-char (point-max)) + ;; This signals an error if the test fails + (should (eq (car (python-indent-context)) :inside-paren-newline-start)))) + +(ert-deftest python-indent-after-block-1 () + "The most simple after-block case that shouldn't fail." + (python-tests-with-temp-buffer + " +def foo(a, b, c=True): +" + (should (eq (car (python-indent-context)) :no-indent)) + (should (= (python-indent-calculate-indentation) 0)) + (goto-char (point-max)) + (should (eq (car (python-indent-context)) :after-block-start)) + (should (= (python-indent-calculate-indentation) 4)))) + +(ert-deftest python-indent-after-block-2 () + "A weird (malformed) multiline block statement." + (python-tests-with-temp-buffer + " +def foo(a, b, c={ + 'a': +}): +" + (goto-char (point-max)) + (should (eq (car (python-indent-context)) :after-block-start)) + (should (= (python-indent-calculate-indentation) 4)))) + +(ert-deftest python-indent-after-block-3 () + "A weird (malformed) sample, usually found in python shells." + (python-tests-with-temp-buffer + " +In [1]: +def func(): +pass + +In [2]: +something +" + (python-tests-look-at "pass") + (should (eq (car (python-indent-context)) :after-block-start)) + (should (= (python-indent-calculate-indentation) 4)) + (python-tests-look-at "something") + (end-of-line) + (should (eq (car (python-indent-context)) :after-line)) + (should (= (python-indent-calculate-indentation) 0)))) + +(ert-deftest python-indent-after-backslash-1 () + "The most common case." + (python-tests-with-temp-buffer + " +from foo.bar.baz import something, something_1 \\\\ + something_2 something_3, \\\\ + something_4, something_5 +" + (python-tests-look-at "from foo.bar.baz import something, something_1") + (should (eq (car (python-indent-context)) :no-indent)) + (should (= (python-indent-calculate-indentation) 0)) + (python-tests-look-at "something_2 something_3,") + (should (eq (car (python-indent-context)) :after-backslash-first-line)) + (should (= (python-indent-calculate-indentation) 4)) + (python-tests-look-at "something_4, something_5") + (should (eq (car (python-indent-context)) :after-backslash)) + (should (= (python-indent-calculate-indentation) 4)) + (goto-char (point-max)) + (should (eq (car (python-indent-context)) :after-line)) + (should (= (python-indent-calculate-indentation) 0)))) + +(ert-deftest python-indent-after-backslash-2 () + "A pretty extreme complicated case." + (python-tests-with-temp-buffer + " +objects = Thing.objects.all() \\\\ + .filter( + type='toy', + status='bought' + ) \\\\ + .aggregate( + Sum('amount') + ) \\\\ + .values_list() +" + (python-tests-look-at "objects = Thing.objects.all()") + (should (eq (car (python-indent-context)) :no-indent)) + (should (= (python-indent-calculate-indentation) 0)) + (python-tests-look-at ".filter(") + (should (eq (car (python-indent-context)) + :after-backslash-dotted-continuation)) + (should (= (python-indent-calculate-indentation) 23)) + (python-tests-look-at "type='toy',") + (should (eq (car (python-indent-context)) :inside-paren-newline-start)) + (should (= (python-indent-calculate-indentation) 27)) + (python-tests-look-at "status='bought'") + (should (eq (car (python-indent-context)) :inside-paren-newline-start)) + (should (= (python-indent-calculate-indentation) 27)) + (python-tests-look-at ") \\\\") + (should (eq (car (python-indent-context)) :inside-paren-at-closing-paren)) + (should (= (python-indent-calculate-indentation) 23)) + (python-tests-look-at ".aggregate(") + (should (eq (car (python-indent-context)) + :after-backslash-dotted-continuation)) + (should (= (python-indent-calculate-indentation) 23)) + (python-tests-look-at "Sum('amount')") + (should (eq (car (python-indent-context)) :inside-paren-newline-start)) + (should (= (python-indent-calculate-indentation) 27)) + (python-tests-look-at ") \\\\") + (should (eq (car (python-indent-context)) :inside-paren-at-closing-paren)) + (should (= (python-indent-calculate-indentation) 23)) + (python-tests-look-at ".values_list()") + (should (eq (car (python-indent-context)) + :after-backslash-dotted-continuation)) + (should (= (python-indent-calculate-indentation) 23)) + (forward-line 1) + (should (eq (car (python-indent-context)) :after-line)) + (should (= (python-indent-calculate-indentation) 0)))) + +(ert-deftest python-indent-after-backslash-3 () + "Backslash continuation from block start." + (python-tests-with-temp-buffer + " +with open('/path/to/some/file/you/want/to/read') as file_1, \\\\ + open('/path/to/some/file/being/written', 'w') as file_2: + file_2.write(file_1.read()) +" + (python-tests-look-at + "with open('/path/to/some/file/you/want/to/read') as file_1, \\\\") + (should (eq (car (python-indent-context)) :no-indent)) + (should (= (python-indent-calculate-indentation) 0)) + (python-tests-look-at + "open('/path/to/some/file/being/written', 'w') as file_2") + (should (eq (car (python-indent-context)) + :after-backslash-block-continuation)) + (should (= (python-indent-calculate-indentation) 5)) + (python-tests-look-at "file_2.write(file_1.read())") + (should (eq (car (python-indent-context)) :after-block-start)) + (should (= (python-indent-calculate-indentation) 4)))) + +(ert-deftest python-indent-after-backslash-4 () + "Backslash continuation from assignment." + (python-tests-with-temp-buffer + " +super_awful_assignment = some_calculation() and \\\\ + another_calculation() and \\\\ + some_final_calculation() +" + (python-tests-look-at + "super_awful_assignment = some_calculation() and \\\\") + (should (eq (car (python-indent-context)) :no-indent)) + (should (= (python-indent-calculate-indentation) 0)) + (python-tests-look-at "another_calculation() and \\\\") + (should (eq (car (python-indent-context)) + :after-backslash-assignment-continuation)) + (should (= (python-indent-calculate-indentation) 25)) + (python-tests-look-at "some_final_calculation()") + (should (eq (car (python-indent-context)) :after-backslash)) + (should (= (python-indent-calculate-indentation) 25)))) + +(ert-deftest python-indent-after-backslash-5 () + "Dotted continuation bizarre example." + (python-tests-with-temp-buffer + " +def delete_all_things(): + Thing \\\\ + .objects.all() \\\\ + .delete() +" + (python-tests-look-at "Thing \\\\") + (should (eq (car (python-indent-context)) :after-block-start)) + (should (= (python-indent-calculate-indentation) 4)) + (python-tests-look-at ".objects.all() \\\\") + (should (eq (car (python-indent-context)) :after-backslash-first-line)) + (should (= (python-indent-calculate-indentation) 8)) + (python-tests-look-at ".delete()") + (should (eq (car (python-indent-context)) + :after-backslash-dotted-continuation)) + (should (= (python-indent-calculate-indentation) 16)))) + +(ert-deftest python-indent-block-enders-1 () + "Test de-indentation for pass keyword." + (python-tests-with-temp-buffer + " +Class foo(object): + + def bar(self): + if self.baz: + return (1, + 2, + 3) + + else: + pass +" + (python-tests-look-at "3)") + (forward-line 1) + (should (= (python-indent-calculate-indentation) 8)) + (python-tests-look-at "pass") + (forward-line 1) + (should (eq (car (python-indent-context)) :after-block-end)) + (should (= (python-indent-calculate-indentation) 8)))) + +(ert-deftest python-indent-block-enders-2 () + "Test de-indentation for return keyword." + (python-tests-with-temp-buffer + " +Class foo(object): + '''raise lorem ipsum dolor sit amet, consectetur adipisicing elit, sed do + + eiusmod tempor incididunt ut labore et dolore magna aliqua. + ''' + def bar(self): + \"return (1, 2, 3).\" + if self.baz: + return (1, + 2, + 3) +" + (python-tests-look-at "def") + (should (= (python-indent-calculate-indentation) 4)) + (python-tests-look-at "if") + (should (= (python-indent-calculate-indentation) 8)) + (python-tests-look-at "return") + (should (= (python-indent-calculate-indentation) 12)) + (goto-char (point-max)) + (should (eq (car (python-indent-context)) :after-block-end)) + (should (= (python-indent-calculate-indentation) 8)))) + +(ert-deftest python-indent-block-enders-3 () + "Test de-indentation for continue keyword." + (python-tests-with-temp-buffer + " +for element in lst: + if element is None: + continue +" + (python-tests-look-at "if") + (should (= (python-indent-calculate-indentation) 4)) + (python-tests-look-at "continue") + (should (= (python-indent-calculate-indentation) 8)) + (forward-line 1) + (should (eq (car (python-indent-context)) :after-block-end)) + (should (= (python-indent-calculate-indentation) 4)))) + +(ert-deftest python-indent-block-enders-4 () + "Test de-indentation for break keyword." + (python-tests-with-temp-buffer + " +for element in lst: + if element is None: + break +" + (python-tests-look-at "if") + (should (= (python-indent-calculate-indentation) 4)) + (python-tests-look-at "break") + (should (= (python-indent-calculate-indentation) 8)) + (forward-line 1) + (should (eq (car (python-indent-context)) :after-block-end)) + (should (= (python-indent-calculate-indentation) 4)))) + +(ert-deftest python-indent-block-enders-5 () + "Test de-indentation for raise keyword." + (python-tests-with-temp-buffer + " +for element in lst: + if element is None: + raise ValueError('Element cannot be None') +" + (python-tests-look-at "if") + (should (= (python-indent-calculate-indentation) 4)) + (python-tests-look-at "raise") + (should (= (python-indent-calculate-indentation) 8)) + (forward-line 1) + (should (eq (car (python-indent-context)) :after-block-end)) + (should (= (python-indent-calculate-indentation) 4)))) + +(ert-deftest python-indent-dedenters-1 () + "Test de-indentation for the elif keyword." + (python-tests-with-temp-buffer + " +if save: + try: + write_to_disk(data) + finally: + cleanup() + elif +" + (python-tests-look-at "elif\n") + (should (eq (car (python-indent-context)) :at-dedenter-block-start)) + (should (= (python-indent-calculate-indentation) 0)) + (should (= (python-indent-calculate-indentation t) 0)))) + +(ert-deftest python-indent-dedenters-2 () + "Test de-indentation for the else keyword." + (python-tests-with-temp-buffer + " +if save: + try: + write_to_disk(data) + except IOError: + msg = 'Error saving to disk' + message(msg) + logger.exception(msg) + except Exception: + if hide_details: + logger.exception('Unhandled exception') + else + finally: + data.free() +" + (python-tests-look-at "else\n") + (should (eq (car (python-indent-context)) :at-dedenter-block-start)) + (should (= (python-indent-calculate-indentation) 8)) + (python-indent-line t) + (should (= (python-indent-calculate-indentation t) 4)) + (python-indent-line t) + (should (= (python-indent-calculate-indentation t) 0)) + (python-indent-line t) + (should (= (python-indent-calculate-indentation t) 8)))) + +(ert-deftest python-indent-dedenters-3 () + "Test de-indentation for the except keyword." + (python-tests-with-temp-buffer + " +if save: + try: + write_to_disk(data) + except +" + (python-tests-look-at "except\n") + (should (eq (car (python-indent-context)) :at-dedenter-block-start)) + (should (= (python-indent-calculate-indentation) 4)) + (python-indent-line t) + (should (= (python-indent-calculate-indentation t) 4)))) + +(ert-deftest python-indent-dedenters-4 () + "Test de-indentation for the finally keyword." + (python-tests-with-temp-buffer + " +if save: + try: + write_to_disk(data) + finally +" + (python-tests-look-at "finally\n") + (should (eq (car (python-indent-context)) :at-dedenter-block-start)) + (should (= (python-indent-calculate-indentation) 4)) + (python-indent-line t) + (should (= (python-indent-calculate-indentation) 4)))) + +(ert-deftest python-indent-dedenters-5 () + "Test invalid levels are skipped in a complex example." + (python-tests-with-temp-buffer + " +if save: + try: + write_to_disk(data) + except IOError: + msg = 'Error saving to disk' + message(msg) + logger.exception(msg) + finally: + if cleanup: + do_cleanup() + else +" + (python-tests-look-at "else\n") + (should (eq (car (python-indent-context)) :at-dedenter-block-start)) + (should (= (python-indent-calculate-indentation) 8)) + (should (= (python-indent-calculate-indentation t) 0)) + (python-indent-line t) + (should (= (python-indent-calculate-indentation t) 8)))) + +(ert-deftest python-indent-dedenters-6 () + "Test indentation is zero when no opening block for dedenter." + (python-tests-with-temp-buffer + " +try: + # if save: + write_to_disk(data) + else +" + (python-tests-look-at "else\n") + (should (eq (car (python-indent-context)) :at-dedenter-block-start)) + (should (= (python-indent-calculate-indentation) 0)) + (should (= (python-indent-calculate-indentation t) 0)))) + +(ert-deftest python-indent-dedenters-7 () + "Test indentation case from Bug#15163." + (python-tests-with-temp-buffer + " +if a: + if b: + pass + else: + pass + else: +" + (python-tests-look-at "else:" 2) + (should (eq (car (python-indent-context)) :at-dedenter-block-start)) + (should (= (python-indent-calculate-indentation) 0)) + (should (= (python-indent-calculate-indentation t) 0)))) + +(ert-deftest python-indent-dedenters-8 () + "Test indentation for Bug#18432." + (python-tests-with-temp-buffer + " +if (a == 1 or + a == 2): + pass +elif (a == 3 or +a == 4): +" + (python-tests-look-at "elif (a == 3 or") + (should (eq (car (python-indent-context)) :at-dedenter-block-start)) + (should (= (python-indent-calculate-indentation) 0)) + (should (= (python-indent-calculate-indentation t) 0)) + (python-tests-look-at "a == 4):\n") + (should (eq (car (python-indent-context)) :inside-paren)) + (should (= (python-indent-calculate-indentation) 6)) + (python-indent-line) + (should (= (python-indent-calculate-indentation t) 4)) + (python-indent-line t) + (should (= (python-indent-calculate-indentation t) 0)) + (python-indent-line t) + (should (= (python-indent-calculate-indentation t) 6)))) + +(ert-deftest python-indent-inside-string-1 () + "Test indentation for strings." + (python-tests-with-temp-buffer + " +multiline = ''' +bunch +of +lines +''' +" + (python-tests-look-at "multiline = '''") + (should (eq (car (python-indent-context)) :no-indent)) + (should (= (python-indent-calculate-indentation) 0)) + (python-tests-look-at "bunch") + (should (eq (car (python-indent-context)) :inside-string)) + (should (= (python-indent-calculate-indentation) 0)) + (python-tests-look-at "of") + (should (eq (car (python-indent-context)) :inside-string)) + (should (= (python-indent-calculate-indentation) 0)) + (python-tests-look-at "lines") + (should (eq (car (python-indent-context)) :inside-string)) + (should (= (python-indent-calculate-indentation) 0)) + (python-tests-look-at "'''") + (should (eq (car (python-indent-context)) :inside-string)) + (should (= (python-indent-calculate-indentation) 0)))) + +(ert-deftest python-indent-inside-string-2 () + "Test indentation for docstrings." + (python-tests-with-temp-buffer + " +def fn(a, b, c=True): + '''docstring + bunch + of + lines + ''' +" + (python-tests-look-at "'''docstring") + (should (eq (car (python-indent-context)) :after-block-start)) + (should (= (python-indent-calculate-indentation) 4)) + (python-tests-look-at "bunch") + (should (eq (car (python-indent-context)) :inside-docstring)) + (should (= (python-indent-calculate-indentation) 4)) + (python-tests-look-at "of") + (should (eq (car (python-indent-context)) :inside-docstring)) + ;; Any indentation deeper than the base-indent must remain unmodified. + (should (= (python-indent-calculate-indentation) 8)) + (python-tests-look-at "lines") + (should (eq (car (python-indent-context)) :inside-docstring)) + (should (= (python-indent-calculate-indentation) 4)) + (python-tests-look-at "'''") + (should (eq (car (python-indent-context)) :inside-docstring)) + (should (= (python-indent-calculate-indentation) 4)))) + +(ert-deftest python-indent-inside-string-3 () + "Test indentation for nested strings." + (python-tests-with-temp-buffer + " +def fn(a, b, c=True): + some_var = ''' + bunch + of + lines + ''' +" + (python-tests-look-at "some_var = '''") + (should (eq (car (python-indent-context)) :after-block-start)) + (should (= (python-indent-calculate-indentation) 4)) + (python-tests-look-at "bunch") + (should (eq (car (python-indent-context)) :inside-string)) + (should (= (python-indent-calculate-indentation) 4)) + (python-tests-look-at "of") + (should (eq (car (python-indent-context)) :inside-string)) + (should (= (python-indent-calculate-indentation) 4)) + (python-tests-look-at "lines") + (should (eq (car (python-indent-context)) :inside-string)) + (should (= (python-indent-calculate-indentation) 4)) + (python-tests-look-at "'''") + (should (eq (car (python-indent-context)) :inside-string)) + (should (= (python-indent-calculate-indentation) 4)))) + +(ert-deftest python-indent-electric-colon-1 () + "Test indentation case from Bug#18228." + (python-tests-with-temp-buffer + " +def a(): + pass + +def b() +" + (python-tests-look-at "def b()") + (goto-char (line-end-position)) + (python-tests-self-insert ":") + (should (= (current-indentation) 0)))) + +(ert-deftest python-indent-electric-colon-2 () + "Test indentation case for dedenter." + (python-tests-with-temp-buffer + " +if do: + something() + else +" + (python-tests-look-at "else") + (goto-char (line-end-position)) + (python-tests-self-insert ":") + (should (= (current-indentation) 0)))) + +(ert-deftest python-indent-electric-colon-3 () + "Test indentation case for multi-line dedenter." + (python-tests-with-temp-buffer + " +if do: + something() + elif (this + and + that) +" + (python-tests-look-at "that)") + (goto-char (line-end-position)) + (python-tests-self-insert ":") + (python-tests-look-at "elif" -1) + (should (= (current-indentation) 0)) + (python-tests-look-at "and") + (should (= (current-indentation) 6)) + (python-tests-look-at "that)") + (should (= (current-indentation) 6)))) + +(ert-deftest python-indent-region-1 () + "Test indentation case from Bug#18843." + (let ((contents " +def foo (): + try: + pass + except: + pass +")) + (python-tests-with-temp-buffer + contents + (python-indent-region (point-min) (point-max)) + (should (string= (buffer-substring-no-properties (point-min) (point-max)) + contents))))) + +(ert-deftest python-indent-region-2 () + "Test region indentation on comments." + (let ((contents " +def f(): + if True: + pass + +# This is +# some multiline +# comment +")) + (python-tests-with-temp-buffer + contents + (python-indent-region (point-min) (point-max)) + (should (string= (buffer-substring-no-properties (point-min) (point-max)) + contents))))) + +(ert-deftest python-indent-region-3 () + "Test region indentation on comments." + (let ((contents " +def f(): + if True: + pass +# This is +# some multiline +# comment +") + (expected " +def f(): + if True: + pass + # This is + # some multiline + # comment +")) + (python-tests-with-temp-buffer + contents + (python-indent-region (point-min) (point-max)) + (should (string= (buffer-substring-no-properties (point-min) (point-max)) + expected))))) + +(ert-deftest python-indent-region-4 () + "Test region indentation block starts, dedenters and enders." + (let ((contents " +def f(): + if True: +a = 5 + else: + a = 10 + return a +") + (expected " +def f(): + if True: + a = 5 + else: + a = 10 + return a +")) + (python-tests-with-temp-buffer + contents + (python-indent-region (point-min) (point-max)) + (should (string= (buffer-substring-no-properties (point-min) (point-max)) + expected))))) + +(ert-deftest python-indent-region-5 () + "Test region indentation for docstrings." + (let ((contents " +def f(): +''' +this is + a multiline +string +''' + x = \\ + ''' +this is an arbitrarily + indented multiline + string +''' +") + (expected " +def f(): + ''' + this is + a multiline + string + ''' + x = \\ + ''' +this is an arbitrarily + indented multiline + string +''' +")) + (python-tests-with-temp-buffer + contents + (python-indent-region (point-min) (point-max)) + (should (string= (buffer-substring-no-properties (point-min) (point-max)) + expected))))) + + +;;; Mark + +(ert-deftest python-mark-defun-1 () + """Test `python-mark-defun' with point at defun symbol start.""" + (python-tests-with-temp-buffer + " +def foo(x): + return x + +class A: + pass + +class B: + + def __init__(self): + self.b = 'b' + + def fun(self): + return self.b + +class C: + '''docstring''' +" + (let ((expected-mark-beginning-position + (progn + (python-tests-look-at "class A:") + (1- (point)))) + (expected-mark-end-position-1 + (save-excursion + (python-tests-look-at "pass") + (forward-line) + (point))) + (expected-mark-end-position-2 + (save-excursion + (python-tests-look-at "return self.b") + (forward-line) + (point))) + (expected-mark-end-position-3 + (save-excursion + (python-tests-look-at "'''docstring'''") + (forward-line) + (point)))) + ;; Select class A only, with point at bol. + (python-mark-defun 1) + (should (= (point) expected-mark-beginning-position)) + (should (= (marker-position (mark-marker)) + expected-mark-end-position-1)) + ;; expand to class B, start position should remain the same. + (python-mark-defun 1) + (should (= (point) expected-mark-beginning-position)) + (should (= (marker-position (mark-marker)) + expected-mark-end-position-2)) + ;; expand to class C, start position should remain the same. + (python-mark-defun 1) + (should (= (point) expected-mark-beginning-position)) + (should (= (marker-position (mark-marker)) + expected-mark-end-position-3))))) + +(ert-deftest python-mark-defun-2 () + """Test `python-mark-defun' with point at nested defun symbol start.""" + (python-tests-with-temp-buffer + " +def foo(x): + return x + +class A: + pass + +class B: + + def __init__(self): + self.b = 'b' + + def fun(self): + return self.b + +class C: + '''docstring''' +" + (let ((expected-mark-beginning-position + (progn + (python-tests-look-at "def __init__(self):") + (1- (line-beginning-position)))) + (expected-mark-end-position-1 + (save-excursion + (python-tests-look-at "self.b = 'b'") + (forward-line) + (point))) + (expected-mark-end-position-2 + (save-excursion + (python-tests-look-at "return self.b") + (forward-line) + (point))) + (expected-mark-end-position-3 + (save-excursion + (python-tests-look-at "'''docstring'''") + (forward-line) + (point)))) + ;; Select B.__init only, with point at its start. + (python-mark-defun 1) + (should (= (point) expected-mark-beginning-position)) + (should (= (marker-position (mark-marker)) + expected-mark-end-position-1)) + ;; expand to B.fun, start position should remain the same. + (python-mark-defun 1) + (should (= (point) expected-mark-beginning-position)) + (should (= (marker-position (mark-marker)) + expected-mark-end-position-2)) + ;; expand to class C, start position should remain the same. + (python-mark-defun 1) + (should (= (point) expected-mark-beginning-position)) + (should (= (marker-position (mark-marker)) + expected-mark-end-position-3))))) + +(ert-deftest python-mark-defun-3 () + """Test `python-mark-defun' with point inside defun symbol.""" + (python-tests-with-temp-buffer + " +def foo(x): + return x + +class A: + pass + +class B: + + def __init__(self): + self.b = 'b' + + def fun(self): + return self.b + +class C: + '''docstring''' +" + (let ((expected-mark-beginning-position + (progn + (python-tests-look-at "def fun(self):") + (python-tests-look-at "(self):") + (1- (line-beginning-position)))) + (expected-mark-end-position + (save-excursion + (python-tests-look-at "return self.b") + (forward-line) + (point)))) + ;; Should select B.fun, despite point is inside the defun symbol. + (python-mark-defun 1) + (should (= (point) expected-mark-beginning-position)) + (should (= (marker-position (mark-marker)) + expected-mark-end-position))))) + + +;;; Navigation + +(ert-deftest python-nav-beginning-of-defun-1 () + (python-tests-with-temp-buffer + " +def decoratorFunctionWithArguments(arg1, arg2, arg3): + '''print decorated function call data to stdout. + + Usage: + + @decoratorFunctionWithArguments('arg1', 'arg2') + def func(a, b, c=True): + pass + ''' + + def wwrap(f): + print 'Inside wwrap()' + def wrapped_f(*args): + print 'Inside wrapped_f()' + print 'Decorator arguments:', arg1, arg2, arg3 + f(*args) + print 'After f(*args)' + return wrapped_f + return wwrap +" + (python-tests-look-at "return wrap") + (should (= (save-excursion + (python-nav-beginning-of-defun) + (point)) + (save-excursion + (python-tests-look-at "def wrapped_f(*args):" -1) + (beginning-of-line) + (point)))) + (python-tests-look-at "def wrapped_f(*args):" -1) + (should (= (save-excursion + (python-nav-beginning-of-defun) + (point)) + (save-excursion + (python-tests-look-at "def wwrap(f):" -1) + (beginning-of-line) + (point)))) + (python-tests-look-at "def wwrap(f):" -1) + (should (= (save-excursion + (python-nav-beginning-of-defun) + (point)) + (save-excursion + (python-tests-look-at "def decoratorFunctionWithArguments" -1) + (beginning-of-line) + (point)))))) + +(ert-deftest python-nav-beginning-of-defun-2 () + (python-tests-with-temp-buffer + " +class C(object): + + def m(self): + self.c() + + def b(): + pass + + def a(): + pass + + def c(self): + pass +" + ;; Nested defuns, are handled with care. + (python-tests-look-at "def c(self):") + (should (= (save-excursion + (python-nav-beginning-of-defun) + (point)) + (save-excursion + (python-tests-look-at "def m(self):" -1) + (beginning-of-line) + (point)))) + ;; Defuns on same levels should be respected. + (python-tests-look-at "def a():" -1) + (should (= (save-excursion + (python-nav-beginning-of-defun) + (point)) + (save-excursion + (python-tests-look-at "def b():" -1) + (beginning-of-line) + (point)))) + ;; Jump to a top level defun. + (python-tests-look-at "def b():" -1) + (should (= (save-excursion + (python-nav-beginning-of-defun) + (point)) + (save-excursion + (python-tests-look-at "def m(self):" -1) + (beginning-of-line) + (point)))) + ;; Jump to a top level defun again. + (python-tests-look-at "def m(self):" -1) + (should (= (save-excursion + (python-nav-beginning-of-defun) + (point)) + (save-excursion + (python-tests-look-at "class C(object):" -1) + (beginning-of-line) + (point)))))) + +(ert-deftest python-nav-end-of-defun-1 () + (python-tests-with-temp-buffer + " +class C(object): + + def m(self): + self.c() + + def b(): + pass + + def a(): + pass + + def c(self): + pass +" + (should (= (save-excursion + (python-tests-look-at "class C(object):") + (python-nav-end-of-defun) + (point)) + (save-excursion + (point-max)))) + (should (= (save-excursion + (python-tests-look-at "def m(self):") + (python-nav-end-of-defun) + (point)) + (save-excursion + (python-tests-look-at "def c(self):") + (forward-line -1) + (point)))) + (should (= (save-excursion + (python-tests-look-at "def b():") + (python-nav-end-of-defun) + (point)) + (save-excursion + (python-tests-look-at "def b():") + (forward-line 2) + (point)))) + (should (= (save-excursion + (python-tests-look-at "def c(self):") + (python-nav-end-of-defun) + (point)) + (save-excursion + (point-max)))))) + +(ert-deftest python-nav-end-of-defun-2 () + (python-tests-with-temp-buffer + " +def decoratorFunctionWithArguments(arg1, arg2, arg3): + '''print decorated function call data to stdout. + + Usage: + + @decoratorFunctionWithArguments('arg1', 'arg2') + def func(a, b, c=True): + pass + ''' + + def wwrap(f): + print 'Inside wwrap()' + def wrapped_f(*args): + print 'Inside wrapped_f()' + print 'Decorator arguments:', arg1, arg2, arg3 + f(*args) + print 'After f(*args)' + return wrapped_f + return wwrap +" + (should (= (save-excursion + (python-tests-look-at "def decoratorFunctionWithArguments") + (python-nav-end-of-defun) + (point)) + (save-excursion + (point-max)))) + (should (= (save-excursion + (python-tests-look-at "@decoratorFunctionWithArguments") + (python-nav-end-of-defun) + (point)) + (save-excursion + (point-max)))) + (should (= (save-excursion + (python-tests-look-at "def wwrap(f):") + (python-nav-end-of-defun) + (point)) + (save-excursion + (python-tests-look-at "return wwrap") + (line-beginning-position)))) + (should (= (save-excursion + (python-tests-look-at "def wrapped_f(*args):") + (python-nav-end-of-defun) + (point)) + (save-excursion + (python-tests-look-at "return wrapped_f") + (line-beginning-position)))) + (should (= (save-excursion + (python-tests-look-at "f(*args)") + (python-nav-end-of-defun) + (point)) + (save-excursion + (python-tests-look-at "return wrapped_f") + (line-beginning-position)))))) + +(ert-deftest python-nav-backward-defun-1 () + (python-tests-with-temp-buffer + " +class A(object): # A + + def a(self): # a + pass + + def b(self): # b + pass + + class B(object): # B + + class C(object): # C + + def d(self): # d + pass + + # def e(self): # e + # pass + + def c(self): # c + pass + + # def d(self): # d + # pass +" + (goto-char (point-max)) + (should (= (save-excursion (python-nav-backward-defun)) + (python-tests-look-at " def c(self): # c" -1))) + (should (= (save-excursion (python-nav-backward-defun)) + (python-tests-look-at " def d(self): # d" -1))) + (should (= (save-excursion (python-nav-backward-defun)) + (python-tests-look-at " class C(object): # C" -1))) + (should (= (save-excursion (python-nav-backward-defun)) + (python-tests-look-at " class B(object): # B" -1))) + (should (= (save-excursion (python-nav-backward-defun)) + (python-tests-look-at " def b(self): # b" -1))) + (should (= (save-excursion (python-nav-backward-defun)) + (python-tests-look-at " def a(self): # a" -1))) + (should (= (save-excursion (python-nav-backward-defun)) + (python-tests-look-at "class A(object): # A" -1))) + (should (not (python-nav-backward-defun))))) + +(ert-deftest python-nav-backward-defun-2 () + (python-tests-with-temp-buffer + " +def decoratorFunctionWithArguments(arg1, arg2, arg3): + '''print decorated function call data to stdout. + + Usage: + + @decoratorFunctionWithArguments('arg1', 'arg2') + def func(a, b, c=True): + pass + ''' + + def wwrap(f): + print 'Inside wwrap()' + def wrapped_f(*args): + print 'Inside wrapped_f()' + print 'Decorator arguments:', arg1, arg2, arg3 + f(*args) + print 'After f(*args)' + return wrapped_f + return wwrap +" + (goto-char (point-max)) + (should (= (save-excursion (python-nav-backward-defun)) + (python-tests-look-at " def wrapped_f(*args):" -1))) + (should (= (save-excursion (python-nav-backward-defun)) + (python-tests-look-at " def wwrap(f):" -1))) + (should (= (save-excursion (python-nav-backward-defun)) + (python-tests-look-at "def decoratorFunctionWithArguments(arg1, arg2, arg3):" -1))) + (should (not (python-nav-backward-defun))))) + +(ert-deftest python-nav-backward-defun-3 () + (python-tests-with-temp-buffer + " +''' + def u(self): + pass + + def v(self): + pass + + def w(self): + pass +''' + +class A(object): + pass +" + (goto-char (point-min)) + (let ((point (python-tests-look-at "class A(object):"))) + (should (not (python-nav-backward-defun))) + (should (= point (point)))))) + +(ert-deftest python-nav-forward-defun-1 () + (python-tests-with-temp-buffer + " +class A(object): # A + + def a(self): # a + pass + + def b(self): # b + pass + + class B(object): # B + + class C(object): # C + + def d(self): # d + pass + + # def e(self): # e + # pass + + def c(self): # c + pass + + # def d(self): # d + # pass +" + (goto-char (point-min)) + (should (= (save-excursion (python-nav-forward-defun)) + (python-tests-look-at "(object): # A"))) + (should (= (save-excursion (python-nav-forward-defun)) + (python-tests-look-at "(self): # a"))) + (should (= (save-excursion (python-nav-forward-defun)) + (python-tests-look-at "(self): # b"))) + (should (= (save-excursion (python-nav-forward-defun)) + (python-tests-look-at "(object): # B"))) + (should (= (save-excursion (python-nav-forward-defun)) + (python-tests-look-at "(object): # C"))) + (should (= (save-excursion (python-nav-forward-defun)) + (python-tests-look-at "(self): # d"))) + (should (= (save-excursion (python-nav-forward-defun)) + (python-tests-look-at "(self): # c"))) + (should (not (python-nav-forward-defun))))) + +(ert-deftest python-nav-forward-defun-2 () + (python-tests-with-temp-buffer + " +def decoratorFunctionWithArguments(arg1, arg2, arg3): + '''print decorated function call data to stdout. + + Usage: + + @decoratorFunctionWithArguments('arg1', 'arg2') + def func(a, b, c=True): + pass + ''' + + def wwrap(f): + print 'Inside wwrap()' + def wrapped_f(*args): + print 'Inside wrapped_f()' + print 'Decorator arguments:', arg1, arg2, arg3 + f(*args) + print 'After f(*args)' + return wrapped_f + return wwrap +" + (goto-char (point-min)) + (should (= (save-excursion (python-nav-forward-defun)) + (python-tests-look-at "(arg1, arg2, arg3):"))) + (should (= (save-excursion (python-nav-forward-defun)) + (python-tests-look-at "(f):"))) + (should (= (save-excursion (python-nav-forward-defun)) + (python-tests-look-at "(*args):"))) + (should (not (python-nav-forward-defun))))) + +(ert-deftest python-nav-forward-defun-3 () + (python-tests-with-temp-buffer + " +class A(object): + pass + +''' + def u(self): + pass + + def v(self): + pass + + def w(self): + pass +''' +" + (goto-char (point-min)) + (let ((point (python-tests-look-at "(object):"))) + (should (not (python-nav-forward-defun))) + (should (= point (point)))))) + +(ert-deftest python-nav-beginning-of-statement-1 () + (python-tests-with-temp-buffer + " +v1 = 123 + \ + 456 + \ + 789 +v2 = (value1, + value2, + + value3, + value4) +v3 = ('this is a string' + + 'that is continued' + 'between lines' + 'within a paren', + # this is a comment, yo + 'continue previous line') +v4 = ''' +a very long +string +''' +" + (python-tests-look-at "v2 =") + (python-util-forward-comment -1) + (should (= (save-excursion + (python-nav-beginning-of-statement) + (point)) + (python-tests-look-at "v1 =" -1 t))) + (python-tests-look-at "v3 =") + (python-util-forward-comment -1) + (should (= (save-excursion + (python-nav-beginning-of-statement) + (point)) + (python-tests-look-at "v2 =" -1 t))) + (python-tests-look-at "v4 =") + (python-util-forward-comment -1) + (should (= (save-excursion + (python-nav-beginning-of-statement) + (point)) + (python-tests-look-at "v3 =" -1 t))) + (goto-char (point-max)) + (python-util-forward-comment -1) + (should (= (save-excursion + (python-nav-beginning-of-statement) + (point)) + (python-tests-look-at "v4 =" -1 t))))) + +(ert-deftest python-nav-end-of-statement-1 () + (python-tests-with-temp-buffer + " +v1 = 123 + \ + 456 + \ + 789 +v2 = (value1, + value2, + + value3, + value4) +v3 = ('this is a string' + + 'that is continued' + 'between lines' + 'within a paren', + # this is a comment, yo + 'continue previous line') +v4 = ''' +a very long +string +''' +" + (python-tests-look-at "v1 =") + (should (= (save-excursion + (python-nav-end-of-statement) + (point)) + (save-excursion + (python-tests-look-at "789") + (line-end-position)))) + (python-tests-look-at "v2 =") + (should (= (save-excursion + (python-nav-end-of-statement) + (point)) + (save-excursion + (python-tests-look-at "value4)") + (line-end-position)))) + (python-tests-look-at "v3 =") + (should (= (save-excursion + (python-nav-end-of-statement) + (point)) + (save-excursion + (python-tests-look-at + "'continue previous line')") + (line-end-position)))) + (python-tests-look-at "v4 =") + (should (= (save-excursion + (python-nav-end-of-statement) + (point)) + (save-excursion + (goto-char (point-max)) + (python-util-forward-comment -1) + (point)))))) + +(ert-deftest python-nav-forward-statement-1 () + (python-tests-with-temp-buffer + " +v1 = 123 + \ + 456 + \ + 789 +v2 = (value1, + value2, + + value3, + value4) +v3 = ('this is a string' + + 'that is continued' + 'between lines' + 'within a paren', + # this is a comment, yo + 'continue previous line') +v4 = ''' +a very long +string +''' +" + (python-tests-look-at "v1 =") + (should (= (save-excursion + (python-nav-forward-statement) + (point)) + (python-tests-look-at "v2 ="))) + (should (= (save-excursion + (python-nav-forward-statement) + (point)) + (python-tests-look-at "v3 ="))) + (should (= (save-excursion + (python-nav-forward-statement) + (point)) + (python-tests-look-at "v4 ="))) + (should (= (save-excursion + (python-nav-forward-statement) + (point)) + (point-max))))) + +(ert-deftest python-nav-backward-statement-1 () + (python-tests-with-temp-buffer + " +v1 = 123 + \ + 456 + \ + 789 +v2 = (value1, + value2, + + value3, + value4) +v3 = ('this is a string' + + 'that is continued' + 'between lines' + 'within a paren', + # this is a comment, yo + 'continue previous line') +v4 = ''' +a very long +string +''' +" + (goto-char (point-max)) + (should (= (save-excursion + (python-nav-backward-statement) + (point)) + (python-tests-look-at "v4 =" -1))) + (should (= (save-excursion + (python-nav-backward-statement) + (point)) + (python-tests-look-at "v3 =" -1))) + (should (= (save-excursion + (python-nav-backward-statement) + (point)) + (python-tests-look-at "v2 =" -1))) + (should (= (save-excursion + (python-nav-backward-statement) + (point)) + (python-tests-look-at "v1 =" -1))))) + +(ert-deftest python-nav-backward-statement-2 () + :expected-result :failed + (python-tests-with-temp-buffer + " +v1 = 123 + \ + 456 + \ + 789 +v2 = (value1, + value2, + + value3, + value4) +" + ;; FIXME: For some reason `python-nav-backward-statement' is moving + ;; back two sentences when starting from 'value4)'. + (goto-char (point-max)) + (python-util-forward-comment -1) + (should (= (save-excursion + (python-nav-backward-statement) + (point)) + (python-tests-look-at "v2 =" -1 t))))) + +(ert-deftest python-nav-beginning-of-block-1 () + (python-tests-with-temp-buffer + " +def decoratorFunctionWithArguments(arg1, arg2, arg3): + '''print decorated function call data to stdout. + + Usage: + + @decoratorFunctionWithArguments('arg1', 'arg2') + def func(a, b, c=True): + pass + ''' + + def wwrap(f): + print 'Inside wwrap()' + def wrapped_f(*args): + print 'Inside wrapped_f()' + print 'Decorator arguments:', arg1, arg2, arg3 + f(*args) + print 'After f(*args)' + return wrapped_f + return wwrap +" + (python-tests-look-at "return wwrap") + (should (= (save-excursion + (python-nav-beginning-of-block) + (point)) + (python-tests-look-at "def decoratorFunctionWithArguments" -1))) + (python-tests-look-at "print 'Inside wwrap()'") + (should (= (save-excursion + (python-nav-beginning-of-block) + (point)) + (python-tests-look-at "def wwrap(f):" -1))) + (python-tests-look-at "print 'After f(*args)'") + (end-of-line) + (should (= (save-excursion + (python-nav-beginning-of-block) + (point)) + (python-tests-look-at "def wrapped_f(*args):" -1))) + (python-tests-look-at "return wrapped_f") + (should (= (save-excursion + (python-nav-beginning-of-block) + (point)) + (python-tests-look-at "def wwrap(f):" -1))))) + +(ert-deftest python-nav-end-of-block-1 () + (python-tests-with-temp-buffer + " +def decoratorFunctionWithArguments(arg1, arg2, arg3): + '''print decorated function call data to stdout. + + Usage: + + @decoratorFunctionWithArguments('arg1', 'arg2') + def func(a, b, c=True): + pass + ''' + + def wwrap(f): + print 'Inside wwrap()' + def wrapped_f(*args): + print 'Inside wrapped_f()' + print 'Decorator arguments:', arg1, arg2, arg3 + f(*args) + print 'After f(*args)' + return wrapped_f + return wwrap +" + (python-tests-look-at "def decoratorFunctionWithArguments") + (should (= (save-excursion + (python-nav-end-of-block) + (point)) + (save-excursion + (goto-char (point-max)) + (python-util-forward-comment -1) + (point)))) + (python-tests-look-at "def wwrap(f):") + (should (= (save-excursion + (python-nav-end-of-block) + (point)) + (save-excursion + (python-tests-look-at "return wrapped_f") + (line-end-position)))) + (end-of-line) + (should (= (save-excursion + (python-nav-end-of-block) + (point)) + (save-excursion + (python-tests-look-at "return wrapped_f") + (line-end-position)))) + (python-tests-look-at "f(*args)") + (should (= (save-excursion + (python-nav-end-of-block) + (point)) + (save-excursion + (python-tests-look-at "print 'After f(*args)'") + (line-end-position)))))) + +(ert-deftest python-nav-forward-block-1 () + "This also accounts as a test for `python-nav-backward-block'." + (python-tests-with-temp-buffer + " +if request.user.is_authenticated(): + # def block(): + # pass + try: + profile = request.user.get_profile() + except Profile.DoesNotExist: + profile = Profile.objects.create(user=request.user) + else: + if profile.stats: + profile.recalculate_stats() + else: + profile.clear_stats() + finally: + profile.views += 1 + profile.save() +" + (should (= (save-excursion (python-nav-forward-block)) + (python-tests-look-at "if request.user.is_authenticated():"))) + (should (= (save-excursion (python-nav-forward-block)) + (python-tests-look-at "try:"))) + (should (= (save-excursion (python-nav-forward-block)) + (python-tests-look-at "except Profile.DoesNotExist:"))) + (should (= (save-excursion (python-nav-forward-block)) + (python-tests-look-at "else:"))) + (should (= (save-excursion (python-nav-forward-block)) + (python-tests-look-at "if profile.stats:"))) + (should (= (save-excursion (python-nav-forward-block)) + (python-tests-look-at "else:"))) + (should (= (save-excursion (python-nav-forward-block)) + (python-tests-look-at "finally:"))) + ;; When point is at the last block, leave it there and return nil + (should (not (save-excursion (python-nav-forward-block)))) + ;; Move backwards, and even if the number of moves is less than the + ;; provided argument return the point. + (should (= (save-excursion (python-nav-forward-block -10)) + (python-tests-look-at + "if request.user.is_authenticated():" -1))))) + +(ert-deftest python-nav-forward-sexp-1 () + (python-tests-with-temp-buffer + " +a() +b() +c() +" + (python-tests-look-at "a()") + (python-nav-forward-sexp) + (should (looking-at "$")) + (should (save-excursion + (beginning-of-line) + (looking-at "a()"))) + (python-nav-forward-sexp) + (should (looking-at "$")) + (should (save-excursion + (beginning-of-line) + (looking-at "b()"))) + (python-nav-forward-sexp) + (should (looking-at "$")) + (should (save-excursion + (beginning-of-line) + (looking-at "c()"))) + ;; The default behavior when next to a paren should do what lisp + ;; does and, otherwise `blink-matching-open' breaks. + (python-nav-forward-sexp -1) + (should (looking-at "()")) + (should (save-excursion + (beginning-of-line) + (looking-at "c()"))) + (end-of-line) + ;; Skipping parens should jump to `bolp' + (python-nav-forward-sexp -1 nil t) + (should (looking-at "c()")) + (forward-line -1) + (end-of-line) + ;; b() + (python-nav-forward-sexp -1) + (should (looking-at "()")) + (python-nav-forward-sexp -1) + (should (looking-at "b()")) + (end-of-line) + (python-nav-forward-sexp -1 nil t) + (should (looking-at "b()")) + (forward-line -1) + (end-of-line) + ;; a() + (python-nav-forward-sexp -1) + (should (looking-at "()")) + (python-nav-forward-sexp -1) + (should (looking-at "a()")) + (end-of-line) + (python-nav-forward-sexp -1 nil t) + (should (looking-at "a()")))) + +(ert-deftest python-nav-forward-sexp-2 () + (python-tests-with-temp-buffer + " +def func(): + if True: + aaa = bbb + ccc = ddd + eee = fff + return ggg +" + (python-tests-look-at "aa =") + (python-nav-forward-sexp) + (should (looking-at " = bbb")) + (python-nav-forward-sexp) + (should (looking-at "$")) + (should (save-excursion + (back-to-indentation) + (looking-at "aaa = bbb"))) + (python-nav-forward-sexp) + (should (looking-at "$")) + (should (save-excursion + (back-to-indentation) + (looking-at "ccc = ddd"))) + (python-nav-forward-sexp) + (should (looking-at "$")) + (should (save-excursion + (back-to-indentation) + (looking-at "eee = fff"))) + (python-nav-forward-sexp) + (should (looking-at "$")) + (should (save-excursion + (back-to-indentation) + (looking-at "return ggg"))) + (python-nav-forward-sexp -1) + (should (looking-at "def func():")))) + +(ert-deftest python-nav-forward-sexp-3 () + (python-tests-with-temp-buffer + " +from some_module import some_sub_module +from another_module import another_sub_module + +def another_statement(): + pass +" + (python-tests-look-at "some_module") + (python-nav-forward-sexp) + (should (looking-at " import")) + (python-nav-forward-sexp) + (should (looking-at " some_sub_module")) + (python-nav-forward-sexp) + (should (looking-at "$")) + (should + (save-excursion + (back-to-indentation) + (looking-at + "from some_module import some_sub_module"))) + (python-nav-forward-sexp) + (should (looking-at "$")) + (should + (save-excursion + (back-to-indentation) + (looking-at + "from another_module import another_sub_module"))) + (python-nav-forward-sexp) + (should (looking-at "$")) + (should + (save-excursion + (back-to-indentation) + (looking-at + "pass"))) + (python-nav-forward-sexp -1) + (should (looking-at "def another_statement():")) + (python-nav-forward-sexp -1) + (should (looking-at "from another_module import another_sub_module")) + (python-nav-forward-sexp -1) + (should (looking-at "from some_module import some_sub_module")))) + +(ert-deftest python-nav-forward-sexp-safe-1 () + (python-tests-with-temp-buffer + " +profile = Profile.objects.create(user=request.user) +profile.notify() +" + (python-tests-look-at "profile =") + (python-nav-forward-sexp-safe 1) + (should (looking-at "$")) + (beginning-of-line 1) + (python-tests-look-at "user=request.user") + (python-nav-forward-sexp-safe -1) + (should (looking-at "(user=request.user)")) + (python-nav-forward-sexp-safe -4) + (should (looking-at "profile =")) + (python-tests-look-at "user=request.user") + (python-nav-forward-sexp-safe 3) + (should (looking-at ")")) + (python-nav-forward-sexp-safe 1) + (should (looking-at "$")) + (python-nav-forward-sexp-safe 1) + (should (looking-at "$")))) + +(ert-deftest python-nav-up-list-1 () + (python-tests-with-temp-buffer + " +def f(): + if True: + return [i for i in range(3)] +" + (python-tests-look-at "3)]") + (python-nav-up-list) + (should (looking-at "]")) + (python-nav-up-list) + (should (looking-at "$")))) + +(ert-deftest python-nav-backward-up-list-1 () + :expected-result :failed + (python-tests-with-temp-buffer + " +def f(): + if True: + return [i for i in range(3)] +" + (python-tests-look-at "3)]") + (python-nav-backward-up-list) + (should (looking-at "(3)\\]")) + (python-nav-backward-up-list) + (should (looking-at + "\\[i for i in range(3)\\]")) + ;; FIXME: Need to move to beginning-of-statement. + (python-nav-backward-up-list) + (should (looking-at + "return \\[i for i in range(3)\\]")) + (python-nav-backward-up-list) + (should (looking-at "if True:")) + (python-nav-backward-up-list) + (should (looking-at "def f():")))) + +(ert-deftest python-indent-dedent-line-backspace-1 () + "Check de-indentation on first call. Bug#18319." + (python-tests-with-temp-buffer + " +if True: + x () + if False: +" + (python-tests-look-at "if False:") + (call-interactively #'python-indent-dedent-line-backspace) + (should (zerop (current-indentation))) + ;; XXX: This should be a call to `undo' but it's triggering errors. + (insert " ") + (should (= (current-indentation) 4)) + (call-interactively #'python-indent-dedent-line-backspace) + (should (zerop (current-indentation))))) + +(ert-deftest python-indent-dedent-line-backspace-2 () + "Check de-indentation with tabs. Bug#19730." + (let ((tab-width 8)) + (python-tests-with-temp-buffer + " +if x: +\tabcdefg +" + (python-tests-look-at "abcdefg") + (goto-char (line-end-position)) + (call-interactively #'python-indent-dedent-line-backspace) + (should + (string= (buffer-substring-no-properties + (line-beginning-position) (line-end-position)) + "\tabcdef"))))) + +(ert-deftest python-indent-dedent-line-backspace-3 () + "Paranoid check of de-indentation with tabs. Bug#19730." + (let ((tab-width 8)) + (python-tests-with-temp-buffer + " +if x: +\tif y: +\t abcdefg +" + (python-tests-look-at "abcdefg") + (goto-char (line-end-position)) + (call-interactively #'python-indent-dedent-line-backspace) + (should + (string= (buffer-substring-no-properties + (line-beginning-position) (line-end-position)) + "\t abcdef")) + (back-to-indentation) + (call-interactively #'python-indent-dedent-line-backspace) + (should + (string= (buffer-substring-no-properties + (line-beginning-position) (line-end-position)) + "\tabcdef")) + (call-interactively #'python-indent-dedent-line-backspace) + (should + (string= (buffer-substring-no-properties + (line-beginning-position) (line-end-position)) + " abcdef")) + (call-interactively #'python-indent-dedent-line-backspace) + (should + (string= (buffer-substring-no-properties + (line-beginning-position) (line-end-position)) + "abcdef"))))) + + +;;; Shell integration + +(defvar python-tests-shell-interpreter "python") + +(ert-deftest python-shell-get-process-name-1 () + "Check process name calculation sans `buffer-file-name'." + (python-tests-with-temp-buffer + "" + (should (string= (python-shell-get-process-name nil) + python-shell-buffer-name)) + (should (string= (python-shell-get-process-name t) + (format "%s[%s]" python-shell-buffer-name (buffer-name)))))) + +(ert-deftest python-shell-get-process-name-2 () + "Check process name calculation with `buffer-file-name'." + (python-tests-with-temp-file + "" + ;; `buffer-file-name' is non-nil but the dedicated flag is nil and + ;; should be respected. + (should (string= (python-shell-get-process-name nil) + python-shell-buffer-name)) + (should (string= + (python-shell-get-process-name t) + (format "%s[%s]" python-shell-buffer-name (buffer-name)))))) + +(ert-deftest python-shell-internal-get-process-name-1 () + "Check the internal process name is buffer-unique sans `buffer-file-name'." + (python-tests-with-temp-buffer + "" + (should (string= (python-shell-internal-get-process-name) + (format "%s[%s]" python-shell-internal-buffer-name (buffer-name)))))) + +(ert-deftest python-shell-internal-get-process-name-2 () + "Check the internal process name is buffer-unique with `buffer-file-name'." + (python-tests-with-temp-file + "" + (should (string= (python-shell-internal-get-process-name) + (format "%s[%s]" python-shell-internal-buffer-name (buffer-name)))))) + +(ert-deftest python-shell-calculate-command-1 () + "Check the command to execute is calculated correctly. +Using `python-shell-interpreter' and +`python-shell-interpreter-args'." + (skip-unless (executable-find python-tests-shell-interpreter)) + (let ((python-shell-interpreter (executable-find + python-tests-shell-interpreter)) + (python-shell-interpreter-args "-B")) + (should (string= + (format "%s %s" + (shell-quote-argument python-shell-interpreter) + python-shell-interpreter-args) + (python-shell-calculate-command))))) + +(ert-deftest python-shell-calculate-pythonpath-1 () + "Test PYTHONPATH calculation." + (let ((process-environment '("PYTHONPATH=/path0")) + (python-shell-extra-pythonpaths '("/path1" "/path2"))) + (should (string= (python-shell-calculate-pythonpath) + (concat "/path1" path-separator + "/path2" path-separator "/path0"))))) + +(ert-deftest python-shell-calculate-pythonpath-2 () + "Test existing paths are moved to front." + (let ((process-environment + (list (concat "PYTHONPATH=/path0" path-separator "/path1"))) + (python-shell-extra-pythonpaths '("/path1" "/path2"))) + (should (string= (python-shell-calculate-pythonpath) + (concat "/path1" path-separator + "/path2" path-separator "/path0"))))) + +(ert-deftest python-shell-calculate-process-environment-1 () + "Test `python-shell-process-environment' modification." + (let* ((python-shell-process-environment + '("TESTVAR1=value1" "TESTVAR2=value2")) + (process-environment (python-shell-calculate-process-environment))) + (should (equal (getenv "TESTVAR1") "value1")) + (should (equal (getenv "TESTVAR2") "value2")))) + +(ert-deftest python-shell-calculate-process-environment-2 () + "Test `python-shell-extra-pythonpaths' modification." + (let* ((process-environment process-environment) + (original-pythonpath (setenv "PYTHONPATH" "/path0")) + (python-shell-extra-pythonpaths '("/path1" "/path2")) + (process-environment (python-shell-calculate-process-environment))) + (should (equal (getenv "PYTHONPATH") + (concat "/path1" path-separator + "/path2" path-separator "/path0"))))) + +(ert-deftest python-shell-calculate-process-environment-3 () + "Test `python-shell-virtualenv-root' modification." + (let* ((python-shell-virtualenv-root "/env") + (process-environment + (let (process-environment process-environment) + (setenv "PYTHONHOME" "/home") + (setenv "VIRTUAL_ENV") + (python-shell-calculate-process-environment)))) + (should (not (getenv "PYTHONHOME"))) + (should (string= (getenv "VIRTUAL_ENV") "/env")))) + +(ert-deftest python-shell-calculate-process-environment-4 () + "Test PYTHONUNBUFFERED when `python-shell-unbuffered' is non-nil." + (let* ((python-shell-unbuffered t) + (process-environment + (let ((process-environment process-environment)) + (setenv "PYTHONUNBUFFERED") + (python-shell-calculate-process-environment)))) + (should (string= (getenv "PYTHONUNBUFFERED") "1")))) + +(ert-deftest python-shell-calculate-process-environment-5 () + "Test PYTHONUNBUFFERED when `python-shell-unbuffered' is nil." + (let* ((python-shell-unbuffered nil) + (process-environment + (let ((process-environment process-environment)) + (setenv "PYTHONUNBUFFERED") + (python-shell-calculate-process-environment)))) + (should (not (getenv "PYTHONUNBUFFERED"))))) + +(ert-deftest python-shell-calculate-process-environment-6 () + "Test PYTHONUNBUFFERED=1 when `python-shell-unbuffered' is nil." + (let* ((python-shell-unbuffered nil) + (process-environment + (let ((process-environment process-environment)) + (setenv "PYTHONUNBUFFERED" "1") + (python-shell-calculate-process-environment)))) + ;; User default settings must remain untouched: + (should (string= (getenv "PYTHONUNBUFFERED") "1")))) + +(ert-deftest python-shell-calculate-process-environment-7 () + "Test no side-effects on `process-environment'." + (let* ((python-shell-process-environment + '("TESTVAR1=value1" "TESTVAR2=value2")) + (python-shell-virtualenv-root "/env") + (python-shell-unbuffered t) + (python-shell-extra-pythonpaths'("/path1" "/path2")) + (original-process-environment (copy-sequence process-environment))) + (python-shell-calculate-process-environment) + (should (equal process-environment original-process-environment)))) + +(ert-deftest python-shell-calculate-process-environment-8 () + "Test no side-effects on `tramp-remote-process-environment'." + (let* ((default-directory "/ssh::/example/dir/") + (python-shell-process-environment + '("TESTVAR1=value1" "TESTVAR2=value2")) + (python-shell-virtualenv-root "/env") + (python-shell-unbuffered t) + (python-shell-extra-pythonpaths'("/path1" "/path2")) + (original-process-environment + (copy-sequence tramp-remote-process-environment))) + (python-shell-calculate-process-environment) + (should (equal tramp-remote-process-environment original-process-environment)))) + +(ert-deftest python-shell-calculate-exec-path-1 () + "Test `python-shell-exec-path' modification." + (let* ((exec-path '("/path0")) + (python-shell-exec-path '("/path1" "/path2")) + (new-exec-path (python-shell-calculate-exec-path))) + (should (equal new-exec-path '("/path1" "/path2" "/path0"))))) + +(ert-deftest python-shell-calculate-exec-path-2 () + "Test `python-shell-virtualenv-root' modification." + (let* ((exec-path '("/path0")) + (python-shell-virtualenv-root "/env") + (new-exec-path (python-shell-calculate-exec-path))) + (should (equal new-exec-path + (list (expand-file-name "/env/bin") "/path0"))))) + +(ert-deftest python-shell-calculate-exec-path-3 () + "Test complete `python-shell-virtualenv-root' modification." + (let* ((exec-path '("/path0")) + (python-shell-exec-path '("/path1" "/path2")) + (python-shell-virtualenv-root "/env") + (new-exec-path (python-shell-calculate-exec-path))) + (should (equal new-exec-path + (list (expand-file-name "/env/bin") + "/path1" "/path2" "/path0"))))) + +(ert-deftest python-shell-calculate-exec-path-4 () + "Test complete `python-shell-virtualenv-root' with remote." + (let* ((default-directory "/ssh::/example/dir/") + (python-shell-remote-exec-path '("/path0")) + (python-shell-exec-path '("/path1" "/path2")) + (python-shell-virtualenv-root "/env") + (new-exec-path (python-shell-calculate-exec-path))) + (should (equal new-exec-path + (list (expand-file-name "/env/bin") + "/path1" "/path2" "/path0"))))) + +(ert-deftest python-shell-calculate-exec-path-5 () + "Test no side-effects on `exec-path'." + (let* ((exec-path '("/path0")) + (python-shell-exec-path '("/path1" "/path2")) + (python-shell-virtualenv-root "/env") + (original-exec-path (copy-sequence exec-path))) + (python-shell-calculate-exec-path) + (should (equal exec-path original-exec-path)))) + +(ert-deftest python-shell-calculate-exec-path-6 () + "Test no side-effects on `python-shell-remote-exec-path'." + (let* ((default-directory "/ssh::/example/dir/") + (python-shell-remote-exec-path '("/path0")) + (python-shell-exec-path '("/path1" "/path2")) + (python-shell-virtualenv-root "/env") + (original-exec-path (copy-sequence python-shell-remote-exec-path))) + (python-shell-calculate-exec-path) + (should (equal python-shell-remote-exec-path original-exec-path)))) + +(ert-deftest python-shell-with-environment-1 () + "Test environment with local `default-directory'." + (let* ((exec-path '("/path0")) + (python-shell-exec-path '("/path1" "/path2")) + (original-exec-path exec-path) + (python-shell-virtualenv-root "/env")) + (python-shell-with-environment + (should (equal exec-path + (list (expand-file-name "/env/bin") + "/path1" "/path2" "/path0"))) + (should (not (getenv "PYTHONHOME"))) + (should (string= (getenv "VIRTUAL_ENV") "/env"))) + (should (equal exec-path original-exec-path)))) + +(ert-deftest python-shell-with-environment-2 () + "Test environment with remote `default-directory'." + (let* ((default-directory "/ssh::/example/dir/") + (python-shell-remote-exec-path '("/remote1" "/remote2")) + (python-shell-exec-path '("/path1" "/path2")) + (tramp-remote-process-environment '("EMACS=t")) + (original-process-environment (copy-sequence tramp-remote-process-environment)) + (python-shell-virtualenv-root "/env")) + (python-shell-with-environment + (should (equal (python-shell-calculate-exec-path) + (list (expand-file-name "/env/bin") + "/path1" "/path2" "/remote1" "/remote2"))) + (let ((process-environment (python-shell-calculate-process-environment))) + (should (not (getenv "PYTHONHOME"))) + (should (string= (getenv "VIRTUAL_ENV") "/env")) + (should (equal tramp-remote-process-environment process-environment)))) + (should (equal tramp-remote-process-environment original-process-environment)))) + +(ert-deftest python-shell-with-environment-3 () + "Test `python-shell-with-environment' is idempotent." + (let* ((python-shell-extra-pythonpaths '("/example/dir/")) + (python-shell-exec-path '("path1" "path2")) + (python-shell-virtualenv-root "/home/user/env") + (single-call + (python-shell-with-environment + (list exec-path process-environment))) + (nested-call + (python-shell-with-environment + (python-shell-with-environment + (list exec-path process-environment))))) + (should (equal single-call nested-call)))) + +(ert-deftest python-shell-make-comint-1 () + "Check comint creation for global shell buffer." + (skip-unless (executable-find python-tests-shell-interpreter)) + ;; The interpreter can get killed too quickly to allow it to clean + ;; up the tempfiles that the default python-shell-setup-codes create, + ;; so it leaves tempfiles behind, which is a minor irritation. + (let* ((python-shell-setup-codes nil) + (python-shell-interpreter + (executable-find python-tests-shell-interpreter)) + (proc-name (python-shell-get-process-name nil)) + (shell-buffer + (python-tests-with-temp-buffer + "" (python-shell-make-comint + (python-shell-calculate-command) proc-name))) + (process (get-buffer-process shell-buffer))) + (unwind-protect + (progn + (set-process-query-on-exit-flag process nil) + (should (process-live-p process)) + (with-current-buffer shell-buffer + (should (eq major-mode 'inferior-python-mode)) + (should (string= (buffer-name) (format "*%s*" proc-name))))) + (kill-buffer shell-buffer)))) + +(ert-deftest python-shell-make-comint-2 () + "Check comint creation for internal shell buffer." + (skip-unless (executable-find python-tests-shell-interpreter)) + (let* ((python-shell-setup-codes nil) + (python-shell-interpreter + (executable-find python-tests-shell-interpreter)) + (proc-name (python-shell-internal-get-process-name)) + (shell-buffer + (python-tests-with-temp-buffer + "" (python-shell-make-comint + (python-shell-calculate-command) proc-name nil t))) + (process (get-buffer-process shell-buffer))) + (unwind-protect + (progn + (set-process-query-on-exit-flag process nil) + (should (process-live-p process)) + (with-current-buffer shell-buffer + (should (eq major-mode 'inferior-python-mode)) + (should (string= (buffer-name) (format " *%s*" proc-name))))) + (kill-buffer shell-buffer)))) + +(ert-deftest python-shell-make-comint-3 () + "Check comint creation with overridden python interpreter and args. +The command passed to `python-shell-make-comint' as argument must +locally override global values set in `python-shell-interpreter' +and `python-shell-interpreter-args' in the new shell buffer." + (skip-unless (executable-find python-tests-shell-interpreter)) + (let* ((python-shell-setup-codes nil) + (python-shell-interpreter "interpreter") + (python-shell-interpreter-args "--some-args") + (proc-name (python-shell-get-process-name nil)) + (interpreter-override + (concat (executable-find python-tests-shell-interpreter) " " "-i")) + (shell-buffer + (python-tests-with-temp-buffer + "" (python-shell-make-comint interpreter-override proc-name nil))) + (process (get-buffer-process shell-buffer))) + (unwind-protect + (progn + (set-process-query-on-exit-flag process nil) + (should (process-live-p process)) + (with-current-buffer shell-buffer + (should (eq major-mode 'inferior-python-mode)) + (should (file-equal-p + python-shell-interpreter + (executable-find python-tests-shell-interpreter))) + (should (string= python-shell-interpreter-args "-i")))) + (kill-buffer shell-buffer)))) + +(ert-deftest python-shell-make-comint-4 () + "Check shell calculated prompts regexps are set." + (skip-unless (executable-find python-tests-shell-interpreter)) + (let* ((process-environment process-environment) + (python-shell-setup-codes nil) + (python-shell-interpreter + (executable-find python-tests-shell-interpreter)) + (python-shell-interpreter-args "-i") + (python-shell--prompt-calculated-input-regexp nil) + (python-shell--prompt-calculated-output-regexp nil) + (python-shell-prompt-detect-enabled t) + (python-shell-prompt-input-regexps '("extralargeinputprompt" "sml")) + (python-shell-prompt-output-regexps '("extralargeoutputprompt" "sml")) + (python-shell-prompt-regexp "in") + (python-shell-prompt-block-regexp "block") + (python-shell-prompt-pdb-regexp "pdf") + (python-shell-prompt-output-regexp "output") + (startup-code (concat "import sys\n" + "sys.ps1 = 'py> '\n" + "sys.ps2 = '..> '\n" + "sys.ps3 = 'out '\n")) + (startup-file (python-shell--save-temp-file startup-code)) + (proc-name (python-shell-get-process-name nil)) + (shell-buffer + (progn + (setenv "PYTHONSTARTUP" startup-file) + (python-tests-with-temp-buffer + "" (python-shell-make-comint + (python-shell-calculate-command) proc-name nil)))) + (process (get-buffer-process shell-buffer))) + (unwind-protect + (progn + (set-process-query-on-exit-flag process nil) + (should (process-live-p process)) + (with-current-buffer shell-buffer + (should (eq major-mode 'inferior-python-mode)) + (should (string= + python-shell--prompt-calculated-input-regexp + (concat "^\\(extralargeinputprompt\\|\\.\\.> \\|" + "block\\|py> \\|pdf\\|sml\\|in\\)"))) + (should (string= + python-shell--prompt-calculated-output-regexp + "^\\(extralargeoutputprompt\\|output\\|out \\|sml\\)")))) + (delete-file startup-file) + (kill-buffer shell-buffer)))) + +(ert-deftest python-shell-get-process-1 () + "Check dedicated shell process preference over global." + (skip-unless (executable-find python-tests-shell-interpreter)) + (python-tests-with-temp-file + "" + (let* ((python-shell-setup-codes nil) + (python-shell-interpreter + (executable-find python-tests-shell-interpreter)) + (global-proc-name (python-shell-get-process-name nil)) + (dedicated-proc-name (python-shell-get-process-name t)) + (global-shell-buffer + (python-shell-make-comint + (python-shell-calculate-command) global-proc-name)) + (dedicated-shell-buffer + (python-shell-make-comint + (python-shell-calculate-command) dedicated-proc-name)) + (global-process (get-buffer-process global-shell-buffer)) + (dedicated-process (get-buffer-process dedicated-shell-buffer))) + (unwind-protect + (progn + (set-process-query-on-exit-flag global-process nil) + (set-process-query-on-exit-flag dedicated-process nil) + ;; Prefer dedicated if global also exists. + (should (equal (python-shell-get-process) dedicated-process)) + (kill-buffer dedicated-shell-buffer) + ;; If there's only global, use it. + (should (equal (python-shell-get-process) global-process)) + (kill-buffer global-shell-buffer) + ;; No buffer available. + (should (not (python-shell-get-process)))) + (ignore-errors (kill-buffer global-shell-buffer)) + (ignore-errors (kill-buffer dedicated-shell-buffer)))))) + +(ert-deftest python-shell-internal-get-or-create-process-1 () + "Check internal shell process creation fallback." + (skip-unless (executable-find python-tests-shell-interpreter)) + (python-tests-with-temp-file + "" + (should (not (process-live-p (python-shell-internal-get-process-name)))) + (let* ((python-shell-interpreter + (executable-find python-tests-shell-interpreter)) + (internal-process-name (python-shell-internal-get-process-name)) + (internal-process (python-shell-internal-get-or-create-process)) + (internal-shell-buffer (process-buffer internal-process))) + (unwind-protect + (progn + (set-process-query-on-exit-flag internal-process nil) + (should (equal (process-name internal-process) + internal-process-name)) + (should (equal internal-process + (python-shell-internal-get-or-create-process))) + ;; Assert the internal process is not a user process + (should (not (python-shell-get-process))) + (kill-buffer internal-shell-buffer)) + (ignore-errors (kill-buffer internal-shell-buffer)))))) + +(ert-deftest python-shell-prompt-detect-1 () + "Check prompt autodetection." + (skip-unless (executable-find python-tests-shell-interpreter)) + (let ((process-environment process-environment)) + ;; Ensure no startup file is enabled + (setenv "PYTHONSTARTUP" "") + (should python-shell-prompt-detect-enabled) + (should (equal (python-shell-prompt-detect) '(">>> " "... " ""))))) + +(ert-deftest python-shell-prompt-detect-2 () + "Check prompt autodetection with startup file. Bug#17370." + (skip-unless (executable-find python-tests-shell-interpreter)) + (let* ((process-environment process-environment) + (startup-code (concat "import sys\n" + "sys.ps1 = 'py> '\n" + "sys.ps2 = '..> '\n" + "sys.ps3 = 'out '\n")) + (startup-file (python-shell--save-temp-file startup-code))) + (unwind-protect + (progn + ;; Ensure startup file is enabled + (setenv "PYTHONSTARTUP" startup-file) + (should python-shell-prompt-detect-enabled) + (should (equal (python-shell-prompt-detect) '("py> " "..> " "out ")))) + (ignore-errors (delete-file startup-file))))) + +(ert-deftest python-shell-prompt-detect-3 () + "Check prompts are not autodetected when feature is disabled." + (skip-unless (executable-find python-tests-shell-interpreter)) + (let ((process-environment process-environment) + (python-shell-prompt-detect-enabled nil)) + ;; Ensure no startup file is enabled + (should (not python-shell-prompt-detect-enabled)) + (should (not (python-shell-prompt-detect))))) + +(ert-deftest python-shell-prompt-detect-4 () + "Check warning is shown when detection fails." + (skip-unless (executable-find python-tests-shell-interpreter)) + (let* ((process-environment process-environment) + ;; Trigger failure by removing prompts in the startup file + (startup-code (concat "import sys\n" + "sys.ps1 = ''\n" + "sys.ps2 = ''\n" + "sys.ps3 = ''\n")) + (startup-file (python-shell--save-temp-file startup-code))) + (unwind-protect + (progn + (kill-buffer (get-buffer-create "*Warnings*")) + (should (not (get-buffer "*Warnings*"))) + (setenv "PYTHONSTARTUP" startup-file) + (should python-shell-prompt-detect-failure-warning) + (should python-shell-prompt-detect-enabled) + (should (not (python-shell-prompt-detect))) + (should (get-buffer "*Warnings*"))) + (ignore-errors (delete-file startup-file))))) + +(ert-deftest python-shell-prompt-detect-5 () + "Check disabled warnings are not shown when detection fails." + (skip-unless (executable-find python-tests-shell-interpreter)) + (let* ((process-environment process-environment) + (startup-code (concat "import sys\n" + "sys.ps1 = ''\n" + "sys.ps2 = ''\n" + "sys.ps3 = ''\n")) + (startup-file (python-shell--save-temp-file startup-code)) + (python-shell-prompt-detect-failure-warning nil)) + (unwind-protect + (progn + (kill-buffer (get-buffer-create "*Warnings*")) + (should (not (get-buffer "*Warnings*"))) + (setenv "PYTHONSTARTUP" startup-file) + (should (not python-shell-prompt-detect-failure-warning)) + (should python-shell-prompt-detect-enabled) + (should (not (python-shell-prompt-detect))) + (should (not (get-buffer "*Warnings*")))) + (ignore-errors (delete-file startup-file))))) + +(ert-deftest python-shell-prompt-detect-6 () + "Warnings are not shown when detection is disabled." + (skip-unless (executable-find python-tests-shell-interpreter)) + (let* ((process-environment process-environment) + (startup-code (concat "import sys\n" + "sys.ps1 = ''\n" + "sys.ps2 = ''\n" + "sys.ps3 = ''\n")) + (startup-file (python-shell--save-temp-file startup-code)) + (python-shell-prompt-detect-failure-warning t) + (python-shell-prompt-detect-enabled nil)) + (unwind-protect + (progn + (kill-buffer (get-buffer-create "*Warnings*")) + (should (not (get-buffer "*Warnings*"))) + (setenv "PYTHONSTARTUP" startup-file) + (should python-shell-prompt-detect-failure-warning) + (should (not python-shell-prompt-detect-enabled)) + (should (not (python-shell-prompt-detect))) + (should (not (get-buffer "*Warnings*")))) + (ignore-errors (delete-file startup-file))))) + +(ert-deftest python-shell-prompt-validate-regexps-1 () + "Check `python-shell-prompt-input-regexps' are validated." + (let* ((python-shell-prompt-input-regexps '("\\(")) + (error-data (should-error (python-shell-prompt-validate-regexps) + :type 'user-error))) + (should + (string= (cadr error-data) + (format-message + "Invalid regexp \\( in `python-shell-prompt-input-regexps'"))))) + +(ert-deftest python-shell-prompt-validate-regexps-2 () + "Check `python-shell-prompt-output-regexps' are validated." + (let* ((python-shell-prompt-output-regexps '("\\(")) + (error-data (should-error (python-shell-prompt-validate-regexps) + :type 'user-error))) + (should + (string= (cadr error-data) + (format-message + "Invalid regexp \\( in `python-shell-prompt-output-regexps'"))))) + +(ert-deftest python-shell-prompt-validate-regexps-3 () + "Check `python-shell-prompt-regexp' is validated." + (let* ((python-shell-prompt-regexp "\\(") + (error-data (should-error (python-shell-prompt-validate-regexps) + :type 'user-error))) + (should + (string= (cadr error-data) + (format-message + "Invalid regexp \\( in `python-shell-prompt-regexp'"))))) + +(ert-deftest python-shell-prompt-validate-regexps-4 () + "Check `python-shell-prompt-block-regexp' is validated." + (let* ((python-shell-prompt-block-regexp "\\(") + (error-data (should-error (python-shell-prompt-validate-regexps) + :type 'user-error))) + (should + (string= (cadr error-data) + (format-message + "Invalid regexp \\( in `python-shell-prompt-block-regexp'"))))) + +(ert-deftest python-shell-prompt-validate-regexps-5 () + "Check `python-shell-prompt-pdb-regexp' is validated." + (let* ((python-shell-prompt-pdb-regexp "\\(") + (error-data (should-error (python-shell-prompt-validate-regexps) + :type 'user-error))) + (should + (string= (cadr error-data) + (format-message + "Invalid regexp \\( in `python-shell-prompt-pdb-regexp'"))))) + +(ert-deftest python-shell-prompt-validate-regexps-6 () + "Check `python-shell-prompt-output-regexp' is validated." + (let* ((python-shell-prompt-output-regexp "\\(") + (error-data (should-error (python-shell-prompt-validate-regexps) + :type 'user-error))) + (should + (string= (cadr error-data) + (format-message + "Invalid regexp \\( in `python-shell-prompt-output-regexp'"))))) + +(ert-deftest python-shell-prompt-validate-regexps-7 () + "Check default regexps are valid." + ;; should not signal error + (python-shell-prompt-validate-regexps)) + +(ert-deftest python-shell-prompt-set-calculated-regexps-1 () + "Check regexps are validated." + (let* ((python-shell-prompt-output-regexp '("\\(")) + (python-shell--prompt-calculated-input-regexp nil) + (python-shell--prompt-calculated-output-regexp nil) + (python-shell-prompt-detect-enabled nil) + (error-data (should-error (python-shell-prompt-set-calculated-regexps) + :type 'user-error))) + (should + (string= (cadr error-data) + (format-message + "Invalid regexp \\( in `python-shell-prompt-output-regexp'"))))) + +(ert-deftest python-shell-prompt-set-calculated-regexps-2 () + "Check `python-shell-prompt-input-regexps' are set." + (let* ((python-shell-prompt-input-regexps '("my" "prompt")) + (python-shell-prompt-output-regexps '("")) + (python-shell-prompt-regexp "") + (python-shell-prompt-block-regexp "") + (python-shell-prompt-pdb-regexp "") + (python-shell-prompt-output-regexp "") + (python-shell--prompt-calculated-input-regexp nil) + (python-shell--prompt-calculated-output-regexp nil) + (python-shell-prompt-detect-enabled nil)) + (python-shell-prompt-set-calculated-regexps) + (should (string= python-shell--prompt-calculated-input-regexp + "^\\(prompt\\|my\\|\\)")))) + +(ert-deftest python-shell-prompt-set-calculated-regexps-3 () + "Check `python-shell-prompt-output-regexps' are set." + (let* ((python-shell-prompt-input-regexps '("")) + (python-shell-prompt-output-regexps '("my" "prompt")) + (python-shell-prompt-regexp "") + (python-shell-prompt-block-regexp "") + (python-shell-prompt-pdb-regexp "") + (python-shell-prompt-output-regexp "") + (python-shell--prompt-calculated-input-regexp nil) + (python-shell--prompt-calculated-output-regexp nil) + (python-shell-prompt-detect-enabled nil)) + (python-shell-prompt-set-calculated-regexps) + (should (string= python-shell--prompt-calculated-output-regexp + "^\\(prompt\\|my\\|\\)")))) + +(ert-deftest python-shell-prompt-set-calculated-regexps-4 () + "Check user defined prompts are set." + (let* ((python-shell-prompt-input-regexps '("")) + (python-shell-prompt-output-regexps '("")) + (python-shell-prompt-regexp "prompt") + (python-shell-prompt-block-regexp "block") + (python-shell-prompt-pdb-regexp "pdb") + (python-shell-prompt-output-regexp "output") + (python-shell--prompt-calculated-input-regexp nil) + (python-shell--prompt-calculated-output-regexp nil) + (python-shell-prompt-detect-enabled nil)) + (python-shell-prompt-set-calculated-regexps) + (should (string= python-shell--prompt-calculated-input-regexp + "^\\(prompt\\|block\\|pdb\\|\\)")) + (should (string= python-shell--prompt-calculated-output-regexp + "^\\(output\\|\\)")))) + +(ert-deftest python-shell-prompt-set-calculated-regexps-5 () + "Check order of regexps (larger first)." + (let* ((python-shell-prompt-input-regexps '("extralargeinputprompt" "sml")) + (python-shell-prompt-output-regexps '("extralargeoutputprompt" "sml")) + (python-shell-prompt-regexp "in") + (python-shell-prompt-block-regexp "block") + (python-shell-prompt-pdb-regexp "pdf") + (python-shell-prompt-output-regexp "output") + (python-shell--prompt-calculated-input-regexp nil) + (python-shell--prompt-calculated-output-regexp nil) + (python-shell-prompt-detect-enabled nil)) + (python-shell-prompt-set-calculated-regexps) + (should (string= python-shell--prompt-calculated-input-regexp + "^\\(extralargeinputprompt\\|block\\|pdf\\|sml\\|in\\)")) + (should (string= python-shell--prompt-calculated-output-regexp + "^\\(extralargeoutputprompt\\|output\\|sml\\)")))) + +(ert-deftest python-shell-prompt-set-calculated-regexps-6 () + "Check detected prompts are included `regexp-quote'd." + (skip-unless (executable-find python-tests-shell-interpreter)) + (let* ((python-shell-prompt-input-regexps '("")) + (python-shell-prompt-output-regexps '("")) + (python-shell-prompt-regexp "") + (python-shell-prompt-block-regexp "") + (python-shell-prompt-pdb-regexp "") + (python-shell-prompt-output-regexp "") + (python-shell--prompt-calculated-input-regexp nil) + (python-shell--prompt-calculated-output-regexp nil) + (python-shell-prompt-detect-enabled t) + (process-environment process-environment) + (startup-code (concat "import sys\n" + "sys.ps1 = 'p.> '\n" + "sys.ps2 = '..> '\n" + "sys.ps3 = 'o.t '\n")) + (startup-file (python-shell--save-temp-file startup-code))) + (unwind-protect + (progn + (setenv "PYTHONSTARTUP" startup-file) + (python-shell-prompt-set-calculated-regexps) + (should (string= python-shell--prompt-calculated-input-regexp + "^\\(\\.\\.> \\|p\\.> \\|\\)")) + (should (string= python-shell--prompt-calculated-output-regexp + "^\\(o\\.t \\|\\)"))) + (ignore-errors (delete-file startup-file))))) + +(ert-deftest python-shell-buffer-substring-1 () + "Selecting a substring of the whole buffer must match its contents." + (python-tests-with-temp-buffer + " +class Foo(models.Model): + pass + + +class Bar(models.Model): + pass +" + (should (string= (buffer-string) + (python-shell-buffer-substring (point-min) (point-max)))))) + +(ert-deftest python-shell-buffer-substring-2 () + "Main block should be removed if NOMAIN is non-nil." + (python-tests-with-temp-buffer + " +class Foo(models.Model): + pass + +class Bar(models.Model): + pass + +if __name__ == \"__main__\": + foo = Foo() + print (foo) +" + (should (string= (python-shell-buffer-substring (point-min) (point-max) t) + " +class Foo(models.Model): + pass + +class Bar(models.Model): + pass + + + + +")))) + +(ert-deftest python-shell-buffer-substring-3 () + "Main block should be removed if NOMAIN is non-nil." + (python-tests-with-temp-buffer + " +class Foo(models.Model): + pass + +if __name__ == \"__main__\": + foo = Foo() + print (foo) + +class Bar(models.Model): + pass +" + (should (string= (python-shell-buffer-substring (point-min) (point-max) t) + " +class Foo(models.Model): + pass + + + + + +class Bar(models.Model): + pass +")))) + +(ert-deftest python-shell-buffer-substring-4 () + "Coding cookie should be added for substrings." + (python-tests-with-temp-buffer + "# coding: latin-1 + +class Foo(models.Model): + pass + +if __name__ == \"__main__\": + foo = Foo() + print (foo) + +class Bar(models.Model): + pass +" + (should (string= (python-shell-buffer-substring + (python-tests-look-at "class Foo(models.Model):") + (progn (python-nav-forward-sexp) (point))) + "# -*- coding: latin-1 -*- + +class Foo(models.Model): + pass")))) + +(ert-deftest python-shell-buffer-substring-5 () + "The proper amount of blank lines is added for a substring." + (python-tests-with-temp-buffer + "# coding: latin-1 + +class Foo(models.Model): + pass + +if __name__ == \"__main__\": + foo = Foo() + print (foo) + +class Bar(models.Model): + pass +" + (should (string= (python-shell-buffer-substring + (python-tests-look-at "class Bar(models.Model):") + (progn (python-nav-forward-sexp) (point))) + "# -*- coding: latin-1 -*- + + + + + + + + +class Bar(models.Model): + pass")))) + +(ert-deftest python-shell-buffer-substring-6 () + "Handle substring with coding cookie in the second line." + (python-tests-with-temp-buffer + " +# coding: latin-1 + +class Foo(models.Model): + pass + +if __name__ == \"__main__\": + foo = Foo() + print (foo) + +class Bar(models.Model): + pass +" + (should (string= (python-shell-buffer-substring + (python-tests-look-at "# coding: latin-1") + (python-tests-look-at "if __name__ == \"__main__\":")) + "# -*- coding: latin-1 -*- + + +class Foo(models.Model): + pass + +")))) + +(ert-deftest python-shell-buffer-substring-7 () + "Ensure first coding cookie gets precedence." + (python-tests-with-temp-buffer + "# coding: utf-8 +# coding: latin-1 + +class Foo(models.Model): + pass + +if __name__ == \"__main__\": + foo = Foo() + print (foo) + +class Bar(models.Model): + pass +" + (should (string= (python-shell-buffer-substring + (python-tests-look-at "# coding: latin-1") + (python-tests-look-at "if __name__ == \"__main__\":")) + "# -*- coding: utf-8 -*- + + +class Foo(models.Model): + pass + +")))) + +(ert-deftest python-shell-buffer-substring-8 () + "Ensure first coding cookie gets precedence when sending whole buffer." + (python-tests-with-temp-buffer + "# coding: utf-8 +# coding: latin-1 + +class Foo(models.Model): + pass +" + (should (string= (python-shell-buffer-substring (point-min) (point-max)) + "# coding: utf-8 + + +class Foo(models.Model): + pass +")))) + +(ert-deftest python-shell-buffer-substring-9 () + "Check substring starting from `point-min'." + (python-tests-with-temp-buffer + "# coding: utf-8 + +class Foo(models.Model): + pass + +class Bar(models.Model): + pass +" + (should (string= (python-shell-buffer-substring + (point-min) + (python-tests-look-at "class Bar(models.Model):")) + "# coding: utf-8 + +class Foo(models.Model): + pass + +")))) + +(ert-deftest python-shell-buffer-substring-10 () + "Check substring from partial block." + (python-tests-with-temp-buffer + " +def foo(): + print ('a') +" + (should (string= (python-shell-buffer-substring + (python-tests-look-at "print ('a')") + (point-max)) + "if True: + + print ('a') +")))) + +(ert-deftest python-shell-buffer-substring-11 () + "Check substring from partial block and point within indentation." + (python-tests-with-temp-buffer + " +def foo(): + print ('a') +" + (should (string= (python-shell-buffer-substring + (progn + (python-tests-look-at "print ('a')") + (backward-char 1) + (point)) + (point-max)) + "if True: + + print ('a') +")))) + +(ert-deftest python-shell-buffer-substring-12 () + "Check substring from partial block and point in whitespace." + (python-tests-with-temp-buffer + " +def foo(): + + # Whitespace + + print ('a') +" + (should (string= (python-shell-buffer-substring + (python-tests-look-at "# Whitespace") + (point-max)) + "if True: + + + # Whitespace + + print ('a') +")))) + + + +;;; Shell completion + +(ert-deftest python-shell-completion-native-interpreter-disabled-p-1 () + (let* ((python-shell-completion-native-disabled-interpreters (list "pypy")) + (python-shell-interpreter "/some/path/to/bin/pypy")) + (should (python-shell-completion-native-interpreter-disabled-p)))) + + + + +;;; PDB Track integration + + +;;; Symbol completion + + +;;; Fill paragraph + + +;;; Skeletons + + +;;; FFAP + + +;;; Code check + + +;;; Eldoc + +(ert-deftest python-eldoc--get-symbol-at-point-1 () + "Test paren handling." + (python-tests-with-temp-buffer + " +map(xx +map(codecs.open('somefile' +" + (python-tests-look-at "ap(xx") + (should (string= (python-eldoc--get-symbol-at-point) "map")) + (goto-char (line-end-position)) + (should (string= (python-eldoc--get-symbol-at-point) "map")) + (python-tests-look-at "('somefile'") + (should (string= (python-eldoc--get-symbol-at-point) "map")) + (goto-char (line-end-position)) + (should (string= (python-eldoc--get-symbol-at-point) "codecs.open")))) + +(ert-deftest python-eldoc--get-symbol-at-point-2 () + "Ensure self is replaced with the class name." + (python-tests-with-temp-buffer + " +class TheClass: + + def some_method(self, n): + return n + + def other(self): + return self.some_method(1234) + +" + (python-tests-look-at "self.some_method") + (should (string= (python-eldoc--get-symbol-at-point) + "TheClass.some_method")) + (python-tests-look-at "1234)") + (should (string= (python-eldoc--get-symbol-at-point) + "TheClass.some_method")))) + +(ert-deftest python-eldoc--get-symbol-at-point-3 () + "Ensure symbol is found when point is at end of buffer." + (python-tests-with-temp-buffer + " +some_symbol + +" + (goto-char (point-max)) + (should (string= (python-eldoc--get-symbol-at-point) + "some_symbol")))) + +(ert-deftest python-eldoc--get-symbol-at-point-4 () + "Ensure symbol is found when point is at whitespace." + (python-tests-with-temp-buffer + " +some_symbol some_other_symbol +" + (python-tests-look-at " some_other_symbol") + (should (string= (python-eldoc--get-symbol-at-point) + "some_symbol")))) + + +;;; Imenu + +(ert-deftest python-imenu-create-index-1 () + (python-tests-with-temp-buffer + " +class Foo(models.Model): + pass + + +class Bar(models.Model): + pass + + +def decorator(arg1, arg2, arg3): + '''print decorated function call data to stdout. + + Usage: + + @decorator('arg1', 'arg2') + def func(a, b, c=True): + pass + ''' + + def wrap(f): + print ('wrap') + def wrapped_f(*args): + print ('wrapped_f') + print ('Decorator arguments:', arg1, arg2, arg3) + f(*args) + print ('called f(*args)') + return wrapped_f + return wrap + + +class Baz(object): + + def a(self): + pass + + def b(self): + pass + + class Frob(object): + + def c(self): + pass +" + (goto-char (point-max)) + (should (equal + (list + (cons "Foo (class)" (copy-marker 2)) + (cons "Bar (class)" (copy-marker 38)) + (list + "decorator (def)" + (cons "*function definition*" (copy-marker 74)) + (list + "wrap (def)" + (cons "*function definition*" (copy-marker 254)) + (cons "wrapped_f (def)" (copy-marker 294)))) + (list + "Baz (class)" + (cons "*class definition*" (copy-marker 519)) + (cons "a (def)" (copy-marker 539)) + (cons "b (def)" (copy-marker 570)) + (list + "Frob (class)" + (cons "*class definition*" (copy-marker 601)) + (cons "c (def)" (copy-marker 626))))) + (python-imenu-create-index))))) + +(ert-deftest python-imenu-create-index-2 () + (python-tests-with-temp-buffer + " +class Foo(object): + def foo(self): + def foo1(): + pass + + def foobar(self): + pass +" + (goto-char (point-max)) + (should (equal + (list + (list + "Foo (class)" + (cons "*class definition*" (copy-marker 2)) + (list + "foo (def)" + (cons "*function definition*" (copy-marker 21)) + (cons "foo1 (def)" (copy-marker 40))) + (cons "foobar (def)" (copy-marker 78)))) + (python-imenu-create-index))))) + +(ert-deftest python-imenu-create-index-3 () + (python-tests-with-temp-buffer + " +class Foo(object): + def foo(self): + def foo1(): + pass + def foo2(): + pass +" + (goto-char (point-max)) + (should (equal + (list + (list + "Foo (class)" + (cons "*class definition*" (copy-marker 2)) + (list + "foo (def)" + (cons "*function definition*" (copy-marker 21)) + (cons "foo1 (def)" (copy-marker 40)) + (cons "foo2 (def)" (copy-marker 77))))) + (python-imenu-create-index))))) + +(ert-deftest python-imenu-create-index-4 () + (python-tests-with-temp-buffer + " +class Foo(object): + class Bar(object): + def __init__(self): + pass + + def __str__(self): + pass + + def __init__(self): + pass +" + (goto-char (point-max)) + (should (equal + (list + (list + "Foo (class)" + (cons "*class definition*" (copy-marker 2)) + (list + "Bar (class)" + (cons "*class definition*" (copy-marker 21)) + (cons "__init__ (def)" (copy-marker 44)) + (cons "__str__ (def)" (copy-marker 90))) + (cons "__init__ (def)" (copy-marker 135)))) + (python-imenu-create-index))))) + +(ert-deftest python-imenu-create-flat-index-1 () + (python-tests-with-temp-buffer + " +class Foo(models.Model): + pass + + +class Bar(models.Model): + pass + + +def decorator(arg1, arg2, arg3): + '''print decorated function call data to stdout. + + Usage: + + @decorator('arg1', 'arg2') + def func(a, b, c=True): + pass + ''' + + def wrap(f): + print ('wrap') + def wrapped_f(*args): + print ('wrapped_f') + print ('Decorator arguments:', arg1, arg2, arg3) + f(*args) + print ('called f(*args)') + return wrapped_f + return wrap + + +class Baz(object): + + def a(self): + pass + + def b(self): + pass + + class Frob(object): + + def c(self): + pass +" + (goto-char (point-max)) + (should (equal + (list (cons "Foo" (copy-marker 2)) + (cons "Bar" (copy-marker 38)) + (cons "decorator" (copy-marker 74)) + (cons "decorator.wrap" (copy-marker 254)) + (cons "decorator.wrap.wrapped_f" (copy-marker 294)) + (cons "Baz" (copy-marker 519)) + (cons "Baz.a" (copy-marker 539)) + (cons "Baz.b" (copy-marker 570)) + (cons "Baz.Frob" (copy-marker 601)) + (cons "Baz.Frob.c" (copy-marker 626))) + (python-imenu-create-flat-index))))) + +(ert-deftest python-imenu-create-flat-index-2 () + (python-tests-with-temp-buffer + " +class Foo(object): + class Bar(object): + def __init__(self): + pass + + def __str__(self): + pass + + def __init__(self): + pass +" + (goto-char (point-max)) + (should (equal + (list + (cons "Foo" (copy-marker 2)) + (cons "Foo.Bar" (copy-marker 21)) + (cons "Foo.Bar.__init__" (copy-marker 44)) + (cons "Foo.Bar.__str__" (copy-marker 90)) + (cons "Foo.__init__" (copy-marker 135))) + (python-imenu-create-flat-index))))) + + +;;; Misc helpers + +(ert-deftest python-info-current-defun-1 () + (python-tests-with-temp-buffer + " +def foo(a, b): +" + (forward-line 1) + (should (string= "foo" (python-info-current-defun))) + (should (string= "def foo" (python-info-current-defun t))) + (forward-line 1) + (should (not (python-info-current-defun))) + (indent-for-tab-command) + (should (string= "foo" (python-info-current-defun))) + (should (string= "def foo" (python-info-current-defun t))))) + +(ert-deftest python-info-current-defun-2 () + (python-tests-with-temp-buffer + " +class C(object): + + def m(self): + if True: + return [i for i in range(3)] + else: + return [] + + def b(): + do_b() + + def a(): + do_a() + + def c(self): + do_c() +" + (forward-line 1) + (should (string= "C" (python-info-current-defun))) + (should (string= "class C" (python-info-current-defun t))) + (python-tests-look-at "return [i for ") + (should (string= "C.m" (python-info-current-defun))) + (should (string= "def C.m" (python-info-current-defun t))) + (python-tests-look-at "def b():") + (should (string= "C.m.b" (python-info-current-defun))) + (should (string= "def C.m.b" (python-info-current-defun t))) + (forward-line 2) + (indent-for-tab-command) + (python-indent-dedent-line-backspace 1) + (should (string= "C.m" (python-info-current-defun))) + (should (string= "def C.m" (python-info-current-defun t))) + (python-tests-look-at "def c(self):") + (forward-line -1) + (indent-for-tab-command) + (should (string= "C.m.a" (python-info-current-defun))) + (should (string= "def C.m.a" (python-info-current-defun t))) + (python-indent-dedent-line-backspace 1) + (should (string= "C.m" (python-info-current-defun))) + (should (string= "def C.m" (python-info-current-defun t))) + (python-indent-dedent-line-backspace 1) + (should (string= "C" (python-info-current-defun))) + (should (string= "class C" (python-info-current-defun t))) + (python-tests-look-at "def c(self):") + (should (string= "C.c" (python-info-current-defun))) + (should (string= "def C.c" (python-info-current-defun t))) + (python-tests-look-at "do_c()") + (should (string= "C.c" (python-info-current-defun))) + (should (string= "def C.c" (python-info-current-defun t))))) + +(ert-deftest python-info-current-defun-3 () + (python-tests-with-temp-buffer + " +def decoratorFunctionWithArguments(arg1, arg2, arg3): + '''print decorated function call data to stdout. + + Usage: + + @decoratorFunctionWithArguments('arg1', 'arg2') + def func(a, b, c=True): + pass + ''' + + def wwrap(f): + print 'Inside wwrap()' + def wrapped_f(*args): + print 'Inside wrapped_f()' + print 'Decorator arguments:', arg1, arg2, arg3 + f(*args) + print 'After f(*args)' + return wrapped_f + return wwrap +" + (python-tests-look-at "def wwrap(f):") + (forward-line -1) + (should (not (python-info-current-defun))) + (indent-for-tab-command 1) + (should (string= (python-info-current-defun) + "decoratorFunctionWithArguments")) + (should (string= (python-info-current-defun t) + "def decoratorFunctionWithArguments")) + (python-tests-look-at "def wrapped_f(*args):") + (should (string= (python-info-current-defun) + "decoratorFunctionWithArguments.wwrap.wrapped_f")) + (should (string= (python-info-current-defun t) + "def decoratorFunctionWithArguments.wwrap.wrapped_f")) + (python-tests-look-at "return wrapped_f") + (should (string= (python-info-current-defun) + "decoratorFunctionWithArguments.wwrap")) + (should (string= (python-info-current-defun t) + "def decoratorFunctionWithArguments.wwrap")) + (end-of-line 1) + (python-tests-look-at "return wwrap") + (should (string= (python-info-current-defun) + "decoratorFunctionWithArguments")) + (should (string= (python-info-current-defun t) + "def decoratorFunctionWithArguments")))) + +(ert-deftest python-info-current-symbol-1 () + (python-tests-with-temp-buffer + " +class C(object): + + def m(self): + self.c() + + def c(self): + print ('a') +" + (python-tests-look-at "self.c()") + (should (string= "self.c" (python-info-current-symbol))) + (should (string= "C.c" (python-info-current-symbol t))))) + +(ert-deftest python-info-current-symbol-2 () + (python-tests-with-temp-buffer + " +class C(object): + + class M(object): + + def a(self): + self.c() + + def c(self): + pass +" + (python-tests-look-at "self.c()") + (should (string= "self.c" (python-info-current-symbol))) + (should (string= "C.M.c" (python-info-current-symbol t))))) + +(ert-deftest python-info-current-symbol-3 () + "Keywords should not be considered symbols." + :expected-result :failed + (python-tests-with-temp-buffer + " +class C(object): + pass +" + ;; FIXME: keywords are not symbols. + (python-tests-look-at "class C") + (should (not (python-info-current-symbol))) + (should (not (python-info-current-symbol t))) + (python-tests-look-at "C(object)") + (should (string= "C" (python-info-current-symbol))) + (should (string= "class C" (python-info-current-symbol t))))) + +(ert-deftest python-info-statement-starts-block-p-1 () + (python-tests-with-temp-buffer + " +def long_function_name( + var_one, var_two, var_three, + var_four): + print (var_one) +" + (python-tests-look-at "def long_function_name") + (should (python-info-statement-starts-block-p)) + (python-tests-look-at "print (var_one)") + (python-util-forward-comment -1) + (should (python-info-statement-starts-block-p)))) + +(ert-deftest python-info-statement-starts-block-p-2 () + (python-tests-with-temp-buffer + " +if width == 0 and height == 0 and \\\\ + color == 'red' and emphasis == 'strong' or \\\\ + highlight > 100: + raise ValueError('sorry, you lose') +" + (python-tests-look-at "if width == 0 and") + (should (python-info-statement-starts-block-p)) + (python-tests-look-at "raise ValueError(") + (python-util-forward-comment -1) + (should (python-info-statement-starts-block-p)))) + +(ert-deftest python-info-statement-ends-block-p-1 () + (python-tests-with-temp-buffer + " +def long_function_name( + var_one, var_two, var_three, + var_four): + print (var_one) +" + (python-tests-look-at "print (var_one)") + (should (python-info-statement-ends-block-p)))) + +(ert-deftest python-info-statement-ends-block-p-2 () + (python-tests-with-temp-buffer + " +if width == 0 and height == 0 and \\\\ + color == 'red' and emphasis == 'strong' or \\\\ + highlight > 100: + raise ValueError( +'sorry, you lose' + +) +" + (python-tests-look-at "raise ValueError(") + (should (python-info-statement-ends-block-p)))) + +(ert-deftest python-info-beginning-of-statement-p-1 () + (python-tests-with-temp-buffer + " +def long_function_name( + var_one, var_two, var_three, + var_four): + print (var_one) +" + (python-tests-look-at "def long_function_name") + (should (python-info-beginning-of-statement-p)) + (forward-char 10) + (should (not (python-info-beginning-of-statement-p))) + (python-tests-look-at "print (var_one)") + (should (python-info-beginning-of-statement-p)) + (goto-char (line-beginning-position)) + (should (not (python-info-beginning-of-statement-p))))) + +(ert-deftest python-info-beginning-of-statement-p-2 () + (python-tests-with-temp-buffer + " +if width == 0 and height == 0 and \\\\ + color == 'red' and emphasis == 'strong' or \\\\ + highlight > 100: + raise ValueError( +'sorry, you lose' + +) +" + (python-tests-look-at "if width == 0 and") + (should (python-info-beginning-of-statement-p)) + (forward-char 10) + (should (not (python-info-beginning-of-statement-p))) + (python-tests-look-at "raise ValueError(") + (should (python-info-beginning-of-statement-p)) + (goto-char (line-beginning-position)) + (should (not (python-info-beginning-of-statement-p))))) + +(ert-deftest python-info-end-of-statement-p-1 () + (python-tests-with-temp-buffer + " +def long_function_name( + var_one, var_two, var_three, + var_four): + print (var_one) +" + (python-tests-look-at "def long_function_name") + (should (not (python-info-end-of-statement-p))) + (end-of-line) + (should (not (python-info-end-of-statement-p))) + (python-tests-look-at "print (var_one)") + (python-util-forward-comment -1) + (should (python-info-end-of-statement-p)) + (python-tests-look-at "print (var_one)") + (should (not (python-info-end-of-statement-p))) + (end-of-line) + (should (python-info-end-of-statement-p)))) + +(ert-deftest python-info-end-of-statement-p-2 () + (python-tests-with-temp-buffer + " +if width == 0 and height == 0 and \\\\ + color == 'red' and emphasis == 'strong' or \\\\ + highlight > 100: + raise ValueError( +'sorry, you lose' + +) +" + (python-tests-look-at "if width == 0 and") + (should (not (python-info-end-of-statement-p))) + (end-of-line) + (should (not (python-info-end-of-statement-p))) + (python-tests-look-at "raise ValueError(") + (python-util-forward-comment -1) + (should (python-info-end-of-statement-p)) + (python-tests-look-at "raise ValueError(") + (should (not (python-info-end-of-statement-p))) + (end-of-line) + (should (not (python-info-end-of-statement-p))) + (goto-char (point-max)) + (python-util-forward-comment -1) + (should (python-info-end-of-statement-p)))) + +(ert-deftest python-info-beginning-of-block-p-1 () + (python-tests-with-temp-buffer + " +def long_function_name( + var_one, var_two, var_three, + var_four): + print (var_one) +" + (python-tests-look-at "def long_function_name") + (should (python-info-beginning-of-block-p)) + (python-tests-look-at "var_one, var_two, var_three,") + (should (not (python-info-beginning-of-block-p))) + (python-tests-look-at "print (var_one)") + (should (not (python-info-beginning-of-block-p))))) + +(ert-deftest python-info-beginning-of-block-p-2 () + (python-tests-with-temp-buffer + " +if width == 0 and height == 0 and \\\\ + color == 'red' and emphasis == 'strong' or \\\\ + highlight > 100: + raise ValueError( +'sorry, you lose' + +) +" + (python-tests-look-at "if width == 0 and") + (should (python-info-beginning-of-block-p)) + (python-tests-look-at "color == 'red' and emphasis") + (should (not (python-info-beginning-of-block-p))) + (python-tests-look-at "raise ValueError(") + (should (not (python-info-beginning-of-block-p))))) + +(ert-deftest python-info-end-of-block-p-1 () + (python-tests-with-temp-buffer + " +def long_function_name( + var_one, var_two, var_three, + var_four): + print (var_one) +" + (python-tests-look-at "def long_function_name") + (should (not (python-info-end-of-block-p))) + (python-tests-look-at "var_one, var_two, var_three,") + (should (not (python-info-end-of-block-p))) + (python-tests-look-at "var_four):") + (end-of-line) + (should (not (python-info-end-of-block-p))) + (python-tests-look-at "print (var_one)") + (should (not (python-info-end-of-block-p))) + (end-of-line 1) + (should (python-info-end-of-block-p)))) + +(ert-deftest python-info-end-of-block-p-2 () + (python-tests-with-temp-buffer + " +if width == 0 and height == 0 and \\\\ + color == 'red' and emphasis == 'strong' or \\\\ + highlight > 100: + raise ValueError( +'sorry, you lose' + +) +" + (python-tests-look-at "if width == 0 and") + (should (not (python-info-end-of-block-p))) + (python-tests-look-at "color == 'red' and emphasis == 'strong' or") + (should (not (python-info-end-of-block-p))) + (python-tests-look-at "highlight > 100:") + (end-of-line) + (should (not (python-info-end-of-block-p))) + (python-tests-look-at "raise ValueError(") + (should (not (python-info-end-of-block-p))) + (end-of-line 1) + (should (not (python-info-end-of-block-p))) + (goto-char (point-max)) + (python-util-forward-comment -1) + (should (python-info-end-of-block-p)))) + +(ert-deftest python-info-dedenter-opening-block-position-1 () + (python-tests-with-temp-buffer + " +if request.user.is_authenticated(): + try: + profile = request.user.get_profile() + except Profile.DoesNotExist: + profile = Profile.objects.create(user=request.user) + else: + if profile.stats: + profile.recalculate_stats() + else: + profile.clear_stats() + finally: + profile.views += 1 + profile.save() +" + (python-tests-look-at "try:") + (should (not (python-info-dedenter-opening-block-position))) + (python-tests-look-at "except Profile.DoesNotExist:") + (should (= (python-tests-look-at "try:" -1 t) + (python-info-dedenter-opening-block-position))) + (python-tests-look-at "else:") + (should (= (python-tests-look-at "except Profile.DoesNotExist:" -1 t) + (python-info-dedenter-opening-block-position))) + (python-tests-look-at "if profile.stats:") + (should (not (python-info-dedenter-opening-block-position))) + (python-tests-look-at "else:") + (should (= (python-tests-look-at "if profile.stats:" -1 t) + (python-info-dedenter-opening-block-position))) + (python-tests-look-at "finally:") + (should (= (python-tests-look-at "else:" -2 t) + (python-info-dedenter-opening-block-position))))) + +(ert-deftest python-info-dedenter-opening-block-position-2 () + (python-tests-with-temp-buffer + " +if request.user.is_authenticated(): + profile = Profile.objects.get_or_create(user=request.user) + if profile.stats: + profile.recalculate_stats() + +data = { + 'else': 'do it' +} + 'else' +" + (python-tests-look-at "'else': 'do it'") + (should (not (python-info-dedenter-opening-block-position))) + (python-tests-look-at "'else'") + (should (not (python-info-dedenter-opening-block-position))))) + +(ert-deftest python-info-dedenter-opening-block-position-3 () + (python-tests-with-temp-buffer + " +if save: + try: + write_to_disk(data) + except IOError: + msg = 'Error saving to disk' + message(msg) + logger.exception(msg) + except Exception: + if hide_details: + logger.exception('Unhandled exception') + else + finally: + data.free() +" + (python-tests-look-at "try:") + (should (not (python-info-dedenter-opening-block-position))) + + (python-tests-look-at "except IOError:") + (should (= (python-tests-look-at "try:" -1 t) + (python-info-dedenter-opening-block-position))) + + (python-tests-look-at "except Exception:") + (should (= (python-tests-look-at "except IOError:" -1 t) + (python-info-dedenter-opening-block-position))) + + (python-tests-look-at "if hide_details:") + (should (not (python-info-dedenter-opening-block-position))) + + ;; check indentation modifies the detected opening block + (python-tests-look-at "else") + (should (= (python-tests-look-at "if hide_details:" -1 t) + (python-info-dedenter-opening-block-position))) + + (indent-line-to 8) + (should (= (python-tests-look-at "if hide_details:" -1 t) + (python-info-dedenter-opening-block-position))) + + (indent-line-to 4) + (should (= (python-tests-look-at "except Exception:" -1 t) + (python-info-dedenter-opening-block-position))) + + (indent-line-to 0) + (should (= (python-tests-look-at "if save:" -1 t) + (python-info-dedenter-opening-block-position))))) + +(ert-deftest python-info-dedenter-opening-block-positions-1 () + (python-tests-with-temp-buffer + " +if save: + try: + write_to_disk(data) + except IOError: + msg = 'Error saving to disk' + message(msg) + logger.exception(msg) + except Exception: + if hide_details: + logger.exception('Unhandled exception') + else + finally: + data.free() +" + (python-tests-look-at "try:") + (should (not (python-info-dedenter-opening-block-positions))) + + (python-tests-look-at "except IOError:") + (should + (equal (list + (python-tests-look-at "try:" -1 t)) + (python-info-dedenter-opening-block-positions))) + + (python-tests-look-at "except Exception:") + (should + (equal (list + (python-tests-look-at "except IOError:" -1 t)) + (python-info-dedenter-opening-block-positions))) + + (python-tests-look-at "if hide_details:") + (should (not (python-info-dedenter-opening-block-positions))) + + ;; check indentation does not modify the detected opening blocks + (python-tests-look-at "else") + (should + (equal (list + (python-tests-look-at "if hide_details:" -1 t) + (python-tests-look-at "except Exception:" -1 t) + (python-tests-look-at "if save:" -1 t)) + (python-info-dedenter-opening-block-positions))) + + (indent-line-to 8) + (should + (equal (list + (python-tests-look-at "if hide_details:" -1 t) + (python-tests-look-at "except Exception:" -1 t) + (python-tests-look-at "if save:" -1 t)) + (python-info-dedenter-opening-block-positions))) + + (indent-line-to 4) + (should + (equal (list + (python-tests-look-at "if hide_details:" -1 t) + (python-tests-look-at "except Exception:" -1 t) + (python-tests-look-at "if save:" -1 t)) + (python-info-dedenter-opening-block-positions))) + + (indent-line-to 0) + (should + (equal (list + (python-tests-look-at "if hide_details:" -1 t) + (python-tests-look-at "except Exception:" -1 t) + (python-tests-look-at "if save:" -1 t)) + (python-info-dedenter-opening-block-positions))))) + +(ert-deftest python-info-dedenter-opening-block-positions-2 () + "Test detection of opening blocks for elif." + (python-tests-with-temp-buffer + " +if var: + if var2: + something() + elif var3: + something_else() + elif +" + (python-tests-look-at "elif var3:") + (should + (equal (list + (python-tests-look-at "if var2:" -1 t) + (python-tests-look-at "if var:" -1 t)) + (python-info-dedenter-opening-block-positions))) + + (python-tests-look-at "elif\n") + (should + (equal (list + (python-tests-look-at "elif var3:" -1 t) + (python-tests-look-at "if var:" -1 t)) + (python-info-dedenter-opening-block-positions))))) + +(ert-deftest python-info-dedenter-opening-block-positions-3 () + "Test detection of opening blocks for else." + (python-tests-with-temp-buffer + " +try: + something() +except: + if var: + if var2: + something() + elif var3: + something_else() + else + +if var4: + while var5: + var4.pop() + else + + for value in var6: + if value > 0: + print value + else +" + (python-tests-look-at "else\n") + (should + (equal (list + (python-tests-look-at "elif var3:" -1 t) + (python-tests-look-at "if var:" -1 t) + (python-tests-look-at "except:" -1 t)) + (python-info-dedenter-opening-block-positions))) + + (python-tests-look-at "else\n") + (should + (equal (list + (python-tests-look-at "while var5:" -1 t) + (python-tests-look-at "if var4:" -1 t)) + (python-info-dedenter-opening-block-positions))) + + (python-tests-look-at "else\n") + (should + (equal (list + (python-tests-look-at "if value > 0:" -1 t) + (python-tests-look-at "for value in var6:" -1 t) + (python-tests-look-at "if var4:" -1 t)) + (python-info-dedenter-opening-block-positions))))) + +(ert-deftest python-info-dedenter-opening-block-positions-4 () + "Test detection of opening blocks for except." + (python-tests-with-temp-buffer + " +try: + something() +except ValueError: + something_else() + except +" + (python-tests-look-at "except ValueError:") + (should + (equal (list (python-tests-look-at "try:" -1 t)) + (python-info-dedenter-opening-block-positions))) + + (python-tests-look-at "except\n") + (should + (equal (list (python-tests-look-at "except ValueError:" -1 t)) + (python-info-dedenter-opening-block-positions))))) + +(ert-deftest python-info-dedenter-opening-block-positions-5 () + "Test detection of opening blocks for finally." + (python-tests-with-temp-buffer + " +try: + something() + finally + +try: + something_else() +except: + logger.exception('something went wrong') + finally + +try: + something_else_else() +except Exception: + logger.exception('something else went wrong') +else: + print ('all good') + finally +" + (python-tests-look-at "finally\n") + (should + (equal (list (python-tests-look-at "try:" -1 t)) + (python-info-dedenter-opening-block-positions))) + + (python-tests-look-at "finally\n") + (should + (equal (list (python-tests-look-at "except:" -1 t)) + (python-info-dedenter-opening-block-positions))) + + (python-tests-look-at "finally\n") + (should + (equal (list (python-tests-look-at "else:" -1 t)) + (python-info-dedenter-opening-block-positions))))) + +(ert-deftest python-info-dedenter-opening-block-message-1 () + "Test dedenters inside strings are ignored." + (python-tests-with-temp-buffer + "''' +try: + something() +except: + logger.exception('something went wrong') +''' +" + (python-tests-look-at "except\n") + (should (not (python-info-dedenter-opening-block-message))))) + +(ert-deftest python-info-dedenter-opening-block-message-2 () + "Test except keyword." + (python-tests-with-temp-buffer + " +try: + something() +except: + logger.exception('something went wrong') +" + (python-tests-look-at "except:") + (should (string= + "Closes try:" + (substring-no-properties + (python-info-dedenter-opening-block-message)))) + (end-of-line) + (should (string= + "Closes try:" + (substring-no-properties + (python-info-dedenter-opening-block-message)))))) + +(ert-deftest python-info-dedenter-opening-block-message-3 () + "Test else keyword." + (python-tests-with-temp-buffer + " +try: + something() +except: + logger.exception('something went wrong') +else: + logger.debug('all good') +" + (python-tests-look-at "else:") + (should (string= + "Closes except:" + (substring-no-properties + (python-info-dedenter-opening-block-message)))) + (end-of-line) + (should (string= + "Closes except:" + (substring-no-properties + (python-info-dedenter-opening-block-message)))))) + +(ert-deftest python-info-dedenter-opening-block-message-4 () + "Test finally keyword." + (python-tests-with-temp-buffer + " +try: + something() +except: + logger.exception('something went wrong') +else: + logger.debug('all good') +finally: + clean() +" + (python-tests-look-at "finally:") + (should (string= + "Closes else:" + (substring-no-properties + (python-info-dedenter-opening-block-message)))) + (end-of-line) + (should (string= + "Closes else:" + (substring-no-properties + (python-info-dedenter-opening-block-message)))))) + +(ert-deftest python-info-dedenter-opening-block-message-5 () + "Test elif keyword." + (python-tests-with-temp-buffer + " +if a: + something() +elif b: +" + (python-tests-look-at "elif b:") + (should (string= + "Closes if a:" + (substring-no-properties + (python-info-dedenter-opening-block-message)))) + (end-of-line) + (should (string= + "Closes if a:" + (substring-no-properties + (python-info-dedenter-opening-block-message)))))) + + +(ert-deftest python-info-dedenter-statement-p-1 () + "Test dedenters inside strings are ignored." + (python-tests-with-temp-buffer + "''' +try: + something() +except: + logger.exception('something went wrong') +''' +" + (python-tests-look-at "except\n") + (should (not (python-info-dedenter-statement-p))))) + +(ert-deftest python-info-dedenter-statement-p-2 () + "Test except keyword." + (python-tests-with-temp-buffer + " +try: + something() +except: + logger.exception('something went wrong') +" + (python-tests-look-at "except:") + (should (= (point) (python-info-dedenter-statement-p))) + (end-of-line) + (should (= (save-excursion + (back-to-indentation) + (point)) + (python-info-dedenter-statement-p))))) + +(ert-deftest python-info-dedenter-statement-p-3 () + "Test else keyword." + (python-tests-with-temp-buffer + " +try: + something() +except: + logger.exception('something went wrong') +else: + logger.debug('all good') +" + (python-tests-look-at "else:") + (should (= (point) (python-info-dedenter-statement-p))) + (end-of-line) + (should (= (save-excursion + (back-to-indentation) + (point)) + (python-info-dedenter-statement-p))))) + +(ert-deftest python-info-dedenter-statement-p-4 () + "Test finally keyword." + (python-tests-with-temp-buffer + " +try: + something() +except: + logger.exception('something went wrong') +else: + logger.debug('all good') +finally: + clean() +" + (python-tests-look-at "finally:") + (should (= (point) (python-info-dedenter-statement-p))) + (end-of-line) + (should (= (save-excursion + (back-to-indentation) + (point)) + (python-info-dedenter-statement-p))))) + +(ert-deftest python-info-dedenter-statement-p-5 () + "Test elif keyword." + (python-tests-with-temp-buffer + " +if a: + something() +elif b: +" + (python-tests-look-at "elif b:") + (should (= (point) (python-info-dedenter-statement-p))) + (end-of-line) + (should (= (save-excursion + (back-to-indentation) + (point)) + (python-info-dedenter-statement-p))))) + +(ert-deftest python-info-line-ends-backslash-p-1 () + (python-tests-with-temp-buffer + " +objects = Thing.objects.all() \\\\ + .filter( + type='toy', + status='bought' + ) \\\\ + .aggregate( + Sum('amount') + ) \\\\ + .values_list() +" + (should (python-info-line-ends-backslash-p 2)) ; .filter(... + (should (python-info-line-ends-backslash-p 3)) + (should (python-info-line-ends-backslash-p 4)) + (should (python-info-line-ends-backslash-p 5)) + (should (python-info-line-ends-backslash-p 6)) ; ) \... + (should (python-info-line-ends-backslash-p 7)) + (should (python-info-line-ends-backslash-p 8)) + (should (python-info-line-ends-backslash-p 9)) + (should (not (python-info-line-ends-backslash-p 10))))) ; .values_list()... + +(ert-deftest python-info-beginning-of-backslash-1 () + (python-tests-with-temp-buffer + " +objects = Thing.objects.all() \\\\ + .filter( + type='toy', + status='bought' + ) \\\\ + .aggregate( + Sum('amount') + ) \\\\ + .values_list() +" + (let ((first 2) + (second (python-tests-look-at ".filter(")) + (third (python-tests-look-at ".aggregate("))) + (should (= first (python-info-beginning-of-backslash 2))) + (should (= second (python-info-beginning-of-backslash 3))) + (should (= second (python-info-beginning-of-backslash 4))) + (should (= second (python-info-beginning-of-backslash 5))) + (should (= second (python-info-beginning-of-backslash 6))) + (should (= third (python-info-beginning-of-backslash 7))) + (should (= third (python-info-beginning-of-backslash 8))) + (should (= third (python-info-beginning-of-backslash 9))) + (should (not (python-info-beginning-of-backslash 10)))))) + +(ert-deftest python-info-continuation-line-p-1 () + (python-tests-with-temp-buffer + " +if width == 0 and height == 0 and \\\\ + color == 'red' and emphasis == 'strong' or \\\\ + highlight > 100: + raise ValueError( +'sorry, you lose' + +) +" + (python-tests-look-at "if width == 0 and height == 0 and") + (should (not (python-info-continuation-line-p))) + (python-tests-look-at "color == 'red' and emphasis == 'strong' or") + (should (python-info-continuation-line-p)) + (python-tests-look-at "highlight > 100:") + (should (python-info-continuation-line-p)) + (python-tests-look-at "raise ValueError(") + (should (not (python-info-continuation-line-p))) + (python-tests-look-at "'sorry, you lose'") + (should (python-info-continuation-line-p)) + (forward-line 1) + (should (python-info-continuation-line-p)) + (python-tests-look-at ")") + (should (python-info-continuation-line-p)) + (forward-line 1) + (should (not (python-info-continuation-line-p))))) + +(ert-deftest python-info-block-continuation-line-p-1 () + (python-tests-with-temp-buffer + " +if width == 0 and height == 0 and \\\\ + color == 'red' and emphasis == 'strong' or \\\\ + highlight > 100: + raise ValueError( +'sorry, you lose' + +) +" + (python-tests-look-at "if width == 0 and") + (should (not (python-info-block-continuation-line-p))) + (python-tests-look-at "color == 'red' and emphasis == 'strong' or") + (should (= (python-info-block-continuation-line-p) + (python-tests-look-at "if width == 0 and" -1 t))) + (python-tests-look-at "highlight > 100:") + (should (not (python-info-block-continuation-line-p))))) + +(ert-deftest python-info-block-continuation-line-p-2 () + (python-tests-with-temp-buffer + " +def foo(a, + b, + c): + pass +" + (python-tests-look-at "def foo(a,") + (should (not (python-info-block-continuation-line-p))) + (python-tests-look-at "b,") + (should (= (python-info-block-continuation-line-p) + (python-tests-look-at "def foo(a," -1 t))) + (python-tests-look-at "c):") + (should (not (python-info-block-continuation-line-p))))) + +(ert-deftest python-info-assignment-statement-p-1 () + (python-tests-with-temp-buffer + " +data = foo(), bar() \\\\ + baz(), 4 \\\\ + 5, 6 +" + (python-tests-look-at "data = foo(), bar()") + (should (python-info-assignment-statement-p)) + (should (python-info-assignment-statement-p t)) + (python-tests-look-at "baz(), 4") + (should (python-info-assignment-statement-p)) + (should (not (python-info-assignment-statement-p t))) + (python-tests-look-at "5, 6") + (should (python-info-assignment-statement-p)) + (should (not (python-info-assignment-statement-p t))))) + +(ert-deftest python-info-assignment-statement-p-2 () + (python-tests-with-temp-buffer + " +data = (foo(), bar() + baz(), 4 + 5, 6) +" + (python-tests-look-at "data = (foo(), bar()") + (should (python-info-assignment-statement-p)) + (should (python-info-assignment-statement-p t)) + (python-tests-look-at "baz(), 4") + (should (python-info-assignment-statement-p)) + (should (not (python-info-assignment-statement-p t))) + (python-tests-look-at "5, 6)") + (should (python-info-assignment-statement-p)) + (should (not (python-info-assignment-statement-p t))))) + +(ert-deftest python-info-assignment-statement-p-3 () + (python-tests-with-temp-buffer + " +data '=' 42 +" + (python-tests-look-at "data '=' 42") + (should (not (python-info-assignment-statement-p))) + (should (not (python-info-assignment-statement-p t))))) + +(ert-deftest python-info-assignment-continuation-line-p-1 () + (python-tests-with-temp-buffer + " +data = foo(), bar() \\\\ + baz(), 4 \\\\ + 5, 6 +" + (python-tests-look-at "data = foo(), bar()") + (should (not (python-info-assignment-continuation-line-p))) + (python-tests-look-at "baz(), 4") + (should (= (python-info-assignment-continuation-line-p) + (python-tests-look-at "foo()," -1 t))) + (python-tests-look-at "5, 6") + (should (not (python-info-assignment-continuation-line-p))))) + +(ert-deftest python-info-assignment-continuation-line-p-2 () + (python-tests-with-temp-buffer + " +data = (foo(), bar() + baz(), 4 + 5, 6) +" + (python-tests-look-at "data = (foo(), bar()") + (should (not (python-info-assignment-continuation-line-p))) + (python-tests-look-at "baz(), 4") + (should (= (python-info-assignment-continuation-line-p) + (python-tests-look-at "(foo()," -1 t))) + (python-tests-look-at "5, 6)") + (should (not (python-info-assignment-continuation-line-p))))) + +(ert-deftest python-info-looking-at-beginning-of-defun-1 () + (python-tests-with-temp-buffer + " +def decorat0r(deff): + '''decorates stuff. + + @decorat0r + def foo(arg): + ... + ''' + def wrap(): + deff() + return wwrap +" + (python-tests-look-at "def decorat0r(deff):") + (should (python-info-looking-at-beginning-of-defun)) + (python-tests-look-at "def foo(arg):") + (should (not (python-info-looking-at-beginning-of-defun))) + (python-tests-look-at "def wrap():") + (should (python-info-looking-at-beginning-of-defun)) + (python-tests-look-at "deff()") + (should (not (python-info-looking-at-beginning-of-defun))))) + +(ert-deftest python-info-current-line-comment-p-1 () + (python-tests-with-temp-buffer + " +# this is a comment +foo = True # another comment +'#this is a string' +if foo: + # more comments + print ('bar') # print bar +" + (python-tests-look-at "# this is a comment") + (should (python-info-current-line-comment-p)) + (python-tests-look-at "foo = True # another comment") + (should (not (python-info-current-line-comment-p))) + (python-tests-look-at "'#this is a string'") + (should (not (python-info-current-line-comment-p))) + (python-tests-look-at "# more comments") + (should (python-info-current-line-comment-p)) + (python-tests-look-at "print ('bar') # print bar") + (should (not (python-info-current-line-comment-p))))) + +(ert-deftest python-info-current-line-empty-p () + (python-tests-with-temp-buffer + " +# this is a comment + +foo = True # another comment +" + (should (python-info-current-line-empty-p)) + (python-tests-look-at "# this is a comment") + (should (not (python-info-current-line-empty-p))) + (forward-line 1) + (should (python-info-current-line-empty-p)))) + +(ert-deftest python-info-docstring-p-1 () + "Test module docstring detection." + (python-tests-with-temp-buffer + "# -*- coding: utf-8 -*- +#!/usr/bin/python + +''' +Module Docstring Django style. +''' +u'''Additional module docstring.''' +'''Not a module docstring.''' +" + (python-tests-look-at "Module Docstring Django style.") + (should (python-info-docstring-p)) + (python-tests-look-at "u'''Additional module docstring.'''") + (should (python-info-docstring-p)) + (python-tests-look-at "'''Not a module docstring.'''") + (should (not (python-info-docstring-p))))) + +(ert-deftest python-info-docstring-p-2 () + "Test variable docstring detection." + (python-tests-with-temp-buffer + " +variable = 42 +U'''Variable docstring.''' +'''Additional variable docstring.''' +'''Not a variable docstring.''' +" + (python-tests-look-at "Variable docstring.") + (should (python-info-docstring-p)) + (python-tests-look-at "u'''Additional variable docstring.'''") + (should (python-info-docstring-p)) + (python-tests-look-at "'''Not a variable docstring.'''") + (should (not (python-info-docstring-p))))) + +(ert-deftest python-info-docstring-p-3 () + "Test function docstring detection." + (python-tests-with-temp-buffer + " +def func(a, b): + r''' + Function docstring. + + onetwo style. + ''' + R'''Additional function docstring.''' + '''Not a function docstring.''' + return a + b +" + (python-tests-look-at "Function docstring.") + (should (python-info-docstring-p)) + (python-tests-look-at "R'''Additional function docstring.'''") + (should (python-info-docstring-p)) + (python-tests-look-at "'''Not a function docstring.'''") + (should (not (python-info-docstring-p))))) + +(ert-deftest python-info-docstring-p-4 () + "Test class docstring detection." + (python-tests-with-temp-buffer + " +class Class: + ur''' + Class docstring. + + symmetric style. + ''' + uR''' + Additional class docstring. + ''' + '''Not a class docstring.''' + pass +" + (python-tests-look-at "Class docstring.") + (should (python-info-docstring-p)) + (python-tests-look-at "uR'''") ;; Additional class docstring + (should (python-info-docstring-p)) + (python-tests-look-at "'''Not a class docstring.'''") + (should (not (python-info-docstring-p))))) + +(ert-deftest python-info-docstring-p-5 () + "Test class attribute docstring detection." + (python-tests-with-temp-buffer + " +class Class: + attribute = 42 + Ur''' + Class attribute docstring. + + pep-257 style. + + ''' + UR''' + Additional class attribute docstring. + ''' + '''Not a class attribute docstring.''' + pass +" + (python-tests-look-at "Class attribute docstring.") + (should (python-info-docstring-p)) + (python-tests-look-at "UR'''") ;; Additional class attr docstring + (should (python-info-docstring-p)) + (python-tests-look-at "'''Not a class attribute docstring.'''") + (should (not (python-info-docstring-p))))) + +(ert-deftest python-info-docstring-p-6 () + "Test class method docstring detection." + (python-tests-with-temp-buffer + " +class Class: + + def __init__(self, a, b): + self.a = a + self.b = b + + def __call__(self): + '''Method docstring. + + pep-257-nn style. + ''' + '''Additional method docstring.''' + '''Not a method docstring.''' + return self.a + self.b +" + (python-tests-look-at "Method docstring.") + (should (python-info-docstring-p)) + (python-tests-look-at "'''Additional method docstring.'''") + (should (python-info-docstring-p)) + (python-tests-look-at "'''Not a method docstring.'''") + (should (not (python-info-docstring-p))))) + +(ert-deftest python-info-encoding-from-cookie-1 () + "Should detect it on first line." + (python-tests-with-temp-buffer + "# coding=latin-1 + +foo = True # another comment +" + (should (eq (python-info-encoding-from-cookie) 'latin-1)))) + +(ert-deftest python-info-encoding-from-cookie-2 () + "Should detect it on second line." + (python-tests-with-temp-buffer + " +# coding=latin-1 + +foo = True # another comment +" + (should (eq (python-info-encoding-from-cookie) 'latin-1)))) + +(ert-deftest python-info-encoding-from-cookie-3 () + "Should not be detected on third line (and following ones)." + (python-tests-with-temp-buffer + " + +# coding=latin-1 +foo = True # another comment +" + (should (not (python-info-encoding-from-cookie))))) + +(ert-deftest python-info-encoding-from-cookie-4 () + "Should detect Emacs style." + (python-tests-with-temp-buffer + "# -*- coding: latin-1 -*- + +foo = True # another comment" + (should (eq (python-info-encoding-from-cookie) 'latin-1)))) + +(ert-deftest python-info-encoding-from-cookie-5 () + "Should detect Vim style." + (python-tests-with-temp-buffer + "# vim: set fileencoding=latin-1 : + +foo = True # another comment" + (should (eq (python-info-encoding-from-cookie) 'latin-1)))) + +(ert-deftest python-info-encoding-from-cookie-6 () + "First cookie wins." + (python-tests-with-temp-buffer + "# -*- coding: iso-8859-1 -*- +# vim: set fileencoding=latin-1 : + +foo = True # another comment" + (should (eq (python-info-encoding-from-cookie) 'iso-8859-1)))) + +(ert-deftest python-info-encoding-from-cookie-7 () + "First cookie wins." + (python-tests-with-temp-buffer + "# vim: set fileencoding=latin-1 : +# -*- coding: iso-8859-1 -*- + +foo = True # another comment" + (should (eq (python-info-encoding-from-cookie) 'latin-1)))) + +(ert-deftest python-info-encoding-1 () + "Should return the detected encoding from cookie." + (python-tests-with-temp-buffer + "# vim: set fileencoding=latin-1 : + +foo = True # another comment" + (should (eq (python-info-encoding) 'latin-1)))) + +(ert-deftest python-info-encoding-2 () + "Should default to utf-8." + (python-tests-with-temp-buffer + "# No encoding for you + +foo = True # another comment" + (should (eq (python-info-encoding) 'utf-8)))) + + +;;; Utility functions + +(ert-deftest python-util-goto-line-1 () + (python-tests-with-temp-buffer + (concat + "# a comment +# another comment +def foo(a, b, c): + pass" (make-string 20 ?\n)) + (python-util-goto-line 10) + (should (= (line-number-at-pos) 10)) + (python-util-goto-line 20) + (should (= (line-number-at-pos) 20)))) + +(ert-deftest python-util-clone-local-variables-1 () + (let ((buffer (generate-new-buffer + "python-util-clone-local-variables-1")) + (varcons + '((python-fill-docstring-style . django) + (python-shell-interpreter . "python") + (python-shell-interpreter-args . "manage.py shell") + (python-shell-prompt-regexp . "In \\[[0-9]+\\]: ") + (python-shell-prompt-output-regexp . "Out\\[[0-9]+\\]: ") + (python-shell-extra-pythonpaths "/home/user/pylib/") + (python-shell-completion-setup-code + . "from IPython.core.completerlib import module_completion") + (python-shell-completion-string-code + . "';'.join(get_ipython().Completer.all_completions('''%s'''))\n") + (python-shell-virtualenv-root + . "/home/user/.virtualenvs/project")))) + (with-current-buffer buffer + (kill-all-local-variables) + (dolist (ccons varcons) + (set (make-local-variable (car ccons)) (cdr ccons)))) + (python-tests-with-temp-buffer + "" + (python-util-clone-local-variables buffer) + (dolist (ccons varcons) + (should + (equal (symbol-value (car ccons)) (cdr ccons))))) + (kill-buffer buffer))) + +(ert-deftest python-util-strip-string-1 () + (should (string= (python-util-strip-string "\t\r\n str") "str")) + (should (string= (python-util-strip-string "str \n\r") "str")) + (should (string= (python-util-strip-string "\t\r\n str \n\r ") "str")) + (should + (string= (python-util-strip-string "\n str \nin \tg \n\r") "str \nin \tg")) + (should (string= (python-util-strip-string "\n \t \n\r ") "")) + (should (string= (python-util-strip-string "") ""))) + +(ert-deftest python-util-forward-comment-1 () + (python-tests-with-temp-buffer + (concat + "# a comment +# another comment + # bad indented comment +# more comments" (make-string 9999 ?\n)) + (python-util-forward-comment 1) + (should (= (point) (point-max))) + (python-util-forward-comment -1) + (should (= (point) (point-min))))) + +(ert-deftest python-util-valid-regexp-p-1 () + (should (python-util-valid-regexp-p "")) + (should (python-util-valid-regexp-p python-shell-prompt-regexp)) + (should (not (python-util-valid-regexp-p "\\(")))) + + +;;; Electricity + +(ert-deftest python-parens-electric-indent-1 () + (let ((eim electric-indent-mode)) + (unwind-protect + (progn + (python-tests-with-temp-buffer + " +from django.conf.urls import patterns, include, url + +from django.contrib import admin + +from myapp import views + + +urlpatterns = patterns('', + url(r'^$', views.index +) +" + (electric-indent-mode 1) + (python-tests-look-at "views.index") + (end-of-line) + + ;; Inserting commas within the same line should leave + ;; indentation unchanged. + (python-tests-self-insert ",") + (should (= (current-indentation) 4)) + + ;; As well as any other input happening within the same + ;; set of parens. + (python-tests-self-insert " name='index')") + (should (= (current-indentation) 4)) + + ;; But a comma outside it, should trigger indentation. + (python-tests-self-insert ",") + (should (= (current-indentation) 23)) + + ;; Newline indents to the first argument column + (python-tests-self-insert "\n") + (should (= (current-indentation) 23)) + + ;; All this input must not change indentation + (indent-line-to 4) + (python-tests-self-insert "url(r'^/login$', views.login)") + (should (= (current-indentation) 4)) + + ;; But this comma does + (python-tests-self-insert ",") + (should (= (current-indentation) 23)))) + (or eim (electric-indent-mode -1))))) + +(ert-deftest python-triple-quote-pairing () + (let ((epm electric-pair-mode)) + (unwind-protect + (progn + (python-tests-with-temp-buffer + "\"\"\n" + (or epm (electric-pair-mode 1)) + (goto-char (1- (point-max))) + (python-tests-self-insert ?\") + (should (string= (buffer-string) + "\"\"\"\"\"\"\n")) + (should (= (point) 4))) + (python-tests-with-temp-buffer + "\n" + (python-tests-self-insert (list ?\" ?\" ?\")) + (should (string= (buffer-string) + "\"\"\"\"\"\"\n")) + (should (= (point) 4))) + (python-tests-with-temp-buffer + "\"\n\"\"\n" + (goto-char (1- (point-max))) + (python-tests-self-insert ?\") + (should (= (point) (1- (point-max)))) + (should (string= (buffer-string) + "\"\n\"\"\"\n")))) + (or epm (electric-pair-mode -1))))) + + +;;; Hideshow support + +(ert-deftest python-hideshow-hide-levels-1 () + "Should hide all methods when called after class start." + (let ((enabled hs-minor-mode)) + (unwind-protect + (progn + (python-tests-with-temp-buffer + " +class SomeClass: + + def __init__(self, arg, kwarg=1): + self.arg = arg + self.kwarg = kwarg + + def filter(self, nums): + def fn(item): + return item in [self.arg, self.kwarg] + return filter(fn, nums) + + def __str__(self): + return '%s-%s' % (self.arg, self.kwarg) +" + (hs-minor-mode 1) + (python-tests-look-at "class SomeClass:") + (forward-line) + (hs-hide-level 1) + (should + (string= + (python-tests-visible-string) + " +class SomeClass: + + def __init__(self, arg, kwarg=1): + def filter(self, nums): + def __str__(self):")))) + (or enabled (hs-minor-mode -1))))) + +(ert-deftest python-hideshow-hide-levels-2 () + "Should hide nested methods and parens at end of defun." + (let ((enabled hs-minor-mode)) + (unwind-protect + (progn + (python-tests-with-temp-buffer + " +class SomeClass: + + def __init__(self, arg, kwarg=1): + self.arg = arg + self.kwarg = kwarg + + def filter(self, nums): + def fn(item): + return item in [self.arg, self.kwarg] + return filter(fn, nums) + + def __str__(self): + return '%s-%s' % (self.arg, self.kwarg) +" + (hs-minor-mode 1) + (python-tests-look-at "def fn(item):") + (hs-hide-block) + (should + (string= + (python-tests-visible-string) + " +class SomeClass: + + def __init__(self, arg, kwarg=1): + self.arg = arg + self.kwarg = kwarg + + def filter(self, nums): + def fn(item): + return filter(fn, nums) + + def __str__(self): + return '%s-%s' % (self.arg, self.kwarg) +")))) + (or enabled (hs-minor-mode -1))))) + + + +(provide 'python-tests) + +;; Local Variables: +;; indent-tabs-mode: nil +;; End: + +;;; python-tests.el ends here diff --git a/test/lisp/progmodes/ruby-mode-tests.el b/test/lisp/progmodes/ruby-mode-tests.el new file mode 100644 index 00000000000..da8d77c5157 --- /dev/null +++ b/test/lisp/progmodes/ruby-mode-tests.el @@ -0,0 +1,713 @@ +;;; ruby-mode-tests.el --- Test suite for ruby-mode + +;; Copyright (C) 2012-2016 Free Software Foundation, Inc. + +;; 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: + +;;; Code: + +(require 'ert) +(require 'ruby-mode) + +(defmacro ruby-with-temp-buffer (contents &rest body) + (declare (indent 1) (debug t)) + `(with-temp-buffer + (insert ,contents) + (ruby-mode) + ,@body)) + +(defun ruby-should-indent (content column) + "Assert indentation COLUMN on the last line of CONTENT." + (ruby-with-temp-buffer content + (indent-according-to-mode) + (should (= (current-indentation) column)))) + +(defun ruby-should-indent-buffer (expected content) + "Assert that CONTENT turns into EXPECTED after the buffer is re-indented. + +The whitespace before and including \"|\" on each line is removed." + (ruby-with-temp-buffer (ruby-test-string content) + (indent-region (point-min) (point-max)) + (should (string= (ruby-test-string expected) (buffer-string))))) + +(defun ruby-test-string (s &rest args) + (apply 'format (replace-regexp-in-string "^[ \t]*|" "" s) args)) + +(defun ruby-assert-state (content index value &optional point) + "Assert syntax state values at the end of CONTENT. + +VALUES-PLIST is a list with alternating index and value elements." + (ruby-with-temp-buffer content + (when point (goto-char point)) + (syntax-propertize (point)) + (should (eq (nth index + (parse-partial-sexp (point-min) (point))) + value)))) + +(defun ruby-assert-face (content pos face) + (ruby-with-temp-buffer content + (font-lock-ensure nil nil) + (should (eq face (get-text-property pos 'face))))) + +(ert-deftest ruby-indent-after-symbol-made-from-string-interpolation () + "It can indent the line after symbol made using string interpolation." + (ruby-should-indent "def foo(suffix)\n :\"bar#{suffix}\"\n" + ruby-indent-level)) + +(ert-deftest ruby-indent-after-js-style-symbol-with-block-beg-name () + "JS-style hash symbol can have keyword name." + (ruby-should-indent "link_to \"home\", home_path, class: \"foo\"\n" 0)) + +(ert-deftest ruby-discern-singleton-class-from-heredoc () + (ruby-assert-state "foo <<asd\n" 3 ?\n) + (ruby-assert-state "class <<asd\n" 3 nil)) + +(ert-deftest ruby-heredoc-font-lock () + (let ((s "foo <<eos.gsub('^ *', '')")) + (ruby-assert-face s 9 font-lock-string-face) + (ruby-assert-face s 10 nil))) + +(ert-deftest ruby-singleton-class-no-heredoc-font-lock () + (ruby-assert-face "class<<a" 8 nil)) + +(ert-deftest ruby-heredoc-highlights-interpolations () + (ruby-assert-face "s = <<EOS\n #{foo}\nEOS" 15 font-lock-variable-name-face)) + +(ert-deftest ruby-no-heredoc-inside-quotes () + (ruby-assert-state "\"<<\", \"\",\nfoo" 3 nil)) + +(ert-deftest ruby-exit!-font-lock () + (ruby-assert-face "exit!" 5 font-lock-builtin-face)) + +(ert-deftest ruby-deep-indent () + (let ((ruby-deep-arglist nil) + (ruby-deep-indent-paren '(?\( ?\{ ?\[ ?\] t))) + (ruby-should-indent "foo = [1,\n2" 7) + (ruby-should-indent "foo = {a: b,\nc: d" 7) + (ruby-should-indent "foo(a,\nb" 4))) + +(ert-deftest ruby-deep-indent-disabled () + (let ((ruby-deep-arglist nil) + (ruby-deep-indent-paren nil)) + (ruby-should-indent "foo = [\n1" ruby-indent-level) + (ruby-should-indent "foo = {\na: b" ruby-indent-level) + (ruby-should-indent "foo(\na" ruby-indent-level))) + +(ert-deftest ruby-indent-after-keyword-in-a-string () + (ruby-should-indent "a = \"abc\nif\"\n " 0) + (ruby-should-indent "a = %w[abc\n def]\n " 0) + (ruby-should-indent "a = \"abc\n def\"\n " 0)) + +(ert-deftest ruby-regexp-doesnt-start-in-string () + (ruby-assert-state "'(/', /\d+/" 3 nil)) + +(ert-deftest ruby-regexp-starts-after-string () + (ruby-assert-state "'(/', /\d+/" 3 ?/ 8)) + +(ert-deftest ruby-regexp-interpolation-is-highlighted () + (ruby-assert-face "/#{foobs}/" 4 font-lock-variable-name-face)) + +(ert-deftest ruby-regexp-skips-over-interpolation () + (ruby-assert-state "/#{foobs.join('/')}/" 3 nil)) + +(ert-deftest ruby-regexp-continues-till-end-when-unclosed () + (ruby-assert-state "/bars" 3 ?/)) + +(ert-deftest ruby-regexp-can-be-multiline () + (ruby-assert-state "/bars\ntees # toots \nfoos/" 3 nil)) + +(ert-deftest ruby-slash-symbol-is-not-mistaken-for-regexp () + (ruby-assert-state ":/" 3 nil)) + +(ert-deftest ruby-slash-char-literal-is-not-mistaken-for-regexp () + (ruby-assert-state "?/" 3 nil)) + +(ert-deftest ruby-indent-simple () + (ruby-should-indent-buffer + "if foo + | bar + |end + |zot + |" + "if foo + |bar + | end + | zot + |")) + +(ert-deftest ruby-indent-keyword-label () + (ruby-should-indent-buffer + "bar(class: XXX) do + | foo + |end + |bar + |" + "bar(class: XXX) do + | foo + | end + | bar + |")) + +(ert-deftest ruby-indent-method-with-question-mark () + (ruby-should-indent-buffer + "if x.is_a?(XXX) + | foo + |end + |" + "if x.is_a?(XXX) + | foo + | end + |")) + +(ert-deftest ruby-indent-expr-in-regexp () + (ruby-should-indent-buffer + "if /#{foo}/ =~ s + | x = 1 + |end + |" + "if /#{foo}/ =~ s + | x = 1 + | end + |")) + +(ert-deftest ruby-indent-singleton-class () + (ruby-should-indent-buffer + "class<<bar + | foo + |end + |" + "class<<bar + |foo + | end + |")) + +(ert-deftest ruby-indent-inside-heredoc-after-operator () + (ruby-should-indent-buffer + "b=<<eos + | 42" + "b=<<eos + | 42")) + +(ert-deftest ruby-indent-inside-heredoc-after-space () + (ruby-should-indent-buffer + "foo <<eos.gsub(' ', '*') + | 42" + "foo <<eos.gsub(' ', '*') + | 42")) + +(ert-deftest ruby-indent-array-literal () + (let ((ruby-deep-indent-paren nil)) + (ruby-should-indent-buffer + "foo = [ + | bar + |] + |" + "foo = [ + | bar + | ] + |")) + (ruby-should-indent-buffer + "foo do + | [bar] + |end + |" + "foo do + |[bar] + | end + |")) + +(ert-deftest ruby-indent-begin-end () + (ruby-should-indent-buffer + "begin + | a[b] + |end + |" + "begin + | a[b] + | end + |")) + +(ert-deftest ruby-indent-array-after-paren-and-space () + (ruby-should-indent-buffer + "class A + | def foo + | foo( []) + | end + |end + |" + "class A + | def foo + |foo( []) + |end + | end + |")) + +(ert-deftest ruby-indent-after-block-in-continued-expression () + (ruby-should-indent-buffer + "var = + | begin + | val + | end + |statement" + "var = + |begin + |val + |end + |statement")) + +(ert-deftest ruby-indent-spread-args-in-parens () + (let ((ruby-deep-indent-paren '(?\())) + (ruby-should-indent-buffer + "foo(1, + | 2, + | 3) + |" + "foo(1, + | 2, + | 3) + |"))) + +(ert-deftest ruby-align-to-stmt-keywords-t () + (let ((ruby-align-to-stmt-keywords t)) + (ruby-should-indent-buffer + "foo = if bar? + | 1 + |else + | 2 + |end + | + |foo || begin + | bar + |end + | + |foo || + | begin + | bar + | end + |" + "foo = if bar? + | 1 + |else + | 2 + | end + | + | foo || begin + | bar + |end + | + | foo || + | begin + |bar + | end + |") + )) + +(ert-deftest ruby-align-to-stmt-keywords-case () + (let ((ruby-align-to-stmt-keywords '(case))) + (ruby-should-indent-buffer + "b = case a + |when 13 + | 6 + |else + | 42 + |end" + "b = case a + | when 13 + | 6 + | else + | 42 + | end"))) + +(ert-deftest ruby-align-chained-calls () + (let ((ruby-align-chained-calls t)) + (ruby-should-indent-buffer + "one.two.three + | .four + | + |my_array.select { |str| str.size > 5 } + | .map { |str| str.downcase }" + "one.two.three + | .four + | + |my_array.select { |str| str.size > 5 } + | .map { |str| str.downcase }"))) + +(ert-deftest ruby-move-to-block-stops-at-indentation () + (ruby-with-temp-buffer "def f\nend" + (beginning-of-line) + (ruby-move-to-block -1) + (should (looking-at "^def")))) + +(ert-deftest ruby-toggle-block-to-do-end () + (ruby-with-temp-buffer "foo {|b|\n}" + (beginning-of-line) + (ruby-toggle-block) + (should (string= "foo do |b|\nend" (buffer-string))))) + +(ert-deftest ruby-toggle-block-to-brace () + (let ((pairs '((17 . "foo { |b| b + 2 }") + (16 . "foo { |b|\n b + 2\n}")))) + (dolist (pair pairs) + (with-temp-buffer + (let ((fill-column (car pair))) + (insert "foo do |b|\n b + 2\nend") + (ruby-mode) + (beginning-of-line) + (ruby-toggle-block) + (should (string= (cdr pair) (buffer-string)))))))) + +(ert-deftest ruby-toggle-block-to-multiline () + (ruby-with-temp-buffer "foo {|b| b + 1}" + (beginning-of-line) + (ruby-toggle-block) + (should (string= "foo do |b|\n b + 1\nend" (buffer-string))))) + +(ert-deftest ruby-toggle-block-with-interpolation () + (ruby-with-temp-buffer "foo do\n \"#{bar}\"\nend" + (beginning-of-line) + (ruby-toggle-block) + (should (string= "foo { \"#{bar}\" }" (buffer-string))))) + +(ert-deftest ruby-recognize-symbols-starting-with-at-character () + (ruby-assert-face ":@abc" 3 font-lock-constant-face)) + +(ert-deftest ruby-hash-character-not-interpolation () + (ruby-assert-face "\"This is #{interpolation}\"" 15 + font-lock-variable-name-face) + (ruby-assert-face "\"This is \\#{no interpolation} despite the #\"" + 15 font-lock-string-face) + (ruby-assert-face "\n#@comment, not ruby code" 5 font-lock-comment-face) + (ruby-assert-state "\n#@comment, not ruby code" 4 t) + (ruby-assert-face "# A comment cannot have #{an interpolation} in it" + 30 font-lock-comment-face) + (ruby-assert-face "# #{comment}\n \"#{interpolation}\"" 16 + font-lock-variable-name-face)) + +(ert-deftest ruby-interpolation-suppresses-quotes-inside () + (let ((s "\"<ul><li>#{@files.join(\"</li><li>\")}</li></ul>\"")) + (ruby-assert-state s 8 nil) + (ruby-assert-face s 9 font-lock-string-face) + (ruby-assert-face s 10 font-lock-variable-name-face) + (ruby-assert-face s 41 font-lock-string-face))) + +(ert-deftest ruby-interpolation-suppresses-one-double-quote () + (let ((s "\"foo#{'\"'}\"")) + (ruby-assert-state s 8 nil) + (ruby-assert-face s 8 font-lock-variable-name-face) + (ruby-assert-face s 11 font-lock-string-face))) + +(ert-deftest ruby-interpolation-suppresses-one-backtick () + (let ((s "`as#{'`'}das`")) + (ruby-assert-state s 8 nil))) + +(ert-deftest ruby-interpolation-keeps-non-quote-syntax () + (let ((s "\"foo#{baz.tee}bar\"")) + (ruby-with-temp-buffer s + (goto-char (point-min)) + (ruby-mode) + (syntax-propertize (point-max)) + (search-forward "tee") + (should (string= (thing-at-point 'symbol) "tee"))))) + +(ert-deftest ruby-interpolation-inside-percent-literal () + (let ((s "%( #{boo} )")) + (ruby-assert-face s 1 font-lock-string-face) + (ruby-assert-face s 4 font-lock-variable-name-face) + (ruby-assert-face s 10 font-lock-string-face) + (ruby-assert-state s 8 nil))) + +(ert-deftest ruby-interpolation-inside-percent-literal-with-paren () + :expected-result :failed + (let ((s "%(^#{\")\"}^)")) + (ruby-assert-face s 3 font-lock-string-face) + (ruby-assert-face s 4 font-lock-variable-name-face) + (ruby-assert-face s 10 font-lock-string-face) + ;; It's confused by the closing paren in the middle. + (ruby-assert-state s 8 nil))) + +(ert-deftest ruby-interpolation-inside-double-quoted-percent-literals () + (ruby-assert-face "%Q{foo #@bar}" 8 font-lock-variable-name-face) + (ruby-assert-face "%W{foo #@bar}" 8 font-lock-variable-name-face) + (ruby-assert-face "%r{foo #@bar}" 8 font-lock-variable-name-face) + (ruby-assert-face "%x{foo #@bar}" 8 font-lock-variable-name-face)) + +(ert-deftest ruby-no-interpolation-in-single-quoted-literals () + (ruby-assert-face "'foo #@bar'" 7 font-lock-string-face) + (ruby-assert-face "%q{foo #@bar}" 8 font-lock-string-face) + (ruby-assert-face "%w{foo #@bar}" 8 font-lock-string-face) + (ruby-assert-face "%s{foo #@bar}" 8 font-lock-string-face)) + +(ert-deftest ruby-interpolation-after-dollar-sign () + (ruby-assert-face "\"$#{balance}\"" 2 'font-lock-string-face) + (ruby-assert-face "\"$#{balance}\"" 3 'font-lock-variable-name-face)) + +(ert-deftest ruby-no-unknown-percent-literals () + ;; No folding of case. + (ruby-assert-face "%S{foo}" 4 nil) + (ruby-assert-face "%R{foo}" 4 nil)) + +(ert-deftest ruby-add-log-current-method-examples () + (let ((pairs '(("foo" . "#foo") + ("C.foo" . ".foo") + ("self.foo" . ".foo")))) + (dolist (pair pairs) + (let ((name (car pair)) + (value (cdr pair))) + (ruby-with-temp-buffer (ruby-test-string + "module M + | class C + | def %s + | _ + | end + | end + |end" + name) + (search-backward "_") + (forward-line) + (should (string= (ruby-add-log-current-method) + (format "M::C%s" value)))))))) + +(ert-deftest ruby-add-log-current-method-outside-of-method () + (ruby-with-temp-buffer (ruby-test-string + "module M + | class C + | def foo + | end + | _ + | end + |end") + (search-backward "_") + (should (string= (ruby-add-log-current-method)"M::C")))) + +(ert-deftest ruby-add-log-current-method-in-singleton-class () + (ruby-with-temp-buffer (ruby-test-string + "class C + | class << self + | def foo + | _ + | end + | end + |end") + (search-backward "_") + (should (string= (ruby-add-log-current-method) "C.foo")))) + +(ert-deftest ruby-add-log-current-method-namespace-shorthand () + (ruby-with-temp-buffer (ruby-test-string + "class C::D + | def foo + | _ + | end + |end") + (search-backward "_") + (should (string= (ruby-add-log-current-method) "C::D#foo")))) + +(ert-deftest ruby-add-log-current-method-after-inner-class () + (ruby-with-temp-buffer (ruby-test-string + "module M + | class C + | class D + | end + | def foo + | _ + | end + | end + |end") + (search-backward "_") + (should (string= (ruby-add-log-current-method) "M::C#foo")))) + +(defvar ruby-block-test-example + (ruby-test-string + "class C + | def foo + | 1 + | end + | + | def bar + | 2 + | end + | + | def baz + |some do + |3 + | end + | end + |end")) + +(defmacro ruby-deftest-move-to-block (name &rest body) + (declare (indent defun)) + `(ert-deftest ,(intern (format "ruby-move-to-block-%s" name)) () + (with-temp-buffer + (insert ruby-block-test-example) + (ruby-mode) + (goto-char (point-min)) + ,@body))) + +(ruby-deftest-move-to-block works-on-do + (forward-line 10) + (ruby-end-of-block) + (should (= 13 (line-number-at-pos))) + (ruby-beginning-of-block) + (should (= 11 (line-number-at-pos)))) + +(ruby-deftest-move-to-block zero-is-noop + (forward-line 4) + (ruby-move-to-block 0) + (should (= 5 (line-number-at-pos)))) + +(ruby-deftest-move-to-block ok-with-three + (forward-line 1) + (ruby-move-to-block 3) + (should (= 14 (line-number-at-pos)))) + +(ruby-deftest-move-to-block ok-with-minus-two + (forward-line 9) + (ruby-move-to-block -2) + (should (= 2 (line-number-at-pos)))) + +(ert-deftest ruby-move-to-block-skips-percent-literal () + (dolist (s (list (ruby-test-string + "foo do + | a = %%w( + | def yaa + | ) + |end") + (ruby-test-string + "foo do + | a = %%w| + | end + | | + |end"))) + (ruby-with-temp-buffer s + (goto-char (point-min)) + (ruby-end-of-block) + (should (= 5 (line-number-at-pos))) + (ruby-beginning-of-block) + (should (= 1 (line-number-at-pos)))))) + +(ert-deftest ruby-move-to-block-skips-heredoc () + (ruby-with-temp-buffer + (ruby-test-string + "if something_wrong? + | ActiveSupport::Deprecation.warn(<<-eowarn) + | boo hoo + | end + | eowarn + |end") + (goto-char (point-min)) + (ruby-end-of-block) + (should (= 6 (line-number-at-pos))) + (ruby-beginning-of-block) + (should (= 1 (line-number-at-pos))))) + +(ert-deftest ruby-move-to-block-does-not-fold-case () + (ruby-with-temp-buffer + (ruby-test-string + "foo do + | Module.to_s + |end") + (let ((case-fold-search t)) + (ruby-beginning-of-block)) + (should (= 1 (line-number-at-pos))))) + +(ert-deftest ruby-move-to-block-moves-from-else-to-if () + (ruby-with-temp-buffer (ruby-test-string + "if true + | nested_block do + | end + |else + |end") + (goto-char (point-min)) + (forward-line 3) + (ruby-beginning-of-block) + (should (= 1 (line-number-at-pos))))) + +(ert-deftest ruby-beginning-of-defun-does-not-fold-case () + (ruby-with-temp-buffer + (ruby-test-string + "class C + | def bar + | Class.to_s + | end + |end") + (goto-char (point-min)) + (forward-line 3) + (let ((case-fold-search t)) + (beginning-of-defun)) + (should (= 2 (line-number-at-pos))))) + +(ert-deftest ruby-end-of-defun-skips-to-next-line-after-the-method () + (ruby-with-temp-buffer + (ruby-test-string + "class D + | def tee + | 'ho hum' + | end + |end") + (goto-char (point-min)) + (forward-line 1) + (end-of-defun) + (should (= 5 (line-number-at-pos))))) + +(defvar ruby-sexp-test-example + (ruby-test-string + "class C + | def foo + | self.end + | D.new.class + | [1, 2, 3].map do |i| + | i + 1 + | end.sum + | end + |end")) + +(ert-deftest ruby-forward-sexp-skips-method-calls-with-keyword-names () + (ruby-with-temp-buffer ruby-sexp-test-example + (goto-line 2) + (ruby-forward-sexp) + (should (= 8 (line-number-at-pos))))) + +(ert-deftest ruby-backward-sexp-skips-method-calls-with-keyword-names () + (ruby-with-temp-buffer ruby-sexp-test-example + (goto-line 8) + (end-of-line) + (ruby-backward-sexp) + (should (= 2 (line-number-at-pos))))) + +(ert-deftest ruby--insert-coding-comment-ruby-style () + (with-temp-buffer + (let ((ruby-encoding-magic-comment-style 'ruby)) + (ruby--insert-coding-comment "utf-8") + (should (string= "# coding: utf-8\n" (buffer-string)))))) + +(ert-deftest ruby--insert-coding-comment-emacs-style () + (with-temp-buffer + (let ((ruby-encoding-magic-comment-style 'emacs)) + (ruby--insert-coding-comment "utf-8") + (should (string= "# -*- coding: utf-8 -*-\n" (buffer-string)))))) + +(ert-deftest ruby--insert-coding-comment-custom-style () + (with-temp-buffer + (let ((ruby-encoding-magic-comment-style 'custom) + (ruby-custom-encoding-magic-comment-template "# encoding: %s\n")) + (ruby--insert-coding-comment "utf-8") + (should (string= "# encoding: utf-8\n\n" (buffer-string)))))) + + +(provide 'ruby-mode-tests) + +;;; ruby-mode-tests.el ends here diff --git a/test/lisp/progmodes/subword-tests.el b/test/lisp/progmodes/subword-tests.el new file mode 100644 index 00000000000..5a562765bb1 --- /dev/null +++ b/test/lisp/progmodes/subword-tests.el @@ -0,0 +1,81 @@ +;;; subword-tests.el --- Testing the subword rules + +;; Copyright (C) 2011-2016 Free Software Foundation, Inc. + +;; Author: Stefan Monnier <monnier@iro.umontreal.ca> +;; Keywords: + +;; 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/>. + +;;; Commentary: + +;; + +;;; Code: + +(require 'ert) +(require 'subword) + +(defconst subword-tests-strings + '("ABC^" ;;Bug#13758 + "ABC^ ABC^Foo^ ABC^-Foo^ toto^ ABC^")) + +(ert-deftest subword-tests () + "Test the `subword-mode' rules." + (with-temp-buffer + (dolist (str subword-tests-strings) + (erase-buffer) + (insert str) + (goto-char (point-min)) + (while (search-forward "^" nil t) + (replace-match "")) + (goto-char (point-min)) + (while (not (eobp)) + (subword-forward 1) + (insert "^")) + (should (equal (buffer-string) str))))) + +(ert-deftest subword-tests2 () + "Test that motion in subword-mode stops at the right places." + + (let* ((line "fooBarBAZ quXD g_TESTThingAbc word BLAH test") + (fwrd "* * * * * * * * * * * * *") + (bkwd "* * * * * * * * * * * * *")) + + (with-temp-buffer + (subword-mode 1) + (insert line) + + ;; Test forward motion. + + (goto-char (point-min)) + (let ((stops (make-string (length fwrd) ?\ ))) + (while (progn + (aset stops (1- (point)) ?\*) + (not (eobp))) + (forward-word)) + (should (equal stops fwrd))) + + ;; Test backward motion. + + (goto-char (point-max)) + (let ((stops (make-string (length bkwd) ?\ ))) + (while (progn + (aset stops (1- (point)) ?\*) + (not (bobp))) + (backward-word)) + (should (equal stops bkwd)))))) + +(provide 'subword-tests) +;;; subword-tests.el ends here diff --git a/test/lisp/ps-print-tests.el b/test/lisp/ps-print-tests.el new file mode 100644 index 00000000000..67c3fbb67c4 --- /dev/null +++ b/test/lisp/ps-print-tests.el @@ -0,0 +1,36 @@ +;;; ps-print-tests.el --- Test suite for ps-print.el -*- lexical-binding: t; -*- + +;; Copyright (C) 2015 Free Software Foundation, Inc. + +;; Author: Phillip Lord <phillip.lord@russet.org.uk> + +;; 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: + +;;; Code: +(require 'ps-print) +(require 'ert) + +;;; Autoload tests +(ert-deftest ps-mule-autoload () + "Tests to see whether ps-mule has been autoloaded" + (should + (fboundp 'ps-mule-initialize)) + (should + (autoloadp + (symbol-function + 'ps-mule-initialize)))) diff --git a/test/lisp/replace-tests.el b/test/lisp/replace-tests.el new file mode 100644 index 00000000000..bfaab6c8944 --- /dev/null +++ b/test/lisp/replace-tests.el @@ -0,0 +1,35 @@ +;;; replace-tests.el --- tests for replace.el. + +;; Copyright (C) 2015-2016 Free Software Foundation, Inc. + +;; 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/>. + +;;; Code: + +(require 'ert) + +(ert-deftest query-replace--split-string-tests () + (let ((sep (propertize "\0" 'separator t))) + (dolist (before '("" "b")) + (dolist (after '("" "a")) + (should (equal + (query-replace--split-string (concat before sep after)) + (cons before after))) + (should (equal + (query-replace--split-string (concat before "\0" after)) + (concat before "\0" after))))))) + +;;; replace-tests.el ends here diff --git a/test/lisp/simple-tests.el b/test/lisp/simple-tests.el new file mode 100644 index 00000000000..12ebc75ea92 --- /dev/null +++ b/test/lisp/simple-tests.el @@ -0,0 +1,315 @@ +;;; simple-test.el --- Tests for simple.el -*- lexical-binding: t; -*- + +;; Copyright (C) 2015-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) + +(defmacro simple-test--dummy-buffer (&rest body) + (declare (indent 0) + (debug t)) + `(with-temp-buffer + (emacs-lisp-mode) + (setq indent-tabs-mode nil) + (insert "(a b") + (save-excursion (insert " c d)")) + ,@body + (cons (buffer-substring (point-min) (point)) + (buffer-substring (point) (point-max))))) + + +(defmacro simple-test--transpositions (&rest body) + (declare (indent 0) + (debug t)) + `(with-temp-buffer + (emacs-lisp-mode) + (insert "(s1) (s2) (s3) (s4) (s5)") + (backward-sexp 1) + ,@body + (cons (buffer-substring (point-min) (point)) + (buffer-substring (point) (point-max))))) + + +;;; `newline' +(ert-deftest newline () + (should-error (newline -1)) + (should (equal (simple-test--dummy-buffer (newline 1)) + '("(a b\n" . " c d)"))) + (should (equal (simple-test--dummy-buffer + (electric-indent-mode -1) + (call-interactively #'newline)) + '("(a b\n" . " c d)"))) + (should (equal (simple-test--dummy-buffer + (let ((current-prefix-arg 5)) + (call-interactively #'newline))) + '("(a b\n\n\n\n\n" . " c d)"))) + (should (equal (simple-test--dummy-buffer (newline 5)) + '("(a b\n\n\n\n\n" . " c d)"))) + (should (equal (simple-test--dummy-buffer + (forward-char 1) + (newline 1)) + '("(a b \n" . "c d)")))) + +(ert-deftest newline-indent () + (should (equal (simple-test--dummy-buffer + (electric-indent-local-mode 1) + (newline 1)) + '("(a b\n" . " c d)"))) + (should (equal (simple-test--dummy-buffer + (electric-indent-local-mode 1) + (newline 1 'interactive)) + '("(a b\n " . "c d)"))) + (should (equal (simple-test--dummy-buffer + (electric-indent-local-mode 1) + (let ((current-prefix-arg nil)) + (call-interactively #'newline) + (call-interactively #'newline))) + '("(a b\n\n " . "c d)"))) + (should (equal (simple-test--dummy-buffer + (electric-indent-local-mode 1) + (newline 5 'interactive)) + '("(a b\n\n\n\n\n " . "c d)"))) + (should (equal (simple-test--dummy-buffer + (electric-indent-local-mode 1) + (let ((current-prefix-arg 5)) + (call-interactively #'newline))) + '("(a b\n\n\n\n\n " . "c d)"))) + (should (equal (simple-test--dummy-buffer + (forward-char 1) + (electric-indent-local-mode 1) + (newline 1 'interactive)) + '("(a b\n " . "c d)")))) + + +;;; `open-line' +(ert-deftest open-line () + (should-error (open-line -1)) + (should-error (open-line)) + (should (equal (simple-test--dummy-buffer (open-line 1)) + '("(a b" . "\n c d)"))) + (should (equal (simple-test--dummy-buffer + (electric-indent-mode -1) + (call-interactively #'open-line)) + '("(a b" . "\n c d)"))) + (should (equal (simple-test--dummy-buffer + (let ((current-prefix-arg 5)) + (call-interactively #'open-line))) + '("(a b" . "\n\n\n\n\n c d)"))) + (should (equal (simple-test--dummy-buffer (open-line 5)) + '("(a b" . "\n\n\n\n\n c d)"))) + (should (equal (simple-test--dummy-buffer + (forward-char 1) + (open-line 1)) + '("(a b " . "\nc d)")))) + +(ert-deftest open-line-margin-and-prefix () + (should (equal (simple-test--dummy-buffer + (let ((left-margin 10)) + (open-line 3))) + '("(a b" . "\n\n\n c d)"))) + (should (equal (simple-test--dummy-buffer + (forward-line 0) + (let ((left-margin 2)) + (open-line 1))) + '(" " . "\n (a b c d)"))) + (should (equal (simple-test--dummy-buffer + (let ((fill-prefix "- - ")) + (open-line 1))) + '("(a b" . "\n c d)"))) + (should (equal (simple-test--dummy-buffer + (forward-line 0) + (let ((fill-prefix "- - ")) + (open-line 1))) + '("- - " . "\n(a b c d)")))) + +;; For a while, from 24 Oct - 21 Nov 2015, `open-line' in the Emacs +;; development tree became sensitive to `electric-indent-mode', which +;; it had not been before. This sensitivity was reverted for the +;; Emacs 25 release, so it could be discussed further (see thread +;; "Questioning the new behavior of `open-line'." on the Emacs Devel +;; mailing list, and bug #21884). +(ert-deftest open-line-indent () + (should (equal (simple-test--dummy-buffer + (electric-indent-local-mode 1) + (open-line 1)) + '("(a b" . "\n c d)"))) + (should (equal (simple-test--dummy-buffer + (electric-indent-local-mode 1) + (open-line 1)) + '("(a b" . "\n c d)"))) + (should (equal (simple-test--dummy-buffer + (electric-indent-local-mode 1) + (let ((current-prefix-arg nil)) + (call-interactively #'open-line) + (call-interactively #'open-line))) + '("(a b" . "\n\n c d)"))) + (should (equal (simple-test--dummy-buffer + (electric-indent-local-mode 1) + (open-line 5)) + '("(a b" . "\n\n\n\n\n c d)"))) + (should (equal (simple-test--dummy-buffer + (electric-indent-local-mode 1) + (let ((current-prefix-arg 5)) + (call-interactively #'open-line))) + '("(a b" . "\n\n\n\n\n c d)"))) + (should (equal (simple-test--dummy-buffer + (forward-char 1) + (electric-indent-local-mode 1) + (open-line 1)) + '("(a b " . "\nc d)")))) + +;; From 24 Oct - 21 Nov 2015, `open-line' took a second argument +;; INTERACTIVE and ran `post-self-insert-hook' if the argument was +;; true. This test tested that. Currently, however, `open-line' +;; does not run run `post-self-insert-hook' at all, so for now +;; this test just makes sure that it doesn't. +(ert-deftest open-line-hook () + (let* ((x 0) + (inc (lambda () (setq x (1+ x))))) + (simple-test--dummy-buffer + (add-hook 'post-self-insert-hook inc nil 'local) + (open-line 1)) + (should (= x 0)) + (simple-test--dummy-buffer + (add-hook 'post-self-insert-hook inc nil 'local) + (open-line 1)) + (should (= x 0)) + + (unwind-protect + (progn + (add-hook 'post-self-insert-hook inc) + (simple-test--dummy-buffer + (open-line 1)) + (should (= x 0)) + (simple-test--dummy-buffer + (open-line 10)) + (should (= x 0))) + (remove-hook 'post-self-insert-hook inc)))) + + +;;; `delete-trailing-whitespace' +(ert-deftest simple-delete-trailing-whitespace () + "Test bug#21766: delete-whitespace sometimes deletes non-whitespace." + (defvar python-indent-guess-indent-offset) ; to avoid a warning + (let ((python (featurep 'python)) + (python-indent-guess-indent-offset nil) + (delete-trailing-lines t)) + (unwind-protect + (with-temp-buffer + (python-mode) + (insert (concat "query = \"\"\"WITH filtered AS \n" + "WHERE \n" + "\"\"\".format(fv_)\n" + "\n" + "\n")) + (delete-trailing-whitespace) + (should (equal (count-lines (point-min) (point-max)) 3))) + ;; Let's clean up if running interactive + (unless (or noninteractive python) + (unload-feature 'python))))) + + +;;; auto-boundary tests +(ert-deftest undo-auto-boundary-timer () + (should + undo-auto-current-boundary-timer)) + +(ert-deftest undo-auto--boundaries-added () + ;; The change in the buffer should have caused addition + ;; to undo-auto--undoably-changed-buffers. + (should + (with-temp-buffer + (setq buffer-undo-list nil) + (insert "hello") + (member (current-buffer) undo-auto--undoably-changed-buffers))) + ;; The head of buffer-undo-list should be the insertion event, and + ;; therefore not nil + (should + (with-temp-buffer + (setq buffer-undo-list nil) + (insert "hello") + (car buffer-undo-list))) + ;; Now the head of the buffer-undo-list should be a boundary and so + ;; nil. We have to call auto-boundary explicitly because we are out + ;; of the command loop + (should-not + (with-temp-buffer + (setq buffer-undo-list nil) + (insert "hello") + (car buffer-undo-list) + (undo-auto--boundaries 'test)))) + +;;; Transposition with negative args (bug#20698, bug#21885) +(ert-deftest simple-transpose-subr () + (should (equal (simple-test--transpositions (transpose-sexps -1)) + '("(s1) (s2) (s4)" . " (s3) (s5)"))) + (should (equal (simple-test--transpositions (transpose-sexps -2)) + '("(s1) (s4)" . " (s2) (s3) (s5)")))) + + +;; Test for a regression introduced by undo-auto--boundaries changes. +;; https://lists.gnu.org/archive/html/emacs-devel/2015-11/msg01652.html +(defun undo-test-kill-c-a-then-undo () + (with-temp-buffer + (switch-to-buffer (current-buffer)) + (setq buffer-undo-list nil) + (insert "a\nb\n\c\n") + (goto-char (point-max)) + ;; We use a keyboard macro because it adds undo events in the same + ;; way as if a user were involved. + (kmacro-call-macro nil nil nil + [left + ;; Delete "c" + backspace + left left left + ;; Delete "a" + backspace + ;; C-/ or undo + 67108911 + ]) + (point))) + +(defun undo-test-point-after-forward-kill () + (with-temp-buffer + (switch-to-buffer (current-buffer)) + (setq buffer-undo-list nil) + (insert "kill word forward") + ;; Move to word "word". + (goto-char 6) + (kmacro-call-macro nil nil nil + [ + ;; kill-word + C-delete + ;; undo + 67108911 + ]) + (point))) + +(ert-deftest undo-point-in-wrong-place () + (should + ;; returns 5 with the bug + (= 2 + (undo-test-kill-c-a-then-undo))) + (should + (= 6 + (undo-test-point-after-forward-kill)))) + + +(provide 'simple-test) +;;; simple-test.el ends here diff --git a/test/lisp/sort-tests.el b/test/lisp/sort-tests.el new file mode 100644 index 00000000000..52973297818 --- /dev/null +++ b/test/lisp/sort-tests.el @@ -0,0 +1,106 @@ +;;; sort-tests.el --- Tests for sort.el -*- lexical-binding: t; -*- + +;; Copyright (C) 2015-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 'sort) + +(defun sort-tests-random-word (n) + (mapconcat (lambda (_) (string (let ((c (random 52))) + (+ (if (> c 25) 71 65) + c)))) + (make-list n nil) "")) + +(defun sort-tests--insert-words-sort-and-compare (words separator function reverse less-predicate) + (with-temp-buffer + (let ((aux words)) + (while aux + (insert (pop aux)) + (when aux + (insert separator)))) + ;; Final newline. + (insert "\n") + (funcall function reverse (point-min) (point-max)) + (let ((sorted-words + (mapconcat #'identity + (let ((x (sort (copy-sequence words) less-predicate))) + (if reverse (reverse x) x)) + separator))) + (should (string= (substring (buffer-string) 0 -1) sorted-words))))) + +;;; This function uses randomly generated tests and should satisfy +;;; most needs for this lib. +(cl-defun sort-tests-test-sorter-function (separator function &key generator less-pred noreverse) + "Check that FUNCTION correctly sorts words separated by SEPARATOR. +This checks whether it is equivalent to sorting a list of such +words via LESS-PREDICATE, and then inserting them separated by +SEPARATOR. +LESS-PREDICATE defaults to `string-lessp'. +GENERATOR is a function called with one argument that returns a +word, it defaults to `sort-tests-random-word'. +NOREVERSE means that the first arg of FUNCTION is not used for +reversing the sort." + (dotimes (n 20) + ;; Sort n words of length n. + (let ((words (mapcar (or generator #'sort-tests-random-word) (make-list n n))) + (sort-fold-case nil) + (less-pred (or less-pred #'string<))) + (sort-tests--insert-words-sort-and-compare words separator function nil less-pred) + (unless noreverse + (sort-tests--insert-words-sort-and-compare + words separator function 'reverse less-pred)) + (let ((less-pred-case (lambda (a b) (funcall less-pred (downcase a) (downcase b)))) + (sort-fold-case t)) + (sort-tests--insert-words-sort-and-compare words separator function nil less-pred-case) + (unless noreverse + (sort-tests--insert-words-sort-and-compare + words separator function 'reverse less-pred-case)))))) + +(ert-deftest sort-tests--lines () + (sort-tests-test-sorter-function "\n" #'sort-lines)) + +(ert-deftest sort-tests--paragraphs () + (let ((paragraph-separate "[\s\t\f]*$")) + (sort-tests-test-sorter-function "\n\n" #'sort-paragraphs))) + +(ert-deftest sort-tests--numeric-fields () + (cl-labels ((field-to-number (f) (string-to-number (car (split-string f))))) + (sort-tests-test-sorter-function "\n" (lambda (_ l r) (sort-numeric-fields 1 l (1- r))) + :noreverse t + :generator (lambda (_) (format "%s %s" (random) (sort-tests-random-word 20))) + :less-pred (lambda (a b) (< (field-to-number a) + (field-to-number b)))))) + +(ert-deftest sort-tests--fields-1 () + (cl-labels ((field-n (f n) (elt (split-string f) (1- n)))) + (sort-tests-test-sorter-function "\n" (lambda (_ l r) (sort-fields 1 l (1- r))) + :noreverse t + :generator (lambda (n) (concat (sort-tests-random-word n) " " (sort-tests-random-word n))) + :less-pred (lambda (a b) (string< (field-n a 1) (field-n b 1)))))) + +(ert-deftest sort-tests--fields-2 () + (cl-labels ((field-n (f n) (elt (split-string f) (1- n)))) + (sort-tests-test-sorter-function "\n" (lambda (_ l r) (sort-fields 2 l (1- r))) + :noreverse t + :generator (lambda (n) (concat (sort-tests-random-word n) " " (sort-tests-random-word n))) + :less-pred (lambda (a b) (string< (field-n a 2) (field-n b 2)))))) + +(provide 'sort-tests) +;;; sort-tests.el ends here diff --git a/test/lisp/subr-tests.el b/test/lisp/subr-tests.el new file mode 100644 index 00000000000..7906a207a96 --- /dev/null +++ b/test/lisp/subr-tests.el @@ -0,0 +1,219 @@ +;;; subr-tests.el --- Tests for subr.el + +;; Copyright (C) 2015-2016 Free Software Foundation, Inc. + +;; Author: Oleh Krehel <ohwoeowho@gmail.com>, +;; Nicolas Petton <nicolas@petton.fr> +;; Keywords: + +;; 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: + +;; + +;;; Code: + +(require 'ert) + +(ert-deftest let-when-compile () + ;; good case + (should (equal (macroexpand '(let-when-compile ((foo (+ 2 3))) + (setq bar (eval-when-compile (+ foo foo))) + (setq boo (eval-when-compile (* foo foo))))) + '(progn + (setq bar (quote 10)) + (setq boo (quote 25))))) + ;; bad case: `eval-when-compile' omitted, byte compiler should catch this + (should (equal (macroexpand + '(let-when-compile ((foo (+ 2 3))) + (setq bar (+ foo foo)) + (setq boo (eval-when-compile (* foo foo))))) + '(progn + (setq bar (+ foo foo)) + (setq boo (quote 25))))) + ;; something practical + (should (equal (macroexpand + '(let-when-compile ((keywords '("true" "false"))) + (font-lock-add-keywords + 'c++-mode + `((,(eval-when-compile + (format "\\<%s\\>" (regexp-opt keywords))) + 0 font-lock-keyword-face))))) + '(font-lock-add-keywords + (quote c++-mode) + (list + (cons (quote + "\\<\\(?:\\(?:fals\\|tru\\)e\\)\\>") + (quote + (0 font-lock-keyword-face)))))))) + +(ert-deftest string-comparison-test () + (should (string-lessp "abc" "acb")) + (should (string-lessp "aBc" "abc")) + (should (string-lessp "abc" "abcd")) + (should (string-lessp "abc" "abcd")) + (should-not (string-lessp "abc" "abc")) + (should-not (string-lessp "" "")) + + (should (string-greaterp "acb" "abc")) + (should (string-greaterp "abc" "aBc")) + (should (string-greaterp "abcd" "abc")) + (should (string-greaterp "abcd" "abc")) + (should-not (string-greaterp "abc" "abc")) + (should-not (string-greaterp "" "")) + + ;; Symbols are also accepted + (should (string-lessp 'abc 'acb)) + (should (string-lessp "abc" 'acb)) + (should (string-greaterp 'acb 'abc)) + (should (string-greaterp "acb" 'abc))) + +(ert-deftest subr-test-when () + (should (equal (when t 1) 1)) + (should (equal (when t 2) 2)) + (should (equal (when nil 1) nil)) + (should (equal (when nil 2) nil)) + (should (equal (when t 'x 1) 1)) + (should (equal (when t 'x 2) 2)) + (should (equal (when nil 'x 1) nil)) + (should (equal (when nil 'x 2) nil)) + (let ((x 1)) + (should-not (when nil + (setq x (1+ x)) + x)) + (should (= x 1)) + (should (= 2 (when t + (setq x (1+ x)) + x))) + (should (= x 2))) + (should (equal (macroexpand-all '(when a b c d)) + '(if a (progn b c d))))) + +(ert-deftest subr-test-version-parsing () + (should (equal (version-to-list ".5") '(0 5))) + (should (equal (version-to-list "0.9 alpha1") '(0 9 -3 1))) + (should (equal (version-to-list "0.9 snapshot") '(0 9 -4))) + (should (equal (version-to-list "0.9-alpha1") '(0 9 -3 1))) + (should (equal (version-to-list "0.9-snapshot") '(0 9 -4))) + (should (equal (version-to-list "0.9.snapshot") '(0 9 -4))) + (should (equal (version-to-list "0.9_snapshot") '(0 9 -4))) + (should (equal (version-to-list "0.9alpha1") '(0 9 -3 1))) + (should (equal (version-to-list "0.9snapshot") '(0 9 -4))) + (should (equal (version-to-list "1.0 git") '(1 0 -4))) + (should (equal (version-to-list "1.0 pre2") '(1 0 -1 2))) + (should (equal (version-to-list "1.0-git") '(1 0 -4))) + (should (equal (version-to-list "1.0-pre2") '(1 0 -1 2))) + (should (equal (version-to-list "1.0.1-a") '(1 0 1 1))) + (should (equal (version-to-list "1.0.1-f") '(1 0 1 6))) + (should (equal (version-to-list "1.0.1.a") '(1 0 1 1))) + (should (equal (version-to-list "1.0.1.f") '(1 0 1 6))) + (should (equal (version-to-list "1.0.1_a") '(1 0 1 1))) + (should (equal (version-to-list "1.0.1_f") '(1 0 1 6))) + (should (equal (version-to-list "1.0.1a") '(1 0 1 1))) + (should (equal (version-to-list "1.0.1f") '(1 0 1 6))) + (should (equal (version-to-list "1.0.7.5") '(1 0 7 5))) + (should (equal (version-to-list "1.0.git") '(1 0 -4))) + (should (equal (version-to-list "1.0.pre2") '(1 0 -1 2))) + (should (equal (version-to-list "1.0_git") '(1 0 -4))) + (should (equal (version-to-list "1.0_pre2") '(1 0 -1 2))) + (should (equal (version-to-list "1.0git") '(1 0 -4))) + (should (equal (version-to-list "1.0pre2") '(1 0 -1 2))) + (should (equal (version-to-list "22.8 beta3") '(22 8 -2 3))) + (should (equal (version-to-list "22.8-beta3") '(22 8 -2 3))) + (should (equal (version-to-list "22.8.beta3") '(22 8 -2 3))) + (should (equal (version-to-list "22.8_beta3") '(22 8 -2 3))) + (should (equal (version-to-list "22.8beta3") '(22 8 -2 3))) + (should (equal (version-to-list "6.9.30 Beta") '(6 9 30 -2))) + (should (equal (version-to-list "6.9.30-Beta") '(6 9 30 -2))) + (should (equal (version-to-list "6.9.30.Beta") '(6 9 30 -2))) + (should (equal (version-to-list "6.9.30Beta") '(6 9 30 -2))) + (should (equal (version-to-list "6.9.30_Beta") '(6 9 30 -2))) + + (should (equal + (error-message-string (should-error (version-to-list "OTP-18.1.5"))) + "Invalid version syntax: `OTP-18.1.5' (must start with a number)")) + (should (equal + (error-message-string (should-error (version-to-list ""))) + "Invalid version syntax: `' (must start with a number)")) + (should (equal + (error-message-string (should-error (version-to-list "1.0..7.5"))) + "Invalid version syntax: `1.0..7.5'")) + (should (equal + (error-message-string (should-error (version-to-list "1.0prepre2"))) + "Invalid version syntax: `1.0prepre2'")) + (should (equal + (error-message-string (should-error (version-to-list "22.8X3"))) + "Invalid version syntax: `22.8X3'")) + (should (equal + (error-message-string (should-error (version-to-list "beta22.8alpha3"))) + "Invalid version syntax: `beta22.8alpha3' (must start with a number)")) + (should (equal + (error-message-string (should-error (version-to-list "honk"))) + "Invalid version syntax: `honk' (must start with a number)")) + (should (equal + (error-message-string (should-error (version-to-list 9))) + "Version must be a string")) + + (let ((version-separator "_")) + (should (equal (version-to-list "_5") '(0 5))) + (should (equal (version-to-list "0_9 alpha1") '(0 9 -3 1))) + (should (equal (version-to-list "0_9 snapshot") '(0 9 -4))) + (should (equal (version-to-list "0_9-alpha1") '(0 9 -3 1))) + (should (equal (version-to-list "0_9-snapshot") '(0 9 -4))) + (should (equal (version-to-list "0_9.alpha1") '(0 9 -3 1))) + (should (equal (version-to-list "0_9.snapshot") '(0 9 -4))) + (should (equal (version-to-list "0_9alpha1") '(0 9 -3 1))) + (should (equal (version-to-list "0_9snapshot") '(0 9 -4))) + (should (equal (version-to-list "1_0 git") '(1 0 -4))) + (should (equal (version-to-list "1_0 pre2") '(1 0 -1 2))) + (should (equal (version-to-list "1_0-git") '(1 0 -4))) + (should (equal (version-to-list "1_0.pre2") '(1 0 -1 2))) + (should (equal (version-to-list "1_0_1-a") '(1 0 1 1))) + (should (equal (version-to-list "1_0_1-f") '(1 0 1 6))) + (should (equal (version-to-list "1_0_1.a") '(1 0 1 1))) + (should (equal (version-to-list "1_0_1.f") '(1 0 1 6))) + (should (equal (version-to-list "1_0_1_a") '(1 0 1 1))) + (should (equal (version-to-list "1_0_1_f") '(1 0 1 6))) + (should (equal (version-to-list "1_0_1a") '(1 0 1 1))) + (should (equal (version-to-list "1_0_1f") '(1 0 1 6))) + (should (equal (version-to-list "1_0_7_5") '(1 0 7 5))) + (should (equal (version-to-list "1_0_git") '(1 0 -4))) + (should (equal (version-to-list "1_0pre2") '(1 0 -1 2))) + (should (equal (version-to-list "22_8 beta3") '(22 8 -2 3))) + (should (equal (version-to-list "22_8-beta3") '(22 8 -2 3))) + (should (equal (version-to-list "22_8.beta3") '(22 8 -2 3))) + (should (equal (version-to-list "22_8beta3") '(22 8 -2 3))) + (should (equal (version-to-list "6_9_30 Beta") '(6 9 30 -2))) + (should (equal (version-to-list "6_9_30-Beta") '(6 9 30 -2))) + (should (equal (version-to-list "6_9_30.Beta") '(6 9 30 -2))) + (should (equal (version-to-list "6_9_30Beta") '(6 9 30 -2))) + + (should (equal + (error-message-string (should-error (version-to-list "1_0__7_5"))) + "Invalid version syntax: `1_0__7_5'")) + (should (equal + (error-message-string (should-error (version-to-list "1_0prepre2"))) + "Invalid version syntax: `1_0prepre2'")) + (should (equal + (error-message-string (should-error (version-to-list "22.8X3"))) + "Invalid version syntax: `22.8X3'")) + (should (equal + (error-message-string (should-error (version-to-list "beta22_8alpha3"))) + "Invalid version syntax: `beta22_8alpha3' (must start with a number)")))) + +(provide 'subr-tests) +;;; subr-tests.el ends here diff --git a/test/lisp/textmodes/reftex-tests.el b/test/lisp/textmodes/reftex-tests.el new file mode 100644 index 00000000000..12ec7f5a394 --- /dev/null +++ b/test/lisp/textmodes/reftex-tests.el @@ -0,0 +1,223 @@ +;;; reftex-tests.el --- Test suite for reftex. -*- lexical-binding: t -*- + +;; Copyright (C) 2013-2016 Free Software Foundation, Inc. + +;; Author: Rüdiger Sonderfeld <ruediger@c-plusplus.de> +;; Keywords: internal +;; Human-Keywords: internal + +;; 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/>. + +;;; Code: + +(require 'ert) + +;;; reftex +(require 'reftex) + +;;; reftex-parse +(require 'reftex-parse) + +(ert-deftest reftex-locate-bibliography-files () + "Test `reftex-locate-bibliography-files'." + (let ((temp-dir (make-temp-file "reftex-bib" 'dir)) + (files '("ref1.bib" "ref2.bib")) + (test '(("\\addbibresource{ref1.bib}\n" . ("ref1.bib")) + ("\\\\addbibresource[label=x]{ref2.bib}\\n" . ("ref2.bib")) + ("\\begin{document}\n\\bibliographystyle{plain}\n +\\bibliography{ref1,ref2}\n\\end{document}" . ("ref1.bib" "ref2.bib")))) + (reftex-bibliography-commands + ;; Default value: See reftex-vars.el `reftex-bibliography-commands' + '("bibliography" "nobibliography" "setupbibtex\\[.*?database=" + "addbibresource"))) + (with-temp-buffer + (insert "test\n") + (mapc + (lambda (file) + (write-region (point-min) (point-max) (expand-file-name file + temp-dir))) + files)) + (mapc + (lambda (data) + (with-temp-buffer + (insert (car data)) + (let ((res (mapcar #'file-name-nondirectory + (reftex-locate-bibliography-files temp-dir)))) + (should (equal res (cdr data)))))) + test) + (delete-directory temp-dir 'recursive))) + +(ert-deftest reftex-what-environment-test () + "Test `reftex-what-environment'." + (with-temp-buffer + (insert "\\begin{equation}\n x=y^2\n") + (let ((pt (point)) + pt2) + (insert "\\end{equation}\n") + (goto-char pt) + + (should (equal (reftex-what-environment 1) '("equation" . 1))) + (should (equal (reftex-what-environment t) '(("equation" . 1)))) + + (insert "\\begin{something}\nxxx") + (setq pt2 (point)) + (insert "\\end{something}") + (goto-char pt2) + (should (equal (reftex-what-environment 1) `("something" . ,pt))) + (should (equal (reftex-what-environment t) `(("something" . ,pt) + ("equation" . 1)))) + (should (equal (reftex-what-environment t pt) `(("something" . ,pt)))) + (should (equal (reftex-what-environment '("equation")) + '("equation" . 1)))))) + +(ert-deftest reftex-roman-number-test () + "Test `reftex-roman-number'." + (let ((hindu-arabic '(1 2 4 9 14 1050)) + (roman '("I" "II" "IV" "IX" "XIV" "ML"))) + (while (and hindu-arabic roman) + (should (string= (reftex-roman-number (car hindu-arabic)) + (car roman))) + (pop roman) + (pop hindu-arabic)))) + +(ert-deftest reftex-parse-from-file-test () + "Test `reftex-parse-from-file'." + ;; Use file-truename to convert 8+3 aliases in $TEMP value on + ;; MS-Windows into their long file-name equivalents, which is + ;; necessary for the 'equal' and 'string=' comparisons below. This + ;; also resolves any symlinks, which cannot be bad for the same + ;; reason. (An alternative solution would be to use file-equal-p, + ;; but I'm too lazy to do that, as one of the tests compares a + ;; list.) + (let* ((temp-dir (file-truename (make-temp-file "reftex-parse" 'dir))) + (tex-file (expand-file-name "test.tex" temp-dir)) + (bib-file (expand-file-name "ref.bib" temp-dir))) + (with-temp-buffer + (insert +"\\begin{document} +\\section{test}\\label{sec:test} +\\subsection{subtest} + +\\begin{align*}\\label{eq:foo} + x &= y^2 +\\end{align*} + +\\bibliographystyle{plain} +\\bibliography{ref} +\\end{document}") + (write-region (point-min) (point-max) tex-file)) + (with-temp-buffer + (insert "test\n") + (write-region (point-min) (point-max) bib-file)) + (reftex-ensure-compiled-variables) + (let ((parsed (reftex-parse-from-file tex-file nil temp-dir))) + (should (equal (car parsed) `(eof ,tex-file))) + (pop parsed) + (while parsed + (let ((entry (pop parsed))) + (cond + ((eq (car entry) 'bib) + (should (string= (cadr entry) bib-file))) + ((eq (car entry) 'toc)) ;; ... + ((string= (car entry) "eq:foo")) + ((string= (car entry) "sec:test")) + ((eq (car entry) 'bof) + (should (string= (cadr entry) tex-file)) + (should (null parsed))) + (t (should-not t))))) + (delete-directory temp-dir 'recursive)))) + +;;; reftex-cite +(require 'reftex-cite) + +(ert-deftest reftex-parse-bibtex-entry-test () + "Test `reftex-parse-bibtex-entry'." + (let ((entry "@Book{Stallman12, + author = {Richard Stallman\net al.}, + title = {The Emacs Editor}, + publisher = {GNU Press}, + year = 2012, + edition = {17th}, + note = {Updated for Emacs Version 24.2} +}") + (check (function + (lambda (parsed) + (should (string= (reftex-get-bib-field "&key" parsed) + "Stallman12")) + (should (string= (reftex-get-bib-field "&type" parsed) + "book")) + (should (string= (reftex-get-bib-field "author" parsed) + "Richard Stallman et al.")) + (should (string= (reftex-get-bib-field "title" parsed) + "The Emacs Editor")) + (should (string= (reftex-get-bib-field "publisher" parsed) + "GNU Press")) + (should (string= (reftex-get-bib-field "year" parsed) + "2012")) + (should (string= (reftex-get-bib-field "edition" parsed) + "17th")) + (should (string= (reftex-get-bib-field "note" parsed) + "Updated for Emacs Version 24.2")))))) + (funcall check (reftex-parse-bibtex-entry entry)) + (with-temp-buffer + (insert entry) + (funcall check (reftex-parse-bibtex-entry nil (point-min) + (point-max)))))) + +(ert-deftest reftex-get-bib-names-test () + "Test `reftex-get-bib-names'." + (let ((entry (reftex-parse-bibtex-entry "@article{Foo123, + author = {Jane Roe and\tJohn Doe and W. Public}, +}"))) + (should (equal (reftex-get-bib-names "author" entry) + '("Jane Roe" "John Doe" "Public")))) + (let ((entry (reftex-parse-bibtex-entry "@article{Foo123, + editor = {Jane Roe and\tJohn Doe and W. Public}, +}"))) + (should (equal (reftex-get-bib-names "author" entry) + '("Jane Roe" "John Doe" "Public"))))) + +(ert-deftest reftex-format-citation-test () + "Test `reftex-format-citation'." + (let ((entry (reftex-parse-bibtex-entry +"@article{Foo13, + author = {Jane Roe and John Doe and Jane Q. Taxpayer}, + title = {Some Article}, + journal = {Some Journal}, + year = 2013, + pages = {1--333} +}"))) + (should (string= (reftex-format-citation entry nil) "\\cite{Foo13}")) + (should (string= (reftex-format-citation entry "%l:%A:%y:%t %j %P %a") + "Foo13:Jane Roe:2013:Some Article Some Journal 1 Jane Roe, John Doe \\& Jane Taxpayer")))) + + +;;; Autoload tests + +;; Test to check whether reftex autoloading mechanisms are working +;; correctly. +(ert-deftest reftex-autoload-auc () + "Tests to see whether reftex-auc has been autoloaded" + (should + (fboundp 'reftex-arg-label)) + (should + (autoloadp + (symbol-function + 'reftex-arg-label)))) + + +(provide 'reftex-tests) +;;; reftex-tests.el ends here. diff --git a/test/lisp/textmodes/sgml-mode-tests.el b/test/lisp/textmodes/sgml-mode-tests.el new file mode 100644 index 00000000000..4184e2c3802 --- /dev/null +++ b/test/lisp/textmodes/sgml-mode-tests.el @@ -0,0 +1,135 @@ +;;; sgml-mode-tests.el --- Tests for sgml-mode + +;; Copyright (C) 2015-2016 Free Software Foundation, Inc. + +;; Author: Przemysław Wojnowski <esperanto@cumego.com> +;; Keywords: tests + +;; 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: + +;;; Code: + +(require 'sgml-mode) +(require 'ert) + +(defmacro sgml-with-content (content &rest body) + "Insert CONTENT into a temporary `sgml-mode' buffer and execute BODY on it. +The point is set to the beginning of the buffer." + `(with-temp-buffer + (sgml-mode) + (insert ,content) + (goto-char (point-min)) + ,@body)) + +;;; sgml-delete-tag + +(ert-deftest sgml-delete-tag-should-not-delete-tags-when-wrong-args () + "Don't delete tag, when number of tags to delete is not positive number." + (let ((content "<p>Valar Morghulis</p>")) + (sgml-with-content + content + (sgml-delete-tag -1) + (should (string= content (buffer-string))) + (sgml-delete-tag 0) + (should (string= content (buffer-string)))))) + +(ert-deftest sgml-delete-tag-should-delete-tags-n-times () + ;; Delete only 1, when 1 available: + (sgml-with-content + "<br />" + (sgml-delete-tag 1) + (should (string= "" (buffer-string)))) + ;; Delete from position on whitespaces before tag: + (sgml-with-content + " \t\n<br />" + (sgml-delete-tag 1) + (should (string= "" (buffer-string)))) + ;; Delete from position on tag: + (sgml-with-content + "<br />" + (goto-char 3) + (sgml-delete-tag 1) + (should (string= "" (buffer-string)))) + ;; Delete one by one: + (sgml-with-content + "<h1><p>You know nothing, Jon Snow.</p></h1>" + (sgml-delete-tag 1) + (should (string= "<p>You know nothing, Jon Snow.</p>" (buffer-string))) + (sgml-delete-tag 1) + (should (string= "You know nothing, Jon Snow." (buffer-string)))) + ;; Delete 2 at a time, when 2 available: + (sgml-with-content + "<h1><p>You know nothing, Jon Snow.</p></h1>" + (sgml-delete-tag 2) + (should (string= "You know nothing, Jon Snow." (buffer-string))))) + +(ert-deftest sgml-delete-tag-should-delete-unclosed-tag () + (sgml-with-content + "<ul><li>Keep your stones connected.</ul>" + (goto-char 5) ; position on "li" tag + (sgml-delete-tag 1) + (should (string= "<ul>Keep your stones connected.</ul>" (buffer-string))))) + +(ert-deftest sgml-delete-tag-should-signal-error-for-malformed-tags () + (let ((content "<h1><h2>Drakaris!</h1></h2>")) + ;; Delete outside tag: + (sgml-with-content + content + (sgml-delete-tag 1) + (should (string= "<h2>Drakaris!</h2>" (buffer-string)))) + ;; Delete inner tag: + (sgml-with-content + content + (goto-char 5) ; position the inner tag + (sgml-delete-tag 1) + (should (string= "<h1>Drakaris!</h1>" (buffer-string)))))) + +(ert-deftest sgml-delete-tag-should-signal-error-when-deleting-too-much () + (let ((content "<emph>Drakaris!</emph>")) + ;; No tags to delete: + (sgml-with-content + "Drakaris!" + (should-error (sgml-delete-tag 1) :type 'error) + (should (string= "Drakaris!" (buffer-string)))) + ;; Trying to delete 2 tags, when only 1 available: + (sgml-with-content + content + (should-error (sgml-delete-tag 2) :type 'error) + (should (string= "Drakaris!" (buffer-string)))) + ;; Trying to delete a tag, but not on/before a tag: + (sgml-with-content + content + (goto-char 7) ; D in Drakaris + (should-error (sgml-delete-tag 1) :type 'error) + (should (string= content (buffer-string)))) + ;; Trying to delete a tag from position outside tag: + (sgml-with-content + content + (goto-char (point-max)) + (should-error (sgml-delete-tag 1) :type 'error) + (should (string= content (buffer-string)))))) + +(ert-deftest sgml-delete-tag-bug-8203-should-not-delete-apostrophe () + :expected-result :failed + (sgml-with-content + "<title>Winter is comin'</title>" + (sgml-delete-tag 1) + (should (string= "Winter is comin'" (buffer-string))))) + +(provide 'sgml-mode-tests) +;;; sgml-mode-tests.el ends here diff --git a/test/lisp/textmodes/tildify-tests.el b/test/lisp/textmodes/tildify-tests.el new file mode 100644 index 00000000000..8b50cf72868 --- /dev/null +++ b/test/lisp/textmodes/tildify-tests.el @@ -0,0 +1,264 @@ +;;; tildify-test.el --- ERT tests for tildify.el -*- lexical-binding: t -*- + +;; Copyright (C) 2014-2016 Free Software Foundation, Inc. + +;; Author: Michal Nazarewicz <mina86@mina86.com> +;; Version: 4.5 +;; Keywords: text, TeX, SGML, wp + +;; 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: + +;; This package defines regression tests for the tildify package. + +;;; Code: + +(require 'ert) +(require 'tildify) + +(defun tildify-test--example-sentence (space) + "Return an example sentence with SPACE where hard space is required." + (concat "Lorem ipsum v" space "dolor sit amet, a" space + "consectetur adipiscing elit.")) + + +(defun tildify-test--example-html (sentence &optional with-nbsp is-xml) + "Return an example HTML code. +SENTENCE is placed where spaces should not be replaced with hard spaces, and +WITH-NBSP is placed where spaces should be replaced with hard spaces. If the +latter is missing, SENTENCE will be used in all placeholder positions. +If IS-XML is non-nil, <pre> tag is not treated specially." + (let ((with-nbsp (or with-nbsp sentence))) + (concat "<p>" with-nbsp "</p>\n" + "<pre>" (if is-xml with-nbsp sentence) "</pre>\n" + "<! -- " sentence " -- >\n" + "<p>" with-nbsp "</p>\n" + "<" sentence ">\n"))) + + +(defun tildify-test--test (modes input expected) + "Test tildify running in MODES. +INPUT is the initial content of the buffer and EXPECTED is expected result +after `tildify-buffer' is run." + (with-temp-buffer + (setq-local buffer-file-coding-system 'utf-8) + (dolist (mode modes) + (erase-buffer) + (funcall mode) + (let ((header (concat "Testing `tildify-buffer' in " + (symbol-name mode) "\n"))) + (insert header input) + (tildify-buffer t) + (should (string-equal (concat header expected) (buffer-string)))) + (erase-buffer) + (let ((header (concat "Testing `tildify-region' in " + (symbol-name mode) "\n"))) + (insert header input) + (tildify-region (point-min) (point-max) t) + (should (string-equal (concat header expected) (buffer-string))))))) + +(ert-deftest tildify-test-html () + "Tests tildification in an HTML document" + (let* ((sentence (tildify-test--example-sentence " ")) + (with-nbsp (tildify-test--example-sentence " "))) + (tildify-test--test '(html-mode sgml-mode) + (tildify-test--example-html sentence sentence) + (tildify-test--example-html sentence with-nbsp)))) + +(ert-deftest tildify-test-xml () + "Tests tildification in an XML document" + (let* ((sentence (tildify-test--example-sentence " ")) + (with-nbsp (tildify-test--example-sentence " "))) + (tildify-test--test '(nxml-mode) + (tildify-test--example-html sentence sentence t) + (tildify-test--example-html sentence with-nbsp t)))) + + +(defun tildify-test--example-tex (sentence &optional with-nbsp) + "Return an example (La)Tex code. +SENTENCE is placed where spaces should not be replaced with hard spaces, and +WITH-NBSP is placed where spaces should be replaced with hard spaces. If the +latter is missing, SENTENCE will be used in all placeholder positions." + (let ((with-nbsp (or with-nbsp sentence))) + (concat with-nbsp "\n" + "\\begin{verbatim}\n" sentence "\n\\end{verbatim}\n" + "\\verb#" sentence "#\n" + "$$" sentence "$$\n" + "$" sentence "$\n" + "\\[" sentence "\\]\n" + "\\v A % " sentence "\n" + with-nbsp "\n"))) + +(ert-deftest tildify-test-tex () + "Tests tildification in a (La)TeX document" + (let* ((sentence (tildify-test--example-sentence " ")) + (with-nbsp (tildify-test--example-sentence "~"))) + (tildify-test--test '(tex-mode latex-mode plain-tex-mode) + (tildify-test--example-tex sentence sentence) + (tildify-test--example-tex sentence with-nbsp)))) + + +(ert-deftest tildify-test-find-env-end-re-bug () + "Tests generation of end-regex using mix of indexes and strings" + (with-temp-buffer + (insert "foo whatever end-foo") + (goto-char (point-min)) + (should (string-equal "end-foo" + (tildify--find-env "foo\\|bar" + '(("foo\\|bar" . ("end-" 0)))))))) + + +(ert-deftest tildify-test-find-env-group-index-bug () + "Tests generation of match-string indexes" + (with-temp-buffer + (let ((pairs '(("start-\\(foo\\|bar\\)" . ("end-" 1)) + ("open-\\(foo\\|bar\\)" . ("close-" 1)))) + (beg-re "start-\\(foo\\|bar\\)\\|open-\\(foo\\|bar\\)")) + (insert "open-foo whatever close-foo") + (goto-char (point-min)) + (should (string-equal "close-foo" (tildify--find-env beg-re pairs)))))) + + +(defmacro with-test-foreach (expected &rest body) + "Helper macro for testing foreach functions. +BODY has access to pairs variable and called lambda." + (declare (indent 1)) + (let ((got (make-symbol "got"))) + `(with-temp-buffer + (insert "1 /- 2 -/ 3 V~ 4 ~ 5 /- 6 -/ 7") + (let* ((pairs '(("/-" . "-/") ("V\\(.\\)" . (1)))) + (,got "") + (called (lambda (s e) + (setq ,got (concat ,got (buffer-substring s e)))))) + (setq-local tildify-foreach-region-function + (apply-partially 'tildify-foreach-ignore-environments + pairs)) + ,@body + (should (string-equal ,expected ,got)))))) + +(ert-deftest tildify-test-foreach-ignore-environments () + "Basic test of `tildify-foreach-ignore-environments'" + (with-test-foreach "1 3 5 7" + (tildify-foreach-ignore-environments pairs called (point-min) (point-max)))) + + +(ert-deftest tildify-test-foreach-ignore-environments-early-return () + "Test whether `tildify-foreach-ignore-environments' returns early +The function must terminate as soon as callback returns nil." + (with-test-foreach "1 " + (tildify-foreach-ignore-environments + pairs (lambda (start end) (funcall called start end) nil) + (point-min) (point-max)))) + +(ert-deftest tildify-test-foreach-region () + "Basic test of `tildify--foreach-region'" + (with-test-foreach "1 3 5 7" + (tildify--foreach-region called (point-min) (point-max)))) + +(ert-deftest tildify-test-foreach-region-early-return () + "Test whether `tildify--foreach-ignore' returns early +The function must terminate as soon as callback returns nil." + (with-test-foreach "1 " + (tildify--foreach-region (lambda (start end) (funcall called start end) nil) + (point-min) (point-max)))) + +(ert-deftest tildify-test-foreach-region-limit-region () + "Test whether `tildify--foreach-ignore' limits callback to given region" + (with-test-foreach "3 " + (tildify--foreach-region called + (+ (point-min) 10) (+ (point-min) 16))) ; start at "3" end past "4" + (with-test-foreach "3 5" + (tildify--foreach-region called + (+ (point-min) 10) (+ (point-min) 20)))) ; start at "3" end past "5" + + +(defun tildify-space-test--test (modes nbsp env-open &optional set-space-string) + (with-temp-buffer + (setq-local buffer-file-coding-system 'utf-8) + (dolist (mode modes) + (funcall mode) + (when set-space-string + (setq-local tildify-space-string nbsp)) + (let ((header (concat "Testing `tildify-space' in " + (symbol-name mode) "\n"))) + ;; Replace space with hard space. + (erase-buffer) + (insert header "Lorem v ") + (should (tildify-space)) + (should (string-equal (concat header "Lorem v" nbsp) (buffer-string))) + ;; Inside and ignore environment, replacing does not happen. + (erase-buffer) + (insert header env-open "Lorem v ") + (should (not (tildify-space))) + (should (string-equal (concat header env-open "Lorem v ") + (buffer-string))))))) + +(ert-deftest tildify-space-test-html () + "Tests auto-tildification in an HTML document" + (tildify-space-test--test '(html-mode sgml-mode) " " "<pre>")) + +(ert-deftest tildify-space-test-html-nbsp () + "Tests auto-tildification in an HTML document" + (tildify-space-test--test '(html-mode sgml-mode) " " "<pre>" t)) + +(ert-deftest tildify-space-test-xml () + "Tests auto-tildification in an XML document" + (tildify-space-test--test '(nxml-mode) " " "<! -- ")) + +(ert-deftest tildify-space-test-tex () + "Tests tildification in a TeX document" + (tildify-space-test--test '(tex-mode latex-mode plain-tex-mode) + "~" "\\verb# ")) + + +(defun tildify-space-undo-test--test + (modes nbsp env-open &optional set-space-string) + (with-temp-buffer + (setq-local buffer-file-coding-system 'utf-8) + (dolist (mode modes) + (funcall mode) + (when set-space-string + (setq-local tildify-space-string nbsp)) + (let ((header (concat "Testing double-space-undos in " + (symbol-name mode) "\n"))) + (erase-buffer) + (insert header "Lorem v" nbsp " ") + (should (not (tildify-space))) + (should (string-equal (concat header "Lorem v ") (buffer-string))))))) + +(ert-deftest tildify-space-undo-test-html () + "Tests auto-tildification in an HTML document" + (tildify-space-undo-test--test '(html-mode sgml-mode) " " "<pre>")) + +(ert-deftest tildify-space-undo-test-html-nbsp () + "Tests auto-tildification in an HTML document" + (tildify-space-undo-test--test '(html-mode sgml-mode) " " "<pre>" t)) + +(ert-deftest tildify-space-undo-test-xml () + "Tests auto-tildification in an XML document" + (tildify-space-undo-test--test '(nxml-mode) " " "<! -- ")) + +(ert-deftest tildify-space-undo-test-tex () + "Tests tildification in a TeX document" + (tildify-space-undo-test--test '(tex-mode latex-mode plain-tex-mode) + "~" "\\verb# ")) + + + +(provide 'tildify-tests) + +;;; tildify-tests.el ends here diff --git a/test/lisp/thingatpt-tests.el b/test/lisp/thingatpt-tests.el new file mode 100644 index 00000000000..d3ecbf8c642 --- /dev/null +++ b/test/lisp/thingatpt-tests.el @@ -0,0 +1,87 @@ +;;; thingatpt.el --- tests for thing-at-point. + +;; Copyright (C) 2013-2016 Free Software Foundation, Inc. + +;; 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/>. + +;;; Code: + +(require 'ert) + +(defvar thing-at-point-test-data + '(("http://1.gnu.org" 1 url "http://1.gnu.org") + ("http://2.gnu.org" 6 url "http://2.gnu.org") + ("http://3.gnu.org" 19 url "http://3.gnu.org") + ("https://4.gnu.org" 1 url "https://4.gnu.org") + ("A geo URI (geo:3.14159,-2.71828)." 12 url "geo:3.14159,-2.71828") + ("Visit http://5.gnu.org now." 5 url nil) + ("Visit http://6.gnu.org now." 7 url "http://6.gnu.org") + ("Visit http://7.gnu.org now." 22 url "http://7.gnu.org") + ("Visit http://8.gnu.org now." 22 url "http://8.gnu.org") + ("Visit http://9.gnu.org now." 24 url nil) + ;; Invalid URIs + ("<<<<" 2 url nil) + ("<>" 1 url nil) + ("<url:>" 1 url nil) + ("http://" 1 url nil) + ;; Invalid schema + ("foo://www.gnu.org" 1 url nil) + ("foohttp://www.gnu.org" 1 url nil) + ;; Non alphanumeric characters can be found in URIs + ("ftp://example.net/~foo!;#bar=baz&goo=bob" 3 url "ftp://example.net/~foo!;#bar=baz&goo=bob") + ("bzr+ssh://user@example.net:5/a%20d,5" 34 url "bzr+ssh://user@example.net:5/a%20d,5") + ;; <url:...> markup + ("Url: <url:foo://1.example.com>..." 8 url "foo://1.example.com") + ("Url: <url:foo://2.example.com>..." 30 url "foo://2.example.com") + ("Url: <url:foo://www.gnu.org/a bc>..." 20 url "foo://www.gnu.org/a bc") + ;; Hack used by thing-at-point: drop punctuation at end of URI. + ("Go to http://www.gnu.org, for details" 7 url "http://www.gnu.org") + ("Go to http://www.gnu.org." 24 url "http://www.gnu.org") + ;; Standard URI delimiters + ("Go to \"http://10.gnu.org\"." 8 url "http://10.gnu.org") + ("Go to \"http://11.gnu.org/\"." 26 url "http://11.gnu.org/") + ("Go to <http://12.gnu.org> now." 8 url "http://12.gnu.org") + ("Go to <http://13.gnu.org> now." 24 url "http://13.gnu.org") + ;; Parenthesis handling (non-standard) + ("http://example.com/a(b)c" 21 url "http://example.com/a(b)c") + ("http://example.com/a(b)" 21 url "http://example.com/a(b)") + ("(http://example.com/abc)" 2 url "http://example.com/abc") + ("This (http://example.com/a(b))" 7 url "http://example.com/a(b)") + ("This (http://example.com/a(b))" 30 url "http://example.com/a(b)") + ("This (http://example.com/a(b))" 5 url nil) + ("http://example.com/ab)c" 4 url "http://example.com/ab)c") + ;; URL markup, lacking schema + ("<url:foo@example.com>" 1 url "mailto:foo@example.com") + ("<url:ftp.example.net/abc/>" 1 url "ftp://ftp.example.net/abc/")) + "List of thing-at-point tests. +Each list element should have the form + + (STRING POS THING RESULT) + +where STRING is a string of buffer contents, POS is the value of +point, THING is a symbol argument for `thing-at-point', and +RESULT should be the result of calling `thing-at-point' from that +position to retrieve THING.") + +(ert-deftest thing-at-point-tests () + "Test the file-local variables implementation." + (dolist (test thing-at-point-test-data) + (with-temp-buffer + (insert (nth 0 test)) + (goto-char (nth 1 test)) + (should (equal (thing-at-point (nth 2 test)) (nth 3 test)))))) + +;;; thingatpt.el ends here diff --git a/test/lisp/url/url-expand-tests.el b/test/lisp/url/url-expand-tests.el new file mode 100644 index 00000000000..6d1d54d4ffc --- /dev/null +++ b/test/lisp/url/url-expand-tests.el @@ -0,0 +1,105 @@ +;;; url-expand-tests.el --- Test suite for relative URI/URL resolution. + +;; Copyright (C) 2012-2016 Free Software Foundation, Inc. + +;; Author: Alain Schneble <a.s@realize.ch> +;; 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: + +;; Test cases covering URI reference resolution as described in RFC3986, +;; section 5. Reference Resolution and especially the relative resolution +;; rules specified in section 5.2. Relative Resolution. + +;; Each test calls `url-expand-file-name', typically with a relative +;; reference URI and a base URI as string and compares the result (Actual) +;; against a manually specified URI (Expected) + +;;; Code: + +(require 'url-expand) +(require 'ert) + +(ert-deftest url-expand-file-name/relative-resolution-normal-examples () + "RFC 3986, Section 5.4 Reference Resolution Examples / Section 5.4.1. Normal Examples" + (should (equal (url-expand-file-name "g:h" "http://a/b/c/d;p?q") "g:h")) + (should (equal (url-expand-file-name "g" "http://a/b/c/d;p?q") "http://a/b/c/g")) + (should (equal (url-expand-file-name "./g" "http://a/b/c/d;p?q") "http://a/b/c/g")) + (should (equal (url-expand-file-name "g/" "http://a/b/c/d;p?q") "http://a/b/c/g/")) + (should (equal (url-expand-file-name "/g" "http://a/b/c/d;p?q") "http://a/g")) + (should (equal (url-expand-file-name "//g" "http://a/b/c/d;p?q") "http://g")) + (should (equal (url-expand-file-name "?y" "http://a/b/c/d;p?q") "http://a/b/c/d;p?y")) + (should (equal (url-expand-file-name "g?y" "http://a/b/c/d;p?q") "http://a/b/c/g?y")) + (should (equal (url-expand-file-name "#s" "http://a/b/c/d;p?q") "http://a/b/c/d;p?q#s")) + (should (equal (url-expand-file-name "g#s" "http://a/b/c/d;p?q") "http://a/b/c/g#s")) + (should (equal (url-expand-file-name "g?y#s" "http://a/b/c/d;p?q") "http://a/b/c/g?y#s")) + (should (equal (url-expand-file-name ";x" "http://a/b/c/d;p?q") "http://a/b/c/;x")) + (should (equal (url-expand-file-name "g;x" "http://a/b/c/d;p?q") "http://a/b/c/g;x")) + (should (equal (url-expand-file-name "g;x?y#s" "http://a/b/c/d;p?q") "http://a/b/c/g;x?y#s")) + (should (equal (url-expand-file-name "" "http://a/b/c/d;p?q") "http://a/b/c/d;p?q")) + (should (equal (url-expand-file-name "." "http://a/b/c/d;p?q") "http://a/b/c/")) + (should (equal (url-expand-file-name "./" "http://a/b/c/d;p?q") "http://a/b/c/")) + (should (equal (url-expand-file-name ".." "http://a/b/c/d;p?q") "http://a/b/")) + (should (equal (url-expand-file-name "../" "http://a/b/c/d;p?q") "http://a/b/")) + (should (equal (url-expand-file-name "../g" "http://a/b/c/d;p?q") "http://a/b/g")) + (should (equal (url-expand-file-name "../.." "http://a/b/c/d;p?q") "http://a/")) + (should (equal (url-expand-file-name "../../" "http://a/b/c/d;p?q") "http://a/")) + (should (equal (url-expand-file-name "../../g" "http://a/b/c/d;p?q") "http://a/g"))) + +(ert-deftest url-expand-file-name/relative-resolution-absolute-examples () + "RFC 3986, Section 5.4 Reference Resolution Examples / Section 5.4.2. Abnormal Examples" + (should (equal (url-expand-file-name "../../../g" "http://a/b/c/d;p?q") "http://a/g")) + (should (equal (url-expand-file-name "../../../../g" "http://a/b/c/d;p?q") "http://a/g")) + + (should (equal (url-expand-file-name "/./g" "http://a/b/c/d;p?q") "http://a/g")) + (should (equal (url-expand-file-name "/../g" "http://a/b/c/d;p?q") "http://a/g")) + (should (equal (url-expand-file-name "g." "http://a/b/c/d;p?q") "http://a/b/c/g.")) + (should (equal (url-expand-file-name ".g" "http://a/b/c/d;p?q") "http://a/b/c/.g")) + (should (equal (url-expand-file-name "g.." "http://a/b/c/d;p?q") "http://a/b/c/g..")) + (should (equal (url-expand-file-name "..g" "http://a/b/c/d;p?q") "http://a/b/c/..g")) + + (should (equal (url-expand-file-name "./../g" "http://a/b/c/d;p?q") "http://a/b/g")) + (should (equal (url-expand-file-name "./g/." "http://a/b/c/d;p?q") "http://a/b/c/g/")) + (should (equal (url-expand-file-name "g/./h" "http://a/b/c/d;p?q") "http://a/b/c/g/h")) + (should (equal (url-expand-file-name "g/../h" "http://a/b/c/d;p?q") "http://a/b/c/h")) + (should (equal (url-expand-file-name "g;x=1/./y" "http://a/b/c/d;p?q") "http://a/b/c/g;x=1/y")) + (should (equal (url-expand-file-name "g;x=1/../y" "http://a/b/c/d;p?q") "http://a/b/c/y")) + + (should (equal (url-expand-file-name "g?y/./x" "http://a/b/c/d;p?q") "http://a/b/c/g?y/./x")) + (should (equal (url-expand-file-name "g?y/../x" "http://a/b/c/d;p?q") "http://a/b/c/g?y/../x")) + (should (equal (url-expand-file-name "g#s/./x" "http://a/b/c/d;p?q") "http://a/b/c/g#s/./x")) + (should (equal (url-expand-file-name "g#s/../x" "http://a/b/c/d;p?q") "http://a/b/c/g#s/../x")) + + (should (equal (url-expand-file-name "http:g" "http://a/b/c/d;p?q") "http:g")) ; for strict parsers + ) + +(ert-deftest url-expand-file-name/relative-resolution-additional-examples () + "Reference Resolution Examples / Arbitrary Examples" + (should (equal (url-expand-file-name "" "http://host/foobar") "http://host/foobar")) + (should (equal (url-expand-file-name "?y" "http://a/b/c/d") "http://a/b/c/d?y")) + (should (equal (url-expand-file-name "?y" "http://a/b/c/d/") "http://a/b/c/d/?y")) + (should (equal (url-expand-file-name "?y#fragment" "http://a/b/c/d;p?q") "http://a/b/c/d;p?y#fragment")) + (should (equal (url-expand-file-name "#bar" "http://host") "http://host#bar")) + (should (equal (url-expand-file-name "#bar" "http://host/") "http://host/#bar")) + (should (equal (url-expand-file-name "#bar" "http://host/foo") "http://host/foo#bar")) + (should (equal (url-expand-file-name "foo#bar" "http://host/foobar") "http://host/foo#bar")) + (should (equal (url-expand-file-name "foo#bar" "http://host/foobar/") "http://host/foobar/foo#bar"))) + +(provide 'url-expand-tests) + +;;; url-expand-tests.el ends here diff --git a/test/lisp/url/url-future-tests.el b/test/lisp/url/url-future-tests.el new file mode 100644 index 00000000000..87298cc1b96 --- /dev/null +++ b/test/lisp/url/url-future-tests.el @@ -0,0 +1,57 @@ +;;; url-future-tests.el --- Test suite for url-future. + +;; Copyright (C) 2011-2016 Free Software Foundation, Inc. + +;; Author: Teodor Zlatanov <tzz@lifelogs.com> +;; Keywords: data + +;; 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/>. + +;;; Code: + +(require 'ert) +(require 'url-future) + +(ert-deftest url-future-tests () + (let* (saver + (text "running future") + (good (make-url-future :value (lambda () (format text)) + :callback (lambda (f) (set 'saver f)))) + (bad (make-url-future :value (lambda () (/ 1 0)) + :errorback (lambda (&rest d) (set 'saver d)))) + (tocancel (make-url-future :value (lambda () (/ 1 0)) + :callback (lambda (f) (set 'saver f)) + :errorback (lambda (&rest d) + (set 'saver d))))) + (should (equal good (url-future-call good))) + (should (equal good saver)) + (should (equal text (url-future-value good))) + (should (url-future-completed-p good)) + (should-error (url-future-call good)) + (setq saver nil) + (should (equal bad (url-future-call bad))) + (should-error (url-future-call bad)) + (should (equal saver (list bad '(arith-error)))) + (should (url-future-errored-p bad)) + (setq saver nil) + (should (equal (url-future-cancel tocancel) tocancel)) + (should-error (url-future-call tocancel)) + (should (null saver)) + (should (url-future-cancelled-p tocancel)))) + +(provide 'url-future-tests) + +;;; url-future-tests.el ends here diff --git a/test/lisp/url/url-parse-tests.el b/test/lisp/url/url-parse-tests.el new file mode 100644 index 00000000000..77c5320e351 --- /dev/null +++ b/test/lisp/url/url-parse-tests.el @@ -0,0 +1,167 @@ +;;; url-parse-tests.el --- Test suite for URI/URL parsing. + +;; Copyright (C) 2012-2016 Free Software Foundation, Inc. + +;; Author: Alain Schneble <a.s@realize.ch> +;; 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: + +;; Test cases covering generic URI syntax as described in RFC3986, +;; section 3. Syntax Components and 4. Usage. See also appendix +;; A. Collected ABNF for URI, as the example given here are all +;; productions of this grammar. + +;; Each tests parses a given URI string - whether relative or absolute - +;; using `url-generic-parse-url' and compares the constructed +;; URL-struct (Actual) against a manually `url-parse-make-urlobj'- +;; constructed URL-struct (Expected). + +;;; Code: + +(require 'url-parse) +(require 'ert) + +(ert-deftest url-generic-parse-url/generic-uri-examples () + "RFC 3986, section 1.1.2. Examples / Example illustrating several URI schemes and variations in their common syntax components" + (should (equal (url-generic-parse-url "ftp://ftp.is.co.za/rfc/rfc1808.txt") (url-parse-make-urlobj "ftp" nil nil "ftp.is.co.za" nil "/rfc/rfc1808.txt" nil nil t))) + (should (equal (url-generic-parse-url "http://www.ietf.org/rfc/rfc2396.txt") (url-parse-make-urlobj "http" nil nil "www.ietf.org" nil "/rfc/rfc2396.txt" nil nil t))) + (should (equal (url-generic-parse-url "ldap://[2001:db8::7]/c=GB?objectClass?one") (url-parse-make-urlobj "ldap" nil nil "[2001:db8::7]" nil "/c=GB?objectClass?one" nil nil t))) + (should (equal (url-generic-parse-url "mailto:John.Doe@example.com") (url-parse-make-urlobj "mailto" nil nil nil nil "John.Doe@example.com" nil nil nil))) + (should (equal (url-generic-parse-url "news:comp.infosystems.www.servers.unix") (url-parse-make-urlobj "news" nil nil nil nil "comp.infosystems.www.servers.unix" nil nil nil))) + (should (equal (url-generic-parse-url "tel:+1-816-555-1212") (url-parse-make-urlobj "tel" nil nil nil nil "+1-816-555-1212" nil nil nil))) + (should (equal (url-generic-parse-url "telnet://192.0.2.16:80/") (url-parse-make-urlobj "telnet" nil nil "192.0.2.16" 80 "/" nil nil t))) + (should (equal (url-generic-parse-url "urn:oasis:names:specification:docbook:dtd:xml:4.1.2") (url-parse-make-urlobj "urn" nil nil nil nil "oasis:names:specification:docbook:dtd:xml:4.1.2" nil nil nil)))) + +(ert-deftest url-generic-parse-url/generic-uri () + "RFC 3986, section 3. Syntax Components / generic URI syntax" + ;; empty path + (should (equal (url-generic-parse-url "http://host#") (url-parse-make-urlobj "http" nil nil "host" nil "" "" nil t))) + (should (equal (url-generic-parse-url "http://host#fragment") (url-parse-make-urlobj "http" nil nil "host" nil "" "fragment" nil t))) + (should (equal (url-generic-parse-url "http://host?#") (url-parse-make-urlobj "http" nil nil "host" nil "?" "" nil t))) + (should (equal (url-generic-parse-url "http://host?query#") (url-parse-make-urlobj "http" nil nil "host" nil "?query" "" nil t))) + (should (equal (url-generic-parse-url "http://host?#fragment") (url-parse-make-urlobj "http" nil nil "host" nil "?" "fragment" nil t))) + (should (equal (url-generic-parse-url "http://host?query#fragment") (url-parse-make-urlobj "http" nil nil "host" nil "?query" "fragment" nil t))) + ;; absolute path / + (should (equal (url-generic-parse-url "http://host/#") (url-parse-make-urlobj "http" nil nil "host" nil "/" "" nil t))) + (should (equal (url-generic-parse-url "http://host/#fragment") (url-parse-make-urlobj "http" nil nil "host" nil "/" "fragment" nil t))) + (should (equal (url-generic-parse-url "http://host/?#") (url-parse-make-urlobj "http" nil nil "host" nil "/?" "" nil t))) + (should (equal (url-generic-parse-url "http://host/?query#") (url-parse-make-urlobj "http" nil nil "host" nil "/?query" "" nil t))) + (should (equal (url-generic-parse-url "http://host/?#fragment") (url-parse-make-urlobj "http" nil nil "host" nil "/?" "fragment" nil t))) + (should (equal (url-generic-parse-url "http://host/?query#fragment") (url-parse-make-urlobj "http" nil nil "host" nil "/?query" "fragment" nil t))) + ;; absolute path /foo + (should (equal (url-generic-parse-url "http://host/foo#") (url-parse-make-urlobj "http" nil nil "host" nil "/foo" "" nil t))) + (should (equal (url-generic-parse-url "http://host/foo#fragment") (url-parse-make-urlobj "http" nil nil "host" nil "/foo" "fragment" nil t))) + (should (equal (url-generic-parse-url "http://host/foo?#") (url-parse-make-urlobj "http" nil nil "host" nil "/foo?" "" nil t))) + (should (equal (url-generic-parse-url "http://host/foo?query#") (url-parse-make-urlobj "http" nil nil "host" nil "/foo?query" "" nil t))) + (should (equal (url-generic-parse-url "http://host/foo?#fragment") (url-parse-make-urlobj "http" nil nil "host" nil "/foo?" "fragment" nil t))) + (should (equal (url-generic-parse-url "http://host/foo?query#fragment") (url-parse-make-urlobj "http" nil nil "host" nil "/foo?query" "fragment" nil t))) + ;; absolute path /foo/ + (should (equal (url-generic-parse-url "http://host/foo/#") (url-parse-make-urlobj "http" nil nil "host" nil "/foo/" "" nil t))) + (should (equal (url-generic-parse-url "http://host/foo/#fragment") (url-parse-make-urlobj "http" nil nil "host" nil "/foo/" "fragment" nil t))) + (should (equal (url-generic-parse-url "http://host/foo/?#") (url-parse-make-urlobj "http" nil nil "host" nil "/foo/?" "" nil t))) + (should (equal (url-generic-parse-url "http://host/foo/?query#") (url-parse-make-urlobj "http" nil nil "host" nil "/foo/?query" "" nil t))) + (should (equal (url-generic-parse-url "http://host/foo/?#fragment") (url-parse-make-urlobj "http" nil nil "host" nil "/foo/?" "fragment" nil t))) + (should (equal (url-generic-parse-url "http://host/foo/?query#fragment") (url-parse-make-urlobj "http" nil nil "host" nil "/foo/?query" "fragment" nil t))) + ;; absolute path /foo/bar + (should (equal (url-generic-parse-url "http://host/foo/bar#") (url-parse-make-urlobj "http" nil nil "host" nil "/foo/bar" "" nil t))) + (should (equal (url-generic-parse-url "http://host/foo/bar#fragment") (url-parse-make-urlobj "http" nil nil "host" nil "/foo/bar" "fragment" nil t))) + (should (equal (url-generic-parse-url "http://host/foo/bar?#") (url-parse-make-urlobj "http" nil nil "host" nil "/foo/bar?" "" nil t))) + (should (equal (url-generic-parse-url "http://host/foo/bar?query#") (url-parse-make-urlobj "http" nil nil "host" nil "/foo/bar?query" "" nil t))) + (should (equal (url-generic-parse-url "http://host/foo/bar?#fragment") (url-parse-make-urlobj "http" nil nil "host" nil "/foo/bar?" "fragment" nil t))) + (should (equal (url-generic-parse-url "http://host/foo/bar?query#fragment") (url-parse-make-urlobj "http" nil nil "host" nil "/foo/bar?query" "fragment" nil t))) + ;; absolute path /foo/bar/ + (should (equal (url-generic-parse-url "http://host/foo/bar/#") (url-parse-make-urlobj "http" nil nil "host" nil "/foo/bar/" "" nil t))) + (should (equal (url-generic-parse-url "http://host/foo/bar/#fragment") (url-parse-make-urlobj "http" nil nil "host" nil "/foo/bar/" "fragment" nil t))) + (should (equal (url-generic-parse-url "http://host/foo/bar/?#") (url-parse-make-urlobj "http" nil nil "host" nil "/foo/bar/?" "" nil t))) + (should (equal (url-generic-parse-url "http://host/foo/bar/?query#") (url-parse-make-urlobj "http" nil nil "host" nil "/foo/bar/?query" "" nil t))) + (should (equal (url-generic-parse-url "http://host/foo/bar/?#fragment") (url-parse-make-urlobj "http" nil nil "host" nil "/foo/bar/?" "fragment" nil t))) + (should (equal (url-generic-parse-url "http://host/foo/bar/?query#fragment") (url-parse-make-urlobj "http" nil nil "host" nil "/foo/bar/?query" "fragment" nil t))) + ;; for more examples of URIs without fragments, see tests covering section 4.3. Absolute URI + ) + +(ert-deftest url-generic-parse-url/network-path-reference () + "RFC 3986, section 4.2. Relative Reference / network-path reference: a relative reference that begins with two slash characters" + (should (equal (url-generic-parse-url "//host") (url-parse-make-urlobj nil nil nil "host" nil "" nil nil t))) + (should (equal (url-generic-parse-url "//host/") (url-parse-make-urlobj nil nil nil "host" nil "/" nil nil t))) + (should (equal (url-generic-parse-url "//host/foo") (url-parse-make-urlobj nil nil nil "host" nil "/foo" nil nil t))) + (should (equal (url-generic-parse-url "//host/foo/bar") (url-parse-make-urlobj nil nil nil "host" nil "/foo/bar" nil nil t))) + (should (equal (url-generic-parse-url "//host/foo/bar/") (url-parse-make-urlobj nil nil nil "host" nil "/foo/bar/" nil nil t)))) + +(ert-deftest url-generic-parse-url/absolute-path-reference () + "RFC 3986, section 4.2. Relative Reference / absolute-path reference: a relative reference that begins with a single slash character" + (should (equal (url-generic-parse-url "/") (url-parse-make-urlobj nil nil nil nil nil "/" nil nil nil))) + (should (equal (url-generic-parse-url "/foo") (url-parse-make-urlobj nil nil nil nil nil "/foo" nil nil nil))) + (should (equal (url-generic-parse-url "/foo/bar") (url-parse-make-urlobj nil nil nil nil nil "/foo/bar" nil nil nil))) + (should (equal (url-generic-parse-url "/foo/bar/") (url-parse-make-urlobj nil nil nil nil nil "/foo/bar/" nil nil nil))) + (should (equal (url-generic-parse-url "/foo/bar#") (url-parse-make-urlobj nil nil nil nil nil "/foo/bar" "" nil nil))) + (should (equal (url-generic-parse-url "/foo/bar/#") (url-parse-make-urlobj nil nil nil nil nil "/foo/bar/" "" nil nil)))) + +(ert-deftest url-generic-parse-url/relative-path-reference () + "RFC 3986, section 4.2. Relative Reference / relative-path reference: a relative reference that does not begin with a slash character" + (should (equal (url-generic-parse-url "foo") (url-parse-make-urlobj nil nil nil nil nil "foo" nil nil nil))) + (should (equal (url-generic-parse-url "foo/bar") (url-parse-make-urlobj nil nil nil nil nil "foo/bar" nil nil nil))) + (should (equal (url-generic-parse-url "foo/bar/") (url-parse-make-urlobj nil nil nil nil nil "foo/bar/" nil nil nil))) + (should (equal (url-generic-parse-url "./foo") (url-parse-make-urlobj nil nil nil nil nil "./foo" nil nil nil))) + (should (equal (url-generic-parse-url "./foo/bar") (url-parse-make-urlobj nil nil nil nil nil "./foo/bar" nil nil nil))) + (should (equal (url-generic-parse-url "./foo/bar/") (url-parse-make-urlobj nil nil nil nil nil "./foo/bar/" nil nil nil))) + (should (equal (url-generic-parse-url "../foo") (url-parse-make-urlobj nil nil nil nil nil "../foo" nil nil nil))) + (should (equal (url-generic-parse-url "../foo/bar") (url-parse-make-urlobj nil nil nil nil nil "../foo/bar" nil nil nil))) + (should (equal (url-generic-parse-url "../foo/bar/") (url-parse-make-urlobj nil nil nil nil nil "../foo/bar/" nil nil nil))) + (should (equal (url-generic-parse-url "./this:that") (url-parse-make-urlobj nil nil nil nil nil "./this:that" nil nil nil))) + ;; for more examples of relative-path references, see tests covering section 4.4. Same-Document Reference + ) + +(ert-deftest url-generic-parse-url/absolute-uri () + "RFC 3986, section 4.3. Absolute URI / absolute URI: absolute form of a URI without a fragment identifier" + ;; empty path + (should (equal (url-generic-parse-url "http://host") (url-parse-make-urlobj "http" nil nil "host" nil "" nil nil t))) + (should (equal (url-generic-parse-url "http://host?") (url-parse-make-urlobj "http" nil nil "host" nil "?" nil nil t))) + (should (equal (url-generic-parse-url "http://host?query") (url-parse-make-urlobj "http" nil nil "host" nil "?query" nil nil t))) + ;; absolute path / + (should (equal (url-generic-parse-url "http://host/") (url-parse-make-urlobj "http" nil nil "host" nil "/" nil nil t))) + (should (equal (url-generic-parse-url "http://host/?") (url-parse-make-urlobj "http" nil nil "host" nil "/?" nil nil t))) + (should (equal (url-generic-parse-url "http://host/?query") (url-parse-make-urlobj "http" nil nil "host" nil "/?query" nil nil t))) + ;; absolute path /foo + (should (equal (url-generic-parse-url "http://host/foo") (url-parse-make-urlobj "http" nil nil "host" nil "/foo" nil nil t))) + (should (equal (url-generic-parse-url "http://host/foo?") (url-parse-make-urlobj "http" nil nil "host" nil "/foo?" nil nil t))) + (should (equal (url-generic-parse-url "http://host/foo?query") (url-parse-make-urlobj "http" nil nil "host" nil "/foo?query" nil nil t))) + ;; absolute path /foo/ + (should (equal (url-generic-parse-url "http://host/foo/") (url-parse-make-urlobj "http" nil nil "host" nil "/foo/" nil nil t))) + (should (equal (url-generic-parse-url "http://host/foo/?") (url-parse-make-urlobj "http" nil nil "host" nil "/foo/?" nil nil t))) + (should (equal (url-generic-parse-url "http://host/foo/?query") (url-parse-make-urlobj "http" nil nil "host" nil "/foo/?query" nil nil t))) + ;; absolute path /foo/bar + (should (equal (url-generic-parse-url "http://host/foo/bar") (url-parse-make-urlobj "http" nil nil "host" nil "/foo/bar" nil nil t))) + (should (equal (url-generic-parse-url "http://host/foo/bar?") (url-parse-make-urlobj "http" nil nil "host" nil "/foo/bar?" nil nil t))) + (should (equal (url-generic-parse-url "http://host/foo/bar?query") (url-parse-make-urlobj "http" nil nil "host" nil "/foo/bar?query" nil nil t))) + ;; absolute path /foo/bar/ + (should (equal (url-generic-parse-url "http://host/foo/bar/") (url-parse-make-urlobj "http" nil nil "host" nil "/foo/bar/" nil nil t))) + (should (equal (url-generic-parse-url "http://host/foo/bar/?") (url-parse-make-urlobj "http" nil nil "host" nil "/foo/bar/?" nil nil t))) + (should (equal (url-generic-parse-url "http://host/foo/bar/?query") (url-parse-make-urlobj "http" nil nil "host" nil "/foo/bar/?query" nil nil t))) + ;; example mentioned in RFC3986, section 5.4. Reference Resolution Examples + (should (equal (url-generic-parse-url "http://a/b/c/d;p?q") (url-parse-make-urlobj "http" nil nil "a" nil "/b/c/d;p?q" nil nil t)))) + +(ert-deftest url-generic-parse-url/same-document-reference () + "RFC 3986, section 4.4. Same-Document Reference / same-document reference: empty or number sign (\"#\") followed by a fragment identifier" + (should (equal (url-generic-parse-url "") (url-parse-make-urlobj nil nil nil nil nil "" nil nil nil))) + (should (equal (url-generic-parse-url "#") (url-parse-make-urlobj nil nil nil nil nil "" "" nil nil))) + (should (equal (url-generic-parse-url "#foo") (url-parse-make-urlobj nil nil nil nil nil "" "foo" nil nil)))) + +(provide 'url-parse-tests) + +;;; url-parse-tests.el ends here diff --git a/test/lisp/url/url-util-tests.el b/test/lisp/url/url-util-tests.el new file mode 100644 index 00000000000..2f1de5103d6 --- /dev/null +++ b/test/lisp/url/url-util-tests.el @@ -0,0 +1,51 @@ +;;; url-util-tests.el --- Test suite for url-util. + +;; Copyright (C) 2012-2016 Free Software Foundation, Inc. + +;; Author: Teodor Zlatanov <tzz@lifelogs.com> +;; Keywords: data + +;; 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/>. + +;;; Code: + +(require 'ert) +(require 'url-util) + +(ert-deftest url-util-tests () + (let ((tests + '(("key1=val1&key2=val2&key3=val1&key3=val2&key4&key5" + ((key1 val1) (key2 "val2") (key3 val1 val2) (key4) (key5 ""))) + ("key1=val1;key2=val2;key3=val1;key3=val2;key4;key5" + ((key1 "val1") (key2 val2) (key3 val1 val2) ("key4") (key5 "")) t) + ("key1=val1;key2=val2;key3=val1;key3=val2;key4=;key5=" + ((key1 val1) (key2 val2) ("key3" val1 val2) (key4) (key5 "")) t t))) + test) + (while tests + (setq test (car tests) + tests (cdr tests)) + (should (equal (apply 'url-build-query-string (cdr test)) (car test))))) + (should (equal (url-parse-query-string + "key1=val1&key2=val2&key3=val1&key3=val2&key4=&key5") + '(("key5" "") + ("key4" "") + ("key3" "val2" "val1") + ("key2" "val2") + ("key1" "val1"))))) + +(provide 'url-util-tests) + +;;; url-util-tests.el ends here diff --git a/test/lisp/vc/add-log-tests.el b/test/lisp/vc/add-log-tests.el new file mode 100644 index 00000000000..71be5a9eadc --- /dev/null +++ b/test/lisp/vc/add-log-tests.el @@ -0,0 +1,85 @@ +;;; add-log-tests.el --- Test suite for add-log. + +;; Copyright (C) 2013-2016 Free Software Foundation, Inc. + +;; Author: Masatake YAMATO <yamato@redhat.com> +;; Keywords: vc tools + +;; 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/>. + +;;; Code: + +(require 'ert) +(require 'add-log) + +(defmacro add-log-current-defun-deftest (name doc major-mode + content marker expected-defun) + "Generate an ert test for mode-own `add-log-current-defun-function'. +Run `add-log-current-defun' at the point where MARKER specifies in a +buffer which content is CONTENT under MAJOR-MODE. Then it compares the +result with EXPECTED-DEFUN." + (let ((xname (intern (concat "add-log-current-defun-test-" + (symbol-name name) + )))) + `(ert-deftest ,xname () + ,doc + (with-temp-buffer + (insert ,content) + (goto-char (point-min)) + (funcall ',major-mode) + (should (equal (when (search-forward ,marker nil t) + (replace-match "" nil t) + (add-log-current-defun)) + ,expected-defun)))))) + +(add-log-current-defun-deftest + sh-func1 + "Test sh-current-defun-name can find function." + sh-mode " +function foo +{ + >< +}" "><" "foo") + +(add-log-current-defun-deftest + sh-func2 + "Test sh-current-defun-name can find function." + sh-mode " +foo() +{ + >< +}" "><" "foo") + +(add-log-current-defun-deftest + sh-func3 + "Test sh-current-defun-name can find function." + sh-mode " +function foo() +{ + >< +}" "><" "foo") + +(add-log-current-defun-deftest + sh-var + "Test sh-current-defun-name can find variable definition." + sh-mode " +PATH=a:/ab:/usr/abc +DIR=/pr><oc" +"><" "DIR") + +(provide 'add-log-tests) + +;;; add-log-tests.el ends here diff --git a/test/lisp/vc/vc-bzr-tests.el b/test/lisp/vc/vc-bzr-tests.el new file mode 100644 index 00000000000..82721eeee4e --- /dev/null +++ b/test/lisp/vc/vc-bzr-tests.el @@ -0,0 +1,144 @@ +;;; vc-bzr.el --- tests for vc/vc-bzr.el + +;; Copyright (C) 2011-2016 Free Software Foundation, Inc. + +;; Author: Glenn Morris <rgm@gnu.org> +;; Maintainer: emacs-devel@gnu.org + +;; 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: + +;;; Code: + +(require 'ert) +(require 'vc-bzr) +(require 'vc-dir) + +(ert-deftest vc-bzr-test-bug9726 () + "Test for http://debbugs.gnu.org/9726 ." + (skip-unless (executable-find vc-bzr-program)) + ;; Bzr wants to access HOME, e.g. to write ~/.bzr.log. + ;; This is a problem on hydra, where HOME is non-existent. + ;; You can disable logging with BZR_LOG=/dev/null, but then some + ;; commands (eg `bzr status') want to access ~/.bazaar, and will + ;; abort if they cannot. I could not figure out how to stop bzr + ;; doing that, so just give it a temporary homedir for the duration. + ;; http://bugs.launchpad.net/bzr/+bug/137407 ? + (let* ((homedir (make-temp-file "vc-bzr-test" t)) + (bzrdir (expand-file-name "bzr" homedir)) + (ignored-dir (progn + (make-directory bzrdir) + (expand-file-name "ignored-dir" bzrdir))) + (default-directory (file-name-as-directory bzrdir)) + (process-environment (cons (format "BZR_HOME=%s" homedir) + process-environment))) + (unwind-protect + (progn + (make-directory ignored-dir) + (with-temp-buffer + (insert (file-name-nondirectory ignored-dir)) + (write-region nil nil (expand-file-name ".bzrignore" bzrdir) + nil 'silent)) + (call-process vc-bzr-program nil nil nil "init") + (call-process vc-bzr-program nil nil nil "add") + (call-process vc-bzr-program nil nil nil "commit" "-m" "Commit 1") + (with-temp-buffer + (insert "unregistered file") + (write-region nil nil (expand-file-name "testfile2" ignored-dir) + nil 'silent)) + (vc-dir ignored-dir) + (while (vc-dir-busy) + (sit-for 0.1)) + ;; FIXME better to explicitly test for error from process sentinel. + (with-current-buffer "*vc-dir*" + (goto-char (point-min)) + (should (search-forward "unregistered" nil t)))) + (delete-directory homedir t)))) + +;; Not specific to bzr. +(ert-deftest vc-bzr-test-bug9781 () + "Test for http://debbugs.gnu.org/9781 ." + (skip-unless (executable-find vc-bzr-program)) + (let* ((homedir (make-temp-file "vc-bzr-test" t)) + (bzrdir (expand-file-name "bzr" homedir)) + (subdir (progn + (make-directory bzrdir) + (expand-file-name "subdir" bzrdir))) + (file (expand-file-name "file" bzrdir)) + (default-directory (file-name-as-directory bzrdir)) + (process-environment (cons (format "BZR_HOME=%s" homedir) + process-environment))) + (unwind-protect + (progn + (call-process vc-bzr-program nil nil nil "init") + (make-directory subdir) + (with-temp-buffer + (insert "text") + (write-region nil nil file nil 'silent) + (write-region nil nil (expand-file-name "subfile" subdir) + nil 'silent)) + (call-process vc-bzr-program nil nil nil "add") + (call-process vc-bzr-program nil nil nil "commit" "-m" "Commit 1") + (call-process vc-bzr-program nil nil nil "remove" subdir) + (with-temp-buffer + (insert "different text") + (write-region nil nil file nil 'silent)) + (vc-dir bzrdir) + (while (vc-dir-busy) + (sit-for 0.1)) + (vc-dir-mark-all-files t) + (let ((f (symbol-function 'y-or-n-p))) + (unwind-protect + (progn + (fset 'y-or-n-p (lambda (prompt) t)) + (vc-next-action nil)) + (fset 'y-or-n-p f))) + (should (get-buffer "*vc-log*"))) + (delete-directory homedir t)))) + +;; http://lists.gnu.org/archive/html/help-gnu-emacs/2012-04/msg00145.html +(ert-deftest vc-bzr-test-faulty-bzr-autoloads () + "Test we can generate autoloads in a bzr directory when bzr is faulty." + (skip-unless (executable-find vc-bzr-program)) + (let* ((homedir (make-temp-file "vc-bzr-test" t)) + (bzrdir (expand-file-name "bzr" homedir)) + (file (progn + (make-directory bzrdir) + (expand-file-name "foo.el" bzrdir))) + (default-directory (file-name-as-directory bzrdir)) + (generated-autoload-file (expand-file-name "loaddefs.el" bzrdir)) + (process-environment (cons (format "BZR_HOME=%s" homedir) + process-environment))) + (unwind-protect + (progn + (call-process vc-bzr-program nil nil nil "init") + (with-temp-buffer + (insert ";;;###autoload +\(defun foo () \"foo\" (interactive) (message \"foo!\"))") + (write-region nil nil file nil 'silent)) + (call-process vc-bzr-program nil nil nil "add") + (call-process vc-bzr-program nil nil nil "commit" "-m" "Commit 1") + ;; Deleting dirstate ensures both that vc-bzr's status heuristic + ;; fails, so it has to call the external bzr status, and + ;; causes bzr status to fail. This simulates a broken bzr + ;; installation. + (delete-file ".bzr/checkout/dirstate") + (should (progn (update-directory-autoloads default-directory) + t))) + (delete-directory homedir t)))) + +;;; vc-bzr.el ends here diff --git a/test/lisp/vc/vc-tests.el b/test/lisp/vc/vc-tests.el new file mode 100644 index 00000000000..2faa1436522 --- /dev/null +++ b/test/lisp/vc/vc-tests.el @@ -0,0 +1,618 @@ +;;; vc-tests.el --- Tests of different backends of vc.el + +;; Copyright (C) 2014-2016 Free Software Foundation, Inc. + +;; Author: Michael Albinus <michael.albinus@gmx.de> + +;; 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/'. + +;;; Commentary: + +;; For every supported VC on the machine, different test cases are +;; generated automatically. + +;; Functions to be tested (see Commentary of vc.el). Mandatory +;; functions are marked with `*', optional functions are marked with `-': + +;; BACKEND PROPERTIES +;; +;; * revision-granularity DONE + +;; STATE-QUERYING FUNCTIONS +;; +;; * registered (file) DONE +;; * state (file) DONE +;; - dir-status (dir update-function) +;; - dir-status-files (dir files default-state update-function) +;; - dir-extra-headers (dir) +;; - dir-printer (fileinfo) +;; - status-fileinfo-extra (file) +;; * working-revision (file) DONE +;; - latest-on-branch-p (file) +;; * checkout-model (files) DONE +;; - mode-line-string (file) + +;; STATE-CHANGING FUNCTIONS +;; +;; * create-repo (backend) DONE +;; * register (files &optional comment) DONE +;; - responsible-p (file) +;; - receive-file (file rev) +;; - unregister (file) DONE +;; * checkin (files comment) +;; * find-revision (file rev buffer) +;; * checkout (file &optional rev) +;; * revert (file &optional contents-done) +;; - rollback (files) +;; - merge-file (file rev1 rev2) +;; - merge-branch () +;; - merge-news (file) +;; - pull (prompt) +;; - steal-lock (file &optional revision) +;; - modify-change-comment (files rev comment) +;; - mark-resolved (files) +;; - find-admin-dir (file) + +;; HISTORY FUNCTIONS +;; +;; * print-log (files buffer &optional shortlog start-revision limit) +;; * log-outgoing (backend remote-location) +;; * log-incoming (backend remote-location) +;; - log-view-mode () +;; - show-log-entry (revision) +;; - comment-history (file) +;; - update-changelog (files) +;; * diff (files &optional async rev1 rev2 buffer) +;; - revision-completion-table (files) +;; - annotate-command (file buf &optional rev) +;; - annotate-time () +;; - annotate-current-time () +;; - annotate-extract-revision-at-line () +;; - region-history (FILE BUFFER LFROM LTO) +;; - region-history-mode () + +;; TAG SYSTEM +;; +;; - create-tag (dir name branchp) +;; - retrieve-tag (dir name update) + +;; MISCELLANEOUS +;; +;; - make-version-backups-p (file) +;; - root (file) +;; - ignore (file &optional directory) +;; - ignore-completion-table +;; - previous-revision (file rev) +;; - next-revision (file rev) +;; - log-edit-mode () +;; - check-headers () +;; - delete-file (file) +;; - rename-file (old new) +;; - find-file-hook () +;; - extra-menu () +;; - extra-dir-menu () +;; - conflicted-files (dir) + +;;; Code: + +(require 'ert) +(require 'vc) + +;; The working horses. + +(defvar vc-test--cleanup-hook nil + "Functions for cleanup at the end of an ert test. +Don't set it globally, the functions shall be let-bound.") + +(defun vc-test--revision-granularity-function (backend) + "Run the `vc-revision-granularity' backend function." + (funcall (intern (downcase (format "vc-%s-revision-granularity" backend))))) + +(defun vc-test--create-repo-function (backend) + "Run the `vc-create-repo' backend function. +For backends which dont support it, it is emulated." + + (cond + ((eq backend 'CVS) + (let ((tmp-dir + (expand-file-name + (make-temp-name "vc-test") temporary-file-directory))) + (make-directory (expand-file-name "module" tmp-dir) 'parents) + (make-directory (expand-file-name "CVSROOT" tmp-dir) 'parents) + (if (not (fboundp 'w32-application-type)) + (shell-command-to-string (format "cvs -Q -d:local:%s co module" + tmp-dir)) + (let ((cvs-prog (executable-find "cvs")) + (tdir tmp-dir)) + ;; If CVS executable is an MSYS program, reformat the file + ;; name of TMP-DIR to have the /d/foo/bar form supported by + ;; MSYS programs. (FIXME: What about Cygwin cvs.exe?) + (if (eq (w32-application-type cvs-prog) 'msys) + (setq tdir + (concat "/" (substring tmp-dir 0 1) (substring tmp-dir 2)))) + (shell-command-to-string (format "cvs -Q -d:local:%s co module" + tdir)))) + (rename-file "module/CVS" default-directory) + (delete-directory "module" 'recursive) + ;; We must cleanup the "remote" CVS repo as well. + (add-hook 'vc-test--cleanup-hook + `(lambda () (delete-directory ,tmp-dir 'recursive))))) + + ((eq backend 'Arch) + (let ((archive-name (format "%s--%s" user-mail-address (random)))) + (when (string-match + "no arch user id set" (shell-command-to-string "tla my-id")) + (shell-command-to-string + (format "tla my-id \"<%s>\"" user-mail-address))) + (shell-command-to-string + (format "tla make-archive %s %s" archive-name default-directory)) + (shell-command-to-string + (format "tla my-default-archive %s" archive-name)))) + + ((eq backend 'Mtn) + (let ((archive-name "foo.mtn")) + (shell-command-to-string + (format + "mtn db init --db=%s" + (expand-file-name archive-name default-directory))) + (shell-command-to-string + (format "mtn --db=%s --branch=foo setup ." archive-name)))) + + (t (vc-create-repo backend)))) + +(defun vc-test--create-repo (backend) + "Create a test repository in `default-directory', a temporary directory." + + (let ((vc-handled-backends `(,backend)) + (default-directory + (file-name-as-directory + (expand-file-name + (make-temp-name "vc-test") temporary-file-directory))) + vc-test--cleanup-hook) + + (unwind-protect + (progn + ;; Cleanup. + (add-hook + 'vc-test--cleanup-hook + `(lambda () (delete-directory ,default-directory 'recursive))) + + ;; Check the revision granularity. + (should (memq (vc-test--revision-granularity-function backend) + '(file repository))) + + ;; Create empty repository. + (make-directory default-directory) + (should (file-directory-p default-directory)) + (vc-test--create-repo-function backend) + (should (eq (vc-responsible-backend default-directory) backend))) + + ;; Save exit. + (ignore-errors (run-hooks 'vc-test--cleanup-hook))))) + +;; Why isn't there `vc-unregister'? +(defun vc-test--unregister-function (backend file) + "Run the `vc-unregister' backend function. +For backends which dont support it, `vc-not-supported' is signalled." + + (let ((symbol (intern (downcase (format "vc-%s-unregister" backend))))) + (if (functionp symbol) + (funcall symbol file) + ;; CVS, SVN, SCCS, SRC and Mtn are not supported. + (signal 'vc-not-supported (list 'unregister backend))))) + +(defun vc-test--register (backend) + "Register and unregister a file." + + (let ((vc-handled-backends `(,backend)) + (default-directory + (file-name-as-directory + (expand-file-name + (make-temp-name "vc-test") temporary-file-directory))) + vc-test--cleanup-hook) + + (unwind-protect + (progn + ;; Cleanup. + (add-hook + 'vc-test--cleanup-hook + `(lambda () (delete-directory ,default-directory 'recursive))) + + ;; Create empty repository. + (make-directory default-directory) + (vc-test--create-repo-function backend) + + (let ((tmp-name1 (expand-file-name "foo" default-directory)) + (tmp-name2 "bla")) + ;; Register files. Check for it. + (write-region "foo" nil tmp-name1 nil 'nomessage) + (should (file-exists-p tmp-name1)) + (should-not (vc-registered tmp-name1)) + (write-region "bla" nil tmp-name2 nil 'nomessage) + (should (file-exists-p tmp-name2)) + (should-not (vc-registered tmp-name2)) + (vc-register (list backend (list tmp-name1 tmp-name2))) + (should (file-exists-p tmp-name1)) + (should (vc-registered tmp-name1)) + (should (file-exists-p tmp-name2)) + (should (vc-registered tmp-name2)) + + ;; Unregister the files. + (condition-case err + (progn + (vc-test--unregister-function backend tmp-name1) + (should-not (vc-registered tmp-name1)) + (vc-test--unregister-function backend tmp-name2) + (should-not (vc-registered tmp-name2))) + ;; CVS, SVN, SCCS, SRC and Mtn are not supported. + (vc-not-supported t)) + ;; The files shall still exist. + (should (file-exists-p tmp-name1)) + (should (file-exists-p tmp-name2)))) + + ;; Save exit. + (ignore-errors (run-hooks 'vc-test--cleanup-hook))))) + +(defun vc-test--state (backend) + "Check the different states of a file." + + (let ((vc-handled-backends `(,backend)) + (default-directory + (file-name-as-directory + (expand-file-name + (make-temp-name "vc-test") temporary-file-directory))) + vc-test--cleanup-hook) + + (unwind-protect + (progn + ;; Cleanup. + (add-hook + 'vc-test--cleanup-hook + `(lambda () (delete-directory ,default-directory 'recursive))) + + ;; Create empty repository. Check repository state. + (make-directory default-directory) + (vc-test--create-repo-function backend) + + ;; nil: Hg Mtn RCS + ;; added: Git + ;; unregistered: CVS SCCS SRC + ;; up-to-date: Bzr SVN + (message "vc-state1 %s" (vc-state default-directory)) + (should (eq (vc-state default-directory) + (vc-state default-directory backend))) + (should (memq (vc-state default-directory) + '(nil added unregistered up-to-date))) + + (let ((tmp-name (expand-file-name "foo" default-directory))) + ;; Check state of an empty file. + + ;; nil: Hg Mtn SRC SVN + ;; added: Git + ;; unregistered: RCS SCCS + ;; up-to-date: Bzr CVS + (message "vc-state2 %s" (vc-state tmp-name)) + (should (eq (vc-state tmp-name) (vc-state tmp-name backend))) + (should (memq (vc-state tmp-name) + '(nil added unregistered up-to-date))) + + ;; Write a new file. Check state. + (write-region "foo" nil tmp-name nil 'nomessage) + + ;; nil: Mtn + ;; added: Git + ;; unregistered: Hg RCS SCCS SRC SVN + ;; up-to-date: Bzr CVS + (message "vc-state3 %s" (vc-state tmp-name)) + (should (eq (vc-state tmp-name) (vc-state tmp-name backend))) + (should (memq (vc-state tmp-name) + '(nil added unregistered up-to-date))) + + ;; Register a file. Check state. + (vc-register + (list backend (list (file-name-nondirectory tmp-name)))) + + ;; added: Git Mtn + ;; unregistered: Hg RCS SCCS SRC SVN + ;; up-to-date: Bzr CVS + (message "vc-state4 %s" (vc-state tmp-name)) + (should (eq (vc-state tmp-name) (vc-state tmp-name backend))) + (should (memq (vc-state tmp-name) '(added unregistered up-to-date))) + + ;; Unregister the file. Check state. + (condition-case nil + (progn + (vc-test--unregister-function backend tmp-name) + + ;; added: Git + ;; unregistered: Hg RCS + ;; unsupported: CVS Mtn SCCS SRC SVN + ;; up-to-date: Bzr + (message "vc-state5 %s" (vc-state tmp-name)) + (should (eq (vc-state tmp-name) (vc-state tmp-name backend))) + (should (memq (vc-state tmp-name) + '(added unregistered up-to-date)))) + (vc-not-supported (message "vc-state5 unsupported"))))) + + ;; Save exit. + (ignore-errors (run-hooks 'vc-test--cleanup-hook))))) + +(defun vc-test--working-revision (backend) + "Check the working revision of a repository." + + (let ((vc-handled-backends `(,backend)) + (default-directory + (file-name-as-directory + (expand-file-name + (make-temp-name "vc-test") temporary-file-directory))) + vc-test--cleanup-hook) + + (unwind-protect + (progn + ;; Cleanup. + (add-hook + 'vc-test--cleanup-hook + `(lambda () (delete-directory ,default-directory 'recursive))) + + ;; Create empty repository. Check working revision of + ;; repository, should be nil. + (make-directory default-directory) + (vc-test--create-repo-function backend) + + ;; nil: CVS Git Mtn RCS SCCS + ;; "0": Bzr Hg SRC SVN + (message + "vc-working-revision1 %s" (vc-working-revision default-directory)) + (should (eq (vc-working-revision default-directory) + (vc-working-revision default-directory backend))) + (should (member (vc-working-revision default-directory) '(nil "0"))) + + (let ((tmp-name (expand-file-name "foo" default-directory))) + ;; Check initial working revision, should be nil until + ;; it's registered. + + ;; nil: CVS Git Mtn RCS SCCS SVN + ;; "0": Bzr Hg SRC + (message "vc-working-revision2 %s" (vc-working-revision tmp-name)) + (should (eq (vc-working-revision tmp-name) + (vc-working-revision tmp-name backend))) + (should (member (vc-working-revision tmp-name) '(nil "0"))) + + ;; Write a new file. Check working revision. + (write-region "foo" nil tmp-name nil 'nomessage) + + ;; nil: CVS Git Mtn RCS SCCS SVN + ;; "0": Bzr Hg SRC + (message "vc-working-revision3 %s" (vc-working-revision tmp-name)) + (should (eq (vc-working-revision tmp-name) + (vc-working-revision tmp-name backend))) + (should (member (vc-working-revision tmp-name) '(nil "0"))) + + ;; Register a file. Check working revision. + (vc-register + (list backend (list (file-name-nondirectory tmp-name)))) + + ;; nil: Mtn Git RCS SCCS + ;; "0": Bzr CVS Hg SRC SVN + (message "vc-working-revision4 %s" (vc-working-revision tmp-name)) + (should (eq (vc-working-revision tmp-name) + (vc-working-revision tmp-name backend))) + (should (member (vc-working-revision tmp-name) '(nil "0"))) + + ;; Unregister the file. Check working revision. + (condition-case nil + (progn + (vc-test--unregister-function backend tmp-name) + + ;; nil: Git RCS + ;; "0": Bzr Hg + ;; unsupported: CVS Mtn SCCS SRC SVN + (message + "vc-working-revision5 %s" (vc-working-revision tmp-name)) + (should (eq (vc-working-revision tmp-name) + (vc-working-revision tmp-name backend))) + (should (member (vc-working-revision tmp-name) '(nil "0")))) + (vc-not-supported (message "vc-working-revision5 unsupported"))))) + + ;; Save exit. + (ignore-errors (run-hooks 'vc-test--cleanup-hook))))) + +(defun vc-test--checkout-model (backend) + "Check the checkout model of a repository." + + (let ((vc-handled-backends `(,backend)) + (default-directory + (file-name-as-directory + (expand-file-name + (make-temp-name "vc-test") temporary-file-directory))) + vc-test--cleanup-hook) + + (unwind-protect + (progn + ;; Cleanup. + (add-hook + 'vc-test--cleanup-hook + `(lambda () (delete-directory ,default-directory 'recursive))) + + ;; Create empty repository. Check repository checkout model. + (make-directory default-directory) + (vc-test--create-repo-function backend) + + ;; Surprisingly, none of the backends returns 'announce. + ;; nil: RCS + ;; implicit: Bzr CVS Git Hg Mtn SRC SVN + ;; locking: SCCS + (message + "vc-checkout-model1 %s" + (vc-checkout-model backend default-directory)) + (should (memq (vc-checkout-model backend default-directory) + '(announce implicit locking))) + + (let ((tmp-name (expand-file-name "foo" default-directory))) + ;; Check checkout model of an empty file. + + ;; nil: RCS + ;; implicit: Bzr CVS Git Hg Mtn SRC SVN + ;; locking: SCCS + (message + "vc-checkout-model2 %s" (vc-checkout-model backend tmp-name)) + (should (memq (vc-checkout-model backend tmp-name) + '(announce implicit locking))) + + ;; Write a new file. Check checkout model. + (write-region "foo" nil tmp-name nil 'nomessage) + + ;; nil: RCS + ;; implicit: Bzr CVS Git Hg Mtn SRC SVN + ;; locking: SCCS + (message + "vc-checkout-model3 %s" (vc-checkout-model backend tmp-name)) + (should (memq (vc-checkout-model backend tmp-name) + '(announce implicit locking))) + + ;; Register a file. Check checkout model. + (vc-register + (list backend (list (file-name-nondirectory tmp-name)))) + + ;; nil: RCS + ;; implicit: Bzr CVS Git Hg Mtn SRC SVN + ;; locking: SCCS + (message + "vc-checkout-model4 %s" (vc-checkout-model backend tmp-name)) + (should (memq (vc-checkout-model backend tmp-name) + '(announce implicit locking))) + + ;; Unregister the file. Check checkout model. + (condition-case nil + (progn + (vc-test--unregister-function backend tmp-name) + + ;; nil: RCS + ;; implicit: Bzr Git Hg + ;; unsupported: CVS Mtn SCCS SRC SVN + (message + "vc-checkout-model5 %s" (vc-checkout-model backend tmp-name)) + (should (memq (vc-checkout-model backend tmp-name) + '(announce implicit locking)))) + (vc-not-supported (message "vc-checkout-model5 unsupported"))))) + + ;; Save exit. + (ignore-errors (run-hooks 'vc-test--cleanup-hook))))) + +;; Create the test cases. + +(defun vc-test--rcs-enabled () + (executable-find "rcs")) + +(defun vc-test--cvs-enabled () + (executable-find "cvs")) + +(defvar vc-svn-program) +(defun vc-test--svn-enabled () + (executable-find vc-svn-program)) + +(defun vc-test--sccs-enabled () + (executable-find "sccs")) + +(defvar vc-src-program) +(defun vc-test--src-enabled () + (executable-find vc-src-program)) + +(defvar vc-bzr-program) +(defun vc-test--bzr-enabled () + (executable-find vc-bzr-program)) + +(defvar vc-git-program) +(defun vc-test--git-enabled () + (executable-find vc-git-program)) + +(defvar vc-hg-program) +(defun vc-test--hg-enabled () + (executable-find vc-hg-program)) + +(defvar vc-mtn-program) +(defun vc-test--mtn-enabled () + (executable-find vc-mtn-program)) + +;; Obsoleted. +(defvar vc-arch-program) +(defun vc-test--arch-enabled () + (executable-find vc-arch-program)) + +;; Create the test cases. +(dolist (backend vc-handled-backends) + (let ((backend-string (downcase (symbol-name backend)))) + (require (intern (format "vc-%s" backend-string))) + (eval + ;; Check, whether the backend is supported. + `(when (funcall ',(intern (format "vc-test--%s-enabled" backend-string))) + + (ert-deftest + ,(intern (format "vc-test-%s00-create-repo" backend-string)) () + ,(format "Check `vc-create-repo' for the %s backend." + backend-string) + (vc-test--create-repo ',backend)) + + (ert-deftest + ,(intern (format "vc-test-%s01-register" backend-string)) () + ,(format + "Check `vc-register' and `vc-registered' for the %s backend." + backend-string) + (skip-unless + (ert-test-passed-p + (ert-test-most-recent-result + (ert-get-test + ',(intern + (format "vc-test-%s00-create-repo" backend-string)))))) + (vc-test--register ',backend)) + + (ert-deftest + ,(intern (format "vc-test-%s02-state" backend-string)) () + ,(format "Check `vc-state' for the %s backend." backend-string) + (skip-unless + (ert-test-passed-p + (ert-test-most-recent-result + (ert-get-test + ',(intern + (format "vc-test-%s01-register" backend-string)))))) + (vc-test--state ',backend)) + + (ert-deftest + ,(intern (format "vc-test-%s03-working-revision" backend-string)) () + ,(format "Check `vc-working-revision' for the %s backend." + backend-string) + (skip-unless + (ert-test-passed-p + (ert-test-most-recent-result + (ert-get-test + ',(intern + (format "vc-test-%s01-register" backend-string)))))) + (vc-test--working-revision ',backend)) + + (ert-deftest + ,(intern (format "vc-test-%s04-checkout-model" backend-string)) () + ,(format "Check `vc-checkout-model' for the %s backend." + backend-string) + ;; FIXME make this pass. + :expected-result ,(if (equal backend 'RCS) :failed :passed) + (skip-unless + (ert-test-passed-p + (ert-test-most-recent-result + (ert-get-test + ',(intern + (format "vc-test-%s01-register" backend-string)))))) + (vc-test--checkout-model ',backend)))))) + +(provide 'vc-tests) +;;; vc-tests.el ends here diff --git a/test/lisp/xml-tests.el b/test/lisp/xml-tests.el new file mode 100644 index 00000000000..763febb9b69 --- /dev/null +++ b/test/lisp/xml-tests.el @@ -0,0 +1,136 @@ +;;; xml-parse-tests.el --- Test suite for XML parsing. + +;; Copyright (C) 2012-2016 Free Software Foundation, Inc. + +;; Author: Chong Yidong <cyd@stupidchicken.com> +;; Keywords: internal +;; Human-Keywords: internal + +;; 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: + +;; Type M-x test-xml-parse RET to generate the test buffer. + +;;; Code: + +(require 'ert) +(require 'xml) + +(defvar xml-parse-tests--data + `(;; General entity substitution + ("<?xml version=\"1.0\"?><!DOCTYPE foo SYSTEM \"bar.dtd\" [<!ENTITY ent \"AbC\">]><foo a=\"b\"><bar>&ent;;</bar></foo>" . + ((foo ((a . "b")) (bar nil "AbC;")))) + ("<?xml version=\"1.0\"?><foo>&amp;&apos;'<>"</foo>" . + ((foo () "&''<>\""))) + ;; Parameter entity substitution + ("<?xml version=\"1.0\"?><!DOCTYPE foo SYSTEM \"bar.dtd\" [<!ENTITY % pent \"AbC\"><!ENTITY ent \"%pent;\">]><foo a=\"b\"><bar>&ent;;</bar></foo>" . + ((foo ((a . "b")) (bar nil "AbC;")))) + ;; Tricky parameter entity substitution (like XML spec Appendix D) + ("<?xml version='1.0'?><!DOCTYPE foo [ <!ENTITY % xx '%zz;'><!ENTITY % zz '<!ENTITY ent \"b\" >' > %xx; ]><foo>A&ent;C</foo>" . + ((foo () "AbC"))) + ;; Bug#7172 + ("<?xml version=\"1.0\"?><!DOCTYPE foo [ <!ELEMENT EXAM_PLE EMPTY> ]><foo></foo>" . + ((foo ()))) + ;; Entities referencing entities, in character data + ("<!DOCTYPE foo [ <!ENTITY b \"B\"><!ENTITY abc \"a&b;c\">]><foo>&abc;</foo>" . + ((foo () "aBc"))) + ;; Entities referencing entities, in attribute values + ("<!DOCTYPE foo [ <!ENTITY b \"B\"><!ENTITY abc \"a&b;c\">]><foo a=\"-&abc;-\">1</foo>" . + ((foo ((a . "-aBc-")) "1"))) + ;; Character references must be treated as character data + ("<foo>AT&T;</foo>" . ((foo () "AT&T;"))) + ("<foo>&amp;</foo>" . ((foo () "&"))) + ("<foo>&amp;</foo>" . ((foo () "&"))) + ;; Unusual but valid XML names [5] + ("<ÀÖØö.3·-‿⁀>abc</ÀÖØö.3·-‿⁀>" . ((,(intern "ÀÖØö.3·-‿⁀") () "abc"))) + ("<:>abc</:>" . ((,(intern ":") () "abc")))) + "Alist of XML strings and their expected parse trees.") + +(defvar xml-parse-tests--bad-data + '(;; XML bomb in content + "<!DOCTYPE foo [<!ENTITY lol \"lol\"><!ENTITY lol1 \"&lol;&lol;&lol;&lol;&lol;&lol;&lol;&lol;&lol;&lol;\"><!ENTITY lol2 \"&lol1;&lol1;&lol1;&lol1;&lol1;&lol1;&lol1;&lol1;&lol1;&lol1;\">]><foo>&lol2;</foo>" + ;; XML bomb in attribute value + "<!DOCTYPE foo [<!ENTITY lol \"lol\"><!ENTITY lol1 \"&lol;&lol;&lol;&lol;&lol;&lol;&lol;&lol;&lol;&lol;\"><!ENTITY lol2 \"&lol1;&lol1;&lol1;&lol1;&lol1;&lol1;&lol1;&lol1;&lol1;&lol1;\">]><foo a=\"&lol2;\">!</foo>" + ;; Non-terminating DTD + "<!DOCTYPE foo [ <!ENTITY b \"B\"><!ENTITY abc \"a&b;c\">" + "<!DOCTYPE foo [ <!ENTITY b \"B\"><!ENTITY abc \"a&b;c\">asdf" + "<!DOCTYPE foo [ <!ENTITY b \"B\"><!ENTITY abc \"a&b;c\">asdf&abc;" + ;; Invalid XML names + "<0foo>abc</0foo>" + "<‿foo>abc</‿foo>" + "<f¿>abc</f¿>") + "List of XML strings that should signal an error in the parser") + +(defvar xml-parse-tests--qnames + '( ;; Test data for name expansion + ("<?xml version=\"1.0\" encoding=\"UTF-8\"?><D:multistatus xmlns:D=\"DAV:\"><D:response><D:href>/calendar/events/</D:href><D:propstat><D:status>HTTP/1.1 200 OK</D:status></D:propstat></D:response></D:multistatus>" + ;; Result with qnames as cons + ((("DAV:" . "multistatus") + ((("http://www.w3.org/2000/xmlns/" . "D") . "DAV:")) + (("DAV:" . "response") nil (("DAV:" . "href") nil "/calendar/events/") + (("DAV:" . "propstat") nil (("DAV:" . "status") nil "HTTP/1.1 200 OK"))))) + ;; Result with qnames as symbols + ((DAV:multistatus + ((("http://www.w3.org/2000/xmlns/" . "D") . "DAV:")) + (DAV:response nil (DAV:href nil "/calendar/events/") + (DAV:propstat nil (DAV:status nil "HTTP/1.1 200 OK")))))) + ("<?xml version=\"1.0\" encoding=\"UTF-8\"?><F:something>hi there</F:something>" + ((("FOOBAR:" . "something") nil "hi there")) + ((FOOBAR:something nil "hi there")))) + "List of strings which are parsed using namespace expansion. +Parser is called with and without 'symbol-qnames argument.") + +(ert-deftest xml-parse-tests () + "Test XML parsing." + (with-temp-buffer + (dolist (test xml-parse-tests--data) + (erase-buffer) + (insert (car test)) + (should (equal (cdr test) (xml-parse-region)))) + (let ((xml-entity-expansion-limit 50)) + (dolist (test xml-parse-tests--bad-data) + (erase-buffer) + (insert test) + (should-error (xml-parse-region)))) + (let ((testdata (car xml-parse-tests--qnames))) + (erase-buffer) + (insert (car testdata)) + (should (equal (nth 1 testdata) + (xml-parse-region nil nil nil nil t))) + (should (equal (nth 2 testdata) + (xml-parse-region nil nil nil nil 'symbol-qnames)))) + (let ((testdata (nth 1 xml-parse-tests--qnames))) + (erase-buffer) + (insert (car testdata)) + ;; Provide additional namespace-URI mapping + (should (equal (nth 1 testdata) + (xml-parse-region + nil nil nil nil + (append xml-default-ns + '(("F" . "FOOBAR:")))))) + (should (equal (nth 2 testdata) + (xml-parse-region + nil nil nil nil + (cons 'symbol-qnames + (append xml-default-ns + '(("F" . "FOOBAR:")))))))))) + +;; Local Variables: +;; no-byte-compile: t +;; End: + +;;; xml-parse-tests.el ends here. |