aboutsummaryrefslogtreecommitdiffstats
path: root/lisp
diff options
context:
space:
mode:
authorGnus developers2010-09-26 04:03:19 +0000
committerKatsumi Yamaoka2010-09-26 04:03:19 +0000
commit8ccbef23ea624d892bada3c66ef2339ada342997 (patch)
treeb8baaa6929a0742ffd301529bcc27001dd08e031 /lisp
parent83e245c4906513429cb56629485deb5f04a240a3 (diff)
downloademacs-8ccbef23ea624d892bada3c66ef2339ada342997.tar.gz
emacs-8ccbef23ea624d892bada3c66ef2339ada342997.zip
Merge changes made in Gnus trunk.
nnimap.el: Implement partial IMAP article fetch. nnimap.el: Have nnimap not update the infos if it can't get info from the server. Implement functions for showing the complete articles. gnus-int.el (gnus-open-server): Don't query whether to go offline -- just do it. gnus-art.el (gnus-mime-delete-part): Fix plural for "byte" when there isn't a single byte. nndoc.el (nndoc-type-alist): Move mime-parts after mbox. Suggested by Jay Berkenbilt. mm-decode.el (mm-save-part): Allow saving to other directories the normal Emacs way. gnus-html.el (gnus-html-rescale-image): Use our defalias gnus-window-inside-pixel-edges. gnus-srvr.el (gnus-server-copy-server): Add documentation. gnus.texi (Using IMAP): Document the new nnimap. nnimap.el (nnimap-wait-for-response): Search further when we're not using streaming. gnus-int.el (gnus-check-server): Say what the error was when opening failed. nnheader.el (nnheader-get-report-string): New function. gnus-int.el (gnus-check-server): Use report-string. nnimap.el (nnimap-open-connection): Add more error reporting when nnimap fails early. gnus-start.el (gnus-get-unread-articles): Don't try to open failed servers twice. nnimap.el (nnimap-wait-for-response): Reversed logic in the nnimap-streaming test. gnus-art.el: Removed CTAN button stuff, which I don't think is very relevant any more. Remove NoCeM support, since nobody seems to use it any more. Remove earcon and gnus-audio. gnus.el (gnus): Silence gnus-load message. gnus-group.el (gnus-read-ephemeral-bug-group): Add the bug email address to the To list for easier response. gnus.texi (Connecting to an IMAP Server): Show how to use as primary method instead of secondary.
Diffstat (limited to 'lisp')
-rw-r--r--lisp/gnus/earcon.el230
-rw-r--r--lisp/gnus/gnus-art.el120
-rw-r--r--lisp/gnus/gnus-audio.el149
-rw-r--r--lisp/gnus/gnus-cus.el5
-rw-r--r--lisp/gnus/gnus-demon.el9
-rw-r--r--lisp/gnus/gnus-group.el16
-rw-r--r--lisp/gnus/gnus-html.el9
-rw-r--r--lisp/gnus/gnus-int.el68
-rw-r--r--lisp/gnus/gnus-nocem.el452
-rw-r--r--lisp/gnus/gnus-srvr.el62
-rw-r--r--lisp/gnus/gnus-start.el15
-rw-r--r--lisp/gnus/gnus-sum.el25
-rw-r--r--lisp/gnus/gnus.el37
-rw-r--r--lisp/gnus/mm-decode.el24
-rw-r--r--lisp/gnus/mml1991.el95
-rw-r--r--lisp/gnus/mml2015.el365
-rw-r--r--lisp/gnus/nndoc.el6
-rw-r--r--lisp/gnus/nnheader.el12
-rw-r--r--lisp/gnus/nnimap.el269
19 files changed, 418 insertions, 1550 deletions
diff --git a/lisp/gnus/earcon.el b/lisp/gnus/earcon.el
deleted file mode 100644
index 2086f86c417..00000000000
--- a/lisp/gnus/earcon.el
+++ /dev/null
@@ -1,230 +0,0 @@
1;;; earcon.el --- Sound effects for messages
2
3;; Copyright (C) 1996, 2000, 2001, 2002, 2003, 2004,
4;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
5
6;; Author: Steven L. Baur <steve@miranova.com>
7
8;; This file is part of GNU Emacs.
9
10;; GNU Emacs is free software: you can redistribute it and/or modify
11;; it under the terms of the GNU General Public License as published by
12;; the Free Software Foundation, either version 3 of the License, or
13;; (at your option) any later version.
14
15;; GNU Emacs is distributed in the hope that it will be useful,
16;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18;; GNU General Public License for more details.
19
20;; You should have received a copy of the GNU General Public License
21;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
22
23;;; Commentary:
24;; This file provides access to sound effects in Gnus.
25
26;;; Code:
27
28(eval-when-compile (require 'cl))
29(require 'gnus)
30(require 'gnus-audio)
31(require 'gnus-art)
32
33(defgroup earcon nil
34 "Turn ** sounds ** into noise."
35 :group 'gnus-visual)
36
37(defcustom earcon-prefix "**"
38 "*String denoting the start of an earcon."
39 :type 'string
40 :group 'earcon)
41
42(defcustom earcon-suffix "**"
43 "String denoting the end of an earcon."
44 :type 'string
45 :group 'earcon)
46
47(defcustom earcon-regexp-alist
48 '(("boring" 1 "Boring.au")
49 ("evil[ \t]+laugh" 1 "Evil_Laugh.au")
50 ("gag\\|puke" 1 "Puke.au")
51 ("snicker" 1 "Snicker.au")
52 ("meow" 1 "catmeow.wav")
53 ("sob\\|boohoo" 1 "cry.wav")
54 ("drum[ \t]*roll" 1 "drumroll.au")
55 ("blast" 1 "explosion.au")
56 ("flush\\|plonk!*" 1 "flush.au")
57 ("kiss" 1 "kiss.wav")
58 ("tee[ \t]*hee" 1 "laugh.au")
59 ("shoot" 1 "shotgun.wav")
60 ("yawn" 1 "snore.wav")
61 ("cackle" 1 "witch.au")
62 ("yell\\|roar" 1 "yell2.au")
63 ("whoop-de-doo" 1 "whistle.au"))
64 "*A list of regexps to map earcons to real sounds."
65 :type '(repeat (list regexp
66 (integer :tag "Match")
67 (string :tag "Sound")))
68 :group 'earcon)
69(defvar earcon-button-marker-list nil)
70(make-variable-buffer-local 'earcon-button-marker-list)
71
72;;; FIXME!! clone of code from gnus-vis.el FIXME!!
73(defun earcon-article-push-button (event)
74 "Check text under the mouse pointer for a callback function.
75If the text under the mouse pointer has a `earcon-callback' property,
76call it with the value of the `earcon-data' text property."
77 (interactive "e")
78 (set-buffer (window-buffer (posn-window (event-start event))))
79 (let* ((pos (posn-point (event-start event)))
80 (data (get-text-property pos 'earcon-data))
81 (fun (get-text-property pos 'earcon-callback)))
82 (if fun (funcall fun data))))
83
84(defun earcon-article-press-button ()
85 "Check text at point for a callback function.
86If the text at point has a `earcon-callback' property,
87call it with the value of the `earcon-data' text property."
88 (interactive)
89 (let* ((data (get-text-property (point) 'earcon-data))
90 (fun (get-text-property (point) 'earcon-callback)))
91 (if fun (funcall fun data))))
92
93(defun earcon-article-prev-button (n)
94 "Move point to N buttons backward.
95If N is negative, move forward instead."
96 (interactive "p")
97 (earcon-article-next-button (- n)))
98
99(defun earcon-article-next-button (n)
100 "Move point to N buttons forward.
101If N is negative, move backward instead."
102 (interactive "p")
103 (let ((function (if (< n 0) 'previous-single-property-change
104 'next-single-property-change))
105 (inhibit-point-motion-hooks t)
106 (backward (< n 0))
107 (limit (if (< n 0) (point-min) (point-max))))
108 (setq n (abs n))
109 (while (and (not (= limit (point)))
110 (> n 0))
111 ;; Skip past the current button.
112 (when (get-text-property (point) 'earcon-callback)
113 (goto-char (funcall function (point) 'earcon-callback nil limit)))
114 ;; Go to the next (or previous) button.
115 (gnus-goto-char (funcall function (point) 'earcon-callback nil limit))
116 ;; Put point at the start of the button.
117 (when (and backward (not (get-text-property (point) 'earcon-callback)))
118 (goto-char (funcall function (point) 'earcon-callback nil limit)))
119 ;; Skip past intangible buttons.
120 (when (get-text-property (point) 'intangible)
121 (incf n))
122 (decf n))
123 (unless (zerop n)
124 (gnus-message 5 "No more buttons"))
125 n))
126
127(defun earcon-article-add-button (from to fun &optional data)
128 "Create a button between FROM and TO with callback FUN and data DATA."
129 (and (boundp gnus-article-button-face)
130 gnus-article-button-face
131 (gnus-overlay-put (gnus-make-overlay from to)
132 'face gnus-article-button-face))
133 (gnus-add-text-properties
134 from to
135 (nconc (and gnus-article-mouse-face
136 (list gnus-mouse-face-prop gnus-article-mouse-face))
137 (list 'gnus-callback fun)
138 (and data (list 'gnus-data data)))))
139
140(defun earcon-button-entry ()
141 ;; Return the first entry in `gnus-button-alist' matching this place.
142 (let ((alist earcon-regexp-alist)
143 (case-fold-search t)
144 (entry nil))
145 (while alist
146 (setq entry (pop alist))
147 (if (looking-at (car entry))
148 (setq alist nil)
149 (setq entry nil)))
150 entry))
151
152(defun earcon-button-push (marker)
153 ;; Push button starting at MARKER.
154 (with-current-buffer gnus-article-buffer
155 (goto-char marker)
156 (let* ((entry (earcon-button-entry))
157 (inhibit-point-motion-hooks t)
158 (fun 'gnus-audio-play)
159 (args (list (nth 2 entry))))
160 (cond
161 ((fboundp fun)
162 (apply fun args))
163 ((and (boundp fun)
164 (fboundp (symbol-value fun)))
165 (apply (symbol-value fun) args))
166 (t
167 (gnus-message 1 "You must define `%S' to use this button"
168 (cons fun args)))))))
169
170;;; FIXME!! clone of code from gnus-vis.el FIXME!!
171
172;;;###interactive
173(defun earcon-region (beg end)
174 "Play Sounds in the region between point and mark."
175 (interactive "r")
176 (earcon-buffer (current-buffer) beg end))
177
178;;;###interactive
179(defun earcon-buffer (&optional buffer st nd)
180 (interactive)
181 (save-excursion
182 ;; clear old markers.
183 (if (boundp 'earcon-button-marker-list)
184 (while earcon-button-marker-list
185 (set-marker (pop earcon-button-marker-list) nil))
186 (setq earcon-button-marker-list nil))
187 (and buffer (set-buffer buffer))
188 (let ((buffer-read-only nil)
189 (inhibit-point-motion-hooks t)
190 (case-fold-search t)
191 (alist earcon-regexp-alist)
192 beg entry regexp)
193 (goto-char (point-min))
194 (setq beg (point))
195 (while (setq entry (pop alist))
196 (setq regexp (concat (regexp-quote earcon-prefix)
197 ".*\\("
198 (car entry)
199 "\\).*"
200 (regexp-quote earcon-suffix)))
201 (goto-char beg)
202 (while (re-search-forward regexp nil t)
203 (let* ((start (and entry (match-beginning 1)))
204 (end (and entry (match-end 1)))
205 (from (match-beginning 1)))
206 (earcon-article-add-button
207 start end 'earcon-button-push
208 (car (push (set-marker (make-marker) from)
209 earcon-button-marker-list)))
210 (gnus-audio-play (caddr entry))))))))
211
212;;;###autoload
213(defun gnus-earcon-display ()
214 "Play sounds in message buffers."
215 (interactive)
216 (with-current-buffer gnus-article-buffer
217 (goto-char (point-min))
218 ;; Skip headers
219 (unless (search-forward "\n\n" nil t)
220 (goto-char (point-max)))
221 (sit-for 0)
222 (earcon-buffer (current-buffer) (point))))
223
224;;;***
225
226(provide 'earcon)
227
228(run-hooks 'earcon-load-hook)
229
230;;; earcon.el ends here
diff --git a/lisp/gnus/gnus-art.el b/lisp/gnus/gnus-art.el
index fd6957d9aac..8a0f0a3c388 100644
--- a/lisp/gnus/gnus-art.el
+++ b/lisp/gnus/gnus-art.el
@@ -257,6 +257,22 @@ This can also be a list of the above values."
257 (regexp :value ".*")) 257 (regexp :value ".*"))
258 :group 'gnus-article-signature) 258 :group 'gnus-article-signature)
259 259
260(defcustom gnus-fetch-partial-articles nil
261 "If non-nil, Gnus will fetch partial articles.
262If t, nnimap will fetch only the first part. If a string, it
263will fetch all parts that have types that match that string. A
264likely value would be \"text/\" to automatically fetch all
265textual parts.
266
267Currently only the nnimap backend actually supports partial
268article fetching. If the backend doesn't support it, it has no
269effect."
270 :version "24.1"
271 :type '(choice (const nil)
272 (const t)
273 (regexp))
274 :group 'gnus-article)
275
260(defcustom gnus-hidden-properties '(invisible t intangible t) 276(defcustom gnus-hidden-properties '(invisible t intangible t)
261 "Property list to use for hiding text." 277 "Property list to use for hiding text."
262 :type 'sexp 278 :type 'sexp
@@ -1598,15 +1614,6 @@ predicate. See Info node `(gnus)Customizing Articles'."
1598 :link '(custom-manual "(gnus)Customizing Articles") 1614 :link '(custom-manual "(gnus)Customizing Articles")
1599 :type gnus-article-treat-custom) 1615 :type gnus-article-treat-custom)
1600 1616
1601(defcustom gnus-treat-play-sounds nil
1602 "Play sounds.
1603Valid values are nil, t, `head', `first', `last', an integer or a
1604predicate. See Info node `(gnus)Customizing Articles'."
1605 :version "21.1"
1606 :group 'gnus-article-treat
1607 :link '(custom-manual "(gnus)Customizing Articles")
1608 :type gnus-article-treat-custom)
1609
1610(defcustom gnus-treat-x-pgp-sig nil 1617(defcustom gnus-treat-x-pgp-sig nil
1611 "Verify X-PGP-Sig. 1618 "Verify X-PGP-Sig.
1612To automatically treat X-PGP-Sig, set it to head. 1619To automatically treat X-PGP-Sig, set it to head.
@@ -1711,8 +1718,7 @@ This requires GNU Libidn, and by default only enabled if it is found."
1711 (gnus-treat-hide-citation gnus-article-hide-citation) 1718 (gnus-treat-hide-citation gnus-article-hide-citation)
1712 (gnus-treat-hide-citation-maybe gnus-article-hide-citation-maybe) 1719 (gnus-treat-hide-citation-maybe gnus-article-hide-citation-maybe)
1713 (gnus-treat-highlight-citation gnus-article-highlight-citation) 1720 (gnus-treat-highlight-citation gnus-article-highlight-citation)
1714 (gnus-treat-body-boundary gnus-article-treat-body-boundary) 1721 (gnus-treat-body-boundary gnus-article-treat-body-boundary)))
1715 (gnus-treat-play-sounds gnus-earcon-display)))
1716 1722
1717(defvar gnus-article-mime-handle-alist nil) 1723(defvar gnus-article-mime-handle-alist nil)
1718(defvar article-lapsed-timer nil) 1724(defvar article-lapsed-timer nil)
@@ -5075,7 +5081,10 @@ Deleting parts may malfunction or destroy the article; continue? "))
5075 "|\n" 5081 "|\n"
5076 "| Type: " type "\n" 5082 "| Type: " type "\n"
5077 "| Filename: " filename "\n" 5083 "| Filename: " filename "\n"
5078 "| Size (encoded): " bsize " Byte\n" 5084 "| Size (encoded): " bsize (format " byte%s\n"
5085 (if (= bsize 1)
5086 ""
5087 "s"))
5079 (when description 5088 (when description
5080 (concat "| Description: " description "\n")) 5089 (concat "| Description: " description "\n"))
5081 "`----\n")) 5090 "`----\n"))
@@ -7030,9 +7039,7 @@ groups."
7030 (gnus-backlog-remove-article 7039 (gnus-backlog-remove-article
7031 (car gnus-article-current) (cdr gnus-article-current))) 7040 (car gnus-article-current) (cdr gnus-article-current)))
7032 ;; Flush original article as well. 7041 ;; Flush original article as well.
7033 (when (get-buffer gnus-original-article-buffer) 7042 (gnus-flush-original-article-buffer)
7034 (with-current-buffer gnus-original-article-buffer
7035 (setq gnus-original-article nil)))
7036 (when gnus-use-cache 7043 (when gnus-use-cache
7037 (gnus-cache-update-article 7044 (gnus-cache-update-article
7038 (car gnus-article-current) (cdr gnus-article-current))) 7045 (car gnus-article-current) (cdr gnus-article-current)))
@@ -7046,6 +7053,11 @@ groups."
7046 (set-window-point (get-buffer-window buf) (point))) 7053 (set-window-point (get-buffer-window buf) (point)))
7047 (gnus-summary-show-article)) 7054 (gnus-summary-show-article))
7048 7055
7056(defun gnus-flush-original-article-buffer ()
7057 (when (get-buffer gnus-original-article-buffer)
7058 (with-current-buffer gnus-original-article-buffer
7059 (setq gnus-original-article nil))))
7060
7049(defun gnus-article-edit-exit () 7061(defun gnus-article-edit-exit ()
7050 "Exit the article editing without updating." 7062 "Exit the article editing without updating."
7051 (interactive) 7063 (interactive)
@@ -7134,46 +7146,6 @@ man page."
7134 (function :tag "Other")) 7146 (function :tag "Other"))
7135 :group 'gnus-article-buttons) 7147 :group 'gnus-article-buttons)
7136 7148
7137(defcustom gnus-ctan-url "http://tug.ctan.org/tex-archive/"
7138 "Top directory of a CTAN \(Comprehensive TeX Archive Network\) archive.
7139If the default site is too slow, try to find a CTAN mirror, see
7140<URL:http://tug.ctan.org/tex-archive/CTAN.sites?action=/index.html>. See also
7141the variable `gnus-button-handle-ctan'."
7142 :version "22.1"
7143 :group 'gnus-article-buttons
7144 :link '(custom-manual "(gnus)Group Parameters")
7145 :type '(choice (const "http://www.tex.ac.uk/tex-archive/")
7146 (const "http://tug.ctan.org/tex-archive/")
7147 (const "http://www.dante.de/CTAN/")
7148 (string :tag "Other")))
7149
7150(defcustom gnus-button-ctan-handler 'browse-url
7151 "Function to use for displaying CTAN links.
7152The function must take one argument, the string naming the URL."
7153 :version "22.1"
7154 :type '(choice (function-item :tag "Browse Url" browse-url)
7155 (function :tag "Other"))
7156 :group 'gnus-article-buttons)
7157
7158(defcustom gnus-button-handle-ctan-bogus-regexp "^/?tex-archive/\\|^/"
7159 "Bogus strings removed from CTAN URLs."
7160 :version "22.1"
7161 :group 'gnus-article-buttons
7162 :type '(choice (const "^/?tex-archive/\\|/")
7163 (regexp :tag "Other")))
7164
7165(defcustom gnus-button-ctan-directory-regexp
7166 (regexp-opt
7167 (list "archive-tools" "biblio" "bibliography" "digests" "documentation"
7168 "dviware" "fonts" "graphics" "help" "indexing" "info" "language"
7169 "languages" "macros" "nonfree" "obsolete" "support" "systems"
7170 "tds" "tools" "usergrps" "web") t)
7171 "Regular expression for ctan directories.
7172It should match all directories in the top level of `gnus-ctan-url'."
7173 :version "22.1"
7174 :group 'gnus-article-buttons
7175 :type 'regexp)
7176
7177(defcustom gnus-button-mid-or-mail-regexp 7149(defcustom gnus-button-mid-or-mail-regexp
7178 (concat "\\b\\(<?" gnus-button-valid-localpart-regexp "@" 7150 (concat "\\b\\(<?" gnus-button-valid-localpart-regexp "@"
7179 gnus-button-valid-fqdn-regexp 7151 gnus-button-valid-fqdn-regexp
@@ -7431,26 +7403,6 @@ Calls `describe-variable' or `describe-function'."
7431 (gnus-message 1 "Cannot locale library `%s'." url) 7403 (gnus-message 1 "Cannot locale library `%s'." url)
7432 (find-file-read-only file)))) 7404 (find-file-read-only file))))
7433 7405
7434(defun gnus-button-handle-ctan (url)
7435 "Call `browse-url' when pushing a CTAN URL button."
7436 (funcall
7437 gnus-button-ctan-handler
7438 (concat
7439 gnus-ctan-url
7440 (gnus-replace-in-string url gnus-button-handle-ctan-bogus-regexp ""))))
7441
7442(defcustom gnus-button-tex-level 5
7443 "*Integer that says how many TeX-related buttons Gnus will show.
7444The higher the number, the more buttons will appear and the more false
7445positives are possible. Note that you can set this variable local to
7446specific groups. Setting it higher in TeX groups is probably a good idea.
7447See Info node `(gnus)Group Parameters' and the variable `gnus-parameters' on
7448how to set variables in specific groups."
7449 :version "22.1"
7450 :group 'gnus-article-buttons
7451 :link '(custom-manual "(gnus)Group Parameters")
7452 :type 'integer)
7453
7454(defcustom gnus-button-man-level 5 7406(defcustom gnus-button-man-level 5
7455 "*Integer that says how many man-related buttons Gnus will show. 7407 "*Integer that says how many man-related buttons Gnus will show.
7456The higher the number, the more buttons will appear and the more false 7408The higher the number, the more buttons will appear and the more false
@@ -7517,20 +7469,6 @@ positives are possible."
7517 0 (>= gnus-button-message-level 0) gnus-url-mailto 1) 7469 0 (>= gnus-button-message-level 0) gnus-url-mailto 1)
7518 ("\\bmailto:\\([^ \n\t]+\\)" 7470 ("\\bmailto:\\([^ \n\t]+\\)"
7519 0 (>= gnus-button-message-level 0) gnus-url-mailto 1) 7471 0 (>= gnus-button-message-level 0) gnus-url-mailto 1)
7520 ;; CTAN
7521 ((concat "\\bCTAN:[ \t\n]?[^>)!;:,'\n\t ]*\\("
7522 gnus-button-ctan-directory-regexp
7523 "[^][>)!;:,'\n\t ]+\\)")
7524 0 (>= gnus-button-tex-level 1) gnus-button-handle-ctan 1)
7525 ((concat "\\btex-archive/\\("
7526 gnus-button-ctan-directory-regexp
7527 "/[-_.a-z0-9/]+[-_./a-z0-9]+[/a-z0-9]\\)")
7528 1 (>= gnus-button-tex-level 6) gnus-button-handle-ctan 1)
7529 ((concat
7530 "\\b\\("
7531 gnus-button-ctan-directory-regexp
7532 "/[-_.a-z0-9]+/[-_./a-z0-9]+[/a-z0-9]\\)")
7533 1 (>= gnus-button-tex-level 8) gnus-button-handle-ctan 1)
7534 ;; Info Konqueror style <info:/foo/bar baz>. 7472 ;; Info Konqueror style <info:/foo/bar baz>.
7535 ;; Must come before " Gnus home-grown style". 7473 ;; Must come before " Gnus home-grown style".
7536 ("\\binfo://?\\([^'\">\n\t]+\\)" 7474 ("\\binfo://?\\([^'\">\n\t]+\\)"
@@ -8512,9 +8450,7 @@ For example:
8512 (when gnus-keep-backlog 8450 (when gnus-keep-backlog
8513 (gnus-backlog-remove-article 8451 (gnus-backlog-remove-article
8514 (car gnus-article-current) (cdr gnus-article-current))) 8452 (car gnus-article-current) (cdr gnus-article-current)))
8515 (when (get-buffer gnus-original-article-buffer) 8453 (gnus-flush-original-article-buffer)
8516 (with-current-buffer gnus-original-article-buffer
8517 (setq gnus-original-article nil)))
8518 (when gnus-use-cache 8454 (when gnus-use-cache
8519 (gnus-cache-update-article 8455 (gnus-cache-update-article
8520 (car gnus-article-current) (cdr gnus-article-current)))))))) 8456 (car gnus-article-current) (cdr gnus-article-current))))))))
diff --git a/lisp/gnus/gnus-audio.el b/lisp/gnus/gnus-audio.el
deleted file mode 100644
index cc198176f10..00000000000
--- a/lisp/gnus/gnus-audio.el
+++ /dev/null
@@ -1,149 +0,0 @@
1;;; gnus-audio.el --- Sound effects for Gnus
2
3;; Copyright (C) 1996, 2000, 2001, 2002, 2003, 2004,
4;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
5
6;; Author: Steven L. Baur <steve@miranova.com>
7;; Keywords: news, mail, multimedia
8
9;; This file is part of GNU Emacs.
10
11;; GNU Emacs is free software: you can redistribute it and/or modify
12;; it under the terms of the GNU General Public License as published by
13;; the Free Software Foundation, either version 3 of the License, or
14;; (at your option) any later version.
15
16;; GNU Emacs is distributed in the hope that it will be useful,
17;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19;; GNU General Public License for more details.
20
21;; You should have received a copy of the GNU General Public License
22;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
23
24;;; Commentary:
25
26;; This file provides access to sound effects in Gnus.
27;; This file is partially stripped to support earcons.el.
28
29;;; Code:
30
31(require 'nnheader)
32
33(defgroup gnus-audio nil
34 "Playing sound in Gnus."
35 :version "21.1"
36 :group 'gnus-visual
37 :group 'multimedia)
38
39(defvar gnus-audio-inline-sound
40 (or (if (fboundp 'device-sound-enabled-p)
41 (device-sound-enabled-p)) ; XEmacs
42 (fboundp 'play-sound)) ; Emacs
43 "Non-nil means try to play sounds without using an external program.")
44
45(defcustom gnus-audio-directory (nnheader-find-etc-directory "sounds")
46 "The directory containing the Sound Files."
47 :type '(choice directory (const nil))
48 :group 'gnus-audio)
49
50(defcustom gnus-audio-au-player (executable-find "play")
51 "Executable program for playing sun AU format sound files."
52 :group 'gnus-audio
53 :type '(choice file (const nil)))
54
55(defcustom gnus-audio-wav-player (executable-find "play")
56 "Executable program for playing WAV files."
57 :group 'gnus-audio
58 :type '(choice file (const nil)))
59
60;;; The following isn't implemented yet. Wait for Millennium Gnus.
61;;(defvar gnus-audio-effects-enabled t
62;; "When t, Gnus will use sound effects.")
63;;(defvar gnus-audio-enable-hooks nil
64;; "Functions run when enabling sound effects.")
65;;(defvar gnus-audio-disable-hooks nil
66;; "Functions run when disabling sound effects.")
67;;(defvar gnus-audio-theme-song nil
68;; "Theme song for Gnus.")
69;;(defvar gnus-audio-enter-group nil
70;; "Sound effect played when selecting a group.")
71;;(defvar gnus-audio-exit-group nil
72;; "Sound effect played when exiting a group.")
73;;(defvar gnus-audio-score-group nil
74;; "Sound effect played when scoring a group.")
75;;(defvar gnus-audio-busy-sound nil
76;; "Sound effect played when going into a ... sequence.")
77
78
79;;;###autoload
80;;(defun gnus-audio-enable-sound ()
81;; "Enable Sound Effects for Gnus."
82;; (interactive)
83;; (setq gnus-audio-effects-enabled t)
84;; (gnus-run-hooks gnus-audio-enable-hooks))
85
86;;;###autoload
87 ;(defun gnus-audio-disable-sound ()
88;; "Disable Sound Effects for Gnus."
89;; (interactive)
90;; (setq gnus-audio-effects-enabled nil)
91;; (gnus-run-hooks gnus-audio-disable-hooks))
92
93;;;###autoload
94(defun gnus-audio-play (file)
95 "Play a sound FILE through the speaker."
96 (interactive "fSound file name: ")
97 (let ((sound-file (if (file-exists-p file)
98 file
99 (expand-file-name file gnus-audio-directory))))
100 (when (file-exists-p sound-file)
101 (cond ((and gnus-audio-inline-sound
102 (condition-case nil
103 ;; Even if we have audio, we may fail with the
104 ;; wrong sort of sound file.
105 (progn (play-sound-file sound-file)
106 t)
107 (error nil))))
108 ;; If we don't have built-in sound, or playing it failed,
109 ;; try with external program.
110 ((equal "wav" (file-name-extension sound-file))
111 (call-process gnus-audio-wav-player
112 sound-file
113 0
114 nil
115 sound-file))
116 ((equal "au" (file-name-extension sound-file))
117 (call-process gnus-audio-au-player
118 sound-file
119 0
120 nil
121 sound-file))))))
122
123
124;;; The following isn't implemented yet, wait for Red Gnus
125;;(defun gnus-audio-startrek-sounds ()
126;; "Enable sounds from Star Trek the original series."
127;; (interactive)
128;; (setq gnus-audio-busy-sound "working.au")
129;; (setq gnus-audio-enter-group "bulkhead_door.au")
130;; (setq gnus-audio-exit-group "bulkhead_door.au")
131;; (setq gnus-audio-score-group "ST_laser.au")
132;; (setq gnus-audio-theme-song "startrek.au")
133;; (add-hook 'gnus-select-group-hook 'gnus-audio-startrek-select-group)
134;; (add-hook 'gnus-exit-group-hook 'gnus-audio-startrek-exit-group))
135;;;***
136
137(defvar gnus-startup-jingle "Tuxedomoon.Jingle4.au"
138 "Name of the Gnus startup jingle file.")
139
140(defun gnus-play-jingle ()
141 "Play the Gnus startup jingle, unless that's inhibited."
142 (interactive)
143 (gnus-audio-play gnus-startup-jingle))
144
145(provide 'gnus-audio)
146
147(run-hooks 'gnus-audio-load-hook)
148
149;;; gnus-audio.el ends here
diff --git a/lisp/gnus/gnus-cus.el b/lisp/gnus/gnus-cus.el
index 838150d1146..6da91bdc266 100644
--- a/lisp/gnus/gnus-cus.el
+++ b/lisp/gnus/gnus-cus.el
@@ -865,11 +865,6 @@ This can be changed using the `\\[gnus-score-change-score-file]' command."
865Check the [ ] for the entries you want to apply to this score file, then 865Check the [ ] for the entries you want to apply to this score file, then
866edit the value to suit your taste. Don't forget to mark the checkbox, 866edit the value to suit your taste. Don't forget to mark the checkbox,
867if you do all your changes will be lost. ") 867if you do all your changes will be lost. ")
868 (widget-create 'push-button
869 :action (lambda (&rest ignore)
870 (require 'gnus-audio)
871 (gnus-audio-play "Evil_Laugh.au"))
872 "Bhahahah!")
873 (widget-insert "\n\n") 868 (widget-insert "\n\n")
874 (make-local-variable 'gnus-custom-scores) 869 (make-local-variable 'gnus-custom-scores)
875 (setq gnus-custom-scores 870 (setq gnus-custom-scores
diff --git a/lisp/gnus/gnus-demon.el b/lisp/gnus/gnus-demon.el
index 67c1c8ba3bc..c4e439c3bf4 100644
--- a/lisp/gnus/gnus-demon.el
+++ b/lisp/gnus/gnus-demon.el
@@ -240,15 +240,6 @@ time Emacs has been idle for IDLE `gnus-demon-timestep's."
240 ;; this idle-cycle. 240 ;; this idle-cycle.
241 (push (car handler) gnus-demon-idle-has-been-called))))))))) 241 (push (car handler) gnus-demon-idle-has-been-called)))))))))
242 242
243(defun gnus-demon-add-nocem ()
244 "Add daemonic NoCeM handling to Gnus."
245 (gnus-demon-add-handler 'gnus-demon-scan-nocem 60 30))
246
247(defun gnus-demon-scan-nocem ()
248 "Scan NoCeM groups for NoCeM messages."
249 (save-window-excursion
250 (gnus-nocem-scan-groups)))
251
252(defun gnus-demon-add-disconnection () 243(defun gnus-demon-add-disconnection ()
253 "Add daemonic server disconnection to Gnus." 244 "Add daemonic server disconnection to Gnus."
254 (gnus-demon-add-handler 'gnus-demon-close-connections nil 30)) 245 (gnus-demon-add-handler 'gnus-demon-close-connections nil 30))
diff --git a/lisp/gnus/gnus-group.el b/lisp/gnus/gnus-group.el
index 5a25d513a57..7dddb9b6f70 100644
--- a/lisp/gnus/gnus-group.el
+++ b/lisp/gnus/gnus-group.el
@@ -2418,6 +2418,14 @@ the bug number, and browsing the URL must return mbox output."
2418 (let ((tmpfile (mm-make-temp-file "gnus-temp-group-"))) 2418 (let ((tmpfile (mm-make-temp-file "gnus-temp-group-")))
2419 (with-temp-file tmpfile 2419 (with-temp-file tmpfile
2420 (url-insert-file-contents (format mbox-url number)) 2420 (url-insert-file-contents (format mbox-url number))
2421 (goto-char (point-min))
2422 ;; Add the debbugs address so that we can respond to reports easily.
2423 (while (re-search-forward "^To: " nil t)
2424 (end-of-line)
2425 (insert (format ", %s@%s" number
2426 (replace-regexp-in-string
2427 "/.*$" ""
2428 (replace-regexp-in-string "^http://" "" mbox-url)))))
2421 (write-region (point-min) (point-max) tmpfile) 2429 (write-region (point-min) (point-max) tmpfile)
2422 (gnus-group-read-ephemeral-group 2430 (gnus-group-read-ephemeral-group
2423 "gnus-read-ephemeral-bug" 2431 "gnus-read-ephemeral-bug"
@@ -3946,14 +3954,6 @@ re-scanning. If ARG is non-nil and not a number, this will force
3946 (unless gnus-slave 3954 (unless gnus-slave
3947 (gnus-master-read-slave-newsrc)) 3955 (gnus-master-read-slave-newsrc))
3948 3956
3949 ;; We might read in new NoCeM messages here.
3950 (when (and gnus-use-nocem
3951 (or (and (numberp gnus-use-nocem)
3952 (numberp arg)
3953 (>= arg gnus-use-nocem))
3954 (not arg)))
3955 (gnus-nocem-scan-groups))
3956
3957 (gnus-get-unread-articles arg) 3957 (gnus-get-unread-articles arg)
3958 3958
3959 ;; If the user wants it, we scan for new groups. 3959 ;; If the user wants it, we scan for new groups.
diff --git a/lisp/gnus/gnus-html.el b/lisp/gnus/gnus-html.el
index 5199f7dfd5f..cb5d3c6e30b 100644
--- a/lisp/gnus/gnus-html.el
+++ b/lisp/gnus/gnus-html.el
@@ -104,7 +104,12 @@ CHARS is a regexp-like character alternative (e.g., \"[)$]\")."
104 (match-string 0 encoded-text))) 104 (match-string 0 encoded-text)))
105 t t encoded-text) 105 t t encoded-text)
106 s (1+ s))) 106 s (1+ s)))
107 encoded-text))))) 107 encoded-text))))
108 ;; XEmacs does not have window-inside-pixel-edges
109 (defalias 'gnus-window-inside-pixel-edges
110 (if (fboundp 'window-inside-pixel-edges)
111 'window-inside-pixel-edges
112 'window-pixel-edges)))
108 113
109(defun gnus-html-encode-url (url) 114(defun gnus-html-encode-url (url)
110 "Encode URL." 115 "Encode URL."
@@ -450,7 +455,7 @@ Return a string with image data."
450 image 455 image
451 (let* ((width (car size)) 456 (let* ((width (car size))
452 (height (cdr size)) 457 (height (cdr size))
453 (edges (window-pixel-edges (get-buffer-window (current-buffer)))) 458 (edges (gnus-window-inside-pixel-edges (get-buffer-window (current-buffer))))
454 (window-width (truncate (* gnus-max-image-proportion 459 (window-width (truncate (* gnus-max-image-proportion
455 (- (nth 2 edges) (nth 0 edges))))) 460 (- (nth 2 edges) (nth 0 edges)))))
456 (window-height (truncate (* gnus-max-image-proportion 461 (window-height (truncate (* gnus-max-image-proportion
diff --git a/lisp/gnus/gnus-int.el b/lisp/gnus/gnus-int.el
index 395f47daf35..3245b16997b 100644
--- a/lisp/gnus/gnus-int.el
+++ b/lisp/gnus/gnus-int.el
@@ -181,10 +181,15 @@ If it is down, start it up (again)."
181 (prog1 181 (prog1
182 (setq result (gnus-open-server method)) 182 (setq result (gnus-open-server method))
183 (unless silent 183 (unless silent
184 (gnus-message 5 "Opening %s server%s...%s" (car method) 184 (gnus-message
185 (if (equal (nth 1 method) "") "" 185 (if result 5 3)
186 (format " on %s" (nth 1 method))) 186 "Opening %s server%s...%s" (car method)
187 (if result "done" "failed"))))))) 187 (if (equal (nth 1 method) "") ""
188 (format " on %s" (nth 1 method)))
189 (if result
190 "done"
191 (format "failed: %s"
192 (nnheader-get-report-string (car method))))))))))
188 193
189(defun gnus-get-function (method function &optional noerror) 194(defun gnus-get-function (method function &optional noerror)
190 "Return a function symbol based on METHOD and FUNCTION." 195 "Return a function symbol based on METHOD and FUNCTION."
@@ -265,36 +270,31 @@ If it is down, start it up (again)."
265 (setq elem (list gnus-command-method nil) 270 (setq elem (list gnus-command-method nil)
266 gnus-opened-servers (cons elem gnus-opened-servers))) 271 gnus-opened-servers (cons elem gnus-opened-servers)))
267 ;; Set the status of this server. 272 ;; Set the status of this server.
268 (setcar (cdr elem) 273 (setcar
269 (cond (result 274 (cdr elem)
270 (if (eq open-server-function #'nnagent-open-server) 275 (cond (result
271 ;; The agent's backend has a "special" status 276 (if (eq open-server-function #'nnagent-open-server)
272 'offline 277 ;; The agent's backend has a "special" status
273 'ok)) 278 'offline
274 ((and gnus-agent 279 'ok))
275 (gnus-agent-method-p gnus-command-method)) 280 ((and gnus-agent
276 (cond (gnus-server-unopen-status 281 (gnus-agent-method-p gnus-command-method))
277 ;; Set the server's status to the unopen 282 (cond
278 ;; status. If that status is offline, 283 (gnus-server-unopen-status
279 ;; recurse to open the agent's backend. 284 ;; Set the server's status to the unopen
280 (setq open-offline (eq gnus-server-unopen-status 'offline)) 285 ;; status. If that status is offline,
281 gnus-server-unopen-status) 286 ;; recurse to open the agent's backend.
282 ((and 287 (setq open-offline (eq gnus-server-unopen-status 'offline))
283 (not gnus-batch-mode) 288 gnus-server-unopen-status)
284 (gnus-y-or-n-p 289 ((not gnus-batch-mode)
285 (format 290 (setq open-offline t)
286 "Unable to open server %s (%s), go offline? " 291 'offline)
287 server 292 (t
288 (nnheader-get-report 293 ;; This agentized server was still denied
289 (car gnus-command-method))))) 294 'denied)))
290 (setq open-offline t) 295 (t
291 'offline) 296 ;; This unagentized server must be denied
292 (t 297 'denied)))
293 ;; This agentized server was still denied
294 'denied)))
295 (t
296 ;; This unagentized server must be denied
297 'denied)))
298 298
299 ;; NOTE: I MUST set the server's status to offline before this 299 ;; NOTE: I MUST set the server's status to offline before this
300 ;; recursive call as this status will drive the 300 ;; recursive call as this status will drive the
diff --git a/lisp/gnus/gnus-nocem.el b/lisp/gnus/gnus-nocem.el
deleted file mode 100644
index 0364c963a27..00000000000
--- a/lisp/gnus/gnus-nocem.el
+++ /dev/null
@@ -1,452 +0,0 @@
1;;; gnus-nocem.el --- NoCeM pseudo-cancellation treatment
2
3;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
4;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
5
6;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
7;; Keywords: news
8
9;; This file is part of GNU Emacs.
10
11;; GNU Emacs is free software: you can redistribute it and/or modify
12;; it under the terms of the GNU General Public License as published by
13;; the Free Software Foundation, either version 3 of the License, or
14;; (at your option) any later version.
15
16;; GNU Emacs is distributed in the hope that it will be useful,
17;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19;; GNU General Public License for more details.
20
21;; You should have received a copy of the GNU General Public License
22;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
23
24;;; Commentary:
25
26;;; Code:
27
28(eval-when-compile (require 'cl))
29
30(require 'gnus)
31(require 'nnmail)
32(require 'gnus-art)
33(require 'gnus-sum)
34(require 'gnus-range)
35
36(defgroup gnus-nocem nil
37 "NoCeM pseudo-cancellation treatment."
38 :group 'gnus-score)
39
40(defcustom gnus-nocem-groups
41 '("news.lists.filters" "alt.nocem.misc")
42 "*List of groups that will be searched for NoCeM messages."
43 :group 'gnus-nocem
44 :version "23.1"
45 :type '(repeat (string :tag "Group")))
46
47(defcustom gnus-nocem-issuers
48 '("Adri Verhoef"
49 "alba-nocem@albasani.net"
50 "bleachbot@httrack.com"
51 "news@arcor-online.net"
52 "news@uni-berlin.de"
53 "nocem@arcor.de"
54 "pgpmoose@killfile.org"
55 "xjsppl@gmx.de")
56 "*List of NoCeM issuers to pay attention to.
57
58This can also be a list of `(ISSUER CONDITION ...)' elements.
59
60See <URL:http://www.xs4all.nl/~rosalind/nocemreg/nocemreg.html> for an
61issuer registry."
62 :group 'gnus-nocem
63 :link '(url-link "http://www.xs4all.nl/~rosalind/nocemreg/nocemreg.html")
64 :version "23.1"
65 :type '(repeat (cons :format "%v" (string :tag "Issuer")
66 (repeat :tag "Condition"
67 (group (checklist :inline t (const not))
68 (regexp :tag "Type" :value ".*")))))
69 :get (lambda (symbol)
70 (mapcar (lambda (elem)
71 (if (consp elem)
72 (cons (car elem)
73 (mapcar (lambda (elt)
74 (if (consp elt) elt (list elt)))
75 (cdr elem)))
76 (list elem)))
77 (default-value symbol)))
78 :set (lambda (symbol value)
79 (custom-set-default
80 symbol
81 (mapcar (lambda (elem)
82 (if (consp elem)
83 (if (cdr elem)
84 (mapcar (lambda (elt)
85 (if (consp elt)
86 (if (cdr elt) elt (car elt))
87 elt))
88 elem)
89 (car elem))
90 elem))
91 value))))
92
93(defcustom gnus-nocem-directory
94 (nnheader-concat gnus-article-save-directory "NoCeM/")
95 "*Directory where NoCeM files will be stored."
96 :group 'gnus-nocem
97 :type 'directory)
98
99(defcustom gnus-nocem-expiry-wait 15
100 "*Number of days to keep NoCeM headers in the cache."
101 :group 'gnus-nocem
102 :type 'integer)
103
104(defcustom gnus-nocem-verifyer (if (locate-library "epg")
105 'gnus-nocem-epg-verify
106 'pgg-verify)
107 "*Function called to verify that the NoCeM message is valid.
108If the function in this variable isn't bound, the message will be used
109unconditionally."
110 :group 'gnus-nocem
111 :version "23.1"
112 :type '(radio (function-item gnus-nocem-epg-verify)
113 (function-item pgg-verify)
114 (function-item mc-verify)
115 (function :tag "other"))
116 :set (lambda (symbol value)
117 (custom-set-default symbol
118 (if (and (eq value 'gnus-nocem-epg-verify)
119 (not (locate-library "epg")))
120 'pgg-verify
121 value))))
122
123(defcustom gnus-nocem-liberal-fetch nil
124 "*If t try to fetch all messages which have @@NCM in the subject.
125Otherwise don't fetch messages which have references or whose message-id
126matches a previously scanned and verified nocem message."
127 :group 'gnus-nocem
128 :type 'boolean)
129
130(defcustom gnus-nocem-check-article-limit 500
131 "*If non-nil, the maximum number of articles to check in any NoCeM group."
132 :group 'gnus-nocem
133 :version "21.1"
134 :type '(choice (const :tag "unlimited" nil)
135 (integer 1000)))
136
137(defcustom gnus-nocem-check-from t
138 "Non-nil means check for valid issuers in message bodies.
139Otherwise don't bother fetching articles unless their author matches a
140valid issuer, which is much faster if you are selective about the issuers."
141 :group 'gnus-nocem
142 :version "21.1"
143 :type 'boolean)
144
145;;; Internal variables
146
147(defvar gnus-nocem-active nil)
148(defvar gnus-nocem-alist nil)
149(defvar gnus-nocem-touched-alist nil)
150(defvar gnus-nocem-hashtb nil)
151(defvar gnus-nocem-seen-message-ids nil)
152
153;;; Functions
154
155(defun gnus-nocem-active-file ()
156 (concat (file-name-as-directory gnus-nocem-directory) "active"))
157
158(defun gnus-nocem-cache-file ()
159 (concat (file-name-as-directory gnus-nocem-directory) "cache"))
160
161;;
162;; faster lookups for group names:
163;;
164
165(defvar gnus-nocem-real-group-hashtb nil
166 "Real-name mappings of subscribed groups.")
167
168(defun gnus-fill-real-hashtb ()
169 "Fill up a hash table with the real-name mappings from the user's active file."
170 (if (hash-table-p gnus-nocem-real-group-hashtb)
171 (clrhash gnus-nocem-real-group-hashtb)
172 (setq gnus-nocem-real-group-hashtb (make-hash-table :test 'equal)))
173 (mapcar (lambda (group)
174 (setq group (gnus-group-real-name (car group)))
175 (puthash group t gnus-nocem-real-group-hashtb))
176 gnus-newsrc-alist))
177
178;;;###autoload
179(defun gnus-nocem-scan-groups ()
180 "Scan all NoCeM groups for new NoCeM messages."
181 (interactive)
182 (let ((groups gnus-nocem-groups)
183 (gnus-inhibit-demon t)
184 group active gactive articles check-headers)
185 (gnus-make-directory gnus-nocem-directory)
186 ;; Load any previous NoCeM headers.
187 (gnus-nocem-load-cache)
188 ;; Get the group name mappings:
189 (gnus-fill-real-hashtb)
190 ;; Read the active file if it hasn't been read yet.
191 (and (file-exists-p (gnus-nocem-active-file))
192 (not gnus-nocem-active)
193 (ignore-errors
194 (load (gnus-nocem-active-file) t t t)))
195 ;; Go through all groups and see whether new articles have
196 ;; arrived.
197 (while (setq group (pop groups))
198 (if (not (setq gactive (gnus-activate-group group)))
199 () ; This group doesn't exist.
200 (setq active (nth 1 (assoc group gnus-nocem-active)))
201 (when (and (not (< (cdr gactive) (car gactive))) ; Empty group.
202 (or (not active)
203 (< (cdr active) (cdr gactive))))
204 ;; Ok, there are new articles in this group, se we fetch the
205 ;; headers.
206 (save-excursion
207 (let ((dependencies (make-vector 10 nil))
208 headers header)
209 (with-temp-buffer
210 (setq headers
211 (if (eq 'nov
212 (gnus-retrieve-headers
213 (setq articles
214 (gnus-uncompress-range
215 (cons
216 (if active (1+ (cdr active))
217 (car gactive))
218 (cdr gactive))))
219 group))
220 (gnus-get-newsgroup-headers-xover
221 articles nil dependencies)
222 (gnus-get-newsgroup-headers dependencies)))
223 (while (setq header (pop headers))
224 ;; We take a closer look on all articles that have
225 ;; "@@NCM" in the subject. Unless we already read
226 ;; this cross posted message. Nocem messages
227 ;; are not allowed to have references, so we can
228 ;; ignore scanning followups.
229 (and (string-match "@@NCM" (mail-header-subject header))
230 (and gnus-nocem-check-from
231 (let ((case-fold-search t))
232 (catch 'ok
233 (mapc
234 (lambda (author)
235 (if (consp author)
236 (setq author (car author)))
237 (if (string-match
238 author (mail-header-from header))
239 (throw 'ok t)))
240 gnus-nocem-issuers)
241 nil)))
242 (or gnus-nocem-liberal-fetch
243 (and (or (string= "" (mail-header-references
244 header))
245 (null (mail-header-references header)))
246 (not (member (mail-header-message-id header)
247 gnus-nocem-seen-message-ids))))
248 (push header check-headers)))
249 (setq check-headers (last (nreverse check-headers)
250 gnus-nocem-check-article-limit))
251 (let ((i 0)
252 (len (length check-headers)))
253 (dolist (h check-headers)
254 (gnus-message
255 7 "Checking article %d in %s for NoCeM (%d of %d)..."
256 (mail-header-number h) group (incf i) len)
257 (gnus-nocem-check-article group h)))))))
258 (setq gnus-nocem-active
259 (cons (list group gactive)
260 (delq (assoc group gnus-nocem-active)
261 gnus-nocem-active)))))
262 ;; Save the results, if any.
263 (gnus-nocem-save-cache)
264 (gnus-nocem-save-active)))
265
266(defun gnus-nocem-check-article (group header)
267 "Check whether the current article is an NCM article and that we want it."
268 ;; Get the article.
269 (let ((date (mail-header-date header))
270 (gnus-newsgroup-name group)
271 issuer b e type)
272 (when (or (not date)
273 (time-less-p
274 (time-since (date-to-time date))
275 (days-to-time gnus-nocem-expiry-wait)))
276 (gnus-request-article-this-buffer (mail-header-number header) group)
277 (goto-char (point-min))
278 (when (re-search-forward
279 "-----BEGIN PGP\\(?: SIGNED\\)? MESSAGE-----"
280 nil t)
281 (delete-region (point-min) (match-beginning 0)))
282 (when (re-search-forward
283 "-----END PGP \\(?:MESSAGE\\|SIGNATURE\\)-----\n?"
284 nil t)
285 (delete-region (match-end 0) (point-max)))
286 (goto-char (point-min))
287 ;; The article has to have proper NoCeM headers.
288 (when (and (setq b (search-forward "\n@@BEGIN NCM HEADERS\n" nil t))
289 (setq e (search-forward "\n@@BEGIN NCM BODY\n" nil t)))
290 ;; We get the name of the issuer.
291 (narrow-to-region b e)
292 (setq issuer (mail-fetch-field "issuer")
293 type (mail-fetch-field "type"))
294 (widen)
295 (if (not (gnus-nocem-message-wanted-p issuer type))
296 (message "invalid NoCeM issuer: %s" issuer)
297 (and (gnus-nocem-verify-issuer issuer) ; She is who she says she is.
298 (gnus-nocem-enter-article) ; We gobble the message.
299 (push (mail-header-message-id header) ; But don't come back for
300 gnus-nocem-seen-message-ids))))))) ; second helpings.
301
302(defun gnus-nocem-message-wanted-p (issuer type)
303 (let ((issuers gnus-nocem-issuers)
304 wanted conditions condition)
305 (cond
306 ;; Do the quick check first.
307 ((member issuer issuers)
308 t)
309 ((setq conditions (cdr (assoc issuer issuers)))
310 ;; Check whether we want this type.
311 (while (setq condition (pop conditions))
312 (cond
313 ((stringp condition)
314 (when (string-match condition type)
315 (setq wanted t)))
316 ((and (consp condition)
317 (eq (car condition) 'not)
318 (stringp (cadr condition)))
319 (when (string-match (cadr condition) type)
320 (setq wanted nil)))
321 (t
322 (error "Invalid NoCeM condition: %S" condition))))
323 wanted))))
324
325(defun gnus-nocem-verify-issuer (person)
326 "Verify using PGP that the canceler is who she says she is."
327 (if (functionp gnus-nocem-verifyer)
328 (ignore-errors
329 (funcall gnus-nocem-verifyer))
330 ;; If we don't have Mailcrypt, then we use the message anyway.
331 t))
332
333(defun gnus-nocem-enter-article ()
334 "Enter the current article into the NoCeM cache."
335 (goto-char (point-min))
336 (let ((b (search-forward "\n@@BEGIN NCM BODY\n" nil t))
337 (e (search-forward "\n@@END NCM BODY\n" nil t))
338 (buf (current-buffer))
339 ncm id group)
340 (when (and b e)
341 (narrow-to-region b (1+ (match-beginning 0)))
342 (goto-char (point-min))
343 (while (search-forward "\t" nil t)
344 (cond
345 ((not (ignore-errors
346 (setq group (gnus-group-real-name (symbol-name (read buf))))
347 (gethash group gnus-nocem-real-group-hashtb)))
348 ;; An error.
349 )
350 (t
351 ;; Valid group.
352 (beginning-of-line)
353 (while (eq (char-after) ?\t)
354 (forward-line -1))
355 (setq id (buffer-substring (point) (1- (search-forward "\t"))))
356 (unless (if (hash-table-p gnus-nocem-hashtb)
357 (gethash id gnus-nocem-hashtb)
358 (setq gnus-nocem-hashtb (make-hash-table :test 'equal))
359 nil)
360 ;; only store if not already present
361 (puthash id t gnus-nocem-hashtb)
362 (push id ncm))
363 (forward-line 1)
364 (while (eq (char-after) ?\t)
365 (forward-line 1)))))
366 (when ncm
367 (setq gnus-nocem-touched-alist t)
368 (push (cons (let ((time (current-time))) (setcdr (cdr time) nil) time)
369 ncm)
370 gnus-nocem-alist))
371 t)))
372
373;;;###autoload
374(defun gnus-nocem-load-cache ()
375 "Load the NoCeM cache."
376 (interactive)
377 (unless gnus-nocem-alist
378 ;; The buffer doesn't exist, so we create it and load the NoCeM
379 ;; cache.
380 (when (file-exists-p (gnus-nocem-cache-file))
381 (load (gnus-nocem-cache-file) t t t)
382 (gnus-nocem-alist-to-hashtb))))
383
384(defun gnus-nocem-save-cache ()
385 "Save the NoCeM cache."
386 (when (and gnus-nocem-alist
387 gnus-nocem-touched-alist)
388 (with-temp-file (gnus-nocem-cache-file)
389 (gnus-prin1 `(setq gnus-nocem-alist ',gnus-nocem-alist)))
390 (setq gnus-nocem-touched-alist nil)))
391
392(defun gnus-nocem-save-active ()
393 "Save the NoCeM active file."
394 (with-temp-file (gnus-nocem-active-file)
395 (gnus-prin1 `(setq gnus-nocem-active ',gnus-nocem-active))))
396
397(defun gnus-nocem-alist-to-hashtb ()
398 "Create a hashtable from the Message-IDs we have."
399 (let* ((alist gnus-nocem-alist)
400 (pprev (cons nil alist))
401 (prev pprev)
402 (expiry (days-to-time gnus-nocem-expiry-wait))
403 entry)
404 (if (hash-table-p gnus-nocem-hashtb)
405 (clrhash gnus-nocem-hashtb)
406 (setq gnus-nocem-hashtb (make-hash-table :test 'equal)))
407 (while (setq entry (car alist))
408 (if (not (time-less-p (time-since (car entry)) expiry))
409 ;; This entry has expired, so we remove it.
410 (setcdr prev (cdr alist))
411 (setq prev alist)
412 ;; This is ok, so we enter it into the hashtable.
413 (setq entry (cdr entry))
414 (while entry
415 (puthash (car entry) t gnus-nocem-hashtb)
416 (setq entry (cdr entry))))
417 (setq alist (cdr alist)))))
418
419(gnus-add-shutdown 'gnus-nocem-close 'gnus)
420
421(defun gnus-nocem-close ()
422 "Clear internal NoCeM variables."
423 (setq gnus-nocem-alist nil
424 gnus-nocem-hashtb nil
425 gnus-nocem-active nil
426 gnus-nocem-touched-alist nil
427 gnus-nocem-seen-message-ids nil
428 gnus-nocem-real-group-hashtb nil))
429
430(defun gnus-nocem-unwanted-article-p (id)
431 "Say whether article ID in the current group is wanted."
432 (and gnus-nocem-hashtb
433 (gethash id gnus-nocem-hashtb)))
434
435(autoload 'epg-make-context "epg")
436(eval-when-compile
437 (autoload 'epg-verify-string "epg")
438 (autoload 'epg-context-result-for "epg")
439 (autoload 'epg-signature-status "epg"))
440
441(defun gnus-nocem-epg-verify ()
442 "Return t if EasyPG verifies a signed message in the current buffer."
443 (let ((context (epg-make-context 'OpenPGP))
444 result)
445 (epg-verify-string context (buffer-string))
446 (and (setq result (epg-context-result-for context 'verify))
447 (not (cdr result))
448 (eq (epg-signature-status (car result)) 'good))))
449
450(provide 'gnus-nocem)
451
452;;; gnus-nocem.el ends here
diff --git a/lisp/gnus/gnus-srvr.el b/lisp/gnus/gnus-srvr.el
index 2966212de69..11164a8df6c 100644
--- a/lisp/gnus/gnus-srvr.el
+++ b/lisp/gnus/gnus-srvr.el
@@ -28,6 +28,7 @@
28(eval-when-compile (require 'cl)) 28(eval-when-compile (require 'cl))
29 29
30(require 'gnus) 30(require 'gnus)
31(require 'gnus-start)
31(require 'gnus-spec) 32(require 'gnus-spec)
32(require 'gnus-group) 33(require 'gnus-group)
33(require 'gnus-int) 34(require 'gnus-int)
@@ -547,6 +548,7 @@ The following commands are available:
547 (gnus-server-list-servers)) 548 (gnus-server-list-servers))
548 549
549(defun gnus-server-copy-server (from to) 550(defun gnus-server-copy-server (from to)
551 "Copy a server definiton to a new name."
550 (interactive 552 (interactive
551 (list 553 (list
552 (or (gnus-server-server-name) 554 (or (gnus-server-server-name)
@@ -643,6 +645,30 @@ The following commands are available:
643(defvar gnus-browse-menu-hook nil 645(defvar gnus-browse-menu-hook nil
644 "*Hook run after the creation of the browse mode menu.") 646 "*Hook run after the creation of the browse mode menu.")
645 647
648(defcustom gnus-browse-subscribe-newsgroup-method
649 'gnus-subscribe-alphabetically
650 "Function(s) called when subscribing groups in the Browse Server Buffer
651A few pre-made functions are supplied: `gnus-subscribe-randomly'
652inserts new groups at the beginning of the list of groups;
653`gnus-subscribe-alphabetically' inserts new groups in strict
654alphabetic order; `gnus-subscribe-hierarchically' inserts new groups
655in hierarchical newsgroup order; `gnus-subscribe-interactively' asks
656for your decision; `gnus-subscribe-killed' kills all new groups;
657`gnus-subscribe-zombies' will make all new groups into zombies;
658`gnus-subscribe-topics' will enter groups into the topics that
659claim them."
660 :version "24.1"
661 :group 'gnus-server
662 :type '(radio (function-item gnus-subscribe-randomly)
663 (function-item gnus-subscribe-alphabetically)
664 (function-item gnus-subscribe-hierarchically)
665 (function-item gnus-subscribe-interactively)
666 (function-item gnus-subscribe-killed)
667 (function-item gnus-subscribe-zombies)
668 (function-item gnus-subscribe-topics)
669 function
670 (repeat function)))
671
646(defvar gnus-browse-mode-hook nil) 672(defvar gnus-browse-mode-hook nil)
647(defvar gnus-browse-mode-map nil) 673(defvar gnus-browse-mode-map nil)
648(put 'gnus-browse-mode 'mode-class 'special) 674(put 'gnus-browse-mode 'mode-class 'special)
@@ -890,7 +916,9 @@ If NUMBER, fetch this number of articles."
890 (gnus-browse-next-group (- n))) 916 (gnus-browse-next-group (- n)))
891 917
892(defun gnus-browse-unsubscribe-current-group (arg) 918(defun gnus-browse-unsubscribe-current-group (arg)
893 "(Un)subscribe to the next ARG groups." 919 "(Un)subscribe to the next ARG groups.
920The variable `gnus-browse-subscribe-newsgroup-method' determines
921how new groups will be entered into the group buffer."
894 (interactive "p") 922 (interactive "p")
895 (when (eobp) 923 (when (eobp)
896 (error "No group at current line")) 924 (error "No group at current line"))
@@ -939,22 +967,24 @@ If NUMBER, fetch this number of articles."
939 ;; subscribe to it. 967 ;; subscribe to it.
940 (if (gnus-ephemeral-group-p group) 968 (if (gnus-ephemeral-group-p group)
941 (gnus-kill-ephemeral-group group)) 969 (gnus-kill-ephemeral-group group))
942 ;; We need to discern between killed/zombie groups and 970 (let ((entry (gnus-group-entry group)))
943 ;; just unsubscribed ones. 971 (if entry
944 (gnus-group-change-level 972 ;; Just change the subscription level if it is an
945 (or (gnus-group-entry group) 973 ;; unsubscribed group.
946 (list t group gnus-level-default-subscribed 974 (gnus-group-change-level entry
947 nil nil (if (gnus-server-equal 975 gnus-level-default-subscribed)
948 gnus-browse-current-method "native") 976 ;; If it is a killed group or a zombie, feed it to the
949 nil 977 ;; mechanism for new group subscription.
950 (gnus-method-simplify 978 (gnus-call-subscribe-functions
951 gnus-browse-current-method)))) 979 gnus-browse-subscribe-newsgroup-method
952 gnus-level-default-subscribed (gnus-group-level group) 980 group)))
953 (and (car (nth 1 gnus-newsrc-alist))
954 (gnus-group-entry (car (nth 1 gnus-newsrc-alist))))
955 (null (gnus-group-entry group)))
956 (delete-char 1) 981 (delete-char 1)
957 (insert ? )) 982 (insert (let ((lvl (gnus-group-level group)))
983 (cond
984 ((< lvl gnus-level-unsubscribed) ? )
985 ((< lvl gnus-level-zombie) ?U)
986 ((< lvl gnus-level-killed) ?Z)
987 (t ?K)))))
958 (gnus-group-change-level 988 (gnus-group-change-level
959 group gnus-level-unsubscribed gnus-level-default-subscribed) 989 group gnus-level-unsubscribed gnus-level-default-subscribed)
960 (delete-char 1) 990 (delete-char 1)
diff --git a/lisp/gnus/gnus-start.el b/lisp/gnus/gnus-start.el
index 5aec3e7b729..68f26ea143b 100644
--- a/lisp/gnus/gnus-start.el
+++ b/lisp/gnus/gnus-start.el
@@ -1063,15 +1063,6 @@ If LEVEL is non-nil, the news will be set up at level LEVEL."
1063 (gnus-server-opened gnus-select-method)) 1063 (gnus-server-opened gnus-select-method))
1064 (gnus-check-bogus-newsgroups)) 1064 (gnus-check-bogus-newsgroups))
1065 1065
1066 ;; We might read in new NoCeM messages here.
1067 (when (and (not dont-connect)
1068 gnus-use-nocem
1069 (or (and (numberp gnus-use-nocem)
1070 (numberp level)
1071 (>= level gnus-use-nocem))
1072 (not level)))
1073 (gnus-nocem-scan-groups))
1074
1075 ;; Read any slave files. 1066 ;; Read any slave files.
1076 (gnus-master-read-slave-newsrc) 1067 (gnus-master-read-slave-newsrc)
1077 1068
@@ -1767,8 +1758,10 @@ If SCAN, request a scan of that group as well."
1767 (not (gnus-method-denied-p method))) 1758 (not (gnus-method-denied-p method)))
1768 (unless (gnus-server-opened method) 1759 (unless (gnus-server-opened method)
1769 (gnus-open-server method)) 1760 (gnus-open-server method))
1770 (when (gnus-check-backend-function 1761 (when (and
1771 'retrieve-group-data-early (car method)) 1762 (gnus-server-opened method)
1763 (gnus-check-backend-function
1764 'retrieve-group-data-early (car method)))
1772 (when (gnus-check-backend-function 'request-scan (car method)) 1765 (when (gnus-check-backend-function 'request-scan (car method))
1773 (gnus-request-scan nil method)) 1766 (gnus-request-scan nil method))
1774 (setcar (nthcdr 3 elem) 1767 (setcar (nthcdr 3 elem)
diff --git a/lisp/gnus/gnus-sum.el b/lisp/gnus/gnus-sum.el
index 0af75829bd3..195c7249778 100644
--- a/lisp/gnus/gnus-sum.el
+++ b/lisp/gnus/gnus-sum.el
@@ -2047,6 +2047,7 @@ increase the score of each group you read."
2047 "e" gnus-summary-end-of-article 2047 "e" gnus-summary-end-of-article
2048 "^" gnus-summary-refer-parent-article 2048 "^" gnus-summary-refer-parent-article
2049 "r" gnus-summary-refer-parent-article 2049 "r" gnus-summary-refer-parent-article
2050 "C" gnus-summary-show-complete-article
2050 "D" gnus-summary-enter-digest-group 2051 "D" gnus-summary-enter-digest-group
2051 "R" gnus-summary-refer-references 2052 "R" gnus-summary-refer-references
2052 "T" gnus-summary-refer-thread 2053 "T" gnus-summary-refer-thread
@@ -8645,8 +8646,7 @@ fetch-old-headers verbiage, and so on."
8645 (null gnus-summary-expunge-below) 8646 (null gnus-summary-expunge-below)
8646 (not (eq gnus-build-sparse-threads 'some)) 8647 (not (eq gnus-build-sparse-threads 'some))
8647 (not (eq gnus-build-sparse-threads 'more)) 8648 (not (eq gnus-build-sparse-threads 'more))
8648 (null gnus-thread-expunge-below) 8649 (null gnus-thread-expunge-below)))
8649 (not gnus-use-nocem)))
8650 (push gnus-newsgroup-limit gnus-newsgroup-limits) 8650 (push gnus-newsgroup-limit gnus-newsgroup-limits)
8651 (setq gnus-newsgroup-limit nil) 8651 (setq gnus-newsgroup-limit nil)
8652 (mapatoms 8652 (mapatoms
@@ -8729,14 +8729,7 @@ fetch-old-headers verbiage, and so on."
8729 t) 8729 t)
8730 ;; Do the `display' group parameter. 8730 ;; Do the `display' group parameter.
8731 (and gnus-newsgroup-display 8731 (and gnus-newsgroup-display
8732 (not (funcall gnus-newsgroup-display))) 8732 (not (funcall gnus-newsgroup-display)))))
8733 ;; Check NoCeM things.
8734 (when (and gnus-use-nocem
8735 (gnus-nocem-unwanted-article-p
8736 (mail-header-id (car thread))))
8737 (setq gnus-newsgroup-unreads
8738 (delq number gnus-newsgroup-unreads))
8739 t)))
8740 ;; Nope, invisible article. 8733 ;; Nope, invisible article.
8741 0 8734 0
8742 ;; Ok, this article is to be visible, so we add it to the limit 8735 ;; Ok, this article is to be visible, so we add it to the limit
@@ -9357,6 +9350,18 @@ to save in."
9357 (ps-spool-buffer))))) 9350 (ps-spool-buffer)))))
9358 (kill-buffer buffer)))) 9351 (kill-buffer buffer))))
9359 9352
9353(defun gnus-summary-show-complete-article ()
9354 "Show a complete version of the current article.
9355This is only useful if you're looking at a partial version of the
9356article currently."
9357 (interactive)
9358 (let ((gnus-keep-backlog nil)
9359 (gnus-use-cache nil)
9360 (gnus-agent nil)
9361 (gnus-fetch-partial-articles nil))
9362 (gnus-flush-original-article-buffer)
9363 (gnus-summary-show-article)))
9364
9360(defun gnus-summary-show-article (&optional arg) 9365(defun gnus-summary-show-article (&optional arg)
9361 "Force redisplaying of the current article. 9366 "Force redisplaying of the current article.
9362If ARG (the prefix) is a number, show the article with the charset 9367If ARG (the prefix) is a number, show the article with the charset
diff --git a/lisp/gnus/gnus.el b/lisp/gnus/gnus.el
index c3bf47b9533..0c01d599cfc 100644
--- a/lisp/gnus/gnus.el
+++ b/lisp/gnus/gnus.el
@@ -308,11 +308,6 @@ be set in `.emacs' instead."
308 :group 'gnus-start 308 :group 'gnus-start
309 :type 'boolean) 309 :type 'boolean)
310 310
311(defcustom gnus-play-startup-jingle nil
312 "If non-nil, play the Gnus jingle at startup."
313 :group 'gnus-start
314 :type 'boolean)
315
316(unless (fboundp 'gnus-group-remove-excess-properties) 311(unless (fboundp 'gnus-group-remove-excess-properties)
317 (defalias 'gnus-group-remove-excess-properties 'ignore)) 312 (defalias 'gnus-group-remove-excess-properties 'ignore))
318 313
@@ -960,8 +955,6 @@ be set in `.emacs' instead."
960 955
961(defvar gnus-group-buffer "*Group*") 956(defvar gnus-group-buffer "*Group*")
962 957
963(autoload 'gnus-play-jingle "gnus-audio")
964
965(defface gnus-splash 958(defface gnus-splash
966 '((((class color) 959 '((((class color)
967 (background dark)) 960 (background dark))
@@ -984,9 +977,7 @@ be set in `.emacs' instead."
984 (erase-buffer) 977 (erase-buffer)
985 (unless gnus-inhibit-startup-message 978 (unless gnus-inhibit-startup-message
986 (gnus-group-startup-message) 979 (gnus-group-startup-message)
987 (sit-for 0) 980 (sit-for 0)))))
988 (when gnus-play-startup-jingle
989 (gnus-play-jingle))))))
990 981
991(defun gnus-indent-rigidly (start end arg) 982(defun gnus-indent-rigidly (start end arg)
992 "Indent rigidly using only spaces and no tabs." 983 "Indent rigidly using only spaces and no tabs."
@@ -1580,25 +1571,6 @@ articles. This is not a good idea."
1580 (sexp :format "all" 1571 (sexp :format "all"
1581 :value t))) 1572 :value t)))
1582 1573
1583(defcustom gnus-use-nocem nil
1584 "*If non-nil, Gnus will read NoCeM cancel messages.
1585You can also set this variable to a positive number as a group level.
1586In that case, Gnus scans NoCeM messages when checking new news if this
1587value is not exceeding a group level that you specify as the prefix
1588argument to some commands, e.g. `gnus', `gnus-group-get-new-news', etc.
1589Otherwise, Gnus does not scan NoCeM messages if you specify a group
1590level to those commands."
1591 :group 'gnus-meta
1592 :type '(choice
1593 (const :tag "off" nil)
1594 (const :tag "on" t)
1595 (list :convert-widget
1596 (lambda (widget)
1597 (list 'integer :tag "group level"
1598 :value (if (boundp 'gnus-level-default-subscribed)
1599 gnus-level-default-subscribed
1600 3))))))
1601
1602(defcustom gnus-suppress-duplicates nil 1574(defcustom gnus-suppress-duplicates nil
1603 "*If non-nil, Gnus will mark duplicate copies of the same article as read." 1575 "*If non-nil, Gnus will mark duplicate copies of the same article as read."
1604 :group 'gnus-meta 1576 :group 'gnus-meta
@@ -2813,13 +2785,12 @@ gnus-registry.el will populate this if it's loaded.")
2813 rmail-summary-exists rmail-select-summary) 2785 rmail-summary-exists rmail-select-summary)
2814 ;; Only used in gnus-util, which has an autoload. 2786 ;; Only used in gnus-util, which has an autoload.
2815 ("rmailsum" rmail-update-summary) 2787 ("rmailsum" rmail-update-summary)
2816 ("gnus-audio" :interactive t gnus-audio-play)
2817 ("gnus-xmas" gnus-xmas-splash) 2788 ("gnus-xmas" gnus-xmas-splash)
2818 ("score-mode" :interactive t gnus-score-mode) 2789 ("score-mode" :interactive t gnus-score-mode)
2819 ("gnus-mh" gnus-summary-save-article-folder 2790 ("gnus-mh" gnus-summary-save-article-folder
2820 gnus-Folder-save-name gnus-folder-save-name) 2791 gnus-Folder-save-name gnus-folder-save-name)
2821 ("gnus-mh" :interactive t gnus-summary-save-in-folder) 2792 ("gnus-mh" :interactive t gnus-summary-save-in-folder)
2822 ("gnus-demon" gnus-demon-add-nocem gnus-demon-add-scanmail 2793 ("gnus-demon" gnus-demon-add-scanmail
2823 gnus-demon-add-rescan gnus-demon-add-scan-timestamps 2794 gnus-demon-add-rescan gnus-demon-add-scan-timestamps
2824 gnus-demon-add-disconnection gnus-demon-add-handler 2795 gnus-demon-add-disconnection gnus-demon-add-handler
2825 gnus-demon-remove-handler) 2796 gnus-demon-remove-handler)
@@ -2830,8 +2801,6 @@ gnus-registry.el will populate this if it's loaded.")
2830 gnus-face-from-file) 2801 gnus-face-from-file)
2831 ("gnus-salt" gnus-highlight-selected-tree gnus-possibly-generate-tree 2802 ("gnus-salt" gnus-highlight-selected-tree gnus-possibly-generate-tree
2832 gnus-tree-open gnus-tree-close gnus-carpal-setup-buffer) 2803 gnus-tree-open gnus-tree-close gnus-carpal-setup-buffer)
2833 ("gnus-nocem" gnus-nocem-scan-groups gnus-nocem-close
2834 gnus-nocem-unwanted-article-p)
2835 ("gnus-srvr" gnus-enter-server-buffer gnus-server-set-info 2804 ("gnus-srvr" gnus-enter-server-buffer gnus-server-set-info
2836 gnus-server-server-name) 2805 gnus-server-server-name)
2837 ("gnus-srvr" gnus-browse-foreign-server) 2806 ("gnus-srvr" gnus-browse-foreign-server)
@@ -4395,7 +4364,7 @@ prompt the user for the name of an NNTP server to use."
4395 ;; When using the development version of Gnus, load the gnus-load 4364 ;; When using the development version of Gnus, load the gnus-load
4396 ;; file. 4365 ;; file.
4397 (unless (string-match "^Gnus" gnus-version) 4366 (unless (string-match "^Gnus" gnus-version)
4398 (load "gnus-load")) 4367 (load "gnus-load" nil t))
4399 (unless (byte-code-function-p (symbol-function 'gnus)) 4368 (unless (byte-code-function-p (symbol-function 'gnus))
4400 (message "You should byte-compile Gnus") 4369 (message "You should byte-compile Gnus")
4401 (sit-for 2)) 4370 (sit-for 2))
diff --git a/lisp/gnus/mm-decode.el b/lisp/gnus/mm-decode.el
index 948fc08135d..f773c2fea68 100644
--- a/lisp/gnus/mm-decode.el
+++ b/lisp/gnus/mm-decode.el
@@ -1147,13 +1147,15 @@ in HANDLE."
1147 ;; time to adjust it, since we know at this point that it should 1147 ;; time to adjust it, since we know at this point that it should
1148 ;; be unibyte. 1148 ;; be unibyte.
1149 `(let* ((handle ,handle)) 1149 `(let* ((handle ,handle))
1150 (with-temp-buffer 1150 (when (and (mm-handle-buffer handle)
1151 (mm-disable-multibyte) 1151 (buffer-name (mm-handle-buffer handle)))
1152 (insert-buffer-substring (mm-handle-buffer handle)) 1152 (with-temp-buffer
1153 (mm-decode-content-transfer-encoding 1153 (mm-disable-multibyte)
1154 (mm-handle-encoding handle) 1154 (insert-buffer-substring (mm-handle-buffer handle))
1155 (mm-handle-media-type handle)) 1155 (mm-decode-content-transfer-encoding
1156 ,@forms))) 1156 (mm-handle-encoding handle)
1157 (mm-handle-media-type handle))
1158 ,@forms))))
1157(put 'mm-with-part 'lisp-indent-function 1) 1159(put 'mm-with-part 'lisp-indent-function 1)
1158(put 'mm-with-part 'edebug-form-spec '(body)) 1160(put 'mm-with-part 'edebug-form-spec '(body))
1159 1161
@@ -1246,9 +1248,13 @@ PROMPT overrides the default one used to ask user for a file name."
1246 (setq filename (gnus-map-function mm-file-name-rewrite-functions 1248 (setq filename (gnus-map-function mm-file-name-rewrite-functions
1247 (file-name-nondirectory filename)))) 1249 (file-name-nondirectory filename))))
1248 (setq file 1250 (setq file
1249 (read-file-name (or prompt "Save MIME part to: ") 1251 (read-file-name (or prompt
1252 (format "Save MIME part to (default %s): "
1253 (or filename "")))
1250 (or mm-default-directory default-directory) 1254 (or mm-default-directory default-directory)
1251 nil nil (or filename ""))) 1255 (or filename "")))
1256 (when (file-directory-p file)
1257 (setq file (expand-file-name filename file)))
1252 (setq mm-default-directory (file-name-directory file)) 1258 (setq mm-default-directory (file-name-directory file))
1253 (and (or (not (file-exists-p file)) 1259 (and (or (not (file-exists-p file))
1254 (yes-or-no-p (format "File %s already exists; overwrite? " 1260 (yes-or-no-p (format "File %s already exists; overwrite? "
diff --git a/lisp/gnus/mml1991.el b/lisp/gnus/mml1991.el
index b73162ff131..22eb7b66829 100644
--- a/lisp/gnus/mml1991.el
+++ b/lisp/gnus/mml1991.el
@@ -57,8 +57,6 @@
57(defvar mml1991-function-alist 57(defvar mml1991-function-alist
58 '((mailcrypt mml1991-mailcrypt-sign 58 '((mailcrypt mml1991-mailcrypt-sign
59 mml1991-mailcrypt-encrypt) 59 mml1991-mailcrypt-encrypt)
60 (gpg mml1991-gpg-sign
61 mml1991-gpg-encrypt)
62 (pgg mml1991-pgg-sign 60 (pgg mml1991-pgg-sign
63 mml1991-pgg-encrypt) 61 mml1991-pgg-encrypt)
64 (epg mml1991-epg-sign 62 (epg mml1991-epg-sign
@@ -168,99 +166,6 @@ Whether the passphrase is cached at all is controlled by
168 (insert-buffer-substring cipher) 166 (insert-buffer-substring cipher)
169 (goto-char (point-max)))))) 167 (goto-char (point-max))))))
170 168
171;;; gpg wrapper
172
173(autoload 'gpg-sign-cleartext "gpg")
174
175(declare-function gpg-sign-encrypt "ext:gpg"
176 (plaintext ciphertext result recipients &optional
177 passphrase sign-with-key armor textmode))
178(declare-function gpg-encrypt "ext:gpg"
179 (plaintext ciphertext result recipients &optional
180 passphrase armor textmode))
181
182(defun mml1991-gpg-sign (cont)
183 (let ((text (current-buffer))
184 headers signature
185 (result-buffer (get-buffer-create "*GPG Result*")))
186 ;; Save MIME Content[^ ]+: headers from signing
187 (goto-char (point-min))
188 (while (looking-at "^Content[^ ]+:") (forward-line))
189 (unless (bobp)
190 (setq headers (buffer-string))
191 (delete-region (point-min) (point)))
192 (goto-char (point-max))
193 (unless (bolp)
194 (insert "\n"))
195 (quoted-printable-decode-region (point-min) (point-max))
196 (with-temp-buffer
197 (unless (gpg-sign-cleartext text (setq signature (current-buffer))
198 result-buffer
199 nil
200 (message-options-get 'message-sender))
201 (unless (> (point-max) (point-min))
202 (pop-to-buffer result-buffer)
203 (error "Sign error")))
204 (goto-char (point-min))
205 (while (re-search-forward "\r+$" nil t)
206 (replace-match "" t t))
207 (quoted-printable-encode-region (point-min) (point-max))
208 (set-buffer text)
209 (delete-region (point-min) (point-max))
210 (if headers (insert headers))
211 (insert "\n")
212 (insert-buffer-substring signature)
213 (goto-char (point-max)))))
214
215(defun mml1991-gpg-encrypt (cont &optional sign)
216 (let ((text (current-buffer))
217 cipher
218 (result-buffer (get-buffer-create "*GPG Result*")))
219 ;; Strip MIME Content[^ ]: headers since it will be ASCII ARMORED
220 (goto-char (point-min))
221 (while (looking-at "^Content[^ ]+:") (forward-line))
222 (unless (bobp)
223 (delete-region (point-min) (point)))
224 (mm-with-unibyte-current-buffer
225 (with-temp-buffer
226 (inline (mm-disable-multibyte))
227 (flet ((gpg-encrypt-func
228 (sign plaintext ciphertext result recipients &optional
229 passphrase sign-with-key armor textmode)
230 (if sign
231 (gpg-sign-encrypt
232 plaintext ciphertext result recipients passphrase
233 sign-with-key armor textmode)
234 (gpg-encrypt
235 plaintext ciphertext result recipients passphrase
236 armor textmode))))
237 (unless (gpg-encrypt-func
238 sign
239 text (setq cipher (current-buffer))
240 result-buffer
241 (split-string
242 (or
243 (message-options-get 'message-recipients)
244 (message-options-set 'message-recipients
245 (read-string "Recipients: ")))
246 "[ \f\t\n\r\v,]+")
247 nil
248 (message-options-get 'message-sender)
249 t t) ; armor & textmode
250 (unless (> (point-max) (point-min))
251 (pop-to-buffer result-buffer)
252 (error "Encrypt error"))))
253 (goto-char (point-min))
254 (while (re-search-forward "\r+$" nil t)
255 (replace-match "" t t))
256 (set-buffer text)
257 (delete-region (point-min) (point-max))
258 ;;(insert "Content-Type: application/pgp-encrypted\n\n")
259 ;;(insert "Version: 1\n\n")
260 (insert "\n")
261 (insert-buffer-substring cipher)
262 (goto-char (point-max))))))
263
264;; pgg wrapper 169;; pgg wrapper
265 170
266(defvar pgg-default-user-id) 171(defvar pgg-default-user-id)
diff --git a/lisp/gnus/mml2015.el b/lisp/gnus/mml2015.el
index 1002f24ea82..391517f38ba 100644
--- a/lisp/gnus/mml2015.el
+++ b/lisp/gnus/mml2015.el
@@ -63,11 +63,6 @@
63 (require 'pgg))) 63 (require 'pgg)))
64 (and (fboundp 'pgg-sign-region) 64 (and (fboundp 'pgg-sign-region)
65 'pgg)) 65 'pgg))
66 (progn
67 (ignore-errors
68 (require 'gpg))
69 (and (fboundp 'gpg-sign-detached)
70 'gpg))
71 (progn (ignore-errors 66 (progn (ignore-errors
72 (load "mc-toplev")) 67 (load "mc-toplev"))
73 (and (fboundp 'mc-encrypt-generic) 68 (and (fboundp 'mc-encrypt-generic)
@@ -75,7 +70,7 @@
75 (fboundp 'mc-cleanup-recipient-headers) 70 (fboundp 'mc-cleanup-recipient-headers)
76 'mailcrypt))) 71 'mailcrypt)))
77 "The package used for PGP/MIME. 72 "The package used for PGP/MIME.
78Valid packages include `epg', `pgg', `gpg' and `mailcrypt'.") 73Valid packages include `epg', `pgg' and `mailcrypt'.")
79 74
80;; Something is not RFC2015. 75;; Something is not RFC2015.
81(defvar mml2015-function-alist 76(defvar mml2015-function-alist
@@ -85,24 +80,18 @@ Valid packages include `epg', `pgg', `gpg' and `mailcrypt'.")
85 mml2015-mailcrypt-decrypt 80 mml2015-mailcrypt-decrypt
86 mml2015-mailcrypt-clear-verify 81 mml2015-mailcrypt-clear-verify
87 mml2015-mailcrypt-clear-decrypt) 82 mml2015-mailcrypt-clear-decrypt)
88 (gpg mml2015-gpg-sign 83 (pgg mml2015-pgg-sign
89 mml2015-gpg-encrypt 84 mml2015-pgg-encrypt
90 mml2015-gpg-verify 85 mml2015-pgg-verify
91 mml2015-gpg-decrypt 86 mml2015-pgg-decrypt
92 mml2015-gpg-clear-verify 87 mml2015-pgg-clear-verify
93 mml2015-gpg-clear-decrypt) 88 mml2015-pgg-clear-decrypt)
94 (pgg mml2015-pgg-sign 89 (epg mml2015-epg-sign
95 mml2015-pgg-encrypt 90 mml2015-epg-encrypt
96 mml2015-pgg-verify 91 mml2015-epg-verify
97 mml2015-pgg-decrypt 92 mml2015-epg-decrypt
98 mml2015-pgg-clear-verify 93 mml2015-epg-clear-verify
99 mml2015-pgg-clear-decrypt) 94 mml2015-epg-clear-decrypt))
100 (epg mml2015-epg-sign
101 mml2015-epg-encrypt
102 mml2015-epg-verify
103 mml2015-epg-decrypt
104 mml2015-epg-clear-verify
105 mml2015-epg-clear-decrypt))
106 "Alist of PGP/MIME functions.") 95 "Alist of PGP/MIME functions.")
107 96
108(defvar mml2015-result-buffer nil) 97(defvar mml2015-result-buffer nil)
@@ -148,7 +137,7 @@ Whether the passphrase is cached at all is controlled by
148 137
149;; Extract plaintext from cleartext signature. IMO, this kind of task 138;; Extract plaintext from cleartext signature. IMO, this kind of task
150;; should be done by GnuPG rather than Elisp, but older PGP backends 139;; should be done by GnuPG rather than Elisp, but older PGP backends
151;; (such as Mailcrypt, PGG, and gpg.el) discard the output from GnuPG. 140;; (such as Mailcrypt, and PGG) discard the output from GnuPG.
152(defun mml2015-extract-cleartext-signature () 141(defun mml2015-extract-cleartext-signature ()
153 ;; Daiki Ueno in 142 ;; Daiki Ueno in
154 ;; <54a15d860801080142l70b95d7dkac4bf51a86196011@mail.gmail.com>: ``I still 143 ;; <54a15d860801080142l70b95d7dkac4bf51a86196011@mail.gmail.com>: ``I still
@@ -234,6 +223,58 @@ Whether the passphrase is cached at all is controlled by
234 handles 223 handles
235 (list handles))))) 224 (list handles)))))
236 225
226(defun mml2015-gpg-pretty-print-fpr (fingerprint)
227 (let* ((result "")
228 (fpr-length (string-width fingerprint))
229 (n-slice 0)
230 slice)
231 (setq fingerprint (string-to-list fingerprint))
232 (while fingerprint
233 (setq fpr-length (- fpr-length 4))
234 (setq slice (butlast fingerprint fpr-length))
235 (setq fingerprint (nthcdr 4 fingerprint))
236 (setq n-slice (1+ n-slice))
237 (setq result
238 (concat
239 result
240 (case n-slice
241 (1 slice)
242 (otherwise (concat " " slice))))))
243 result))
244
245(defun mml2015-gpg-extract-signature-details ()
246 (goto-char (point-min))
247 (let* ((expired (re-search-forward
248 "^\\[GNUPG:\\] SIGEXPIRED$"
249 nil t))
250 (signer (and (re-search-forward
251 "^\\[GNUPG:\\] GOODSIG \\([0-9A-Za-z]*\\) \\(.*\\)$"
252 nil t)
253 (cons (match-string 1) (match-string 2))))
254 (fprint (and (re-search-forward
255 "^\\[GNUPG:\\] VALIDSIG \\([0-9a-zA-Z]*\\) "
256 nil t)
257 (match-string 1)))
258 (trust (and (re-search-forward
259 "^\\[GNUPG:\\] \\(TRUST_.*\\)$"
260 nil t)
261 (match-string 1)))
262 (trust-good-enough-p
263 (cdr (assoc trust mml2015-unabbrev-trust-alist))))
264 (cond ((and signer fprint)
265 (concat (cdr signer)
266 (unless trust-good-enough-p
267 (concat "\nUntrusted, Fingerprint: "
268 (mml2015-gpg-pretty-print-fpr fprint)))
269 (when expired
270 (format "\nWARNING: Signature from expired key (%s)"
271 (car signer)))))
272 ((re-search-forward
273 "^\\(gpg: \\)?Good signature from \"\\(.*\\)\"$" nil t)
274 (match-string 2))
275 (t
276 "From unknown user"))))
277
237(defun mml2015-mailcrypt-clear-decrypt () 278(defun mml2015-mailcrypt-clear-decrypt ()
238 (let (result) 279 (let (result)
239 (setq result 280 (setq result
@@ -446,280 +487,6 @@ Whether the passphrase is cached at all is controlled by
446 (insert (format "--%s--\n" boundary)) 487 (insert (format "--%s--\n" boundary))
447 (goto-char (point-max)))) 488 (goto-char (point-max))))
448 489
449;;; gpg wrapper
450
451(autoload 'gpg-decrypt "gpg")
452(autoload 'gpg-verify "gpg")
453(autoload 'gpg-verify-cleartext "gpg")
454(autoload 'gpg-sign-detached "gpg")
455(autoload 'gpg-sign-encrypt "gpg")
456(autoload 'gpg-encrypt "gpg")
457(autoload 'gpg-passphrase-read "gpg")
458
459(defun mml2015-gpg-passphrase ()
460 (or (message-options-get 'gpg-passphrase)
461 (message-options-set 'gpg-passphrase (gpg-passphrase-read))))
462
463(defun mml2015-gpg-decrypt-1 ()
464 (let ((cipher (current-buffer)) plain result)
465 (if (with-temp-buffer
466 (prog1
467 (gpg-decrypt cipher (setq plain (current-buffer))
468 mml2015-result-buffer nil)
469 (mm-set-handle-multipart-parameter
470 mm-security-handle 'gnus-details
471 (with-current-buffer mml2015-result-buffer
472 (buffer-string)))
473 (set-buffer cipher)
474 (erase-buffer)
475 (insert-buffer-substring plain)
476 (goto-char (point-min))
477 (while (search-forward "\r\n" nil t)
478 (replace-match "\n" t t))))
479 '(t)
480 ;; Some wrong with the return value, check plain text buffer.
481 (if (> (point-max) (point-min))
482 '(t)
483 nil))))
484
485(defun mml2015-gpg-decrypt (handle ctl)
486 (let ((mml2015-decrypt-function 'mml2015-gpg-decrypt-1))
487 (mml2015-mailcrypt-decrypt handle ctl)))
488
489(defun mml2015-gpg-clear-decrypt ()
490 (let (result)
491 (setq result (mml2015-gpg-decrypt-1))
492 (if (car result)
493 (mm-set-handle-multipart-parameter
494 mm-security-handle 'gnus-info "OK")
495 (mm-set-handle-multipart-parameter
496 mm-security-handle 'gnus-info "Failed"))))
497
498(defun mml2015-gpg-pretty-print-fpr (fingerprint)
499 (let* ((result "")
500 (fpr-length (string-width fingerprint))
501 (n-slice 0)
502 slice)
503 (setq fingerprint (string-to-list fingerprint))
504 (while fingerprint
505 (setq fpr-length (- fpr-length 4))
506 (setq slice (butlast fingerprint fpr-length))
507 (setq fingerprint (nthcdr 4 fingerprint))
508 (setq n-slice (1+ n-slice))
509 (setq result
510 (concat
511 result
512 (case n-slice
513 (1 slice)
514 (otherwise (concat " " slice))))))
515 result))
516
517(defun mml2015-gpg-extract-signature-details ()
518 (goto-char (point-min))
519 (let* ((expired (re-search-forward
520 "^\\[GNUPG:\\] SIGEXPIRED$"
521 nil t))
522 (signer (and (re-search-forward
523 "^\\[GNUPG:\\] GOODSIG \\([0-9A-Za-z]*\\) \\(.*\\)$"
524 nil t)
525 (cons (match-string 1) (match-string 2))))
526 (fprint (and (re-search-forward
527 "^\\[GNUPG:\\] VALIDSIG \\([0-9a-zA-Z]*\\) "
528 nil t)
529 (match-string 1)))
530 (trust (and (re-search-forward
531 "^\\[GNUPG:\\] \\(TRUST_.*\\)$"
532 nil t)
533 (match-string 1)))
534 (trust-good-enough-p
535 (cdr (assoc trust mml2015-unabbrev-trust-alist))))
536 (cond ((and signer fprint)
537 (concat (cdr signer)
538 (unless trust-good-enough-p
539 (concat "\nUntrusted, Fingerprint: "
540 (mml2015-gpg-pretty-print-fpr fprint)))
541 (when expired
542 (format "\nWARNING: Signature from expired key (%s)"
543 (car signer)))))
544 ((re-search-forward
545 "^\\(gpg: \\)?Good signature from \"\\(.*\\)\"$" nil t)
546 (match-string 2))
547 (t
548 "From unknown user"))))
549
550(defun mml2015-gpg-verify (handle ctl)
551 (catch 'error
552 (let (part message signature info-is-set-p)
553 (unless (setq part (mm-find-raw-part-by-type
554 ctl (or (mm-handle-multipart-ctl-parameter
555 ctl 'protocol)
556 "application/pgp-signature")
557 t))
558 (mm-set-handle-multipart-parameter
559 mm-security-handle 'gnus-info "Corrupted")
560 (throw 'error handle))
561 (with-temp-buffer
562 (setq message (current-buffer))
563 (insert part)
564 ;; Convert <LF> to <CR><LF> in signed text. If --textmode is
565 ;; specified when signing, the conversion is not necessary.
566 (goto-char (point-min))
567 (end-of-line)
568 (while (not (eobp))
569 (unless (eq (char-before) ?\r)
570 (insert "\r"))
571 (forward-line)
572 (end-of-line))
573 (with-temp-buffer
574 (setq signature (current-buffer))
575 (unless (setq part (mm-find-part-by-type
576 (cdr handle) "application/pgp-signature" nil t))
577 (mm-set-handle-multipart-parameter
578 mm-security-handle 'gnus-info "Corrupted")
579 (throw 'error handle))
580 (mm-insert-part part)
581 (unless (condition-case err
582 (prog1
583 (gpg-verify message signature mml2015-result-buffer)
584 (mm-set-handle-multipart-parameter
585 mm-security-handle 'gnus-details
586 (with-current-buffer mml2015-result-buffer
587 (buffer-string))))
588 (error
589 (mm-set-handle-multipart-parameter
590 mm-security-handle 'gnus-details (mml2015-format-error err))
591 (mm-set-handle-multipart-parameter
592 mm-security-handle 'gnus-info "Error.")
593 (setq info-is-set-p t)
594 nil)
595 (quit
596 (mm-set-handle-multipart-parameter
597 mm-security-handle 'gnus-details "Quit.")
598 (mm-set-handle-multipart-parameter
599 mm-security-handle 'gnus-info "Quit.")
600 (setq info-is-set-p t)
601 nil))
602 (unless info-is-set-p
603 (mm-set-handle-multipart-parameter
604 mm-security-handle 'gnus-info "Failed"))
605 (throw 'error handle)))
606 (mm-set-handle-multipart-parameter
607 mm-security-handle 'gnus-info
608 (with-current-buffer mml2015-result-buffer
609 (mml2015-gpg-extract-signature-details))))
610 handle)))
611
612(defun mml2015-gpg-clear-verify ()
613 (if (condition-case err
614 (prog1
615 (gpg-verify-cleartext (current-buffer) mml2015-result-buffer)
616 (mm-set-handle-multipart-parameter
617 mm-security-handle 'gnus-details
618 (with-current-buffer mml2015-result-buffer
619 (buffer-string))))
620 (error
621 (mm-set-handle-multipart-parameter
622 mm-security-handle 'gnus-details (mml2015-format-error err))
623 nil)
624 (quit
625 (mm-set-handle-multipart-parameter
626 mm-security-handle 'gnus-details "Quit.")
627 nil))
628 (mm-set-handle-multipart-parameter
629 mm-security-handle 'gnus-info
630 (with-current-buffer mml2015-result-buffer
631 (mml2015-gpg-extract-signature-details)))
632 (mm-set-handle-multipart-parameter
633 mm-security-handle 'gnus-info "Failed"))
634 (mml2015-extract-cleartext-signature))
635
636(defun mml2015-gpg-sign (cont)
637 (let ((boundary (mml-compute-boundary cont))
638 (text (current-buffer)) signature)
639 (goto-char (point-max))
640 (unless (bolp)
641 (insert "\n"))
642 (with-temp-buffer
643 (unless (gpg-sign-detached text (setq signature (current-buffer))
644 mml2015-result-buffer
645 nil
646 (message-options-get 'message-sender)
647 t t) ; armor & textmode
648 (unless (> (point-max) (point-min))
649 (pop-to-buffer mml2015-result-buffer)
650 (error "Sign error")))
651 (goto-char (point-min))
652 (while (re-search-forward "\r+$" nil t)
653 (replace-match "" t t))
654 (set-buffer text)
655 (goto-char (point-min))
656 (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n"
657 boundary))
658 ;;; FIXME: what is the micalg?
659 (insert "\tmicalg=pgp-sha1; protocol=\"application/pgp-signature\"\n")
660 (insert (format "\n--%s\n" boundary))
661 (goto-char (point-max))
662 (insert (format "\n--%s\n" boundary))
663 (insert "Content-Type: application/pgp-signature\n\n")
664 (insert-buffer-substring signature)
665 (goto-char (point-max))
666 (insert (format "--%s--\n" boundary))
667 (goto-char (point-max)))))
668
669(defun mml2015-gpg-encrypt (cont &optional sign)
670 (let ((boundary (mml-compute-boundary cont))
671 (text (current-buffer))
672 cipher)
673 (mm-with-unibyte-current-buffer
674 (with-temp-buffer
675 (mm-disable-multibyte)
676 ;; set up a function to call the correct gpg encrypt routine
677 ;; with the right arguments. (FIXME: this should be done
678 ;; differently.)
679 (flet ((gpg-encrypt-func
680 (sign plaintext ciphertext result recipients &optional
681 passphrase sign-with-key armor textmode)
682 (if sign
683 (gpg-sign-encrypt
684 plaintext ciphertext result recipients passphrase
685 sign-with-key armor textmode)
686 (gpg-encrypt
687 plaintext ciphertext result recipients passphrase
688 armor textmode))))
689 (unless (gpg-encrypt-func
690 sign ; passed in when using signencrypt
691 text (setq cipher (current-buffer))
692 mml2015-result-buffer
693 (split-string
694 (or
695 (message-options-get 'message-recipients)
696 (message-options-set 'message-recipients
697 (read-string "Recipients: ")))
698 "[ \f\t\n\r\v,]+")
699 nil
700 (message-options-get 'message-sender)
701 t t) ; armor & textmode
702 (unless (> (point-max) (point-min))
703 (pop-to-buffer mml2015-result-buffer)
704 (error "Encrypt error"))))
705 (goto-char (point-min))
706 (while (re-search-forward "\r+$" nil t)
707 (replace-match "" t t))
708 (set-buffer text)
709 (delete-region (point-min) (point-max))
710 (insert (format "Content-Type: multipart/encrypted; boundary=\"%s\";\n"
711 boundary))
712 (insert "\tprotocol=\"application/pgp-encrypted\"\n\n")
713 (insert (format "--%s\n" boundary))
714 (insert "Content-Type: application/pgp-encrypted\n\n")
715 (insert "Version: 1\n\n")
716 (insert (format "--%s\n" boundary))
717 (insert "Content-Type: application/octet-stream\n\n")
718 (insert-buffer-substring cipher)
719 (goto-char (point-max))
720 (insert (format "--%s--\n" boundary))
721 (goto-char (point-max))))))
722
723;;; pgg wrapper 490;;; pgg wrapper
724 491
725(defvar pgg-default-user-id) 492(defvar pgg-default-user-id)
diff --git a/lisp/gnus/nndoc.el b/lisp/gnus/nndoc.el
index d6d455f078f..2eeaeba0512 100644
--- a/lisp/gnus/nndoc.el
+++ b/lisp/gnus/nndoc.el
@@ -64,9 +64,6 @@ from the document.")
64 (body-end . "") 64 (body-end . "")
65 (file-end . "") 65 (file-end . "")
66 (subtype digest guess)) 66 (subtype digest guess))
67 (mime-parts
68 (generate-head-function . nndoc-generate-mime-parts-head)
69 (article-transform-function . nndoc-transform-mime-parts))
70 (nsmail 67 (nsmail
71 (article-begin . "^From - ")) 68 (article-begin . "^From - "))
72 (news 69 (news
@@ -77,6 +74,9 @@ from the document.")
77 (mbox 74 (mbox
78 (article-begin-function . nndoc-mbox-article-begin) 75 (article-begin-function . nndoc-mbox-article-begin)
79 (body-end-function . nndoc-mbox-body-end)) 76 (body-end-function . nndoc-mbox-body-end))
77 (mime-parts
78 (generate-head-function . nndoc-generate-mime-parts-head)
79 (article-transform-function . nndoc-transform-mime-parts))
80 (babyl 80 (babyl
81 (article-begin . "\^_\^L *\n") 81 (article-begin . "\^_\^L *\n")
82 (body-end . "\^_") 82 (body-end . "\^_")
diff --git a/lisp/gnus/nnheader.el b/lisp/gnus/nnheader.el
index 9d22080cc75..b97fe5f8079 100644
--- a/lisp/gnus/nnheader.el
+++ b/lisp/gnus/nnheader.el
@@ -822,12 +822,16 @@ The first string in ARGS can be a format string."
822 (apply 'format args))) 822 (apply 'format args)))
823 nil) 823 nil)
824 824
825(defun nnheader-get-report (backend) 825(defun nnheader-get-report-string (backend)
826 "Get the most recent report from BACKEND." 826 "Get the most recent report from BACKEND."
827 (condition-case () 827 (condition-case ()
828 (nnheader-message 5 "%s" (symbol-value (intern (format "%s-status-string" 828 (format "%s" (symbol-value (intern (format "%s-status-string"
829 backend)))) 829 backend))))
830 (error (nnheader-message 5 "")))) 830 (error "")))
831
832(defun nnheader-get-report (backend)
833 "Get the most recent report from BACKEND."
834 (nnheader-message 5 (nnheader-get-report-string backend)))
831 835
832(defun nnheader-insert (format &rest args) 836(defun nnheader-insert (format &rest args)
833 "Clear the communication buffer and insert FORMAT and ARGS into the buffer. 837 "Clear the communication buffer and insert FORMAT and ARGS into the buffer.
diff --git a/lisp/gnus/nnimap.el b/lisp/gnus/nnimap.el
index 000855db8da..f3cb77f5201 100644
--- a/lisp/gnus/nnimap.el
+++ b/lisp/gnus/nnimap.el
@@ -62,22 +62,23 @@ Values are `ssl', `network', `starttls' or `shell'.")
62(defvoo nnimap-inbox nil 62(defvoo nnimap-inbox nil
63 "The mail box where incoming mail arrives and should be split out of.") 63 "The mail box where incoming mail arrives and should be split out of.")
64 64
65(defvoo nnimap-split-methods nil
66 "How mail is split.
67Uses the same syntax as nnmail-split-methods")
68
65(defvoo nnimap-authenticator nil 69(defvoo nnimap-authenticator nil
66 "How nnimap authenticate itself to the server. 70 "How nnimap authenticate itself to the server.
67Possible choices are nil (use default methods) or `anonymous'.") 71Possible choices are nil (use default methods) or `anonymous'.")
68 72
69(defvoo nnimap-fetch-partial-articles nil
70 "If non-nil, nnimap will fetch partial articles.
71If t, nnimap will fetch only the first part. If a string, it
72will fetch all parts that have types that match that string. A
73likely value would be \"text/\" to automatically fetch all
74textual parts.")
75
76(defvoo nnimap-expunge t 73(defvoo nnimap-expunge t
77 "If non-nil, expunge articles after deleting them. 74 "If non-nil, expunge articles after deleting them.
78This is always done if the server supports UID EXPUNGE, but it's 75This is always done if the server supports UID EXPUNGE, but it's
79not done by default on servers that doesn't support that command.") 76not done by default on servers that doesn't support that command.")
80 77
78(defvoo nnimap-streaming t
79 "If non-nil, try to use streaming commands with IMAP servers.
80Switching this off will make nnimap slower, but it helps with
81some servers.")
81 82
82(defvoo nnimap-connection-alist nil) 83(defvoo nnimap-connection-alist nil)
83 84
@@ -110,8 +111,6 @@ not done by default on servers that doesn't support that command.")
110 (download "gnus-download") 111 (download "gnus-download")
111 (forward "gnus-forward"))) 112 (forward "gnus-forward")))
112 113
113(defvar nnimap-split-methods nil)
114
115(defun nnimap-buffer () 114(defun nnimap-buffer ()
116 (nnimap-find-process-buffer nntp-server-buffer)) 115 (nnimap-find-process-buffer nntp-server-buffer))
117 116
@@ -128,8 +127,7 @@ not done by default on servers that doesn't support that command.")
128 (nnimap-article-ranges (gnus-compress-sequence articles)) 127 (nnimap-article-ranges (gnus-compress-sequence articles))
129 (format "(UID RFC822.SIZE BODYSTRUCTURE %s)" 128 (format "(UID RFC822.SIZE BODYSTRUCTURE %s)"
130 (format 129 (format
131 (if (member "IMAP4REV1" 130 (if (nnimap-ver4-p)
132 (nnimap-capabilities nnimap-object))
133 "BODY.PEEK[HEADER.FIELDS %s]" 131 "BODY.PEEK[HEADER.FIELDS %s]"
134 "RFC822.HEADER.LINES %s") 132 "RFC822.HEADER.LINES %s")
135 (append '(Subject From Date Message-Id 133 (append '(Subject From Date Message-Id
@@ -273,42 +271,50 @@ not done by default on servers that doesn't support that command.")
273 (with-current-buffer (nnimap-make-process-buffer buffer) 271 (with-current-buffer (nnimap-make-process-buffer buffer)
274 (let* ((coding-system-for-read 'binary) 272 (let* ((coding-system-for-read 'binary)
275 (coding-system-for-write 'binary) 273 (coding-system-for-write 'binary)
274 (port nil)
276 (ports 275 (ports
277 (cond 276 (cond
278 ((eq nnimap-stream 'network) 277 ((eq nnimap-stream 'network)
279 (open-network-stream 278 (open-network-stream
280 "*nnimap*" (current-buffer) nnimap-address 279 "*nnimap*" (current-buffer) nnimap-address
281 (or nnimap-server-port 280 (setq port
282 (if (netrc-find-service-number "imap") 281 (or nnimap-server-port
283 "imap" 282 (if (netrc-find-service-number "imap")
284 "143"))) 283 "imap"
284 "143"))))
285 '("143" "imap")) 285 '("143" "imap"))
286 ((eq nnimap-stream 'shell) 286 ((eq nnimap-stream 'shell)
287 (nnimap-open-shell-stream 287 (nnimap-open-shell-stream
288 "*nnimap*" (current-buffer) nnimap-address 288 "*nnimap*" (current-buffer) nnimap-address
289 (or nnimap-server-port "imap")) 289 (setq port (or nnimap-server-port "imap")))
290 '("imap")) 290 '("imap"))
291 ((eq nnimap-stream 'starttls) 291 ((eq nnimap-stream 'starttls)
292 (starttls-open-stream 292 (starttls-open-stream
293 "*nnimap*" (current-buffer) nnimap-address 293 "*nnimap*" (current-buffer) nnimap-address
294 (or nnimap-server-port "imap")) 294 (setq port (or nnimap-server-port "imap")))
295 '("imap")) 295 '("imap"))
296 ((eq nnimap-stream 'ssl) 296 ((eq nnimap-stream 'ssl)
297 (open-tls-stream 297 (open-tls-stream
298 "*nnimap*" (current-buffer) nnimap-address 298 "*nnimap*" (current-buffer) nnimap-address
299 (or nnimap-server-port 299 (setq port
300 (if (netrc-find-service-number "imaps") 300 (or nnimap-server-port
301 "imaps" 301 (if (netrc-find-service-number "imaps")
302 "993"))) 302 "imaps"
303 "993"))))
303 '("143" "993" "imap" "imaps")))) 304 '("143" "993" "imap" "imaps"))))
304 connection-result login-result credentials) 305 connection-result login-result credentials)
305 (setf (nnimap-process nnimap-object) 306 (setf (nnimap-process nnimap-object)
306 (get-buffer-process (current-buffer))) 307 (get-buffer-process (current-buffer)))
307 (when (and (nnimap-process nnimap-object) 308 (if (not (and (nnimap-process nnimap-object)
308 (memq (process-status (nnimap-process nnimap-object)) 309 (memq (process-status (nnimap-process nnimap-object))
309 '(open run))) 310 '(open run))))
311 (nnheader-report 'nnimap "Unable to contact %s:%s via %s"
312 nnimap-address port nnimap-stream)
310 (gnus-set-process-query-on-exit-flag (nnimap-process nnimap-object) nil) 313 (gnus-set-process-query-on-exit-flag (nnimap-process nnimap-object) nil)
311 (when (setq connection-result (nnimap-wait-for-connection)) 314 (if (not (setq connection-result (nnimap-wait-for-connection)))
315 (nnheader-report 'nnimap
316 "%s" (buffer-substring
317 (point) (line-end-position)))
312 (when (eq nnimap-stream 'starttls) 318 (when (eq nnimap-stream 'starttls)
313 (nnimap-command "STARTTLS") 319 (nnimap-command "STARTTLS")
314 (starttls-negotiate (nnimap-process nnimap-object))) 320 (starttls-negotiate (nnimap-process nnimap-object)))
@@ -370,7 +376,7 @@ not done by default on servers that doesn't support that command.")
370(deffoo nnimap-request-article (article &optional group server to-buffer) 376(deffoo nnimap-request-article (article &optional group server to-buffer)
371 (with-current-buffer nntp-server-buffer 377 (with-current-buffer nntp-server-buffer
372 (let ((result (nnimap-possibly-change-group group server)) 378 (let ((result (nnimap-possibly-change-group group server))
373 parts) 379 parts structure)
374 (when (stringp article) 380 (when (stringp article)
375 (setq article (nnimap-find-article-by-message-id group article))) 381 (setq article (nnimap-find-article-by-message-id group article)))
376 (when (and result 382 (when (and result
@@ -378,36 +384,113 @@ not done by default on servers that doesn't support that command.")
378 (erase-buffer) 384 (erase-buffer)
379 (with-current-buffer (nnimap-buffer) 385 (with-current-buffer (nnimap-buffer)
380 (erase-buffer) 386 (erase-buffer)
381 (when nnimap-fetch-partial-articles 387 (when gnus-fetch-partial-articles
382 (if (eq nnimap-fetch-partial-articles t) 388 (if (eq gnus-fetch-partial-articles t)
383 (setq parts '(1)) 389 (setq parts '(1))
384 (nnimap-command "UID FETCH %d (BODYSTRUCTURE)" article) 390 (nnimap-command "UID FETCH %d (BODYSTRUCTURE)" article)
385 (goto-char (point-min)) 391 (goto-char (point-min))
386 (when (re-search-forward "FETCH.*BODYSTRUCTURE" nil t) 392 (when (re-search-forward "FETCH.*BODYSTRUCTURE" nil t)
387 (let ((structure (ignore-errors (read (current-buffer))))) 393 (setq structure (ignore-errors (read (current-buffer)))
388 (setq parts (nnimap-find-wanted-parts structure)))))) 394 parts (nnimap-find-wanted-parts structure)))))
389 (setq result 395 (when (if parts
390 (nnimap-command 396 (nnimap-get-partial-article article parts structure)
391 (if (member "IMAP4REV1" (nnimap-capabilities nnimap-object)) 397 (nnimap-get-whole-article article))
392 "UID FETCH %d BODY.PEEK[]" 398 (let ((buffer (current-buffer)))
393 "UID FETCH %d RFC822.PEEK") 399 (with-current-buffer (or to-buffer nntp-server-buffer)
394 article)) 400 (erase-buffer)
395 ;; Check that we really got an article. 401 (insert-buffer-substring buffer)
396 (goto-char (point-min)) 402 (nnheader-ms-strip-cr)
397 (unless (looking-at "\\* [0-9]+ FETCH") 403 (cons group article)))))))))
398 (setq result nil))) 404
399 (let ((buffer (nnimap-find-process-buffer (current-buffer)))) 405(defun nnimap-get-whole-article (article)
400 (when (car result) 406 (let ((result
401 (with-current-buffer (or to-buffer nntp-server-buffer) 407 (nnimap-command
402 (insert-buffer-substring buffer) 408 (if (nnimap-ver4-p)
403 (goto-char (point-min)) 409 "UID FETCH %d BODY.PEEK[]"
404 (let ((bytes (nnimap-get-length))) 410 "UID FETCH %d RFC822.PEEK")
405 (delete-region (line-beginning-position) 411 article)))
406 (progn (forward-line 1) (point))) 412 ;; Check that we really got an article.
407 (goto-char (+ (point) bytes)) 413 (goto-char (point-min))
408 (delete-region (point) (point-max)) 414 (unless (looking-at "\\* [0-9]+ FETCH")
409 (nnheader-ms-strip-cr)) 415 (setq result nil))
410 (cons group article)))))))) 416 (when result
417 (goto-char (point-min))
418 (let ((bytes (nnimap-get-length)))
419 (delete-region (line-beginning-position)
420 (progn (forward-line 1) (point)))
421 (goto-char (+ (point) bytes))
422 (delete-region (point) (point-max)))
423 t)))
424
425(defun nnimap-ver4-p ()
426 (member "IMAP4REV1" (nnimap-capabilities nnimap-object)))
427
428(defun nnimap-get-partial-article (article parts structure)
429 (let ((result
430 (nnimap-command
431 "UID FETCH %d (%s %s)"
432 article
433 (if (nnimap-ver4-p)
434 "BODY.PEEK[HEADER]"
435 "RFC822.HEADER")
436 (if (nnimap-ver4-p)
437 (mapconcat (lambda (part)
438 (format "BODY.PEEK[%s]" part))
439 parts " ")
440 (mapconcat (lambda (part)
441 (format "RFC822.PEEK[%s]" part))
442 parts " ")))))
443 (when result
444 (nnimap-convert-partial-article structure))))
445
446(defun nnimap-convert-partial-article (structure)
447 ;; First just skip past the headers.
448 (goto-char (point-min))
449 (let ((bytes (nnimap-get-length))
450 id parts)
451 ;; Delete "FETCH" line.
452 (delete-region (line-beginning-position)
453 (progn (forward-line 1) (point)))
454 (goto-char (+ (point) bytes))
455 ;; Collect all the body parts.
456 (while (looking-at ".*BODY\\[\\([.0-9]+\\)\\]")
457 (setq id (match-string 1)
458 bytes (nnimap-get-length))
459 (beginning-of-line)
460 (delete-region (point) (progn (forward-line 1) (point)))
461 (push (list id (buffer-substring (point) (+ (point) bytes)))
462 parts)
463 (delete-region (point) (+ (point) bytes)))
464 ;; Delete trailing junk.
465 (delete-region (point) (point-max))
466 ;; Now insert all the parts again where they fit in the structure.
467 (nnimap-insert-partial-structure structure parts)
468 t))
469
470(defun nnimap-insert-partial-structure (structure parts &optional subp)
471 (let ((type (car (last structure 4)))
472 (boundary (cadr (member "BOUNDARY" (car (last structure 3))))))
473 (when subp
474 (insert (format "Content-type: multipart/%s; boundary=%S\n\n"
475 (downcase type) boundary)))
476 (while (not (stringp (car structure)))
477 (insert "\n--" boundary "\n")
478 (if (consp (caar structure))
479 (nnimap-insert-partial-structure (pop structure) parts t)
480 (let ((bit (pop structure)))
481 (insert (format "Content-type: %s/%s"
482 (downcase (nth 0 bit))
483 (downcase (nth 1 bit))))
484 (if (member "CHARSET" (nth 2 bit))
485 (insert (format
486 "; charset=%S\n" (cadr (member "CHARSET" (nth 2 bit)))))
487 (insert "\n"))
488 (insert (format "Content-transfer-encoding: %s\n"
489 (nth 5 bit)))
490 (insert "\n")
491 (when (assoc (nth 9 bit) parts)
492 (insert (cadr (assoc (nth 9 bit) parts)))))))
493 (insert "\n--" boundary "--\n")))
411 494
412(defun nnimap-find-wanted-parts (structure) 495(defun nnimap-find-wanted-parts (structure)
413 (message-flatten-list (nnimap-find-wanted-parts-1 structure ""))) 496 (message-flatten-list (nnimap-find-wanted-parts-1 structure "")))
@@ -423,13 +506,14 @@ not done by default on servers that doesn't support that command.")
423 (number-to-string num) 506 (number-to-string num)
424 (format "%s.%s" prefix num))) 507 (format "%s.%s" prefix num)))
425 parts) 508 parts)
426 (let ((type (format "%s/%s" (nth 0 sub) (nth 1 sub)))) 509 (let ((type (format "%s/%s" (nth 0 sub) (nth 1 sub)))
427 (when (string-match nnimap-fetch-partial-articles type) 510 (id (if (string= prefix "")
428 (push (if (string= prefix "")
429 (number-to-string num) 511 (number-to-string num)
430 (format "%s.%s" prefix num)) 512 (format "%s.%s" prefix num))))
431 parts))) 513 (setcar (nthcdr 9 sub) id)
432 (incf num)))) 514 (when (string-match gnus-fetch-partial-articles type)
515 (push id parts))))
516 (incf num)))
433 (nreverse parts))) 517 (nreverse parts)))
434 518
435(deffoo nnimap-request-group (group &optional server dont-check info) 519(deffoo nnimap-request-group (group &optional server dont-check info)
@@ -777,7 +861,12 @@ not done by default on servers that doesn't support that command.")
777 (nnimap-send-command "UID FETCH %d:* FLAGS" start) 861 (nnimap-send-command "UID FETCH %d:* FLAGS" start)
778 start 862 start
779 (car elem)) 863 (car elem))
780 sequences)))) 864 sequences)))
865 ;; Some servers apparently can't have many outstanding
866 ;; commands, so throttle them.
867 (when (and (not nnimap-streaming)
868 (car sequences))
869 (nnimap-wait-for-response (caar sequences))))
781 sequences)))) 870 sequences))))
782 871
783(deffoo nnimap-finish-retrieve-group-infos (server infos sequences) 872(deffoo nnimap-finish-retrieve-group-infos (server infos sequences)
@@ -785,26 +874,26 @@ not done by default on servers that doesn't support that command.")
785 (nnimap-possibly-change-group nil server)) 874 (nnimap-possibly-change-group nil server))
786 (with-current-buffer (nnimap-buffer) 875 (with-current-buffer (nnimap-buffer)
787 ;; Wait for the final data to trickle in. 876 ;; Wait for the final data to trickle in.
788 (nnimap-wait-for-response (cadar sequences)) 877 (when (nnimap-wait-for-response (cadar sequences))
789 ;; Now we should have all the data we need, no matter whether 878 ;; Now we should have all the data we need, no matter whether
790 ;; we're QRESYNCING, fetching all the flags from scratch, or 879 ;; we're QRESYNCING, fetching all the flags from scratch, or
791 ;; just fetching the last 100 flags per group. 880 ;; just fetching the last 100 flags per group.
792 (nnimap-update-infos (nnimap-flags-to-marks 881 (nnimap-update-infos (nnimap-flags-to-marks
793 (nnimap-parse-flags 882 (nnimap-parse-flags
794 (nreverse sequences))) 883 (nreverse sequences)))
795 infos) 884 infos)
796 ;; Finally, just return something resembling an active file in 885 ;; Finally, just return something resembling an active file in
797 ;; the nntp buffer, so that the agent can save the info, too. 886 ;; the nntp buffer, so that the agent can save the info, too.
798 (with-current-buffer nntp-server-buffer 887 (with-current-buffer nntp-server-buffer
799 (erase-buffer) 888 (erase-buffer)
800 (dolist (info infos) 889 (dolist (info infos)
801 (let* ((group (gnus-info-group info)) 890 (let* ((group (gnus-info-group info))
802 (active (gnus-active group))) 891 (active (gnus-active group)))
803 (when active 892 (when active
804 (insert (format "%S %d %d y\n" 893 (insert (format "%S %d %d y\n"
805 (gnus-group-real-name group) 894 (gnus-group-real-name group)
806 (cdr active) 895 (cdr active)
807 (car active)))))))))) 896 (car active)))))))))))
808 897
809(defun nnimap-update-infos (flags infos) 898(defun nnimap-update-infos (flags infos)
810 (dolist (info infos) 899 (dolist (info infos)
@@ -1045,17 +1134,22 @@ not done by default on servers that doesn't support that command.")
1045 (match-string 1)))) 1134 (match-string 1))))
1046 1135
1047(defun nnimap-wait-for-response (sequence &optional messagep) 1136(defun nnimap-wait-for-response (sequence &optional messagep)
1048 (let ((process (get-buffer-process (current-buffer)))) 1137 (let ((process (get-buffer-process (current-buffer)))
1138 openp)
1049 (goto-char (point-max)) 1139 (goto-char (point-max))
1050 (while (and (memq (process-status process) 1140 (while (and (setq openp (memq (process-status process)
1051 '(open run)) 1141 '(open run)))
1052 (not (re-search-backward (format "^%d .*\n" sequence) 1142 (not (re-search-backward
1053 (max (point-min) (- (point) 500)) 1143 (format "^%d .*\n" sequence)
1054 t))) 1144 (if nnimap-streaming
1145 (max (point-min) (- (point) 500))
1146 (point-min))
1147 t)))
1055 (when messagep 1148 (when messagep
1056 (message "Read %dKB" (/ (buffer-size) 1000))) 1149 (message "Read %dKB" (/ (buffer-size) 1000)))
1057 (nnheader-accept-process-output process) 1150 (nnheader-accept-process-output process)
1058 (goto-char (point-max))))) 1151 (goto-char (point-max)))
1152 openp))
1059 1153
1060(defun nnimap-parse-response () 1154(defun nnimap-parse-response ()
1061 (let ((lines (split-string (nnimap-last-response-string) "\r\n" t)) 1155 (let ((lines (split-string (nnimap-last-response-string) "\r\n" t))
@@ -1129,8 +1223,7 @@ not done by default on servers that doesn't support that command.")
1129 (nnimap-article-ranges articles) 1223 (nnimap-article-ranges articles)
1130 (format "(UID %s%s)" 1224 (format "(UID %s%s)"
1131 (format 1225 (format
1132 (if (member "IMAP4REV1" 1226 (if (nnimap-ver4-p)
1133 (nnimap-capabilities nnimap-object))
1134 "BODY.PEEK[HEADER] BODY.PEEK" 1227 "BODY.PEEK[HEADER] BODY.PEEK"
1135 "RFC822.PEEK")) 1228 "RFC822.PEEK"))
1136 (if nnimap-split-download-body-default 1229 (if nnimap-split-download-body-default
generated by cgit v1.2.1 (git 2.18.0) at 2026-04-16 18:26:46 +0000