;;; gnus-art.el --- article mode commands for Gnus
-;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005
-;; Free Software Foundation, Inc.
+
+;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
+;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news
;; 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 2, or (at your option)
+;; the Free Software Foundation; either version 3, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
-;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
;;; Commentary:
;;; Code:
+;; For Emacs < 22.2.
+(eval-and-compile
+ (unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
(eval-when-compile
- (require 'cl)
- (defvar tool-bar-map))
+ (require 'cl))
+(defvar tool-bar-map)
+(defvar w3m-minor-mode-map)
(require 'gnus)
;; Avoid the "Recursive load suspected" error in Emacs 21.1.
(autoload 'gnus-msg-mail "gnus-msg" nil t)
(autoload 'gnus-button-mailto "gnus-msg")
(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")
+(autoload 'mm-extern-cache-contents "mm-extern")
(defgroup gnus-article nil
"Article display."
"X-Virus-Scanned" "X-Delivery-Agent" "Posted-Date" "X-Gateway"
"X-Local-Origin" "X-Local-Destination" "X-UserInfo1"
"X-Received-Date" "X-Hashcash" "Face" "X-DMCA-Notifications"
- "X-Abuse-and-DMCA-Info" "X-Postfilter" "X-Gpg-.*" "X-Disclaimer"))
+ "X-Abuse-and-DMCA-Info" "X-Postfilter" "X-Gpg-.*" "X-Disclaimer"
+ "Envelope-To" "X-Spam-Score" "System-Type" "X-Injected-Via-Gmane"
+ "X-Gmane-NNTP-Posting-Host" "Jabber-ID" "Archived-At"
+ "Envelope-Sender" "Envelope-Recipients"))
"*All headers that start with this regexp will be hidden.
This variable can also be a list of regexps of headers to be ignored.
If `gnus-visible-headers' is non-nil, this variable will be ignored."
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
regexp. If it matches, the text in question is not a signature.
This can also be a list of the above values."
- :type '(choice (integer :value 200)
+ :type '(choice (const nil)
+ (integer :value 200)
(number :value 4.0)
- (function :value fun)
+ function
(regexp :value ".*"))
:group 'gnus-article-signature)
display -"))
"*String or function to be executed to display an X-Face header.
If it is a string, the command will be executed in a sub-shell
-asynchronously. The compressed face will be piped to this command."
+asynchronously. The compressed face will be piped to this command."
:type `(choice string
(function-item gnus-display-x-face-in-from)
function)
(or (nth 4 spec) 3)
(intern (format "gnus-emphasis-%s" (nth 2 spec)))))
types))
- '(("\\(\\s-\\|^\\)\\(_\\(\\(\\w\\|_[^_]\\)+\\)_\\)\\(\\s-\\|[?!.,;]\\)"
+ '(;; I've never seen anyone use this strikethru convention whereas I've
+ ;; several times seen it triggered by normal text. --Stef
+ ;; Miles suggests that this form is sometimes used but for italics,
+ ;; so maybe we should map it to `italic'.
+ ;; ("\\(\\s-\\|^\\)\\(-\\(\\(\\w\\|-[^-]\\)+\\)-\\)\\(\\s-\\|[?!.,;]\\)"
+ ;; 2 3 gnus-emphasis-strikethru)
+ ("\\(\\s-\\|^\\)\\(_\\(\\(\\w\\|_[^_]\\)+\\)_\\)\\(\\s-\\|[?!.,;]\\)"
2 3 gnus-emphasis-underline))))
"*Alist that says how to fontify certain phrases.
Each item looks like this:
:link '(custom-manual "(gnus)Article Date")
:group 'gnus-article-washing)
-(eval-and-compile
- (autoload 'mail-extract-address-components "mail-extr"))
-
(defcustom gnus-save-all-headers t
- "*If non-nil, don't remove any headers before saving."
+ "*If non-nil, don't remove any headers before saving.
+This will be overridden by the `:headers' property that the symbol of
+the saver function, which is specified by `gnus-default-article-saver',
+might have."
:group 'gnus-article-saving
:type 'boolean)
"Headers to keep if `gnus-save-all-headers' is nil.
If `gnus-save-all-headers' is non-nil, this variable will be ignored.
If that variable is nil, however, all headers that match this regexp
-will be kept while the rest will be deleted before saving."
+will be kept while the rest will be deleted before saving. This and
+`gnus-save-all-headers' will be overridden by the `:headers' property
+that the symbol of the saver function, which is specified by
+`gnus-default-article-saver', might have."
:group 'gnus-article-saving
:type 'regexp)
(defcustom gnus-default-article-saver 'gnus-summary-save-in-rmail
"A function to save articles in your favourite format.
-The function must be interactively callable (in other words, it must
-be an Emacs command).
+The function will be called by way of the `gnus-summary-save-article'
+command, and friends such as `gnus-summary-save-article-rmail'.
Gnus provides the following functions:
* gnus-summary-save-in-file (article format)
* gnus-summary-save-body-in-file (article body)
* gnus-summary-save-in-vm (use VM's folder format)
-* gnus-summary-write-to-file (article format -- overwrite)."
+* gnus-summary-write-to-file (article format -- overwrite)
+* gnus-summary-write-body-to-file (article body -- overwrite)
+
+The symbol of each function may have the following properties:
+
+* :decode
+The value non-nil means save decoded articles. This is meaningful
+only with `gnus-summary-save-in-file', `gnus-summary-save-body-in-file',
+`gnus-summary-write-to-file', and `gnus-summary-write-body-to-file'.
+
+* :function
+The value specifies an alternative function which appends, not
+overwrites, articles to a file. This implies that when saving many
+articles at a time, `gnus-prompt-before-saving' is bound to t and all
+articles are saved in a single file. This is meaningful only with
+`gnus-summary-write-to-file' and `gnus-summary-write-body-to-file'.
+
+* :headers
+The value specifies the symbol of a variable of which the value
+specifies headers to be saved. If it is omitted,
+`gnus-save-all-headers' and `gnus-saved-headers' control what
+headers should be saved."
:group 'gnus-article-saving
:type '(radio (function-item gnus-summary-save-in-rmail)
(function-item gnus-summary-save-in-mail)
(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-item gnus-summary-write-body-to-file)
+ (function)))
+
+(defcustom gnus-article-save-coding-system
+ (or (and (mm-coding-system-p 'utf-8) 'utf-8)
+ (and (mm-coding-system-p 'iso-2022-7bit) 'iso-2022-7bit)
+ (and (mm-coding-system-p 'emacs-mule) 'emacs-mule)
+ (and (mm-coding-system-p 'escape-quoted) 'escape-quoted))
+ "Coding system used to save decoded articles to a file.
+
+The recommended coding systems are `utf-8', `iso-2022-7bit' and so on,
+which can safely encode any characters in text. This is used by the
+commands including:
+
+* gnus-summary-save-article-file
+* gnus-summary-save-article-body-file
+* gnus-summary-write-article-file
+* gnus-summary-write-article-body-file
+
+and the functions to which you may set `gnus-default-article-saver':
+
+* gnus-summary-save-in-file
+* gnus-summary-save-body-in-file
+* gnus-summary-write-to-file
+* gnus-summary-write-body-to-file
+
+Those commands and functions save just text displayed in the article
+buffer to a file if the value of this variable is non-nil. Note that
+buttonized MIME parts will be lost in a saved file in that case.
+Otherwise, raw articles will be saved."
+ :group 'gnus-article-saving
+ :type `(choice
+ :format "%{%t%}:\n %[Value Menu%] %v"
+ (const :tag "Save raw articles" nil)
+ ,@(delq nil
+ (mapcar
+ (lambda (arg) (if (mm-coding-system-p (nth 3 arg)) arg))
+ '((const :tag "UTF-8" utf-8)
+ (const :tag "iso-2022-7bit" iso-2022-7bit)
+ (const :tag "Emacs internal" emacs-mule)
+ (const :tag "escape-quoted" escape-quoted))))
+ (symbol :tag "Coding system")))
(defcustom gnus-rmail-save-name 'gnus-plain-save-name
"A function generating a file name to save articles in Rmail format.
If the match is a string, it is used as a regexp match on the
article. If the match is a symbol, that symbol will be funcalled
-from the buffer of the article to be saved with the newsgroup as
-the parameter. If it is a list, it will be evaled in the same
-buffer.
+from the buffer of the article to be saved with the newsgroup as the
+parameter. If it is a list, it will be evaled in the same buffer.
-If this form or function returns a string, this string will be
-used as a possible file name; and if it returns a non-nil list,
-that list will be used as possible file names."
+If this form or function returns a string, this string will be used as a
+possible file name; and if it returns a non-nil list, that list will be
+used as possible file names."
:group 'gnus-article-saving
:type '(repeat (choice (list :value (fun) function)
(cons :value ("" "") regexp (repeat string))
(defcustom gnus-copy-article-ignored-headers nil
"List of headers to be removed when copying an article.
Each element is a regular expression."
- :version "23.0" ;; No Gnus
+ :version "23.1" ;; No Gnus
:type '(repeat regexp)
:group 'gnus-article-various)
(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
:type 'face
:group 'gnus-article-buttons)
-(defcustom gnus-signature-face 'gnus-signature-face
+(defcustom gnus-signature-face 'gnus-signature
"Face used for highlighting a signature in the article buffer.
-Obsolete; use the face `gnus-signature-face' for customizations instead."
+Obsolete; use the face `gnus-signature' for customizations instead."
:type 'face
:group 'gnus-article-highlight
:group 'gnus-article-signature)
-(defface gnus-signature-face
+(defface gnus-signature
'((t
(:italic t)))
"Face used for highlighting a signature in the article buffer."
:group 'gnus-article-highlight
:group 'gnus-article-signature)
+;; backward-compatibility alias
+(put 'gnus-signature-face 'face-alias 'gnus-signature)
-(defface gnus-header-from-face
+(defface gnus-header-from
'((((class color)
(background dark))
- (:foreground "spring green"))
+ (:foreground "PaleGreen1"))
(((class color)
(background light))
(:foreground "red3"))
"Face used for displaying from headers."
:group 'gnus-article-headers
:group 'gnus-article-highlight)
+;; backward-compatibility alias
+(put 'gnus-header-from-face 'face-alias 'gnus-header-from)
-(defface gnus-header-subject-face
+(defface gnus-header-subject
'((((class color)
(background dark))
- (:foreground "SeaGreen3"))
+ (:foreground "SeaGreen1"))
(((class color)
(background light))
(:foreground "red4"))
"Face used for displaying subject headers."
:group 'gnus-article-headers
:group 'gnus-article-highlight)
+;; backward-compatibility alias
+(put 'gnus-header-subject-face 'face-alias 'gnus-header-subject)
-(defface gnus-header-newsgroups-face
+(defface gnus-header-newsgroups
'((((class color)
(background dark))
(:foreground "yellow" :italic t))
articles."
:group 'gnus-article-headers
:group 'gnus-article-highlight)
+;; backward-compatibility alias
+(put 'gnus-header-newsgroups-face 'face-alias 'gnus-header-newsgroups)
-(defface gnus-header-name-face
+(defface gnus-header-name
'((((class color)
(background dark))
- (:foreground "SeaGreen"))
+ (:foreground "SpringGreen2"))
(((class color)
(background light))
(:foreground "maroon"))
"Face used for displaying header names."
:group 'gnus-article-headers
:group 'gnus-article-highlight)
+;; backward-compatibility alias
+(put 'gnus-header-name-face 'face-alias 'gnus-header-name)
-(defface gnus-header-content-face
+(defface gnus-header-content
'((((class color)
(background dark))
- (:foreground "forest green" :italic t))
+ (:foreground "SpringGreen1" :italic t))
(((class color)
(background light))
(:foreground "indianred4" :italic t))
(:italic t))) "Face used for displaying header content."
:group 'gnus-article-headers
:group 'gnus-article-highlight)
+;; backward-compatibility alias
+(put 'gnus-header-content-face 'face-alias 'gnus-header-content)
(defcustom gnus-header-face-alist
- '(("From" nil gnus-header-from-face)
- ("Subject" nil gnus-header-subject-face)
- ("Newsgroups:.*," nil gnus-header-newsgroups-face)
- ("" gnus-header-name-face gnus-header-content-face))
+ '(("From" nil gnus-header-from)
+ ("Subject" nil gnus-header-subject)
+ ("Newsgroups:.*," nil gnus-header-newsgroups)
+ ("" gnus-header-name gnus-header-content))
"*Controls highlighting of article headers.
An alist of the form (HEADER NAME CONTENT).
(item :tag "skip" nil)
(face :value default)))))
+(defcustom gnus-face-properties-alist (if (featurep 'xemacs)
+ '((xface . (:face gnus-x-face)))
+ '((pbm . (:face gnus-x-face))
+ (png . nil)))
+ "Alist of image types and properties applied to Face and X-Face images.
+Here are examples:
+
+;; Specify the altitude of Face images in the From header.
+\(setq gnus-face-properties-alist
+ '((pbm . (:face gnus-x-face :ascent 80))
+ (png . (:ascent 80))))
+
+;; Show Face images as pressed buttons.
+\(setq gnus-face-properties-alist
+ '((pbm . (:face gnus-x-face :relief -2))
+ (png . (:relief -2))))
+
+See the manual for the valid properties for various image types.
+Currently, `pbm' is used for X-Face images and `png' is used for Face
+images in Emacs. Only the `:face' property is effective on the `xface'
+image type in XEmacs if it is built with the libcompface library."
+ :version "23.1" ;; No Gnus
+ :group 'gnus-article-headers
+ :type '(repeat (cons :format "%v" (symbol :tag "Image type") plist)))
+
(defcustom gnus-article-decode-hook
'(article-decode-charset article-decode-encoded-words
article-decode-group-name article-decode-idna-rhs)
(defvar gnus-decode-header-function 'mail-decode-encoded-word-region
"Function used to decode headers.")
+(defvar gnus-decode-address-function 'mail-decode-encoded-address-region
+ "Function used to decode addresses.")
+
(defvar gnus-article-dumbquotes-map
'(("\200" "EUR")
("\202" ",")
"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
This is meant for people who want to do something automatic based
on parts -- for instance, adding Vcard info to a database."
:group 'gnus-article-mime
- :type 'function)
+ :type '(choice (const nil)
+ function))
(defcustom gnus-mime-multipart-functions nil
"An alist of MIME types to functions to display them."
(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)
:type '(repeat (cons (string :tag "name")
(function))))
+(defcustom gnus-auto-select-part 1
+ "Advance to next MIME part when deleting or stripping parts.
+
+When 0, point will be placed on the same part as before. When
+positive (negative), move point forward (backwards) this many
+parts. When nil, redisplay article."
+ :version "23.1" ;; No Gnus
+ :group 'gnus-article-mime
+ :type '(choice (const nil :tag "Redisplay article.")
+ (const 1 :tag "Next part.")
+ (const 0 :tag "Current part.")
+ integer))
+
;;;
;;; The treatment variables
;;;
'(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)
'(choice (const :tag "Off" nil)
(const :tag "Header" head)))
-(defvar gnus-article-treat-types '("text/plain")
+(defvar gnus-article-treat-types '("text/plain" "text/x-verbatim"
+ "text/x-patch")
"Parts to treat.")
(defvar gnus-inhibit-treatment nil
(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)
(put 'gnus-treat-buttonize-head 'highlight t)
-(defcustom gnus-treat-emphasize
- (and (or window-system
- (featurep 'xemacs))
- 50000)
+(defcustom gnus-treat-emphasize 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")
:type gnus-article-treat-custom)
+(defcustom gnus-article-unfold-long-headers nil
+ "If non-nil, allow unfolding headers even if the header is long.
+If it is a regexp, only long headers matching this regexp are unfolded.
+If it is t, all long headers are unfolded.
+
+This variable has no effect if `gnus-treat-unfold-headers' is nil."
+ :version "23.1" ;; No Gnus
+ :group 'gnus-article-treat
+ :type '(choice (const nil)
+ (const :tag "all" t)
+ (regexp)))
+
(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)
(defcustom gnus-treat-display-x-face
(and (not noninteractive)
- (or (and (fboundp 'image-type-available-p)
- (image-type-available-p 'xbm)
- (string-match "^0x" (shell-command-to-string "uncompface"))
- (executable-find "icontopbm"))
- (and (featurep 'xemacs)
- (featurep 'xface)))
+ (gnus-image-type-available-p 'xbm)
+ (if (featurep 'xemacs)
+ (featurep 'xface)
+ (and (string-match "^0x" (shell-command-to-string "uncompface"))
+ (executable-find "icontopbm")))
'head)
"Display X-Face headers.
-Valid values are nil, t, `head', `last', an integer or a predicate.
+Valid values are nil and `head'.
See Info node `(gnus)Customizing Articles' and Info node
`(gnus)X-Face' for details."
:group 'gnus-article-treat
(defcustom gnus-treat-display-face
(and (not noninteractive)
- (or (and (fboundp 'image-type-available-p)
- (image-type-available-p 'png))
- (and (featurep 'xemacs)
- (featurep 'png)))
+ (gnus-image-type-available-p '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")
:type gnus-article-treat-head-custom)
(put 'gnus-treat-display-face 'highlight t)
-(defcustom gnus-treat-display-smileys
- (if (or (and (featurep 'xemacs)
- (featurep 'xpm))
- (and (fboundp 'image-type-available-p)
- (image-type-available-p 'pbm)))
- t nil)
+(defcustom gnus-treat-display-smileys (gnus-image-type-available-p 'xpm)
"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
(put 'gnus-treat-newsgroups-picon 'highlight t)
(defcustom gnus-treat-body-boundary
- (if (and (eq window-system 'x)
- (or gnus-treat-newsgroups-picon
- gnus-treat-mail-picon
- gnus-treat-from-picon))
- 'head nil)
+ (if (or gnus-treat-newsgroups-picon
+ gnus-treat-mail-picon
+ gnus-treat-from-picon)
+ ;; If there's much decoration, the user might prefer a boundery.
+ 'head
+ nil)
"Draw a boundary at the end of the headers.
Valid values are nil and `head'.
See Info node `(gnus)Customizing Articles' for details."
(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
'("January" "February" "March" "April" "May" "June" "July" "August"
"September" "October" "November" "December"))
-(defvar gnus-button-regexp nil)
-(defvar gnus-button-marker-list nil)
-;; Regexp matching any of the regexps from `gnus-button-alist'.
-
-(defvar gnus-button-last nil)
-;; The value of `gnus-button-alist' when `gnus-button-regexp' was build.
-
(defvar article-goto-body-goes-to-point-min-p nil)
(defvar gnus-article-wash-types nil)
(defvar gnus-article-emphasis-alist nil)
(gnus-treat-date-ut gnus-article-date-ut)
(gnus-treat-date-local gnus-article-date-local)
(gnus-treat-date-english gnus-article-date-english)
- (gnus-treat-date-lapsed gnus-article-date-lapsed)
(gnus-treat-date-original gnus-article-date-original)
(gnus-treat-date-user-defined gnus-article-date-user)
(gnus-treat-date-iso8601 gnus-article-date-iso8601)
+ (gnus-treat-date-lapsed gnus-article-date-lapsed)
(gnus-treat-display-x-face gnus-article-display-x-face)
(gnus-treat-display-face gnus-article-display-face)
(gnus-treat-hide-headers gnus-article-maybe-hide-headers)
(gnus-treat-overstrike gnus-article-treat-overstrike)
(gnus-treat-ansi-sequences gnus-article-treat-ansi-sequences)
(gnus-treat-unfold-headers gnus-article-treat-unfold-headers)
- (gnus-treat-fold-headers gnus-article-treat-fold-headers)
(gnus-treat-fold-newsgroups gnus-article-treat-fold-newsgroups)
+ (gnus-treat-fold-headers gnus-article-treat-fold-headers)
(gnus-treat-buttonize-head gnus-article-add-buttons-to-head)
(gnus-treat-display-smileys gnus-treat-smiley)
(gnus-treat-capitalize-sentences gnus-article-capitalize-sentences)
;;; Macros for dealing with the article buffer.
(defmacro gnus-with-article-headers (&rest forms)
- `(save-excursion
- (set-buffer gnus-article-buffer)
+ `(with-current-buffer gnus-article-buffer
(save-restriction
(let ((inhibit-read-only t)
(inhibit-point-motion-hooks t)
(put 'gnus-with-article-headers 'edebug-form-spec '(body))
(defmacro gnus-with-article-buffer (&rest forms)
- `(save-excursion
- (set-buffer gnus-article-buffer)
+ `(with-current-buffer gnus-article-buffer
(let ((inhibit-read-only t))
,@forms)))
"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."
(interactive)
;; This function might be inhibited.
(unless gnus-inhibit-hiding
- (let ((inhibit-read-only nil)
+ (let ((inhibit-read-only t)
(case-fold-search t)
(max (1+ (length gnus-sorted-header-list)))
(inhibit-point-motion-hooks t)
'string<))))
(gnus-article-hide-header "reply-to")))))
((eq elem 'date)
- (let ((date (message-fetch-field "date")))
+ (let ((date (with-current-buffer gnus-original-article-buffer
+ ;; If date in `gnus-article-buffer' is localized
+ ;; (`gnus-treat-date-user-defined'),
+ ;; `days-between' might fail.
+ (message-fetch-field "date"))))
(when (and date
(< (days-between (current-time-string) date)
4))
(while (not (eobp))
(save-restriction
(mail-header-narrow-to-field)
- (let ((header (buffer-string)))
+ (let* ((header (buffer-string))
+ (unfoldable
+ (or (equal gnus-article-unfold-long-headers t)
+ (and (stringp gnus-article-unfold-long-headers)
+ (string-match gnus-article-unfold-long-headers header)))))
(with-temp-buffer
(insert header)
(goto-char (point-min))
(while (re-search-forward "\n[\t ]" nil t)
(replace-match " " t t)))
- (setq length (- (point-max) (point-min) 1)))
- (when (< length (window-width))
- (while (re-search-forward "\n[\t ]" nil t)
- (replace-match " " t t)))
+ (setq length (- (point-max) (point-min) 1))
+ (when (or unfoldable
+ (< length (window-width)))
+ (while (re-search-forward "\n[\t ]" nil t)
+ (replace-match " " t t))))
(goto-char (point-max)))))))
(defun gnus-article-treat-fold-headers ()
(mail-header-fold-field)
(goto-char (point-max))))))
+(defcustom gnus-article-truncate-lines (default-value 'truncate-lines)
+ "Value of `truncate-lines' in Gnus Article buffer.
+Valid values are nil, t, `head', `first', `last', an integer or a
+predicate. See Info node `(gnus)Customizing Articles'."
+ :version "23.1" ;; No Gnus
+ :group 'gnus-article
+ ;; :link '(custom-manual "(gnus)Customizing Articles")
+ :type 'boolean)
+
+(defun gnus-article-toggle-truncate-lines (&optional arg)
+ "Toggle whether to fold or truncate long lines in article the buffer.
+If ARG is non-nil and not a number, toggle
+`gnus-article-truncate-lines' too. If ARG is a number, truncate
+long lines iff arg is positive."
+ (interactive "P")
+ (cond
+ ((and (numberp arg) (> arg 0))
+ (setq gnus-article-truncate-lines t))
+ ((numberp arg)
+ (setq gnus-article-truncate-lines nil))
+ (arg
+ (setq gnus-article-truncate-lines
+ (not gnus-article-truncate-lines))))
+ (gnus-with-article-buffer
+ (cond
+ ((and (numberp arg) (> arg 0))
+ (setq truncate-lines nil))
+ ((numberp arg)
+ (setq truncate-lines t)))
+ ;; In versions of Emacs 22 (CVS) before 2006-05-26,
+ ;; `toggle-truncate-lines' needs an argument.
+ (toggle-truncate-lines)))
+
(defun gnus-article-treat-body-boundary ()
"Place a boundary line at the end of the headers."
(interactive)
(forward-line 1)
(point))))))
-(eval-when-compile
- (defvar gnus-face-properties-alist))
+(defvar gnus-face-properties-alist)
-(defun article-display-face ()
+(defun article-display-face (&optional force)
"Display any Face headers in the header."
- (interactive)
+ (interactive (list 'force))
(let ((wash-face-p buffer-read-only))
(gnus-with-article-headers
;; When displaying parts, this function can be called several times on
;; read-only.
(if (and wash-face-p (memq 'face gnus-article-wash-types))
(gnus-delete-images 'face)
- (let (face faces)
- (save-excursion
+ (let ((from (message-fetch-field "from"))
+ face faces)
+ (save-current-buffer
(when (and wash-face-p
- (progn
- (goto-char (point-min))
- (not (re-search-forward "^Face:[\t ]*" nil t)))
- (gnus-buffer-live-p gnus-original-article-buffer))
+ (gnus-buffer-live-p gnus-original-article-buffer)
+ (not (re-search-forward "^Face:[\t ]*" nil t)))
(set-buffer gnus-original-article-buffer))
(save-restriction
(mail-narrow-to-head)
- (while (gnus-article-goto-header "Face")
- (setq faces (nconc faces (list (mail-header-field-value)))))))
- (dolist (face faces)
- (let ((png (gnus-convert-face-to-png face))
- image)
- (when png
- (setq image
- (apply 'gnus-create-image png 'png t
- (cdr (assq 'png gnus-face-properties-alist))))
- (gnus-article-goto-header "from")
- (when (bobp)
- (insert "From: [no `from' set]\n")
- (forward-char -17))
- (gnus-add-wash-type 'face)
- (gnus-add-image 'face image)
- (gnus-put-image image nil 'face))))))
- )))
+ (when (or force
+ ;; Check whether this face is censored.
+ (not (and gnus-article-x-face-too-ugly
+ (or from
+ (setq from (message-fetch-field "from")))
+ (string-match gnus-article-x-face-too-ugly
+ from))))
+ (while (gnus-article-goto-header "Face")
+ (push (mail-header-field-value) faces)))))
+ (when faces
+ (goto-char (point-min))
+ (let (png image)
+ (unless (setq from (gnus-article-goto-header "from"))
+ (insert "From:")
+ (setq from (point))
+ (insert " [no `from' set]\n"))
+ (while faces
+ (when (setq png (gnus-convert-face-to-png (pop faces)))
+ (setq image
+ (apply 'gnus-create-image png 'png t
+ (cdr (assq 'png gnus-face-properties-alist))))
+ (goto-char from)
+ (gnus-add-wash-type 'face)
+ (gnus-add-image 'face image)
+ (gnus-put-image image nil 'face))))))))))
(defun article-display-x-face (&optional force)
"Look for an X-Face header and display it if present."
;; instead.
(gnus-delete-images 'xface)
;; Display X-Faces.
- (let (x-faces from face)
- (save-excursion
+ (let ((from (message-fetch-field "from"))
+ x-faces face)
+ (save-current-buffer
(when (and wash-face-p
- (progn
- (goto-char (point-min))
- (not (re-search-forward
- "^X-Face\\(-[0-9]+\\)?:[\t ]*" nil t)))
- (gnus-buffer-live-p gnus-original-article-buffer))
+ (gnus-buffer-live-p gnus-original-article-buffer)
+ (not (re-search-forward "^X-Face:[\t ]*" nil t)))
;; If type `W f', use gnus-original-article-buffer,
;; otherwise use the current buffer because displaying
;; RFC822 parts calls this function too.
(set-buffer gnus-original-article-buffer))
(save-restriction
(mail-narrow-to-head)
- (while (gnus-article-goto-header "X-Face")
- (push (mail-header-field-value) x-faces))
- (setq from (message-fetch-field "from"))))
- ;; Sending multiple EOFs to xv doesn't work, so we only do a
- ;; single external face.
- (when (stringp gnus-article-x-face-command)
- (setq x-faces (list (car x-faces))))
- (while (and (setq face (pop x-faces))
- gnus-article-x-face-command
- (or force
- ;; Check whether this face is censored.
- (not gnus-article-x-face-too-ugly)
- (and gnus-article-x-face-too-ugly from
- (not (string-match gnus-article-x-face-too-ugly
- from)))))
+ (and gnus-article-x-face-command
+ (or force
+ ;; Check whether this face is censored.
+ (not (and gnus-article-x-face-too-ugly
+ (or from
+ (setq from (message-fetch-field "from")))
+ (string-match gnus-article-x-face-too-ugly
+ from))))
+ (while (gnus-article-goto-header "X-Face")
+ (push (mail-header-field-value) x-faces)))))
+ (when x-faces
;; We display the face.
- (cond ((stringp gnus-article-x-face-command)
+ (cond ((functionp gnus-article-x-face-command)
+ ;; The command is a lisp function, so we call it.
+ (mapc gnus-article-x-face-command x-faces))
+ ((stringp gnus-article-x-face-command)
;; The command is a string, so we interpret the command
;; as a, well, command, and fork it off.
(let ((process-connection-type nil))
- (process-kill-without-query
+ (gnus-set-process-query-on-exit-flag
(start-process
"article-x-face" nil shell-file-name
- shell-command-switch gnus-article-x-face-command))
+ shell-command-switch gnus-article-x-face-command)
+ nil)
+ ;; Sending multiple EOFs to xv doesn't work,
+ ;; so we only do a single external face.
(with-temp-buffer
- (insert face)
+ (insert (car x-faces))
(process-send-region "article-x-face"
(point-min) (point-max)))
(process-send-eof "article-x-face")))
- ((functionp gnus-article-x-face-command)
- ;; The command is a lisp function, so we call it.
- (funcall gnus-article-x-face-command face))
(t
- (error "%s is not a function"
- gnus-article-x-face-command)))))))))
+ (error "`%s' set to `%s' is not a function"
+ gnus-article-x-face-command
+ 'gnus-article-x-face-command)))))))))
(defun article-decode-mime-words ()
"Decode all MIME-encoded words in the article."
(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."
(set-buffer gnus-summary-buffer)
(error))
gnus-newsgroup-ignored-charsets))
- (inhibit-read-only t))
- (save-restriction
- (article-narrow-to-head)
- (funcall gnus-decode-header-function (point-min) (point-max)))))
+ (inhibit-read-only t)
+ end start)
+ (goto-char (point-min))
+ (when (search-forward "\n\n" nil 'move)
+ (forward-line -1))
+ (setq end (point))
+ (while (not (bobp))
+ (while (progn
+ (forward-line -1)
+ (and (not (bobp))
+ (memq (char-after) '(?\t ? )))))
+ (setq start (point))
+ (if (looking-at "\
+\\(?:Resent-\\)?\\(?:From\\|Cc\\|To\\|Bcc\\|\\(?:In-\\)?Reply-To\\|Sender\
+\\|Mail-Followup-To\\|Mail-Copies-To\\|Approved\\):")
+ (funcall gnus-decode-address-function start end)
+ (funcall gnus-decode-header-function start end))
+ (goto-char (setq end start)))))
(defun article-decode-group-name ()
- "Decode group names in `Newsgroups:'."
+ "Decode group names in Newsgroups, Followup-To and Xref headers."
(let ((inhibit-point-motion-hooks t)
(inhibit-read-only t)
- (method (gnus-find-method-for-group gnus-newsgroup-name)))
+ (method (gnus-find-method-for-group gnus-newsgroup-name))
+ regexp)
(when (and (or gnus-group-name-charset-method-alist
gnus-group-name-charset-group-alist)
(gnus-buffer-live-p gnus-original-article-buffer))
(save-restriction
(article-narrow-to-head)
- (with-current-buffer gnus-original-article-buffer
- (goto-char (point-min)))
- (while (re-search-forward
- "^Newsgroups:\\(\\(.\\|\n[\t ]\\)*\\)\n[^\t ]" nil t)
- (replace-match (save-match-data
- (gnus-decode-newsgroups
- ;; XXX how to use data in article buffer?
- (with-current-buffer gnus-original-article-buffer
- (re-search-forward
- "^Newsgroups:\\(\\(.\\|\n[\t ]\\)*\\)\n[^\t ]"
- nil t)
- (match-string 1))
- gnus-newsgroup-name method))
- t t nil 1))
- (goto-char (point-min))
- (with-current-buffer gnus-original-article-buffer
- (goto-char (point-min)))
- (while (re-search-forward
- "^Followup-To:\\(\\(.\\|\n[\t ]\\)*\\)\n[^\t ]" nil t)
- (replace-match (save-match-data
- (gnus-decode-newsgroups
- ;; XXX how to use data in article buffer?
- (with-current-buffer gnus-original-article-buffer
- (re-search-forward
- "^Followup-To:\\(\\(.\\|\n[\t ]\\)*\\)\n[^\t ]"
- nil t)
- (match-string 1))
- gnus-newsgroup-name method))
- t t nil 1))))))
+ (dolist (header '("Newsgroups" "Followup-To" "Xref"))
+ (with-current-buffer gnus-original-article-buffer
+ (goto-char (point-min)))
+ (setq regexp (concat "^" header
+ ":\\([^\n]*\\(?:\n[\t ]+[^\n]+\\)*\\)\n"))
+ (while (re-search-forward regexp nil t)
+ (replace-match (save-match-data
+ (gnus-decode-newsgroups
+ ;; XXX how to use data in article buffer?
+ (with-current-buffer gnus-original-article-buffer
+ (re-search-forward regexp nil t)
+ (match-string 1))
+ gnus-newsgroup-name method))
+ t t nil 1))
+ (goto-char (point-min)))))))
(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
(t
(apply (car func) (cdr func))))))))))
+;; External.
+(declare-function w3-region "ext:w3-display" (st nd))
+
(defun gnus-article-wash-html-with-w3 ()
"Wash the current buffer with w3."
(mm-setup-w3)
(w3-region (point-min) (point-max))
(error))))
+;; External.
+(declare-function w3m-region "ext:w3m" (start end &optional url charset))
+
(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))))
+
+(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
+ :version "23.1" ;; No Gnus
+ :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)
+ (gnus-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 &optional header)
+ "View all \"text/html\" parts from LIST.
+Recurse into multiparts. The optional HEADER that should be a decoded
+message header will be added to the bodies of the \"text/html\" parts."
+ ;; Internal function used by `gnus-article-browse-html-article'.
+ (let (type file charset tmp-file showed)
+ ;; Find and show the html-parts.
+ (dolist (handle list)
+ ;; If HTML, show it:
+ (cond ((not (listp handle)))
+ ((or (equal (car (setq type (mm-handle-type handle))) "text/html")
+ (and (equal (car type) "message/external-body")
+ (or header
+ (setq file (or (mail-content-type-get type 'name)
+ (mail-content-type-get
+ (mm-handle-disposition handle)
+ 'filename))))
+ (or (mm-handle-cache handle)
+ (condition-case code
+ (progn (mm-extern-cache-contents handle) t)
+ (error
+ (gnus-message 3 "%s" (error-message-string code))
+ (when (>= gnus-verbose 3) (sit-for 2))
+ nil)))
+ (progn
+ (setq handle (mm-handle-cache handle)
+ type (mm-handle-type handle))
+ (equal (car type) "text/html"))))
+ (when (or (setq charset (mail-content-type-get type 'charset))
+ header
+ (not file))
+ (setq tmp-file (mm-make-temp-file
+ ;; Do we need to care for 8.3 filenames?
+ "mm-" nil ".html")))
+ ;; Add a meta html tag to specify charset and a header.
+ (cond
+ (header
+ (let (title eheader body hcharset coding)
+ (with-temp-buffer
+ (mm-enable-multibyte)
+ (setq case-fold-search t)
+ (insert header "\n")
+ (setq title (message-fetch-field "subject"))
+ (goto-char (point-min))
+ (while (re-search-forward "\\(<\\)\\|\\(>\\)\\|&" nil t)
+ (replace-match (cond ((match-beginning 1) "<")
+ ((match-beginning 2) ">")
+ (t "&"))))
+ (goto-char (point-min))
+ (insert "<pre>\n")
+ (goto-char (point-max))
+ (insert "</pre>\n<hr>\n")
+ ;; We have to examine charset one by one since
+ ;; charset specified in parts might be different.
+ (if (eq charset 'gnus-decoded)
+ (setq charset 'utf-8
+ eheader (mm-encode-coding-string (buffer-string)
+ charset)
+ title (when title
+ (mm-encode-coding-string title charset))
+ body (mm-encode-coding-string (mm-get-part handle)
+ charset))
+ (setq hcharset (mm-find-mime-charset-region (point-min)
+ (point-max)))
+ (cond ((= (length hcharset) 1)
+ (setq hcharset (car hcharset)
+ coding (mm-charset-to-coding-system
+ hcharset)))
+ ((> (length hcharset) 1)
+ (setq hcharset 'utf-8
+ coding hcharset)))
+ (if coding
+ (if charset
+ (progn
+ (setq body
+ (mm-charset-to-coding-system charset))
+ (if (eq coding body)
+ (setq eheader (mm-encode-coding-string
+ (buffer-string) coding)
+ title (when title
+ (mm-encode-coding-string
+ title coding))
+ body (mm-get-part handle))
+ (setq charset 'utf-8
+ eheader (mm-encode-coding-string
+ (buffer-string) charset)
+ title (when title
+ (mm-encode-coding-string
+ title charset))
+ body (mm-encode-coding-string
+ (mm-decode-coding-string
+ (mm-get-part handle) body)
+ charset))))
+ (setq charset hcharset
+ eheader (mm-encode-coding-string
+ (buffer-string) coding)
+ title (when title
+ (mm-encode-coding-string
+ title coding))
+ body (mm-get-part handle)))
+ (setq eheader (mm-string-as-unibyte (buffer-string))
+ body (mm-get-part handle))))
+ (erase-buffer)
+ (mm-disable-multibyte)
+ (insert body)
+ (when charset
+ (mm-add-meta-html-tag handle charset))
+ (when title
+ (goto-char (point-min))
+ (unless (search-forward "<title>" nil t)
+ (re-search-forward "<head>\\s-*" nil t)
+ (insert "<title>" title "</title>\n")))
+ (goto-char (point-min))
+ (or (re-search-forward
+ "<body\\(?:\\s-+[^>]+\\|\\s-*\\)>\\s-*" nil t)
+ (re-search-forward
+ "</head\\(?:\\s-+[^>]+\\|\\s-*\\)>\\s-*" nil t))
+ (insert eheader)
+ (mm-write-region (point-min) (point-max)
+ tmp-file nil nil nil 'binary t))))
+ (charset
+ (mm-with-unibyte-buffer
+ (insert (if (eq charset 'gnus-decoded)
+ (mm-encode-coding-string
+ (mm-get-part handle)
+ (setq charset 'utf-8))
+ (mm-get-part handle)))
+ (if (or (mm-add-meta-html-tag handle charset)
+ (not file))
+ (mm-write-region (point-min) (point-max)
+ tmp-file nil nil nil 'binary t)
+ (setq tmp-file nil))))
+ (tmp-file
+ (mm-save-part-to-file handle tmp-file)))
+ (when 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)))
+ ;; FIXME: Warn if there's an <img> tag?
+ (browse-url-of-file (or tmp-file (expand-file-name file)))
+ (setq showed t))
+ ;; If multipart, recurse
+ ((equal (mm-handle-media-supertype handle) "multipart")
+ (when (gnus-article-browse-html-parts handle header)
+ (setq showed t)))
+ ((equal (mm-handle-media-type handle) "message/rfc822")
+ (mm-with-multibyte-buffer
+ (mm-insert-part handle)
+ (setq handle (mm-dissect-buffer t t))
+ (when (and (bufferp (car handle))
+ (stringp (car (mm-handle-type handle))))
+ (setq handle (list handle)))
+ (when header
+ (article-decode-encoded-words)
+ (let ((gnus-visible-headers
+ (or (get 'gnus-visible-headers 'standard-value)
+ gnus-visible-headers)))
+ (article-hide-headers))
+ (goto-char (point-min))
+ (search-forward "\n\n" nil 'move)
+ (skip-chars-backward "\t\n ")
+ (setq header (buffer-substring (point-min) (point)))))
+ (when (prog1
+ (gnus-article-browse-html-parts handle header)
+ (mm-destroy-parts handle))
+ (setq showed t)))))
+ showed))
+
+;; FIXME: Documentation in texi/gnus.texi missing.
+(defun gnus-article-browse-html-article (&optional arg)
+ "View \"text/html\" parts of the current article with a WWW browser.
+The message header is added to the beginning of every html part unless
+the prefix argument ARG is given.
+
+Warning: Spammers use links to images in HTML articles to verify
+whether you have read the message. As
+`gnus-article-browse-html-article' passes the unmodified HTML
+content to the browser without eliminating these \"web bugs\" you
+should only use it for mails from trusted senders.
+
+If you alwasy want to display HTML part in the browser, set
+`mm-text-html-renderer' to nil."
+ ;; Cf. `mm-w3m-safe-url-regexp'
+ (interactive "P")
+ (if arg
+ (gnus-summary-show-article)
+ (let ((gnus-visible-headers (or (get 'gnus-visible-headers 'standard-value)
+ gnus-visible-headers)))
+ (gnus-summary-show-article)))
+ (with-current-buffer gnus-article-buffer
+ (let ((header (unless arg
+ (save-restriction
+ (widen)
+ (buffer-substring-no-properties
+ (goto-char (point-min))
+ (if (search-forward "\n\n" nil t)
+ (match-beginning 0)
+ (goto-char (point-max))
+ (skip-chars-backward "\t\n ")
+ (point))))))
+ parts)
+ (set-buffer gnus-original-article-buffer)
+ (setq 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 header)
+ (gnus-error 3 "Mail doesn't contain a \"text/html\" part!"))
+ (mm-destroy-parts parts)
+ (unless arg
+ (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)
(forward-line 1)
(setq ended t)))))
-(defun article-date-ut (&optional type highlight header)
+(defun article-date-ut (&optional type highlight)
"Convert DATE date to universal time in the current article.
If TYPE is `local', convert to local time; if it is `lapsed', output
how much time has lapsed since DATE. For `lapsed', the value of
`gnus-article-date-lapsed-new-header' says whether the \"X-Sent:\" header
should replace the \"Date:\" one, or should be added below it."
(interactive (list 'ut t))
- (let* ((header (or header
- (message-fetch-field "date")
- ""))
- (tdate-regexp "^Date:[ \t]\\|^X-Sent:[ \t]")
- (date-regexp
- (cond
- ((not gnus-article-date-lapsed-new-header)
- tdate-regexp)
- ((eq type 'lapsed)
- "^X-Sent:[ \t]")
- (t
- "^Date:[ \t]")))
- (date (if (vectorp header) (mail-header-date header)
- header))
+ (let* ((tdate-regexp "^Date:[ \t]\\|^X-Sent:[ \t]")
+ (date-regexp (cond ((not gnus-article-date-lapsed-new-header)
+ tdate-regexp)
+ ((eq type 'lapsed)
+ "^X-Sent:[ \t]")
+ (article-lapsed-timer
+ "^Date:[ \t]")
+ (t
+ tdate-regexp)))
+ (case-fold-search t)
+ (inhibit-read-only t)
(inhibit-point-motion-hooks t)
- pos
- bface eface)
+ pos date bface eface)
(save-excursion
(save-restriction
- (article-narrow-to-head)
- (when (re-search-forward tdate-regexp nil t)
- (setq bface (get-text-property (point-at-bol) 'face)
- date (or (get-text-property (point-at-bol)
- 'original-date)
- date)
- eface (get-text-property (1- (point-at-eol)) 'face))
- (forward-line 1))
- (when (and date (not (string= date "")))
+ (widen)
+ (goto-char (point-min))
+ (while (or (setq date (get-text-property (setq pos (point))
+ 'original-date))
+ (when (setq pos (next-single-property-change
+ (point) 'original-date))
+ (setq date (get-text-property pos 'original-date))
+ t))
+ (narrow-to-region pos (or (text-property-any pos (point-max)
+ 'original-date nil)
+ (point-max)))
(goto-char (point-min))
- (let ((inhibit-read-only t))
- ;; Delete any old Date headers.
- (while (re-search-forward date-regexp nil t)
- (if pos
- (delete-region (point-at-bol)
- (progn (gnus-article-forward-header)
- (point)))
- (delete-region (point-at-bol)
- (progn (gnus-article-forward-header)
- (forward-char -1)
- (point)))
- (setq pos (point))))
- (when (and (not pos)
- (re-search-forward tdate-regexp nil t))
- (forward-line 1))
- (gnus-goto-char pos)
- (insert (article-make-date-line date (or type 'ut)))
- (unless pos
- (insert "\n")
- (forward-line -1))
- ;; Do highlighting.
- (beginning-of-line)
- (when (looking-at "\\([^:]+\\): *\\(.*\\)$")
- (add-text-properties (match-beginning 1) (1+ (match-end 1))
- (list 'original-date date 'face bface))
- (put-text-property (match-beginning 2) (match-end 2)
- 'face eface))))))))
+ (when (re-search-forward tdate-regexp nil t)
+ (setq bface (get-text-property (point-at-bol) 'face)
+ eface (get-text-property (1- (point-at-eol)) 'face)))
+ (goto-char (point-min))
+ (setq pos nil)
+ ;; Delete any old Date headers.
+ (while (re-search-forward date-regexp nil t)
+ (if pos
+ (delete-region (point-at-bol) (progn
+ (gnus-article-forward-header)
+ (point)))
+ (delete-region (point-at-bol) (progn
+ (gnus-article-forward-header)
+ (forward-char -1)
+ (point)))
+ (setq pos (point))))
+ (when (and (not pos)
+ (re-search-forward tdate-regexp nil t))
+ (forward-line 1))
+ (gnus-goto-char pos)
+ (insert (article-make-date-line date (or type 'ut)))
+ (unless pos
+ (insert "\n")
+ (forward-line -1))
+ ;; Do highlighting.
+ (beginning-of-line)
+ (when (looking-at "\\([^:]+\\): *\\(.*\\)$")
+ (put-text-property (match-beginning 1) (1+ (match-end 1))
+ 'face bface)
+ (put-text-property (match-beginning 2) (match-end 2)
+ 'face eface))
+ (put-text-property (point-min) (1- (point-max)) 'original-date date)
+ (goto-char (point-max))
+ (widen))))))
(defun article-make-date-line (date type)
"Return a DATE line of TYPE."
(defun article-update-date-lapsed ()
"Function to be run from a timer to update the lapsed time line."
- (let (deactivate-mark)
- (save-excursion
- (ignore-errors
- (walk-windows
- (lambda (w)
- (set-buffer (window-buffer w))
- (when (eq major-mode 'gnus-article-mode)
- (let ((mark (point-marker)))
- (goto-char (point-min))
- (when (re-search-forward "^X-Sent:" nil t)
- (article-date-lapsed t))
- (goto-char (marker-position mark))
- (move-marker mark nil))))
- nil 'visible)))))
+ (save-match-data
+ (let (deactivate-mark)
+ (save-excursion
+ (ignore-errors
+ (walk-windows
+ (lambda (w)
+ (set-buffer (window-buffer w))
+ (when (eq major-mode 'gnus-article-mode)
+ (let ((mark (point-marker)))
+ (goto-char (point-min))
+ (when (re-search-forward "^X-Sent:" nil t)
+ (article-date-lapsed t))
+ (goto-char (marker-position mark))
+ (move-marker mark nil))))
+ nil 'visible))))))
(defun gnus-start-date-timer (&optional n)
"Start a timer to update the X-Sent header in the article buffers.
(interactive (list t))
(article-date-ut 'iso8601 highlight))
+(defmacro gnus-article-save-original-date (&rest forms)
+ "Save the original date as a text property and evaluate FORMS."
+ `(let* ((case-fold-search t)
+ (start (progn
+ (goto-char (point-min))
+ (when (and (re-search-forward "^date:[\t\n ]+" nil t)
+ (not (bolp)))
+ (match-end 0))))
+ (date (when (and start
+ (re-search-forward "[\t ]*\n\\(?:[^\t ]\\|\\'\\)"
+ nil t))
+ (buffer-substring-no-properties start
+ (match-beginning 0)))))
+ (goto-char (point-max))
+ (skip-chars-backward "\n")
+ (put-text-property (point-min) (point) 'original-date date)
+ ,@forms
+ (goto-char (point-max))
+ (skip-chars-backward "\n")
+ (put-text-property (point-min) (point) 'original-date date)))
+
;; (defun article-show-all ()
;; "Show all hidden text in the article buffer."
;; (interactive)
gnus-newsgroup-name 'highlight-words t)))
gnus-emphasis-alist)))))
-(eval-when-compile
- (defvar gnus-summary-article-menu)
- (defvar gnus-summary-post-menu))
+(defvar gnus-summary-article-menu)
+(defvar gnus-summary-post-menu)
;;; Saving functions.
(defun gnus-article-save (save-buffer file &optional num)
"Save the currently selected article."
- (unless gnus-save-all-headers
- ;; Remove headers according to `gnus-saved-headers'.
+ (when (or (get gnus-default-article-saver :headers)
+ (not gnus-save-all-headers))
+ ;; Remove headers according to `gnus-saved-headers' or the value
+ ;; of the `:headers' property that the saver function might have.
(let ((gnus-visible-headers
- (or gnus-saved-headers gnus-visible-headers))
+ (or (symbol-value (get gnus-default-article-saver :headers))
+ gnus-saved-headers gnus-visible-headers))
(gnus-article-buffer save-buffer))
- (save-excursion
- (set-buffer save-buffer)
+ (with-current-buffer save-buffer
(article-hide-headers 1 t))))
(save-window-excursion
(if (not gnus-default-article-saver)
(funcall gnus-default-article-saver filename)))))
(defun gnus-read-save-file-name (prompt &optional filename
- function group headers variable)
+ function group headers variable
+ dir-var)
(let ((default-name
(funcall function group headers (symbol-value variable)))
result)
default-name)
(filename filename)
(t
+ (when (symbol-value dir-var)
+ (setq default-name (expand-file-name
+ (file-name-nondirectory default-name)
+ (symbol-value dir-var))))
(let* ((split-name (gnus-get-split-value gnus-split-methods))
(prompt
(format prompt
((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)))
;; Possibly translate some characters.
(nnheader-translate-file-chars file))))))
(gnus-make-directory (file-name-directory result))
- (set variable result)))
+ (when variable
+ (set variable result))
+ (when dir-var
+ (set dir-var (file-name-directory result)))
+ result))
(defun gnus-article-archive-name (group)
"Return the first instance of an \"Archive-name\" in the current 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 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
(gnus-output-to-mail filename)))))
filename)
+(put 'gnus-summary-save-in-file :decode t)
+(put 'gnus-summary-save-in-file :headers 'gnus-saved-headers)
(defun gnus-summary-save-in-file (&optional filename overwrite)
"Append this article to file.
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
(gnus-output-to-file filename))))
filename)
+(put 'gnus-summary-write-to-file :decode t)
+(put 'gnus-summary-write-to-file :function 'gnus-summary-save-in-file)
+(put 'gnus-summary-write-to-file :headers 'gnus-saved-headers)
(defun gnus-summary-write-to-file (&optional filename)
"Write this article to a file, overwriting it if the file exists.
Optional argument FILENAME specifies file name.
The directory to save in defaults to `gnus-article-save-directory'."
- (gnus-summary-save-in-file nil t))
+ (setq filename (gnus-read-save-file-name
+ "Save %s in file" filename
+ gnus-file-save-name gnus-newsgroup-name
+ gnus-current-headers nil 'gnus-newsgroup-last-directory))
+ (gnus-summary-save-in-file filename t))
-(defun gnus-summary-save-body-in-file (&optional filename)
+(put 'gnus-summary-save-body-in-file :decode t)
+(defun gnus-summary-save-body-in-file (&optional filename overwrite)
"Append this article body to a file.
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
(widen)
(when (article-goto-body)
(narrow-to-region (point) (point-max)))
+ (when (and overwrite
+ (file-exists-p filename))
+ (delete-file filename))
(gnus-output-to-file filename))))
filename)
+(put 'gnus-summary-write-body-to-file :decode t)
+(put 'gnus-summary-write-body-to-file
+ :function 'gnus-summary-save-body-in-file)
+(defun gnus-summary-write-body-to-file (&optional filename)
+ "Write this article body to a file, overwriting it if the file exists.
+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
+ gnus-file-save-name gnus-newsgroup-name
+ gnus-current-headers nil 'gnus-newsgroup-last-directory))
+ (gnus-summary-save-body-in-file filename t))
+
(defun gnus-summary-save-in-pipe (&optional command)
"Pipe this article to subprocess."
(setq command
(defun gnus-numeric-save-name (newsgroup headers &optional last-file)
"Generate file name from NEWSGROUP, HEADERS, and optional LAST-FILE.
If variable `gnus-use-long-file-name' is non-nil, it is
-~/News/news.group/num. Otherwise, it is like ~/News/news/group/num."
+~/News/news.group/num. Otherwise, it is like ~/News/news/group/num."
(let ((default
(expand-file-name
(concat (if (gnus-use-long-file-name 'not-save)
(defun article-verify-x-pgp-sig ()
"Verify X-PGP-Sig."
+ ;; <ftp://ftp.isc.org/pub/pgpcontrol/FORMAT>
(interactive)
(if (gnus-buffer-live-p gnus-original-article-buffer)
(let ((sig (with-current-buffer gnus-original-article-buffer
(canlock-verify gnus-original-article-buffer)))
(eval-and-compile
- (mapcar
+ (mapc
(lambda (func)
(let (afunc gfunc)
(if (consp func)
`(lambda (&optional interactive &rest args)
,(documentation afunc t)
(interactive (list t))
- (save-excursion
- (set-buffer gnus-article-buffer)
+ (with-current-buffer gnus-article-buffer
(if interactive
(call-interactively ',afunc)
(apply ',afunc args))))))))
article-emphasize
article-treat-dumbquotes
article-normalize-headers
-;; (article-show-all . gnus-article-show-all-headers)
+ ;;(article-show-all . gnus-article-show-all-headers)
)))
\f
;;;
"F" gnus-article-followup-with-original
"\C-hk" gnus-article-describe-key
"\C-hc" gnus-article-describe-key-briefly
+ "\C-hb" gnus-article-describe-bindings
"\C-d" gnus-article-read-summary-keys
"\M-*" gnus-article-read-summary-keys
(substitute-key-definition
'undefined 'gnus-article-read-summary-keys gnus-article-mode-map)
+(gnus-define-keys (gnus-article-send-map "S" gnus-article-mode-map)
+ "W" gnus-article-wide-reply-with-original)
+(if (featurep 'xemacs)
+ (set-keymap-default-binding gnus-article-send-map
+ 'gnus-article-read-summary-send-keys)
+ (define-key gnus-article-send-map [t] 'gnus-article-read-summary-send-keys))
+
(defun gnus-article-make-menu-bar ()
(unless (boundp 'gnus-article-commands-menu)
(gnus-summary-make-menu-bar))
\\[gnus-article-describe-briefly]\t Describe the current mode briefly
\\[gnus-info-find-node]\t Go to the Gnus info node"
(interactive)
+ (kill-all-local-variables)
(gnus-simplify-mode-line)
(setq mode-name "Article")
(setq major-mode 'gnus-article-mode)
(make-local-variable 'gnus-article-image-alist)
(make-local-variable 'gnus-article-charset)
(make-local-variable 'gnus-article-ignored-charsets)
- ;; Prevent recent Emacsen from displaying non-break space as "\ ".
- (set (make-local-variable 'show-nonbreak-escape) nil)
+ ;; Prevent Emacs 22 from displaying non-break space with `nobreak-space'
+ ;; face.
+ (set (make-local-variable 'nobreak-char-display) nil)
+ (setq cursor-in-non-selected-windows nil)
+ (setq truncate-lines gnus-article-truncate-lines)
(gnus-set-default-directory)
(buffer-disable-undo)
(setq buffer-read-only t
show-trailing-whitespace nil)
(set-syntax-table gnus-article-mode-syntax-table)
(mm-enable-multibyte)
- (gnus-run-hooks 'gnus-article-mode-hook))
+ (gnus-run-mode-hooks 'gnus-article-mode-hook))
+
+(defvar gnus-button-marker-list nil
+ "Regexp matching any of the regexps from `gnus-button-alist'.
+Internal variable.")
(defun gnus-article-setup-buffer ()
"Initialize the article buffer."
(setq gnus-article-buffer name)
(setq gnus-original-article-buffer original)
(setq gnus-article-mime-handle-alist nil)
- ;; This might be a variable local to the summary buffer.
- (unless gnus-single-article-buffer
- (save-excursion
- (set-buffer gnus-summary-buffer)
+ (with-current-buffer gnus-summary-buffer
+ ;; This might be a variable local to the summary buffer.
+ (unless gnus-single-article-buffer
(setq gnus-article-buffer name)
(setq gnus-original-article-buffer original)
(gnus-set-global-variables)))
(gnus-article-setup-highlight-words)
;; Init original article buffer.
- (save-excursion
- (set-buffer (gnus-get-buffer-create gnus-original-article-buffer))
+ (with-current-buffer (gnus-get-buffer-create gnus-original-article-buffer)
(mm-enable-multibyte)
(setq major-mode 'gnus-original-article-mode)
(make-local-variable 'gnus-original-article))
nil)
(error "Action aborted"))
t)))
- (save-excursion
- (set-buffer name)
+ (with-current-buffer name
(set (make-local-variable 'gnus-article-edit-mode) nil)
(when gnus-article-mime-handles
(mm-destroy-parts gnus-article-mime-handles)
(unless (eq major-mode 'gnus-article-mode)
(gnus-article-mode))
(current-buffer))
- (save-excursion
- (set-buffer (gnus-get-buffer-create name))
+ (with-current-buffer (gnus-get-buffer-create name)
(gnus-article-mode)
(make-local-variable 'gnus-summary-buffer)
+ (setq gnus-summary-buffer
+ (gnus-summary-buffer-name gnus-newsgroup-name))
(gnus-summary-set-local-parameters gnus-newsgroup-name)
(current-buffer)))))
;; Set article window start at LINE, where LINE is the number of lines
;; from the head of the article.
(defun gnus-article-set-window-start (&optional line)
- (set-window-start
- (gnus-get-buffer-window gnus-article-buffer t)
- (save-excursion
- (set-buffer gnus-article-buffer)
- (goto-char (point-min))
- (if (not line)
- (point-min)
- (gnus-message 6 "Moved to bookmark")
- (search-forward "\n\n" nil t)
- (forward-line line)
- (point)))))
+ (let ((article-window (gnus-get-buffer-window gnus-article-buffer t)))
+ (when article-window
+ (set-window-start
+ article-window
+ (with-current-buffer gnus-article-buffer
+ (goto-char (point-min))
+ (if (not line)
+ (point-min)
+ (gnus-message 6 "Moved to bookmark")
+ (search-forward "\n\n" nil t)
+ (forward-line line)
+ (point)))))))
(defun gnus-article-prepare (article &optional all-headers header)
"Prepare ARTICLE in article mode buffer.
(if (or (eq result 'pseudo)
(eq result 'nneething))
(progn
- (save-excursion
- (set-buffer summary-buffer)
+ (with-current-buffer summary-buffer
(push article gnus-newsgroup-history)
(setq gnus-last-article gnus-current-article
gnus-current-article 0
(not (eq article gnus-current-article)))
;; Seems like a new article has been selected.
;; `gnus-current-article' must be an article number.
- (save-excursion
- (set-buffer summary-buffer)
+ (with-current-buffer summary-buffer
(push article gnus-newsgroup-history)
(setq gnus-last-article gnus-current-article
gnus-current-article article
(funcall gnus-display-mime-function))
(gnus-run-hooks 'gnus-article-prepare-hook)))
+;;;
+;;; Gnus Sticky Article Mode
+;;;
+
+(define-derived-mode gnus-sticky-article-mode gnus-article-mode "StickyArticle"
+ "Mode for sticky articles."
+ ;; Release bindings that won't work.
+ (substitute-key-definition 'gnus-article-read-summary-keys 'undefined
+ gnus-sticky-article-mode-map)
+ (substitute-key-definition 'gnus-article-refer-article 'undefined
+ gnus-sticky-article-mode-map)
+ (dolist (k '("e" "h" "s" "F" "R"))
+ (define-key gnus-sticky-article-mode-map k nil))
+ (define-key gnus-sticky-article-mode-map "k" 'gnus-kill-sticky-article-buffer)
+ (define-key gnus-sticky-article-mode-map "q" 'bury-buffer)
+ (define-key gnus-sticky-article-mode-map "\C-hc" 'describe-key-briefly)
+ (define-key gnus-sticky-article-mode-map "\C-hk" 'describe-key))
+
+(defun gnus-sticky-article (arg)
+ "Make the current article sticky.
+If a prefix ARG is given, ask for a name for this sticky article buffer."
+ (interactive "P")
+ (gnus-summary-show-thread)
+ (gnus-summary-select-article nil nil 'pseudo)
+ (let (new-art-buf-name)
+ (gnus-eval-in-buffer-window gnus-article-buffer
+ (setq new-art-buf-name
+ (concat
+ "*Sticky Article: "
+ (if arg
+ (read-from-minibuffer "Sticky article buffer name: ")
+ (gnus-with-article-headers
+ (gnus-article-goto-header "subject")
+ (setq new-art-buf-name
+ (buffer-substring-no-properties
+ (line-beginning-position) (line-end-position)))
+ (goto-char (point-min))
+ (gnus-article-goto-header "from")
+ (setq new-art-buf-name
+ (concat
+ new-art-buf-name ", "
+ (buffer-substring-no-properties
+ (line-beginning-position) (line-end-position))))
+ (goto-char (point-min))
+ (gnus-article-goto-header "date")
+ (setq new-art-buf-name
+ (concat
+ new-art-buf-name ", "
+ (buffer-substring-no-properties
+ (line-beginning-position) (line-end-position))))))
+ "*"))
+ (if (and (gnus-buffer-live-p new-art-buf-name)
+ (with-current-buffer new-art-buf-name
+ (eq major-mode 'gnus-sticky-article-mode)))
+ (switch-to-buffer new-art-buf-name)
+ (setq new-art-buf-name (rename-buffer new-art-buf-name t)))
+ (gnus-sticky-article-mode))
+ (setq gnus-article-buffer new-art-buf-name))
+ (gnus-summary-recenter)
+ (gnus-summary-position-point))
+
+(defun gnus-kill-sticky-article-buffer (&optional buffer)
+ "Kill the given sticky article BUFFER.
+If none is given, assume the current buffer and kill it if it has
+`gnus-sticky-article-mode'."
+ (interactive)
+ (unless buffer
+ (setq buffer (current-buffer)))
+ (with-current-buffer buffer
+ (when (eq major-mode 'gnus-sticky-article-mode)
+ (gnus-kill-buffer buffer))))
+
+(defun gnus-kill-sticky-article-buffers (arg)
+ "Kill all sticky article buffers.
+If a prefix ARG is given, ask for confirmation."
+ (interactive "P")
+ (dolist (buf (gnus-buffers))
+ (with-current-buffer buf
+ (when (eq major-mode 'gnus-sticky-article-mode)
+ (if (not arg)
+ (gnus-kill-buffer buf)
+ (when (yes-or-no-p (concat "Kill buffer " (buffer-name buf) "? "))
+ (gnus-kill-buffer buf)))))))
+
;;;
;;; Gnus MIME viewing functions
;;;
(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-mime-button-menu gnus-mime-button-map "MIME button menu."
`("MIME Part"
,@(mapcar (lambda (c)
- (vector (caddr c) (car c) :enable t))
+ (vector (caddr c) (car c) :active t))
gnus-mime-button-commands)))
(defun gnus-mime-button-menu (event prefix)
(delete-region (point) (point-max))
(mm-display-parts handles))))))
+(defun gnus-article-jump-to-part (n)
+ "Jump to MIME part N."
+ (interactive "P")
+ (pop-to-buffer gnus-article-buffer)
+ ;; FIXME: why is it necessary?
+ (sit-for 0)
+ (let ((parts (length gnus-article-mime-handle-alist)))
+ (or n (setq n
+ (string-to-number
+ (read-string ;; Emacs 21 doesn't have `read-number'.
+ (format "Jump to part (2..%s): " parts)))))
+ (unless (and (integerp n) (<= n parts) (>= n 1))
+ (setq n
+ (progn
+ (gnus-message 7 "Invalid part `%s', using %s instead."
+ n parts)
+ parts)))
+ (gnus-message 9 "Jumping to part %s." n)
+ (cond ((>= gnus-auto-select-part 1)
+ (while (and (<= n parts)
+ (not (gnus-article-goto-part n)))
+ (setq n (1+ n))))
+ ((< gnus-auto-select-part 0)
+ (while (and (>= n 1)
+ (not (gnus-article-goto-part n)))
+ (setq n (1- n))))
+ (t
+ (gnus-article-goto-part n)))))
+
(eval-when-compile
- (defsubst gnus-article-edit-part (handles)
+ (defsubst gnus-article-edit-part (handles &optional current-id)
"Edit an article in order to delete a mime part.
This function is exclusively used by `gnus-mime-save-part-and-strip'
and `gnus-mime-delete-part', and not provided at run-time normally."
(gnus-article-edit-article
`(lambda ()
+ (buffer-disable-undo)
(erase-buffer)
(let ((mail-parse-charset (or gnus-article-charset
',gnus-newsgroup-charset))
',gnus-newsgroup-ignored-charsets))
(mbl mml-buffer-list))
(setq mml-buffer-list nil)
- (insert-buffer gnus-original-article-buffer)
+ (insert-buffer-substring gnus-original-article-buffer)
(mime-to-mml ',handles)
(setq gnus-article-mime-handles nil)
(let ((mbl1 mml-buffer-list))
(gnus-summary-edit-article-done
,(or (mail-header-references gnus-current-headers) "")
,(gnus-group-read-only-p)
- ,gnus-summary-buffer no-highlight)))
+ ,gnus-summary-buffer no-highlight))
+ t)
(gnus-article-edit-done)
(gnus-summary-expand-window)
- (gnus-summary-show-article)))
-
-(defun gnus-mime-save-part-and-strip ()
- "Save the MIME part under point then replace it with an external body."
+ (gnus-summary-show-article)
+ (when (and current-id (integerp gnus-auto-select-part))
+ (gnus-article-jump-to-part
+ (if (text-property-any (point-min) (point-max)
+ 'gnus-part (+ current-id gnus-auto-select-part))
+ (+ current-id gnus-auto-select-part)
+ (with-current-buffer gnus-article-buffer
+ (length gnus-article-mime-handle-alist)))))))
+
+(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)
(when (mm-complicated-handles gnus-article-mime-handles)
(error "\
The current article has a complicated MIME structure, giving up..."))
- (when (gnus-yes-or-no-p "\
-Deleting parts may malfunction or destroy the article; continue? ")
- (let* ((data (get-text-property (point) 'gnus-data))
- file param
- (handles gnus-article-mime-handles))
- (setq file (and data (mm-save-part data)))
- (when file
- (with-current-buffer (mm-handle-buffer data)
- (erase-buffer)
- (insert "Content-Type: " (mm-handle-media-type data))
- (mml-insert-parameter-string (cdr (mm-handle-type data))
- '(charset))
- (insert "\n")
- (insert "Content-ID: " (message-make-message-id) "\n")
- (insert "Content-Transfer-Encoding: binary\n")
- (insert "\n"))
- (setcdr data
- (cdr (mm-make-handle nil
- `("message/external-body"
- (access-type . "LOCAL-FILE")
- (name . ,file)))))
- (set-buffer gnus-summary-buffer)
- (gnus-article-edit-part handles)))))
+ (let* ((data (get-text-property (point) 'gnus-data))
+ (id (get-text-property (point) 'gnus-part))
+ param
+ (handles gnus-article-mime-handles))
+ (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)
+ (insert "Content-Type: " (mm-handle-media-type data))
+ (mml-insert-parameter-string (cdr (mm-handle-type data))
+ '(charset))
+ ;; Add a filename for the sake of saving the part again.
+ (mml-insert-parameter
+ (mail-header-encode-parameter "name" (file-name-nondirectory file)))
+ (insert "\n")
+ (insert "Content-ID: " (message-make-message-id) "\n")
+ (insert "Content-Transfer-Encoding: binary\n")
+ (insert "\n"))
+ (setcdr data
+ (cdr (mm-make-handle nil
+ `("message/external-body"
+ (access-type . "LOCAL-FILE")
+ (name . ,file)))))
+ ;; (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.
(when (mm-complicated-handles gnus-article-mime-handles)
(error "\
The current article has a complicated MIME structure, giving up..."))
- (when (gnus-yes-or-no-p "\
-Deleting parts may malfunction or destroy the article; continue? ")
+ (when (or gnus-expert-user
+ (gnus-yes-or-no-p "\
+Deleting parts may malfunction or destroy the article; continue? "))
(let* ((data (get-text-property (point) 'gnus-data))
+ (id (get-text-property (point) 'gnus-part))
(handles gnus-article-mime-handles)
(none "(none)")
(description
- (or
- (mail-decode-encoded-word-string (or (mm-handle-description data)
- none))))
+ (let ((desc (mm-handle-description data)))
+ (when desc
+ (mail-decode-encoded-word-string desc))))
(filename
(or (mail-content-type-get (mm-handle-disposition data) 'filename)
none))
"| Type: " type "\n"
"| Filename: " filename "\n"
"| Size (encoded): " bsize " Byte\n"
- "| Description: " description "\n"
+ (when description
+ (concat "| Description: " description "\n"))
"`----\n"))
(setcdr data
(cdr (mm-make-handle
nil `("text/plain") nil nil
(list "attachment")
(format "Deleted attachment (%s bytes)" bsize))))))
- (set-buffer gnus-summary-buffer)
- (gnus-article-edit-part handles))))
+ ;; (set-buffer gnus-summary-buffer)
+ (gnus-article-edit-part handles id))))
(defun gnus-mime-save-part ()
"Save the MIME part under point."
(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))))
-
-(defun gnus-mime-view-part-as-type (&optional mime-type)
- "Choose a MIME media type, and view the part as such."
+ (or (and def-type (cons def-type 0))
+ (and handle
+ (equal (mm-handle-media-supertype handle) "text")
+ '("text/plain" . 0))
+ '("application/octet-stream" . 0))))
+
+(defun gnus-mime-view-part-as-type (&optional mime-type pred)
+ "Choose a MIME media type, and view the part as such.
+If non-nil, PRED is a predicate to use during completion to limit the
+available media-types."
(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))
+ pred nil nil nil
+ (car default)))))
(gnus-article-check-buffer)
(let ((handle (get-text-property (point) 'gnus-data)))
(when handle
+ (when (equal (mm-handle-media-type handle) "message/external-body")
+ (unless (mm-handle-cache handle)
+ (mm-extern-cache-contents handle))
+ (setq handle (mm-handle-cache handle)))
(setq handle
(mm-make-handle (mm-handle-buffer handle)
(cons mime-type (cdr (mm-handle-type handle)))
(mm-handle-id handle)))
(setq gnus-article-mime-handles
(mm-merge-handles gnus-article-mime-handles handle))
+ (when (mm-handle-displayed-p handle)
+ (mm-remove-part handle))
(gnus-mm-display-part handle))))
(defun gnus-mime-copy-part (&optional handle arg)
(unless handle
(setq handle (get-text-property (point) 'gnus-data)))
(when handle
- (let ((filename (or (mail-content-type-get (mm-handle-disposition handle)
+ (let ((filename (or (mail-content-type-get (mm-handle-type handle)
'name)
(mail-content-type-get (mm-handle-disposition handle)
'filename)))
(mm-insert-part handle)
(setq contents
(or (mm-decompress-buffer
- (or (mail-content-type-get (mm-handle-disposition handle)
+ (or (mail-content-type-get (mm-handle-type handle)
'name)
(mail-content-type-get (mm-handle-disposition handle)
'filename))
(and charset
(setq coding-system
(mm-charset-to-coding-system charset))
- (not (eq charset 'ascii))))
+ (not (eq coding-system 'ascii))))
(mm-decode-coding-string contents coding-system)
(mm-string-to-multibyte contents)))
(goto-char b)))))
+(defun gnus-mime-strip-charset-parameters (handle)
+ "Strip charset parameters from HANDLE."
+ (if (stringp (car handle))
+ (mapc #'gnus-mime-strip-charset-parameters (cdr handle))
+ (let* ((type (mm-handle-type (if (equal (mm-handle-media-type handle)
+ "message/external-body")
+ (progn
+ (unless (mm-handle-cache handle)
+ (mm-extern-cache-contents handle))
+ (mm-handle-cache handle))
+ handle)))
+ (charset (assq 'charset (cdr type))))
+ (when charset
+ (delq charset type)))))
+
(defun gnus-mime-view-part-as-charset (&optional handle arg)
"Insert the MIME part under point into the current buffer using the
specified charset."
(interactive (list nil current-prefix-arg))
(gnus-article-check-buffer)
- (let* ((handle (or handle (get-text-property (point) 'gnus-data)))
- contents charset
- (b (point))
- (inhibit-read-only t))
+ (let ((handle (or handle (get-text-property (point) 'gnus-data)))
+ (fun (get-text-property (point) 'gnus-callback))
+ (gnus-newsgroup-ignored-charsets 'gnus-all)
+ gnus-newsgroup-charset form preferred parts)
(when handle
- (if (mm-handle-undisplayer handle)
- (mm-remove-part handle))
- (let ((gnus-newsgroup-charset
- (or (cdr (assq arg
- gnus-summary-show-article-charset-alist))
- (mm-read-coding-system "Charset: ")))
- (gnus-newsgroup-ignored-charsets 'gnus-all))
- (gnus-article-press-button)))))
+ (when (prog1
+ (and fun
+ (setq gnus-newsgroup-charset
+ (or (cdr (assq
+ arg
+ gnus-summary-show-article-charset-alist))
+ (mm-read-coding-system "Charset: "))))
+ (if (mm-handle-undisplayer handle)
+ (mm-remove-part handle)))
+ (gnus-mime-strip-charset-parameters handle)
+ (when (and (consp (setq form (cdr-safe fun)))
+ (setq form (ignore-errors
+ (assq 'gnus-mime-display-alternative form)))
+ (setq preferred (caddr form))
+ (progn
+ (when (eq (car preferred) 'quote)
+ (setq preferred (cadr preferred)))
+ (not (equal preferred
+ (get-text-property (point) 'gnus-data))))
+ (setq parts (get-text-property (point) 'gnus-part))
+ (setq parts (cdr (assq parts
+ gnus-article-mime-handle-alist)))
+ (equal (mm-handle-media-type parts) "multipart/alternative")
+ (setq parts (reverse (cdr parts))))
+ (setcar (cddr form)
+ (list 'quote (or (cadr (member preferred parts))
+ (car parts)))))
+ (funcall fun handle)))))
(defun gnus-mime-view-part-externally (&optional handle)
"View the MIME part under point with an external viewer."
(mm-inlined-types nil)
(mail-parse-charset gnus-newsgroup-charset)
(mail-parse-ignored-charsets
- (with-current-buffer gnus-summary-buffer
- gnus-newsgroup-ignored-charsets)))
- (when handle
- (if (mm-handle-undisplayer handle)
- (mm-remove-part handle)
- (mm-display-part handle)))))
+ (with-current-buffer gnus-summary-buffer
+ gnus-newsgroup-ignored-charsets))
+ (type (mm-handle-media-type handle))
+ (method (mailcap-mime-info type))
+ (mm-enable-external t))
+ (if (not (stringp method))
+ (gnus-mime-view-part-as-type
+ nil (lambda (types) (stringp (mailcap-mime-info (car types)))))
+ (when handle
+ (if (mm-handle-undisplayer handle)
+ (mm-remove-part handle)
+ (mm-display-part handle))))))
(defun gnus-mime-view-part-internally (&optional handle)
"View the MIME part under point with an internal viewer.
(with-current-buffer gnus-summary-buffer
gnus-newsgroup-ignored-charsets))
(inhibit-read-only t))
- (when handle
- (if (mm-handle-undisplayer handle)
- (mm-remove-part handle)
- (mm-display-part handle)))))
+ (if (not (mm-inlinable-p handle))
+ (gnus-mime-view-part-as-type
+ nil (lambda (types) (mm-inlinable-p handle (car types))))
+ (when handle
+ (if (mm-handle-undisplayer handle)
+ (mm-remove-part handle)
+ (mm-display-part handle))))))
(defun gnus-mime-action-on-part (&optional action)
"Do something with the MIME attachment at \(point\)."
(if action-pair
(funcall (cdr action-pair)))))
-(defun gnus-article-part-wrapper (n function)
- (with-current-buffer gnus-article-buffer
- (when (> n (length gnus-article-mime-handle-alist))
- (error "No such part"))
- (gnus-article-goto-part n)
- (let ((handle (cdr (assq n gnus-article-mime-handle-alist))))
- (funcall function 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)
+ (setq window (get-buffer-window gnus-article-buffer t))
+ (frame-visible-p (setq frame (window-frame window))))
+ (error "No article is displayed"))
+ (with-current-buffer gnus-article-buffer
+ ;; Check whether the article displays the right contents.
+ (unless (with-current-buffer gnus-summary-buffer
+ (eq gnus-current-article (gnus-summary-article-number)))
+ (error "You should select the right article first"))
+ (if n
+ (setq n (prefix-numeric-value n))
+ (let ((pt (point)))
+ (setq n (or (get-text-property pt 'gnus-part)
+ (and (not (bobp))
+ (get-text-property (1- pt) 'gnus-part))
+ (get-text-property (prog2
+ (forward-line 1)
+ (point)
+ (goto-char pt))
+ 'gnus-part)
+ (get-text-property
+ (or (and (setq pt (previous-single-property-change
+ pt 'gnus-part))
+ (1- pt))
+ (next-single-property-change (point) 'gnus-part)
+ (point))
+ 'gnus-part)
+ 1))))
+ ;; Check whether the specified part exists.
+ (when (> n (length gnus-article-mime-handle-alist))
+ (error "No such part")))
+ (unless
+ (progn
+ ;; To select the window is needed so that the cursor
+ ;; might be visible on the MIME button.
+ (select-window (prog1
+ window
+ (setq window (selected-window))
+ ;; Article may be displayed in the other frame.
+ (gnus-select-frame-set-input-focus
+ (prog1
+ frame
+ (setq frame (selected-frame))))))
+ (when (gnus-article-goto-part n)
+ ;; We point the cursor and the arrow at the MIME button
+ ;; when the `function' prompt the user for something.
+ (let ((cursor-in-non-selected-windows t)
+ (overlay-arrow-string "=>")
+ (overlay-arrow-position (point-marker)))
+ (unwind-protect
+ (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)))))
+ (set-marker overlay-arrow-position nil)
+ (unless gnus-auto-select-part
+ (gnus-select-frame-set-input-focus frame)
+ (select-window window))))
+ t))
+ (if gnus-inhibit-mime-unbuttonizing
+ ;; This is the default though the program shouldn't reach here.
+ (error "No such part")
+ ;; The part which doesn't have the MIME button is selected.
+ ;; So, we display all the buttons and redo it.
+ (let ((gnus-inhibit-mime-unbuttonizing t))
+ (gnus-summary-show-article)
+ (gnus-article-part-wrapper n function no-handle))))))
(defun gnus-article-pipe-part (n)
"Pipe MIME part N, which is the numerical prefix."
- (interactive "p")
+ (interactive "P")
(gnus-article-part-wrapper n 'mm-pipe-part))
(defun gnus-article-save-part (n)
"Save MIME part N, which is the numerical prefix."
- (interactive "p")
+ (interactive "P")
(gnus-article-part-wrapper n 'mm-save-part))
(defun gnus-article-interactively-view-part (n)
"View MIME part N interactively, which is the numerical prefix."
- (interactive "p")
+ (interactive "P")
(gnus-article-part-wrapper n 'mm-interactively-view-part))
(defun gnus-article-copy-part (n)
"Copy MIME part N, which is the numerical prefix."
- (interactive "p")
+ (interactive "P")
(gnus-article-part-wrapper n 'gnus-mime-copy-part))
(defun gnus-article-view-part-as-charset (n)
"View MIME part N using a specified charset.
N is the numerical prefix."
- (interactive "p")
+ (interactive "P")
(gnus-article-part-wrapper n 'gnus-mime-view-part-as-charset))
(defun gnus-article-view-part-externally (n)
"View MIME part N externally, which is the numerical prefix."
- (interactive "p")
+ (interactive "P")
(gnus-article-part-wrapper n 'gnus-mime-view-part-externally))
(defun gnus-article-inline-part (n)
"Inline MIME part N, which is the numerical prefix."
- (interactive "p")
+ (interactive "P")
(gnus-article-part-wrapper n 'gnus-mime-inline-part))
+(defun gnus-article-save-part-and-strip (n)
+ "Save MIME part N and replace it with an external body.
+N is the numerical prefix."
+ (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."
+ (interactive "P")
+ (gnus-article-part-wrapper n 'gnus-mime-delete-part t))
+
+(defun gnus-article-view-part-as-type (n)
+ "Choose a MIME media type, and view part N as such.
+N is the numerical prefix."
+ (interactive "P")
+ (gnus-article-part-wrapper n 'gnus-mime-view-part-as-type t))
+
(defun gnus-article-mime-match-handle-first (condition)
(if condition
(let (n)
(mail-content-type-get (mm-handle-type handle) 'url)
""))
(gnus-tmp-type (mm-handle-media-type handle))
- (gnus-tmp-description
- (mail-decode-encoded-word-string (or (mm-handle-description handle)
- "")))
+ (gnus-tmp-description (or (mm-handle-description handle) ""))
(gnus-tmp-dots
(if (if displayed (car displayed)
(mm-handle-displayed-p handle))
;; Exclude a newline.
(1- (point))
(point)))
+ (when gnus-article-button-face
+ (gnus-overlay-put (gnus-make-overlay b e nil t)
+ 'face gnus-article-button-face))
(widget-convert-button
'link b e
:mime-handle handle
(set-window-point window point)))
(let ((handles ihandles)
(inhibit-read-only t)
- handle name type b e display)
+ handle)
(cond (handles)
((setq handles (mm-dissect-buffer nil gnus-article-loose-mime))
(when gnus-article-emulate-mime
(save-restriction
(article-goto-body)
(narrow-to-region (point-min) (point))
- (gnus-treat-article 'head))))))))
+ (gnus-article-save-original-date
+ (gnus-treat-article 'head)))))))
+ ;; Cope with broken MIME messages.
+ (goto-char (point-max))
+ (unless (bolp)
+ (insert "\n"))))
(defcustom gnus-mime-display-multipart-as-mixed nil
"Display \"multipart\" parts as \"multipart/mixed\".
(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))
(let ((id (1+ (length gnus-article-mime-handle-alist)))
beg)
(push (cons id handle) gnus-article-mime-handle-alist)
+ (when (and display
+ (equal (mm-handle-media-supertype handle) "message"))
+ (insert-char
+ ?\n
+ (cond ((not (bolp)) 2)
+ ((or (bobp) (eq (char-before (1- (point))) ?\n)) 0)
+ (t 1))))
(when (or (not display)
(not (gnus-unbuttonized-mime-type-p type)))
(gnus-insert-mime-button
(forward-line -1)
(setq beg (point)))
(gnus-article-insert-newline)
- (mm-display-inline handle)
+ (mm-insert-inline
+ handle
+ (let ((charset (or (mail-content-type-get (mm-handle-type handle)
+ 'charset)
+ (and (equal type "text/calendar") 'utf-8))))
+ (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
(save-restriction
(narrow-to-region beg (point))
- (gnus-treat-article
- nil id
- (gnus-article-mime-total-parts)
- (mm-handle-media-type handle)))))))))
+ (if (eq handle gnus-article-mime-handles)
+ ;; The format=flowed case.
+ (gnus-treat-article nil 1 1 (mm-handle-media-type handle))
+ ;; Don't count signature parts that are never displayed.
+ ;; The part number should be re-calculated supposing this
+ ;; might be a message/rfc822 part.
+ (let (handles)
+ (dolist (part gnus-article-mime-handles)
+ (unless (or (stringp part)
+ (equal (car (mm-handle-type part))
+ "application/pgp-signature"))
+ (push part handles)))
+ (gnus-treat-article
+ nil (length (memq handle handles)) (length handles)
+ (mm-handle-media-type handle)))))))))))
(defun gnus-unbuttonized-mime-type-p (type)
"Say whether TYPE is to be unbuttonized."
,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)
;;; Article savers.
(defun gnus-output-to-file (file-name)
- "Append the current article to a file named FILE-NAME."
- (let ((artbuf (current-buffer)))
+ "Append the current article to a file named FILE-NAME.
+If `gnus-article-save-coding-system' is non-nil, it is used to encode
+text and used as the value of the coding cookie which is added to the
+top of a file. Otherwise, this function saves a raw article without
+the coding cookie."
+ (let* ((artbuf (current-buffer))
+ (file-name-coding-system nnmail-pathname-coding-system)
+ (coding gnus-article-save-coding-system)
+ (coding-system-for-read (if coding
+ nil ;; Rely on the coding cookie.
+ mm-text-coding-system))
+ (coding-system-for-write (or coding
+ mm-text-coding-system-for-write
+ mm-text-coding-system))
+ (exists (file-exists-p file-name)))
(with-temp-buffer
+ (when exists
+ (insert-file-contents file-name)
+ (goto-char (point-min))
+ ;; Remove the existing coding cookie.
+ (when (looking-at "X-Gnus-Coding-System: .+\n\n")
+ (delete-region (match-beginning 0) (match-end 0))))
+ (goto-char (point-max))
(insert-buffer-substring artbuf)
;; Append newline at end of the buffer as separator, and then
;; save it to file.
(goto-char (point-max))
(insert "\n")
- (let ((file-name-coding-system nnmail-pathname-coding-system))
- (mm-append-to-file (point-min) (point-max) file-name))
- t)))
+ (when coding
+ ;; If the coding system is not suitable to encode the text,
+ ;; ask a user for a proper one.
+ (when (fboundp 'select-safe-coding-system)
+ (setq coding (coding-system-base
+ (save-window-excursion
+ (select-safe-coding-system (point-min) (point-max)
+ coding))))
+ (setq coding-system-for-write
+ (or (cdr (assq coding '((mule-utf-8 . utf-8))))
+ coding)))
+ (goto-char (point-min))
+ ;; Add the coding cookie.
+ (insert (format "X-Gnus-Coding-System: -*- coding: %s; -*-\n\n"
+ coding-system-for-write)))
+ (if exists
+ (progn
+ (write-region (point-min) (point-max) file-name nil 'no-message)
+ (message "Appended to %s" file-name))
+ (write-region (point-min) (point-max) file-name))))
+ t)
(defun gnus-narrow-to-page (&optional arg)
"Narrow the article buffer to a page.
If given a numerical ARG, move forward ARG pages."
(interactive "P")
(setq arg (if arg (prefix-numeric-value arg) 0))
- (save-excursion
- (set-buffer gnus-article-buffer)
- (goto-char (point-min))
+ (with-current-buffer gnus-article-buffer
(widen)
;; Remove any old next/prev buttons.
(when (gnus-visual-p 'page-marker)
(let ((inhibit-read-only t))
(gnus-remove-text-with-property 'gnus-prev)
(gnus-remove-text-with-property 'gnus-next)))
- (if
- (cond ((< arg 0)
- (re-search-backward page-delimiter nil 'move (1+ (abs arg))))
- ((> arg 0)
- (re-search-forward page-delimiter nil 'move arg)))
- (goto-char (match-end 0))
- (save-excursion
- (goto-char (point-min))
- (setq gnus-page-broken
- (and (re-search-forward page-delimiter nil t) t))))
- (when gnus-page-broken
- (narrow-to-region
- (point)
- (if (re-search-forward page-delimiter nil 'move)
- (match-beginning 0)
- (point)))
- (when (and (gnus-visual-p 'page-marker)
- (> (point-min) (save-restriction (widen) (point-min))))
- (save-excursion
- (goto-char (point-min))
- (gnus-insert-prev-page-button)))
- (when (and (gnus-visual-p 'page-marker)
- (< (point-max) (save-restriction (widen) (point-max))))
- (save-excursion
- (goto-char (point-max))
- (gnus-insert-next-page-button))))))
+ (let (st nd pt)
+ (when (save-excursion
+ (cond ((< arg 0)
+ (if (re-search-backward page-delimiter nil 'move (abs arg))
+ (prog1
+ (setq nd (match-beginning 0)
+ pt nd)
+ (when (re-search-backward page-delimiter nil t)
+ (setq st (match-end 0))))
+ (when (re-search-forward page-delimiter nil t)
+ (setq nd (match-beginning 0)
+ pt (point-min)))))
+ ((> arg 0)
+ (if (re-search-forward page-delimiter nil 'move arg)
+ (prog1
+ (setq st (match-end 0)
+ pt st)
+ (when (re-search-forward page-delimiter nil t)
+ (setq nd (match-beginning 0))))
+ (when (re-search-backward page-delimiter nil t)
+ (setq st (match-end 0)
+ pt (point-max)))))
+ (t
+ (when (re-search-backward page-delimiter nil t)
+ (goto-char (setq st (match-end 0))))
+ (when (re-search-forward page-delimiter nil t)
+ (setq nd (match-beginning 0)))
+ (or st nd))))
+ (setq gnus-page-broken t)
+ (when pt (goto-char pt))
+ (narrow-to-region (or st (point-min)) (or nd (point-max)))
+ (when (gnus-visual-p 'page-marker)
+ (save-excursion
+ (when nd
+ (goto-char nd)
+ (gnus-insert-next-page-button))
+ (when st
+ (goto-char st)
+ (gnus-insert-prev-page-button))))))))
;; Article mode commands
(defun gnus-article-goto-prev-page ()
"Show the previous page of the article."
(interactive)
- (if (bobp)
+ (if (save-restriction (widen) (bobp)) ;; Real beginning-of-buffer?
(gnus-article-read-summary-keys nil (gnus-character-to-event ?p))
(gnus-article-prev-page nil)))
Argument LINES specifies lines to be scrolled up."
(interactive "p")
(move-to-window-line -1)
- (if (save-excursion
- (end-of-line)
- (and (pos-visible-in-window-p) ;Not continuation line.
- (>= (1+ (point)) (point-max)))) ;Allow for trailing newline.
+ (if (and (not (and gnus-article-over-scroll
+ (> (count-lines (window-start) (point-max))
+ (+ (or lines (1- (window-height)))
+ (or (and (boundp 'scroll-margin)
+ (symbol-value 'scroll-margin))
+ 0)))))
+ (save-excursion
+ (end-of-line)
+ (and (pos-visible-in-window-p) ;Not continuation line.
+ (>= (1+ (point)) (point-max))))) ;Allow for trailing newline.
;; Nothing in this page.
(if (or (not gnus-page-broken)
(save-excursion
(gnus-article-next-page-1 lines)
nil))
+(defmacro gnus-article-beginning-of-window ()
+ "Move point to the beginning of the window.
+In Emacs, the point is placed at the line number which `scroll-margin'
+specifies."
+ (if (featurep 'xemacs)
+ '(move-to-window-line 0)
+ '(move-to-window-line
+ (min (max 0 scroll-margin)
+ (max 1 (- (window-height)
+ (if mode-line-format 1 0)
+ (if header-line-format 1 0)))))))
+
(defun gnus-article-next-page-1 (lines)
- (let ((scroll-in-place nil))
- (condition-case ()
- (scroll-up lines)
- (end-of-buffer
- ;; Long lines may cause an end-of-buffer error.
- (goto-char (point-max)))))
- (move-to-window-line 0))
+ (when (and (not (featurep 'xemacs))
+ (numberp lines)
+ (> lines 0)
+ (numberp (symbol-value 'scroll-margin))
+ (> (symbol-value 'scroll-margin) 0))
+ ;; Protect against the bug that Emacs 21.x hangs up when scrolling up for
+ ;; too many number of lines if `scroll-margin' is set as two or greater.
+ (setq lines (min lines
+ (max 0 (- (count-lines (window-start) (point-max))
+ (symbol-value 'scroll-margin))))))
+ (condition-case ()
+ (let ((scroll-in-place nil))
+ (scroll-up lines))
+ (end-of-buffer
+ ;; Long lines may cause an end-of-buffer error.
+ (goto-char (point-max))))
+ (gnus-article-beginning-of-window))
(defun gnus-article-prev-page (&optional lines)
"Show previous page of current article.
(progn
(gnus-narrow-to-page -1) ;Go to previous page.
(goto-char (point-max))
- (recenter -1))
- (let ((scroll-in-place nil))
- (prog1
- (condition-case ()
- (scroll-down lines)
- (beginning-of-buffer
- (goto-char (point-min))))
- (move-to-window-line 0)))))
+ (recenter (if gnus-article-over-scroll
+ (if lines
+ (max (+ lines (or (and (boundp 'scroll-margin)
+ (symbol-value 'scroll-margin))
+ 0))
+ 3)
+ (- (window-height) 2))
+ -1)))
+ (prog1
+ (condition-case ()
+ (let ((scroll-in-place nil))
+ (scroll-down lines))
+ (beginning-of-buffer
+ (goto-char (point-min))))
+ (gnus-article-beginning-of-window))))
(defun gnus-article-only-boring-p ()
"Decide whether there is only boring text remaining in the article.
(boundp 'gnus-article-boring-faces)
(symbol-value 'gnus-article-boring-faces))
(save-excursion
- (catch 'only-boring
- (while (re-search-forward "\\b\\w\\w" nil t)
- (forward-char -1)
- (when (not (gnus-intersection
- (gnus-faces-at (point))
- (symbol-value 'gnus-article-boring-faces)))
- (throw 'only-boring nil)))
- (throw 'only-boring t)))))
+ (let ((inhibit-point-motion-hooks t))
+ (catch 'only-boring
+ (while (re-search-forward "\\b\\w\\w" nil t)
+ (forward-char -1)
+ (when (not (gnus-intersection
+ (gnus-faces-at (point))
+ (symbol-value 'gnus-article-boring-faces)))
+ (throw 'only-boring nil)))
+ (throw 'only-boring t))))))
(defun gnus-article-refer-article ()
"Read article specified by message-id around point."
"Execute the last keystroke in the summary buffer."
(interactive)
(let (func)
- (pop-to-buffer gnus-article-current-summary 'norecord)
+ (pop-to-buffer gnus-article-current-summary)
(setq func (lookup-key (current-local-map) (this-command-keys)))
(call-interactively func)))
"Zc" "ZC" "ZE" "ZQ" "ZZ" "Zn" "ZR" "ZG" "ZN" "ZP"
"=" "^" "\M-^" "|"))
(nosave-but-article
- '("A\r"))
+ '("A " "A<" "A>" "AM" "AP" "AR" "AT" "A\C-?" "A\M-\r" "A\r" "Ab" "Ae"
+ "An" "Ap" [?A (meta return)] [?A delete]))
(nosave-in-article
- '("\C-d"))
+ '("AS" "\C-d"))
(up-to-top
'("n" "Gn" "p" "Gp"))
keys new-sum-point)
- (save-excursion
- (set-buffer gnus-article-current-summary)
+ (with-current-buffer gnus-article-current-summary
(let (gnus-pick-mode)
- (push (or key last-command-event) unread-command-events)
- (setq keys (if (featurep 'xemacs)
- (events-to-keys (read-key-sequence nil))
- (read-key-sequence nil)))))
+ (setq unread-command-events (nconc unread-command-events
+ (list (or key last-command-event)))
+ keys (if (featurep 'xemacs)
+ (events-to-keys (read-key-sequence nil t))
+ (read-key-sequence nil t)))))
(message "")
- (if (or (member keys nosaves)
- (member keys nosave-but-article)
- (member keys nosave-in-article))
- (let (func)
- (save-window-excursion
- (pop-to-buffer gnus-article-current-summary 'norecord)
- ;; We disable the pick minor mode commands.
- (let (gnus-pick-mode)
- (setq func (lookup-key (current-local-map) keys))))
- (if (or (not func)
- (numberp func))
- (ding)
- (unless (member keys nosave-in-article)
- (set-buffer gnus-article-current-summary))
- (call-interactively func)
- (setq new-sum-point (point)))
- (when (member keys nosave-but-article)
- (pop-to-buffer gnus-article-buffer 'norecord)))
+ (cond
+ ((eq (aref keys (1- (length keys))) ?\C-h)
+ (gnus-article-describe-bindings (substring keys 0 -1)))
+ ((or (member keys nosaves)
+ (member keys nosave-but-article)
+ (member keys nosave-in-article))
+ (let (func)
+ (save-window-excursion
+ (pop-to-buffer gnus-article-current-summary)
+ ;; We disable the pick minor mode commands.
+ (let (gnus-pick-mode)
+ (setq func (lookup-key (current-local-map) keys))))
+ (if (or (not func)
+ (numberp func))
+ (ding)
+ (unless (member keys nosave-in-article)
+ (set-buffer gnus-article-current-summary))
+ (call-interactively func)
+ (setq new-sum-point (point)))
+ (when (member keys nosave-but-article)
+ (pop-to-buffer gnus-article-buffer))))
+ (t
;; These commands should restore window configuration.
(let ((obuf (current-buffer))
(owin (current-window-configuration))
- (opoint (point))
- win func in-buffer selected new-sum-start new-sum-hscroll)
+ win func in-buffer selected new-sum-start new-sum-hscroll err)
(cond (not-restore-window
- (pop-to-buffer gnus-article-current-summary 'norecord))
+ (pop-to-buffer gnus-article-current-summary)
+ (setq win (selected-window)))
((setq win (get-buffer-window gnus-article-current-summary))
(select-window win))
(t
- (switch-to-buffer gnus-article-current-summary 'norecord)))
+ (let ((summary-buffer gnus-article-current-summary))
+ (gnus-configure-windows 'article)
+ (unless (setq win (get-buffer-window summary-buffer 'visible))
+ (let ((gnus-buffer-configuration
+ '(article ((vertical 1.0
+ (summary 0.25 point)
+ (article 1.0))))))
+ (gnus-configure-windows 'article))
+ (setq win (get-buffer-window summary-buffer 'visible)))
+ (gnus-select-frame-set-input-focus (window-frame win))
+ (select-window win))))
(setq in-buffer (current-buffer))
;; We disable the pick minor mode commands.
(if (and (setq func (let (gnus-pick-mode)
(lookup-key (current-local-map) keys)))
- (functionp func))
+ (functionp func)
+ (condition-case code
+ (progn
+ (call-interactively func)
+ t)
+ (error
+ (setq err code)
+ nil)))
(progn
- (call-interactively func)
(when (eq win (selected-window))
(setq new-sum-point (point)
new-sum-start (window-start win)
- new-sum-hscroll (window-hscroll win))
- (when (eq in-buffer (current-buffer))
+ new-sum-hscroll (window-hscroll win)))
+ (when (or (eq in-buffer (current-buffer))
+ (when (eq obuf (current-buffer))
+ (set-buffer in-buffer)
+ t))
(setq selected (gnus-summary-select-article))
(set-buffer obuf)
(unless not-restore-window
(set-window-configuration owin))
- (when (eq selected 'old)
- (article-goto-body)
+ (when (and (eq selected 'old)
+ new-sum-point)
(set-window-start (get-buffer-window (current-buffer))
1)
(set-window-point (get-buffer-window (current-buffer))
- (point)))
+ (if (article-goto-body)
+ (1- (point))
+ (point))))
(when (and (not not-restore-window)
- new-sum-point)
+ new-sum-point
+ (with-current-buffer (window-buffer win)
+ (eq major-mode 'gnus-summary-mode)))
(set-window-point win new-sum-point)
(set-window-start win new-sum-start)
- (set-window-hscroll win new-sum-hscroll)))))
+ (set-window-hscroll win new-sum-hscroll))))
(set-window-configuration owin)
- (ding))))))
+ (if err
+ (signal (car err) (cdr err))
+ (ding))))))))
+
+(defun gnus-article-read-summary-send-keys ()
+ (interactive)
+ (let ((unread-command-events (list (gnus-character-to-event ?S))))
+ (gnus-article-read-summary-keys)))
(defun gnus-article-describe-key (key)
- "Display documentation of the function invoked by KEY. KEY is a string."
- (interactive "kDescribe key: ")
+ "Display documentation of the function invoked by KEY.
+KEY is a string or a vector."
+ (interactive (list (let ((cursor-in-echo-area t)) ;; better for XEmacs.
+ (read-key-sequence "Describe key: "))))
(gnus-article-check-buffer)
- (if (eq (key-binding key) 'gnus-article-read-summary-keys)
- (save-excursion
- (set-buffer gnus-article-current-summary)
- (let (gnus-pick-mode)
- (if (featurep 'xemacs)
- (progn
- (push (elt key 0) unread-command-events)
- (setq key (events-to-keys
- (read-key-sequence "Describe key: "))))
- (setq unread-command-events
- (mapcar
- (lambda (x) (if (>= x 128) (list 'meta (- x 128)) x))
- (string-to-list key)))
- (setq key (read-key-sequence "Describe key: "))))
- (describe-key key))
+ (if (memq (key-binding key t) '(gnus-article-read-summary-keys
+ gnus-article-read-summary-send-keys))
+ (with-current-buffer gnus-article-current-summary
+ (setq unread-command-events
+ (if (featurep 'xemacs)
+ (append key nil)
+ (mapcar (lambda (x) (if (and (integerp x) (>= x 128))
+ (list 'meta (- x 128))
+ x))
+ key)))
+ (let ((cursor-in-echo-area t)
+ gnus-pick-mode)
+ (describe-key (read-key-sequence nil t))))
(describe-key key)))
(defun gnus-article-describe-key-briefly (key &optional insert)
- "Display documentation of the function invoked by KEY. KEY is a string."
- (interactive "kDescribe key: \nP")
+ "Display documentation of the function invoked by KEY.
+KEY is a string or a vector."
+ (interactive (list (let ((cursor-in-echo-area t)) ;; better for XEmacs.
+ (read-key-sequence "Describe key: "))
+ current-prefix-arg))
(gnus-article-check-buffer)
- (if (eq (key-binding key) 'gnus-article-read-summary-keys)
- (save-excursion
- (set-buffer gnus-article-current-summary)
- (let (gnus-pick-mode)
- (if (featurep 'xemacs)
- (progn
- (push (elt key 0) unread-command-events)
- (setq key (events-to-keys
- (read-key-sequence "Describe key: "))))
- (setq unread-command-events
- (mapcar
- (lambda (x) (if (>= x 128) (list 'meta (- x 128)) x))
- (string-to-list key)))
- (setq key (read-key-sequence "Describe key: "))))
- (describe-key-briefly key insert))
+ (if (memq (key-binding key t) '(gnus-article-read-summary-keys
+ gnus-article-read-summary-send-keys))
+ (with-current-buffer gnus-article-current-summary
+ (setq unread-command-events
+ (if (featurep 'xemacs)
+ (append key nil)
+ (mapcar (lambda (x) (if (and (integerp x) (>= x 128))
+ (list 'meta (- x 128))
+ x))
+ key)))
+ (let ((cursor-in-echo-area t)
+ gnus-pick-mode)
+ (describe-key-briefly (read-key-sequence nil t) insert)))
(describe-key-briefly key insert)))
+;;`gnus-agent-mode' in gnus-agent.el will define it.
+(defvar gnus-agent-summary-mode)
+(defvar gnus-draft-mode)
+
+(defun gnus-article-describe-bindings (&optional prefix)
+ "Show a list of all defined keys, and their definitions.
+The optional argument PREFIX, if non-nil, should be a key sequence;
+then we display only bindings that start with that prefix."
+ (interactive)
+ (gnus-article-check-buffer)
+ (let ((keymap (copy-keymap gnus-article-mode-map))
+ (map (copy-keymap gnus-article-send-map))
+ (sumkeys (where-is-internal 'gnus-article-read-summary-keys))
+ agent draft)
+ (define-key keymap "S" map)
+ (define-key map [t] nil)
+ (with-current-buffer gnus-article-current-summary
+ (set-keymap-parent map (key-binding "S"))
+ (let (key def gnus-pick-mode)
+ (while sumkeys
+ (setq key (pop sumkeys))
+ (cond ((and (vectorp key) (= (length key) 1)
+ (consp (setq def (aref key 0)))
+ (numberp (car def)) (numberp (cdr def)))
+ (when (< (max (car def) (cdr def)) 128)
+ (setq sumkeys
+ (append (mapcar
+ #'vector
+ (nreverse (gnus-uncompress-range def)))
+ sumkeys))))
+ ((setq def (key-binding key))
+ (unless (eq def 'undefined)
+ (define-key keymap key def))))))
+ (when (boundp 'gnus-agent-summary-mode)
+ (setq agent gnus-agent-summary-mode))
+ (when (boundp 'gnus-draft-mode)
+ (setq draft gnus-draft-mode)))
+ (with-temp-buffer
+ (use-local-map keymap)
+ (set (make-local-variable 'gnus-agent-summary-mode) agent)
+ (set (make-local-variable 'gnus-draft-mode) draft)
+ (describe-bindings prefix))
+ (let ((item `((lambda (prefix)
+ (with-current-buffer ,(current-buffer)
+ (gnus-article-describe-bindings prefix)))
+ ,prefix)))
+ (with-current-buffer (if (fboundp 'help-buffer)
+ (let (help-xref-following) (help-buffer))
+ "*Help*") ;; Emacs 21
+ (setq help-xref-stack-item item)))))
+
(defun gnus-article-reply-with-original (&optional wide)
"Start composing a reply mail to the current message.
The text in the region will be yanked. If the region isn't active,
the entire article will be yanked."
- (interactive "P")
+ (interactive)
(let ((article (cdr gnus-article-current))
contents)
(if (not (gnus-region-active-p))
(gnus-summary-reply
(list (list article contents)) wide)))))
+(defun gnus-article-wide-reply-with-original ()
+ "Start composing a wide reply mail to the current message.
+The text in the region will be yanked. If the region isn't active,
+the entire article will be yanked."
+ (interactive)
+ (gnus-article-reply-with-original t))
+
(defun gnus-article-followup-with-original ()
"Compose a followup to the current article.
The text in the region will be yanked. If the region isn't active,
gnus-summary-buffer
(get-buffer gnus-summary-buffer)
(gnus-buffer-exists-p gnus-summary-buffer))
- (save-excursion
- (set-buffer gnus-summary-buffer)
+ (with-current-buffer gnus-summary-buffer
(let ((header (gnus-summary-article-header article)))
(when (< article 0)
(cond
,(or (mail-header-references gnus-current-headers) "")
,(gnus-group-read-only-p) ,gnus-summary-buffer no-highlight))))
-(defun gnus-article-edit-article (start-func exit-func)
+(defun gnus-article-edit-article (start-func exit-func &optional quiet)
"Start editing the contents of the current article buffer."
(let ((winconf (current-window-configuration)))
(set-buffer gnus-article-buffer)
(gnus-configure-windows 'edit-article)
(setq gnus-article-edit-done-function exit-func)
(setq gnus-prev-winconf winconf)
- (gnus-message 6 "C-c C-c to end edits")))
+ (unless quiet
+ (gnus-message 6 "C-c C-c to end edits"))))
(defun gnus-article-edit-done (&optional arg)
"Update the article edits and exit."
(gnus-backlog-remove-article
(car gnus-article-current) (cdr gnus-article-current)))
;; Flush original article as well.
- (save-excursion
- (when (get-buffer gnus-original-article-buffer)
- (set-buffer gnus-original-article-buffer)
+ (when (get-buffer gnus-original-article-buffer)
+ (with-current-buffer gnus-original-article-buffer
(setq gnus-original-article nil)))
(when gnus-use-cache
(gnus-cache-update-article
(window-start (window-start)))
(erase-buffer)
(if (gnus-buffer-live-p gnus-original-article-buffer)
- (insert-buffer gnus-original-article-buffer))
+ (insert-buffer-substring gnus-original-article-buffer))
(let ((winconf gnus-prev-winconf))
(kill-all-local-variables)
(gnus-article-mode)
;;; Internal Variables:
(defcustom gnus-button-url-regexp
- (if (string-match "[[:digit:]]" "1") ;; support POSIX?
- "\\b\\(\\(www\\.\\|\\(s?https?\\|ftp\\|file\\|gopher\\|nntp\\|news\\|telnet\\|wais\\|mailto\\|info\\):\\)\\(//[-a-z0-9_.]+:[0-9]*\\)?[-a-z0-9_=!?#$@~%&*+\\/:;.,[:word:]]+[-a-z0-9_=#$@~%&*+\\/[:word:]]\\)"
- "\\b\\(\\(www\\.\\|\\(s?https?\\|ftp\\|file\\|gopher\\|nntp\\|news\\|telnet\\|wais\\|mailto\\|info\\):\\)\\(//[-a-z0-9_.]+:[0-9]*\\)?\\([-a-z0-9_=!?#$@~%&*+\\/:;.,]\\|\\w\\)+\\([-a-z0-9_=#$@~%&*+\\/]\\|\\w\\)\\)")
+ (concat
+ "\\b\\(\\(www\\.\\|\\(s?https?\\|ftp\\|file\\|gopher\\|"
+ "nntp\\|news\\|telnet\\|wais\\|mailto\\|info\\):\\)"
+ "\\(//[-a-z0-9_.]+:[0-9]*\\)?"
+ (if (string-match "[[:digit:]]" "1") ;; Support POSIX?
+ (let ((chars "-a-z0-9_=#$@~%&*+\\/[:word:]")
+ (punct "!?:;.,"))
+ (concat
+ "\\(?:"
+ ;; Match paired parentheses, e.g. in Wikipedia URLs:
+ "[" chars punct "]+" "(" "[" chars punct "]+" "[" chars "]*)" "[" chars "]"
+ "\\|"
+ "[" chars punct "]+" "[" chars "]"
+ "\\)"))
+ (concat ;; XEmacs 21.4 doesn't support POSIX.
+ "\\([-a-z0-9_=!?#$@~%&*+\\/:;.,]\\|\\w\\)+"
+ "\\([-a-z0-9_=#$@~%&*+\\/]\\|\\w\\)"))
+ "\\)")
"Regular expression that matches URLs."
:group 'gnus-article-buttons
:type 'regexp)
:group 'gnus-article-buttons
:type 'regexp)
+;; Regexp suggested by Felix Wiemann in <87oeuomcz9.fsf@news2.ososo.de>
+(defcustom gnus-button-valid-localpart-regexp
+ "[a-z0-9$%(*-=?[_][^<>\")!;:,{}\n\t @]*"
+ "Regular expression that matches a localpart of mail addresses or MIDs."
+ :version "22.1"
+ :group 'gnus-article-buttons
+ :type 'regexp)
+
(defcustom gnus-button-man-handler 'manual-entry
"Function to use for displaying man pages.
The function must take at least one argument with a string naming the
(regexp :tag "Other")))
(defcustom gnus-button-ctan-directory-regexp
- (concat
- "\\(?:"
- "biblio\\|digests\\|dviware\\|fonts\\|graphics\\|help\\|"
- "indexing\\|info\\|language\\|macros\\|support\\|systems\\|"
- "tds\\|tools\\|usergrps\\|web\\|nonfree\\|obsolete"
- "\\)")
+ (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"
:type 'regexp)
(defcustom gnus-button-mid-or-mail-regexp
- (concat "\\b\\(<?[a-z0-9$%(*-=?[_][^<>\")!;:,{}\n\t ]*@"
- ;; Felix Wiemann in <87oeuomcz9.fsf@news2.ososo.de>
+ (concat "\\b\\(<?" gnus-button-valid-localpart-regexp "@"
gnus-button-valid-fqdn-regexp
">?\\)\\b")
"Regular expression that matches a message ID or a mail address."
of the symbols `mid' or `mail', Gnus will always assume that the string is a
message ID or a mail address, respectively. If this variable is set to the
symbol `ask', always query the user what do do. If it is a function, this
-function will be called with the string as it's only argument. The function
+function will be called with the string as its only argument. The function
must return `mid', `mail', `invalid' or `ask'."
:version "22.1"
:group 'gnus-article-buttons
(-20.0 . "\\.fsf@") ;; Gnus
(-20.0 . "^slrn")
(-20.0 . "^Pine")
+ (-20.0 . "^alpine\\.")
(-20.0 . "_-_") ;; Subject change in thread
;;
(-20.0 . "\\.ln@") ;; leafnode
(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)
+ (if (string-match "^customize-apropos" fun)
+ arg
+ (intern arg))))
(defvar gnus-button-handle-describe-prefix "^\\(C-h\\|<?[Ff]1>?\\)")
(defcustom gnus-button-alist
'(("<\\(url:[>\n\t ]*?\\)?\\(nntp\\|news\\):[>\n\t ]*\\([^>\n\t ]*@[^>\n\t ]*\\)>"
0 (>= gnus-button-message-level 0) gnus-button-handle-news 3)
- ("\\b\\(nntp\\|news\\):\\([^>\n\t ]*@[^>)!;:,\n\t ]*\\)" 0 t
- gnus-button-handle-news 2)
+ ((concat "\\b\\(nntp\\|news\\):\\("
+ gnus-button-valid-localpart-regexp "@[a-z0-9.-]+[a-z]\\)")
+ 0 t gnus-button-handle-news 2)
("\\(\\b<\\(url:[>\n\t ]*\\)?\\(nntp\\|news\\):[>\n\t ]*\\(//\\)?\\([^>\n\t ]*\\)>\\)"
1 (>= gnus-button-message-level 0) gnus-button-fetch-group 5)
("\\b\\(nntp\\|news\\):\\(//\\)?\\([^'\">\n\t ]+\\)"
0 (>= gnus-button-message-level 0) gnus-button-message-id 2)
("\\bin\\( +article\\| +message\\)? +\\(<\\([^\n @<>]+@[^\n @<>]+\\)>\\)"
2 (>= gnus-button-message-level 0) gnus-button-message-id 3)
+ ("\\b\\(mid\\|message-id\\):? +\\(<\\([^\n @<>]+@[^\n @<>]+\\)>\\)"
+ 2 (>= gnus-button-message-level 0) gnus-button-message-id 3)
("\\(<URL: *\\)mailto: *\\([^> \n\t]+\\)>"
0 (>= gnus-button-message-level 0) gnus-url-mailto 2)
;; RFC 2368 (The mailto URL scheme)
;; 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 ` '.
1 (>= gnus-button-emacs-level 8) gnus-button-handle-library 1)
("`\\([a-z][-a-z0-9]+\\.el\\)'"
1 (>= gnus-button-emacs-level 8) gnus-button-handle-library 1)
- ("`\\([a-z][a-z0-9]+-[a-z]+-[-a-z]+\\|\\(gnus\\|message\\)-[-a-z]+\\)'"
+ ("`\\([a-z][a-z0-9]+-[a-z0-9]+-[-a-z0-9]*[a-z]\\|\\(gnus\\|message\\)-[-a-z]+\\)'"
0 (>= gnus-button-emacs-level 8) gnus-button-handle-symbol 1)
("`\\([a-z][a-z0-9]+-[a-z]+\\)'"
0 (>= gnus-button-emacs-level 9) gnus-button-handle-symbol 1)
0 (>= gnus-button-emacs-level 1) gnus-button-handle-describe-function 2)
("\\b\\(C-h\\|<?[Ff]1>?\\)[ \t\n]+v[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET"
0 (>= gnus-button-emacs-level 1) gnus-button-handle-describe-variable 2)
- ("`\\(\\b\\(C-h\\|<?[Ff]1>?\\)[ \t\n]+k[ \t\n]+\\([^']+\\)\\)'"
+ ("`\\(\\(C-h\\|<?[Ff]1>?\\)[ \t\n]+k[ \t\n]+\\([^']+\\)\\)'"
;; Unlike the other regexps we really have to require quoting
;; here to determine where it ends.
1 (>= gnus-button-emacs-level 1) gnus-button-handle-describe-key 3)
;; This is how URLs _should_ be embedded in text (RFC 1738, RFC 2396)...
- ("<URL: *\\([^<>]*\\)>"
- 1 (>= gnus-button-browse-level 0) gnus-button-embedded-url 1)
- ;; RFC 2396 (2.4.3., delims) ...
- ("\"URL: *\\([^\"]*\\)\""
+ ("<URL: *\\([^\n<>]*\\)>"
1 (>= gnus-button-browse-level 0) gnus-button-embedded-url 1)
;; RFC 2396 (2.4.3., delims) ...
- ("\"URL: *\\([^\"]*\\)\""
+ ("\"URL: *\\([^\n\"]*\\)\""
1 (>= gnus-button-browse-level 0) gnus-button-embedded-url 1)
;; Raw URLs.
(gnus-button-url-regexp
;; SoWWWAnchor(3iv), XSelectInput(3X11), X(1), X(7)
("\\b\\(\\(?:[a-z][-+_.:a-z0-9]+([1-9][X1a-z]*)\\)\\|\\b\\(?:X([1-9])\\)\\)\\W"
0 (>= gnus-button-man-level 5) gnus-button-handle-man 1)
+ ;; Recognizing patches to .el files. This is somewhat obscure,
+ ;; but considering the percentage of Gnus users who hack Emacs
+ ;; Lisp files...
+ ("^--- \\([^ .]+\\.el\\).*\n.*\n@@ -?\\([0-9]+\\)" 1
+ (>= gnus-button-message-level 4) gnus-button-patch 1 2)
+ ("^\\*\\*\\* \\([^ .]+\\.el\\).*\n.*\n\\*+\n\\*\\*\\* \\([0-9]+\\)" 1
+ (>= gnus-button-message-level 4) gnus-button-patch 1 2)
;; MID or mail: To avoid too many false positives we don't try to catch
;; all kind of allowed MIDs or mail addresses. Domain part must contain
;; at least one dot. TLD must contain two or three chars or be a know TLD
(repeat :tag "Par"
:inline t
(integer :tag "Regexp group")))))
+(put 'gnus-button-alist 'risky-local-variable t)
(defcustom gnus-header-button-alist
'(("^\\(References\\|Message-I[Dd]\\|^In-Reply-To\\):" "<[^<>]+>"
(repeat :tag "Par"
:inline t
(integer :tag "Regexp group")))))
+(put 'gnus-header-button-alist 'risky-local-variable t)
;;; Commands:
(defun gnus-article-highlight-signature ()
"Highlight the signature in an article.
It does this by highlighting everything after
-`gnus-signature-separator' using `gnus-signature-face'."
+`gnus-signature-separator' using the face `gnus-signature'."
(interactive)
(gnus-with-article-buffer
(let ((inhibit-point-motion-hooks t))
(save-restriction
(when (and gnus-signature-face
(gnus-article-narrow-to-signature))
- (gnus-overlay-put (gnus-make-overlay (point-min) (point-max))
+ (gnus-overlay-put (gnus-make-overlay (point-min) (point-max) nil t)
'face gnus-signature-face)
(widen)
(gnus-article-search-signature)
(setq regexp (eval (car entry)))
(goto-char beg)
(while (re-search-forward regexp nil t)
- (let* ((start (and entry (match-beginning (nth 1 entry))))
- (end (and entry (match-end (nth 1 entry))))
- (from (match-beginning 0)))
+ (let ((start (match-beginning (nth 1 entry)))
+ (end (match-end (nth 1 entry)))
+ (from (match-beginning 0)))
(when (and (or (eq t (nth 2 entry))
(eval (nth 2 entry)))
(not (gnus-button-in-region-p
start end 'gnus-callback)))
;; That optional form returned non-nil, so we add the
;; button.
- (gnus-article-add-button
- start end 'gnus-button-push
- (car (push (set-marker (make-marker) from)
- gnus-button-marker-list))))))))))
+ (setq from (set-marker (make-marker) from))
+ (push from gnus-button-marker-list)
+ (unless (and (eq (car entry) 'gnus-button-url-regexp)
+ (gnus-article-extend-url-button from start end))
+ (gnus-article-add-button start end
+ 'gnus-button-push from)))))))))
+
+(defun gnus-article-extend-url-button (beg start end)
+ "Extend url button if url is folded into two or more lines.
+Return non-nil if button is extended. BEG is a marker that points to
+the beginning position of a text containing url. START and END are
+the endpoints of a url button before it is extended. The concatenated
+url is put as the `gnus-button-url' overlay property on the button."
+ (let ((opoint (point))
+ (points (list start end))
+ url delim regexp)
+ (prog1
+ (when (and (progn
+ (goto-char end)
+ (not (looking-at "[\t ]*[\">]")))
+ (progn
+ (goto-char start)
+ (string-match
+ "\\(?:\"\\|\\(<\\)\\)[\t ]*\\(?:url[\t ]*:[\t ]*\\)?\\'"
+ (buffer-substring (point-at-bol) start)))
+ (progn
+ (setq url (list (buffer-substring start end))
+ delim (if (match-beginning 1) ">" "\""))
+ (beginning-of-line)
+ (setq regexp (concat
+ (when (and (looking-at
+ message-cite-prefix-regexp)
+ (< (match-end 0) start))
+ (regexp-quote (match-string 0)))
+ "\
+\[\t ]*\\(?:\\([^\t\n \">]+\\)[\t ]*$\\|\\([^\t\n \">]*\\)[\t ]*"
+ delim "\\)"))
+ (while (progn
+ (forward-line 1)
+ (and (looking-at regexp)
+ (prog1
+ (match-beginning 1)
+ (push (or (match-string 2)
+ (match-string 1))
+ url)
+ (push (setq end (or (match-end 2)
+ (match-end 1)))
+ points)
+ (push (or (match-beginning 2)
+ (match-beginning 1))
+ points)))))
+ (match-beginning 2)))
+ (let (gnus-article-mouse-face widget-mouse-face)
+ (while points
+ (gnus-article-add-button (pop points) (pop points)
+ 'gnus-button-push beg)))
+ (let ((overlay (gnus-make-overlay start end)))
+ (gnus-overlay-put overlay 'evaporate t)
+ (gnus-overlay-put overlay 'gnus-button-url
+ (list (mapconcat 'identity (nreverse url) "")))
+ (when gnus-article-mouse-face
+ (gnus-overlay-put overlay 'mouse-face gnus-article-mouse-face)))
+ t)
+ (goto-char opoint))))
;; Add buttons to the head of an article.
(defun gnus-article-add-buttons-to-head ()
(defun gnus-article-add-button (from to fun &optional data)
"Create a button between FROM and TO with callback FUN and data DATA."
(when gnus-article-button-face
- (gnus-overlay-put (gnus-make-overlay from to)
+ (gnus-overlay-put (gnus-make-overlay from to nil t)
'face gnus-article-button-face))
(gnus-add-text-properties
from to
(let* ((entry (gnus-button-entry))
(inhibit-point-motion-hooks t)
(fun (nth 3 entry))
- (args (mapcar (lambda (group)
- (let ((string (match-string group)))
- (set-text-properties
- 0 (length string) nil string)
- string))
- (nthcdr 4 entry))))
+ (args (or (and (eq (car entry) 'gnus-button-url-regexp)
+ (get-char-property marker 'gnus-button-url))
+ (mapcar (lambda (group)
+ (let ((string (match-string group)))
+ (set-text-properties
+ 0 (length string) nil string)
+ string))
+ (nthcdr 4 entry)))))
(cond
((fboundp fun)
(apply fun args))
(gnus-parse-news-url url)
(cond
(message-id
- (save-excursion
- (set-buffer gnus-summary-buffer)
+ (with-current-buffer gnus-summary-buffer
(if server
(let ((gnus-refer-article-method
(nconc (list (list 'nntp server))
(group
(gnus-button-fetch-group url)))))
+(defun gnus-button-patch (library line)
+ "Visit an Emacs Lisp library LIBRARY on line LINE."
+ (interactive)
+ (let ((file (locate-library (file-name-nondirectory library))))
+ (unless file
+ (error "Couldn't find library %s" library))
+ (find-file file)
+ (goto-line (string-to-number line))))
+
(defun gnus-button-handle-man (url)
"Fetch a man page."
(gnus-message 9 "`%s' `%s'" gnus-button-man-handler url)
"Fetch KDE style info URL."
(gnus-info-find-node (gnus-url-unhex-string url)))
+;; (info) will autoload info.el
+(declare-function Info-menu "info" (menu-item &optional fork))
+
(defun gnus-button-handle-info-keystrokes (url)
"Call `info' when pushing the corresponding URL button."
;; For links like `C-h i d m gnus RET', `C-h i d m CC Mode RET'.
(Info-directory)
(Info-menu url))
+;; Called after pgg-snarf-keys-region, which autoloads pgg.el.
+(declare-function pgg-display-output-buffer "pgg" (start end status))
+
(defun gnus-button-openpgp (url)
"Retrieve and add an OpenPGP key given URL from an OpenPGP header."
(with-temp-buffer
(with-current-buffer gnus-summary-buffer
(gnus-summary-refer-article message-id)))
-(defun gnus-button-fetch-group (address)
+(defun gnus-button-fetch-group (address &rest ignore)
"Fetch GROUP specified by ADDRESS."
+ (when (string-match "\\`\\(nntp\\|news\\):\\(//\\)?\\(.*\\)\\'"
+ address)
+ ;; Allow to use `gnus-button-fetch-group' in `browse-url-browser-function'
+ ;; for nntp:// and news://
+ (setq address (match-string 3 address)))
(if (not (string-match "[:/]" address))
;; This is just a simple group url.
(gnus-group-read-ephemeral-group address gnus-select-method)
(match-string 3 address)
"nntp")))
nil nil nil
- (and (match-end 6) (list (string-to-int (match-string 6 address))))))))
+ (and (match-end 6) (list (string-to-number (match-string 6 address))))))))
(defun gnus-url-parse-query-string (query &optional downcase)
(let (retval pairs cur key val)
map))
(defun gnus-insert-prev-page-button ()
- (let ((b (point))
+ (let ((b (point)) e
(inhibit-read-only t))
(gnus-eval-format
gnus-prev-page-line-format nil
`(keymap ,gnus-prev-page-map
- gnus-prev t
- gnus-callback gnus-article-button-prev-page
- article-type annotation))
+ gnus-prev t
+ gnus-callback gnus-article-button-prev-page
+ article-type annotation))
+ (setq e (if (bolp)
+ ;; Exclude a newline.
+ (1- (point))
+ (point)))
+ (when gnus-article-button-face
+ (gnus-overlay-put (gnus-make-overlay b e nil t)
+ 'face gnus-article-button-face))
(widget-convert-button
- 'link b (if (bolp)
- ;; Exclude a newline.
- (1- (point))
- (point))
+ 'link b e
:action 'gnus-button-prev-page
:button-keymap gnus-prev-page-map)))
(select-window win)))
(defun gnus-insert-next-page-button ()
- (let ((b (point))
+ (let ((b (point)) e
(inhibit-read-only t))
(gnus-eval-format gnus-next-page-line-format nil
`(keymap ,gnus-next-page-map
- gnus-next t
- gnus-callback gnus-article-button-next-page
- article-type annotation))
+ gnus-next t
+ gnus-callback gnus-article-button-next-page
+ article-type annotation))
+ (setq e (if (bolp)
+ ;; Exclude a newline.
+ (1- (point))
+ (point)))
+ (when gnus-article-button-face
+ (gnus-overlay-put (gnus-make-overlay b e nil t)
+ 'face gnus-article-button-face))
(widget-convert-button
- 'link b (if (bolp)
- ;; Exclude a newline.
- (1- (point))
- (point))
+ 'link b e
:action 'gnus-button-next-page
:button-keymap gnus-next-page-map)))
(eq gnus-newsgroup-name
(car gnus-decode-header-methods-cache)))
(setq gnus-decode-header-methods-cache (list gnus-newsgroup-name))
- (mapcar (lambda (x)
- (if (symbolp x)
- (nconc gnus-decode-header-methods-cache (list x))
- (if (and gnus-newsgroup-name
- (string-match (car x) gnus-newsgroup-name))
- (nconc gnus-decode-header-methods-cache
- (list (cdr x))))))
- gnus-decode-header-methods))
+ (dolist (x gnus-decode-header-methods)
+ (if (symbolp x)
+ (nconc gnus-decode-header-methods-cache (list x))
+ (if (and gnus-newsgroup-name
+ (string-match (car x) gnus-newsgroup-name))
+ (nconc gnus-decode-header-methods-cache
+ (list (cdr x)))))))
(let ((xlist gnus-decode-header-methods-cache))
(pop xlist)
(save-restriction
(funcall (cadr elem)))))))
;; Dynamic variables.
-(eval-when-compile
- (defvar part-number)
- (defvar total-parts)
- (defvar type)
- (defvar condition)
- (defvar length))
+(defvar part-number)
+(defvar total-parts)
+(defvar type)
+(defvar condition)
+(defvar length)
(defun gnus-treat-predicate (val)
(cond
t)
((eq val 'head)
nil)
+ ((eq val 'first)
+ (eq part-number 1))
((eq val 'last)
(eq part-number total-parts))
((numberp val)
gnus-article-encrypt-protocol-alist
nil t))
current-prefix-arg))
+ ;; User might hit `K E' instead of `K e', so prompt once.
+ (when (and gnus-article-encrypt-protocol
+ gnus-novice-user)
+ (unless (gnus-y-or-n-p "Really encrypt article(s)? ")
+ (error "Encrypt aborted.")))
(let ((func (cdr (assoc protocol gnus-article-encrypt-protocol-alist))))
(unless func
- (error (format "Can't find the encrypt protocol %s" protocol)))
+ (error "Can't find the encrypt protocol %s" protocol))
(if (member gnus-newsgroup-name '("nndraft:delayed"
"nndraft:drafts"
"nndraft:queue"))
(error "Can't encrypt the article in group %s"
gnus-newsgroup-name))
(gnus-summary-iterate n
- (save-excursion
- (set-buffer gnus-summary-buffer)
+ (with-current-buffer gnus-summary-buffer
(let ((mail-parse-charset gnus-newsgroup-charset)
(mail-parse-ignored-charsets gnus-newsgroup-ignored-charsets)
(summary-buffer gnus-summary-buffer)
(when gnus-keep-backlog
(gnus-backlog-remove-article
(car gnus-article-current) (cdr gnus-article-current)))
- (save-excursion
- (when (get-buffer gnus-original-article-buffer)
- (set-buffer gnus-original-article-buffer)
+ (when (get-buffer gnus-original-article-buffer)
+ (with-current-buffer gnus-original-article-buffer
(setq gnus-original-article nil)))
(when gnus-use-cache
(gnus-cache-update-article
(?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) :active 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)
point (inhibit-read-only t))
(if region
(goto-char (car region)))
- (save-restriction
- (narrow-to-region (point) (point))
- (with-current-buffer (mm-handle-multipart-original-buffer handle)
- (let* ((mm-verify-option 'known)
- (mm-decrypt-option 'known)
- (nparts (mm-possibly-verify-or-decrypt (cdr handle) handle)))
- (unless (eq nparts (cdr handle))
- (mm-destroy-parts (cdr handle))
- (setcdr handle nparts))))
- (setq point (point))
- (gnus-mime-display-security handle)
- (goto-char (point-max)))
+ (setq point (point))
+ (with-current-buffer (mm-handle-multipart-original-buffer handle)
+ (let* ((mm-verify-option 'known)
+ (mm-decrypt-option 'known)
+ (nparts (mm-possibly-verify-or-decrypt (cdr handle) handle)))
+ (unless (eq nparts (cdr handle))
+ (mm-destroy-parts (cdr handle))
+ (setcdr handle nparts))))
+ (gnus-mime-display-security handle)
(when region
(delete-region (point) (cdr region))
(set-marker (car region) nil)
;; Exclude a newline.
(1- (point))
(point)))
+ (when gnus-article-button-face
+ (gnus-overlay-put (gnus-make-overlay b e nil t)
+ 'face gnus-article-button-face))
(widget-convert-button
'link b e
:mime-handle handle
(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
(narrow-to-region (point) (point))
(unless (gnus-unbuttonized-mime-type-p (car handle))
(gnus-insert-mime-security-button handle))
- (gnus-mime-display-mixed (cdr handle))
+ (gnus-mime-display-part (cadr handle))
(unless (bolp)
(insert "\n"))
(unless (gnus-unbuttonized-mime-type-p (car handle))
(mm-set-handle-multipart-parameter
handle 'gnus-region
(cons (set-marker (make-marker) (point-min))
- (set-marker (make-marker) (point-max))))))
+ (set-marker (make-marker) (point-max))))
+ (goto-char (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)
(run-hooks 'gnus-art-load-hook)
-;;; arch-tag: 2654516f-6279-48f9-a83b-05c1fa450c33
+;; arch-tag: 2654516f-6279-48f9-a83b-05c1fa450c33
;;; gnus-art.el ends here
projects / gnus / blobdiff