;;; gnus-art.el --- article mode commands for Gnus
;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005 Free Software Foundation, Inc.
+;; 2005, 2006 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news
(autoload 'gnus-button-reply "gnus-msg" nil t)
(autoload 'parse-time-string "parse-time" nil nil)
(autoload 'ansi-color-apply-on-region "ansi-color")
+(autoload 'mm-url-insert-file-contents-external "mm-url")
(defgroup gnus-article nil
"Article display."
This can also be a list of regexps. In that case, it will be checked
from head to tail looking for a separator. Searches will be done from
the end of the buffer."
- :type '(repeat string)
+ :type '(choice :format "%{%t%}: %[Value Menu%]\n%v"
+ (regexp)
+ (repeat :tag "List of regexp" regexp))
:group 'gnus-article-signature)
(defcustom gnus-signature-limit nil
(function-item gnus-summary-save-in-file)
(function-item gnus-summary-save-body-in-file)
(function-item gnus-summary-save-in-vm)
- (function-item gnus-summary-write-to-file)))
+ (function-item gnus-summary-write-to-file)
+ (function)))
(defcustom gnus-rmail-save-name 'gnus-plain-save-name
"A function generating a file name to save articles in Rmail format.
(make-obsolete-variable 'gnus-article-hide-pgp-hook
"This variable is obsolete in Gnus 5.10.")
-(defcustom gnus-article-button-face 'bold
+(defface gnus-button
+ '((t (:weight bold)))
+ "Face used for highlighting a button in the article buffer."
+ :group 'gnus-article-buttons)
+
+(defcustom gnus-article-button-face 'gnus-button
"Face used for highlighting buttons in the article buffer.
An article button is a piece of text that you can activate by pressing
"List of MIME types that should be given buttons when rendered inline.
If set, this variable overrides `gnus-unbuttonized-mime-types'.
To see e.g. security buttons you could set this to
-`(\"multipart/signed\")'.
+`(\"multipart/signed\")'. You could also add \"multipart/alternative\" to
+this list to display radio buttons that allow you to choose one of two
+media types those mails include. See also `mm-discouraged-alternatives'.
This variable is only used when `gnus-inhibit-mime-unbuttonizing' is nil."
:version "22.1"
:group 'gnus-article-mime
(defcustom gnus-mime-action-alist
'(("save to file" . gnus-mime-save-part)
("save and strip" . gnus-mime-save-part-and-strip)
+ ("replace with file" . gnus-mime-replace-part)
("delete part" . gnus-mime-delete-part)
("display as text" . gnus-mime-inline-part)
("view the part" . gnus-mime-view-part)
'(choice (const :tag "Off" nil)
(const :tag "On" t)
(const :tag "Header" head)
+ (const :tag "First" first)
(const :tag "Last" last)
(integer :tag "Less")
(repeat :tag "Groups" regexp)
(defcustom gnus-treat-highlight-signature '(or t (typep "text/x-vcard"))
"Highlight the signature.
-Valid values are nil, t, `head', `last', an integer or a predicate.
-See Info node `(gnus)Customizing Articles'."
+Valid values are nil, t, `head', `first', `last', an integer or a
+predicate. See Info node `(gnus)Customizing Articles'."
:group 'gnus-article-treat
:link '(custom-manual "(gnus)Customizing Articles")
:type gnus-article-treat-custom)
(defcustom gnus-treat-buttonize 100000
"Add buttons.
-Valid values are nil, t, `head', `last', an integer or a predicate.
-See Info node `(gnus)Customizing Articles'."
+Valid values are nil, t, `head', `first', `last', an integer or a
+predicate. See Info node `(gnus)Customizing Articles'."
:group 'gnus-article-treat
:link '(custom-manual "(gnus)Customizing Articles")
:type gnus-article-treat-custom)
(defcustom gnus-treat-buttonize-head 'head
"Add buttons to the head.
-Valid values are nil, t, `head', `last', an integer or a predicate.
-See Info node `(gnus)Customizing Articles' for details."
+Valid values are nil, t, `head', `first', `last', an integer or a
+predicate. See Info node `(gnus)Customizing Articles'."
:group 'gnus-article-treat
:link '(custom-manual "(gnus)Customizing Articles")
:type gnus-article-treat-head-custom)
(featurep 'xemacs))
50000)
"Emphasize text.
-Valid values are nil, t, `head', `last', an integer or a predicate.
-See Info node `(gnus)Customizing Articles' for details."
+Valid values are nil, t, `head', `first', `last', an integer or a
+predicate. See Info node `(gnus)Customizing Articles'."
:group 'gnus-article-treat
:link '(custom-manual "(gnus)Customizing Articles")
:type gnus-article-treat-custom)
(defcustom gnus-treat-strip-cr nil
"Remove carriage returns.
-Valid values are nil, t, `head', `last', an integer or a predicate.
-See Info node `(gnus)Customizing Articles' for details."
+Valid values are nil, t, `head', `first', `last', an integer or a
+predicate. See Info node `(gnus)Customizing Articles'."
:version "22.1"
:group 'gnus-article-treat
:link '(custom-manual "(gnus)Customizing Articles")
(defcustom gnus-treat-unsplit-urls nil
"Remove newlines from within URLs.
-Valid values are nil, t, `head', `last', an integer or a predicate.
-See Info node `(gnus)Customizing Articles' for details."
+Valid values are nil, t, `head', `first', `last', an integer or a
+predicate. See Info node `(gnus)Customizing Articles'."
:version "22.1"
:group 'gnus-article-treat
:link '(custom-manual "(gnus)Customizing Articles")
(defcustom gnus-treat-leading-whitespace nil
"Remove leading whitespace in headers.
-Valid values are nil, t, `head', `last', an integer or a predicate.
-See Info node `(gnus)Customizing Articles' for details."
+Valid values are nil, t, `head', `first', `last', an integer or a
+predicate. See Info node `(gnus)Customizing Articles'."
:version "22.1"
:group 'gnus-article-treat
:link '(custom-manual "(gnus)Customizing Articles")
(defcustom gnus-treat-hide-headers 'head
"Hide headers.
-Valid values are nil, t, `head', `last', an integer or a predicate.
-See Info node `(gnus)Customizing Articles' for details."
+Valid values are nil, t, `head', `first', `last', an integer or a
+predicate. See Info node `(gnus)Customizing Articles'."
:group 'gnus-article-treat
:link '(custom-manual "(gnus)Customizing Articles")
:type gnus-article-treat-head-custom)
(defcustom gnus-treat-hide-boring-headers nil
"Hide boring headers.
-Valid values are nil, t, `head', `last', an integer or a predicate.
-See Info node `(gnus)Customizing Articles' for details."
+Valid values are nil, t, `head', `first', `last', an integer or a
+predicate. See Info node `(gnus)Customizing Articles'."
:group 'gnus-article-treat
:link '(custom-manual "(gnus)Customizing Articles")
:type gnus-article-treat-head-custom)
(defcustom gnus-treat-hide-signature nil
"Hide the signature.
-Valid values are nil, t, `head', `last', an integer or a predicate.
-See Info node `(gnus)Customizing Articles' for details."
+Valid values are nil, t, `head', `first', `last', an integer or a
+predicate. See Info node `(gnus)Customizing Articles'."
:group 'gnus-article-treat
:link '(custom-manual "(gnus)Customizing Articles")
:type gnus-article-treat-custom)
(defcustom gnus-treat-fill-article nil
"Fill the article.
-Valid values are nil, t, `head', `last', an integer or a predicate.
-See Info node `(gnus)Customizing Articles' for details."
+Valid values are nil, t, `head', `first', `last', an integer or a
+predicate. See Info node `(gnus)Customizing Articles'."
:group 'gnus-article-treat
:link '(custom-manual "(gnus)Customizing Articles")
:type gnus-article-treat-custom)
(defcustom gnus-treat-hide-citation nil
"Hide cited text.
-Valid values are nil, t, `head', `last', an integer or a predicate.
-See Info node `(gnus)Customizing Articles' for details."
+Valid values are nil, t, `head', `first', `last', an integer or a
+predicate. See Info node `(gnus)Customizing Articles'."
:group 'gnus-article-treat
:link '(custom-manual "(gnus)Customizing Articles")
:type gnus-article-treat-custom)
(defcustom gnus-treat-hide-citation-maybe nil
"Hide cited text.
-Valid values are nil, t, `head', `last', an integer or a predicate.
-See Info node `(gnus)Customizing Articles' for details."
+Valid values are nil, t, `head', `first', `last', an integer or a
+predicate. See Info node `(gnus)Customizing Articles'."
:group 'gnus-article-treat
:link '(custom-manual "(gnus)Customizing Articles")
:type gnus-article-treat-custom)
(defcustom gnus-treat-strip-list-identifiers 'head
"Strip list identifiers from `gnus-list-identifiers`.
-Valid values are nil, t, `head', `last', an integer or a predicate.
-See Info node `(gnus)Customizing Articles' for details."
+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")
(defcustom gnus-treat-strip-pem nil
"Strip PEM signatures.
-Valid values are nil, t, `head', `last', an integer or a predicate.
-See Info node `(gnus)Customizing Articles' for details."
+Valid values are nil, t, `head', `first', `last', an integer or a
+predicate. See Info node `(gnus)Customizing Articles'."
:group 'gnus-article-treat
:link '(custom-manual "(gnus)Customizing Articles")
:type gnus-article-treat-custom)
(defcustom gnus-treat-strip-banner t
"Strip banners from articles.
The banner to be stripped is specified in the `banner' group parameter.
-Valid values are nil, t, `head', `last', an integer or a predicate.
-See Info node `(gnus)Customizing Articles' for details."
+Valid values are nil, t, `head', `first', `last', an integer or a
+predicate. See Info node `(gnus)Customizing Articles'."
:group 'gnus-article-treat
:link '(custom-manual "(gnus)Customizing Articles")
:type gnus-article-treat-custom)
(defcustom gnus-treat-highlight-headers 'head
"Highlight the headers.
-Valid values are nil, t, `head', `last', an integer or a predicate.
-See Info node `(gnus)Customizing Articles' for details."
+Valid values are nil, t, `head', `first', `last', an integer or a
+predicate. See Info node `(gnus)Customizing Articles'."
:group 'gnus-article-treat
:link '(custom-manual "(gnus)Customizing Articles")
:type gnus-article-treat-head-custom)
(defcustom gnus-treat-highlight-citation t
"Highlight cited text.
-Valid values are nil, t, `head', `last', an integer or a predicate.
-See Info node `(gnus)Customizing Articles' for details."
+Valid values are nil, t, `head', `first', `last', an integer or a
+predicate. See Info node `(gnus)Customizing Articles'."
:group 'gnus-article-treat
:link '(custom-manual "(gnus)Customizing Articles")
:type gnus-article-treat-custom)
(defcustom gnus-treat-date-ut nil
"Display the Date in UT (GMT).
-Valid values are nil, t, `head', `last', an integer or a predicate.
-See Info node `(gnus)Customizing Articles' for details."
+Valid values are nil, t, `head', `first', `last', an integer or a
+predicate. See Info node `(gnus)Customizing Articles'."
:group 'gnus-article-treat
:link '(custom-manual "(gnus)Customizing Articles")
:type gnus-article-treat-head-custom)
(defcustom gnus-treat-date-local nil
"Display the Date in the local timezone.
-Valid values are nil, t, `head', `last', an integer or a predicate.
-See Info node `(gnus)Customizing Articles' for details."
+Valid values are nil, t, `head', `first', `last', an integer or a
+predicate. See Info node `(gnus)Customizing Articles'."
:group 'gnus-article-treat
:link '(custom-manual "(gnus)Customizing Articles")
:type gnus-article-treat-head-custom)
(defcustom gnus-treat-date-english nil
"Display the Date in a format that can be read aloud in English.
-Valid values are nil, t, `head', `last', an integer or a predicate.
-See Info node `(gnus)Customizing Articles' for details."
+Valid values are nil, t, `head', `first', `last', an integer or a
+predicate. See Info node `(gnus)Customizing Articles'."
:version "22.1"
:group 'gnus-article-treat
:link '(custom-manual "(gnus)Customizing Articles")
(defcustom gnus-treat-date-lapsed nil
"Display the Date header in a way that says how much time has elapsed.
-Valid values are nil, t, `head', `last', an integer or a predicate.
-See Info node `(gnus)Customizing Articles' for details."
+Valid values are nil, t, `head', `first', `last', an integer or a
+predicate. See Info node `(gnus)Customizing Articles'."
:group 'gnus-article-treat
:link '(custom-manual "(gnus)Customizing Articles")
:type gnus-article-treat-head-custom)
(defcustom gnus-treat-date-original nil
"Display the date in the original timezone.
-Valid values are nil, t, `head', `last', an integer or a predicate.
-See Info node `(gnus)Customizing Articles' for details."
+Valid values are nil, t, `head', `first', `last', an integer or a
+predicate. See Info node `(gnus)Customizing Articles'."
:group 'gnus-article-treat
:link '(custom-manual "(gnus)Customizing Articles")
:type gnus-article-treat-head-custom)
(defcustom gnus-treat-date-iso8601 nil
"Display the date in the ISO8601 format.
-Valid values are nil, t, `head', `last', an integer or a predicate.
-See Info node `(gnus)Customizing Articles' for details."
+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")
(defcustom gnus-treat-date-user-defined nil
"Display the date in a user-defined format.
The format is defined by the `gnus-article-time-format' variable.
-Valid values are nil, t, `head', `last', an integer or a predicate.
-See Info node `(gnus)Customizing Articles' for details."
+Valid values are nil, t, `head', `first', `last', an integer or a
+predicate. See Info node `(gnus)Customizing Articles'."
:group 'gnus-article-treat
:link '(custom-manual "(gnus)Customizing Articles")
:type gnus-article-treat-head-custom)
(defcustom gnus-treat-strip-headers-in-body t
"Strip the X-No-Archive header line from the beginning of the body.
-Valid values are nil, t, `head', `last', an integer or a predicate.
-See Info node `(gnus)Customizing Articles' for details."
+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")
(defcustom gnus-treat-strip-trailing-blank-lines nil
"Strip trailing blank lines.
-Valid values are nil, t, `head', `last', an integer or a predicate.
-See Info node `(gnus)Customizing Articles' for details."
+Valid values are nil, t, `head', `first', `last', an integer or a
+predicate. See Info node `(gnus)Customizing Articles'.
+
+When set to t, it also strips trailing blanks in all MIME parts.
+Consider to use `last' instead."
:group 'gnus-article-treat
:link '(custom-manual "(gnus)Customizing Articles")
:type gnus-article-treat-custom)
(defcustom gnus-treat-strip-leading-blank-lines nil
"Strip leading blank lines.
-Valid values are nil, t, `head', `last', an integer or a predicate.
-See Info node `(gnus)Customizing Articles' for details."
+Valid values are nil, t, `head', `first', `last', an integer or a
+predicate. See Info node `(gnus)Customizing Articles'.
+
+When set to t, it also strips trailing blanks in all MIME parts."
:group 'gnus-article-treat
:link '(custom-manual "(gnus)Customizing Articles")
:type gnus-article-treat-custom)
(defcustom gnus-treat-strip-multiple-blank-lines nil
"Strip multiple blank lines.
-Valid values are nil, t, `head', `last', an integer or a predicate.
-See Info node `(gnus)Customizing Articles' for details."
+Valid values are nil, t, `head', `first', `last', an integer or a
+predicate. See Info node `(gnus)Customizing Articles'."
:group 'gnus-article-treat
:link '(custom-manual "(gnus)Customizing Articles")
:type gnus-article-treat-custom)
(defcustom gnus-treat-unfold-headers 'head
"Unfold folded header lines.
-Valid values are nil, t, `head', `last', an integer or a predicate.
-See Info node `(gnus)Customizing Articles' for details."
+Valid values are nil, t, `head', `first', `last', an integer or a
+predicate. See Info node `(gnus)Customizing Articles'."
:version "22.1"
:group 'gnus-article-treat
:link '(custom-manual "(gnus)Customizing Articles")
(defcustom gnus-treat-fold-headers nil
"Fold headers.
-Valid values are nil, t, `head', `last', an integer or a predicate.
-See Info node `(gnus)Customizing Articles' for details."
+Valid values are nil, t, `head', `first', `last', an integer or a
+predicate. See Info node `(gnus)Customizing Articles'."
:version "22.1"
:group 'gnus-article-treat
:link '(custom-manual "(gnus)Customizing Articles")
(defcustom gnus-treat-fold-newsgroups 'head
"Fold the Newsgroups and Followup-To headers.
-Valid values are nil, t, `head', `last', an integer or a predicate.
-See Info node `(gnus)Customizing Articles' for details."
+Valid values are nil, t, `head', `first', `last', an integer or a
+predicate. See Info node `(gnus)Customizing Articles'."
:version "22.1"
:group 'gnus-article-treat
:link '(custom-manual "(gnus)Customizing Articles")
(defcustom gnus-treat-overstrike t
"Treat overstrike highlighting.
-Valid values are nil, t, `head', `last', an integer or a predicate.
-See Info node `(gnus)Customizing Articles' for details."
+Valid values are nil, t, `head', `first', `last', an integer or a
+predicate. See Info node `(gnus)Customizing Articles'."
:group 'gnus-article-treat
:link '(custom-manual "(gnus)Customizing Articles")
:type gnus-article-treat-custom)
(defcustom gnus-treat-ansi-sequences (if (locate-library "ansi-color") t)
"Treat ANSI SGR control sequences.
-Valid values are nil, t, `head', `last', an integer or a predicate.
-See Info node `(gnus)Customizing Articles' for details."
+Valid values are nil, t, `head', `first', `last', an integer or a
+predicate. See Info node `(gnus)Customizing Articles'."
:group 'gnus-article-treat
:link '(custom-manual "(gnus)Customizing Articles")
:type gnus-article-treat-custom)
(featurep 'xface)))
'head)
"Display X-Face headers.
-Valid values are nil, t, `head', `last', an integer or a predicate.
-See Info node `(gnus)Customizing Articles' and Info node
-`(gnus)X-Face' for details."
+Valid values are nil, t, `head', `first', `last', an integer or a
+predicate. See Info node `(gnus)Customizing Articles' and Info
+node `(gnus)X-Face' for details."
:group 'gnus-article-treat
:version "21.1"
:link '(custom-manual "(gnus)Customizing Articles")
(featurep 'png)))
'head)
"Display Face headers.
-Valid values are nil, t, `head', `last', an integer or a predicate.
-See Info node `(gnus)Customizing Articles' and Info node
-`(gnus)X-Face' for details."
+Valid values are nil, t, `head', `first', `last', an integer or a
+predicate. See Info node `(gnus)Customizing Articles' and Info
+node `(gnus)X-Face' for details."
:group 'gnus-article-treat
:version "22.1"
:link '(custom-manual "(gnus)Customizing Articles")
(image-type-available-p 'pbm)))
t nil)
"Display smileys.
-Valid values are nil, t, `head', `last', an integer or a predicate.
-See Info node `(gnus)Customizing Articles' and Info node
-`(gnus)Smileys' for details."
+Valid values are nil, t, `head', `first', `last', an integer or a
+predicate. See Info node `(gnus)Customizing Articles' and Info
+node `(gnus)Smileys' for details."
:group 'gnus-article-treat
:version "21.1"
:link '(custom-manual "(gnus)Customizing Articles")
(gnus-picons-installed-p))
'head nil)
"Display picons in the From header.
-Valid values are nil, t, `head', `last', an integer or a predicate.
-See Info node `(gnus)Customizing Articles' and Info node
-`(gnus)Picons' for details."
+Valid values are nil, t, `head', `first', `last', an integer or a
+predicate. See Info node `(gnus)Customizing Articles' and Info
+node `(gnus)Picons' for details."
:version "22.1"
:group 'gnus-article-treat
:group 'gnus-picon
(gnus-picons-installed-p))
'head nil)
"Display picons in To and Cc headers.
-Valid values are nil, t, `head', `last', an integer or a predicate.
-See Info node `(gnus)Customizing Articles' and Info node
-`(gnus)Picons' for details."
+Valid values are nil, t, `head', `first', `last', an integer or a
+predicate. See Info node `(gnus)Customizing Articles' and Info
+node `(gnus)Picons' for details."
:version "22.1"
:group 'gnus-article-treat
:group 'gnus-picon
(gnus-picons-installed-p))
'head nil)
"Display picons in the Newsgroups and Followup-To headers.
-Valid values are nil, t, `head', `last', an integer or a predicate.
-See Info node `(gnus)Customizing Articles' and Info node
-`(gnus)Picons' for details."
+Valid values are nil, t, `head', `first', `last', an integer or a
+predicate. See Info node `(gnus)Customizing Articles' and Info
+node `(gnus)Picons' for details."
:version "22.1"
:group 'gnus-article-treat
:group 'gnus-picon
(defcustom gnus-treat-capitalize-sentences nil
"Capitalize sentence-starting words.
-Valid values are nil, t, `head', `last', an integer or a predicate.
-See Info node `(gnus)Customizing Articles' for details."
+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")
(defcustom gnus-treat-wash-html nil
"Format as HTML.
-Valid values are nil, t, `head', `last', an integer or a predicate.
-See Info node `(gnus)Customizing Articles' for details."
+Valid values are nil, t, `head', `first', `last', an integer or a
+predicate. See Info node `(gnus)Customizing Articles'."
:version "22.1"
:group 'gnus-article-treat
:link '(custom-manual "(gnus)Customizing Articles")
(defcustom gnus-treat-fill-long-lines nil
"Fill long lines.
-Valid values are nil, t, `head', `last', an integer or a predicate.
-See Info node `(gnus)Customizing Articles' for details."
+Valid values are nil, t, `head', `first', `last', an integer or a
+predicate. See Info node `(gnus)Customizing Articles'."
:group 'gnus-article-treat
: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', `last', an integer or a predicate.
-See Info node `(gnus)Customizing Articles' for details."
+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")
(defcustom gnus-treat-translate nil
"Translate articles from one language to another.
-Valid values are nil, t, `head', `last', an integer or a predicate.
-See Info node `(gnus)Customizing Articles' for details."
+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")
(defcustom gnus-treat-x-pgp-sig nil
"Verify X-PGP-Sig.
To automatically treat X-PGP-Sig, set it to head.
-Valid values are nil, t, `head', `last', an integer or a predicate.
-See Info node `(gnus)Customizing Articles' for details."
+Valid values are nil, t, `head', `first', `last', an integer or a
+predicate. See Info node `(gnus)Customizing Articles'."
:version "22.1"
:group 'gnus-article-treat
:group 'mime-security
"Delete text of TYPE in the current buffer."
(save-excursion
(let ((b (point-min)))
- (while (setq b (text-property-any b (point-max) 'article-type type))
- (delete-region
- b (or (text-property-not-all b (point-max) 'article-type type)
- (point-max)))))))
+ (if (eq type 'multipart)
+ ;; Remove MIME buttons associated with multipart/alternative parts.
+ (progn
+ (goto-char b)
+ (while (if (get-text-property (point) 'gnus-part)
+ (setq b (point))
+ (when (setq b (next-single-property-change (point)
+ 'gnus-part))
+ (goto-char b)
+ t))
+ (end-of-line)
+ (skip-chars-forward "\n")
+ (when (eq (get-text-property b 'article-type) 'multipart)
+ (delete-region b (point)))))
+ (while (setq b (text-property-any b (point-max) 'article-type type))
+ (delete-region
+ b (or (text-property-not-all b (point-max) 'article-type type)
+ (point-max))))))))
(defun gnus-article-delete-invisible-text ()
"Delete all invisible text in the current buffer."
(error))
gnus-newsgroup-ignored-charsets))
ct cte ctl charset format)
- (save-excursion
- (save-restriction
- (article-narrow-to-head)
- (setq ct (message-fetch-field "Content-Type" t)
- cte (message-fetch-field "Content-Transfer-Encoding" t)
- ctl (and ct (ignore-errors
- (mail-header-parse-content-type ct)))
- charset (cond
- (prompt
- (mm-read-coding-system "Charset to decode: "))
- (ctl
- (mail-content-type-get ctl 'charset)))
- format (and ctl (mail-content-type-get ctl 'format)))
- (when cte
- (setq cte (mail-header-strip cte)))
- (if (and ctl (not (string-match "/" (car ctl))))
- (setq ctl nil))
- (goto-char (point-max)))
- (forward-line 1)
- (save-restriction
- (narrow-to-region (point) (point-max))
- (when (and (eq mail-parse-charset 'gnus-decoded)
- (eq (mm-body-7-or-8) '8bit))
- ;; The text code could have been decoded.
- (setq charset mail-parse-charset))
- (when (and (or (not ctl)
- (equal (car ctl) "text/plain"))
- (not format)) ;; article with format will decode later.
- (mm-decode-body
- charset (and cte (intern (downcase
- (gnus-strip-whitespace cte))))
- (car ctl)))))))
+ (save-excursion
+ (save-restriction
+ (article-narrow-to-head)
+ (setq ct (message-fetch-field "Content-Type" t)
+ cte (message-fetch-field "Content-Transfer-Encoding" t)
+ ctl (and ct (mail-header-parse-content-type ct))
+ charset (cond
+ (prompt
+ (mm-read-coding-system "Charset to decode: "))
+ (ctl
+ (mail-content-type-get ctl 'charset)))
+ format (and ctl (mail-content-type-get ctl 'format)))
+ (when cte
+ (setq cte (mail-header-strip cte)))
+ (if (and ctl (not (string-match "/" (car ctl))))
+ (setq ctl nil))
+ (goto-char (point-max)))
+ (forward-line 1)
+ (save-restriction
+ (narrow-to-region (point) (point-max))
+ (when (and (eq mail-parse-charset 'gnus-decoded)
+ (eq (mm-body-7-or-8) '8bit))
+ ;; The text code could have been decoded.
+ (setq charset mail-parse-charset))
+ (when (and (or (not ctl)
+ (equal (car ctl) "text/plain"))
+ (not format)) ;; article with format will decode later.
+ (mm-decode-body
+ charset (and cte (intern (downcase
+ (gnus-strip-whitespace cte))))
+ (car ctl)))))))
(defun article-decode-encoded-words ()
"Remove encoded-word encoding from headers."
(autoload 'idna-to-unicode "idna")
(defun article-decode-idna-rhs ()
- "Decode IDNA strings in RHS in From:, To: and Cc: headers in current buffer."
+ "Decode IDNA strings in RHS in various headers in current buffer.
+The following headers are decoded: From:, To:, Cc:, Reply-To:,
+Mail-Reply-To: and Mail-Followup-To:."
(when gnus-use-idna
(save-restriction
(let ((inhibit-point-motion-hooks t)
(inhibit-read-only t))
(article-narrow-to-head)
(goto-char (point-min))
- (while (re-search-forward "@.*\\(xn--[-A-Za-z0-9.]*\\)[ \t\n\r,>]" nil t)
+ (while (re-search-forward "@[^ \t\n\r,>]*\\(xn--[-A-Za-z0-9.]*\\)[ \t\n\r,>]" nil t)
(let (ace unicode)
(when (save-match-data
(and (setq ace (match-string 1))
(save-excursion
(and (re-search-backward "^[^ \t]" nil t)
- (looking-at "From\\|To\\|Cc")))
+ (looking-at "From\\|To\\|Cc\\|Reply-To\\|Mail-Reply-To\\|Mail-Followup-To")))
(setq unicode (idna-to-unicode ace))))
(unless (string= ace unicode)
(replace-match unicode nil nil nil 1)))))))))
(setq type
(gnus-fetch-field "content-transfer-encoding"))
(let* ((ct (gnus-fetch-field "content-type"))
- (ctl (and ct
- (ignore-errors
- (mail-header-parse-content-type ct)))))
+ (ctl (and ct (mail-header-parse-content-type ct))))
(setq charset (and ctl
(mail-content-type-get ctl 'charset)))
(if (stringp charset)
(setq type
(gnus-fetch-field "content-transfer-encoding"))
(let* ((ct (gnus-fetch-field "content-type"))
- (ctl (and ct
- (ignore-errors
- (mail-header-parse-content-type ct)))))
+ (ctl (and ct (mail-header-parse-content-type ct))))
(setq charset (and ctl
(mail-content-type-get ctl 'charset)))
(if (stringp charset)
(defun article-wash-html (&optional read-charset)
"Format an HTML article.
-If READ-CHARSET, ask for a coding system."
+If READ-CHARSET, ask for a coding system. If it is a number, the
+charset defined in `gnus-summary-show-article-charset-alist' is used."
(interactive "P")
(save-excursion
(let ((inhibit-read-only t)
charset)
- (when (gnus-buffer-live-p gnus-original-article-buffer)
- (with-current-buffer gnus-original-article-buffer
- (let* ((ct (gnus-fetch-field "content-type"))
- (ctl (and ct
- (ignore-errors
- (mail-header-parse-content-type ct)))))
- (setq charset (and ctl
- (mail-content-type-get ctl 'charset)))
- (when (stringp charset)
- (setq charset (intern (downcase charset)))))))
- (when read-charset
- (setq charset (mm-read-coding-system "Charset: " charset)))
- (unless charset
- (setq charset gnus-newsgroup-charset))
+ (if read-charset
+ (if (or (and (numberp read-charset)
+ (setq charset
+ (cdr
+ (assq read-charset
+ gnus-summary-show-article-charset-alist))))
+ (setq charset (mm-read-coding-system "Charset: ")))
+ (let ((gnus-summary-show-article-charset-alist
+ (list (cons 1 charset))))
+ (with-current-buffer gnus-summary-buffer
+ (gnus-summary-show-article 1)))
+ (error "No charset is given"))
+ (when (gnus-buffer-live-p gnus-original-article-buffer)
+ (with-current-buffer gnus-original-article-buffer
+ (let* ((ct (gnus-fetch-field "content-type"))
+ (ctl (and ct (mail-header-parse-content-type ct))))
+ (setq charset (and ctl
+ (mail-content-type-get ctl 'charset)))
+ (when (stringp charset)
+ (setq charset (intern (downcase charset)))))))
+ (unless charset
+ (setq charset gnus-newsgroup-charset)))
(article-goto-body)
(save-window-excursion
(save-restriction
(defun gnus-article-wash-html-with-w3m ()
"Wash the current buffer with emacs-w3m."
(mm-setup-w3m)
- (save-restriction
- (narrow-to-region (point) (point-max))
- (let ((w3m-safe-url-regexp mm-w3m-safe-url-regexp)
- w3m-force-redisplay)
- (w3m-region (point-min) (point-max)))
- (when (and mm-inline-text-html-with-w3m-keymap
- (boundp 'w3m-minor-mode-map)
- w3m-minor-mode-map)
- (add-text-properties
- (point-min) (point-max)
- (list 'keymap w3m-minor-mode-map
- ;; Put the mark meaning this part was rendered by emacs-w3m.
- 'mm-inline-text-html-with-w3m t)))))
+ (let ((w3m-safe-url-regexp mm-w3m-safe-url-regexp)
+ w3m-force-redisplay)
+ (w3m-region (point-min) (point-max)))
+ (when (and mm-inline-text-html-with-w3m-keymap
+ (boundp 'w3m-minor-mode-map)
+ w3m-minor-mode-map)
+ (add-text-properties
+ (point-min) (point-max)
+ (list 'keymap w3m-minor-mode-map
+ ;; Put the mark meaning this part was rendered by emacs-w3m.
+ 'mm-inline-text-html-with-w3m t))))
+
+(eval-when-compile (defvar charset)) ;; Bound by `article-wash-html'.
+
+(defun gnus-article-wash-html-with-w3m-standalone ()
+ "Wash the current buffer with w3m."
+ (if (mm-w3m-standalone-supports-m17n-p)
+ (progn
+ (unless (mm-coding-system-p charset) ;; Bound by `article-wash-html'.
+ ;; The default.
+ (setq charset 'iso-8859-1))
+ (let ((coding-system-for-write charset)
+ (coding-system-for-read charset))
+ (call-process-region
+ (point-min) (point-max)
+ "w3m" t t nil "-dump" "-T" "text/html"
+ "-I" (symbol-name charset) "-O" (symbol-name charset))))
+ (mm-inline-wash-with-stdin nil "w3m" "-dump" "-T" "text/html")))
+
+(defvar gnus-article-browse-html-temp-list nil
+ "List of temporary files created by `gnus-article-browse-html-parts'.
+Internal variable.")
+
+(defcustom gnus-article-browse-delete-temp 'ask
+ "What to do with temporary files from `gnus-article-browse-html-parts'.
+If nil, don't delete temporary files. If it is t, delete them on
+exit from the summary buffer. If it is the symbol `file', query
+on each file, if it is `ask' ask once when exiting from the
+summary buffer."
+ :group 'gnus-article
+ :type '(choice (const :tag "Don't delete" nil)
+ (const :tag "Don't ask" t)
+ (const :tag "Ask" ask)
+ (const :tag "Ask for each file" file)))
+
+;; Cf. mm-postponed-undisplay-list / mm-destroy-postponed-undisplay-list.
+
+(defun gnus-article-browse-delete-temp-files (&optional how)
+ "Delete temp-files created by `gnus-article-browse-html-parts'."
+ (when (and gnus-article-browse-html-temp-list
+ (or how
+ (setq how gnus-article-browse-delete-temp)))
+ (when (and (eq how 'ask)
+ (y-or-n-p (format
+ "Delete all %s temporary HTML file(s)? "
+ (length gnus-article-browse-html-temp-list)))
+ (setq how t)))
+ (dolist (file gnus-article-browse-html-temp-list)
+ (when (and (file-exists-p file)
+ (or (eq how t)
+ ;; `how' is neither `nil', `ask' nor `t' (i.e. `file'):
+ (gnus-y-or-n-p
+ (format "Delete temporary HTML file `%s'? " file))))
+ (delete-file file)))
+ ;; Also remove file from the list when not deleted or if file doesn't
+ ;; exist anymore.
+ (setq gnus-article-browse-html-temp-list nil))
+ gnus-article-browse-html-temp-list)
+
+(defun gnus-article-browse-html-parts (list)
+ "View all \"text/html\" parts from LIST.
+Recurse into multiparts."
+ ;; Internal function used by `gnus-article-browse-html-article'.
+ (let ((showed))
+ ;; Find and show the html-parts.
+ (dolist (handle list)
+ ;; If HTML, show it:
+ (when (listp handle)
+ (cond ((and (bufferp (car handle))
+ (string-match "text/html" (car (mm-handle-type handle))))
+ (let ((tmp-file (mm-make-temp-file
+ ;; Do we need to care for 8.3 filenames?
+ "mm-" nil ".html")))
+ (mm-save-part-to-file handle tmp-file)
+ (add-to-list 'gnus-article-browse-html-temp-list tmp-file)
+ (add-hook 'gnus-summary-prepare-exit-hook
+ 'gnus-article-browse-delete-temp-files)
+ (add-hook 'gnus-exit-gnus-hook
+ (lambda ()
+ (gnus-article-browse-delete-temp-files t)))
+ (browse-url tmp-file)
+ (setq showed t)))
+ ;; If multipart, recurse
+ ((and (stringp (car handle))
+ (string-match "^multipart/" (car handle))
+ (setq showed
+ (or showed
+ (gnus-article-browse-html-parts handle))))))))
+ showed))
+
+;; TODO: Key binding
+(defun gnus-article-browse-html-article ()
+ "View \"text/html\" parts of the current article with a WWW browser."
+ (interactive)
+ (save-window-excursion
+ ;; Open raw article and select the buffer
+ (gnus-summary-show-article t)
+ (gnus-summary-select-article-buffer)
+ (let ((parts (mm-dissect-buffer t t)))
+ ;; If singlepart, enforce a list.
+ (when (and (bufferp (car parts))
+ (stringp (car (mm-handle-type parts))))
+ (setq parts (list parts)))
+ ;; Process the list
+ (unless (gnus-article-browse-html-parts parts)
+ (gnus-error 3 "Mail doesn't contain a \"text/html\" part!"))
+ (gnus-summary-show-article))))
(defun article-hide-list-identifiers ()
"Remove list identifies from the Subject header.
(article-really-strip-banner
(gnus-parameter-banner gnus-newsgroup-name)))
(when gnus-article-address-banner-alist
- ;; It is necessary to encode from fields before checking,
- ;; because `mail-header-parse-addresses' does not work
- ;; (reliably) on decoded headers. And more, it is
- ;; impossible to use `gnus-fetch-original-field' here,
- ;; because `article-strip-banner' may be called in draft
- ;; buffers to preview them.
+ ;; Note that the From header is decoded here, so it is
+ ;; required that the *-extract-address-components function
+ ;; supports non-ASCII text.
(let ((from (save-restriction
(widen)
(article-narrow-to-head)
(mail-fetch-field "from"))))
(when (and from
(setq from
- (caar (mail-header-parse-addresses
- (mail-encode-encoded-word-string from)))))
+ (cadr (funcall gnus-extract-address-components
+ from))))
(catch 'found
(dolist (pair gnus-article-address-banner-alist)
(when (string-match (car pair) from)
((null split-name)
(read-file-name
(concat prompt " (default "
- (file-name-nondirectory default-name) ") ")
+ (file-name-nondirectory default-name) "): ")
(file-name-directory default-name)
default-name))
;; A single group name is returned.
(symbol-value variable)))
(read-file-name
(concat prompt " (default "
- (file-name-nondirectory default-name) ") ")
+ (file-name-nondirectory default-name) "): ")
(file-name-directory default-name)
default-name))
;; A single split name was found
((file-exists-p name) name)
(t gnus-article-save-directory))))
(read-file-name
- (concat prompt " (default " name ") ")
+ (concat prompt " (default " name "): ")
dir name)))
;; A list of splits was found.
(t
(setq result
(expand-file-name
(read-file-name
- (concat prompt " (`M-p' for defaults) ")
+ (concat prompt " (`M-p' for defaults): ")
gnus-article-save-directory
(car split-name))
gnus-article-save-directory)))
Optional argument FILENAME specifies file name.
Directory to save to is default to `gnus-article-save-directory'."
(setq filename (gnus-read-save-file-name
- "Save %s in rmail file:" filename
+ "Save %s in rmail file" filename
gnus-rmail-save-name gnus-newsgroup-name
gnus-current-headers 'gnus-newsgroup-last-rmail))
(gnus-eval-in-buffer-window gnus-save-article-buffer
Optional argument FILENAME specifies file name.
Directory to save to is default to `gnus-article-save-directory'."
(setq filename (gnus-read-save-file-name
- "Save %s in Unix mail file:" filename
+ "Save %s in Unix mail file" filename
gnus-mail-save-name gnus-newsgroup-name
gnus-current-headers 'gnus-newsgroup-last-mail))
(gnus-eval-in-buffer-window gnus-save-article-buffer
Optional argument FILENAME specifies file name.
Directory to save to is default to `gnus-article-save-directory'."
(setq filename (gnus-read-save-file-name
- "Save %s in file:" filename
+ "Save %s in file" filename
gnus-file-save-name gnus-newsgroup-name
gnus-current-headers 'gnus-newsgroup-last-file))
(gnus-eval-in-buffer-window gnus-save-article-buffer
Optional argument FILENAME specifies file name.
The directory to save in defaults to `gnus-article-save-directory'."
(setq filename (gnus-read-save-file-name
- "Save %s body in file:" filename
+ "Save %s body in file" filename
gnus-file-save-name gnus-newsgroup-name
gnus-current-headers 'gnus-newsgroup-last-file))
(gnus-eval-in-buffer-window gnus-save-article-buffer
(gnus-mime-view-part-as-charset "C" "View As charset...")
(gnus-mime-save-part "o" "Save...")
(gnus-mime-save-part-and-strip "\C-o" "Save and Strip")
+ (gnus-mime-replace-part "r" "Replace part")
(gnus-mime-delete-part "d" "Delete part")
(gnus-mime-copy-part "c" "View As Text, In Other Buffer")
(gnus-mime-inline-part "i" "View As Text, In This Buffer")
- (gnus-mime-view-part-internally "E" "View Internally")
+ (gnus-mime-view-part-internally "E" "View Internally") ;; Why `E'?
(gnus-mime-view-part-externally "e" "View Externally")
(gnus-mime-print-part "p" "Print")
(gnus-mime-pipe-part "|" "Pipe To Command...")
(gnus-article-jump-to-part
(+ current-id gnus-auto-select-part)))))
-(defun gnus-mime-save-part-and-strip ()
- "Save the MIME part under point then replace it with an external body."
+(defun gnus-mime-replace-part (file)
+ "Replace MIME part under point with an external body."
+ ;; Useful if file has already been saved to disk
+ (interactive
+ (list
+ (mm-with-multibyte
+ (read-file-name "Replace MIME part with file: "
+ (or mm-default-directory default-directory)
+ nil nil))))
+ (gnus-mime-save-part-and-strip file))
+
+(defun gnus-mime-save-part-and-strip (&optional file)
+ "Save the MIME part under point then replace it with an external body.
+If FILE is given, use it for the external part."
(interactive)
(gnus-article-check-buffer)
(when (gnus-group-read-only-p)
The current article has a complicated MIME structure, giving up..."))
(let* ((data (get-text-property (point) 'gnus-data))
(id (get-text-property (point) 'gnus-part))
- file param
+ param
(handles gnus-article-mime-handles))
- (setq file (and data (mm-save-part data "Delete MIME part and save to: ")))
+ (unless file
+ (setq file
+ (and data (mm-save-part data "Delete MIME part and save to: "))))
(when file
(with-current-buffer (mm-handle-buffer data)
(erase-buffer)
;; (set-buffer gnus-summary-buffer)
(gnus-article-edit-part handles id))))
+;; A function like `gnus-summary-save-parts' (`X m', `<MIME> <Extract all
+;; parts...>') but with stripping would be nice.
+
(defun gnus-mime-delete-part ()
"Delete the MIME part under point.
Replace it with some information about the removed part."
(defun gnus-mime-view-part-as-type-internal ()
(gnus-article-check-buffer)
- (let* ((name (mail-content-type-get
- (mm-handle-type (get-text-property (point) 'gnus-data))
- 'name))
+ (let* ((handle (get-text-property (point) 'gnus-data))
+ (name (or
+ ;; Content-Type: foo/bar; name=...
+ (mail-content-type-get (mm-handle-type handle) 'name)
+ ;; Content-Disposition: attachment; filename=...
+ (cdr (assq 'filename (cdr (mm-handle-disposition handle))))))
(def-type (and name (mm-default-file-encoding name))))
(and def-type (cons def-type 0))))
"Choose a MIME media type, and view the part as such."
(interactive)
(unless mime-type
- (setq mime-type (completing-read
- "View as MIME type: "
- (mapcar #'list (mailcap-mime-types))
- nil nil
- (gnus-mime-view-part-as-type-internal))))
+ (setq mime-type
+ (let ((default (gnus-mime-view-part-as-type-internal)))
+ (completing-read
+ (format "View as MIME type (default %s): "
+ (car default))
+ (mapcar #'list (mailcap-mime-types))
+ nil nil nil nil
+ (car default)))))
(gnus-article-check-buffer)
(let ((handle (get-text-property (point) 'gnus-data)))
(when handle
(if action-pair
(funcall (cdr action-pair)))))
-(defun gnus-article-part-wrapper (n function &optional no-handle)
+(defun gnus-article-part-wrapper (n function &optional no-handle interactive)
+ "Call FUNCTION on MIME part N.
+Unless NO-HANDLE, call FUNCTION with N-th MIME handle as it's only argument.
+If INTERACTIVE, call FUNCTION interactivly."
(let (window frame)
;; Check whether the article is displayed.
(unless (and (gnus-buffer-live-p gnus-article-buffer)
(overlay-arrow-string "=>")
(overlay-arrow-position (point-marker)))
(unwind-protect
- (if no-handle
- (funcall function)
+ (cond
+ ((and no-handle interactive)
+ (call-interactively function))
+ (no-handle
+ (funcall function))
+ (interactive
+ (call-interactively
+ function
+ (cdr (assq n gnus-article-mime-handle-alist))))
+ (t
(funcall function
- (cdr (assq n gnus-article-mime-handle-alist))))
+ (cdr (assq n gnus-article-mime-handle-alist)))))
(set-marker overlay-arrow-position nil)
(unless gnus-auto-select-part
(gnus-select-frame-set-input-focus frame)
(interactive "p")
(gnus-article-part-wrapper n 'gnus-mime-save-part-and-strip t))
+(defun gnus-article-replace-part (n)
+ "Replace MIME part N with an external body.
+N is the numerical prefix."
+ (interactive "p")
+ (gnus-article-part-wrapper n 'gnus-mime-replace-part t t))
+
(defun gnus-article-delete-part (n)
"Delete MIME part N and add some information about the removed part.
N is the numerical prefix."
(defun gnus-mime-display-part (handle)
(cond
+ ;; Maybe a broken MIME message.
+ ((null handle))
;; Single part.
((not (stringp (car handle)))
(gnus-mime-display-single handle))
(forward-line -1)
(setq beg (point)))
(gnus-article-insert-newline)
- (mm-display-inline handle)
+ (mm-insert-inline
+ handle
+ (let ((charset (mail-content-type-get (mm-handle-type handle)
+ 'charset)))
+ (cond ((not charset)
+ (mm-string-as-multibyte (mm-get-part handle)))
+ ((eq charset 'gnus-decoded)
+ (with-current-buffer (mm-handle-buffer handle)
+ (buffer-string)))
+ (t
+ (mm-decode-string (mm-get-part handle) charset)))))
(goto-char (point-max))))
;; Do highlighting.
(save-excursion
,gnus-mouse-face-prop ,gnus-article-mouse-face
face ,gnus-article-button-face
gnus-part ,id
- gnus-data ,handle))
+ article-type multipart))
(widget-convert-button 'link from (point)
:action 'gnus-widget-press-button
:button-keymap gnus-widget-button-keymap)
(gnus-url-mailto url-mailto))
(t (gnus-message 3 "Invalid string.")))))
-(defun gnus-button-handle-custom (url)
- "Follow a Custom URL."
- (customize-apropos (gnus-url-unhex-string url)))
+(defun gnus-button-handle-custom (fun arg)
+ "Call function FUN on argument ARG.
+Both FUN and ARG are supposed to be strings. ARG will be passed
+as a symbol to FUN."
+ (funcall (intern fun) (intern arg)))
(defvar gnus-button-handle-describe-prefix "^\\(C-h\\|<?[Ff]1>?\\)")
;; Info links like `C-h i d m CC Mode RET'
0 (>= gnus-button-emacs-level 1) gnus-button-handle-info-keystrokes 2)
;; This is custom
- ("\\bcustom:\\(//\\)?\\([^'\">\n\t ]+\\)"
- 0 (>= gnus-button-emacs-level 5) gnus-button-handle-custom 2)
- ("M-x[ \t\n]customize-[^ ]+[ \t\n]RET[ \t\n]\\([^ ]+\\)[ \t\n]RET" 0
- (>= gnus-button-emacs-level 1) gnus-button-handle-custom 1)
+ ("M-x[ \t\n]\\(customize-[^ ]+\\)[ \t\n]RET[ \t\n]\\([^ ]+\\)[ \t\n]RET" 0
+ (>= gnus-button-emacs-level 1) gnus-button-handle-custom 1 2)
;; Emacs help commands
("M-x[ \t\n]+apropos[ \t\n]+RET[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET"
;; regexp doesn't match arguments containing ` '.
t)
((eq val 'head)
nil)
+ ((eq val 'first)
+ (eq part-number 1))
((eq val 'last)
(eq part-number total-parts))
((numberp val)
(?d gnus-tmp-details ?s)
(?D gnus-tmp-pressed-details ?s)))
+(defvar gnus-mime-security-button-commands
+ '((gnus-article-press-button "\r" "Show Detail")
+ (undefined "v")
+ (undefined "t")
+ (undefined "C")
+ (gnus-mime-security-save-part "o" "Save...")
+ (undefined "\C-o")
+ (undefined "r")
+ (undefined "d")
+ (undefined "c")
+ (undefined "i")
+ (undefined "E")
+ (undefined "e")
+ (undefined "p")
+ (gnus-mime-security-pipe-part "|" "Pipe To Command...")
+ (undefined ".")))
+
(defvar gnus-mime-security-button-map
(let ((map (make-sparse-keymap)))
(define-key map gnus-mouse-2 'gnus-article-push-button)
- (define-key map "\r" 'gnus-article-press-button)
+ (define-key map gnus-down-mouse-3 'gnus-mime-security-button-menu)
+ (dolist (c gnus-mime-security-button-commands)
+ (define-key map (cadr c) (car c)))
map))
+(easy-menu-define
+ gnus-mime-security-button-menu gnus-mime-security-button-map
+ "Security button menu."
+ `("Security Part"
+ ,@(delq nil
+ (mapcar (lambda (c)
+ (unless (eq (car c) 'undefined)
+ (vector (caddr c) (car c) :enable t)))
+ gnus-mime-security-button-commands))))
+
+(defun gnus-mime-security-button-menu (event prefix)
+ "Construct a context-sensitive menu of security commands."
+ (interactive "e\nP")
+ (save-window-excursion
+ (let ((pos (event-start event)))
+ (select-window (posn-window pos))
+ (goto-char (posn-point pos))
+ (gnus-article-check-buffer)
+ (popup-menu gnus-mime-security-button-menu nil prefix))))
+
(defvar gnus-mime-security-details-buffer nil)
(defvar gnus-mime-security-button-pressed nil)
(when (boundp 'help-echo-owns-message)
(setq help-echo-owns-message t))
(format
- "%S: show detail"
- (aref gnus-mouse-2 0))))))
+ "%S: show detail; %S: more options"
+ (aref gnus-mouse-2 0)
+ (aref gnus-down-mouse-3 0))))))
(defun gnus-mime-display-security (handle)
(save-restriction
(cons (set-marker (make-marker) (point-min))
(set-marker (make-marker) (point-max))))))
+(defun gnus-mime-security-run-function (function)
+ "Run FUNCTION with the security part under point."
+ (gnus-article-check-buffer)
+ (let ((data (get-text-property (point) 'gnus-data))
+ buffer handle)
+ (when (and (stringp (car-safe data))
+ (setq buffer (mm-handle-multipart-original-buffer data))
+ (setq handle (cadr data)))
+ (if (bufferp (mm-handle-buffer handle))
+ (progn
+ (setq handle (cons buffer (copy-sequence (cdr handle))))
+ (mm-handle-set-undisplayer handle nil))
+ (setq handle (mm-make-handle
+ buffer
+ (mm-handle-multipart-ctl-parameter handle 'protocol)
+ nil nil nil nil nil nil)))
+ (funcall function handle))))
+
+(defun gnus-mime-security-save-part ()
+ "Save the security part under point."
+ (interactive)
+ (gnus-mime-security-run-function 'mm-save-part))
+
+(defun gnus-mime-security-pipe-part ()
+ "Pipe the security part under point to a process."
+ (interactive)
+ (gnus-mime-security-run-function 'mm-pipe-part))
+
(gnus-ems-redefine)
(provide 'gnus-art)
projects / gnus / blobdiff