Add lisp/gnus/mm-archive.el, lisp/gnus/tests/gnustest-nntp.el, and lisp/gnus/tests/gnustest-registry.el

3 files changed, 417 insertions, 0 deletions

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 <larsi@gnus.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 '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 <dengste@eml.cc>
+
+;; 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 <tzz@lifelogs.com>
+
+;; 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 <tzz@lifelogs.com>"
+                   "noname <ed@you.me>"
+                   "noname <cyd@stupidchicken.com>"
+                   "noname <tzz@lifelogs.com>")
+                 (gnus-registry-extract-addresses
+                  (concat "Ted Zlatanov <tzz@lifelogs.com>, "
+                          "ed <ed@you.me>, " ; "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)