From 3ea82dffd7b2c17a504e336019b70c65c198f6fa Mon Sep 17 00:00:00 2001 From: Gnus developers Date: Tue, 26 Jun 2012 22:55:13 +0000 Subject: [PATCH] Add lisp/gnus/mm-archive.el, lisp/gnus/tests/gnustest-nntp.el, and lisp/gnus/tests/gnustest-registry.el --- lisp/gnus/mm-archive.el | 107 +++++++++++++++++ lisp/gnus/tests/gnustest-nntp.el | 94 +++++++++++++++ lisp/gnus/tests/gnustest-registry.el | 216 +++++++++++++++++++++++++++++++++++ 3 files changed, 417 insertions(+) create mode 100644 lisp/gnus/mm-archive.el create mode 100644 lisp/gnus/tests/gnustest-nntp.el create mode 100644 lisp/gnus/tests/gnustest-registry.el diff --git a/lisp/gnus/mm-archive.el b/lisp/gnus/mm-archive.el new file mode 100644 index 00000000000..7cfa4659fd9 --- /dev/null +++ b/lisp/gnus/mm-archive.el @@ -0,0 +1,107 @@ +;;; mm-archive.el --- Functions for parsing archive files as MIME + +;; Copyright (C) 2012 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen +;; 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 . + +;;; Commentary: + +;;; Code: + +(require 'mm-decode) +(eval-when-compile + (autoload 'gnus-recursive-directory-files "gnus-util") + (autoload 'mailcap-extension-to-mime "mailcap")) + +(defvar mm-archive-decoders + '(("application/ms-tnef" t "tnef" "-f" "-" "-C") + ("application/zip" nil "unzip" "-j" "-x" "%f" "-d") + ("application/x-gtar-compressed" nil "tar" "xzf" "-" "-C") + ("application/x-tar" nil "tar" "xf" "-" "-C"))) + +(defun mm-archive-decoders () mm-archive-decoders) + +(defun mm-dissect-archive (handle) + (let ((decoder (cddr (assoc (car (mm-handle-type handle)) + mm-archive-decoders))) + (dir (mm-make-temp-file + (expand-file-name "emm." mm-tmp-directory) 'dir))) + (set-file-modes dir #o700) + (unwind-protect + (progn + (mm-with-unibyte-buffer + (mm-insert-part handle) + (if (member "%f" decoder) + (let ((file (expand-file-name "mail.zip" dir))) + (write-region (point-min) (point-max) file nil 'silent) + (setq decoder (copy-sequence decoder)) + (setcar (member "%f" decoder) file) + (apply 'call-process (car decoder) nil nil nil + (append (cdr decoder) (list dir))) + (delete-file file)) + (apply 'call-process-region (point-min) (point-max) (car decoder) + nil (get-buffer-create "*tnef*") + nil (append (cdr decoder) (list dir))))) + `("multipart/mixed" + ,handle + ,@(mm-archive-list-files (gnus-recursive-directory-files dir)))) + (delete-directory dir t)))) + +(defun mm-archive-list-files (files) + (let ((handles nil) + type disposition) + (dolist (file files) + (with-temp-buffer + (when (string-match "\\.\\([^.]+\\)$" file) + (setq type (mailcap-extension-to-mime (match-string 1 file)))) + (unless type + (setq type "application/octet-stream")) + (setq disposition + (if (string-match "^image/\\|^text/" type) + "inline" + "attachment")) + (insert (format "Content-type: %s\n" type)) + (insert "Content-Transfer-Encoding: 8bit\n\n") + (insert-file-contents file) + (push + (mm-make-handle (mm-copy-to-buffer) + (list type) + '8bit nil + `(,disposition (filename . ,file)) + nil nil nil) + handles))) + handles)) + +(defun mm-archive-dissect-and-inline (handle) + (let ((start (point-marker))) + (save-restriction + (narrow-to-region (point) (point)) + (dolist (handle (cddr (mm-dissect-archive handle))) + (goto-char (point-max)) + (mm-display-inline handle)) + (goto-char (point-max)) + (mm-handle-set-undisplayer + handle + `(lambda () + (let ((inhibit-read-only t) + (end ,(point-marker))) + (remove-images ,start end) + (delete-region ,start end))))))) + +(provide 'mm-archive) + +;; mm-archive.el ends here diff --git a/lisp/gnus/tests/gnustest-nntp.el b/lisp/gnus/tests/gnustest-nntp.el new file mode 100644 index 00000000000..1ce972520d3 --- /dev/null +++ b/lisp/gnus/tests/gnustest-nntp.el @@ -0,0 +1,94 @@ +;;; gnustest-nntp.el --- Simple NNTP testing for Gnus +;; Copyright (C) 2011-2012 Free Software Foundation, Inc. + +;; Author: David Engster + +;; This file is not 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, 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; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Commentary: + +;; This test will +;; +;; - Fire up Gnus +;; - Connect to Gmane +;; - Subscribe to gmane.discuss +;; - Get its active info +;; - Get one specific article by message-id and check its subject +;; - Quit Gnus + +;;; Code: + +(require 'ert) +(require 'net-utils) + +(defvar gnustest-nntp-server "news.gmane.org" + "NNTP server used for testing.") + +(defun gnustest-ping-host (host) + "Ping HOST once and return non-nil if successful." + (let* ((ping-program-options '("-c" "1")) + (buf (ping host)) + proc) + (sleep-for 0.5) + (with-current-buffer buf + (accept-process-output (get-buffer-process (current-buffer)) 2) + (goto-char (point-min)) + (prog1 + (re-search-forward ",[ ]*1.*?received,[ ]*0" nil t) + (when (setq proc (get-buffer-process (current-buffer))) + (set-process-query-on-exit-flag proc nil)) + (kill-buffer))))) + +(setq gnus-home-directory (concat temporary-file-directory (make-temp-name "gnus-test-"))) +(message "***** Using %s as temporary Gnus home." gnus-home-directory) +(mkdir gnus-home-directory) +(setq-default gnus-init-file nil) + +(require 'gnus-load) + +(setq gnus-select-method `(nntp ,gnustest-nntp-server)) + + +(if (null (gnustest-ping-host gnustest-nntp-server)) + (message "***** Skipping tests: Gmane doesn't seem to be available.") + ;; Server seems to be available, so start Gnus. + (message "***** Firing up Gnus; connecting to Gmane.") + (gnus) + + (ert-deftest gnustest-nntp-run-simple-test () + "Test Gnus with gmane.discuss." + (set-buffer gnus-group-buffer) + (gnus-group-jump-to-group "gmane.discuss") + (gnus-group-get-new-news-this-group 1) + (gnus-active "gmane.discuss") + (message "***** Reading active from gmane.discuss.") + (should (> (car (gnus-active "gmane.discuss")) 0)) + (should (> (cdr (gnus-active "gmane.discuss")) 10000)) + (gnus-group-unsubscribe-current-group) + (gnus-group-set-current-level 1 1) + (gnus-group-select-group 5) + (message "***** Getting article with certain MID and check subject.") + (set-buffer gnus-summary-buffer) + (gnus-summary-refer-article "m3mxr8pa1t.fsf@quimbies.gnus.org") + (should (string= (gnus-summary-article-subject) "Re: gwene idea: strip from from subject if present")) + (gnus-summary-exit) + (message "***** Quitting Gnus.") + (set-buffer gnus-group-buffer) + (gnus-group-save-newsrc) + (gnus-group-exit)) +) diff --git a/lisp/gnus/tests/gnustest-registry.el b/lisp/gnus/tests/gnustest-registry.el new file mode 100644 index 00000000000..512fab49939 --- /dev/null +++ b/lisp/gnus/tests/gnustest-registry.el @@ -0,0 +1,216 @@ +;;; gnustest-registry.el --- Registry and Gnus registry testing for Gnus +;; Copyright (C) 2011-2012 Free Software Foundation, Inc. + +;; Author: Ted Zlatanov + +;; This file is not 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, 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; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Commentary: + +;;; Code: + +(eval-when-compile + (when (null (ignore-errors (require 'ert))) + (defmacro* ert-deftest (name () &body docstring-keys-and-body)))) + +(ignore-errors + (require 'ert)) + +(require 'registry) +(require 'gnus-registry) + +(ert-deftest gnustest-registry-instantiation-test () + (should (registry-db "Testing"))) + +(ert-deftest gnustest-registry-match-test () + (let ((entry '((hello "goodbye" "bye") (blank)))) + + (message "Testing :regex matching") + (should (registry--match :regex entry '((hello "nye" "bye")))) + (should (registry--match :regex entry '((hello "good")))) + (should-not (registry--match :regex entry '((hello "nye")))) + (should-not (registry--match :regex entry '((hello)))) + + (message "Testing :member matching") + (should (registry--match :member entry '((hello "bye")))) + (should (registry--match :member entry '((hello "goodbye")))) + (should-not (registry--match :member entry '((hello "good")))) + (should-not (registry--match :member entry '((hello "nye")))) + (should-not (registry--match :member entry '((hello))))) + (message "Done with matching testing.")) + +(defun gnustest-registry-make-testable-db (n &optional name file) + (let* ((db (registry-db + (or name "Testing") + :file (or file "unused") + :max-hard n + :max-soft 0 ; keep nothing not precious + :precious '(extra more-extra) + :tracked '(sender subject groups)))) + (dotimes (i n) + (registry-insert db i `((sender "me") + (subject "about you") + (more-extra) ; empty data key should be pruned + ;; first 5 entries will NOT have this extra data + ,@(when (< 5 i) (list (list 'extra "more data"))) + (groups ,(number-to-string i))))) + db)) + +(ert-deftest gnustest-registry-usage-test () + (let* ((n 100) + (db (gnustest-registry-make-testable-db n))) + (message "size %d" n) + (should (= n (registry-size db))) + (message "max-hard test") + (should-error (registry-insert db "new" '())) + (message "Individual lookup") + (should (= 58 (caadr (registry-lookup db '(1 58 99))))) + (message "Grouped individual lookup") + (should (= 3 (length (registry-lookup db '(1 58 99))))) + (when (boundp 'lexical-binding) + (message "Individual lookup (breaks before lexbind)") + (should (= 58 + (caadr (registry-lookup-breaks-before-lexbind db '(1 58 99))))) + (message "Grouped individual lookup (breaks before lexbind)") + (should (= 3 + (length (registry-lookup-breaks-before-lexbind db + '(1 58 99)))))) + (message "Search") + (should (= n (length (registry-search db :all t)))) + (should (= n (length (registry-search db :member '((sender "me")))))) + (message "Secondary index search") + (should (= n (length (registry-lookup-secondary-value db 'sender "me")))) + (should (equal '(74) (registry-lookup-secondary-value db 'groups "74"))) + (message "Delete") + (should (registry-delete db '(1) t)) + (decf n) + (message "Search after delete") + (should (= n (length (registry-search db :all t)))) + (message "Secondary search after delete") + (should (= n (length (registry-lookup-secondary-value db 'sender "me")))) + ;; (message "Pruning") + ;; (let* ((tokeep (registry-search db :member '((extra "more data")))) + ;; (count (- n (length tokeep))) + ;; (pruned (registry-prune db)) + ;; (prune-count (length pruned))) + ;; (message "Expecting to prune %d entries and pruned %d" + ;; count prune-count) + ;; (should (and (= count 5) + ;; (= count prune-count)))) + (message "Done with usage testing."))) + +(ert-deftest gnustest-registry-persistence-test () + (let* ((n 100) + (tempfile (make-temp-file "registry-persistence-")) + (name "persistence tester") + (db (gnustest-registry-make-testable-db n name tempfile)) + size back) + (message "Saving to %s" tempfile) + (eieio-persistent-save db) + (setq size (nth 7 (file-attributes tempfile))) + (message "Saved to %s: size %d" tempfile size) + (should (< 0 size)) + (with-temp-buffer + (insert-file-contents-literally tempfile) + (should (looking-at (concat ";; Object " + name + "\n;; EIEIO PERSISTENT OBJECT")))) + (message "Reading object back") + (setq back (eieio-persistent-read tempfile)) + (should back) + (message "Read object back: %d keys, expected %d==%d" + (registry-size back) n (registry-size db)) + (should (= (registry-size back) n)) + (should (= (registry-size back) (registry-size db))) + (delete-file tempfile)) + (message "Done with persistence testing.")) + +(ert-deftest gnustest-gnus-registry-misc-test () + (should-error (gnus-registry-extract-addresses '("" ""))) + + (should (equal '("Ted Zlatanov " + "noname " + "noname " + "noname ") + (gnus-registry-extract-addresses + (concat "Ted Zlatanov , " + "ed , " ; "ed" is not a valid name here + "cyd@stupidchicken.com, " + "tzz@lifelogs.com"))))) + +(ert-deftest gnustest-gnus-registry-usage-test () + (let* ((n 100) + (tempfile (make-temp-file "gnus-registry-persist")) + (db (gnus-registry-make-db tempfile)) + (gnus-registry-db db) + back size) + (message "Adding %d keys to the test Gnus registry" n) + (dotimes (i n) + (let ((id (number-to-string i))) + (gnus-registry-handle-action id + (if (>= 50 i) "fromgroup" nil) + "togroup" + (when (>= 70 i) + (format "subject %d" (mod i 10))) + (when (>= 80 i) + (format "sender %d" (mod i 10)))))) + (message "Testing Gnus registry size is %d" n) + (should (= n (registry-size db))) + (message "Looking up individual keys (registry-lookup)") + (should (equal (loop for e + in (mapcar 'cadr + (registry-lookup db '("20" "83" "72"))) + collect (assq 'subject e) + collect (assq 'sender e) + collect (assq 'group e)) + '((subject "subject 0") (sender "sender 0") (group "togroup") + (subject) (sender) (group "togroup") + (subject) (sender "sender 2") (group "togroup")))) + + (message "Looking up individual keys (gnus-registry-id-key)") + (should (equal (gnus-registry-get-id-key "34" 'group) '("togroup"))) + (should (equal (gnus-registry-get-id-key "34" 'subject) '("subject 4"))) + (message "Trying to insert a duplicate key") + (should-error (gnus-registry-insert db "55" '())) + (message "Looking up individual keys (gnus-registry-get-or-make-entry)") + (should (gnus-registry-get-or-make-entry "22")) + (message "Saving the Gnus registry to %s" tempfile) + (should (gnus-registry-save tempfile db)) + (setq size (nth 7 (file-attributes tempfile))) + (message "Saving the Gnus registry to %s: size %d" tempfile size) + (should (< 0 size)) + (with-temp-buffer + (insert-file-contents-literally tempfile) + (should (looking-at (concat ";; Object " + "Gnus Registry" + "\n;; EIEIO PERSISTENT OBJECT")))) + (message "Reading Gnus registry back") + (setq back (eieio-persistent-read tempfile)) + (should back) + (message "Read Gnus registry back: %d keys, expected %d==%d" + (registry-size back) n (registry-size db)) + (should (= (registry-size back) n)) + (should (= (registry-size back) (registry-size db))) + (delete-file tempfile) + (message "Pruning Gnus registry to 0 by setting :max-soft") + (oset db :max-soft 0) + (registry-prune db) + (should (= (registry-size db) 0))) + (message "Done with Gnus registry usage testing.")) + +(provide 'gnustest-registry) -- 2.11.4.GIT