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.
This commit is contained in:
Gnus developers
Katsumi Yamaoka
parent
83e245c490
commit
8ccbef23ea
21 changed files with 587 additions and 2500 deletions
|
|
@ -246,6 +246,16 @@ of the "Whomever writes:" line. You need to set
|
|||
@code{message-insert-formatted-citation-line} as well.
|
||||
@end itemize
|
||||
|
||||
@item Changes in Browse Server mode
|
||||
|
||||
@itemize @bullet
|
||||
@item Gnus' sophisticated subscription methods are now available in
|
||||
Browse Server buffers as well using the variable
|
||||
@code{gnus-browse-subscribe-newsgroup-method}.
|
||||
|
||||
@end itemize
|
||||
|
||||
|
||||
@item Changes in back ends
|
||||
|
||||
@itemize @bullet
|
||||
|
|
@ -336,6 +346,8 @@ be unchanged except that the marks will be removed when copying or
|
|||
moving articles to a group that has not turned auto-expire on.
|
||||
@xref{Expiring Mail}.
|
||||
|
||||
@item NoCeM support has been removed.
|
||||
|
||||
@end itemize
|
||||
|
||||
@end itemize
|
||||
|
|
|
|||
1107
doc/misc/gnus.texi
1107
doc/misc/gnus.texi
File diff suppressed because it is too large
Load diff
|
|
@ -1,230 +0,0 @@
|
|||
;;; earcon.el --- Sound effects for messages
|
||||
|
||||
;; Copyright (C) 1996, 2000, 2001, 2002, 2003, 2004,
|
||||
;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: Steven L. Baur <steve@miranova.com>
|
||||
|
||||
;; This file is part of GNU Emacs.
|
||||
|
||||
;; GNU Emacs is free software: you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; GNU Emacs is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Commentary:
|
||||
;; This file provides access to sound effects in Gnus.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(eval-when-compile (require 'cl))
|
||||
(require 'gnus)
|
||||
(require 'gnus-audio)
|
||||
(require 'gnus-art)
|
||||
|
||||
(defgroup earcon nil
|
||||
"Turn ** sounds ** into noise."
|
||||
:group 'gnus-visual)
|
||||
|
||||
(defcustom earcon-prefix "**"
|
||||
"*String denoting the start of an earcon."
|
||||
:type 'string
|
||||
:group 'earcon)
|
||||
|
||||
(defcustom earcon-suffix "**"
|
||||
"String denoting the end of an earcon."
|
||||
:type 'string
|
||||
:group 'earcon)
|
||||
|
||||
(defcustom earcon-regexp-alist
|
||||
'(("boring" 1 "Boring.au")
|
||||
("evil[ \t]+laugh" 1 "Evil_Laugh.au")
|
||||
("gag\\|puke" 1 "Puke.au")
|
||||
("snicker" 1 "Snicker.au")
|
||||
("meow" 1 "catmeow.wav")
|
||||
("sob\\|boohoo" 1 "cry.wav")
|
||||
("drum[ \t]*roll" 1 "drumroll.au")
|
||||
("blast" 1 "explosion.au")
|
||||
("flush\\|plonk!*" 1 "flush.au")
|
||||
("kiss" 1 "kiss.wav")
|
||||
("tee[ \t]*hee" 1 "laugh.au")
|
||||
("shoot" 1 "shotgun.wav")
|
||||
("yawn" 1 "snore.wav")
|
||||
("cackle" 1 "witch.au")
|
||||
("yell\\|roar" 1 "yell2.au")
|
||||
("whoop-de-doo" 1 "whistle.au"))
|
||||
"*A list of regexps to map earcons to real sounds."
|
||||
:type '(repeat (list regexp
|
||||
(integer :tag "Match")
|
||||
(string :tag "Sound")))
|
||||
:group 'earcon)
|
||||
(defvar earcon-button-marker-list nil)
|
||||
(make-variable-buffer-local 'earcon-button-marker-list)
|
||||
|
||||
;;; FIXME!! clone of code from gnus-vis.el FIXME!!
|
||||
(defun earcon-article-push-button (event)
|
||||
"Check text under the mouse pointer for a callback function.
|
||||
If the text under the mouse pointer has a `earcon-callback' property,
|
||||
call it with the value of the `earcon-data' text property."
|
||||
(interactive "e")
|
||||
(set-buffer (window-buffer (posn-window (event-start event))))
|
||||
(let* ((pos (posn-point (event-start event)))
|
||||
(data (get-text-property pos 'earcon-data))
|
||||
(fun (get-text-property pos 'earcon-callback)))
|
||||
(if fun (funcall fun data))))
|
||||
|
||||
(defun earcon-article-press-button ()
|
||||
"Check text at point for a callback function.
|
||||
If the text at point has a `earcon-callback' property,
|
||||
call it with the value of the `earcon-data' text property."
|
||||
(interactive)
|
||||
(let* ((data (get-text-property (point) 'earcon-data))
|
||||
(fun (get-text-property (point) 'earcon-callback)))
|
||||
(if fun (funcall fun data))))
|
||||
|
||||
(defun earcon-article-prev-button (n)
|
||||
"Move point to N buttons backward.
|
||||
If N is negative, move forward instead."
|
||||
(interactive "p")
|
||||
(earcon-article-next-button (- n)))
|
||||
|
||||
(defun earcon-article-next-button (n)
|
||||
"Move point to N buttons forward.
|
||||
If N is negative, move backward instead."
|
||||
(interactive "p")
|
||||
(let ((function (if (< n 0) 'previous-single-property-change
|
||||
'next-single-property-change))
|
||||
(inhibit-point-motion-hooks t)
|
||||
(backward (< n 0))
|
||||
(limit (if (< n 0) (point-min) (point-max))))
|
||||
(setq n (abs n))
|
||||
(while (and (not (= limit (point)))
|
||||
(> n 0))
|
||||
;; Skip past the current button.
|
||||
(when (get-text-property (point) 'earcon-callback)
|
||||
(goto-char (funcall function (point) 'earcon-callback nil limit)))
|
||||
;; Go to the next (or previous) button.
|
||||
(gnus-goto-char (funcall function (point) 'earcon-callback nil limit))
|
||||
;; Put point at the start of the button.
|
||||
(when (and backward (not (get-text-property (point) 'earcon-callback)))
|
||||
(goto-char (funcall function (point) 'earcon-callback nil limit)))
|
||||
;; Skip past intangible buttons.
|
||||
(when (get-text-property (point) 'intangible)
|
||||
(incf n))
|
||||
(decf n))
|
||||
(unless (zerop n)
|
||||
(gnus-message 5 "No more buttons"))
|
||||
n))
|
||||
|
||||
(defun earcon-article-add-button (from to fun &optional data)
|
||||
"Create a button between FROM and TO with callback FUN and data DATA."
|
||||
(and (boundp gnus-article-button-face)
|
||||
gnus-article-button-face
|
||||
(gnus-overlay-put (gnus-make-overlay from to)
|
||||
'face gnus-article-button-face))
|
||||
(gnus-add-text-properties
|
||||
from to
|
||||
(nconc (and gnus-article-mouse-face
|
||||
(list gnus-mouse-face-prop gnus-article-mouse-face))
|
||||
(list 'gnus-callback fun)
|
||||
(and data (list 'gnus-data data)))))
|
||||
|
||||
(defun earcon-button-entry ()
|
||||
;; Return the first entry in `gnus-button-alist' matching this place.
|
||||
(let ((alist earcon-regexp-alist)
|
||||
(case-fold-search t)
|
||||
(entry nil))
|
||||
(while alist
|
||||
(setq entry (pop alist))
|
||||
(if (looking-at (car entry))
|
||||
(setq alist nil)
|
||||
(setq entry nil)))
|
||||
entry))
|
||||
|
||||
(defun earcon-button-push (marker)
|
||||
;; Push button starting at MARKER.
|
||||
(with-current-buffer gnus-article-buffer
|
||||
(goto-char marker)
|
||||
(let* ((entry (earcon-button-entry))
|
||||
(inhibit-point-motion-hooks t)
|
||||
(fun 'gnus-audio-play)
|
||||
(args (list (nth 2 entry))))
|
||||
(cond
|
||||
((fboundp fun)
|
||||
(apply fun args))
|
||||
((and (boundp fun)
|
||||
(fboundp (symbol-value fun)))
|
||||
(apply (symbol-value fun) args))
|
||||
(t
|
||||
(gnus-message 1 "You must define `%S' to use this button"
|
||||
(cons fun args)))))))
|
||||
|
||||
;;; FIXME!! clone of code from gnus-vis.el FIXME!!
|
||||
|
||||
;;;###interactive
|
||||
(defun earcon-region (beg end)
|
||||
"Play Sounds in the region between point and mark."
|
||||
(interactive "r")
|
||||
(earcon-buffer (current-buffer) beg end))
|
||||
|
||||
;;;###interactive
|
||||
(defun earcon-buffer (&optional buffer st nd)
|
||||
(interactive)
|
||||
(save-excursion
|
||||
;; clear old markers.
|
||||
(if (boundp 'earcon-button-marker-list)
|
||||
(while earcon-button-marker-list
|
||||
(set-marker (pop earcon-button-marker-list) nil))
|
||||
(setq earcon-button-marker-list nil))
|
||||
(and buffer (set-buffer buffer))
|
||||
(let ((buffer-read-only nil)
|
||||
(inhibit-point-motion-hooks t)
|
||||
(case-fold-search t)
|
||||
(alist earcon-regexp-alist)
|
||||
beg entry regexp)
|
||||
(goto-char (point-min))
|
||||
(setq beg (point))
|
||||
(while (setq entry (pop alist))
|
||||
(setq regexp (concat (regexp-quote earcon-prefix)
|
||||
".*\\("
|
||||
(car entry)
|
||||
"\\).*"
|
||||
(regexp-quote earcon-suffix)))
|
||||
(goto-char beg)
|
||||
(while (re-search-forward regexp nil t)
|
||||
(let* ((start (and entry (match-beginning 1)))
|
||||
(end (and entry (match-end 1)))
|
||||
(from (match-beginning 1)))
|
||||
(earcon-article-add-button
|
||||
start end 'earcon-button-push
|
||||
(car (push (set-marker (make-marker) from)
|
||||
earcon-button-marker-list)))
|
||||
(gnus-audio-play (caddr entry))))))))
|
||||
|
||||
;;;###autoload
|
||||
(defun gnus-earcon-display ()
|
||||
"Play sounds in message buffers."
|
||||
(interactive)
|
||||
(with-current-buffer gnus-article-buffer
|
||||
(goto-char (point-min))
|
||||
;; Skip headers
|
||||
(unless (search-forward "\n\n" nil t)
|
||||
(goto-char (point-max)))
|
||||
(sit-for 0)
|
||||
(earcon-buffer (current-buffer) (point))))
|
||||
|
||||
;;;***
|
||||
|
||||
(provide 'earcon)
|
||||
|
||||
(run-hooks 'earcon-load-hook)
|
||||
|
||||
;;; earcon.el ends here
|
||||
|
|
@ -257,6 +257,22 @@ This can also be a list of the above values."
|
|||
(regexp :value ".*"))
|
||||
:group 'gnus-article-signature)
|
||||
|
||||
(defcustom gnus-fetch-partial-articles nil
|
||||
"If non-nil, Gnus will fetch partial articles.
|
||||
If t, nnimap will fetch only the first part. If a string, it
|
||||
will fetch all parts that have types that match that string. A
|
||||
likely value would be \"text/\" to automatically fetch all
|
||||
textual parts.
|
||||
|
||||
Currently only the nnimap backend actually supports partial
|
||||
article fetching. If the backend doesn't support it, it has no
|
||||
effect."
|
||||
:version "24.1"
|
||||
:type '(choice (const nil)
|
||||
(const t)
|
||||
(regexp))
|
||||
:group 'gnus-article)
|
||||
|
||||
(defcustom gnus-hidden-properties '(invisible t intangible t)
|
||||
"Property list to use for hiding text."
|
||||
:type 'sexp
|
||||
|
|
@ -1598,15 +1614,6 @@ predicate. See Info node `(gnus)Customizing Articles'."
|
|||
:link '(custom-manual "(gnus)Customizing Articles")
|
||||
:type gnus-article-treat-custom)
|
||||
|
||||
(defcustom gnus-treat-play-sounds nil
|
||||
"Play sounds.
|
||||
Valid values are nil, t, `head', `first', `last', an integer or a
|
||||
predicate. See Info node `(gnus)Customizing Articles'."
|
||||
:version "21.1"
|
||||
:group 'gnus-article-treat
|
||||
:link '(custom-manual "(gnus)Customizing Articles")
|
||||
:type gnus-article-treat-custom)
|
||||
|
||||
(defcustom gnus-treat-x-pgp-sig nil
|
||||
"Verify X-PGP-Sig.
|
||||
To 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."
|
|||
(gnus-treat-hide-citation gnus-article-hide-citation)
|
||||
(gnus-treat-hide-citation-maybe gnus-article-hide-citation-maybe)
|
||||
(gnus-treat-highlight-citation gnus-article-highlight-citation)
|
||||
(gnus-treat-body-boundary gnus-article-treat-body-boundary)
|
||||
(gnus-treat-play-sounds gnus-earcon-display)))
|
||||
(gnus-treat-body-boundary gnus-article-treat-body-boundary)))
|
||||
|
||||
(defvar gnus-article-mime-handle-alist nil)
|
||||
(defvar article-lapsed-timer nil)
|
||||
|
|
@ -5075,7 +5081,10 @@ Deleting parts may malfunction or destroy the article; continue? "))
|
|||
"|\n"
|
||||
"| Type: " type "\n"
|
||||
"| Filename: " filename "\n"
|
||||
"| Size (encoded): " bsize " Byte\n"
|
||||
"| Size (encoded): " bsize (format " byte%s\n"
|
||||
(if (= bsize 1)
|
||||
""
|
||||
"s"))
|
||||
(when description
|
||||
(concat "| Description: " description "\n"))
|
||||
"`----\n"))
|
||||
|
|
@ -7030,9 +7039,7 @@ groups."
|
|||
(gnus-backlog-remove-article
|
||||
(car gnus-article-current) (cdr gnus-article-current)))
|
||||
;; Flush original article as well.
|
||||
(when (get-buffer gnus-original-article-buffer)
|
||||
(with-current-buffer gnus-original-article-buffer
|
||||
(setq gnus-original-article nil)))
|
||||
(gnus-flush-original-article-buffer)
|
||||
(when gnus-use-cache
|
||||
(gnus-cache-update-article
|
||||
(car gnus-article-current) (cdr gnus-article-current)))
|
||||
|
|
@ -7046,6 +7053,11 @@ groups."
|
|||
(set-window-point (get-buffer-window buf) (point)))
|
||||
(gnus-summary-show-article))
|
||||
|
||||
(defun gnus-flush-original-article-buffer ()
|
||||
(when (get-buffer gnus-original-article-buffer)
|
||||
(with-current-buffer gnus-original-article-buffer
|
||||
(setq gnus-original-article nil))))
|
||||
|
||||
(defun gnus-article-edit-exit ()
|
||||
"Exit the article editing without updating."
|
||||
(interactive)
|
||||
|
|
@ -7134,46 +7146,6 @@ man page."
|
|||
(function :tag "Other"))
|
||||
:group 'gnus-article-buttons)
|
||||
|
||||
(defcustom gnus-ctan-url "http://tug.ctan.org/tex-archive/"
|
||||
"Top directory of a CTAN \(Comprehensive TeX Archive Network\) archive.
|
||||
If the default site is too slow, try to find a CTAN mirror, see
|
||||
<URL:http://tug.ctan.org/tex-archive/CTAN.sites?action=/index.html>. See also
|
||||
the variable `gnus-button-handle-ctan'."
|
||||
:version "22.1"
|
||||
:group 'gnus-article-buttons
|
||||
:link '(custom-manual "(gnus)Group Parameters")
|
||||
:type '(choice (const "http://www.tex.ac.uk/tex-archive/")
|
||||
(const "http://tug.ctan.org/tex-archive/")
|
||||
(const "http://www.dante.de/CTAN/")
|
||||
(string :tag "Other")))
|
||||
|
||||
(defcustom gnus-button-ctan-handler 'browse-url
|
||||
"Function to use for displaying CTAN links.
|
||||
The function must take one argument, the string naming the URL."
|
||||
:version "22.1"
|
||||
:type '(choice (function-item :tag "Browse Url" browse-url)
|
||||
(function :tag "Other"))
|
||||
:group 'gnus-article-buttons)
|
||||
|
||||
(defcustom gnus-button-handle-ctan-bogus-regexp "^/?tex-archive/\\|^/"
|
||||
"Bogus strings removed from CTAN URLs."
|
||||
:version "22.1"
|
||||
:group 'gnus-article-buttons
|
||||
:type '(choice (const "^/?tex-archive/\\|/")
|
||||
(regexp :tag "Other")))
|
||||
|
||||
(defcustom gnus-button-ctan-directory-regexp
|
||||
(regexp-opt
|
||||
(list "archive-tools" "biblio" "bibliography" "digests" "documentation"
|
||||
"dviware" "fonts" "graphics" "help" "indexing" "info" "language"
|
||||
"languages" "macros" "nonfree" "obsolete" "support" "systems"
|
||||
"tds" "tools" "usergrps" "web") t)
|
||||
"Regular expression for ctan directories.
|
||||
It should match all directories in the top level of `gnus-ctan-url'."
|
||||
:version "22.1"
|
||||
:group 'gnus-article-buttons
|
||||
:type 'regexp)
|
||||
|
||||
(defcustom gnus-button-mid-or-mail-regexp
|
||||
(concat "\\b\\(<?" gnus-button-valid-localpart-regexp "@"
|
||||
gnus-button-valid-fqdn-regexp
|
||||
|
|
@ -7431,26 +7403,6 @@ Calls `describe-variable' or `describe-function'."
|
|||
(gnus-message 1 "Cannot locale library `%s'." url)
|
||||
(find-file-read-only file))))
|
||||
|
||||
(defun gnus-button-handle-ctan (url)
|
||||
"Call `browse-url' when pushing a CTAN URL button."
|
||||
(funcall
|
||||
gnus-button-ctan-handler
|
||||
(concat
|
||||
gnus-ctan-url
|
||||
(gnus-replace-in-string url gnus-button-handle-ctan-bogus-regexp ""))))
|
||||
|
||||
(defcustom gnus-button-tex-level 5
|
||||
"*Integer that says how many TeX-related buttons Gnus will show.
|
||||
The higher the number, the more buttons will appear and the more false
|
||||
positives are possible. Note that you can set this variable local to
|
||||
specific groups. Setting it higher in TeX groups is probably a good idea.
|
||||
See Info node `(gnus)Group Parameters' and the variable `gnus-parameters' on
|
||||
how to set variables in specific groups."
|
||||
:version "22.1"
|
||||
:group 'gnus-article-buttons
|
||||
:link '(custom-manual "(gnus)Group Parameters")
|
||||
:type 'integer)
|
||||
|
||||
(defcustom gnus-button-man-level 5
|
||||
"*Integer that says how many man-related buttons Gnus will show.
|
||||
The higher the number, the more buttons will appear and the more false
|
||||
|
|
@ -7517,20 +7469,6 @@ positives are possible."
|
|||
0 (>= gnus-button-message-level 0) gnus-url-mailto 1)
|
||||
("\\bmailto:\\([^ \n\t]+\\)"
|
||||
0 (>= gnus-button-message-level 0) gnus-url-mailto 1)
|
||||
;; CTAN
|
||||
((concat "\\bCTAN:[ \t\n]?[^>)!;:,'\n\t ]*\\("
|
||||
gnus-button-ctan-directory-regexp
|
||||
"[^][>)!;:,'\n\t ]+\\)")
|
||||
0 (>= gnus-button-tex-level 1) gnus-button-handle-ctan 1)
|
||||
((concat "\\btex-archive/\\("
|
||||
gnus-button-ctan-directory-regexp
|
||||
"/[-_.a-z0-9/]+[-_./a-z0-9]+[/a-z0-9]\\)")
|
||||
1 (>= gnus-button-tex-level 6) gnus-button-handle-ctan 1)
|
||||
((concat
|
||||
"\\b\\("
|
||||
gnus-button-ctan-directory-regexp
|
||||
"/[-_.a-z0-9]+/[-_./a-z0-9]+[/a-z0-9]\\)")
|
||||
1 (>= gnus-button-tex-level 8) gnus-button-handle-ctan 1)
|
||||
;; Info Konqueror style <info:/foo/bar baz>.
|
||||
;; Must come before " Gnus home-grown style".
|
||||
("\\binfo://?\\([^'\">\n\t]+\\)"
|
||||
|
|
@ -8512,9 +8450,7 @@ For example:
|
|||
(when gnus-keep-backlog
|
||||
(gnus-backlog-remove-article
|
||||
(car gnus-article-current) (cdr gnus-article-current)))
|
||||
(when (get-buffer gnus-original-article-buffer)
|
||||
(with-current-buffer gnus-original-article-buffer
|
||||
(setq gnus-original-article nil)))
|
||||
(gnus-flush-original-article-buffer)
|
||||
(when gnus-use-cache
|
||||
(gnus-cache-update-article
|
||||
(car gnus-article-current) (cdr gnus-article-current))))))))
|
||||
|
|
|
|||
|
|
@ -1,149 +0,0 @@
|
|||
;;; gnus-audio.el --- Sound effects for Gnus
|
||||
|
||||
;; Copyright (C) 1996, 2000, 2001, 2002, 2003, 2004,
|
||||
;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: Steven L. Baur <steve@miranova.com>
|
||||
;; Keywords: news, mail, multimedia
|
||||
|
||||
;; This file is part of GNU Emacs.
|
||||
|
||||
;; GNU Emacs is free software: you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; GNU Emacs is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; This file provides access to sound effects in Gnus.
|
||||
;; This file is partially stripped to support earcons.el.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'nnheader)
|
||||
|
||||
(defgroup gnus-audio nil
|
||||
"Playing sound in Gnus."
|
||||
:version "21.1"
|
||||
:group 'gnus-visual
|
||||
:group 'multimedia)
|
||||
|
||||
(defvar gnus-audio-inline-sound
|
||||
(or (if (fboundp 'device-sound-enabled-p)
|
||||
(device-sound-enabled-p)) ; XEmacs
|
||||
(fboundp 'play-sound)) ; Emacs
|
||||
"Non-nil means try to play sounds without using an external program.")
|
||||
|
||||
(defcustom gnus-audio-directory (nnheader-find-etc-directory "sounds")
|
||||
"The directory containing the Sound Files."
|
||||
:type '(choice directory (const nil))
|
||||
:group 'gnus-audio)
|
||||
|
||||
(defcustom gnus-audio-au-player (executable-find "play")
|
||||
"Executable program for playing sun AU format sound files."
|
||||
:group 'gnus-audio
|
||||
:type '(choice file (const nil)))
|
||||
|
||||
(defcustom gnus-audio-wav-player (executable-find "play")
|
||||
"Executable program for playing WAV files."
|
||||
:group 'gnus-audio
|
||||
:type '(choice file (const nil)))
|
||||
|
||||
;;; The following isn't implemented yet. Wait for Millennium Gnus.
|
||||
;;(defvar gnus-audio-effects-enabled t
|
||||
;; "When t, Gnus will use sound effects.")
|
||||
;;(defvar gnus-audio-enable-hooks nil
|
||||
;; "Functions run when enabling sound effects.")
|
||||
;;(defvar gnus-audio-disable-hooks nil
|
||||
;; "Functions run when disabling sound effects.")
|
||||
;;(defvar gnus-audio-theme-song nil
|
||||
;; "Theme song for Gnus.")
|
||||
;;(defvar gnus-audio-enter-group nil
|
||||
;; "Sound effect played when selecting a group.")
|
||||
;;(defvar gnus-audio-exit-group nil
|
||||
;; "Sound effect played when exiting a group.")
|
||||
;;(defvar gnus-audio-score-group nil
|
||||
;; "Sound effect played when scoring a group.")
|
||||
;;(defvar gnus-audio-busy-sound nil
|
||||
;; "Sound effect played when going into a ... sequence.")
|
||||
|
||||
|
||||
;;;###autoload
|
||||
;;(defun gnus-audio-enable-sound ()
|
||||
;; "Enable Sound Effects for Gnus."
|
||||
;; (interactive)
|
||||
;; (setq gnus-audio-effects-enabled t)
|
||||
;; (gnus-run-hooks gnus-audio-enable-hooks))
|
||||
|
||||
;;;###autoload
|
||||
;(defun gnus-audio-disable-sound ()
|
||||
;; "Disable Sound Effects for Gnus."
|
||||
;; (interactive)
|
||||
;; (setq gnus-audio-effects-enabled nil)
|
||||
;; (gnus-run-hooks gnus-audio-disable-hooks))
|
||||
|
||||
;;;###autoload
|
||||
(defun gnus-audio-play (file)
|
||||
"Play a sound FILE through the speaker."
|
||||
(interactive "fSound file name: ")
|
||||
(let ((sound-file (if (file-exists-p file)
|
||||
file
|
||||
(expand-file-name file gnus-audio-directory))))
|
||||
(when (file-exists-p sound-file)
|
||||
(cond ((and gnus-audio-inline-sound
|
||||
(condition-case nil
|
||||
;; Even if we have audio, we may fail with the
|
||||
;; wrong sort of sound file.
|
||||
(progn (play-sound-file sound-file)
|
||||
t)
|
||||
(error nil))))
|
||||
;; If we don't have built-in sound, or playing it failed,
|
||||
;; try with external program.
|
||||
((equal "wav" (file-name-extension sound-file))
|
||||
(call-process gnus-audio-wav-player
|
||||
sound-file
|
||||
0
|
||||
nil
|
||||
sound-file))
|
||||
((equal "au" (file-name-extension sound-file))
|
||||
(call-process gnus-audio-au-player
|
||||
sound-file
|
||||
0
|
||||
nil
|
||||
sound-file))))))
|
||||
|
||||
|
||||
;;; The following isn't implemented yet, wait for Red Gnus
|
||||
;;(defun gnus-audio-startrek-sounds ()
|
||||
;; "Enable sounds from Star Trek the original series."
|
||||
;; (interactive)
|
||||
;; (setq gnus-audio-busy-sound "working.au")
|
||||
;; (setq gnus-audio-enter-group "bulkhead_door.au")
|
||||
;; (setq gnus-audio-exit-group "bulkhead_door.au")
|
||||
;; (setq gnus-audio-score-group "ST_laser.au")
|
||||
;; (setq gnus-audio-theme-song "startrek.au")
|
||||
;; (add-hook 'gnus-select-group-hook 'gnus-audio-startrek-select-group)
|
||||
;; (add-hook 'gnus-exit-group-hook 'gnus-audio-startrek-exit-group))
|
||||
;;;***
|
||||
|
||||
(defvar gnus-startup-jingle "Tuxedomoon.Jingle4.au"
|
||||
"Name of the Gnus startup jingle file.")
|
||||
|
||||
(defun gnus-play-jingle ()
|
||||
"Play the Gnus startup jingle, unless that's inhibited."
|
||||
(interactive)
|
||||
(gnus-audio-play gnus-startup-jingle))
|
||||
|
||||
(provide 'gnus-audio)
|
||||
|
||||
(run-hooks 'gnus-audio-load-hook)
|
||||
|
||||
;;; gnus-audio.el ends here
|
||||
|
|
@ -865,11 +865,6 @@ This can be changed using the `\\[gnus-score-change-score-file]' command."
|
|||
Check the [ ] for the entries you want to apply to this score file, then
|
||||
edit the value to suit your taste. Don't forget to mark the checkbox,
|
||||
if you do all your changes will be lost. ")
|
||||
(widget-create 'push-button
|
||||
:action (lambda (&rest ignore)
|
||||
(require 'gnus-audio)
|
||||
(gnus-audio-play "Evil_Laugh.au"))
|
||||
"Bhahahah!")
|
||||
(widget-insert "\n\n")
|
||||
(make-local-variable 'gnus-custom-scores)
|
||||
(setq gnus-custom-scores
|
||||
|
|
|
|||
|
|
@ -240,15 +240,6 @@ time Emacs has been idle for IDLE `gnus-demon-timestep's."
|
|||
;; this idle-cycle.
|
||||
(push (car handler) gnus-demon-idle-has-been-called)))))))))
|
||||
|
||||
(defun gnus-demon-add-nocem ()
|
||||
"Add daemonic NoCeM handling to Gnus."
|
||||
(gnus-demon-add-handler 'gnus-demon-scan-nocem 60 30))
|
||||
|
||||
(defun gnus-demon-scan-nocem ()
|
||||
"Scan NoCeM groups for NoCeM messages."
|
||||
(save-window-excursion
|
||||
(gnus-nocem-scan-groups)))
|
||||
|
||||
(defun gnus-demon-add-disconnection ()
|
||||
"Add daemonic server disconnection to Gnus."
|
||||
(gnus-demon-add-handler 'gnus-demon-close-connections nil 30))
|
||||
|
|
|
|||
|
|
@ -2418,6 +2418,14 @@ the bug number, and browsing the URL must return mbox output."
|
|||
(let ((tmpfile (mm-make-temp-file "gnus-temp-group-")))
|
||||
(with-temp-file tmpfile
|
||||
(url-insert-file-contents (format mbox-url number))
|
||||
(goto-char (point-min))
|
||||
;; Add the debbugs address so that we can respond to reports easily.
|
||||
(while (re-search-forward "^To: " nil t)
|
||||
(end-of-line)
|
||||
(insert (format ", %s@%s" number
|
||||
(replace-regexp-in-string
|
||||
"/.*$" ""
|
||||
(replace-regexp-in-string "^http://" "" mbox-url)))))
|
||||
(write-region (point-min) (point-max) tmpfile)
|
||||
(gnus-group-read-ephemeral-group
|
||||
"gnus-read-ephemeral-bug"
|
||||
|
|
@ -3946,14 +3954,6 @@ re-scanning. If ARG is non-nil and not a number, this will force
|
|||
(unless gnus-slave
|
||||
(gnus-master-read-slave-newsrc))
|
||||
|
||||
;; We might read in new NoCeM messages here.
|
||||
(when (and gnus-use-nocem
|
||||
(or (and (numberp gnus-use-nocem)
|
||||
(numberp arg)
|
||||
(>= arg gnus-use-nocem))
|
||||
(not arg)))
|
||||
(gnus-nocem-scan-groups))
|
||||
|
||||
(gnus-get-unread-articles arg)
|
||||
|
||||
;; If the user wants it, we scan for new groups.
|
||||
|
|
|
|||
|
|
@ -104,7 +104,12 @@ CHARS is a regexp-like character alternative (e.g., \"[)$]\")."
|
|||
(match-string 0 encoded-text)))
|
||||
t t encoded-text)
|
||||
s (1+ s)))
|
||||
encoded-text)))))
|
||||
encoded-text))))
|
||||
;; XEmacs does not have window-inside-pixel-edges
|
||||
(defalias 'gnus-window-inside-pixel-edges
|
||||
(if (fboundp 'window-inside-pixel-edges)
|
||||
'window-inside-pixel-edges
|
||||
'window-pixel-edges)))
|
||||
|
||||
(defun gnus-html-encode-url (url)
|
||||
"Encode URL."
|
||||
|
|
@ -450,7 +455,7 @@ Return a string with image data."
|
|||
image
|
||||
(let* ((width (car size))
|
||||
(height (cdr size))
|
||||
(edges (window-pixel-edges (get-buffer-window (current-buffer))))
|
||||
(edges (gnus-window-inside-pixel-edges (get-buffer-window (current-buffer))))
|
||||
(window-width (truncate (* gnus-max-image-proportion
|
||||
(- (nth 2 edges) (nth 0 edges)))))
|
||||
(window-height (truncate (* gnus-max-image-proportion
|
||||
|
|
|
|||
|
|
@ -181,10 +181,15 @@ If it is down, start it up (again)."
|
|||
(prog1
|
||||
(setq result (gnus-open-server method))
|
||||
(unless silent
|
||||
(gnus-message 5 "Opening %s server%s...%s" (car method)
|
||||
(if (equal (nth 1 method) "") ""
|
||||
(format " on %s" (nth 1 method)))
|
||||
(if result "done" "failed")))))))
|
||||
(gnus-message
|
||||
(if result 5 3)
|
||||
"Opening %s server%s...%s" (car method)
|
||||
(if (equal (nth 1 method) "") ""
|
||||
(format " on %s" (nth 1 method)))
|
||||
(if result
|
||||
"done"
|
||||
(format "failed: %s"
|
||||
(nnheader-get-report-string (car method))))))))))
|
||||
|
||||
(defun gnus-get-function (method function &optional noerror)
|
||||
"Return a function symbol based on METHOD and FUNCTION."
|
||||
|
|
@ -265,36 +270,31 @@ If it is down, start it up (again)."
|
|||
(setq elem (list gnus-command-method nil)
|
||||
gnus-opened-servers (cons elem gnus-opened-servers)))
|
||||
;; Set the status of this server.
|
||||
(setcar (cdr elem)
|
||||
(cond (result
|
||||
(if (eq open-server-function #'nnagent-open-server)
|
||||
;; The agent's backend has a "special" status
|
||||
'offline
|
||||
'ok))
|
||||
((and gnus-agent
|
||||
(gnus-agent-method-p gnus-command-method))
|
||||
(cond (gnus-server-unopen-status
|
||||
;; Set the server's status to the unopen
|
||||
;; status. If that status is offline,
|
||||
;; recurse to open the agent's backend.
|
||||
(setq open-offline (eq gnus-server-unopen-status 'offline))
|
||||
gnus-server-unopen-status)
|
||||
((and
|
||||
(not gnus-batch-mode)
|
||||
(gnus-y-or-n-p
|
||||
(format
|
||||
"Unable to open server %s (%s), go offline? "
|
||||
server
|
||||
(nnheader-get-report
|
||||
(car gnus-command-method)))))
|
||||
(setq open-offline t)
|
||||
'offline)
|
||||
(t
|
||||
;; This agentized server was still denied
|
||||
'denied)))
|
||||
(t
|
||||
;; This unagentized server must be denied
|
||||
'denied)))
|
||||
(setcar
|
||||
(cdr elem)
|
||||
(cond (result
|
||||
(if (eq open-server-function #'nnagent-open-server)
|
||||
;; The agent's backend has a "special" status
|
||||
'offline
|
||||
'ok))
|
||||
((and gnus-agent
|
||||
(gnus-agent-method-p gnus-command-method))
|
||||
(cond
|
||||
(gnus-server-unopen-status
|
||||
;; Set the server's status to the unopen
|
||||
;; status. If that status is offline,
|
||||
;; recurse to open the agent's backend.
|
||||
(setq open-offline (eq gnus-server-unopen-status 'offline))
|
||||
gnus-server-unopen-status)
|
||||
((not gnus-batch-mode)
|
||||
(setq open-offline t)
|
||||
'offline)
|
||||
(t
|
||||
;; This agentized server was still denied
|
||||
'denied)))
|
||||
(t
|
||||
;; This unagentized server must be denied
|
||||
'denied)))
|
||||
|
||||
;; NOTE: I MUST set the server's status to offline before this
|
||||
;; recursive call as this status will drive the
|
||||
|
|
|
|||
|
|
@ -1,452 +0,0 @@
|
|||
;;; gnus-nocem.el --- NoCeM pseudo-cancellation treatment
|
||||
|
||||
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
|
||||
;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
|
||||
;; Keywords: news
|
||||
|
||||
;; This file is part of GNU Emacs.
|
||||
|
||||
;; GNU Emacs is free software: you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; GNU Emacs is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;;; Code:
|
||||
|
||||
(eval-when-compile (require 'cl))
|
||||
|
||||
(require 'gnus)
|
||||
(require 'nnmail)
|
||||
(require 'gnus-art)
|
||||
(require 'gnus-sum)
|
||||
(require 'gnus-range)
|
||||
|
||||
(defgroup gnus-nocem nil
|
||||
"NoCeM pseudo-cancellation treatment."
|
||||
:group 'gnus-score)
|
||||
|
||||
(defcustom gnus-nocem-groups
|
||||
'("news.lists.filters" "alt.nocem.misc")
|
||||
"*List of groups that will be searched for NoCeM messages."
|
||||
:group 'gnus-nocem
|
||||
:version "23.1"
|
||||
:type '(repeat (string :tag "Group")))
|
||||
|
||||
(defcustom gnus-nocem-issuers
|
||||
'("Adri Verhoef"
|
||||
"alba-nocem@albasani.net"
|
||||
"bleachbot@httrack.com"
|
||||
"news@arcor-online.net"
|
||||
"news@uni-berlin.de"
|
||||
"nocem@arcor.de"
|
||||
"pgpmoose@killfile.org"
|
||||
"xjsppl@gmx.de")
|
||||
"*List of NoCeM issuers to pay attention to.
|
||||
|
||||
This can also be a list of `(ISSUER CONDITION ...)' elements.
|
||||
|
||||
See <URL:http://www.xs4all.nl/~rosalind/nocemreg/nocemreg.html> for an
|
||||
issuer registry."
|
||||
:group 'gnus-nocem
|
||||
:link '(url-link "http://www.xs4all.nl/~rosalind/nocemreg/nocemreg.html")
|
||||
:version "23.1"
|
||||
:type '(repeat (cons :format "%v" (string :tag "Issuer")
|
||||
(repeat :tag "Condition"
|
||||
(group (checklist :inline t (const not))
|
||||
(regexp :tag "Type" :value ".*")))))
|
||||
:get (lambda (symbol)
|
||||
(mapcar (lambda (elem)
|
||||
(if (consp elem)
|
||||
(cons (car elem)
|
||||
(mapcar (lambda (elt)
|
||||
(if (consp elt) elt (list elt)))
|
||||
(cdr elem)))
|
||||
(list elem)))
|
||||
(default-value symbol)))
|
||||
:set (lambda (symbol value)
|
||||
(custom-set-default
|
||||
symbol
|
||||
(mapcar (lambda (elem)
|
||||
(if (consp elem)
|
||||
(if (cdr elem)
|
||||
(mapcar (lambda (elt)
|
||||
(if (consp elt)
|
||||
(if (cdr elt) elt (car elt))
|
||||
elt))
|
||||
elem)
|
||||
(car elem))
|
||||
elem))
|
||||
value))))
|
||||
|
||||
(defcustom gnus-nocem-directory
|
||||
(nnheader-concat gnus-article-save-directory "NoCeM/")
|
||||
"*Directory where NoCeM files will be stored."
|
||||
:group 'gnus-nocem
|
||||
:type 'directory)
|
||||
|
||||
(defcustom gnus-nocem-expiry-wait 15
|
||||
"*Number of days to keep NoCeM headers in the cache."
|
||||
:group 'gnus-nocem
|
||||
:type 'integer)
|
||||
|
||||
(defcustom gnus-nocem-verifyer (if (locate-library "epg")
|
||||
'gnus-nocem-epg-verify
|
||||
'pgg-verify)
|
||||
"*Function called to verify that the NoCeM message is valid.
|
||||
If the function in this variable isn't bound, the message will be used
|
||||
unconditionally."
|
||||
:group 'gnus-nocem
|
||||
:version "23.1"
|
||||
:type '(radio (function-item gnus-nocem-epg-verify)
|
||||
(function-item pgg-verify)
|
||||
(function-item mc-verify)
|
||||
(function :tag "other"))
|
||||
:set (lambda (symbol value)
|
||||
(custom-set-default symbol
|
||||
(if (and (eq value 'gnus-nocem-epg-verify)
|
||||
(not (locate-library "epg")))
|
||||
'pgg-verify
|
||||
value))))
|
||||
|
||||
(defcustom gnus-nocem-liberal-fetch nil
|
||||
"*If t try to fetch all messages which have @@NCM in the subject.
|
||||
Otherwise don't fetch messages which have references or whose message-id
|
||||
matches a previously scanned and verified nocem message."
|
||||
:group 'gnus-nocem
|
||||
:type 'boolean)
|
||||
|
||||
(defcustom gnus-nocem-check-article-limit 500
|
||||
"*If non-nil, the maximum number of articles to check in any NoCeM group."
|
||||
:group 'gnus-nocem
|
||||
:version "21.1"
|
||||
:type '(choice (const :tag "unlimited" nil)
|
||||
(integer 1000)))
|
||||
|
||||
(defcustom gnus-nocem-check-from t
|
||||
"Non-nil means check for valid issuers in message bodies.
|
||||
Otherwise don't bother fetching articles unless their author matches a
|
||||
valid issuer, which is much faster if you are selective about the issuers."
|
||||
:group 'gnus-nocem
|
||||
:version "21.1"
|
||||
:type 'boolean)
|
||||
|
||||
;;; Internal variables
|
||||
|
||||
(defvar gnus-nocem-active nil)
|
||||
(defvar gnus-nocem-alist nil)
|
||||
(defvar gnus-nocem-touched-alist nil)
|
||||
(defvar gnus-nocem-hashtb nil)
|
||||
(defvar gnus-nocem-seen-message-ids nil)
|
||||
|
||||
;;; Functions
|
||||
|
||||
(defun gnus-nocem-active-file ()
|
||||
(concat (file-name-as-directory gnus-nocem-directory) "active"))
|
||||
|
||||
(defun gnus-nocem-cache-file ()
|
||||
(concat (file-name-as-directory gnus-nocem-directory) "cache"))
|
||||
|
||||
;;
|
||||
;; faster lookups for group names:
|
||||
;;
|
||||
|
||||
(defvar gnus-nocem-real-group-hashtb nil
|
||||
"Real-name mappings of subscribed groups.")
|
||||
|
||||
(defun gnus-fill-real-hashtb ()
|
||||
"Fill up a hash table with the real-name mappings from the user's active file."
|
||||
(if (hash-table-p gnus-nocem-real-group-hashtb)
|
||||
(clrhash gnus-nocem-real-group-hashtb)
|
||||
(setq gnus-nocem-real-group-hashtb (make-hash-table :test 'equal)))
|
||||
(mapcar (lambda (group)
|
||||
(setq group (gnus-group-real-name (car group)))
|
||||
(puthash group t gnus-nocem-real-group-hashtb))
|
||||
gnus-newsrc-alist))
|
||||
|
||||
;;;###autoload
|
||||
(defun gnus-nocem-scan-groups ()
|
||||
"Scan all NoCeM groups for new NoCeM messages."
|
||||
(interactive)
|
||||
(let ((groups gnus-nocem-groups)
|
||||
(gnus-inhibit-demon t)
|
||||
group active gactive articles check-headers)
|
||||
(gnus-make-directory gnus-nocem-directory)
|
||||
;; Load any previous NoCeM headers.
|
||||
(gnus-nocem-load-cache)
|
||||
;; Get the group name mappings:
|
||||
(gnus-fill-real-hashtb)
|
||||
;; Read the active file if it hasn't been read yet.
|
||||
(and (file-exists-p (gnus-nocem-active-file))
|
||||
(not gnus-nocem-active)
|
||||
(ignore-errors
|
||||
(load (gnus-nocem-active-file) t t t)))
|
||||
;; Go through all groups and see whether new articles have
|
||||
;; arrived.
|
||||
(while (setq group (pop groups))
|
||||
(if (not (setq gactive (gnus-activate-group group)))
|
||||
() ; This group doesn't exist.
|
||||
(setq active (nth 1 (assoc group gnus-nocem-active)))
|
||||
(when (and (not (< (cdr gactive) (car gactive))) ; Empty group.
|
||||
(or (not active)
|
||||
(< (cdr active) (cdr gactive))))
|
||||
;; Ok, there are new articles in this group, se we fetch the
|
||||
;; headers.
|
||||
(save-excursion
|
||||
(let ((dependencies (make-vector 10 nil))
|
||||
headers header)
|
||||
(with-temp-buffer
|
||||
(setq headers
|
||||
(if (eq 'nov
|
||||
(gnus-retrieve-headers
|
||||
(setq articles
|
||||
(gnus-uncompress-range
|
||||
(cons
|
||||
(if active (1+ (cdr active))
|
||||
(car gactive))
|
||||
(cdr gactive))))
|
||||
group))
|
||||
(gnus-get-newsgroup-headers-xover
|
||||
articles nil dependencies)
|
||||
(gnus-get-newsgroup-headers dependencies)))
|
||||
(while (setq header (pop headers))
|
||||
;; We take a closer look on all articles that have
|
||||
;; "@@NCM" in the subject. Unless we already read
|
||||
;; this cross posted message. Nocem messages
|
||||
;; are not allowed to have references, so we can
|
||||
;; ignore scanning followups.
|
||||
(and (string-match "@@NCM" (mail-header-subject header))
|
||||
(and gnus-nocem-check-from
|
||||
(let ((case-fold-search t))
|
||||
(catch 'ok
|
||||
(mapc
|
||||
(lambda (author)
|
||||
(if (consp author)
|
||||
(setq author (car author)))
|
||||
(if (string-match
|
||||
author (mail-header-from header))
|
||||
(throw 'ok t)))
|
||||
gnus-nocem-issuers)
|
||||
nil)))
|
||||
(or gnus-nocem-liberal-fetch
|
||||
(and (or (string= "" (mail-header-references
|
||||
header))
|
||||
(null (mail-header-references header)))
|
||||
(not (member (mail-header-message-id header)
|
||||
gnus-nocem-seen-message-ids))))
|
||||
(push header check-headers)))
|
||||
(setq check-headers (last (nreverse check-headers)
|
||||
gnus-nocem-check-article-limit))
|
||||
(let ((i 0)
|
||||
(len (length check-headers)))
|
||||
(dolist (h check-headers)
|
||||
(gnus-message
|
||||
7 "Checking article %d in %s for NoCeM (%d of %d)..."
|
||||
(mail-header-number h) group (incf i) len)
|
||||
(gnus-nocem-check-article group h)))))))
|
||||
(setq gnus-nocem-active
|
||||
(cons (list group gactive)
|
||||
(delq (assoc group gnus-nocem-active)
|
||||
gnus-nocem-active)))))
|
||||
;; Save the results, if any.
|
||||
(gnus-nocem-save-cache)
|
||||
(gnus-nocem-save-active)))
|
||||
|
||||
(defun gnus-nocem-check-article (group header)
|
||||
"Check whether the current article is an NCM article and that we want it."
|
||||
;; Get the article.
|
||||
(let ((date (mail-header-date header))
|
||||
(gnus-newsgroup-name group)
|
||||
issuer b e type)
|
||||
(when (or (not date)
|
||||
(time-less-p
|
||||
(time-since (date-to-time date))
|
||||
(days-to-time gnus-nocem-expiry-wait)))
|
||||
(gnus-request-article-this-buffer (mail-header-number header) group)
|
||||
(goto-char (point-min))
|
||||
(when (re-search-forward
|
||||
"-----BEGIN PGP\\(?: SIGNED\\)? MESSAGE-----"
|
||||
nil t)
|
||||
(delete-region (point-min) (match-beginning 0)))
|
||||
(when (re-search-forward
|
||||
"-----END PGP \\(?:MESSAGE\\|SIGNATURE\\)-----\n?"
|
||||
nil t)
|
||||
(delete-region (match-end 0) (point-max)))
|
||||
(goto-char (point-min))
|
||||
;; The article has to have proper NoCeM headers.
|
||||
(when (and (setq b (search-forward "\n@@BEGIN NCM HEADERS\n" nil t))
|
||||
(setq e (search-forward "\n@@BEGIN NCM BODY\n" nil t)))
|
||||
;; We get the name of the issuer.
|
||||
(narrow-to-region b e)
|
||||
(setq issuer (mail-fetch-field "issuer")
|
||||
type (mail-fetch-field "type"))
|
||||
(widen)
|
||||
(if (not (gnus-nocem-message-wanted-p issuer type))
|
||||
(message "invalid NoCeM issuer: %s" issuer)
|
||||
(and (gnus-nocem-verify-issuer issuer) ; She is who she says she is.
|
||||
(gnus-nocem-enter-article) ; We gobble the message.
|
||||
(push (mail-header-message-id header) ; But don't come back for
|
||||
gnus-nocem-seen-message-ids))))))) ; second helpings.
|
||||
|
||||
(defun gnus-nocem-message-wanted-p (issuer type)
|
||||
(let ((issuers gnus-nocem-issuers)
|
||||
wanted conditions condition)
|
||||
(cond
|
||||
;; Do the quick check first.
|
||||
((member issuer issuers)
|
||||
t)
|
||||
((setq conditions (cdr (assoc issuer issuers)))
|
||||
;; Check whether we want this type.
|
||||
(while (setq condition (pop conditions))
|
||||
(cond
|
||||
((stringp condition)
|
||||
(when (string-match condition type)
|
||||
(setq wanted t)))
|
||||
((and (consp condition)
|
||||
(eq (car condition) 'not)
|
||||
(stringp (cadr condition)))
|
||||
(when (string-match (cadr condition) type)
|
||||
(setq wanted nil)))
|
||||
(t
|
||||
(error "Invalid NoCeM condition: %S" condition))))
|
||||
wanted))))
|
||||
|
||||
(defun gnus-nocem-verify-issuer (person)
|
||||
"Verify using PGP that the canceler is who she says she is."
|
||||
(if (functionp gnus-nocem-verifyer)
|
||||
(ignore-errors
|
||||
(funcall gnus-nocem-verifyer))
|
||||
;; If we don't have Mailcrypt, then we use the message anyway.
|
||||
t))
|
||||
|
||||
(defun gnus-nocem-enter-article ()
|
||||
"Enter the current article into the NoCeM cache."
|
||||
(goto-char (point-min))
|
||||
(let ((b (search-forward "\n@@BEGIN NCM BODY\n" nil t))
|
||||
(e (search-forward "\n@@END NCM BODY\n" nil t))
|
||||
(buf (current-buffer))
|
||||
ncm id group)
|
||||
(when (and b e)
|
||||
(narrow-to-region b (1+ (match-beginning 0)))
|
||||
(goto-char (point-min))
|
||||
(while (search-forward "\t" nil t)
|
||||
(cond
|
||||
((not (ignore-errors
|
||||
(setq group (gnus-group-real-name (symbol-name (read buf))))
|
||||
(gethash group gnus-nocem-real-group-hashtb)))
|
||||
;; An error.
|
||||
)
|
||||
(t
|
||||
;; Valid group.
|
||||
(beginning-of-line)
|
||||
(while (eq (char-after) ?\t)
|
||||
(forward-line -1))
|
||||
(setq id (buffer-substring (point) (1- (search-forward "\t"))))
|
||||
(unless (if (hash-table-p gnus-nocem-hashtb)
|
||||
(gethash id gnus-nocem-hashtb)
|
||||
(setq gnus-nocem-hashtb (make-hash-table :test 'equal))
|
||||
nil)
|
||||
;; only store if not already present
|
||||
(puthash id t gnus-nocem-hashtb)
|
||||
(push id ncm))
|
||||
(forward-line 1)
|
||||
(while (eq (char-after) ?\t)
|
||||
(forward-line 1)))))
|
||||
(when ncm
|
||||
(setq gnus-nocem-touched-alist t)
|
||||
(push (cons (let ((time (current-time))) (setcdr (cdr time) nil) time)
|
||||
ncm)
|
||||
gnus-nocem-alist))
|
||||
t)))
|
||||
|
||||
;;;###autoload
|
||||
(defun gnus-nocem-load-cache ()
|
||||
"Load the NoCeM cache."
|
||||
(interactive)
|
||||
(unless gnus-nocem-alist
|
||||
;; The buffer doesn't exist, so we create it and load the NoCeM
|
||||
;; cache.
|
||||
(when (file-exists-p (gnus-nocem-cache-file))
|
||||
(load (gnus-nocem-cache-file) t t t)
|
||||
(gnus-nocem-alist-to-hashtb))))
|
||||
|
||||
(defun gnus-nocem-save-cache ()
|
||||
"Save the NoCeM cache."
|
||||
(when (and gnus-nocem-alist
|
||||
gnus-nocem-touched-alist)
|
||||
(with-temp-file (gnus-nocem-cache-file)
|
||||
(gnus-prin1 `(setq gnus-nocem-alist ',gnus-nocem-alist)))
|
||||
(setq gnus-nocem-touched-alist nil)))
|
||||
|
||||
(defun gnus-nocem-save-active ()
|
||||
"Save the NoCeM active file."
|
||||
(with-temp-file (gnus-nocem-active-file)
|
||||
(gnus-prin1 `(setq gnus-nocem-active ',gnus-nocem-active))))
|
||||
|
||||
(defun gnus-nocem-alist-to-hashtb ()
|
||||
"Create a hashtable from the Message-IDs we have."
|
||||
(let* ((alist gnus-nocem-alist)
|
||||
(pprev (cons nil alist))
|
||||
(prev pprev)
|
||||
(expiry (days-to-time gnus-nocem-expiry-wait))
|
||||
entry)
|
||||
(if (hash-table-p gnus-nocem-hashtb)
|
||||
(clrhash gnus-nocem-hashtb)
|
||||
(setq gnus-nocem-hashtb (make-hash-table :test 'equal)))
|
||||
(while (setq entry (car alist))
|
||||
(if (not (time-less-p (time-since (car entry)) expiry))
|
||||
;; This entry has expired, so we remove it.
|
||||
(setcdr prev (cdr alist))
|
||||
(setq prev alist)
|
||||
;; This is ok, so we enter it into the hashtable.
|
||||
(setq entry (cdr entry))
|
||||
(while entry
|
||||
(puthash (car entry) t gnus-nocem-hashtb)
|
||||
(setq entry (cdr entry))))
|
||||
(setq alist (cdr alist)))))
|
||||
|
||||
(gnus-add-shutdown 'gnus-nocem-close 'gnus)
|
||||
|
||||
(defun gnus-nocem-close ()
|
||||
"Clear internal NoCeM variables."
|
||||
(setq gnus-nocem-alist nil
|
||||
gnus-nocem-hashtb nil
|
||||
gnus-nocem-active nil
|
||||
gnus-nocem-touched-alist nil
|
||||
gnus-nocem-seen-message-ids nil
|
||||
gnus-nocem-real-group-hashtb nil))
|
||||
|
||||
(defun gnus-nocem-unwanted-article-p (id)
|
||||
"Say whether article ID in the current group is wanted."
|
||||
(and gnus-nocem-hashtb
|
||||
(gethash id gnus-nocem-hashtb)))
|
||||
|
||||
(autoload 'epg-make-context "epg")
|
||||
(eval-when-compile
|
||||
(autoload 'epg-verify-string "epg")
|
||||
(autoload 'epg-context-result-for "epg")
|
||||
(autoload 'epg-signature-status "epg"))
|
||||
|
||||
(defun gnus-nocem-epg-verify ()
|
||||
"Return t if EasyPG verifies a signed message in the current buffer."
|
||||
(let ((context (epg-make-context 'OpenPGP))
|
||||
result)
|
||||
(epg-verify-string context (buffer-string))
|
||||
(and (setq result (epg-context-result-for context 'verify))
|
||||
(not (cdr result))
|
||||
(eq (epg-signature-status (car result)) 'good))))
|
||||
|
||||
(provide 'gnus-nocem)
|
||||
|
||||
;;; gnus-nocem.el ends here
|
||||
|
|
@ -28,6 +28,7 @@
|
|||
(eval-when-compile (require 'cl))
|
||||
|
||||
(require 'gnus)
|
||||
(require 'gnus-start)
|
||||
(require 'gnus-spec)
|
||||
(require 'gnus-group)
|
||||
(require 'gnus-int)
|
||||
|
|
@ -547,6 +548,7 @@ The following commands are available:
|
|||
(gnus-server-list-servers))
|
||||
|
||||
(defun gnus-server-copy-server (from to)
|
||||
"Copy a server definiton to a new name."
|
||||
(interactive
|
||||
(list
|
||||
(or (gnus-server-server-name)
|
||||
|
|
@ -643,6 +645,30 @@ The following commands are available:
|
|||
(defvar gnus-browse-menu-hook nil
|
||||
"*Hook run after the creation of the browse mode menu.")
|
||||
|
||||
(defcustom gnus-browse-subscribe-newsgroup-method
|
||||
'gnus-subscribe-alphabetically
|
||||
"Function(s) called when subscribing groups in the Browse Server Buffer
|
||||
A few pre-made functions are supplied: `gnus-subscribe-randomly'
|
||||
inserts new groups at the beginning of the list of groups;
|
||||
`gnus-subscribe-alphabetically' inserts new groups in strict
|
||||
alphabetic order; `gnus-subscribe-hierarchically' inserts new groups
|
||||
in hierarchical newsgroup order; `gnus-subscribe-interactively' asks
|
||||
for your decision; `gnus-subscribe-killed' kills all new groups;
|
||||
`gnus-subscribe-zombies' will make all new groups into zombies;
|
||||
`gnus-subscribe-topics' will enter groups into the topics that
|
||||
claim them."
|
||||
:version "24.1"
|
||||
:group 'gnus-server
|
||||
:type '(radio (function-item gnus-subscribe-randomly)
|
||||
(function-item gnus-subscribe-alphabetically)
|
||||
(function-item gnus-subscribe-hierarchically)
|
||||
(function-item gnus-subscribe-interactively)
|
||||
(function-item gnus-subscribe-killed)
|
||||
(function-item gnus-subscribe-zombies)
|
||||
(function-item gnus-subscribe-topics)
|
||||
function
|
||||
(repeat function)))
|
||||
|
||||
(defvar gnus-browse-mode-hook nil)
|
||||
(defvar gnus-browse-mode-map nil)
|
||||
(put 'gnus-browse-mode 'mode-class 'special)
|
||||
|
|
@ -890,7 +916,9 @@ If NUMBER, fetch this number of articles."
|
|||
(gnus-browse-next-group (- n)))
|
||||
|
||||
(defun gnus-browse-unsubscribe-current-group (arg)
|
||||
"(Un)subscribe to the next ARG groups."
|
||||
"(Un)subscribe to the next ARG groups.
|
||||
The variable `gnus-browse-subscribe-newsgroup-method' determines
|
||||
how new groups will be entered into the group buffer."
|
||||
(interactive "p")
|
||||
(when (eobp)
|
||||
(error "No group at current line"))
|
||||
|
|
@ -939,22 +967,24 @@ If NUMBER, fetch this number of articles."
|
|||
;; subscribe to it.
|
||||
(if (gnus-ephemeral-group-p group)
|
||||
(gnus-kill-ephemeral-group group))
|
||||
;; We need to discern between killed/zombie groups and
|
||||
;; just unsubscribed ones.
|
||||
(gnus-group-change-level
|
||||
(or (gnus-group-entry group)
|
||||
(list t group gnus-level-default-subscribed
|
||||
nil nil (if (gnus-server-equal
|
||||
gnus-browse-current-method "native")
|
||||
nil
|
||||
(gnus-method-simplify
|
||||
gnus-browse-current-method))))
|
||||
gnus-level-default-subscribed (gnus-group-level group)
|
||||
(and (car (nth 1 gnus-newsrc-alist))
|
||||
(gnus-group-entry (car (nth 1 gnus-newsrc-alist))))
|
||||
(null (gnus-group-entry group)))
|
||||
(let ((entry (gnus-group-entry group)))
|
||||
(if entry
|
||||
;; Just change the subscription level if it is an
|
||||
;; unsubscribed group.
|
||||
(gnus-group-change-level entry
|
||||
gnus-level-default-subscribed)
|
||||
;; If it is a killed group or a zombie, feed it to the
|
||||
;; mechanism for new group subscription.
|
||||
(gnus-call-subscribe-functions
|
||||
gnus-browse-subscribe-newsgroup-method
|
||||
group)))
|
||||
(delete-char 1)
|
||||
(insert ? ))
|
||||
(insert (let ((lvl (gnus-group-level group)))
|
||||
(cond
|
||||
((< lvl gnus-level-unsubscribed) ? )
|
||||
((< lvl gnus-level-zombie) ?U)
|
||||
((< lvl gnus-level-killed) ?Z)
|
||||
(t ?K)))))
|
||||
(gnus-group-change-level
|
||||
group gnus-level-unsubscribed gnus-level-default-subscribed)
|
||||
(delete-char 1)
|
||||
|
|
|
|||
|
|
@ -1063,15 +1063,6 @@ If LEVEL is non-nil, the news will be set up at level LEVEL."
|
|||
(gnus-server-opened gnus-select-method))
|
||||
(gnus-check-bogus-newsgroups))
|
||||
|
||||
;; We might read in new NoCeM messages here.
|
||||
(when (and (not dont-connect)
|
||||
gnus-use-nocem
|
||||
(or (and (numberp gnus-use-nocem)
|
||||
(numberp level)
|
||||
(>= level gnus-use-nocem))
|
||||
(not level)))
|
||||
(gnus-nocem-scan-groups))
|
||||
|
||||
;; Read any slave files.
|
||||
(gnus-master-read-slave-newsrc)
|
||||
|
||||
|
|
@ -1767,8 +1758,10 @@ If SCAN, request a scan of that group as well."
|
|||
(not (gnus-method-denied-p method)))
|
||||
(unless (gnus-server-opened method)
|
||||
(gnus-open-server method))
|
||||
(when (gnus-check-backend-function
|
||||
'retrieve-group-data-early (car method))
|
||||
(when (and
|
||||
(gnus-server-opened method)
|
||||
(gnus-check-backend-function
|
||||
'retrieve-group-data-early (car method)))
|
||||
(when (gnus-check-backend-function 'request-scan (car method))
|
||||
(gnus-request-scan nil method))
|
||||
(setcar (nthcdr 3 elem)
|
||||
|
|
|
|||
|
|
@ -2047,6 +2047,7 @@ increase the score of each group you read."
|
|||
"e" gnus-summary-end-of-article
|
||||
"^" gnus-summary-refer-parent-article
|
||||
"r" gnus-summary-refer-parent-article
|
||||
"C" gnus-summary-show-complete-article
|
||||
"D" gnus-summary-enter-digest-group
|
||||
"R" gnus-summary-refer-references
|
||||
"T" gnus-summary-refer-thread
|
||||
|
|
@ -8645,8 +8646,7 @@ fetch-old-headers verbiage, and so on."
|
|||
(null gnus-summary-expunge-below)
|
||||
(not (eq gnus-build-sparse-threads 'some))
|
||||
(not (eq gnus-build-sparse-threads 'more))
|
||||
(null gnus-thread-expunge-below)
|
||||
(not gnus-use-nocem)))
|
||||
(null gnus-thread-expunge-below)))
|
||||
(push gnus-newsgroup-limit gnus-newsgroup-limits)
|
||||
(setq gnus-newsgroup-limit nil)
|
||||
(mapatoms
|
||||
|
|
@ -8729,14 +8729,7 @@ fetch-old-headers verbiage, and so on."
|
|||
t)
|
||||
;; Do the `display' group parameter.
|
||||
(and gnus-newsgroup-display
|
||||
(not (funcall gnus-newsgroup-display)))
|
||||
;; Check NoCeM things.
|
||||
(when (and gnus-use-nocem
|
||||
(gnus-nocem-unwanted-article-p
|
||||
(mail-header-id (car thread))))
|
||||
(setq gnus-newsgroup-unreads
|
||||
(delq number gnus-newsgroup-unreads))
|
||||
t)))
|
||||
(not (funcall gnus-newsgroup-display)))))
|
||||
;; Nope, invisible article.
|
||||
0
|
||||
;; Ok, this article is to be visible, so we add it to the limit
|
||||
|
|
@ -9357,6 +9350,18 @@ to save in."
|
|||
(ps-spool-buffer)))))
|
||||
(kill-buffer buffer))))
|
||||
|
||||
(defun gnus-summary-show-complete-article ()
|
||||
"Show a complete version of the current article.
|
||||
This is only useful if you're looking at a partial version of the
|
||||
article currently."
|
||||
(interactive)
|
||||
(let ((gnus-keep-backlog nil)
|
||||
(gnus-use-cache nil)
|
||||
(gnus-agent nil)
|
||||
(gnus-fetch-partial-articles nil))
|
||||
(gnus-flush-original-article-buffer)
|
||||
(gnus-summary-show-article)))
|
||||
|
||||
(defun gnus-summary-show-article (&optional arg)
|
||||
"Force redisplaying of the current article.
|
||||
If ARG (the prefix) is a number, show the article with the charset
|
||||
|
|
|
|||
|
|
@ -308,11 +308,6 @@ be set in `.emacs' instead."
|
|||
:group 'gnus-start
|
||||
:type 'boolean)
|
||||
|
||||
(defcustom gnus-play-startup-jingle nil
|
||||
"If non-nil, play the Gnus jingle at startup."
|
||||
:group 'gnus-start
|
||||
:type 'boolean)
|
||||
|
||||
(unless (fboundp 'gnus-group-remove-excess-properties)
|
||||
(defalias 'gnus-group-remove-excess-properties 'ignore))
|
||||
|
||||
|
|
@ -960,8 +955,6 @@ be set in `.emacs' instead."
|
|||
|
||||
(defvar gnus-group-buffer "*Group*")
|
||||
|
||||
(autoload 'gnus-play-jingle "gnus-audio")
|
||||
|
||||
(defface gnus-splash
|
||||
'((((class color)
|
||||
(background dark))
|
||||
|
|
@ -984,9 +977,7 @@ be set in `.emacs' instead."
|
|||
(erase-buffer)
|
||||
(unless gnus-inhibit-startup-message
|
||||
(gnus-group-startup-message)
|
||||
(sit-for 0)
|
||||
(when gnus-play-startup-jingle
|
||||
(gnus-play-jingle))))))
|
||||
(sit-for 0)))))
|
||||
|
||||
(defun gnus-indent-rigidly (start end arg)
|
||||
"Indent rigidly using only spaces and no tabs."
|
||||
|
|
@ -1580,25 +1571,6 @@ articles. This is not a good idea."
|
|||
(sexp :format "all"
|
||||
:value t)))
|
||||
|
||||
(defcustom gnus-use-nocem nil
|
||||
"*If non-nil, Gnus will read NoCeM cancel messages.
|
||||
You can also set this variable to a positive number as a group level.
|
||||
In that case, Gnus scans NoCeM messages when checking new news if this
|
||||
value is not exceeding a group level that you specify as the prefix
|
||||
argument to some commands, e.g. `gnus', `gnus-group-get-new-news', etc.
|
||||
Otherwise, Gnus does not scan NoCeM messages if you specify a group
|
||||
level to those commands."
|
||||
:group 'gnus-meta
|
||||
:type '(choice
|
||||
(const :tag "off" nil)
|
||||
(const :tag "on" t)
|
||||
(list :convert-widget
|
||||
(lambda (widget)
|
||||
(list 'integer :tag "group level"
|
||||
:value (if (boundp 'gnus-level-default-subscribed)
|
||||
gnus-level-default-subscribed
|
||||
3))))))
|
||||
|
||||
(defcustom gnus-suppress-duplicates nil
|
||||
"*If non-nil, Gnus will mark duplicate copies of the same article as read."
|
||||
:group 'gnus-meta
|
||||
|
|
@ -2813,13 +2785,12 @@ gnus-registry.el will populate this if it's loaded.")
|
|||
rmail-summary-exists rmail-select-summary)
|
||||
;; Only used in gnus-util, which has an autoload.
|
||||
("rmailsum" rmail-update-summary)
|
||||
("gnus-audio" :interactive t gnus-audio-play)
|
||||
("gnus-xmas" gnus-xmas-splash)
|
||||
("score-mode" :interactive t gnus-score-mode)
|
||||
("gnus-mh" gnus-summary-save-article-folder
|
||||
gnus-Folder-save-name gnus-folder-save-name)
|
||||
("gnus-mh" :interactive t gnus-summary-save-in-folder)
|
||||
("gnus-demon" gnus-demon-add-nocem gnus-demon-add-scanmail
|
||||
("gnus-demon" gnus-demon-add-scanmail
|
||||
gnus-demon-add-rescan gnus-demon-add-scan-timestamps
|
||||
gnus-demon-add-disconnection gnus-demon-add-handler
|
||||
gnus-demon-remove-handler)
|
||||
|
|
@ -2830,8 +2801,6 @@ gnus-registry.el will populate this if it's loaded.")
|
|||
gnus-face-from-file)
|
||||
("gnus-salt" gnus-highlight-selected-tree gnus-possibly-generate-tree
|
||||
gnus-tree-open gnus-tree-close gnus-carpal-setup-buffer)
|
||||
("gnus-nocem" gnus-nocem-scan-groups gnus-nocem-close
|
||||
gnus-nocem-unwanted-article-p)
|
||||
("gnus-srvr" gnus-enter-server-buffer gnus-server-set-info
|
||||
gnus-server-server-name)
|
||||
("gnus-srvr" gnus-browse-foreign-server)
|
||||
|
|
@ -4395,7 +4364,7 @@ prompt the user for the name of an NNTP server to use."
|
|||
;; When using the development version of Gnus, load the gnus-load
|
||||
;; file.
|
||||
(unless (string-match "^Gnus" gnus-version)
|
||||
(load "gnus-load"))
|
||||
(load "gnus-load" nil t))
|
||||
(unless (byte-code-function-p (symbol-function 'gnus))
|
||||
(message "You should byte-compile Gnus")
|
||||
(sit-for 2))
|
||||
|
|
|
|||
|
|
@ -1147,13 +1147,15 @@ in HANDLE."
|
|||
;; time to adjust it, since we know at this point that it should
|
||||
;; be unibyte.
|
||||
`(let* ((handle ,handle))
|
||||
(with-temp-buffer
|
||||
(mm-disable-multibyte)
|
||||
(insert-buffer-substring (mm-handle-buffer handle))
|
||||
(mm-decode-content-transfer-encoding
|
||||
(mm-handle-encoding handle)
|
||||
(mm-handle-media-type handle))
|
||||
,@forms)))
|
||||
(when (and (mm-handle-buffer handle)
|
||||
(buffer-name (mm-handle-buffer handle)))
|
||||
(with-temp-buffer
|
||||
(mm-disable-multibyte)
|
||||
(insert-buffer-substring (mm-handle-buffer handle))
|
||||
(mm-decode-content-transfer-encoding
|
||||
(mm-handle-encoding handle)
|
||||
(mm-handle-media-type handle))
|
||||
,@forms))))
|
||||
(put 'mm-with-part 'lisp-indent-function 1)
|
||||
(put 'mm-with-part 'edebug-form-spec '(body))
|
||||
|
||||
|
|
@ -1246,9 +1248,13 @@ PROMPT overrides the default one used to ask user for a file name."
|
|||
(setq filename (gnus-map-function mm-file-name-rewrite-functions
|
||||
(file-name-nondirectory filename))))
|
||||
(setq file
|
||||
(read-file-name (or prompt "Save MIME part to: ")
|
||||
(read-file-name (or prompt
|
||||
(format "Save MIME part to (default %s): "
|
||||
(or filename "")))
|
||||
(or mm-default-directory default-directory)
|
||||
nil nil (or filename "")))
|
||||
(or filename "")))
|
||||
(when (file-directory-p file)
|
||||
(setq file (expand-file-name filename file)))
|
||||
(setq mm-default-directory (file-name-directory file))
|
||||
(and (or (not (file-exists-p file))
|
||||
(yes-or-no-p (format "File %s already exists; overwrite? "
|
||||
|
|
|
|||
|
|
@ -57,8 +57,6 @@
|
|||
(defvar mml1991-function-alist
|
||||
'((mailcrypt mml1991-mailcrypt-sign
|
||||
mml1991-mailcrypt-encrypt)
|
||||
(gpg mml1991-gpg-sign
|
||||
mml1991-gpg-encrypt)
|
||||
(pgg mml1991-pgg-sign
|
||||
mml1991-pgg-encrypt)
|
||||
(epg mml1991-epg-sign
|
||||
|
|
@ -168,99 +166,6 @@ Whether the passphrase is cached at all is controlled by
|
|||
(insert-buffer-substring cipher)
|
||||
(goto-char (point-max))))))
|
||||
|
||||
;;; gpg wrapper
|
||||
|
||||
(autoload 'gpg-sign-cleartext "gpg")
|
||||
|
||||
(declare-function gpg-sign-encrypt "ext:gpg"
|
||||
(plaintext ciphertext result recipients &optional
|
||||
passphrase sign-with-key armor textmode))
|
||||
(declare-function gpg-encrypt "ext:gpg"
|
||||
(plaintext ciphertext result recipients &optional
|
||||
passphrase armor textmode))
|
||||
|
||||
(defun mml1991-gpg-sign (cont)
|
||||
(let ((text (current-buffer))
|
||||
headers signature
|
||||
(result-buffer (get-buffer-create "*GPG Result*")))
|
||||
;; Save MIME Content[^ ]+: headers from signing
|
||||
(goto-char (point-min))
|
||||
(while (looking-at "^Content[^ ]+:") (forward-line))
|
||||
(unless (bobp)
|
||||
(setq headers (buffer-string))
|
||||
(delete-region (point-min) (point)))
|
||||
(goto-char (point-max))
|
||||
(unless (bolp)
|
||||
(insert "\n"))
|
||||
(quoted-printable-decode-region (point-min) (point-max))
|
||||
(with-temp-buffer
|
||||
(unless (gpg-sign-cleartext text (setq signature (current-buffer))
|
||||
result-buffer
|
||||
nil
|
||||
(message-options-get 'message-sender))
|
||||
(unless (> (point-max) (point-min))
|
||||
(pop-to-buffer result-buffer)
|
||||
(error "Sign error")))
|
||||
(goto-char (point-min))
|
||||
(while (re-search-forward "\r+$" nil t)
|
||||
(replace-match "" t t))
|
||||
(quoted-printable-encode-region (point-min) (point-max))
|
||||
(set-buffer text)
|
||||
(delete-region (point-min) (point-max))
|
||||
(if headers (insert headers))
|
||||
(insert "\n")
|
||||
(insert-buffer-substring signature)
|
||||
(goto-char (point-max)))))
|
||||
|
||||
(defun mml1991-gpg-encrypt (cont &optional sign)
|
||||
(let ((text (current-buffer))
|
||||
cipher
|
||||
(result-buffer (get-buffer-create "*GPG Result*")))
|
||||
;; Strip MIME Content[^ ]: headers since it will be ASCII ARMORED
|
||||
(goto-char (point-min))
|
||||
(while (looking-at "^Content[^ ]+:") (forward-line))
|
||||
(unless (bobp)
|
||||
(delete-region (point-min) (point)))
|
||||
(mm-with-unibyte-current-buffer
|
||||
(with-temp-buffer
|
||||
(inline (mm-disable-multibyte))
|
||||
(flet ((gpg-encrypt-func
|
||||
(sign plaintext ciphertext result recipients &optional
|
||||
passphrase sign-with-key armor textmode)
|
||||
(if sign
|
||||
(gpg-sign-encrypt
|
||||
plaintext ciphertext result recipients passphrase
|
||||
sign-with-key armor textmode)
|
||||
(gpg-encrypt
|
||||
plaintext ciphertext result recipients passphrase
|
||||
armor textmode))))
|
||||
(unless (gpg-encrypt-func
|
||||
sign
|
||||
text (setq cipher (current-buffer))
|
||||
result-buffer
|
||||
(split-string
|
||||
(or
|
||||
(message-options-get 'message-recipients)
|
||||
(message-options-set 'message-recipients
|
||||
(read-string "Recipients: ")))
|
||||
"[ \f\t\n\r\v,]+")
|
||||
nil
|
||||
(message-options-get 'message-sender)
|
||||
t t) ; armor & textmode
|
||||
(unless (> (point-max) (point-min))
|
||||
(pop-to-buffer result-buffer)
|
||||
(error "Encrypt error"))))
|
||||
(goto-char (point-min))
|
||||
(while (re-search-forward "\r+$" nil t)
|
||||
(replace-match "" t t))
|
||||
(set-buffer text)
|
||||
(delete-region (point-min) (point-max))
|
||||
;;(insert "Content-Type: application/pgp-encrypted\n\n")
|
||||
;;(insert "Version: 1\n\n")
|
||||
(insert "\n")
|
||||
(insert-buffer-substring cipher)
|
||||
(goto-char (point-max))))))
|
||||
|
||||
;; pgg wrapper
|
||||
|
||||
(defvar pgg-default-user-id)
|
||||
|
|
|
|||
|
|
@ -63,11 +63,6 @@
|
|||
(require 'pgg)))
|
||||
(and (fboundp 'pgg-sign-region)
|
||||
'pgg))
|
||||
(progn
|
||||
(ignore-errors
|
||||
(require 'gpg))
|
||||
(and (fboundp 'gpg-sign-detached)
|
||||
'gpg))
|
||||
(progn (ignore-errors
|
||||
(load "mc-toplev"))
|
||||
(and (fboundp 'mc-encrypt-generic)
|
||||
|
|
@ -75,7 +70,7 @@
|
|||
(fboundp 'mc-cleanup-recipient-headers)
|
||||
'mailcrypt)))
|
||||
"The package used for PGP/MIME.
|
||||
Valid packages include `epg', `pgg', `gpg' and `mailcrypt'.")
|
||||
Valid packages include `epg', `pgg' and `mailcrypt'.")
|
||||
|
||||
;; Something is not RFC2015.
|
||||
(defvar mml2015-function-alist
|
||||
|
|
@ -85,24 +80,18 @@ Valid packages include `epg', `pgg', `gpg' and `mailcrypt'.")
|
|||
mml2015-mailcrypt-decrypt
|
||||
mml2015-mailcrypt-clear-verify
|
||||
mml2015-mailcrypt-clear-decrypt)
|
||||
(gpg mml2015-gpg-sign
|
||||
mml2015-gpg-encrypt
|
||||
mml2015-gpg-verify
|
||||
mml2015-gpg-decrypt
|
||||
mml2015-gpg-clear-verify
|
||||
mml2015-gpg-clear-decrypt)
|
||||
(pgg mml2015-pgg-sign
|
||||
mml2015-pgg-encrypt
|
||||
mml2015-pgg-verify
|
||||
mml2015-pgg-decrypt
|
||||
mml2015-pgg-clear-verify
|
||||
mml2015-pgg-clear-decrypt)
|
||||
(epg mml2015-epg-sign
|
||||
mml2015-epg-encrypt
|
||||
mml2015-epg-verify
|
||||
mml2015-epg-decrypt
|
||||
mml2015-epg-clear-verify
|
||||
mml2015-epg-clear-decrypt))
|
||||
(pgg mml2015-pgg-sign
|
||||
mml2015-pgg-encrypt
|
||||
mml2015-pgg-verify
|
||||
mml2015-pgg-decrypt
|
||||
mml2015-pgg-clear-verify
|
||||
mml2015-pgg-clear-decrypt)
|
||||
(epg mml2015-epg-sign
|
||||
mml2015-epg-encrypt
|
||||
mml2015-epg-verify
|
||||
mml2015-epg-decrypt
|
||||
mml2015-epg-clear-verify
|
||||
mml2015-epg-clear-decrypt))
|
||||
"Alist of PGP/MIME functions.")
|
||||
|
||||
(defvar mml2015-result-buffer nil)
|
||||
|
|
@ -148,7 +137,7 @@ Whether the passphrase is cached at all is controlled by
|
|||
|
||||
;; Extract plaintext from cleartext signature. IMO, this kind of task
|
||||
;; should be done by GnuPG rather than Elisp, but older PGP backends
|
||||
;; (such as Mailcrypt, PGG, and gpg.el) discard the output from GnuPG.
|
||||
;; (such as Mailcrypt, and PGG) discard the output from GnuPG.
|
||||
(defun mml2015-extract-cleartext-signature ()
|
||||
;; Daiki Ueno in
|
||||
;; <54a15d860801080142l70b95d7dkac4bf51a86196011@mail.gmail.com>: ``I still
|
||||
|
|
@ -234,6 +223,58 @@ Whether the passphrase is cached at all is controlled by
|
|||
handles
|
||||
(list handles)))))
|
||||
|
||||
(defun mml2015-gpg-pretty-print-fpr (fingerprint)
|
||||
(let* ((result "")
|
||||
(fpr-length (string-width fingerprint))
|
||||
(n-slice 0)
|
||||
slice)
|
||||
(setq fingerprint (string-to-list fingerprint))
|
||||
(while fingerprint
|
||||
(setq fpr-length (- fpr-length 4))
|
||||
(setq slice (butlast fingerprint fpr-length))
|
||||
(setq fingerprint (nthcdr 4 fingerprint))
|
||||
(setq n-slice (1+ n-slice))
|
||||
(setq result
|
||||
(concat
|
||||
result
|
||||
(case n-slice
|
||||
(1 slice)
|
||||
(otherwise (concat " " slice))))))
|
||||
result))
|
||||
|
||||
(defun mml2015-gpg-extract-signature-details ()
|
||||
(goto-char (point-min))
|
||||
(let* ((expired (re-search-forward
|
||||
"^\\[GNUPG:\\] SIGEXPIRED$"
|
||||
nil t))
|
||||
(signer (and (re-search-forward
|
||||
"^\\[GNUPG:\\] GOODSIG \\([0-9A-Za-z]*\\) \\(.*\\)$"
|
||||
nil t)
|
||||
(cons (match-string 1) (match-string 2))))
|
||||
(fprint (and (re-search-forward
|
||||
"^\\[GNUPG:\\] VALIDSIG \\([0-9a-zA-Z]*\\) "
|
||||
nil t)
|
||||
(match-string 1)))
|
||||
(trust (and (re-search-forward
|
||||
"^\\[GNUPG:\\] \\(TRUST_.*\\)$"
|
||||
nil t)
|
||||
(match-string 1)))
|
||||
(trust-good-enough-p
|
||||
(cdr (assoc trust mml2015-unabbrev-trust-alist))))
|
||||
(cond ((and signer fprint)
|
||||
(concat (cdr signer)
|
||||
(unless trust-good-enough-p
|
||||
(concat "\nUntrusted, Fingerprint: "
|
||||
(mml2015-gpg-pretty-print-fpr fprint)))
|
||||
(when expired
|
||||
(format "\nWARNING: Signature from expired key (%s)"
|
||||
(car signer)))))
|
||||
((re-search-forward
|
||||
"^\\(gpg: \\)?Good signature from \"\\(.*\\)\"$" nil t)
|
||||
(match-string 2))
|
||||
(t
|
||||
"From unknown user"))))
|
||||
|
||||
(defun mml2015-mailcrypt-clear-decrypt ()
|
||||
(let (result)
|
||||
(setq result
|
||||
|
|
@ -446,280 +487,6 @@ Whether the passphrase is cached at all is controlled by
|
|||
(insert (format "--%s--\n" boundary))
|
||||
(goto-char (point-max))))
|
||||
|
||||
;;; gpg wrapper
|
||||
|
||||
(autoload 'gpg-decrypt "gpg")
|
||||
(autoload 'gpg-verify "gpg")
|
||||
(autoload 'gpg-verify-cleartext "gpg")
|
||||
(autoload 'gpg-sign-detached "gpg")
|
||||
(autoload 'gpg-sign-encrypt "gpg")
|
||||
(autoload 'gpg-encrypt "gpg")
|
||||
(autoload 'gpg-passphrase-read "gpg")
|
||||
|
||||
(defun mml2015-gpg-passphrase ()
|
||||
(or (message-options-get 'gpg-passphrase)
|
||||
(message-options-set 'gpg-passphrase (gpg-passphrase-read))))
|
||||
|
||||
(defun mml2015-gpg-decrypt-1 ()
|
||||
(let ((cipher (current-buffer)) plain result)
|
||||
(if (with-temp-buffer
|
||||
(prog1
|
||||
(gpg-decrypt cipher (setq plain (current-buffer))
|
||||
mml2015-result-buffer nil)
|
||||
(mm-set-handle-multipart-parameter
|
||||
mm-security-handle 'gnus-details
|
||||
(with-current-buffer mml2015-result-buffer
|
||||
(buffer-string)))
|
||||
(set-buffer cipher)
|
||||
(erase-buffer)
|
||||
(insert-buffer-substring plain)
|
||||
(goto-char (point-min))
|
||||
(while (search-forward "\r\n" nil t)
|
||||
(replace-match "\n" t t))))
|
||||
'(t)
|
||||
;; Some wrong with the return value, check plain text buffer.
|
||||
(if (> (point-max) (point-min))
|
||||
'(t)
|
||||
nil))))
|
||||
|
||||
(defun mml2015-gpg-decrypt (handle ctl)
|
||||
(let ((mml2015-decrypt-function 'mml2015-gpg-decrypt-1))
|
||||
(mml2015-mailcrypt-decrypt handle ctl)))
|
||||
|
||||
(defun mml2015-gpg-clear-decrypt ()
|
||||
(let (result)
|
||||
(setq result (mml2015-gpg-decrypt-1))
|
||||
(if (car result)
|
||||
(mm-set-handle-multipart-parameter
|
||||
mm-security-handle 'gnus-info "OK")
|
||||
(mm-set-handle-multipart-parameter
|
||||
mm-security-handle 'gnus-info "Failed"))))
|
||||
|
||||
(defun mml2015-gpg-pretty-print-fpr (fingerprint)
|
||||
(let* ((result "")
|
||||
(fpr-length (string-width fingerprint))
|
||||
(n-slice 0)
|
||||
slice)
|
||||
(setq fingerprint (string-to-list fingerprint))
|
||||
(while fingerprint
|
||||
(setq fpr-length (- fpr-length 4))
|
||||
(setq slice (butlast fingerprint fpr-length))
|
||||
(setq fingerprint (nthcdr 4 fingerprint))
|
||||
(setq n-slice (1+ n-slice))
|
||||
(setq result
|
||||
(concat
|
||||
result
|
||||
(case n-slice
|
||||
(1 slice)
|
||||
(otherwise (concat " " slice))))))
|
||||
result))
|
||||
|
||||
(defun mml2015-gpg-extract-signature-details ()
|
||||
(goto-char (point-min))
|
||||
(let* ((expired (re-search-forward
|
||||
"^\\[GNUPG:\\] SIGEXPIRED$"
|
||||
nil t))
|
||||
(signer (and (re-search-forward
|
||||
"^\\[GNUPG:\\] GOODSIG \\([0-9A-Za-z]*\\) \\(.*\\)$"
|
||||
nil t)
|
||||
(cons (match-string 1) (match-string 2))))
|
||||
(fprint (and (re-search-forward
|
||||
"^\\[GNUPG:\\] VALIDSIG \\([0-9a-zA-Z]*\\) "
|
||||
nil t)
|
||||
(match-string 1)))
|
||||
(trust (and (re-search-forward
|
||||
"^\\[GNUPG:\\] \\(TRUST_.*\\)$"
|
||||
nil t)
|
||||
(match-string 1)))
|
||||
(trust-good-enough-p
|
||||
(cdr (assoc trust mml2015-unabbrev-trust-alist))))
|
||||
(cond ((and signer fprint)
|
||||
(concat (cdr signer)
|
||||
(unless trust-good-enough-p
|
||||
(concat "\nUntrusted, Fingerprint: "
|
||||
(mml2015-gpg-pretty-print-fpr fprint)))
|
||||
(when expired
|
||||
(format "\nWARNING: Signature from expired key (%s)"
|
||||
(car signer)))))
|
||||
((re-search-forward
|
||||
"^\\(gpg: \\)?Good signature from \"\\(.*\\)\"$" nil t)
|
||||
(match-string 2))
|
||||
(t
|
||||
"From unknown user"))))
|
||||
|
||||
(defun mml2015-gpg-verify (handle ctl)
|
||||
(catch 'error
|
||||
(let (part message signature info-is-set-p)
|
||||
(unless (setq part (mm-find-raw-part-by-type
|
||||
ctl (or (mm-handle-multipart-ctl-parameter
|
||||
ctl 'protocol)
|
||||
"application/pgp-signature")
|
||||
t))
|
||||
(mm-set-handle-multipart-parameter
|
||||
mm-security-handle 'gnus-info "Corrupted")
|
||||
(throw 'error handle))
|
||||
(with-temp-buffer
|
||||
(setq message (current-buffer))
|
||||
(insert part)
|
||||
;; Convert <LF> to <CR><LF> in signed text. If --textmode is
|
||||
;; specified when signing, the conversion is not necessary.
|
||||
(goto-char (point-min))
|
||||
(end-of-line)
|
||||
(while (not (eobp))
|
||||
(unless (eq (char-before) ?\r)
|
||||
(insert "\r"))
|
||||
(forward-line)
|
||||
(end-of-line))
|
||||
(with-temp-buffer
|
||||
(setq signature (current-buffer))
|
||||
(unless (setq part (mm-find-part-by-type
|
||||
(cdr handle) "application/pgp-signature" nil t))
|
||||
(mm-set-handle-multipart-parameter
|
||||
mm-security-handle 'gnus-info "Corrupted")
|
||||
(throw 'error handle))
|
||||
(mm-insert-part part)
|
||||
(unless (condition-case err
|
||||
(prog1
|
||||
(gpg-verify message signature mml2015-result-buffer)
|
||||
(mm-set-handle-multipart-parameter
|
||||
mm-security-handle 'gnus-details
|
||||
(with-current-buffer mml2015-result-buffer
|
||||
(buffer-string))))
|
||||
(error
|
||||
(mm-set-handle-multipart-parameter
|
||||
mm-security-handle 'gnus-details (mml2015-format-error err))
|
||||
(mm-set-handle-multipart-parameter
|
||||
mm-security-handle 'gnus-info "Error.")
|
||||
(setq info-is-set-p t)
|
||||
nil)
|
||||
(quit
|
||||
(mm-set-handle-multipart-parameter
|
||||
mm-security-handle 'gnus-details "Quit.")
|
||||
(mm-set-handle-multipart-parameter
|
||||
mm-security-handle 'gnus-info "Quit.")
|
||||
(setq info-is-set-p t)
|
||||
nil))
|
||||
(unless info-is-set-p
|
||||
(mm-set-handle-multipart-parameter
|
||||
mm-security-handle 'gnus-info "Failed"))
|
||||
(throw 'error handle)))
|
||||
(mm-set-handle-multipart-parameter
|
||||
mm-security-handle 'gnus-info
|
||||
(with-current-buffer mml2015-result-buffer
|
||||
(mml2015-gpg-extract-signature-details))))
|
||||
handle)))
|
||||
|
||||
(defun mml2015-gpg-clear-verify ()
|
||||
(if (condition-case err
|
||||
(prog1
|
||||
(gpg-verify-cleartext (current-buffer) mml2015-result-buffer)
|
||||
(mm-set-handle-multipart-parameter
|
||||
mm-security-handle 'gnus-details
|
||||
(with-current-buffer mml2015-result-buffer
|
||||
(buffer-string))))
|
||||
(error
|
||||
(mm-set-handle-multipart-parameter
|
||||
mm-security-handle 'gnus-details (mml2015-format-error err))
|
||||
nil)
|
||||
(quit
|
||||
(mm-set-handle-multipart-parameter
|
||||
mm-security-handle 'gnus-details "Quit.")
|
||||
nil))
|
||||
(mm-set-handle-multipart-parameter
|
||||
mm-security-handle 'gnus-info
|
||||
(with-current-buffer mml2015-result-buffer
|
||||
(mml2015-gpg-extract-signature-details)))
|
||||
(mm-set-handle-multipart-parameter
|
||||
mm-security-handle 'gnus-info "Failed"))
|
||||
(mml2015-extract-cleartext-signature))
|
||||
|
||||
(defun mml2015-gpg-sign (cont)
|
||||
(let ((boundary (mml-compute-boundary cont))
|
||||
(text (current-buffer)) signature)
|
||||
(goto-char (point-max))
|
||||
(unless (bolp)
|
||||
(insert "\n"))
|
||||
(with-temp-buffer
|
||||
(unless (gpg-sign-detached text (setq signature (current-buffer))
|
||||
mml2015-result-buffer
|
||||
nil
|
||||
(message-options-get 'message-sender)
|
||||
t t) ; armor & textmode
|
||||
(unless (> (point-max) (point-min))
|
||||
(pop-to-buffer mml2015-result-buffer)
|
||||
(error "Sign error")))
|
||||
(goto-char (point-min))
|
||||
(while (re-search-forward "\r+$" nil t)
|
||||
(replace-match "" t t))
|
||||
(set-buffer text)
|
||||
(goto-char (point-min))
|
||||
(insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n"
|
||||
boundary))
|
||||
;;; FIXME: what is the micalg?
|
||||
(insert "\tmicalg=pgp-sha1; protocol=\"application/pgp-signature\"\n")
|
||||
(insert (format "\n--%s\n" boundary))
|
||||
(goto-char (point-max))
|
||||
(insert (format "\n--%s\n" boundary))
|
||||
(insert "Content-Type: application/pgp-signature\n\n")
|
||||
(insert-buffer-substring signature)
|
||||
(goto-char (point-max))
|
||||
(insert (format "--%s--\n" boundary))
|
||||
(goto-char (point-max)))))
|
||||
|
||||
(defun mml2015-gpg-encrypt (cont &optional sign)
|
||||
(let ((boundary (mml-compute-boundary cont))
|
||||
(text (current-buffer))
|
||||
cipher)
|
||||
(mm-with-unibyte-current-buffer
|
||||
(with-temp-buffer
|
||||
(mm-disable-multibyte)
|
||||
;; set up a function to call the correct gpg encrypt routine
|
||||
;; with the right arguments. (FIXME: this should be done
|
||||
;; differently.)
|
||||
(flet ((gpg-encrypt-func
|
||||
(sign plaintext ciphertext result recipients &optional
|
||||
passphrase sign-with-key armor textmode)
|
||||
(if sign
|
||||
(gpg-sign-encrypt
|
||||
plaintext ciphertext result recipients passphrase
|
||||
sign-with-key armor textmode)
|
||||
(gpg-encrypt
|
||||
plaintext ciphertext result recipients passphrase
|
||||
armor textmode))))
|
||||
(unless (gpg-encrypt-func
|
||||
sign ; passed in when using signencrypt
|
||||
text (setq cipher (current-buffer))
|
||||
mml2015-result-buffer
|
||||
(split-string
|
||||
(or
|
||||
(message-options-get 'message-recipients)
|
||||
(message-options-set 'message-recipients
|
||||
(read-string "Recipients: ")))
|
||||
"[ \f\t\n\r\v,]+")
|
||||
nil
|
||||
(message-options-get 'message-sender)
|
||||
t t) ; armor & textmode
|
||||
(unless (> (point-max) (point-min))
|
||||
(pop-to-buffer mml2015-result-buffer)
|
||||
(error "Encrypt error"))))
|
||||
(goto-char (point-min))
|
||||
(while (re-search-forward "\r+$" nil t)
|
||||
(replace-match "" t t))
|
||||
(set-buffer text)
|
||||
(delete-region (point-min) (point-max))
|
||||
(insert (format "Content-Type: multipart/encrypted; boundary=\"%s\";\n"
|
||||
boundary))
|
||||
(insert "\tprotocol=\"application/pgp-encrypted\"\n\n")
|
||||
(insert (format "--%s\n" boundary))
|
||||
(insert "Content-Type: application/pgp-encrypted\n\n")
|
||||
(insert "Version: 1\n\n")
|
||||
(insert (format "--%s\n" boundary))
|
||||
(insert "Content-Type: application/octet-stream\n\n")
|
||||
(insert-buffer-substring cipher)
|
||||
(goto-char (point-max))
|
||||
(insert (format "--%s--\n" boundary))
|
||||
(goto-char (point-max))))))
|
||||
|
||||
;;; pgg wrapper
|
||||
|
||||
(defvar pgg-default-user-id)
|
||||
|
|
|
|||
|
|
@ -64,9 +64,6 @@ from the document.")
|
|||
(body-end . "")
|
||||
(file-end . "")
|
||||
(subtype digest guess))
|
||||
(mime-parts
|
||||
(generate-head-function . nndoc-generate-mime-parts-head)
|
||||
(article-transform-function . nndoc-transform-mime-parts))
|
||||
(nsmail
|
||||
(article-begin . "^From - "))
|
||||
(news
|
||||
|
|
@ -77,6 +74,9 @@ from the document.")
|
|||
(mbox
|
||||
(article-begin-function . nndoc-mbox-article-begin)
|
||||
(body-end-function . nndoc-mbox-body-end))
|
||||
(mime-parts
|
||||
(generate-head-function . nndoc-generate-mime-parts-head)
|
||||
(article-transform-function . nndoc-transform-mime-parts))
|
||||
(babyl
|
||||
(article-begin . "\^_\^L *\n")
|
||||
(body-end . "\^_")
|
||||
|
|
|
|||
|
|
@ -822,12 +822,16 @@ The first string in ARGS can be a format string."
|
|||
(apply 'format args)))
|
||||
nil)
|
||||
|
||||
(defun nnheader-get-report (backend)
|
||||
(defun nnheader-get-report-string (backend)
|
||||
"Get the most recent report from BACKEND."
|
||||
(condition-case ()
|
||||
(nnheader-message 5 "%s" (symbol-value (intern (format "%s-status-string"
|
||||
backend))))
|
||||
(error (nnheader-message 5 ""))))
|
||||
(format "%s" (symbol-value (intern (format "%s-status-string"
|
||||
backend))))
|
||||
(error "")))
|
||||
|
||||
(defun nnheader-get-report (backend)
|
||||
"Get the most recent report from BACKEND."
|
||||
(nnheader-message 5 (nnheader-get-report-string backend)))
|
||||
|
||||
(defun nnheader-insert (format &rest args)
|
||||
"Clear the communication buffer and insert FORMAT and ARGS into the buffer.
|
||||
|
|
|
|||
|
|
@ -62,22 +62,23 @@ Values are `ssl', `network', `starttls' or `shell'.")
|
|||
(defvoo nnimap-inbox nil
|
||||
"The mail box where incoming mail arrives and should be split out of.")
|
||||
|
||||
(defvoo nnimap-split-methods nil
|
||||
"How mail is split.
|
||||
Uses the same syntax as nnmail-split-methods")
|
||||
|
||||
(defvoo nnimap-authenticator nil
|
||||
"How nnimap authenticate itself to the server.
|
||||
Possible choices are nil (use default methods) or `anonymous'.")
|
||||
|
||||
(defvoo nnimap-fetch-partial-articles nil
|
||||
"If non-nil, nnimap will fetch partial articles.
|
||||
If t, nnimap will fetch only the first part. If a string, it
|
||||
will fetch all parts that have types that match that string. A
|
||||
likely value would be \"text/\" to automatically fetch all
|
||||
textual parts.")
|
||||
|
||||
(defvoo nnimap-expunge t
|
||||
"If non-nil, expunge articles after deleting them.
|
||||
This is always done if the server supports UID EXPUNGE, but it's
|
||||
not done by default on servers that doesn't support that command.")
|
||||
|
||||
(defvoo nnimap-streaming t
|
||||
"If non-nil, try to use streaming commands with IMAP servers.
|
||||
Switching this off will make nnimap slower, but it helps with
|
||||
some servers.")
|
||||
|
||||
(defvoo nnimap-connection-alist nil)
|
||||
|
||||
|
|
@ -110,8 +111,6 @@ not done by default on servers that doesn't support that command.")
|
|||
(download "gnus-download")
|
||||
(forward "gnus-forward")))
|
||||
|
||||
(defvar nnimap-split-methods nil)
|
||||
|
||||
(defun nnimap-buffer ()
|
||||
(nnimap-find-process-buffer nntp-server-buffer))
|
||||
|
||||
|
|
@ -128,8 +127,7 @@ not done by default on servers that doesn't support that command.")
|
|||
(nnimap-article-ranges (gnus-compress-sequence articles))
|
||||
(format "(UID RFC822.SIZE BODYSTRUCTURE %s)"
|
||||
(format
|
||||
(if (member "IMAP4REV1"
|
||||
(nnimap-capabilities nnimap-object))
|
||||
(if (nnimap-ver4-p)
|
||||
"BODY.PEEK[HEADER.FIELDS %s]"
|
||||
"RFC822.HEADER.LINES %s")
|
||||
(append '(Subject From Date Message-Id
|
||||
|
|
@ -273,42 +271,50 @@ not done by default on servers that doesn't support that command.")
|
|||
(with-current-buffer (nnimap-make-process-buffer buffer)
|
||||
(let* ((coding-system-for-read 'binary)
|
||||
(coding-system-for-write 'binary)
|
||||
(port nil)
|
||||
(ports
|
||||
(cond
|
||||
((eq nnimap-stream 'network)
|
||||
(open-network-stream
|
||||
"*nnimap*" (current-buffer) nnimap-address
|
||||
(or nnimap-server-port
|
||||
(if (netrc-find-service-number "imap")
|
||||
"imap"
|
||||
"143")))
|
||||
(setq port
|
||||
(or nnimap-server-port
|
||||
(if (netrc-find-service-number "imap")
|
||||
"imap"
|
||||
"143"))))
|
||||
'("143" "imap"))
|
||||
((eq nnimap-stream 'shell)
|
||||
(nnimap-open-shell-stream
|
||||
"*nnimap*" (current-buffer) nnimap-address
|
||||
(or nnimap-server-port "imap"))
|
||||
(setq port (or nnimap-server-port "imap")))
|
||||
'("imap"))
|
||||
((eq nnimap-stream 'starttls)
|
||||
(starttls-open-stream
|
||||
"*nnimap*" (current-buffer) nnimap-address
|
||||
(or nnimap-server-port "imap"))
|
||||
(setq port (or nnimap-server-port "imap")))
|
||||
'("imap"))
|
||||
((eq nnimap-stream 'ssl)
|
||||
(open-tls-stream
|
||||
"*nnimap*" (current-buffer) nnimap-address
|
||||
(or nnimap-server-port
|
||||
(if (netrc-find-service-number "imaps")
|
||||
"imaps"
|
||||
"993")))
|
||||
(setq port
|
||||
(or nnimap-server-port
|
||||
(if (netrc-find-service-number "imaps")
|
||||
"imaps"
|
||||
"993"))))
|
||||
'("143" "993" "imap" "imaps"))))
|
||||
connection-result login-result credentials)
|
||||
(setf (nnimap-process nnimap-object)
|
||||
(get-buffer-process (current-buffer)))
|
||||
(when (and (nnimap-process nnimap-object)
|
||||
(memq (process-status (nnimap-process nnimap-object))
|
||||
'(open run)))
|
||||
(if (not (and (nnimap-process nnimap-object)
|
||||
(memq (process-status (nnimap-process nnimap-object))
|
||||
'(open run))))
|
||||
(nnheader-report 'nnimap "Unable to contact %s:%s via %s"
|
||||
nnimap-address port nnimap-stream)
|
||||
(gnus-set-process-query-on-exit-flag (nnimap-process nnimap-object) nil)
|
||||
(when (setq connection-result (nnimap-wait-for-connection))
|
||||
(if (not (setq connection-result (nnimap-wait-for-connection)))
|
||||
(nnheader-report 'nnimap
|
||||
"%s" (buffer-substring
|
||||
(point) (line-end-position)))
|
||||
(when (eq nnimap-stream 'starttls)
|
||||
(nnimap-command "STARTTLS")
|
||||
(starttls-negotiate (nnimap-process nnimap-object)))
|
||||
|
|
@ -370,7 +376,7 @@ not done by default on servers that doesn't support that command.")
|
|||
(deffoo nnimap-request-article (article &optional group server to-buffer)
|
||||
(with-current-buffer nntp-server-buffer
|
||||
(let ((result (nnimap-possibly-change-group group server))
|
||||
parts)
|
||||
parts structure)
|
||||
(when (stringp article)
|
||||
(setq article (nnimap-find-article-by-message-id group article)))
|
||||
(when (and result
|
||||
|
|
@ -378,36 +384,113 @@ not done by default on servers that doesn't support that command.")
|
|||
(erase-buffer)
|
||||
(with-current-buffer (nnimap-buffer)
|
||||
(erase-buffer)
|
||||
(when nnimap-fetch-partial-articles
|
||||
(if (eq nnimap-fetch-partial-articles t)
|
||||
(when gnus-fetch-partial-articles
|
||||
(if (eq gnus-fetch-partial-articles t)
|
||||
(setq parts '(1))
|
||||
(nnimap-command "UID FETCH %d (BODYSTRUCTURE)" article)
|
||||
(goto-char (point-min))
|
||||
(when (re-search-forward "FETCH.*BODYSTRUCTURE" nil t)
|
||||
(let ((structure (ignore-errors (read (current-buffer)))))
|
||||
(setq parts (nnimap-find-wanted-parts structure))))))
|
||||
(setq result
|
||||
(nnimap-command
|
||||
(if (member "IMAP4REV1" (nnimap-capabilities nnimap-object))
|
||||
"UID FETCH %d BODY.PEEK[]"
|
||||
"UID FETCH %d RFC822.PEEK")
|
||||
article))
|
||||
;; Check that we really got an article.
|
||||
(goto-char (point-min))
|
||||
(unless (looking-at "\\* [0-9]+ FETCH")
|
||||
(setq result nil)))
|
||||
(let ((buffer (nnimap-find-process-buffer (current-buffer))))
|
||||
(when (car result)
|
||||
(with-current-buffer (or to-buffer nntp-server-buffer)
|
||||
(insert-buffer-substring buffer)
|
||||
(goto-char (point-min))
|
||||
(let ((bytes (nnimap-get-length)))
|
||||
(delete-region (line-beginning-position)
|
||||
(progn (forward-line 1) (point)))
|
||||
(goto-char (+ (point) bytes))
|
||||
(delete-region (point) (point-max))
|
||||
(nnheader-ms-strip-cr))
|
||||
(cons group article))))))))
|
||||
(setq structure (ignore-errors (read (current-buffer)))
|
||||
parts (nnimap-find-wanted-parts structure)))))
|
||||
(when (if parts
|
||||
(nnimap-get-partial-article article parts structure)
|
||||
(nnimap-get-whole-article article))
|
||||
(let ((buffer (current-buffer)))
|
||||
(with-current-buffer (or to-buffer nntp-server-buffer)
|
||||
(erase-buffer)
|
||||
(insert-buffer-substring buffer)
|
||||
(nnheader-ms-strip-cr)
|
||||
(cons group article)))))))))
|
||||
|
||||
(defun nnimap-get-whole-article (article)
|
||||
(let ((result
|
||||
(nnimap-command
|
||||
(if (nnimap-ver4-p)
|
||||
"UID FETCH %d BODY.PEEK[]"
|
||||
"UID FETCH %d RFC822.PEEK")
|
||||
article)))
|
||||
;; Check that we really got an article.
|
||||
(goto-char (point-min))
|
||||
(unless (looking-at "\\* [0-9]+ FETCH")
|
||||
(setq result nil))
|
||||
(when result
|
||||
(goto-char (point-min))
|
||||
(let ((bytes (nnimap-get-length)))
|
||||
(delete-region (line-beginning-position)
|
||||
(progn (forward-line 1) (point)))
|
||||
(goto-char (+ (point) bytes))
|
||||
(delete-region (point) (point-max)))
|
||||
t)))
|
||||
|
||||
(defun nnimap-ver4-p ()
|
||||
(member "IMAP4REV1" (nnimap-capabilities nnimap-object)))
|
||||
|
||||
(defun nnimap-get-partial-article (article parts structure)
|
||||
(let ((result
|
||||
(nnimap-command
|
||||
"UID FETCH %d (%s %s)"
|
||||
article
|
||||
(if (nnimap-ver4-p)
|
||||
"BODY.PEEK[HEADER]"
|
||||
"RFC822.HEADER")
|
||||
(if (nnimap-ver4-p)
|
||||
(mapconcat (lambda (part)
|
||||
(format "BODY.PEEK[%s]" part))
|
||||
parts " ")
|
||||
(mapconcat (lambda (part)
|
||||
(format "RFC822.PEEK[%s]" part))
|
||||
parts " ")))))
|
||||
(when result
|
||||
(nnimap-convert-partial-article structure))))
|
||||
|
||||
(defun nnimap-convert-partial-article (structure)
|
||||
;; First just skip past the headers.
|
||||
(goto-char (point-min))
|
||||
(let ((bytes (nnimap-get-length))
|
||||
id parts)
|
||||
;; Delete "FETCH" line.
|
||||
(delete-region (line-beginning-position)
|
||||
(progn (forward-line 1) (point)))
|
||||
(goto-char (+ (point) bytes))
|
||||
;; Collect all the body parts.
|
||||
(while (looking-at ".*BODY\\[\\([.0-9]+\\)\\]")
|
||||
(setq id (match-string 1)
|
||||
bytes (nnimap-get-length))
|
||||
(beginning-of-line)
|
||||
(delete-region (point) (progn (forward-line 1) (point)))
|
||||
(push (list id (buffer-substring (point) (+ (point) bytes)))
|
||||
parts)
|
||||
(delete-region (point) (+ (point) bytes)))
|
||||
;; Delete trailing junk.
|
||||
(delete-region (point) (point-max))
|
||||
;; Now insert all the parts again where they fit in the structure.
|
||||
(nnimap-insert-partial-structure structure parts)
|
||||
t))
|
||||
|
||||
(defun nnimap-insert-partial-structure (structure parts &optional subp)
|
||||
(let ((type (car (last structure 4)))
|
||||
(boundary (cadr (member "BOUNDARY" (car (last structure 3))))))
|
||||
(when subp
|
||||
(insert (format "Content-type: multipart/%s; boundary=%S\n\n"
|
||||
(downcase type) boundary)))
|
||||
(while (not (stringp (car structure)))
|
||||
(insert "\n--" boundary "\n")
|
||||
(if (consp (caar structure))
|
||||
(nnimap-insert-partial-structure (pop structure) parts t)
|
||||
(let ((bit (pop structure)))
|
||||
(insert (format "Content-type: %s/%s"
|
||||
(downcase (nth 0 bit))
|
||||
(downcase (nth 1 bit))))
|
||||
(if (member "CHARSET" (nth 2 bit))
|
||||
(insert (format
|
||||
"; charset=%S\n" (cadr (member "CHARSET" (nth 2 bit)))))
|
||||
(insert "\n"))
|
||||
(insert (format "Content-transfer-encoding: %s\n"
|
||||
(nth 5 bit)))
|
||||
(insert "\n")
|
||||
(when (assoc (nth 9 bit) parts)
|
||||
(insert (cadr (assoc (nth 9 bit) parts)))))))
|
||||
(insert "\n--" boundary "--\n")))
|
||||
|
||||
(defun nnimap-find-wanted-parts (structure)
|
||||
(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.")
|
|||
(number-to-string num)
|
||||
(format "%s.%s" prefix num)))
|
||||
parts)
|
||||
(let ((type (format "%s/%s" (nth 0 sub) (nth 1 sub))))
|
||||
(when (string-match nnimap-fetch-partial-articles type)
|
||||
(push (if (string= prefix "")
|
||||
(let ((type (format "%s/%s" (nth 0 sub) (nth 1 sub)))
|
||||
(id (if (string= prefix "")
|
||||
(number-to-string num)
|
||||
(format "%s.%s" prefix num))
|
||||
parts)))
|
||||
(incf num))))
|
||||
(format "%s.%s" prefix num))))
|
||||
(setcar (nthcdr 9 sub) id)
|
||||
(when (string-match gnus-fetch-partial-articles type)
|
||||
(push id parts))))
|
||||
(incf num)))
|
||||
(nreverse parts)))
|
||||
|
||||
(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.")
|
|||
(nnimap-send-command "UID FETCH %d:* FLAGS" start)
|
||||
start
|
||||
(car elem))
|
||||
sequences))))
|
||||
sequences)))
|
||||
;; Some servers apparently can't have many outstanding
|
||||
;; commands, so throttle them.
|
||||
(when (and (not nnimap-streaming)
|
||||
(car sequences))
|
||||
(nnimap-wait-for-response (caar sequences))))
|
||||
sequences))))
|
||||
|
||||
(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.")
|
|||
(nnimap-possibly-change-group nil server))
|
||||
(with-current-buffer (nnimap-buffer)
|
||||
;; Wait for the final data to trickle in.
|
||||
(nnimap-wait-for-response (cadar sequences))
|
||||
;; Now we should have all the data we need, no matter whether
|
||||
;; we're QRESYNCING, fetching all the flags from scratch, or
|
||||
;; just fetching the last 100 flags per group.
|
||||
(nnimap-update-infos (nnimap-flags-to-marks
|
||||
(nnimap-parse-flags
|
||||
(nreverse sequences)))
|
||||
infos)
|
||||
;; Finally, just return something resembling an active file in
|
||||
;; the nntp buffer, so that the agent can save the info, too.
|
||||
(with-current-buffer nntp-server-buffer
|
||||
(erase-buffer)
|
||||
(dolist (info infos)
|
||||
(let* ((group (gnus-info-group info))
|
||||
(active (gnus-active group)))
|
||||
(when active
|
||||
(insert (format "%S %d %d y\n"
|
||||
(gnus-group-real-name group)
|
||||
(cdr active)
|
||||
(car active))))))))))
|
||||
(when (nnimap-wait-for-response (cadar sequences))
|
||||
;; Now we should have all the data we need, no matter whether
|
||||
;; we're QRESYNCING, fetching all the flags from scratch, or
|
||||
;; just fetching the last 100 flags per group.
|
||||
(nnimap-update-infos (nnimap-flags-to-marks
|
||||
(nnimap-parse-flags
|
||||
(nreverse sequences)))
|
||||
infos)
|
||||
;; Finally, just return something resembling an active file in
|
||||
;; the nntp buffer, so that the agent can save the info, too.
|
||||
(with-current-buffer nntp-server-buffer
|
||||
(erase-buffer)
|
||||
(dolist (info infos)
|
||||
(let* ((group (gnus-info-group info))
|
||||
(active (gnus-active group)))
|
||||
(when active
|
||||
(insert (format "%S %d %d y\n"
|
||||
(gnus-group-real-name group)
|
||||
(cdr active)
|
||||
(car active)))))))))))
|
||||
|
||||
(defun nnimap-update-infos (flags infos)
|
||||
(dolist (info infos)
|
||||
|
|
@ -1045,17 +1134,22 @@ not done by default on servers that doesn't support that command.")
|
|||
(match-string 1))))
|
||||
|
||||
(defun nnimap-wait-for-response (sequence &optional messagep)
|
||||
(let ((process (get-buffer-process (current-buffer))))
|
||||
(let ((process (get-buffer-process (current-buffer)))
|
||||
openp)
|
||||
(goto-char (point-max))
|
||||
(while (and (memq (process-status process)
|
||||
'(open run))
|
||||
(not (re-search-backward (format "^%d .*\n" sequence)
|
||||
(max (point-min) (- (point) 500))
|
||||
t)))
|
||||
(while (and (setq openp (memq (process-status process)
|
||||
'(open run)))
|
||||
(not (re-search-backward
|
||||
(format "^%d .*\n" sequence)
|
||||
(if nnimap-streaming
|
||||
(max (point-min) (- (point) 500))
|
||||
(point-min))
|
||||
t)))
|
||||
(when messagep
|
||||
(message "Read %dKB" (/ (buffer-size) 1000)))
|
||||
(nnheader-accept-process-output process)
|
||||
(goto-char (point-max)))))
|
||||
(goto-char (point-max)))
|
||||
openp))
|
||||
|
||||
(defun nnimap-parse-response ()
|
||||
(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.")
|
|||
(nnimap-article-ranges articles)
|
||||
(format "(UID %s%s)"
|
||||
(format
|
||||
(if (member "IMAP4REV1"
|
||||
(nnimap-capabilities nnimap-object))
|
||||
(if (nnimap-ver4-p)
|
||||
"BODY.PEEK[HEADER] BODY.PEEK"
|
||||
"RFC822.PEEK"))
|
||||
(if nnimap-split-download-body-default
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue