X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fgnus-art.el;h=15041e40af919cf177047ed0d7d0275c2dd3c3e1;hb=5835aa3205a79608e81c5534e73826f3d6823c03;hp=8ee36a635822c9ca22e398d619e53d723182f663;hpb=a9931745d24a5570ab451966a5991bb1f92dde49;p=elisp%2Fgnus.git- diff --git a/lisp/gnus-art.el b/lisp/gnus-art.el index 8ee36a6..15041e4 100644 --- a/lisp/gnus-art.el +++ b/lisp/gnus-art.el @@ -1,6 +1,7 @@ ;;; gnus-art.el --- article mode commands for Semi-gnus -;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004 -;; Free Software Foundation, Inc. + +;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, +;; 2005 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; MORIOKA Tomohiko @@ -21,8 +22,8 @@ ;; 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: @@ -31,11 +32,15 @@ (eval-when-compile (require 'cl) (require 'static) - (defvar tool-bar-map)) + (defvar tool-bar-map) + (defvar w3m-minor-mode-map)) (require 'path-util) (require 'gnus) -(require 'gnus-sum) +;; Avoid the "Recursive load suspected" error in Emacs 21.1. +(eval-and-compile + (let ((recursive-load-depth-limit 100)) + (require 'gnus-sum))) (require 'gnus-spec) (require 'gnus-int) (require 'gnus-win) @@ -60,6 +65,7 @@ (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") (defgroup gnus-article nil @@ -228,7 +234,7 @@ By default, if you set this t, then Gnus will display citations and signatures, but will never scroll down to show you a page consisting only of boring text. Boring text is controlled by `gnus-article-boring-faces'." - :version "21.4" + :version "22.1" :type 'boolean :group 'gnus-article-hiding) @@ -237,7 +243,9 @@ only of boring text. Boring text is controlled by 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 @@ -250,7 +258,8 @@ no signature in the buffer. If it is a string, it will be used as a 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) (regexp :value ".*")) @@ -274,9 +283,6 @@ This can also be a list of the above values." "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | ee -")) ((gnus-image-type-available-p 'pbm) 'gnus-display-x-face-in-from) - ((and window-system - (module-installed-p 'x-face-mule)) - 'x-face-mule-gnus-article-display-x-face) (t "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | \ display -")) @@ -284,19 +290,14 @@ display -")) If it is a string, the command will be executed in a sub-shell asynchronously. The compressed face will be piped to this command." :type `(choice - ,@(let ((x-face-mule (if (featurep 'xemacs) - nil - (module-installed-p 'x-face-mule)))) - (delq nil - (list - 'string - (if (or (gnus-image-type-available-p 'xface) - (gnus-image-type-available-p 'pbm)) - '(function-item gnus-display-x-face-in-from)) - (if x-face-mule - '(function-item - x-face-mule-gnus-article-display-x-face)) - 'function)))) + :format "%{%t%}:\n%[Value Menu%] %v" + ,@(delq nil + (list + 'string + (if (or (gnus-image-type-available-p 'xface) + (gnus-image-type-available-p 'pbm)) + '(function-item gnus-display-x-face-in-from)) + 'function))) :version "21.1" :group 'gnus-picon :group 'gnus-article-washing) @@ -353,7 +354,7 @@ advertisements. For example: (symbol :tag "Item in `gnus-article-banner-alist'" none) regexp (const :tag "None" nil)))) - :version "21.4" + :version "22.1" :group 'gnus-article-washing) (defmacro gnus-emphasis-custom-with-format (&rest body) @@ -401,7 +402,13 @@ advertisements. For example: (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: @@ -432,15 +439,15 @@ is the face used for highlighting." :value (gnus-emphasis-custom-value-to-external value)))) (widget-group-value-create widget)) - (regexp :format "%t: %v\n" :size 1) - (integer :format "Match group: %v\n" :size 0) - (integer :format "Emphasize group: %v\n" :size 0) + regexp + (integer :format "Match group: %v") + (integer :format "Emphasize group: %v") face) (group :tag "Simple" :value (("_" . "_") nil default) (cons :format "%v" - (regexp :format "Start regexp: %v\n" :size 0) - (regexp :format "End regexp: %v\n" :size 0)) + (regexp :format "Start regexp: %v") + (regexp :format "End regexp: %v")) (boolean :format "Show start and end patterns: %[%v%]\n" :on " On " :off " Off ") face))) @@ -513,9 +520,6 @@ be fed to `format-time-string'." :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." :group 'gnus-article-saving @@ -601,17 +605,19 @@ you could set this variable to something like: '((\"^Subject:.*gnus\\|^Newsgroups:.*gnus\" \"gnus-stuff\") (\"^Subject:.*vm\\|^Xref:.*vm\" \"vm-stuff\")) -This variable is an alist where the where the key is the match and the -value is a list of possible files to save in if the match is non-nil. +This variable is an alist where the key is the match and the +value is a list of possible files to save in if the match is +non-nil. 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)) @@ -674,7 +680,7 @@ The following additional specs are available: (defcustom gnus-copy-article-ignored-headers nil "List of headers to be removed when copying an article. Each element is a regular expression." - :version "22.0" ;; No Gnus + :version "23.0" ;; No Gnus :type '(repeat regexp) :group 'gnus-article-various) @@ -697,21 +703,23 @@ above them." :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")) @@ -723,8 +731,10 @@ Obsolete; use the face `gnus-signature-face' for customizations instead." "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")) @@ -736,8 +746,10 @@ Obsolete; use the face `gnus-signature-face' for customizations instead." "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)) @@ -751,8 +763,10 @@ In the default setup this face is only used for crossposted 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")) @@ -764,8 +778,10 @@ articles." "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)) @@ -777,12 +793,14 @@ articles." "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). @@ -858,9 +876,11 @@ This variable is only used when `gnus-inhibit-mime-unbuttonizing' is nil." "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 "21.4" + :version "22.1" :group 'gnus-article-mime :type '(repeat regexp)) @@ -869,7 +889,7 @@ This variable is only used when `gnus-inhibit-mime-unbuttonizing' is nil." When nil (the default value), then some MIME parts do not get buttons, as described by the variables `gnus-buttonized-mime-types' and `gnus-unbuttonized-mime-types'." - :version "21.4" + :version "22.1" :group 'gnus-article-mime :type 'boolean) @@ -877,7 +897,7 @@ as described by the variables `gnus-buttonized-mime-types' and "String used to delimit header and body. This variable is used by `gnus-article-treat-body-boundary' which can be controlled by `gnus-treat-body-boundary'." - :version "21.4" + :version "22.1" :group 'gnus-article-various :type '(choice (item :tag "None" :value nil) string)) @@ -887,7 +907,7 @@ be controlled by `gnus-treat-body-boundary'." "Defines the location of the faces database. For information on obtaining this database of pretty pictures, please see http://www.cs.indiana.edu/picons/ftp/index.html" - :version "21.4" + :version "22.1" :type '(repeat directory) :link '(url-link :tag "download" "http://www.cs.indiana.edu/picons/ftp/index.html") @@ -907,7 +927,8 @@ see http://www.cs.indiana.edu/picons/ftp/index.html" 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." @@ -944,6 +965,7 @@ used." (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) @@ -958,6 +980,19 @@ used." :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.0" ;; 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 ;;; @@ -969,6 +1004,7 @@ used." '(choice (const :tag "Off" nil) (const :tag "On" t) (const :tag "Header" head) + (const :tag "First" first) (const :tag "Last" last) (const :tag "Mime" mime) (integer :tag "Less") @@ -987,8 +1023,8 @@ used." (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) @@ -996,8 +1032,8 @@ See Info node `(gnus)Customizing Articles'." (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) @@ -1005,8 +1041,8 @@ See Info node `(gnus)Customizing Articles'." (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) @@ -1017,8 +1053,8 @@ See Info node `(gnus)Customizing Articles' for details." (featurep 'xemacs)) 50000) "Emphasize text. -Valid values are nil, t, `head', `last', an integer or a predicate. -See Info node `(gnus)Customizing Articles' for details." +Valid values are nil, t, `head', `first', `last', an integer or a +predicate. See Info node `(gnus)Customizing Articles'." :group 'gnus-article-treat :link '(custom-manual "(gnus)Customizing Articles") :type gnus-article-treat-custom) @@ -1026,83 +1062,83 @@ See Info node `(gnus)Customizing Articles' for details." (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." - :version "21.4" +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-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." - :version "21.4" +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-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." - :version "21.4" +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-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") @@ -1113,8 +1149,8 @@ See Info node `(gnus)Customizing Articles' for details." (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) @@ -1122,16 +1158,16 @@ See Info node `(gnus)Customizing Articles' for details." (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) @@ -1139,8 +1175,8 @@ See Info node `(gnus)Customizing Articles' for details." (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) @@ -1148,49 +1184,49 @@ See Info node `(gnus)Customizing Articles' for details." (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." - :version "21.4" +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-head-custom) (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") @@ -1199,16 +1235,16 @@ See Info node `(gnus)Customizing Articles' for details." (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") @@ -1216,59 +1252,64 @@ See Info node `(gnus)Customizing Articles' for details." (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." - :version "21.4" +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-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." - :version "21.4" +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-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." - :version "21.4" +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-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) @@ -1276,8 +1317,8 @@ See Info node `(gnus)Customizing Articles' for details." (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) @@ -1287,9 +1328,7 @@ See Info node `(gnus)Customizing Articles' for details." (defcustom gnus-treat-display-x-face (and (not noninteractive) - (or (eq gnus-article-x-face-command - 'x-face-mule-gnus-article-display-x-face) - (and (fboundp 'image-type-available-p) + (or (and (fboundp 'image-type-available-p) (image-type-available-p 'xbm) (string-match "^0x" (shell-command-to-string "uncompface")) (executable-find "icontopbm")) @@ -1297,9 +1336,9 @@ See Info node `(gnus)Customizing Articles' for details." (featurep 'xface))) 'head) "Display X-Face headers. -Valid values are nil, t, `head', `last', an integer or a predicate. -See Info node `(gnus)Customizing Articles' and Info node -`(gnus)X-Face' for details." +Valid values are nil, t, `head', `first', `last', an integer or a +predicate. See Info node `(gnus)Customizing Articles' and Info +node `(gnus)X-Face' for details." :group 'gnus-article-treat :version "21.1" :link '(custom-manual "(gnus)Customizing Articles") @@ -1358,11 +1397,11 @@ smiley functions are not overridden by `smiley').") (featurep 'png))) 'head) "Display Face headers. -Valid values are nil, t, `head', `last', an integer or a predicate. -See Info node `(gnus)Customizing Articles' and Info node -`(gnus)X-Face' for details." +Valid values are nil, t, `head', `first', `last', an integer or a +predicate. See Info node `(gnus)Customizing Articles' and Info +node `(gnus)X-Face' for details." :group 'gnus-article-treat - :version "21.4" + :version "22.1" :link '(custom-manual "(gnus)Customizing Articles") :link '(custom-manual "(gnus)X-Face") :type gnus-article-treat-head-custom) @@ -1380,9 +1419,9 @@ See Info node `(gnus)Customizing Articles' and Info node t nil) "Display smileys. -Valid values are nil, t, `head', `last', an integer or a predicate. -See Info node `(gnus)Customizing Articles' and Info node -`(gnus)Smileys' for details." +Valid values are nil, t, `head', `first', `last', an integer or a +predicate. See Info node `(gnus)Customizing Articles' and Info +node `(gnus)Smileys' for details." :group 'gnus-article-treat :version "21.1" :link '(custom-manual "(gnus)Customizing Articles") @@ -1395,10 +1434,10 @@ See Info node `(gnus)Customizing Articles' and Info node (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." - :version "21.4" +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 :link '(custom-manual "(gnus)Customizing Articles") @@ -1411,10 +1450,10 @@ See Info node `(gnus)Customizing Articles' and Info node (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." - :version "21.4" +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 :link '(custom-manual "(gnus)Customizing Articles") @@ -1427,10 +1466,10 @@ See Info node `(gnus)Customizing Articles' and Info node (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." - :version "21.4" +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 :link '(custom-manual "(gnus)Customizing Articles") @@ -1447,15 +1486,15 @@ See Info node `(gnus)Customizing Articles' and Info node "Draw a boundary at the end of the headers. Valid values are nil and `head'. See Info node `(gnus)Customizing Articles' for details." - :version "21.4" + :version "22.1" :group 'gnus-article-treat :link '(custom-manual "(gnus)Customizing Articles") :type gnus-article-treat-head-custom) (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") @@ -1463,25 +1502,25 @@ See Info node `(gnus)Customizing Articles' for details." (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." - :version "21.4" +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-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") @@ -1499,8 +1538,8 @@ decode the body, '(or header t) for the whole article, etc." (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") @@ -1509,9 +1548,9 @@ See Info node `(gnus)Customizing Articles' for details." (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." - :version "21.4" +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 :type gnus-article-treat-custom) @@ -1533,7 +1572,7 @@ See Info node `(gnus)Customizing Articles' for details." (defcustom gnus-article-encrypt-protocol "PGP" "The protocol used for encrypt articles. It is a string, such as \"PGP\". If nil, ask user." - :version "21.4" + :version "22.1" :type 'string :group 'mime-security) @@ -1545,13 +1584,13 @@ It is a string, such as \"PGP\". If nil, ask user." (executable-find idna-program)) "Whether IDNA decoding of headers is used when viewing messages. This requires GNU Libidn, and by default only enabled if it is found." - :version "21.4" + :version "22.1" :group 'gnus-article-headers :type 'boolean) (defcustom gnus-article-over-scroll nil "If non-nil, allow scrolling the article buffer even when there no more text." - :version "21.4" + :version "22.1" :group 'gnus-article :type 'boolean) @@ -1589,10 +1628,10 @@ This requires GNU Libidn, and by default only enabled if it is found." (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-face gnus-article-display-face) (gnus-treat-hide-headers gnus-article-maybe-hide-headers) (gnus-treat-hide-boring-headers gnus-article-hide-boring-headers) @@ -1730,10 +1769,24 @@ Initialized from `text-mode-syntax-table.") "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." @@ -2272,33 +2325,33 @@ unfolded." ;; read-only. (if (and wash-face-p (memq 'face gnus-article-wash-types)) (gnus-delete-images 'face) - (let (face faces) - (save-excursion + (let (face faces from) + (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)))))) - ))) + (push (mail-header-field-value) faces)))) + (when faces + (goto-char (point-min)) + (let ((from (gnus-article-goto-header "from")) + png image) + (unless 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." @@ -2315,13 +2368,10 @@ unfolded." (gnus-delete-images 'xface) ;; Display X-Faces. (let (x-faces from face) - (save-excursion + (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. @@ -2335,34 +2385,36 @@ unfolded." ;; 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))))) - ;; We display the face. - (cond ((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 - (start-process - "article-x-face" nil shell-file-name - shell-command-switch gnus-article-x-face-command)) - (with-temp-buffer - (insert face) - (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))))))))) + (when (and x-faces + gnus-article-x-face-command + (or force + ;; Check whether this face is censored. + (not gnus-article-x-face-too-ugly) + (and from + (not (string-match gnus-article-x-face-too-ugly + from))))) + (while (setq face (pop x-faces)) + ;; We display the face. + (cond ((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)) + (gnus-set-process-query-on-exit-flag + (start-process + "article-x-face" nil shell-file-name + shell-command-switch gnus-article-x-face-command) + nil) + (with-temp-buffer + (insert face) + (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)))))))))) (defun article-decode-mime-words () "Decode all MIME-encoded words in the article." @@ -2472,20 +2524,22 @@ If PROMPT (the prefix), prompt for a coding system to use." (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))))))))) @@ -2572,7 +2626,7 @@ If READ-CHARSET, ask for a coding system." (let ((inhibit-read-only t)) (goto-char (point-min)) (while (re-search-forward - "^\\(\\(https?\\|ftp\\)://\\S-+\\) *\n\\(\\S-+\\)" nil t) + "\\(\\(https?\\|ftp\\)://\\S-+\\) *\n\\(\\S-+\\)" nil t) (replace-match "\\1\\3" t))) (when (interactive-p) (gnus-treat-article nil)))) @@ -2580,25 +2634,36 @@ If READ-CHARSET, ask for a coding system." (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 + (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))))))) + (unless charset + (setq charset gnus-newsgroup-charset))) (article-goto-body) (save-window-excursion (save-restriction @@ -2627,19 +2692,31 @@ If READ-CHARSET, ask for a coding system." (defun gnus-article-wash-html-with-w3m () "Wash the current buffer with emacs-w3m." (mm-setup-w3m) - (save-restriction - (narrow-to-region (point) (point-max)) - (let ((w3m-safe-url-regexp mm-w3m-safe-url-regexp) - w3m-force-redisplay) - (w3m-region (point-min) (point-max))) - (when (and mm-inline-text-html-with-w3m-keymap - (boundp 'w3m-minor-mode-map) - w3m-minor-mode-map) - (add-text-properties - (point-min) (point-max) - (list 'keymap w3m-minor-mode-map - ;; Put the mark meaning this part was rendered by emacs-w3m. - 'mm-inline-text-html-with-w3m t))))) + (let ((w3m-safe-url-regexp mm-w3m-safe-url-regexp) + w3m-force-redisplay) + (w3m-region (point-min) (point-max))) + (when (and mm-inline-text-html-with-w3m-keymap + (boundp 'w3m-minor-mode-map) + w3m-minor-mode-map) + (add-text-properties + (point-min) (point-max) + (list 'keymap w3m-minor-mode-map + ;; Put the mark meaning this part was rendered by emacs-w3m. + 'mm-inline-text-html-with-w3m t)))) + +(eval-when-compile (defvar charset)) ;; Bound by `article-wash-html'. + +(defun gnus-article-wash-html-with-w3m-standalone () + "Wash the current buffer with w3m." + (unless (mm-coding-system-p charset) + ;; 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)))) (defun article-hide-list-identifiers () "Remove list identifies from the Subject header. @@ -3001,81 +3078,74 @@ lines forward." (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 - (and (eq 1 (point-min)) - (mail-header-date (save-excursion - (set-buffer gnus-summary-buffer) - gnus-current-headers))) - (message-fetch-field "date") - "")) - (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) - bface eface date-pos) - (when (and date (not (string= date ""))) - (save-excursion - (save-restriction - (article-narrow-to-head) - (when (or (and (eq type 'lapsed) - gnus-article-date-lapsed-new-header - ;; Attempt to get the face of X-Sent first. - (re-search-forward "^X-Sent:[ \t]" nil t)) - (re-search-forward "^Date:[ \t]" nil t) - ;; If Date is missing, try again for X-Sent. - (re-search-forward "^X-Sent:[ \t]" nil t)) + pos date bface eface) + (save-excursion + (save-restriction + (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)) + (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))) - (let ((inhibit-read-only t)) - ;; Delete any old X-Sent headers. - (when (setq date-pos - (text-property-any (point-min) (point-max) - 'article-date-lapsed t)) - (goto-char (setq date-pos (set-marker (make-marker) date-pos))) - (delete-region (match-beginning 0) - (progn (forward-line 1) (point)))) - (goto-char (point-min)) - ;; Delete any old Date headers. - (while (re-search-forward "^Date:[ \t]" nil t) - (unless date-pos - (setq date-pos (match-beginning 0))) - (unless (and (eq type 'lapsed) - gnus-article-date-lapsed-new-header) - (delete-region (match-beginning 0) - (progn (message-next-header) (point))))) - (if date-pos - (progn - (goto-char date-pos) - (unless (bolp) - ;; Possibly, Date has been deleted. - (insert "\n")) - (when (and (eq type 'lapsed) - gnus-article-date-lapsed-new-header - (looking-at "Date:")) - (forward-line 1))) - (goto-char (point-min))) - (insert (article-make-date-line date type)) - (when (eq type 'lapsed) - (put-text-property (point-at-bol) (point) - 'article-date-lapsed t)) + 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. - (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)))))))) + (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." @@ -3216,20 +3286,24 @@ function and want to see what the date was before converting." (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 (or (and (eq major-mode 'mime-view-mode) + (eq (mime-preview-original-major-mode) + 'gnus-original-article-mode)) + (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. @@ -3260,6 +3334,27 @@ This format is defined by the `gnus-article-time-format' variable." (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) @@ -3409,7 +3504,7 @@ This format is defined by the `gnus-article-time-format' variable." ((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. @@ -3419,7 +3514,7 @@ This format is defined by the `gnus-article-time-format' variable." (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 @@ -3432,7 +3527,7 @@ This format is defined by the `gnus-article-time-format' variable." ((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 @@ -3443,7 +3538,7 @@ This format is defined by the `gnus-article-time-format' variable." (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))) @@ -3477,7 +3572,7 @@ This format is defined by the `gnus-article-time-format' variable." 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 @@ -3492,7 +3587,7 @@ Directory to save to is default to `gnus-article-save-directory'." Optional argument FILENAME specifies file name. Directory to save to is default to `gnus-article-save-directory'." (setq filename (gnus-read-save-file-name - "Save %s in 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 @@ -3511,7 +3606,7 @@ Directory to save to is default to `gnus-article-save-directory'." Optional argument FILENAME specifies file name. Directory to save to is default to `gnus-article-save-directory'." (setq filename (gnus-read-save-file-name - "Save %s in 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 @@ -3535,7 +3630,7 @@ The directory to save in defaults to `gnus-article-save-directory'." 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 @@ -3909,6 +4004,7 @@ commands: \\[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) @@ -3932,12 +4028,14 @@ commands: (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 'nobreak-char-display) nil) (gnus-set-default-directory) (buffer-disable-undo) (setq buffer-read-only t show-trailing-whitespace nil) (set-syntax-table gnus-article-mode-syntax-table) - (gnus-run-hooks 'gnus-article-mode-hook)) + (gnus-run-mode-hooks 'gnus-article-mode-hook)) (defun gnus-article-setup-buffer () "Initialize the article buffer." @@ -3964,14 +4062,19 @@ commands: (set-buffer-multibyte t) (setq major-mode 'gnus-original-article-mode) (make-local-variable 'gnus-original-article)) - (if (get-buffer name) + (if (and (get-buffer name) + (with-current-buffer name + (if gnus-article-edit-mode + (if (y-or-n-p "Article mode edit in progress; discard? ") + (progn + (set-buffer-modified-p nil) + (gnus-kill-buffer name) + (message "") + nil) + (error "Action aborted")) + t))) (save-excursion (set-buffer name) - (when (and gnus-article-edit-mode - (buffer-modified-p) - (not - (y-or-n-p "Article mode edit in progress; discard? "))) - (error "Action aborted")) (set (make-local-variable 'gnus-article-edit-mode) nil) (buffer-disable-undo) (setq buffer-read-only t) @@ -4191,7 +4294,7 @@ If ALL-HEADERS is non-nil, no headers are hidden." (if (search-forward "\n\n" nil t) (point) (point-max))) - (gnus-treat-article 'head) + (gnus-article-save-original-date (gnus-treat-article 'head)) (put-text-property (point-min) (point-max) 'article-treated-header t) (goto-char (point-max))) (while (and (not (eobp)) entity) @@ -4286,7 +4389,7 @@ If ALL-HEADERS is non-nil, no headers are hidden." (if (search-forward "\n\n" nil t) (point) (point-max))) - (gnus-treat-article 'head) + (gnus-article-save-original-date (gnus-treat-article 'head)) (put-text-property (point-min) (point-max) 'article-treated-header t) (goto-char (point-max)) (widen) @@ -4342,10 +4445,11 @@ General format specifiers can also be used. See Info node (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...") @@ -4405,13 +4509,43 @@ General format specifiers can also be used. See Info node (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)) @@ -4420,7 +4554,7 @@ and `gnus-mime-delete-part', and not provided at run-time normally." ',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)) @@ -4444,13 +4578,29 @@ and `gnus-mime-delete-part', and not provided at run-time normally." (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 + (+ current-id gnus-auto-select-part))))) + +(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) @@ -4458,29 +4608,33 @@ and `gnus-mime-delete-part', and not provided at run-time normally." (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)) + (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', ` ') but with stripping would be nice. (defun gnus-mime-delete-part () "Delete the MIME part under point. @@ -4492,9 +4646,11 @@ Replace it with some information about the removed part." (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 @@ -4525,8 +4681,8 @@ Deleting parts may malfunction or destroy the article; continue? ") 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." @@ -4557,9 +4713,12 @@ Deleting parts may malfunction or destroy the article; continue? ") (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)))) @@ -4567,11 +4726,14 @@ Deleting parts may malfunction or destroy the article; continue? ") "Choose a MIME media type, and view the part as such." (interactive) (unless mime-type - (setq mime-type (completing-read - "View as MIME type: " - (mapcar #'list (mailcap-mime-types)) - nil nil - (gnus-mime-view-part-as-type-internal)))) + (setq mime-type + (let ((default (gnus-mime-view-part-as-type-internal))) + (completing-read + (format "View as MIME type (default %s): " + (car default)) + (mapcar #'list (mailcap-mime-types)) + nil nil nil nil + (car default))))) (gnus-article-check-buffer) (let ((handle (get-text-property (point) 'gnus-data))) (when handle @@ -4588,60 +4750,63 @@ Deleting parts may malfunction or destroy the article; continue? ") (mm-merge-handles gnus-article-mime-handles handle)) (gnus-mm-display-part handle)))) -(eval-when-compile - (require 'jka-compr)) - -;; jka-compr.el uses a "sh -c" to direct stderr to err-file, but these days -;; emacs can do that itself. -;; -(defun gnus-mime-jka-compr-maybe-uncompress () - "Uncompress the current buffer if `auto-compression-mode' is enabled. -The uncompress method used is derived from `buffer-file-name'." - (when (and (fboundp 'jka-compr-installed-p) - (jka-compr-installed-p)) - (let ((info (jka-compr-get-compression-info buffer-file-name))) - (when info - (let ((basename (file-name-nondirectory buffer-file-name)) - (args (jka-compr-info-uncompress-args info)) - (prog (jka-compr-info-uncompress-program info)) - (message (jka-compr-info-uncompress-message info)) - (err-file (jka-compr-make-temp-name))) - (if message - (message "%s %s..." message basename)) - (unwind-protect - (unless (memq (apply 'call-process-region - (point-min) (point-max) - prog - t (list t err-file) nil - args) - jka-compr-acceptable-retval-list) - (jka-compr-error prog args basename message err-file)) - (jka-compr-delete-temp-file err-file))))))) - -(defun gnus-mime-copy-part (&optional handle) +(defun gnus-mime-copy-part (&optional handle arg) "Put the MIME part under point into a new buffer. If `auto-compression-mode' is enabled, compressed files like .gz and .bz2 are decompressed." - (interactive) + (interactive (list nil current-prefix-arg)) (gnus-article-check-buffer) - (let* ((handle (or handle (get-text-property (point) 'gnus-data))) - (contents (and handle (mm-get-part handle))) - (base (and handle - (file-name-nondirectory - (or - (mail-content-type-get (mm-handle-type handle) 'name) - (mail-content-type-get (mm-handle-disposition handle) - 'filename) - "*decoded*")))) - (buffer (and base (generate-new-buffer base)))) - (when contents - (switch-to-buffer buffer) - (insert contents) + (unless handle + (setq handle (get-text-property (point) 'gnus-data))) + (when handle + (let ((filename (or (mail-content-type-get (mm-handle-disposition handle) + 'name) + (mail-content-type-get (mm-handle-disposition handle) + 'filename))) + contents dont-decode charset coding-system) + (mm-with-unibyte-buffer + (mm-insert-part handle) + (setq contents (or (condition-case nil + (mm-decompress-buffer filename nil 'sig) + (error + (setq dont-decode t) + nil)) + (buffer-string)))) + (setq filename (cond (filename (file-name-nondirectory filename)) + (dont-decode "*raw data*") + (t "*decoded*"))) + (cond + (dont-decode) + ((not arg) + (unless (setq charset (mail-content-type-get + (mm-handle-type handle) 'charset)) + (unless (setq coding-system (mm-with-unibyte-buffer + (insert contents) + (mm-find-buffer-file-coding-system))) + (setq charset gnus-newsgroup-charset)))) + ((numberp arg) + (setq charset (or (cdr (assq arg + gnus-summary-show-article-charset-alist)) + (mm-read-coding-system "Charset: "))))) + (switch-to-buffer (generate-new-buffer filename)) + (if (or coding-system + (and charset + (setq coding-system (mm-charset-to-coding-system charset)) + (not (eq charset 'ascii)))) + (progn + (mm-enable-multibyte) + (insert (mm-decode-coding-string contents coding-system)) + (setq buffer-file-coding-system + (if (boundp 'last-coding-system-used) + (symbol-value 'last-coding-system-used) + coding-system))) + (mm-disable-multibyte) + (insert contents) + (setq buffer-file-coding-system mm-binary-coding-system)) ;; We do it this way to make `normal-mode' set the appropriate mode. (unwind-protect (progn - (setq buffer-file-name (expand-file-name base)) - (gnus-mime-jka-compr-maybe-uncompress) + (setq buffer-file-name (expand-file-name filename)) (normal-mode)) (setq buffer-file-name nil)) (goto-char (point-min))))) @@ -4672,37 +4837,57 @@ are decompressed." (ps-despool filename))))) (defun gnus-mime-inline-part (&optional handle arg) - "Insert the MIME part under point into the current buffer." + "Insert the MIME part under point into the current buffer. +Compressed files like .gz and .bz2 are decompressed." (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)) - (when handle + (unless handle + (setq handle (get-text-property (point) 'gnus-data))) + (when handle + (let ((b (point)) + (inhibit-read-only t) + contents charset coding-system) (if (and (not arg) (mm-handle-undisplayer handle)) (mm-remove-part handle) - (setq contents (mm-get-part handle)) + (mm-with-unibyte-buffer + (mm-insert-part handle) + (setq contents + (or (mm-decompress-buffer + (or (mail-content-type-get (mm-handle-disposition handle) + 'name) + (mail-content-type-get (mm-handle-disposition handle) + 'filename)) + nil t) + (buffer-string)))) (cond ((not arg) - (setq charset (or (mail-content-type-get - (mm-handle-type handle) 'charset) - gnus-newsgroup-charset))) + (unless (setq charset (mail-content-type-get + (mm-handle-type handle) 'charset)) + (unless (setq coding-system + (mm-with-unibyte-buffer + (insert contents) + (mm-find-buffer-file-coding-system))) + (setq charset gnus-newsgroup-charset)))) ((numberp arg) (if (mm-handle-undisplayer handle) (mm-remove-part handle)) (setq charset (or (cdr (assq arg gnus-summary-show-article-charset-alist)) - (mm-read-coding-system "Charset: "))))) + (mm-read-coding-system "Charset: ")))) + (t + (if (mm-handle-undisplayer handle) + (mm-remove-part handle)))) (forward-line 2) - (mm-insert-inline handle - (if (and charset - (setq charset (mm-charset-to-coding-system - charset)) - (not (eq charset 'ascii))) - (mm-decode-coding-string contents charset) - contents)) + (mm-insert-inline + handle + (if (or coding-system + (and charset + (setq coding-system + (mm-charset-to-coding-system charset)) + (not (eq coding-system 'ascii)))) + (mm-decode-coding-string contents coding-system) + (mm-string-to-multibyte contents))) (goto-char b))))) (defun gnus-mime-view-part-as-charset (&optional handle arg) @@ -4767,13 +4952,68 @@ If no internal viewer is available, use an external viewer." (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")) + ;; 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." @@ -4811,6 +5051,24 @@ N is the numerical prefix." (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-mime-match-handle-first (condition) (if condition (let (n) @@ -4983,7 +5241,7 @@ N is the numerical prefix." (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 @@ -5022,7 +5280,8 @@ N is the numerical prefix." (save-restriction (article-goto-body) (narrow-to-region (point-min) (point)) - (gnus-treat-article 'head)))))))) + (gnus-article-save-original-date + (gnus-treat-article 'head))))))))) (defcustom gnus-mime-display-multipart-as-mixed nil "Display \"multipart\" parts as \"multipart/mixed\". @@ -5035,7 +5294,7 @@ If t, it overrides nil values of (defcustom gnus-mime-display-multipart-alternative-as-mixed nil "Display \"multipart/alternative\" parts as \"multipart/mixed\"." - :version "21.4" + :version "22.1" :group 'gnus-article-mime :type 'boolean) @@ -5045,12 +5304,14 @@ If t, it overrides nil values of If displaying \"text/html\" is discouraged \(see `mm-discouraged-alternatives'\) images or other material inside a \"multipart/related\" part might be overlooked when this variable is nil." - :version "21.4" + :version "22.1" :group 'gnus-article-mime :type 'boolean) (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)) @@ -5150,7 +5411,17 @@ If displaying \"text/html\" is discouraged \(see (forward-line -1) (setq beg (point))) (gnus-article-insert-newline) - (mm-display-inline handle) + (mm-insert-inline + handle + (let ((charset (mail-content-type-get (mm-handle-type handle) + 'charset))) + (cond ((not charset) + (mm-string-as-multibyte (mm-get-part handle))) + ((eq charset 'gnus-decoded) + (with-current-buffer (mm-handle-buffer handle) + (buffer-string))) + (t + (mm-decode-string (mm-get-part handle) charset))))) (goto-char (point-max)))) ;; Do highlighting. (save-excursion @@ -5220,7 +5491,7 @@ If displaying \"text/html\" is discouraged \(see ,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) @@ -5414,7 +5685,7 @@ If given a numerical ARG, move forward ARG pages." (goto-char (point-min)) (gnus-insert-prev-page-button))) (when (and (gnus-visual-p 'page-marker) - (< (+ (point-max) 2) (buffer-size))) + (< (point-max) (save-restriction (widen) (point-max)))) (save-excursion (goto-char (point-max)) (gnus-insert-next-page-button)))))) @@ -5477,14 +5748,36 @@ Argument LINES specifies lines to be scrolled up." (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. @@ -5498,13 +5791,13 @@ Argument LINES specifies lines to be scrolled down." (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))))) + (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. @@ -5639,7 +5932,7 @@ not have a face in `gnus-article-boring-faces'." (when (eq win (selected-window)) (setq new-sum-point (point) new-sum-start (window-start win) - new-sum-hscroll (window-hscroll win)) + new-sum-hscroll (window-hscroll win))) (when (eq in-buffer (current-buffer)) (setq selected (gnus-summary-select-article)) (set-buffer obuf) @@ -5655,7 +5948,7 @@ not have a face in `gnus-article-boring-faces'." new-sum-point) (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)))))) @@ -6056,7 +6349,7 @@ groups." ,(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) @@ -6071,7 +6364,8 @@ groups." (setq gnus-prev-winconf winconf) (when gnus-article-edit-article-setup-function (funcall gnus-article-edit-article-setup-function)) - (gnus-message 6 "C-c C-c to end edits; C-c C-k to exit"))) + (unless quiet + (gnus-message 6 "C-c C-c to end edits; C-c C-k to exit")))) (defun gnus-article-edit-done (&optional arg) "Update the article edits and exit." @@ -6272,7 +6566,15 @@ after replacing with the original article." (defcustom gnus-button-valid-fqdn-regexp message-valid-fqdn-regexp "Regular expression that matches a valid FQDN." - :version "21.4" + :version "22.1" + :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) @@ -6280,7 +6582,7 @@ after replacing with the original article." "Function to use for displaying man pages. The function must take at least one argument with a string naming the man page." - :version "21.4" + :version "22.1" :type '(choice (function-item :tag "Man" manual-entry) (function-item :tag "Woman" woman) (function :tag "Other")) @@ -6291,7 +6593,7 @@ man page." If the default site is too slow, try to find a CTAN mirror, see . See also the variable `gnus-button-handle-ctan'." - :version "21.4" + :version "22.1" :group 'gnus-article-buttons :link '(custom-manual "(gnus)Group Parameters") :type '(choice (const "http://www.tex.ac.uk/tex-archive/") @@ -6302,38 +6604,36 @@ the variable `gnus-button-handle-ctan'." (defcustom gnus-button-ctan-handler 'browse-url "Function to use for displaying CTAN links. The function must take one argument, the string naming the URL." - :version "21.4" + :version "22.1" :type '(choice (function-item :tag "Browse Url" browse-url) (function :tag "Other")) :group 'gnus-article-buttons) (defcustom gnus-button-handle-ctan-bogus-regexp "^/?tex-archive/\\|^/" "Bogus strings removed from CTAN URLs." - :version "21.4" + :version "22.1" :group 'gnus-article-buttons :type '(choice (const "^/?tex-archive/\\|/") (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 "21.4" + :version "22.1" :group 'gnus-article-buttons :type 'regexp) (defcustom gnus-button-mid-or-mail-regexp - (concat "\\b\\(\")!;:,{}\n\t ]*@" - ;; Felix Wiemann in <87oeuomcz9.fsf@news2.ososo.de> + (concat "\\b\\(?\\)\\b") "Regular expression that matches a message ID or a mail address." - :version "21.4" + :version "22.1" :group 'gnus-article-buttons :type 'regexp) @@ -6345,7 +6645,7 @@ 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 must return `mid', `mail', `invalid' or `ask'." - :version "21.4" + :version "22.1" :group 'gnus-article-buttons :type '(choice (function-item :tag "Heuristic function" gnus-button-mid-or-mail-heuristic) @@ -6409,7 +6709,7 @@ must return `mid', `mail', `invalid' or `ask'." A negative RATE indicates a message IDs, whereas a positive indicates a mail address. The REGEXP is processed with `case-fold-search' set to nil." - :version "21.4" + :version "22.1" :group 'gnus-article-buttons :type '(repeat (cons (number :tag "Rate") (regexp :tag "Regexp")))) @@ -6510,9 +6810,11 @@ address, `ask' if unsure and `invalid' if the string is invalid." (gnus-url-mailto url-mailto)) (t (gnus-message 3 "Invalid string."))))) -(defun gnus-button-handle-custom (url) - "Follow a Custom URL." - (customize-apropos (gnus-url-unhex-string url))) +(defun gnus-button-handle-custom (fun arg) + "Call function FUN on argument ARG. +Both FUN and ARG are supposed to be strings. ARG will be passed +as a symbol to FUN." + (funcall (intern fun) (intern arg))) (defvar gnus-button-handle-describe-prefix "^\\(C-h\\|?\\)") @@ -6594,7 +6896,7 @@ positives are possible. Note that you can set this variable local to specific groups. Setting it higher in TeX groups is probably a good idea. See Info node `(gnus)Group Parameters' and the variable `gnus-parameters' on how to set variables in specific groups." - :version "21.4" + :version "22.1" :group 'gnus-article-buttons :link '(custom-manual "(gnus)Group Parameters") :type 'integer) @@ -6606,7 +6908,7 @@ positives are possible. Note that you can set this variable local to specific groups. Setting it higher in Unix groups is probably a good idea. See Info node `(gnus)Group Parameters' and the variable `gnus-parameters' on how to set variables in specific groups." - :version "21.4" + :version "22.1" :group 'gnus-article-buttons :link '(custom-manual "(gnus)Group Parameters") :type 'integer) @@ -6618,7 +6920,7 @@ positives are possible. Note that you can set this variable local to specific groups. Setting it higher in Emacs or Gnus related groups is probably a good idea. See Info node `(gnus)Group Parameters' and the variable `gnus-parameters' on how to set variables in specific groups." - :version "21.4" + :version "22.1" :group 'gnus-article-buttons :link '(custom-manual "(gnus)Group Parameters") :type 'integer) @@ -6628,7 +6930,7 @@ probably a good idea. See Info node `(gnus)Group Parameters' and the variable The higher the number, the more buttons will appear and the more false positives are possible." ;; mail addresses, MIDs, URLs for news, ... - :version "21.4" + :version "22.1" :group 'gnus-article-buttons :type 'integer) @@ -6637,15 +6939,16 @@ positives are possible." The higher the number, the more buttons will appear and the more false positives are possible." ;; stuff handled by `browse-url' or `gnus-button-embedded-url' - :version "21.4" + :version "22.1" :group 'gnus-article-buttons :type 'integer) (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 ]+\\)" @@ -6691,10 +6994,8 @@ positives are possible." ;; 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 ` '. @@ -6787,13 +7088,15 @@ variable it the real callback function." ("^\\(From\\|Reply-To\\):" ": *\\(.+\\)$" 1 (>= gnus-button-message-level 0) gnus-button-reply 1) ("^\\(Cc\\|To\\):" "[^ \t\n<>,()\"]+@[^ \t\n<>,()\"]+" - 0 (>= gnus-button-message-level 0) gnus-button-mailto 0) + 0 (>= gnus-button-message-level 0) gnus-msg-mail 0) ("^X-[Uu][Rr][Ll]:" gnus-button-url-regexp 0 (>= gnus-button-browse-level 0) browse-url 0) ("^Subject:" gnus-button-url-regexp 0 (>= gnus-button-browse-level 0) browse-url 0) ("^[^:]+:" gnus-button-url-regexp 0 (>= gnus-button-browse-level 0) browse-url 0) + ("^OpenPGP:.*url=" gnus-button-url-regexp + 0 (>= gnus-button-browse-level 0) gnus-button-openpgp 0) ("^[^:]+:" "\\bmailto:\\([-a-z.@_+0-9%=?&/]+\\)" 0 (>= gnus-button-message-level 0) gnus-url-mailto 1) ("^[^:]+:" "\\(<\\(url: \\)?\\(nntp\\|news\\):\\([^>\n ]*\\)>\\)" @@ -6935,7 +7238,7 @@ do the highlighting. See the documentation for those functions." (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) (when gnus-signature-face (gnus-with-article-buffer @@ -7112,15 +7415,18 @@ specified by `gnus-button-alist'." (cons fun args))))))) (defun gnus-parse-news-url (url) - (let (scheme server group message-id articles) + (let (scheme server port group message-id articles) (with-temp-buffer (insert url) (goto-char (point-min)) (when (looking-at "\\([A-Za-z]+\\):") (setq scheme (match-string 1)) (goto-char (match-end 0))) - (when (looking-at "//\\([^/]+\\)/") + (when (looking-at "//\\([^:/]+\\)\\(:?\\)\\([0-9]+\\)?/") (setq server (match-string 1)) + (setq port (if (stringp (match-string 3)) + (string-to-number (match-string 3)) + (match-string 3))) (goto-char (match-end 0))) (cond @@ -7133,18 +7439,23 @@ specified by `gnus-button-alist'." (setq group (match-string 1))) (t (error "Unknown news URL syntax")))) - (list scheme server group message-id articles))) + (list scheme server port group message-id articles))) (defun gnus-button-handle-news (url) "Fetch a news URL." - (destructuring-bind (scheme server group message-id articles) + (destructuring-bind (scheme server port group message-id articles) (gnus-parse-news-url url) (cond (message-id (save-excursion (set-buffer gnus-summary-buffer) (if server - (let ((gnus-refer-article-method (list (list 'nntp server)))) + (let ((gnus-refer-article-method + (nconc (list (list 'nntp server)) + gnus-refer-article-method)) + (nntp-port-number (or port "nntp"))) + (gnus-message 7 "Fetching %s with %s" + message-id gnus-refer-article-method) (gnus-summary-refer-article message-id)) (gnus-summary-refer-article message-id)))) (group @@ -7180,10 +7491,10 @@ specified by `gnus-button-alist'." (if (string-match "\\([^#]+\\)#?\\(.*\\)" url) (gnus-info-find-node (concat "(" - (gnus-url-unhex-string + (gnus-url-unhex-string (match-string 1 url)) ")" - (or (gnus-url-unhex-string + (or (gnus-url-unhex-string (match-string 2 url)) "Top"))) (error "Can't parse %s" url))) @@ -7199,6 +7510,13 @@ specified by `gnus-button-alist'." (Info-directory) (Info-menu url)) +(defun gnus-button-openpgp (url) + "Retrieve and add an OpenPGP key given URL from an OpenPGP header." + (with-temp-buffer + (mm-url-insert-file-contents-external url) + (pgg-snarf-keys-region (point-min) (point-max)) + (pgg-display-output-buffer nil nil nil))) + (defun gnus-button-message-id (message-id) "Fetch MESSAGE-ID." (with-current-buffer gnus-summary-buffer @@ -7222,7 +7540,7 @@ specified by `gnus-button-alist'." (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) @@ -7487,6 +7805,8 @@ For example: t) ((eq val 'head) nil) + ((eq val 'first) + (eq part-number 1)) ((eq val 'last) (eq part-number total-parts)) ((numberp val) @@ -7505,7 +7825,7 @@ For example: current-prefix-arg)) (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")) @@ -7725,7 +8045,7 @@ For example: (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))