mirror/emacs
1
0
Fork 0
mirror of https://git.savannah.gnu.org/git/emacs.git synced 2024-11-22 07:09:54 +00:00
Code Issues Releases Activity

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

Browse Source
This commit is contained in:
Gnus developers 2012-06-26 22:55:13 +00:00 committed by Katsumi Yamaoka
parent 89b163db28
commit 3ea82dffd7
3 changed files with 417 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

107
lisp/gnus/mm-archive.el Normal file
View File

@ -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

94
lisp/gnus/tests/gnustest-nntp.el Normal file
View File

@ -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))
)

216
lisp/gnus/tests/gnustest-registry.el Normal file
View File

@ -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)