-;;; gnus-art.el --- article mode commands for Semi-gnus\r\r
-;; Copyright (C) 1996,97,98 Free Software Foundation, Inc.\r\r
-\r\r
-;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>\r\r
-;; MORIOKA Tomohiko <morioka@jaist.ac.jp>\r\r
-;; Katsumi Yamaoka <yamaoka@jpl.org>\r\r
-;; Keywords: mail, news, MIME\r\r
-\r\r
-;; This file is part of GNU Emacs.\r\r
-\r\r
-;; GNU Emacs is free software; you can redistribute it and/or modify\r\r
-;; it under the terms of the GNU General Public License as published by\r\r
-;; the Free Software Foundation; either version 2, or (at your option)\r\r
-;; any later version.\r\r
-\r\r
-;; GNU Emacs is distributed in the hope that it will be useful,\r\r
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of\r\r
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\r\r
-;; GNU General Public License for more details.\r\r
-\r\r
-;; You should have received a copy of the GNU General Public License\r\r
-;; along with GNU Emacs; see the file COPYING. If not, write to the\r\r
-;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,\r\r
-;; Boston, MA 02111-1307, USA.\r\r
-\r\r
-;;; Commentary:\r\r
-\r\r
-;;; Code:\r\r
-\r\r
-(eval-when-compile (require 'cl))\r\r
-\r\r
-(require 'custom)\r\r
-(require 'gnus)\r\r
-(require 'gnus-sum)\r\r
-(require 'gnus-spec)\r\r
-(require 'gnus-int)\r\r
-(require 'browse-url)\r\r
-(require 'alist)\r\r
-(require 'mime-view)\r\r
-\r\r
-;; Avoid byte-compile warnings.\r\r
-(eval-when-compile\r\r
- (defvar gnus-article-decoded-p)\r\r
- (defvar gnus-article-mime-handles)\r\r
- (require 'mm-bodies)\r\r
- (require 'mail-parse)\r\r
- (require 'mm-decode)\r\r
- (require 'mm-view)\r\r
- (require 'wid-edit)\r\r
- (require 'mm-uu)\r\r
- )\r\r
-\r\r
-(defgroup gnus-article nil\r\r
- "Article display."\r\r
- :link '(custom-manual "(gnus)The Article Buffer")\r\r
- :group 'gnus)\r\r
-\r\r
-(defgroup gnus-article-hiding nil\r\r
- "Hiding article parts."\r\r
- :link '(custom-manual "(gnus)Article Hiding")\r\r
- :group 'gnus-article)\r\r
-\r\r
-(defgroup gnus-article-highlight nil\r\r
- "Article highlighting."\r\r
- :link '(custom-manual "(gnus)Article Highlighting")\r\r
- :group 'gnus-article\r\r
- :group 'gnus-visual)\r\r
-\r\r
-(defgroup gnus-article-signature nil\r\r
- "Article signatures."\r\r
- :link '(custom-manual "(gnus)Article Signature")\r\r
- :group 'gnus-article)\r\r
-\r\r
-(defgroup gnus-article-headers nil\r\r
- "Article headers."\r\r
- :link '(custom-manual "(gnus)Hiding Headers")\r\r
- :group 'gnus-article)\r\r
-\r\r
-(defgroup gnus-article-washing nil\r\r
- "Special commands on articles."\r\r
- :link '(custom-manual "(gnus)Article Washing")\r\r
- :group 'gnus-article)\r\r
-\r\r
-(defgroup gnus-article-emphasis nil\r\r
- "Fontisizing articles."\r\r
- :link '(custom-manual "(gnus)Article Fontisizing")\r\r
- :group 'gnus-article)\r\r
-\r\r
-(defgroup gnus-article-saving nil\r\r
- "Saving articles."\r\r
- :link '(custom-manual "(gnus)Saving Articles")\r\r
- :group 'gnus-article)\r\r
-\r\r
-(defgroup gnus-article-mime nil\r\r
- "Worshiping the MIME wonder."\r\r
- :link '(custom-manual "(gnus)Using MIME")\r\r
- :group 'gnus-article)\r\r
-\r\r
-(defgroup gnus-article-buttons nil\r\r
- "Pushable buttons in the article buffer."\r\r
- :link '(custom-manual "(gnus)Article Buttons")\r\r
- :group 'gnus-article)\r\r
-\r\r
-(defgroup gnus-article-various nil\r\r
- "Other article options."\r\r
- :link '(custom-manual "(gnus)Misc Article")\r\r
- :group 'gnus-article)\r\r
-\r\r
-(defcustom gnus-ignored-headers\r\r
- '("^Path:" "^Expires:" "^Date-Received:" "^References:" "^Xref:" "^Lines:"\r\r
- "^Relay-Version:" "^Message-ID:" "^Approved:" "^Sender:" "^Received:"\r\r
- "^X-UIDL:" "^MIME-Version:" "^Return-Path:" "^In-Reply-To:"\r\r
- "^Content-Type:" "^Content-Transfer-Encoding:" "^X-WebTV-Signature:"\r\r
- "^X-MimeOLE:" "^X-MSMail-Priority:" "^X-Priority:" "^X-Loop:"\r\r
- "^X-Authentication-Warning:" "^X-MIME-Autoconverted:" "^X-Face:"\r\r
- "^X-Attribution:" "^X-Originating-IP:" "^Delivered-To:"\r\r
- "^NNTP-[-A-Za-z]+:" "^Distribution:" "^X-no-archive:" "^X-Trace:"\r\r
- "^X-Complaints-To:" "^X-NNTP-Posting-Host:" "^X-Orig.*:"\r\r
- "^Abuse-Reports-To:" "^Cache-Post-Path:" "^X-Article-Creation-Date:"\r\r
- "^X-Poster:" "^X-Mail2News-Path:" "^X-Server-Date:" "^X-Cache:"\r\r
- "^Originator:" "^X-Problems-To:" "^X-Auth-User:" "^X-Post-Time:"\r\r
- "^X-Admin:" "^X-UID:" "^Resent-[-A-Za-z]+:" "^X-Mailing-List:"\r\r
- "^Precedence:" "^Original-[-A-Za-z]+:" "^X-filename:" "^X-Orcpt:"\r\r
- "^Old-Received:" "^X-Pgp-Fingerprint:" "^X-Pgp-Key-Id:"\r\r
- "^X-Pgp-Public-Key-Url:" "^X-Auth:" "^X-From-Line:"\r\r
- "^X-Gnus-Article-Number:" "^X-Majordomo:" "^X-Url:" "^X-Sender:"\r\r
- "^X-Mailing-List:" "^MBOX-Line" "^Priority:" "^X-Pgp" "^X400-[-A-Za-z]+:"\r\r
- "^Status:")\r\r
- "*All headers that start with this regexp will be hidden.\r\r
-This variable can also be a list of regexps of headers to be ignored.\r\r
-If `gnus-visible-headers' is non-nil, this variable will be ignored."\r\r
- :type '(choice :custom-show nil\r\r
- regexp\r\r
- (repeat regexp))\r\r
- :group 'gnus-article-hiding)\r\r
-\r\r
-(defcustom gnus-visible-headers\r\r
- "From:\\|^Newsgroups:\\|^Subject:\\|^Date:\\|^\\(Mail-\\)?Followup-To:\\|^\\(Mail-\\)?Reply-To:\\|^Mail-Copies-To:\\|^Organization:\\|^Summary:\\|^Keywords:\\|^To:\\|^Cc:\\|^Posted-To:\\|^Apparently-To:\\|^Gnus-Warning:\\|^Resent-From:\\|X-Sent:"\r\r
- "*All headers that do not match this regexp will be hidden.\r\r
-This variable can also be a list of regexp of headers to remain visible.\r\r
-If this variable is non-nil, `gnus-ignored-headers' will be ignored."\r\r
- :type '(repeat :value-to-internal (lambda (widget value)\r\r
- (custom-split-regexp-maybe value))\r\r
- :match (lambda (widget value)\r\r
- (or (stringp value)\r\r
- (widget-editable-list-match widget value)))\r\r
- regexp)\r\r
- :group 'gnus-article-hiding)\r\r
-\r\r
-(defcustom gnus-sorted-header-list\r\r
- '("^From:" "^Subject:" "^Summary:" "^Keywords:" "^Newsgroups:"\r\r
- "^Followup-To:" "^To:" "^Cc:" "^Date:" "^Organization:")\r\r
- "*This variable is a list of regular expressions.\r\r
-If it is non-nil, headers that match the regular expressions will\r\r
-be placed first in the article buffer in the sequence specified by\r\r
-this list."\r\r
- :type '(repeat regexp)\r\r
- :group 'gnus-article-hiding)\r\r
-\r\r
-(defcustom gnus-boring-article-headers '(empty followup-to reply-to)\r\r
- "Headers that are only to be displayed if they have interesting data.\r\r
-Possible values in this list are `empty', `newsgroups', `followup-to',\r\r
-`reply-to', `date', `long-to', and `many-to'."\r\r
- :type '(set (const :tag "Headers with no content." empty)\r\r
- (const :tag "Newsgroups with only one group." newsgroups)\r\r
- (const :tag "Followup-to identical to newsgroups." followup-to)\r\r
- (const :tag "Reply-to identical to from." reply-to)\r\r
- (const :tag "Date less than four days old." date)\r\r
- (const :tag "Very long To header." long-to)\r\r
- (const :tag "Multiple To headers." many-to))\r\r
- :group 'gnus-article-hiding)\r\r
-\r\r
-(defcustom gnus-signature-separator '("^-- $" "^-- *$")\r\r
- "Regexp matching signature separator.\r\r
-This can also be a list of regexps. In that case, it will be checked\r\r
-from head to tail looking for a separator. Searches will be done from\r\r
-the end of the buffer."\r\r
- :type '(repeat string)\r\r
- :group 'gnus-article-signature)\r\r
-\r\r
-(defcustom gnus-signature-limit nil\r\r
- "Provide a limit to what is considered a signature.\r\r
-If it is a number, no signature may not be longer (in characters) than\r\r
-that number. If it is a floating point number, no signature may be\r\r
-longer (in lines) than that number. If it is a function, the function\r\r
-will be called without any parameters, and if it returns nil, there is\r\r
-no signature in the buffer. If it is a string, it will be used as a\r\r
-regexp. If it matches, the text in question is not a signature."\r\r
- :type '(choice (integer :value 200)\r\r
- (number :value 4.0)\r\r
- (function :value fun)\r\r
- (regexp :value ".*"))\r\r
- :group 'gnus-article-signature)\r\r
-\r\r
-(defcustom gnus-hidden-properties '(invisible t intangible t)\r\r
- "Property list to use for hiding text."\r\r
- :type 'sexp\r\r
- :group 'gnus-article-hiding)\r\r
-\r\r
-(defcustom gnus-article-x-face-command\r\r
- "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | xv -quit -"\r\r
- "*String or function to be executed to display an X-Face header.\r\r
-If it is a string, the command will be executed in a sub-shell\r\r
-asynchronously. The compressed face will be piped to this command."\r\r
- :type 'string ;Leave function case to Lisp.\r\r
- :group 'gnus-article-washing)\r\r
-\r\r
-(defcustom gnus-article-x-face-too-ugly nil\r\r
- "Regexp matching posters whose face shouldn't be shown automatically."\r\r
- :type '(choice regexp (const nil))\r\r
- :group 'gnus-article-washing)\r\r
-\r\r
-(defcustom gnus-emphasis-alist\r\r
- (let ((format\r\r
- "\\(\\s-\\|^\\|[-\"]\\|\\s(\\|\\s)\\)\\(%s\\(\\w+\\(\\s-+\\w+\\)*[.,]?\\)%s\\)\\(\\s-\\|[-?!.,;:\"]\\|\\s(\\|\\s)\\)")\r\r
- (types\r\r
- '(("_" "_" underline)\r\r
- ("/" "/" italic)\r\r
- ("\\*" "\\*" bold)\r\r
- ("_/" "/_" underline-italic)\r\r
- ("_\\*" "\\*_" underline-bold)\r\r
- ("\\*/" "/\\*" bold-italic)\r\r
- ("_\\*/" "/\\*_" underline-bold-italic))))\r\r
- `(("\\(\\s-\\|^\\)\\(_\\(\\(\\w\\|_[^_]\\)+\\)_\\)\\(\\s-\\|[?!.,;]\\)"\r\r
- 2 3 gnus-emphasis-underline)\r\r
- ,@(mapcar\r\r
- (lambda (spec)\r\r
- (list\r\r
- (format format (car spec) (cadr spec))\r\r
- 2 3 (intern (format "gnus-emphasis-%s" (nth 2 spec)))))\r\r
- types)))\r\r
- "*Alist that says how to fontify certain phrases.\r\r
-Each item looks like this:\r\r
-\r\r
- (\"_\\\\(\\\\w+\\\\)_\" 0 1 'underline)\r\r
-\r\r
-The first element is a regular expression to be matched. The second\r\r
-is a number that says what regular expression grouping used to find\r\r
-the entire emphasized word. The third is a number that says what\r\r
-regexp grouping should be displayed and highlighted. The fourth\r\r
-is the face used for highlighting."\r\r
- :type '(repeat (list :value ("" 0 0 default)\r\r
- regexp\r\r
- (integer :tag "Match group")\r\r
- (integer :tag "Emphasize group")\r\r
- face))\r\r
- :group 'gnus-article-emphasis)\r\r
-\r\r
-(defface gnus-emphasis-bold '((t (:bold t)))\r\r
- "Face used for displaying strong emphasized text (*word*)."\r\r
- :group 'gnus-article-emphasis)\r\r
-\r\r
-(defface gnus-emphasis-italic '((t (:italic t)))\r\r
- "Face used for displaying italic emphasized text (/word/)."\r\r
- :group 'gnus-article-emphasis)\r\r
-\r\r
-(defface gnus-emphasis-underline '((t (:underline t)))\r\r
- "Face used for displaying underlined emphasized text (_word_)."\r\r
- :group 'gnus-article-emphasis)\r\r
-\r\r
-(defface gnus-emphasis-underline-bold '((t (:bold t :underline t)))\r\r
- "Face used for displaying underlined bold emphasized text (_*word*_)."\r\r
- :group 'gnus-article-emphasis)\r\r
-\r\r
-(defface gnus-emphasis-underline-italic '((t (:italic t :underline t)))\r\r
- "Face used for displaying underlined italic emphasized text (_*word*_)."\r\r
- :group 'gnus-article-emphasis)\r\r
-\r\r
-(defface gnus-emphasis-bold-italic '((t (:bold t :italic t)))\r\r
- "Face used for displaying bold italic emphasized text (/*word*/)."\r\r
- :group 'gnus-article-emphasis)\r\r
-\r\r
-(defface gnus-emphasis-underline-bold-italic\r\r
- '((t (:bold t :italic t :underline t)))\r\r
- "Face used for displaying underlined bold italic emphasized text.\r\r
-Esample: (_/*word*/_)."\r\r
- :group 'gnus-article-emphasis)\r\r
-\r\r
-(defcustom gnus-article-time-format "%a, %b %d %Y %T %Z"\r\r
- "Format for display of Date headers in article bodies.\r\r
-See `format-time-string' for the possible values.\r\r
-\r\r
-The variable can also be function, which should return a complete Date\r\r
-header. The function is called with one argument, the time, which can\r\r
-be fed to `format-time-string'."\r\r
- :type '(choice string symbol)\r\r
- :link '(custom-manual "(gnus)Article Date")\r\r
- :group 'gnus-article-washing)\r\r
-\r\r
-(eval-and-compile\r\r
- (autoload 'mail-extract-address-components "mail-extr"))\r\r
-\r\r
-(defcustom gnus-save-all-headers t\r\r
- "*If non-nil, don't remove any headers before saving."\r\r
- :group 'gnus-article-saving\r\r
- :type 'boolean)\r\r
-\r\r
-(defcustom gnus-prompt-before-saving 'always\r\r
- "*This variable says how much prompting is to be done when saving articles.\r\r
-If it is nil, no prompting will be done, and the articles will be\r\r
-saved to the default files. If this variable is `always', each and\r\r
-every article that is saved will be preceded by a prompt, even when\r\r
-saving large batches of articles. If this variable is neither nil not\r\r
-`always', there the user will be prompted once for a file name for\r\r
-each invocation of the saving commands."\r\r
- :group 'gnus-article-saving\r\r
- :type '(choice (item always)\r\r
- (item :tag "never" nil)\r\r
- (sexp :tag "once" :format "%t\n" :value t)))\r\r
-\r\r
-(defcustom gnus-saved-headers gnus-visible-headers\r\r
- "Headers to keep if `gnus-save-all-headers' is nil.\r\r
-If `gnus-save-all-headers' is non-nil, this variable will be ignored.\r\r
-If that variable is nil, however, all headers that match this regexp\r\r
-will be kept while the rest will be deleted before saving."\r\r
- :group 'gnus-article-saving\r\r
- :type 'regexp)\r\r
-\r\r
-(defcustom gnus-default-article-saver 'gnus-summary-save-in-rmail\r\r
- "A function to save articles in your favourite format.\r\r
-The function must be interactively callable (in other words, it must\r\r
-be an Emacs command).\r\r
-\r\r
-Gnus provides the following functions:\r\r
-\r\r
-* gnus-summary-save-in-rmail (Rmail format)\r\r
-* gnus-summary-save-in-mail (Unix mail format)\r\r
-* gnus-summary-save-in-folder (MH folder)\r\r
-* gnus-summary-save-in-file (article format)\r\r
-* gnus-summary-save-in-vm (use VM's folder format)\r\r
-* gnus-summary-write-to-file (article format -- overwrite)."\r\r
- :group 'gnus-article-saving\r\r
- :type '(radio (function-item gnus-summary-save-in-rmail)\r\r
- (function-item gnus-summary-save-in-mail)\r\r
- (function-item gnus-summary-save-in-folder)\r\r
- (function-item gnus-summary-save-in-file)\r\r
- (function-item gnus-summary-save-in-vm)\r\r
- (function-item gnus-summary-write-to-file)))\r\r
-\r\r
-(defcustom gnus-rmail-save-name 'gnus-plain-save-name\r\r
- "A function generating a file name to save articles in Rmail format.\r\r
-The function is called with NEWSGROUP, HEADERS, and optional LAST-FILE."\r\r
- :group 'gnus-article-saving\r\r
- :type 'function)\r\r
-\r\r
-(defcustom gnus-mail-save-name 'gnus-plain-save-name\r\r
- "A function generating a file name to save articles in Unix mail format.\r\r
-The function is called with NEWSGROUP, HEADERS, and optional LAST-FILE."\r\r
- :group 'gnus-article-saving\r\r
- :type 'function)\r\r
-\r\r
-(defcustom gnus-folder-save-name 'gnus-folder-save-name\r\r
- "A function generating a file name to save articles in MH folder.\r\r
-The function is called with NEWSGROUP, HEADERS, and optional LAST-FOLDER."\r\r
- :group 'gnus-article-saving\r\r
- :type 'function)\r\r
-\r\r
-(defcustom gnus-file-save-name 'gnus-numeric-save-name\r\r
- "A function generating a file name to save articles in article format.\r\r
-The function is called with NEWSGROUP, HEADERS, and optional\r\r
-LAST-FILE."\r\r
- :group 'gnus-article-saving\r\r
- :type 'function)\r\r
-\r\r
-(defcustom gnus-split-methods\r\r
- '((gnus-article-archive-name)\r\r
- (gnus-article-nndoc-name))\r\r
- "*Variable used to suggest where articles are to be saved.\r\r
-For instance, if you would like to save articles related to Gnus in\r\r
-the file \"gnus-stuff\", and articles related to VM in \"vm-stuff\",\r\r
-you could set this variable to something like:\r\r
-\r\r
- '((\"^Subject:.*gnus\\|^Newsgroups:.*gnus\" \"gnus-stuff\")\r\r
- (\"^Subject:.*vm\\|^Xref:.*vm\" \"vm-stuff\"))\r\r
-\r\r
-This variable is an alist where the where the key is the match and the\r\r
-value is a list of possible files to save in if the match is non-nil.\r\r
-\r\r
-If the match is a string, it is used as a regexp match on the\r\r
-article. If the match is a symbol, that symbol will be funcalled\r\r
-from the buffer of the article to be saved with the newsgroup as the\r\r
-parameter. If it is a list, it will be evaled in the same buffer.\r\r
-\r\r
-If this form or function returns a string, this string will be used as\r\r
-a possible file name; and if it returns a non-nil list, that list will\r\r
-be used as possible file names."\r\r
- :group 'gnus-article-saving\r\r
- :type '(repeat (choice (list :value (fun) function)\r\r
- (cons :value ("" "") regexp (repeat string))\r\r
- (sexp :value nil))))\r\r
-\r\r
-(defcustom gnus-article-display-method-for-mime\r\r
- 'gnus-article-display-mime-message\r\r
- "Function to display a MIME message.\r\r
-The function is called from the article buffer."\r\r
- :group 'gnus-article-mime\r\r
- :type 'function)\r\r
-\r\r
-(defcustom gnus-article-display-method-for-traditional\r\r
- 'gnus-article-display-traditional-message\r\r
- "*Function to display a traditional message.\r\r
-The function is called from the article buffer."\r\r
- :group 'gnus-article-mime\r\r
- :type 'function)\r\r
-\r\r
-(defcustom gnus-page-delimiter "^\^L"\r\r
- "*Regexp describing what to use as article page delimiters.\r\r
-The default value is \"^\^L\", which is a form linefeed at the\r\r
-beginning of a line."\r\r
- :type 'regexp\r\r
- :group 'gnus-article-various)\r\r
-\r\r
-(defcustom gnus-article-mode-line-format "Gnus: %g %S%m"\r\r
- "*The format specification for the article mode line.\r\r
-See `gnus-summary-mode-line-format' for a closer description.\r\r
-\r\r
-The following additional specs are available:\r\r
-\r\r
-%w The article washing status.\r\r
-%m The number of MIME parts in the article."\r\r
- :type 'string\r\r
- :group 'gnus-article-various)\r\r
-\r\r
-(defcustom gnus-article-mode-hook nil\r\r
- "*A hook for Gnus article mode."\r\r
- :type 'hook\r\r
- :group 'gnus-article-various)\r\r
-\r\r
-(defcustom gnus-article-menu-hook nil\r\r
- "*Hook run after the creation of the article mode menu."\r\r
- :type 'hook\r\r
- :group 'gnus-article-various)\r\r
-\r\r
-(defcustom gnus-article-prepare-hook nil\r\r
- "*A hook called after an article has been prepared in the article buffer.\r\r
-If you want to run a special decoding program like nkf, use this hook."\r\r
- :type 'hook\r\r
- :group 'gnus-article-various)\r\r
-\r\r
-(defcustom gnus-article-hide-pgp-hook nil\r\r
- "*A hook called after successfully hiding a PGP signature."\r\r
- :type 'hook\r\r
- :group 'gnus-article-various)\r\r
-\r\r
-(defcustom gnus-article-button-face 'bold\r\r
- "Face used for highlighting buttons in the article buffer.\r\r
-\r\r
-An article button is a piece of text that you can activate by pressing\r\r
-`RET' or `mouse-2' above it."\r\r
- :type 'face\r\r
- :group 'gnus-article-buttons)\r\r
-\r\r
-(defcustom gnus-article-mouse-face 'highlight\r\r
- "Face used for mouse highlighting in the article buffer.\r\r
-\r\r
-Article buttons will be displayed in this face when the cursor is\r\r
-above them."\r\r
- :type 'face\r\r
- :group 'gnus-article-buttons)\r\r
-\r\r
-(defcustom gnus-signature-face 'gnus-signature-face\r\r
- "Face used for highlighting a signature in the article buffer.\r\r
-Obsolete; use the face `gnus-signature-face' for customizations instead."\r\r
- :type 'face\r\r
- :group 'gnus-article-highlight\r\r
- :group 'gnus-article-signature)\r\r
-\r\r
-(defface gnus-signature-face\r\r
- '((((type x))\r\r
- (:italic t)))\r\r
- "Face used for highlighting a signature in the article buffer."\r\r
- :group 'gnus-article-highlight\r\r
- :group 'gnus-article-signature)\r\r
-\r\r
-(defface gnus-header-from-face\r\r
- '((((class color)\r\r
- (background dark))\r\r
- (:foreground "spring green"))\r\r
- (((class color)\r\r
- (background light))\r\r
- (:foreground "red3"))\r\r
- (t\r\r
- (:italic t)))\r\r
- "Face used for displaying from headers."\r\r
- :group 'gnus-article-headers\r\r
- :group 'gnus-article-highlight)\r\r
-\r\r
-(defface gnus-header-subject-face\r\r
- '((((class color)\r\r
- (background dark))\r\r
- (:foreground "SeaGreen3"))\r\r
- (((class color)\r\r
- (background light))\r\r
- (:foreground "red4"))\r\r
- (t\r\r
- (:bold t :italic t)))\r\r
- "Face used for displaying subject headers."\r\r
- :group 'gnus-article-headers\r\r
- :group 'gnus-article-highlight)\r\r
-\r\r
-(defface gnus-header-newsgroups-face\r\r
- '((((class color)\r\r
- (background dark))\r\r
- (:foreground "yellow" :italic t))\r\r
- (((class color)\r\r
- (background light))\r\r
- (:foreground "MidnightBlue" :italic t))\r\r
- (t\r\r
- (:italic t)))\r\r
- "Face used for displaying newsgroups headers."\r\r
- :group 'gnus-article-headers\r\r
- :group 'gnus-article-highlight)\r\r
-\r\r
-(defface gnus-header-name-face\r\r
- '((((class color)\r\r
- (background dark))\r\r
- (:foreground "SeaGreen"))\r\r
- (((class color)\r\r
- (background light))\r\r
- (:foreground "maroon"))\r\r
- (t\r\r
- (:bold t)))\r\r
- "Face used for displaying header names."\r\r
- :group 'gnus-article-headers\r\r
- :group 'gnus-article-highlight)\r\r
-\r\r
-(defface gnus-header-content-face\r\r
- '((((class color)\r\r
- (background dark))\r\r
- (:foreground "forest green" :italic t))\r\r
- (((class color)\r\r
- (background light))\r\r
- (:foreground "indianred4" :italic t))\r\r
- (t\r\r
- (:italic t))) "Face used for displaying header content."\r\r
- :group 'gnus-article-headers\r\r
- :group 'gnus-article-highlight)\r\r
-\r\r
-(defcustom gnus-header-face-alist\r\r
- '(("From" nil gnus-header-from-face)\r\r
- ("Subject" nil gnus-header-subject-face)\r\r
- ("Newsgroups:.*," nil gnus-header-newsgroups-face)\r\r
- ("" gnus-header-name-face gnus-header-content-face))\r\r
- "*Controls highlighting of article header.\r\r
-\r\r
-An alist of the form (HEADER NAME CONTENT).\r\r
-\r\r
-HEADER is a regular expression which should match the name of an\r\r
-header header and NAME and CONTENT are either face names or nil.\r\r
-\r\r
-The name of each header field will be displayed using the face\r\r
-specified by the first element in the list where HEADER match the\r\r
-header name and NAME is non-nil. Similarly, the content will be\r\r
-displayed by the first non-nil matching CONTENT face."\r\r
- :group 'gnus-article-headers\r\r
- :group 'gnus-article-highlight\r\r
- :type '(repeat (list (regexp :tag "Header")\r\r
- (choice :tag "Name"\r\r
- (item :tag "skip" nil)\r\r
- (face :value default))\r\r
- (choice :tag "Content"\r\r
- (item :tag "skip" nil)\r\r
- (face :value default)))))\r\r
-\r\r
-(defcustom gnus-article-decode-hook nil\r\r
- "*Hook run to decode charsets in articles."\r\r
- :group 'gnus-article-headers\r\r
- :type 'hook)\r\r
-\r\r
-(defcustom gnus-display-mime-function 'gnus-display-mime\r\r
- "Function to display MIME articles."\r\r
- :group 'gnus-article-mime\r\r
- :type 'function)\r\r
-\r\r
-(defvar gnus-decode-header-function 'mail-decode-encoded-word-region\r\r
- "Function used to decode headers.")\r\r
-\r\r
-(defvar gnus-article-dumbquotes-map\r\r
- '(("\202" ",")\r\r
- ("\203" "f")\r\r
- ("\204" ",,")\r\r
- ("\205" "...")\r\r
- ("\213" "<")\r\r
- ("\214" "OE")\r\r
- ("\205" "...")\r\r
- ("\221" "`")\r\r
- ("\222" "'")\r\r
- ("\223" "``")\r\r
- ("\224" "''")\r\r
- ("\225" "*")\r\r
- ("\226" "-")\r\r
- ("\227" "-")\r\r
- ("\231" "(TM)")\r\r
- ("\233" ">")\r\r
- ("\234" "oe")\r\r
- ("\264" "'"))\r\r
- "Table for MS-to-Latin1 translation.")\r\r
-\r\r
-(defcustom gnus-ignored-mime-types nil\r\r
- "List of MIME types that should be ignored by Gnus."\r\r
- :group 'gnus-article-mime\r\r
- :type '(repeat regexp))\r\r
-\r\r
-(defcustom gnus-unbuttonized-mime-types '(".*/.*")\r\r
- "List of MIME types that should not be given buttons when rendered."\r\r
- :group 'gnus-article-mime\r\r
- :type '(repeat regexp))\r\r
-\r\r
-(defcustom gnus-treat-body-highlight-signature t\r\r
- "Highlight the signature."\r\r
- :group 'gnus-article\r\r
- :type '(choice (const :tag "Off" nil)\r\r
- (const :tag "On" t)\r\r
- (const :tag "Last" last)\r\r
- (integer :tag "Less")\r\r
- (sexp :tag "Predicate")))\r\r
-\r\r
-(defcustom gnus-article-mime-part-function nil\r\r
- "Function called with a MIME handle as the argument."\r\r
- :group 'gnus-article-mime\r\r
- :type 'function)\r\r
-\r\r
-;;; Internal variables\r\r
-\r\r
-(defvar gnus-article-mime-handle-alist-1 nil)\r\r
-(defvar gnus-treatment-function-alist\r\r
- '((gnus-treat-body-highlight-signature gnus-article-highlight-signature nil)\r\r
- ))\r\r
-\r\r
-(defvar gnus-article-mime-handle-alist nil)\r\r
-(defvar article-lapsed-timer nil)\r\r
-(defvar gnus-article-current-summary nil)\r\r
-\r\r
-(defvar gnus-article-mode-syntax-table\r\r
- (let ((table (copy-syntax-table text-mode-syntax-table)))\r\r
- (modify-syntax-entry ?- "w" table)\r\r
- (modify-syntax-entry ?> ")" table)\r\r
- (modify-syntax-entry ?< "(" table)\r\r
- table)\r\r
- "Syntax table used in article mode buffers.\r\r
-Initialized from `text-mode-syntax-table.")\r\r
-\r\r
-(defvar gnus-save-article-buffer nil)\r\r
-\r\r
-(defvar gnus-article-mode-line-format-alist\r\r
- (nconc '((?w (gnus-article-wash-status) ?s)\r\r
- (?m (gnus-article-mime-part-status) ?s))\r\r
- gnus-summary-mode-line-format-alist))\r\r
-\r\r
-(defvar gnus-number-of-articles-to-be-saved nil)\r\r
-\r\r
-(defvar gnus-inhibit-hiding nil)\r\r
-\r\r
-(defsubst gnus-article-hide-text (b e props)\r\r
- "Set text PROPS on the B to E region, extending `intangible' 1 past B."\r\r
- (add-text-properties b e props)\r\r
- (when (memq 'intangible props)\r\r
- (put-text-property\r\r
- (max (1- b) (point-min))\r\r
- b 'intangible (cddr (memq 'intangible props)))))\r\r
-\r\r
-(defmacro gnus-with-article (article &rest forms)\r\r
- "Select ARTICLE and perform FORMS in the original article buffer.\r\r
-Then replace the article with the result."\r\r
- `(progn\r\r
- ;; We don't want the article to be marked as read.\r\r
- (let (gnus-mark-article-hook)\r\r
- (gnus-summary-select-article t t nil ,article))\r\r
- (set-buffer gnus-original-article-buffer)\r\r
- ,@forms\r\r
- (if (not (gnus-check-backend-function\r\r
- 'request-replace-article (car gnus-article-current)))\r\r
- (gnus-message 5 "Read-only group; not replacing")\r\r
- (unless (gnus-request-replace-article\r\r
- ,article (car gnus-article-current)\r\r
- (current-buffer) t)\r\r
- (error "Couldn't replace article")))\r\r
- ;; The cache and backlog have to be flushed somewhat.\r\r
- (when gnus-keep-backlog\r\r
- (gnus-backlog-remove-article\r\r
- (car gnus-article-current) (cdr gnus-article-current)))\r\r
- (when gnus-use-cache\r\r
- (gnus-cache-update-article\r\r
- (car gnus-article-current) (cdr gnus-article-current)))))\r\r
-\r\r
-(put 'gnus-with-article 'lisp-indent-function 1)\r\r
-(put 'gnus-with-article 'edebug-form-spec '(form body))\r\r
-\r\r
-(defsubst gnus-article-unhide-text (b e)\r\r
- "Remove hidden text properties from region between B and E."\r\r
- (remove-text-properties b e gnus-hidden-properties)\r\r
- (when (memq 'intangible gnus-hidden-properties)\r\r
- (put-text-property (max (1- b) (point-min))\r\r
- b 'intangible nil)))\r\r
-\r\r
-(defun gnus-article-hide-text-type (b e type)\r\r
- "Hide text of TYPE between B and E."\r\r
- (gnus-article-hide-text\r\r
- b e (cons 'article-type (cons type gnus-hidden-properties))))\r\r
-\r\r
-(defun gnus-article-unhide-text-type (b e type)\r\r
- "Unhide text of TYPE between B and E."\r\r
- (remove-text-properties\r\r
- b e (cons 'article-type (cons type gnus-hidden-properties)))\r\r
- (when (memq 'intangible gnus-hidden-properties)\r\r
- (put-text-property (max (1- b) (point-min))\r\r
- b 'intangible nil)))\r\r
-\r\r
-(defun gnus-article-hide-text-of-type (type)\r\r
- "Hide text of TYPE in the current buffer."\r\r
- (save-excursion\r\r
- (let ((b (point-min))\r\r
- (e (point-max)))\r\r
- (while (setq b (text-property-any b e 'article-type type))\r\r
- (add-text-properties b (incf b) gnus-hidden-properties)))))\r\r
-\r\r
-(defun gnus-article-delete-text-of-type (type)\r\r
- "Delete text of TYPE in the current buffer."\r\r
- (save-excursion\r\r
- (let ((b (point-min)))\r\r
- (while (setq b (text-property-any b (point-max) 'article-type type))\r\r
- (delete-region\r\r
- b (or (text-property-not-all b (point-max) 'article-type type)\r\r
- (point-max)))))))\r\r
-\r\r
-(defun gnus-article-delete-invisible-text ()\r\r
- "Delete all invisible text in the current buffer."\r\r
- (save-excursion\r\r
- (let ((b (point-min)))\r\r
- (while (setq b (text-property-any b (point-max) 'invisible t))\r\r
- (delete-region\r\r
- b (or (text-property-not-all b (point-max) 'invisible t)\r\r
- (point-max)))))))\r\r
-\r\r
-(defun gnus-article-text-type-exists-p (type)\r\r
- "Say whether any text of type TYPE exists in the buffer."\r\r
- (text-property-any (point-min) (point-max) 'article-type type))\r\r
-\r\r
-(defsubst gnus-article-header-rank ()\r\r
- "Give the rank of the string HEADER as given by `gnus-sorted-header-list'."\r\r
- (let ((list gnus-sorted-header-list)\r\r
- (i 0))\r\r
- (while list\r\r
- (when (looking-at (car list))\r\r
- (setq list nil))\r\r
- (setq list (cdr list))\r\r
- (incf i))\r\r
- i))\r\r
-\r\r
-(defun article-hide-headers (&optional arg delete)\r\r
- "Toggle whether to hide unwanted headers and possibly sort them as well.\r\r
-If given a negative prefix, always show; if given a positive prefix,\r\r
-always hide."\r\r
- (interactive (gnus-article-hidden-arg))\r\r
- (current-buffer)\r\r
- (if (gnus-article-check-hidden-text 'headers arg)\r\r
- ;; Show boring headers as well.\r\r
- (gnus-article-show-hidden-text 'boring-headers)\r\r
- ;; This function might be inhibited.\r\r
- (unless gnus-inhibit-hiding\r\r
- (save-excursion\r\r
- (save-restriction\r\r
- (let ((buffer-read-only nil)\r\r
- (case-fold-search t)\r\r
- (props (nconc (list 'article-type 'headers)\r\r
- gnus-hidden-properties))\r\r
- (max (1+ (length gnus-sorted-header-list)))\r\r
- (ignored (when (not gnus-visible-headers)\r\r
- (cond ((stringp gnus-ignored-headers)\r\r
- gnus-ignored-headers)\r\r
- ((listp gnus-ignored-headers)\r\r
- (mapconcat 'identity gnus-ignored-headers\r\r
- "\\|")))))\r\r
- (visible\r\r
- (cond ((stringp gnus-visible-headers)\r\r
- gnus-visible-headers)\r\r
- ((and gnus-visible-headers\r\r
- (listp gnus-visible-headers))\r\r
- (mapconcat 'identity gnus-visible-headers "\\|"))))\r\r
- (inhibit-point-motion-hooks t)\r\r
- beg)\r\r
- ;; First we narrow to just the headers.\r\r
- (widen)\r\r
- (goto-char (point-min))\r\r
- ;; Hide any "From " lines at the beginning of (mail) articles.\r\r
- (while (looking-at "From ")\r\r
- (forward-line 1))\r\r
- (unless (bobp)\r\r
- (if delete\r\r
- (delete-region (point-min) (point))\r\r
- (gnus-article-hide-text (point-min) (point) props)))\r\r
- ;; Then treat the rest of the header lines.\r\r
- (narrow-to-region\r\r
- (point)\r\r
- (if (search-forward "\n\n" nil t) ; if there's a body\r\r
- (progn (forward-line -1) (point))\r\r
- (point-max)))\r\r
- ;; Then we use the two regular expressions\r\r
- ;; `gnus-ignored-headers' and `gnus-visible-headers' to\r\r
- ;; select which header lines is to remain visible in the\r\r
- ;; article buffer.\r\r
- (goto-char (point-min))\r\r
- (while (re-search-forward "^[^ \t]*:" nil t)\r\r
- (beginning-of-line)\r\r
- ;; Mark the rank of the header.\r\r
- (put-text-property\r\r
- (point) (1+ (point)) 'message-rank\r\r
- (if (or (and visible (looking-at visible))\r\r
- (and ignored\r\r
- (not (looking-at ignored))))\r\r
- (gnus-article-header-rank)\r\r
- (+ 2 max)))\r\r
- (forward-line 1))\r\r
- (message-sort-headers-1)\r\r
- (when (setq beg (text-property-any\r\r
- (point-min) (point-max) 'message-rank (+ 2 max)))\r\r
- ;; We make the unwanted headers invisible.\r\r
- (if delete\r\r
- (delete-region beg (point-max))\r\r
- ;; Suggested by Sudish Joseph <joseph@cis.ohio-state.edu>.\r\r
- (gnus-article-hide-text-type beg (point-max) 'headers))\r\r
- ;; Work around XEmacs lossage.\r\r
- (put-text-property (point-min) beg 'invisible nil))))))))\r\r
-\r\r
-(defun article-hide-boring-headers (&optional arg)\r\r
- "Toggle hiding of headers that aren't very interesting.\r\r
-If given a negative prefix, always show; if given a positive prefix,\r\r
-always hide."\r\r
- (interactive (gnus-article-hidden-arg))\r\r
- (when (and (not (gnus-article-check-hidden-text 'boring-headers arg))\r\r
- (not gnus-show-all-headers))\r\r
- (save-excursion\r\r
- (save-restriction\r\r
- (let ((buffer-read-only nil)\r\r
- (list gnus-boring-article-headers)\r\r
- (inhibit-point-motion-hooks t)\r\r
- elem)\r\r
- (nnheader-narrow-to-headers)\r\r
- (while list\r\r
- (setq elem (pop list))\r\r
- (goto-char (point-min))\r\r
- (cond\r\r
- ;; Hide empty headers.\r\r
- ((eq elem 'empty)\r\r
- (while (re-search-forward "^[^:]+:[ \t]*\n[^ \t]" nil t)\r\r
- (forward-line -1)\r\r
- (gnus-article-hide-text-type\r\r
- (progn (beginning-of-line) (point))\r\r
- (progn\r\r
- (end-of-line)\r\r
- (if (re-search-forward "^[^ \t]" nil t)\r\r
- (match-beginning 0)\r\r
- (point-max)))\r\r
- 'boring-headers)))\r\r
- ;; Hide boring Newsgroups header.\r\r
- ((eq elem 'newsgroups)\r\r
- (when (equal (gnus-fetch-field "newsgroups")\r\r
- (gnus-group-real-name\r\r
- (if (boundp 'gnus-newsgroup-name)\r\r
- gnus-newsgroup-name\r\r
- "")))\r\r
- (gnus-article-hide-header "newsgroups")))\r\r
- ((eq elem 'followup-to)\r\r
- (when (equal (message-fetch-field "followup-to")\r\r
- (message-fetch-field "newsgroups"))\r\r
- (gnus-article-hide-header "followup-to")))\r\r
- ((eq elem 'reply-to)\r\r
- (let ((from (message-fetch-field "from"))\r\r
- (reply-to (message-fetch-field "reply-to")))\r\r
- (when (and\r\r
- from reply-to\r\r
- (ignore-errors\r\r
- (equal\r\r
- (nth 1 (funcall gnus-extract-address-components from))\r\r
- (nth 1 (funcall gnus-extract-address-components reply-to)))))\r\r
- (gnus-article-hide-header "reply-to"))))\r\r
- ((eq elem 'date)\r\r
- (let ((date (message-fetch-field "date")))\r\r
- (when (and date\r\r
- (< (days-between (current-time-string) date)\r\r
- 4))\r\r
- (gnus-article-hide-header "date"))))\r\r
- ((eq elem 'long-to)\r\r
- (let ((to (message-fetch-field "to")))\r\r
- (when (> (length to) 1024)\r\r
- (gnus-article-hide-header "to"))))\r\r
- ((eq elem 'many-to)\r\r
- (let ((to-count 0))\r\r
- (goto-char (point-min))\r\r
- (while (re-search-forward "^to:" nil t)\r\r
- (setq to-count (1+ to-count)))\r\r
- (when (> to-count 1)\r\r
- (while (> to-count 0)\r\r
- (goto-char (point-min))\r\r
- (save-restriction\r\r
- (re-search-forward "^to:" nil nil to-count)\r\r
- (forward-line -1)\r\r
- (narrow-to-region (point) (point-max))\r\r
- (gnus-article-hide-header "to"))\r\r
- (setq to-count (1- to-count)))))))))))))\r\r
-\r\r
-(defun gnus-article-hide-header (header)\r\r
- (save-excursion\r\r
- (goto-char (point-min))\r\r
- (when (re-search-forward (concat "^" header ":") nil t)\r\r
- (gnus-article-hide-text-type\r\r
- (progn (beginning-of-line) (point))\r\r
- (progn\r\r
- (end-of-line)\r\r
- (if (re-search-forward "^[^ \t]" nil t)\r\r
- (match-beginning 0)\r\r
- (point-max)))\r\r
- 'boring-headers))))\r\r
-\r\r
-(defvar gnus-article-normalized-header-length 40\r\r
- "Length of normalized headers.")\r\r
-\r\r
-(defun article-normalize-headers ()\r\r
- "Make all header lines 40 characters long."\r\r
- (interactive)\r\r
- (let ((buffer-read-only nil)\r\r
- column)\r\r
- (save-excursion\r\r
- (save-restriction\r\r
- (message-narrow-to-head)\r\r
- (while (not (eobp))\r\r
- (cond\r\r
- ((< (setq column (- (gnus-point-at-eol) (point)))\r\r
- gnus-article-normalized-header-length)\r\r
- (end-of-line)\r\r
- (insert (make-string\r\r
- (- gnus-article-normalized-header-length column)\r\r
- ? )))\r\r
- ((> column gnus-article-normalized-header-length)\r\r
- (gnus-put-text-property\r\r
- (progn\r\r
- (forward-char gnus-article-normalized-header-length)\r\r
- (point))\r\r
- (gnus-point-at-eol)\r\r
- 'invisible t))\r\r
- (t\r\r
- ;; Do nothing.\r\r
- ))\r\r
- (forward-line 1))))))\r\r
-\r\r
-(defun article-treat-dumbquotes ()\r\r
- "Translate M******** sm*rtq**t*s into proper text."\r\r
- (interactive)\r\r
- (article-translate-strings gnus-article-dumbquotes-map))\r\r
-\r\r
-(defun article-translate-characters (from to)\r\r
- "Translate all characters in the body of the article according to FROM and TO.\r\r
-FROM is a string of characters to translate from; to is a string of\r\r
-characters to translate to."\r\r
- (save-excursion\r\r
- (when (article-goto-body)\r\r
- (let ((buffer-read-only nil)\r\r
- (x (make-string 225 ?x))\r\r
- (i -1))\r\r
- (while (< (incf i) (length x))\r\r
- (aset x i i))\r\r
- (setq i 0)\r\r
- (while (< i (length from))\r\r
- (aset x (aref from i) (aref to i))\r\r
- (incf i))\r\r
- (translate-region (point) (point-max) x)))))\r\r
-\r\r
-(defun article-translate-strings (map)\r\r
- "Translate all string in the body of the article according to MAP.\r\r
-MAP is an alist where the elements are on the form (\"from\" \"to\")."\r\r
- (save-excursion\r\r
- (when (article-goto-body)\r\r
- (let ((buffer-read-only nil)\r\r
- elem)\r\r
- (while (setq elem (pop map))\r\r
- (save-excursion\r\r
- (while (search-forward (car elem) nil t)\r\r
- (replace-match (cadr elem)))))))))\r\r
-\r\r
-(defun article-treat-overstrike ()\r\r
- "Translate overstrikes into bold text."\r\r
- (interactive)\r\r
- (save-excursion\r\r
- (when (article-goto-body)\r\r
- (let ((buffer-read-only nil))\r\r
- (while (search-forward "\b" nil t)\r\r
- (let ((next (char-after))\r\r
- (previous (char-after (- (point) 2))))\r\r
- ;; We do the boldification/underlining by hiding the\r\r
- ;; overstrikes and putting the proper text property\r\r
- ;; on the letters.\r\r
- (cond\r\r
- ((eq next previous)\r\r
- (gnus-article-hide-text-type (- (point) 2) (point) 'overstrike)\r\r
- (put-text-property (point) (1+ (point)) 'face 'bold))\r\r
- ((eq next ?_)\r\r
- (gnus-article-hide-text-type\r\r
- (1- (point)) (1+ (point)) 'overstrike)\r\r
- (put-text-property\r\r
- (- (point) 2) (1- (point)) 'face 'underline))\r\r
- ((eq previous ?_)\r\r
- (gnus-article-hide-text-type (- (point) 2) (point) 'overstrike)\r\r
- (put-text-property\r\r
- (point) (1+ (point)) 'face 'underline)))))))))\r\r
-\r\r
-(defun article-fill ()\r\r
- "Format too long lines."\r\r
- (interactive)\r\r
- (save-excursion\r\r
- (let ((buffer-read-only nil))\r\r
- (widen)\r\r
- (article-goto-body)\r\r
- (end-of-line 1)\r\r
- (let ((paragraph-start "^[>|#:<;* ]*[ \t]*$")\r\r
- (adaptive-fill-regexp "[ \t]*\\([|#:<;>*]+ *\\)?")\r\r
- (adaptive-fill-mode t))\r\r
- (while (not (eobp))\r\r
- (and (>= (current-column) (min fill-column (window-width)))\r\r
- (/= (preceding-char) ?:)\r\r
- (fill-paragraph nil))\r\r
- (end-of-line 2))))))\r\r
-\r\r
-(defun article-remove-cr ()\r\r
- "Translate CRLF pairs into LF, and then CR into LF.."\r\r
- (interactive)\r\r
- (save-excursion\r\r
- (let ((buffer-read-only nil))\r\r
- (goto-char (point-min))\r\r
- (while (search-forward "\r$" nil t)\r\r
- (replace-match "" t t))\r\r
- (goto-char (point-min))\r\r
- (while (search-forward "\r" nil t)\r\r
- (replace-match "\n" t t)))))\r\r
-\r\r
-(defun article-remove-trailing-blank-lines ()\r\r
- "Remove all trailing blank lines from the article."\r\r
- (interactive)\r\r
- (save-excursion\r\r
- (let ((buffer-read-only nil))\r\r
- (goto-char (point-max))\r\r
- (delete-region\r\r
- (point)\r\r
- (progn\r\r
- (while (and (not (bobp))\r\r
- (looking-at "^[ \t]*$")\r\r
- (not (gnus-annotation-in-region-p\r\r
- (point) (gnus-point-at-eol))))\r\r
- (forward-line -1))\r\r
- (forward-line 1)\r\r
- (point))))))\r\r
-\r\r
-(defun article-display-x-face (&optional force)\r\r
- "Look for an X-Face header and display it if present."\r\r
- (interactive (list 'force))\r\r
- (save-excursion\r\r
- ;; Delete the old process, if any.\r\r
- (when (process-status "article-x-face")\r\r
- (delete-process "article-x-face"))\r\r
- (let ((inhibit-point-motion-hooks t)\r\r
- (case-fold-search t)\r\r
- from last)\r\r
- (save-restriction\r\r
- (nnheader-narrow-to-headers)\r\r
- (setq from (message-fetch-field "from"))\r\r
- (goto-char (point-min))\r\r
- (while (and gnus-article-x-face-command\r\r
- (not last)\r\r
- (or force\r\r
- ;; Check whether this face is censored.\r\r
- (not gnus-article-x-face-too-ugly)\r\r
- (and gnus-article-x-face-too-ugly from\r\r
- (not (string-match gnus-article-x-face-too-ugly\r\r
- from))))\r\r
- ;; Has to be present.\r\r
- (re-search-forward "^X-Face: " nil t))\r\r
- ;; This used to try to do multiple faces (`while' instead of\r\r
- ;; `when' above), but (a) sending multiple EOFs to xv doesn't\r\r
- ;; work (b) it can crash some versions of Emacs (c) are\r\r
- ;; multiple faces really something to encourage?\r\r
- (when (stringp gnus-article-x-face-command)\r\r
- (setq last t))\r\r
- ;; We now have the area of the buffer where the X-Face is stored.\r\r
- (save-excursion\r\r
- (let ((beg (point))\r\r
- (end (1- (re-search-forward "^\\($\\|[^ \t]\\)" nil t))))\r\r
- ;; We display the face.\r\r
- (if (symbolp gnus-article-x-face-command)\r\r
- ;; The command is a lisp function, so we call it.\r\r
- (if (gnus-functionp gnus-article-x-face-command)\r\r
- (funcall gnus-article-x-face-command beg end)\r\r
- (error "%s is not a function" gnus-article-x-face-command))\r\r
- ;; The command is a string, so we interpret the command\r\r
- ;; as a, well, command, and fork it off.\r\r
- (let ((process-connection-type nil))\r\r
- (process-kill-without-query\r\r
- (start-process\r\r
- "article-x-face" nil shell-file-name shell-command-switch\r\r
- gnus-article-x-face-command))\r\r
- (process-send-region "article-x-face" beg end)\r\r
- (process-send-eof "article-x-face"))))))))))\r\r
-\r\r
-(defun article-decode-mime-words ()\r\r
- "Decode all MIME-encoded words in the article."\r\r
- (interactive)\r\r
- (save-excursion\r\r
- (set-buffer gnus-article-buffer)\r\r
- (let ((inhibit-point-motion-hooks t)\r\r
- buffer-read-only\r\r
- (rfc2047-default-charset gnus-newsgroup-default-charset)\r\r
- (mm-charset-iso-8859-1-forced gnus-newsgroup-iso-8859-1-forced))\r\r
- (mail-decode-encoded-word-region (point-min) (point-max)))))\r\r
-\r\r
-(defun article-decode-charset (&optional prompt)\r\r
- "Decode charset-encoded text in the article.\r\r
-If PROMPT (the prefix), prompt for a coding system to use."\r\r
- (interactive "P")\r\r
- (save-excursion\r\r
- (save-restriction\r\r
- (message-narrow-to-head)\r\r
- (let* ((inhibit-point-motion-hooks t)\r\r
- (case-fold-search t)\r\r
- (ct (message-fetch-field "Content-Type" t))\r\r
- (cte (message-fetch-field "Content-Transfer-Encoding" t))\r\r
- (ctl (and ct (condition-case ()\r\r
- (mail-header-parse-content-type ct)\r\r
- (error nil))))\r\r
- (charset (cond\r\r
- (prompt\r\r
- (mm-read-coding-system "Charset to decode: "))\r\r
- (ctl\r\r
- (mail-content-type-get ctl 'charset))))\r\r
- (rfc2047-default-charset gnus-newsgroup-default-charset)\r\r
- (mm-charset-iso-8859-1-forced gnus-newsgroup-iso-8859-1-forced)\r\r
- buffer-read-only)\r\r
- (goto-char (point-max))\r\r
- (widen)\r\r
- (forward-line 1)\r\r
- (narrow-to-region (point) (point-max))\r\r
- (when (and (or (not ctl)\r\r
- (equal (car ctl) "text/plain"))\r\r
- (not (mm-uu-test)))\r\r
- (mm-decode-body\r\r
- charset (and cte (intern (downcase\r\r
- (gnus-strip-whitespace cte))))\r\r
- (car ctl)))))))\r\r
-\r\r
-(defun article-decode-encoded-words ()\r\r
- "Remove encoded-word encoding from headers."\r\r
- (let (buffer-read-only)\r\r
- (let ((charset (save-excursion\r\r
- (set-buffer gnus-summary-buffer)\r\r
- default-mime-charset)))\r\r
- (mime-decode-header-in-buffer charset)\r\r
- )))\r\r
-\r\r
-(defun article-de-quoted-unreadable (&optional force)\r\r
- "Translate a quoted-printable-encoded article.\r\r
-If FORCE, decode the article whether it is marked as quoted-printable\r\r
-or not."\r\r
- (interactive (list 'force))\r\r
- (save-excursion\r\r
- (let ((buffer-read-only nil)\r\r
- (type (gnus-fetch-field "content-transfer-encoding"))\r\r
- (charset\r\r
- (or gnus-newsgroup-default-charset mm-default-coding-system))\r\r
- (mm-charset-iso-8859-1-forced gnus-newsgroup-iso-8859-1-forced))\r\r
- (when (or force\r\r
- (and type (string-match "quoted-printable" (downcase type))))\r\r
- (article-goto-body)\r\r
- (save-restriction\r\r
- (narrow-to-region (point) (point-max))\r\r
- (quoted-printable-decode-region (point-min) (point-max))\r\r
- (when charset\r\r
- (mm-decode-body charset)))))))\r\r
-\r\r
-(defun article-hide-pgp (&optional arg)\r\r
- "Toggle hiding of any PGP headers and signatures in the current article.\r\r
-If given a negative prefix, always show; if given a positive prefix,\r\r
-always hide."\r\r
- (interactive (gnus-article-hidden-arg))\r\r
- (unless (gnus-article-check-hidden-text 'pgp arg)\r\r
- (save-excursion\r\r
- (let ((inhibit-point-motion-hooks t)\r\r
- buffer-read-only beg end)\r\r
- (widen)\r\r
- (goto-char (point-min))\r\r
- ;; Hide the "header".\r\r
- (when (search-forward "\n-----BEGIN PGP SIGNED MESSAGE-----\n" nil t)\r\r
- (delete-region (1+ (match-beginning 0)) (match-end 0))\r\r
- ;; PGP 5 and GNU PG add a `Hash: <>' comment, hide that too\r\r
- (when (looking-at "Hash:.*$")\r\r
- (delete-region (point) (1+ (gnus-point-at-eol))))\r\r
- (setq beg (point))\r\r
- ;; Hide the actual signature.\r\r
- (and (search-forward "\n-----BEGIN PGP SIGNATURE-----\n" nil t)\r\r
- (setq end (1+ (match-beginning 0)))\r\r
- (delete-region\r\r
- end\r\r
- (if (search-forward "\n-----END PGP SIGNATURE-----\n" nil t)\r\r
- (match-end 0)\r\r
- ;; Perhaps we shouldn't hide to the end of the buffer\r\r
- ;; if there is no end to the signature?\r\r
- (point-max))))\r\r
- ;; Hide "- " PGP quotation markers.\r\r
- (when (and beg end)\r\r
- (narrow-to-region beg end)\r\r
- (goto-char (point-min))\r\r
- (while (re-search-forward "^- " nil t)\r\r
- (delete-region\r\r
- (match-beginning 0) (match-end 0)))\r\r
- (widen))\r\r
- (gnus-run-hooks 'gnus-article-hide-pgp-hook))))))\r\r
-\r\r
-(defun article-hide-pem (&optional arg)\r\r
- "Toggle hiding of any PEM headers and signatures in the current article.\r\r
-If given a negative prefix, always show; if given a positive prefix,\r\r
-always hide."\r\r
- (interactive (gnus-article-hidden-arg))\r\r
- (unless (gnus-article-check-hidden-text 'pem arg)\r\r
- (save-excursion\r\r
- (let (buffer-read-only end)\r\r
- (widen)\r\r
- (goto-char (point-min))\r\r
- ;; hide the horrendously ugly "header".\r\r
- (and (search-forward "\n-----BEGIN PRIVACY-ENHANCED MESSAGE-----\n"\r\r
- nil\r\r
- t)\r\r
- (setq end (1+ (match-beginning 0)))\r\r
- (gnus-article-hide-text-type\r\r
- end\r\r
- (if (search-forward "\n\n" nil t)\r\r
- (match-end 0)\r\r
- (point-max))\r\r
- 'pem))\r\r
- ;; hide the trailer as well\r\r
- (and (search-forward "\n-----END PRIVACY-ENHANCED MESSAGE-----\n"\r\r
- nil\r\r
- t)\r\r
- (gnus-article-hide-text-type\r\r
- (match-beginning 0) (match-end 0) 'pem))))))\r\r
-\r\r
-(defun article-hide-signature (&optional arg)\r\r
- "Hide the signature in the current article.\r\r
-If given a negative prefix, always show; if given a positive prefix,\r\r
-always hide."\r\r
- (interactive (gnus-article-hidden-arg))\r\r
- (unless (gnus-article-check-hidden-text 'signature arg)\r\r
- (save-excursion\r\r
- (save-restriction\r\r
- (let ((buffer-read-only nil))\r\r
- (when (gnus-article-narrow-to-signature)\r\r
- (gnus-article-hide-text-type\r\r
- (point-min) (point-max) 'signature)))))))\r\r
-\r\r
-(defun article-strip-leading-blank-lines ()\r\r
- "Remove all blank lines from the beginning of the article."\r\r
- (interactive)\r\r
- (save-excursion\r\r
- (let ((inhibit-point-motion-hooks t)\r\r
- buffer-read-only)\r\r
- (when (article-goto-body)\r\r
- (while (and (not (eobp))\r\r
- (looking-at "[ \t]*$"))\r\r
- (gnus-delete-line))))))\r\r
-\r\r
-(defun article-goto-body ()\r\r
- "Place point at the start of the body." \r\r
- (goto-char (point-min))\r\r
- (if (search-forward "\n\n" nil t)\r\r
- t\r\r
- (goto-char (point-max))\r\r
- nil))\r\r
-\r\r
-(defun article-strip-multiple-blank-lines ()\r\r
- "Replace consecutive blank lines with one empty line."\r\r
- (interactive)\r\r
- (save-excursion\r\r
- (let ((inhibit-point-motion-hooks t)\r\r
- buffer-read-only)\r\r
- ;; First make all blank lines empty.\r\r
- (article-goto-body)\r\r
- (while (re-search-forward "^[ \t]+$" nil t)\r\r
- (unless (gnus-annotation-in-region-p\r\r
- (match-beginning 0) (match-end 0))\r\r
- (replace-match "" nil t)))\r\r
- ;; Then replace multiple empty lines with a single empty line.\r\r
- (article-goto-body)\r\r
- (while (re-search-forward "\n\n\n+" nil t)\r\r
- (unless (gnus-annotation-in-region-p\r\r
- (match-beginning 0) (match-end 0))\r\r
- (replace-match "\n\n" t t))))))\r\r
-\r\r
-(defun article-strip-leading-space ()\r\r
- "Remove all white space from the beginning of the lines in the article."\r\r
- (interactive)\r\r
- (save-excursion\r\r
- (let ((inhibit-point-motion-hooks t)\r\r
- buffer-read-only)\r\r
- (article-goto-body)\r\r
- (while (re-search-forward "^[ \t]+" nil t)\r\r
- (replace-match "" t t)))))\r\r
-\r\r
-(defun article-strip-trailing-space ()\r\r
- "Remove all white space from the end of the lines in the article."\r\r
- (interactive)\r\r
- (save-excursion\r\r
- (let ((inhibit-point-motion-hooks t)\r\r
- buffer-read-only)\r\r
- (article-goto-body)\r\r
- (while (re-search-forward "[ \t]+$" nil t)\r\r
- (replace-match "" t t)))))\r\r
-\r\r
-(defun article-strip-blank-lines ()\r\r
- "Strip leading, trailing and multiple blank lines."\r\r
- (interactive)\r\r
- (article-strip-leading-blank-lines)\r\r
- (article-remove-trailing-blank-lines)\r\r
- (article-strip-multiple-blank-lines))\r\r
-\r\r
-(defun article-strip-all-blank-lines ()\r\r
- "Strip all blank lines."\r\r
- (interactive)\r\r
- (save-excursion\r\r
- (let ((inhibit-point-motion-hooks t)\r\r
- buffer-read-only)\r\r
- (article-goto-body)\r\r
- (while (re-search-forward "^[ \t]*\n" nil t)\r\r
- (replace-match "" t t)))))\r\r
-\r\r
-(defun gnus-article-narrow-to-signature ()\r\r
- "Narrow to the signature; return t if a signature is found, else nil."\r\r
- (widen)\r\r
- (let ((inhibit-point-motion-hooks t))\r\r
- (when (gnus-article-search-signature)\r\r
- (forward-line 1)\r\r
- ;; Check whether we have some limits to what we consider\r\r
- ;; to be a signature.\r\r
- (let ((limits (if (listp gnus-signature-limit) gnus-signature-limit\r\r
- (list gnus-signature-limit)))\r\r
- limit limited)\r\r
- (while (setq limit (pop limits))\r\r
- (if (or (and (integerp limit)\r\r
- (< (- (point-max) (point)) limit))\r\r
- (and (floatp limit)\r\r
- (< (count-lines (point) (point-max)) limit))\r\r
- (and (gnus-functionp limit)\r\r
- (funcall limit))\r\r
- (and (stringp limit)\r\r
- (not (re-search-forward limit nil t))))\r\r
- () ; This limit did not succeed.\r\r
- (setq limited t\r\r
- limits nil)))\r\r
- (unless limited\r\r
- (narrow-to-region (point) (point-max))\r\r
- t)))))\r\r
-\r\r
-(defun gnus-article-search-signature ()\r\r
- "Search the current buffer for the signature separator.\r\r
-Put point at the beginning of the signature separator."\r\r
- (let ((cur (point)))\r\r
- (goto-char (point-max))\r\r
- (if (if (stringp gnus-signature-separator)\r\r
- (re-search-backward gnus-signature-separator nil t)\r\r
- (let ((seps gnus-signature-separator))\r\r
- (while (and seps\r\r
- (not (re-search-backward (car seps) nil t)))\r\r
- (pop seps))\r\r
- seps))\r\r
- t\r\r
- (goto-char cur)\r\r
- nil)))\r\r
-\r\r
-(eval-and-compile\r\r
- (autoload 'w3-display "w3-parse")\r\r
- (autoload 'w3-do-setup "w3" "" t)\r\r
- (autoload 'w3-region "w3-display" "" t))\r\r
-\r\r
-(defun gnus-article-treat-html ()\r\r
- "Render HTML."\r\r
- (interactive)\r\r
- (let ((cbuf (current-buffer)))\r\r
- (set-buffer gnus-article-buffer)\r\r
- (let (buf buffer-read-only b e)\r\r
- (w3-do-setup)\r\r
- (goto-char (point-min))\r\r
- (narrow-to-region\r\r
- (if (search-forward "\n\n" nil t)\r\r
- (setq b (point))\r\r
- (point-max))\r\r
- (setq e (point-max)))\r\r
- (with-temp-buffer\r\r
- (insert-buffer-substring gnus-article-buffer b e)\r\r
- (require 'url)\r\r
- (save-window-excursion\r\r
- (w3-region (point-min) (point-max))\r\r
- (setq buf (buffer-substring-no-properties (point-min) (point-max)))))\r\r
- (when buf\r\r
- (delete-region (point-min) (point-max))\r\r
- (insert buf))\r\r
- (widen)\r\r
- (goto-char (point-min))\r\r
- (set-window-start (get-buffer-window (current-buffer)) (point-min))\r\r
- (set-buffer cbuf))))\r\r
-\r\r
-(defun gnus-article-hidden-arg ()\r\r
- "Return the current prefix arg as a number, or 0 if no prefix."\r\r
- (list (if current-prefix-arg\r\r
- (prefix-numeric-value current-prefix-arg)\r\r
- 0)))\r\r
-\r\r
-(defun gnus-article-check-hidden-text (type arg)\r\r
- "Return nil if hiding is necessary.\r\r
-Arg can be nil or a number. Nil and positive means hide, negative\r\r
-means show, 0 means toggle."\r\r
- (save-excursion\r\r
- (save-restriction\r\r
- (widen)\r\r
- (let ((hide (gnus-article-hidden-text-p type)))\r\r
- (cond\r\r
- ((or (null arg)\r\r
- (> arg 0))\r\r
- nil)\r\r
- ((< arg 0)\r\r
- (gnus-article-show-hidden-text type))\r\r
- (t\r\r
- (if (eq hide 'hidden)\r\r
- (gnus-article-show-hidden-text type)\r\r
- nil)))))))\r\r
-\r\r
-(defun gnus-article-hidden-text-p (type)\r\r
- "Say whether the current buffer contains hidden text of type TYPE."\r\r
- (let ((pos (text-property-any (point-min) (point-max) 'article-type type)))\r\r
- (while (and pos\r\r
- (not (get-text-property pos 'invisible)))\r\r
- (setq pos\r\r
- (text-property-any (1+ pos) (point-max) 'article-type type)))\r\r
- (if pos\r\r
- 'hidden\r\r
- nil)))\r\r
-\r\r
-(defun gnus-article-show-hidden-text (type &optional hide)\r\r
- "Show all hidden text of type TYPE.\r\r
-If HIDE, hide the text instead."\r\r
- (save-excursion\r\r
- (let ((buffer-read-only nil)\r\r
- (inhibit-point-motion-hooks t)\r\r
- (end (point-min))\r\r
- beg)\r\r
- (while (setq beg (text-property-any end (point-max) 'article-type type))\r\r
- (goto-char beg)\r\r
- (setq end (or\r\r
- (text-property-not-all beg (point-max) 'article-type type)\r\r
- (point-max)))\r\r
- (if hide\r\r
- (gnus-article-hide-text beg end gnus-hidden-properties)\r\r
- (gnus-article-unhide-text beg end))\r\r
- (goto-char end))\r\r
- t)))\r\r
-\r\r
-(defconst article-time-units\r\r
- `((year . ,(* 365.25 24 60 60))\r\r
- (week . ,(* 7 24 60 60))\r\r
- (day . ,(* 24 60 60))\r\r
- (hour . ,(* 60 60))\r\r
- (minute . 60)\r\r
- (second . 1))\r\r
- "Mapping from time units to seconds.")\r\r
-\r\r
-(defun article-date-ut (&optional type highlight header)\r\r
- "Convert DATE date to universal time in the current article.\r\r
-If TYPE is `local', convert to local time; if it is `lapsed', output\r\r
-how much time has lapsed since DATE."\r\r
- (interactive (list 'ut t))\r\r
- (let* ((header (or header\r\r
- (mail-header-date gnus-current-headers)\r\r
- (message-fetch-field "date")\r\r
- ""))\r\r
- (date (if (vectorp header) (mail-header-date header)\r\r
- header))\r\r
- (date-regexp "^Date:[ \t]\\|^X-Sent:[ \t]")\r\r
- (inhibit-point-motion-hooks t)\r\r
- bface eface newline)\r\r
- (when (and date (not (string= date "")))\r\r
- (save-excursion\r\r
- (save-restriction\r\r
- (nnheader-narrow-to-headers)\r\r
- (let ((buffer-read-only nil))\r\r
- ;; Delete any old Date headers.\r\r
- (if (re-search-forward date-regexp nil t)\r\r
- (progn\r\r
- (setq bface (get-text-property (gnus-point-at-bol) 'face)\r\r
- eface (get-text-property (1- (gnus-point-at-eol))\r\r
- 'face))\r\r
- (delete-region (progn (beginning-of-line) (point))\r\r
- (progn (end-of-line) (point)))\r\r
- (beginning-of-line))\r\r
- (goto-char (point-max))\r\r
- (setq newline t))\r\r
- (insert (article-make-date-line date type))\r\r
- ;; Do highlighting.\r\r
- (beginning-of-line)\r\r
- (when (looking-at "\\([^:]+\\): *\\(.*\\)$")\r\r
- (put-text-property (match-beginning 1) (1+ (match-end 1))\r\r
- 'face bface)\r\r
- (put-text-property (match-beginning 2) (match-end 2)\r\r
- 'face eface))\r\r
- (when newline\r\r
- (end-of-line)\r\r
- (insert "\n"))))))))\r\r
-\r\r
-(defun article-make-date-line (date type)\r\r
- "Return a DATE line of TYPE."\r\r
- (let ((time (condition-case ()\r\r
- (date-to-time date)\r\r
- (error '(0 0)))))\r\r
- (cond\r\r
- ;; Convert to the local timezone. We have to slap a\r\r
- ;; `condition-case' round the calls to the timezone\r\r
- ;; functions since they aren't particularly resistant to\r\r
- ;; buggy dates.\r\r
- ((eq type 'local)\r\r
- (let ((tz (car (current-time-zone))))\r\r
- (format "Date: %s %s%04d" (current-time-string time)\r\r
- (if (> tz 0) "+" "-") (abs (/ tz 36)))))\r\r
- ;; Convert to Universal Time.\r\r
- ((eq type 'ut)\r\r
- (concat "Date: "\r\r
- (current-time-string\r\r
- (let* ((e (parse-time-string date))\r\r
- (tm (apply 'encode-time e))\r\r
- (ms (car tm))\r\r
- (ls (- (cadr tm) (car (current-time-zone)))))\r\r
- (cond ((< ls 0) (list (1- ms) (+ ls 65536)))\r\r
- ((> ls 65535) (list (1+ ms) (- ls 65536)))\r\r
- (t (list ms ls)))))\r\r
- " UT"))\r\r
- ;; Get the original date from the article.\r\r
- ((eq type 'original)\r\r
- (concat "Date: " (if (string-match "\n+$" date)\r\r
- (substring date 0 (match-beginning 0))\r\r
- date)))\r\r
- ;; Let the user define the format.\r\r
- ((eq type 'user)\r\r
- (if (gnus-functionp gnus-article-time-format)\r\r
- (funcall gnus-article-time-format time)\r\r
- (concat\r\r
- "Date: "\r\r
- (format-time-string gnus-article-time-format time))))\r\r
- ;; ISO 8601.\r\r
- ((eq type 'iso8601)\r\r
- (concat\r\r
- "Date: "\r\r
- (format-time-string "%Y%M%DT%h%m%s" time)))\r\r
- ;; Do an X-Sent lapsed format.\r\r
- ((eq type 'lapsed)\r\r
- ;; If the date is seriously mangled, the timezone functions are\r\r
- ;; liable to bug out, so we ignore all errors.\r\r
- (let* ((now (current-time))\r\r
- (real-time (subtract-time now time))\r\r
- (real-sec (and real-time\r\r
- (+ (* (float (car real-time)) 65536)\r\r
- (cadr real-time))))\r\r
- (sec (and real-time (abs real-sec)))\r\r
- num prev)\r\r
- (cond\r\r
- ((null real-time)\r\r
- "X-Sent: Unknown")\r\r
- ((zerop sec)\r\r
- "X-Sent: Now")\r\r
- (t\r\r
- (concat\r\r
- "X-Sent: "\r\r
- ;; This is a bit convoluted, but basically we go\r\r
- ;; through the time units for years, weeks, etc,\r\r
- ;; and divide things to see whether that results\r\r
- ;; in positive answers.\r\r
- (mapconcat\r\r
- (lambda (unit)\r\r
- (if (zerop (setq num (ffloor (/ sec (cdr unit)))))\r\r
- ;; The (remaining) seconds are too few to\r\r
- ;; be divided into this time unit.\r\r
- ""\r\r
- ;; It's big enough, so we output it.\r\r
- (setq sec (- sec (* num (cdr unit))))\r\r
- (prog1\r\r
- (concat (if prev ", " "") (int-to-string\r\r
- (floor num))\r\r
- " " (symbol-name (car unit))\r\r
- (if (> num 1) "s" ""))\r\r
- (setq prev t))))\r\r
- article-time-units "")\r\r
- ;; If dates are odd, then it might appear like the\r\r
- ;; article was sent in the future.\r\r
- (if (> real-sec 0)\r\r
- " ago"\r\r
- " in the future"))))))\r\r
- (t\r\r
- (error "Unknown conversion type: %s" type)))))\r\r
-\r\r
-(defun article-date-local (&optional highlight)\r\r
- "Convert the current article date to the local timezone."\r\r
- (interactive (list t))\r\r
- (article-date-ut 'local highlight))\r\r
-\r\r
-(defun article-date-original (&optional highlight)\r\r
- "Convert the current article date to what it was originally.\r\r
-This is only useful if you have used some other date conversion\r\r
-function and want to see what the date was before converting."\r\r
- (interactive (list t))\r\r
- (article-date-ut 'original highlight))\r\r
-\r\r
-(defun article-date-lapsed (&optional highlight)\r\r
- "Convert the current article date to time lapsed since it was sent."\r\r
- (interactive (list t))\r\r
- (article-date-ut 'lapsed highlight))\r\r
-\r\r
-(defun article-update-date-lapsed ()\r\r
- "Function to be run from a timer to update the lapsed time line."\r\r
- (let (deactivate-mark)\r\r
- (save-excursion\r\r
- (ignore-errors\r\r
- (walk-windows\r\r
- (lambda (w)\r\r
- (set-buffer (window-buffer w))\r\r
- (when (eq major-mode 'gnus-article-mode)\r\r
- (goto-char (point-min))\r\r
- (when (re-search-forward "^X-Sent:" nil t)\r\r
- (article-date-lapsed t)))))))))\r\r
-\r\r
-(defun gnus-start-date-timer (&optional n)\r\r
- "Start a timer to update the X-Sent header in the article buffers.\r\r
-The numerical prefix says how frequently (in seconds) the function\r\r
-is to run."\r\r
- (interactive "p")\r\r
- (unless n\r\r
- (setq n 1))\r\r
- (gnus-stop-date-timer)\r\r
- (setq article-lapsed-timer\r\r
- (nnheader-run-at-time 1 n 'article-update-date-lapsed)))\r\r
-\r\r
-(defun gnus-stop-date-timer ()\r\r
- "Stop the X-Sent timer."\r\r
- (interactive)\r\r
- (when article-lapsed-timer\r\r
- (nnheader-cancel-timer article-lapsed-timer)\r\r
- (setq article-lapsed-timer nil)))\r\r
-\r\r
-(defun article-date-user (&optional highlight)\r\r
- "Convert the current article date to the user-defined format.\r\r
-This format is defined by the `gnus-article-time-format' variable."\r\r
- (interactive (list t))\r\r
- (article-date-ut 'user highlight))\r\r
-\r\r
-(defun article-date-iso8601 (&optional highlight)\r\r
- "Convert the current article date to ISO8601."\r\r
- (interactive (list t))\r\r
- (article-date-ut 'iso8601 highlight))\r\r
-\r\r
-(defun article-show-all ()\r\r
- "Show all hidden text in the article buffer."\r\r
- (interactive)\r\r
- (save-excursion\r\r
- (let ((buffer-read-only nil))\r\r
- (gnus-article-unhide-text (point-min) (point-max)))))\r\r
-\r\r
-(defun article-emphasize (&optional arg)\r\r
- "Emphasize text according to `gnus-emphasis-alist'."\r\r
- (interactive (gnus-article-hidden-arg))\r\r
- (unless (gnus-article-check-hidden-text 'emphasis arg)\r\r
- (save-excursion\r\r
- (let ((alist gnus-emphasis-alist)\r\r
- (buffer-read-only nil)\r\r
- (props (append '(article-type emphasis)\r\r
- gnus-hidden-properties))\r\r
- regexp elem beg invisible visible face)\r\r
- (article-goto-body)\r\r
- (setq beg (point))\r\r
- (while (setq elem (pop alist))\r\r
- (goto-char beg)\r\r
- (setq regexp (car elem)\r\r
- invisible (nth 1 elem)\r\r
- visible (nth 2 elem)\r\r
- face (nth 3 elem))\r\r
- (while (re-search-forward regexp nil t)\r\r
- (when (and (match-beginning visible) (match-beginning invisible))\r\r
- (gnus-article-hide-text\r\r
- (match-beginning invisible) (match-end invisible) props)\r\r
- (gnus-article-unhide-text-type\r\r
- (match-beginning visible) (match-end visible) 'emphasis)\r\r
- (gnus-put-text-property-excluding-newlines\r\r
- (match-beginning visible) (match-end visible) 'face face)\r\r
- (goto-char (match-end invisible)))))))))\r\r
-\r\r
-(defvar gnus-summary-article-menu)\r\r
-(defvar gnus-summary-post-menu)\r\r
-\r\r
-;;; Saving functions.\r\r
-\r\r
-(defun gnus-article-save (save-buffer file &optional num)\r\r
- "Save the currently selected article."\r\r
- (unless gnus-save-all-headers\r\r
- ;; Remove headers according to `gnus-saved-headers'.\r\r
- (let ((gnus-visible-headers\r\r
- (or gnus-saved-headers gnus-visible-headers))\r\r
- (gnus-article-buffer save-buffer))\r\r
- (save-excursion\r\r
- (set-buffer save-buffer)\r\r
- (article-hide-headers 1 t))))\r\r
- (save-window-excursion\r\r
- (if (not gnus-default-article-saver)\r\r
- (error "No default saver is defined")\r\r
- ;; !!! Magic! The saving functions all save\r\r
- ;; `gnus-save-article-buffer' (or so they think), but we\r\r
- ;; bind that variable to our save-buffer.\r\r
- (set-buffer gnus-article-buffer)\r\r
- (let* ((gnus-save-article-buffer save-buffer)\r\r
- (filename\r\r
- (cond\r\r
- ((not gnus-prompt-before-saving) 'default)\r\r
- ((eq gnus-prompt-before-saving 'always) nil)\r\r
- (t file)))\r\r
- (gnus-number-of-articles-to-be-saved\r\r
- (when (eq gnus-prompt-before-saving t)\r\r
- num))) ; Magic\r\r
- (set-buffer gnus-article-current-summary)\r\r
- (funcall gnus-default-article-saver filename)))))\r\r
-\r\r
-(defun gnus-read-save-file-name (prompt &optional filename\r\r
- function group headers variable)\r\r
- (let ((default-name\r\r
- (funcall function group headers (symbol-value variable)))\r\r
- result)\r\r
- (setq\r\r
- result\r\r
- (cond\r\r
- ((eq filename 'default)\r\r
- default-name)\r\r
- ((eq filename t)\r\r
- default-name)\r\r
- (filename filename)\r\r
- (t\r\r
- (let* ((split-name (gnus-get-split-value gnus-split-methods))\r\r
- (prompt\r\r
- (format prompt\r\r
- (if (and gnus-number-of-articles-to-be-saved\r\r
- (> gnus-number-of-articles-to-be-saved 1))\r\r
- (format "these %d articles"\r\r
- gnus-number-of-articles-to-be-saved)\r\r
- "this article")))\r\r
- (file\r\r
- ;; Let the split methods have their say.\r\r
- (cond\r\r
- ;; No split name was found.\r\r
- ((null split-name)\r\r
- (read-file-name\r\r
- (concat prompt " (default "\r\r
- (file-name-nondirectory default-name) ") ")\r\r
- (file-name-directory default-name)\r\r
- default-name))\r\r
- ;; A single group name is returned.\r\r
- ((stringp split-name)\r\r
- (setq default-name\r\r
- (funcall function split-name headers\r\r
- (symbol-value variable)))\r\r
- (read-file-name\r\r
- (concat prompt " (default "\r\r
- (file-name-nondirectory default-name) ") ")\r\r
- (file-name-directory default-name)\r\r
- default-name))\r\r
- ;; A single split name was found\r\r
- ((= 1 (length split-name))\r\r
- (let* ((name (expand-file-name\r\r
- (car split-name) gnus-article-save-directory))\r\r
- (dir (cond ((file-directory-p name)\r\r
- (file-name-as-directory name))\r\r
- ((file-exists-p name) name)\r\r
- (t gnus-article-save-directory))))\r\r
- (read-file-name\r\r
- (concat prompt " (default " name ") ")\r\r
- dir name)))\r\r
- ;; A list of splits was found.\r\r
- (t\r\r
- (setq split-name (nreverse split-name))\r\r
- (let (result)\r\r
- (let ((file-name-history\r\r
- (nconc split-name file-name-history)))\r\r
- (setq result\r\r
- (expand-file-name\r\r
- (read-file-name\r\r
- (concat prompt " (`M-p' for defaults) ")\r\r
- gnus-article-save-directory\r\r
- (car split-name))\r\r
- gnus-article-save-directory)))\r\r
- (car (push result file-name-history)))))))\r\r
- ;; Create the directory.\r\r
- (gnus-make-directory (file-name-directory file))\r\r
- ;; If we have read a directory, we append the default file name.\r\r
- (when (file-directory-p file)\r\r
- (setq file (concat (file-name-as-directory file)\r\r
- (file-name-nondirectory default-name))))\r\r
- ;; Possibly translate some characters.\r\r
- (nnheader-translate-file-chars file)))))\r\r
- (gnus-make-directory (file-name-directory result))\r\r
- (set variable result)))\r\r
-\r\r
-(defun gnus-article-archive-name (group)\r\r
- "Return the first instance of an \"Archive-name\" in the current buffer."\r\r
- (let ((case-fold-search t))\r\r
- (when (re-search-forward "archive-name: *\\([^ \n\t]+\\)[ \t]*$" nil t)\r\r
- (nnheader-concat gnus-article-save-directory\r\r
- (match-string 1)))))\r\r
-\r\r
-(defun gnus-article-nndoc-name (group)\r\r
- "If GROUP is an nndoc group, return the name of the parent group."\r\r
- (when (eq (car (gnus-find-method-for-group group)) 'nndoc)\r\r
- (gnus-group-get-parameter group 'save-article-group)))\r\r
-\r\r
-(defun gnus-summary-save-in-rmail (&optional filename)\r\r
- "Append this article to Rmail file.\r\r
-Optional argument FILENAME specifies file name.\r\r
-Directory to save to is default to `gnus-article-save-directory'."\r\r
- (setq filename (gnus-read-save-file-name\r\r
- "Save %s in rmail file:" filename\r\r
- gnus-rmail-save-name gnus-newsgroup-name\r\r
- gnus-current-headers 'gnus-newsgroup-last-rmail))\r\r
- (gnus-eval-in-buffer-window gnus-save-article-buffer\r\r
- (save-excursion\r\r
- (save-restriction\r\r
- (widen)\r\r
- (gnus-output-to-rmail filename))))\r\r
- filename)\r\r
-\r\r
-(defun gnus-summary-save-in-mail (&optional filename)\r\r
- "Append this article to Unix mail file.\r\r
-Optional argument FILENAME specifies file name.\r\r
-Directory to save to is default to `gnus-article-save-directory'."\r\r
- (setq filename (gnus-read-save-file-name\r\r
- "Save %s in Unix mail file:" filename\r\r
- gnus-mail-save-name gnus-newsgroup-name\r\r
- gnus-current-headers 'gnus-newsgroup-last-mail))\r\r
- (gnus-eval-in-buffer-window gnus-save-article-buffer\r\r
- (save-excursion\r\r
- (save-restriction\r\r
- (widen)\r\r
- (if (and (file-readable-p filename)\r\r
- (mail-file-babyl-p filename))\r\r
- (rmail-output-to-rmail-file filename t)\r\r
- (gnus-output-to-mail filename)))))\r\r
- filename)\r\r
-\r\r
-(defun gnus-summary-save-in-file (&optional filename overwrite)\r\r
- "Append this article to file.\r\r
-Optional argument FILENAME specifies file name.\r\r
-Directory to save to is default to `gnus-article-save-directory'."\r\r
- (setq filename (gnus-read-save-file-name\r\r
- "Save %s in file:" filename\r\r
- gnus-file-save-name gnus-newsgroup-name\r\r
- gnus-current-headers 'gnus-newsgroup-last-file))\r\r
- (gnus-eval-in-buffer-window gnus-save-article-buffer\r\r
- (save-excursion\r\r
- (save-restriction\r\r
- (widen)\r\r
- (when (and overwrite\r\r
- (file-exists-p filename))\r\r
- (delete-file filename))\r\r
- (gnus-output-to-file filename))))\r\r
- filename)\r\r
-\r\r
-(defun gnus-summary-write-to-file (&optional filename)\r\r
- "Write this article to a file.\r\r
-Optional argument FILENAME specifies file name.\r\r
-The directory to save in defaults to `gnus-article-save-directory'."\r\r
- (gnus-summary-save-in-file nil t))\r\r
-\r\r
-(defun gnus-summary-save-body-in-file (&optional filename)\r\r
- "Append this article body to a file.\r\r
-Optional argument FILENAME specifies file name.\r\r
-The directory to save in defaults to `gnus-article-save-directory'."\r\r
- (setq filename (gnus-read-save-file-name\r\r
- "Save %s body in file:" filename\r\r
- gnus-file-save-name gnus-newsgroup-name\r\r
- gnus-current-headers 'gnus-newsgroup-last-file))\r\r
- (gnus-eval-in-buffer-window gnus-save-article-buffer\r\r
- (save-excursion\r\r
- (save-restriction\r\r
- (widen)\r\r
- (when (article-goto-body)\r\r
- (narrow-to-region (point) (point-max)))\r\r
- (gnus-output-to-file filename))))\r\r
- filename)\r\r
-\r\r
-(defun gnus-summary-save-in-pipe (&optional command)\r\r
- "Pipe this article to subprocess."\r\r
- (setq command\r\r
- (cond ((and (eq command 'default)\r\r
- gnus-last-shell-command)\r\r
- gnus-last-shell-command)\r\r
- (command command)\r\r
- (t (read-string\r\r
- (format\r\r
- "Shell command on %s: "\r\r
- (if (and gnus-number-of-articles-to-be-saved\r\r
- (> gnus-number-of-articles-to-be-saved 1))\r\r
- (format "these %d articles"\r\r
- gnus-number-of-articles-to-be-saved)\r\r
- "this article"))\r\r
- gnus-last-shell-command))))\r\r
- (when (string-equal command "")\r\r
- (setq command gnus-last-shell-command))\r\r
- (gnus-eval-in-buffer-window gnus-article-buffer\r\r
- (save-restriction\r\r
- (widen)\r\r
- (shell-command-on-region (point-min) (point-max) command nil)))\r\r
- (setq gnus-last-shell-command command))\r\r
-\r\r
-;;; Article file names when saving.\r\r
-\r\r
-(defun gnus-capitalize-newsgroup (newsgroup)\r\r
- "Capitalize NEWSGROUP name."\r\r
- (when (not (zerop (length newsgroup)))\r\r
- (concat (char-to-string (upcase (aref newsgroup 0)))\r\r
- (substring newsgroup 1))))\r\r
-\r\r
-(defun gnus-Numeric-save-name (newsgroup headers &optional last-file)\r\r
- "Generate file name from NEWSGROUP, HEADERS, and optional LAST-FILE.\r\r
-If variable `gnus-use-long-file-name' is non-nil, it is ~/News/News.group/num.\r\r
-Otherwise, it is like ~/News/news/group/num."\r\r
- (let ((default\r\r
- (expand-file-name\r\r
- (concat (if (gnus-use-long-file-name 'not-save)\r\r
- (gnus-capitalize-newsgroup newsgroup)\r\r
- (gnus-newsgroup-directory-form newsgroup))\r\r
- "/" (int-to-string (mail-header-number headers)))\r\r
- gnus-article-save-directory)))\r\r
- (if (and last-file\r\r
- (string-equal (file-name-directory default)\r\r
- (file-name-directory last-file))\r\r
- (string-match "^[0-9]+$" (file-name-nondirectory last-file)))\r\r
- default\r\r
- (or last-file default))))\r\r
-\r\r
-(defun gnus-numeric-save-name (newsgroup headers &optional last-file)\r\r
- "Generate file name from NEWSGROUP, HEADERS, and optional LAST-FILE.\r\r
-If variable `gnus-use-long-file-name' is non-nil, it is\r\r
-~/News/news.group/num. Otherwise, it is like ~/News/news/group/num."\r\r
- (let ((default\r\r
- (expand-file-name\r\r
- (concat (if (gnus-use-long-file-name 'not-save)\r\r
- newsgroup\r\r
- (gnus-newsgroup-directory-form newsgroup))\r\r
- "/" (int-to-string (mail-header-number headers)))\r\r
- gnus-article-save-directory)))\r\r
- (if (and last-file\r\r
- (string-equal (file-name-directory default)\r\r
- (file-name-directory last-file))\r\r
- (string-match "^[0-9]+$" (file-name-nondirectory last-file)))\r\r
- default\r\r
- (or last-file default))))\r\r
-\r\r
-(defun gnus-Plain-save-name (newsgroup headers &optional last-file)\r\r
- "Generate file name from NEWSGROUP, HEADERS, and optional LAST-FILE.\r\r
-If variable `gnus-use-long-file-name' is non-nil, it is\r\r
-~/News/News.group. Otherwise, it is like ~/News/news/group/news."\r\r
- (or last-file\r\r
- (expand-file-name\r\r
- (if (gnus-use-long-file-name 'not-save)\r\r
- (gnus-capitalize-newsgroup newsgroup)\r\r
- (concat (gnus-newsgroup-directory-form newsgroup) "/news"))\r\r
- gnus-article-save-directory)))\r\r
-\r\r
-(defun gnus-plain-save-name (newsgroup headers &optional last-file)\r\r
- "Generate file name from NEWSGROUP, HEADERS, and optional LAST-FILE.\r\r
-If variable `gnus-use-long-file-name' is non-nil, it is\r\r
-~/News/news.group. Otherwise, it is like ~/News/news/group/news."\r\r
- (or last-file\r\r
- (expand-file-name\r\r
- (if (gnus-use-long-file-name 'not-save)\r\r
- newsgroup\r\r
- (concat (gnus-newsgroup-directory-form newsgroup) "/news"))\r\r
- gnus-article-save-directory)))\r\r
-\r\r
-(eval-and-compile\r\r
- (mapcar\r\r
- (lambda (func)\r\r
- (let (afunc gfunc)\r\r
- (if (consp func)\r\r
- (setq afunc (car func)\r\r
- gfunc (cdr func))\r\r
- (setq afunc func\r\r
- gfunc (intern (format "gnus-%s" func))))\r\r
- (fset gfunc\r\r
- (if (not (fboundp afunc))\r\r
- nil\r\r
- `(lambda (&optional interactive &rest args)\r\r
- ,(documentation afunc t)\r\r
- (interactive (list t))\r\r
- (save-excursion\r\r
- (set-buffer gnus-article-buffer)\r\r
- (if interactive\r\r
- (call-interactively ',afunc)\r\r
- (apply ',afunc args))))))))\r\r
- '(article-hide-headers\r\r
- article-hide-boring-headers\r\r
- article-treat-overstrike\r\r
- (article-fill . gnus-article-word-wrap)\r\r
- article-remove-cr\r\r
- article-display-x-face\r\r
- article-de-quoted-unreadable\r\r
- article-mime-decode-quoted-printable\r\r
- article-hide-pgp\r\r
- article-hide-pem\r\r
- article-hide-signature\r\r
- article-remove-trailing-blank-lines\r\r
- article-strip-leading-blank-lines\r\r
- article-strip-multiple-blank-lines\r\r
- article-strip-leading-space\r\r
- article-strip-trailing-space\r\r
- article-strip-blank-lines\r\r
- article-strip-all-blank-lines\r\r
- article-date-local\r\r
- article-date-iso8601\r\r
- article-date-original\r\r
- article-date-ut\r\r
- article-decode-mime-words\r\r
- article-decode-charset\r\r
- article-decode-encoded-words\r\r
- article-date-user\r\r
- article-date-lapsed\r\r
- article-emphasize\r\r
- article-treat-dumbquotes\r\r
- article-normalize-headers\r\r
- (article-show-all . gnus-article-show-all-headers))))\r\r
-\f\r\r
-;;;\r\r
-;;; Gnus article mode\r\r
-;;;\r\r
-\r\r
-(put 'gnus-article-mode 'mode-class 'special)\r\r
-\r\r
-(gnus-define-keys gnus-article-mode-map\r\r
- " " gnus-article-goto-next-page\r\r
- "\177" gnus-article-goto-prev-page\r\r
- [delete] gnus-article-goto-prev-page\r\r
- "\C-c^" gnus-article-refer-article\r\r
- "h" gnus-article-show-summary\r\r
- "s" gnus-article-show-summary\r\r
- "\C-c\C-m" gnus-article-mail\r\r
- "?" gnus-article-describe-briefly\r\r
- gnus-mouse-2 gnus-article-push-button\r\r
- "\r" gnus-article-press-button\r\r
- "\t" gnus-article-next-button\r\r
- "\M-\t" gnus-article-prev-button\r\r
- "e" gnus-article-edit\r\r
- "<" beginning-of-buffer\r\r
- ">" end-of-buffer\r\r
- "\C-c\C-i" gnus-info-find-node\r\r
- "\C-c\C-b" gnus-bug\r\r
-\r\r
- "\C-d" gnus-article-read-summary-keys\r\r
- "\M-*" gnus-article-read-summary-keys\r\r
- "\M-#" gnus-article-read-summary-keys\r\r
- "\M-^" gnus-article-read-summary-keys\r\r
- "\M-g" gnus-article-read-summary-keys)\r\r
-\r\r
-(substitute-key-definition\r\r
- 'undefined 'gnus-article-read-summary-keys gnus-article-mode-map)\r\r
-\r\r
-(defun gnus-article-make-menu-bar ()\r\r
- (gnus-turn-off-edit-menu 'article)\r\r
- (unless (boundp 'gnus-article-article-menu)\r\r
- (easy-menu-define\r\r
- gnus-article-article-menu gnus-article-mode-map ""\r\r
- '("Article"\r\r
- ["Scroll forwards" gnus-article-goto-next-page t]\r\r
- ["Scroll backwards" gnus-article-goto-prev-page t]\r\r
- ["Show summary" gnus-article-show-summary t]\r\r
- ["Fetch Message-ID at point" gnus-article-refer-article t]\r\r
- ["Mail to address at point" gnus-article-mail t]\r\r
- ["Send a bug report" gnus-bug t]))\r\r
-\r\r
- (easy-menu-define\r\r
- gnus-article-treatment-menu gnus-article-mode-map ""\r\r
- '("Treatment"\r\r
- ["Hide headers" gnus-article-hide-headers t]\r\r
- ["Hide signature" gnus-article-hide-signature t]\r\r
- ["Hide citation" gnus-article-hide-citation t]\r\r
- ["Treat overstrike" gnus-article-treat-overstrike t]\r\r
- ["Remove carriage return" gnus-article-remove-cr t]))\r\r
-\r\r
- ;; Note "Commands" menu is defined in gnus-sum.el for consistency\r\r
-\r\r
- (when (boundp 'gnus-summary-post-menu)\r\r
- (define-key gnus-article-mode-map [menu-bar post]\r\r
- (cons "Post" gnus-summary-post-menu)))\r\r
-\r\r
- (gnus-run-hooks 'gnus-article-menu-hook)))\r\r
-\r\r
-(defun gnus-article-mode ()\r\r
- "Major mode for displaying an article.\r\r
-\r\r
-All normal editing commands are switched off.\r\r
-\r\r
-The following commands are available in addition to all summary mode\r\r
-commands:\r\r
-\\<gnus-article-mode-map>\r\r
-\\[gnus-article-next-page]\t Scroll the article one page forwards\r\r
-\\[gnus-article-prev-page]\t Scroll the article one page backwards\r\r
-\\[gnus-article-refer-article]\t Go to the article referred to by an article id near point\r\r
-\\[gnus-article-show-summary]\t Display the summary buffer\r\r
-\\[gnus-article-mail]\t Send a reply to the address near point\r\r
-\\[gnus-article-describe-briefly]\t Describe the current mode briefly\r\r
-\\[gnus-info-find-node]\t Go to the Gnus info node"\r\r
- (interactive)\r\r
- (when (gnus-visual-p 'article-menu 'menu)\r\r
- (gnus-article-make-menu-bar))\r\r
- (gnus-simplify-mode-line)\r\r
- (setq mode-name "Article")\r\r
- (setq major-mode 'gnus-article-mode)\r\r
- (make-local-variable 'minor-mode-alist)\r\r
- (unless (assq 'gnus-show-mime minor-mode-alist)\r\r
- (push (list 'gnus-show-mime " MIME") minor-mode-alist))\r\r
- (use-local-map gnus-article-mode-map)\r\r
- (gnus-update-format-specifications nil 'article-mode)\r\r
- (set (make-local-variable 'page-delimiter) gnus-page-delimiter)\r\r
- (make-local-variable 'gnus-page-broken)\r\r
- (make-local-variable 'gnus-button-marker-list)\r\r
- (make-local-variable 'gnus-article-current-summary)\r\r
- (make-local-variable 'gnus-article-mime-handles)\r\r
- (make-local-variable 'gnus-article-decoded-p)\r\r
- (make-local-variable 'gnus-article-mime-handle-alist)\r\r
- (gnus-set-default-directory)\r\r
- (buffer-disable-undo)\r\r
- (setq buffer-read-only t)\r\r
- (set-syntax-table gnus-article-mode-syntax-table)\r\r
- (gnus-run-hooks 'gnus-article-mode-hook))\r\r
-\r\r
-(defun gnus-article-setup-buffer ()\r\r
- "Initialize the article buffer."\r\r
- (let* ((name (if gnus-single-article-buffer "*Article*"\r\r
- (concat "*Article " gnus-newsgroup-name "*")))\r\r
- (original\r\r
- (progn (string-match "\\*Article" name)\r\r
- (concat " *Original Article"\r\r
- (substring name (match-end 0))))))\r\r
- (setq gnus-article-buffer name)\r\r
- (setq gnus-original-article-buffer original)\r\r
- (setq gnus-article-mime-handle-alist nil)\r\r
- ;; This might be a variable local to the summary buffer.\r\r
- (unless gnus-single-article-buffer\r\r
- (save-excursion\r\r
- (set-buffer gnus-summary-buffer)\r\r
- (setq gnus-article-buffer name)\r\r
- (setq gnus-original-article-buffer original)\r\r
- (gnus-set-global-variables)))\r\r
- ;; Init original article buffer.\r\r
- (save-excursion\r\r
- (set-buffer (gnus-get-buffer-create gnus-original-article-buffer))\r\r
- (setq major-mode 'gnus-original-article-mode)\r\r
- (make-local-variable 'gnus-original-article))\r\r
- (if (get-buffer name)\r\r
- (save-excursion\r\r
- (set-buffer name)\r\r
- (buffer-disable-undo)\r\r
- (setq buffer-read-only t)\r\r
- (unless (eq major-mode 'gnus-article-mode)\r\r
- (gnus-article-mode))\r\r
- (current-buffer))\r\r
- (save-excursion\r\r
- (set-buffer (gnus-get-buffer-create name))\r\r
- (gnus-article-mode)\r\r
- (make-local-variable 'gnus-summary-buffer)\r\r
- (gnus-summary-set-local-parameters gnus-newsgroup-name)\r\r
- (current-buffer)))))\r\r
-\r\r
-;; Set article window start at LINE, where LINE is the number of lines\r\r
-;; from the head of the article.\r\r
-(defun gnus-article-set-window-start (&optional line)\r\r
- (set-window-start\r\r
- (get-buffer-window gnus-article-buffer t)\r\r
- (save-excursion\r\r
- (set-buffer gnus-article-buffer)\r\r
- (goto-char (point-min))\r\r
- (if (not line)\r\r
- (point-min)\r\r
- (gnus-message 6 "Moved to bookmark")\r\r
- (search-forward "\n\n" nil t)\r\r
- (forward-line line)\r\r
- (point)))))\r\r
-\r\r
-;;; @@ article filters\r\r
-;;;\r\r
-\r\r
-(defun gnus-article-display-mime-message ()\r\r
- "Article display method for MIME message."\r\r
- ;; called from `gnus-original-article-buffer'.\r\r
- (let ((charset (with-current-buffer gnus-summary-buffer\r\r
- default-mime-charset)))\r\r
- (make-local-variable 'default-mime-charset)\r\r
- (setq default-mime-charset charset)\r\r
- (mime-display-message mime-message-structure\r\r
- gnus-article-buffer nil gnus-article-mode-map)\r\r
- (make-local-variable 'default-mime-charset)\r\r
- (setq default-mime-charset charset)\r\r
- )\r\r
- ;; `mime-display-message' changes current buffer to `gnus-article-buffer'.\r\r
- (make-local-variable 'mime-button-mother-dispatcher)\r\r
- (setq mime-button-mother-dispatcher\r\r
- (function gnus-article-push-button))\r\r
- (run-hooks 'gnus-mime-article-prepare-hook))\r\r
-\r\r
-(defun gnus-article-display-traditional-message ()\r\r
- "Article display method for traditional message."\r\r
- (set-buffer gnus-article-buffer)\r\r
- (let (buffer-read-only)\r\r
- (erase-buffer)\r\r
- (insert-buffer-substring gnus-original-article-buffer)))\r\r
-\r\r
-(defun gnus-article-make-full-mail-header (&optional number charset)\r\r
- "Create a new mail header structure in a raw article buffer."\r\r
- (unless (and number charset)\r\r
- (save-current-buffer\r\r
- (set-buffer gnus-summary-buffer)\r\r
- (unless number\r\r
- (setq number (or (cdr gnus-article-current) 0)))\r\r
- (unless charset\r\r
- (setq charset (or default-mime-charset 'x-ctext)))))\r\r
- (goto-char (point-min))\r\r
- (let ((header-end (if (search-forward "\n\n" nil t)\r\r
- (1- (point))\r\r
- (goto-char (point-max))))\r\r
- (chars (- (point-max) (point)))\r\r
- (lines (count-lines (point) (point-max)))\r\r
- (default-mime-charset charset)\r\r
- xref)\r\r
- (narrow-to-region (point-min) header-end)\r\r
- (setq xref (std11-fetch-field "xref"))\r\r
- (prog1\r\r
- (make-full-mail-header\r\r
- number\r\r
- (std11-fetch-field "subject")\r\r
- (std11-fetch-field "from")\r\r
- (std11-fetch-field "date")\r\r
- (std11-fetch-field "message-id")\r\r
- (std11-fetch-field "references")\r\r
- chars\r\r
- lines\r\r
- (when xref (concat "Xref: " xref)))\r\r
- (widen))))\r\r
-\r\r
-(defun gnus-article-prepare (article &optional all-headers header)\r\r
- "Prepare ARTICLE in article mode buffer.\r\r
-ARTICLE should either be an article number or a Message-ID.\r\r
-If ARTICLE is an id, HEADER should be the article headers.\r\r
-If ALL-HEADERS is non-nil, no headers are hidden."\r\r
- (save-excursion\r\r
- ;; Make sure we start in a summary buffer.\r\r
- (unless (eq major-mode 'gnus-summary-mode)\r\r
- (set-buffer gnus-summary-buffer))\r\r
- (setq gnus-summary-buffer (current-buffer))\r\r
- (let* ((gnus-article (if header (mail-header-number header) article))\r\r
- (summary-buffer (current-buffer))\r\r
- (gnus-tmp-internal-hook gnus-article-internal-prepare-hook)\r\r
- (group gnus-newsgroup-name)\r\r
- result)\r\r
- (save-excursion\r\r
- (gnus-article-setup-buffer)\r\r
- (set-buffer gnus-original-article-buffer)\r\r
- ;; Deactivate active regions.\r\r
- (when (and (boundp 'transient-mark-mode)\r\r
- transient-mark-mode)\r\r
- (setq mark-active nil))\r\r
- (if (not (setq result (let ((buffer-read-only nil))\r\r
- (gnus-request-article-this-buffer\r\r
- article group))))\r\r
- ;; There is no such article.\r\r
- (save-excursion\r\r
- (when (and (numberp article)\r\r
- (not (memq article gnus-newsgroup-sparse)))\r\r
- (setq gnus-article-current\r\r
- (cons gnus-newsgroup-name article))\r\r
- (set-buffer gnus-summary-buffer)\r\r
- (setq gnus-current-article article)\r\r
- (if (eq (gnus-article-mark article) gnus-undownloaded-mark)\r\r
- (progn\r\r
- (gnus-summary-set-agent-mark article)\r\r
- (message "Message marked for downloading"))\r\r
- (gnus-summary-mark-article article gnus-canceled-mark)\r\r
- (unless (memq article gnus-newsgroup-sparse)\r\r
- (gnus-error 1\r\r
- "No such article (may have expired or been canceled)")))))\r\r
- (if (or (eq result 'pseudo)\r\r
- (eq result 'nneething))\r\r
- (progn\r\r
- (save-excursion\r\r
- (set-buffer summary-buffer)\r\r
- (push article gnus-newsgroup-history)\r\r
- (setq gnus-last-article gnus-current-article\r\r
- gnus-current-article 0\r\r
- gnus-current-headers nil\r\r
- gnus-article-current nil)\r\r
- (if (eq result 'nneething)\r\r
- (gnus-configure-windows 'summary)\r\r
- (gnus-configure-windows 'article))\r\r
- (gnus-set-global-variables))\r\r
- (let ((gnus-article-mime-handle-alist-1\r\r
- gnus-article-mime-handle-alist))\r\r
- (gnus-set-mode-line 'article)))\r\r
- ;; The result from the `request' was an actual article -\r\r
- ;; or at least some text that is now displayed in the\r\r
- ;; article buffer.\r\r
- (when (and (numberp article)\r\r
- (not (eq article gnus-current-article)))\r\r
- ;; Seems like a new article has been selected.\r\r
- ;; `gnus-current-article' must be an article number.\r\r
- (save-excursion\r\r
- (set-buffer summary-buffer)\r\r
- (push article gnus-newsgroup-history)\r\r
- (setq gnus-last-article gnus-current-article\r\r
- gnus-current-article article\r\r
- gnus-current-headers\r\r
- (gnus-summary-article-header gnus-current-article)\r\r
- gnus-article-current\r\r
- (cons gnus-newsgroup-name gnus-current-article))\r\r
- (unless (vectorp gnus-current-headers)\r\r
- (setq gnus-current-headers nil))\r\r
- (gnus-summary-goto-subject gnus-current-article)\r\r
- (when (gnus-summary-show-thread)\r\r
- ;; If the summary buffer really was folded, the\r\r
- ;; previous goto may not actually have gone to\r\r
- ;; the right article, but the thread root instead.\r\r
- ;; So we go again.\r\r
- (gnus-summary-goto-subject gnus-current-article))\r\r
- (gnus-run-hooks 'gnus-mark-article-hook)\r\r
- (gnus-set-mode-line 'summary)\r\r
- (when (gnus-visual-p 'article-highlight 'highlight)\r\r
- (gnus-run-hooks 'gnus-visual-mark-article-hook))\r\r
- ;; Set the global newsgroup variables here.\r\r
- ;; Suggested by Jim Sisolak\r\r
- ;; <sisolak@trans4.neep.wisc.edu>.\r\r
- (gnus-set-global-variables)\r\r
- (setq gnus-have-all-headers\r\r
- (or all-headers gnus-show-all-headers))))\r\r
- (when (or (numberp article)\r\r
- (stringp article))\r\r
- (gnus-article-prepare-display)\r\r
- ;; Do page break.\r\r
- (goto-char (point-min))\r\r
- (setq gnus-page-broken\r\r
- (when gnus-break-pages\r\r
- (gnus-narrow-to-page)\r\r
- t)))\r\r
- (let ((gnus-article-mime-handle-alist-1\r\r
- gnus-article-mime-handle-alist))\r\r
- (gnus-set-mode-line 'article))\r\r
- (gnus-configure-windows 'article)\r\r
- (article-goto-body)\r\r
- (set-window-point (get-buffer-window (current-buffer)) (point))\r\r
- t))))))\r\r
-\r\r
-(defun gnus-article-prepare-display ()\r\r
- "Make the current buffer look like a nice article."\r\r
- (let ((method\r\r
- (if gnus-show-mime\r\r
- (progn\r\r
- (setq mime-message-structure gnus-current-headers)\r\r
- gnus-article-display-method-for-mime)\r\r
- gnus-article-display-method-for-traditional)))\r\r
- (gnus-run-hooks 'gnus-tmp-internal-hook)\r\r
- (gnus-run-hooks 'gnus-article-prepare-hook)\r\r
- ;; Display message.\r\r
- (funcall method)\r\r
- ;; Associate this article with the current summary buffer.\r\r
- (setq gnus-article-current-summary (current-buffer))\r\r
- ;; Perform the article display hooks.\r\r
- (gnus-run-hooks 'gnus-article-display-hook)))\r\r
-\r\r
-;;;\r\r
-;;; Gnus MIME viewing functions\r\r
-;;;\r\r
-\r\r
-(defvar gnus-mime-button-line-format "%{%([%p. %d%T]%)%}%e\n"\r\r
- "The following specs can be used:\r\r
-%t The MIME type\r\r
-%T MIME type, along with additional info\r\r
-%n The `name' parameter\r\r
-%d The description, if any\r\r
-%l The length of the encoded part\r\r
-%p The part identifier number\r\r
-%e Dots if the part isn't displayed")\r\r
-\r\r
-(defvar gnus-mime-button-line-format-alist\r\r
- '((?t gnus-tmp-type ?s)\r\r
- (?T gnus-tmp-type-long ?s)\r\r
- (?n gnus-tmp-name ?s)\r\r
- (?d gnus-tmp-description ?s)\r\r
- (?p gnus-tmp-id ?s)\r\r
- (?l gnus-tmp-length ?d)\r\r
- (?e gnus-tmp-dots ?s)))\r\r
-\r\r
-(defvar gnus-mime-button-commands\r\r
- '((gnus-article-press-button "\r" "Toggle Display")\r\r
- (gnus-mime-view-part "v" "View Interactively...")\r\r
- (gnus-mime-save-part "o" "Save...")\r\r
- (gnus-mime-copy-part "c" "View As Text, In Other Buffer")\r\r
- (gnus-mime-inline-part "i" "View As Text, In This Buffer")\r\r
- (gnus-mime-internalize-part "E" "View Internally")\r\r
- (gnus-mime-externalize-part "e" "View Externally")\r\r
- (gnus-mime-pipe-part "|" "Pipe To Command...")))\r\r
-\r\r
-(defun gnus-article-mime-part-status ()\r\r
- (if gnus-article-mime-handle-alist-1\r\r
- (format " (%d parts)" (length gnus-article-mime-handle-alist-1))\r\r
- ""))\r\r
-\r\r
-(defvar gnus-mime-button-map nil)\r\r
-(unless gnus-mime-button-map\r\r
- (setq gnus-mime-button-map (make-sparse-keymap))\r\r
- (set-keymap-parent gnus-mime-button-map gnus-article-mode-map)\r\r
- (define-key gnus-mime-button-map gnus-mouse-2 'gnus-article-push-button)\r\r
- (define-key gnus-mime-button-map gnus-mouse-3 'gnus-mime-button-menu)\r\r
- (mapcar (lambda (c)\r\r
- (define-key gnus-mime-button-map (cadr c) (car c)))\r\r
- gnus-mime-button-commands))\r\r
-\r\r
-(defun gnus-mime-button-menu (event)\r\r
- "Construct a context-sensitive menu of MIME commands."\r\r
- (interactive "e")\r\r
- (gnus-article-check-buffer)\r\r
- (let ((response (x-popup-menu \r\r
- t `("MIME Part" \r\r
- ("" ,@(mapcar (lambda (c)\r\r
- (cons (caddr c) (car c)))\r\r
- gnus-mime-button-commands)))))\r\r
- (pos (event-start event)))\r\r
- (when response\r\r
- (set-buffer (window-buffer (posn-window pos)))\r\r
- (goto-char (posn-point pos))\r\r
- (funcall response))))\r\r
-\r\r
-(defun gnus-mime-view-all-parts (&optional handles)\r\r
- "View all the MIME parts."\r\r
- (interactive)\r\r
- (save-current-buffer\r\r
- (set-buffer gnus-article-buffer)\r\r
- (let ((handles (or handles gnus-article-mime-handles))\r\r
- (rfc2047-default-charset gnus-newsgroup-default-charset)\r\r
- (mm-charset-iso-8859-1-forced gnus-newsgroup-iso-8859-1-forced))\r\r
- (if (stringp (car handles))\r\r
- (gnus-mime-view-all-parts (cdr handles))\r\r
- (mapcar 'mm-display-part handles)))))\r\r
-\r\r
-(defun gnus-mime-save-part ()\r\r
- "Save the MIME part under point."\r\r
- (interactive)\r\r
- (gnus-article-check-buffer)\r\r
- (let ((data (get-text-property (point) 'gnus-data)))\r\r
- (mm-save-part data)))\r\r
-\r\r
-(defun gnus-mime-pipe-part ()\r\r
- "Pipe the MIME part under point to a process."\r\r
- (interactive)\r\r
- (gnus-article-check-buffer)\r\r
- (let ((data (get-text-property (point) 'gnus-data)))\r\r
- (mm-pipe-part data)))\r\r
-\r\r
-(defun gnus-mime-view-part ()\r\r
- "Interactively choose a view method for the MIME part under point."\r\r
- (interactive)\r\r
- (gnus-article-check-buffer)\r\r
- (let ((data (get-text-property (point) 'gnus-data))\r\r
- (url-standalone-mode (not gnus-plugged)))\r\r
- (mm-interactively-view-part data)))\r\r
-\r\r
-(defun gnus-mime-copy-part (&optional handle)\r\r
- "Put the the MIME part under point into a new buffer."\r\r
- (interactive)\r\r
- (gnus-article-check-buffer)\r\r
- (let* ((handle (or handle (get-text-property (point) 'gnus-data)))\r\r
- (contents (mm-get-part handle))|\r\r
- (base (file-name-nondirectory\r\r
- (or\r\r
- (mail-content-type-get (mm-handle-type handle) 'name)\r\r
- (mail-content-type-get (mm-handle-type handle)\r\r
- 'filename)\r\r
- "*decoded*")))\r\r
- (buffer (generate-new-buffer base)))\r\r
- (switch-to-buffer buffer)\r\r
- (insert contents)\r\r
- ;; We do it this way to make `normal-mode' set the appropriate mode.\r\r
- (unwind-protect\r\r
- (progn\r\r
- (setq buffer-file-name (expand-file-name base))\r\r
- (normal-mode))\r\r
- (setq buffer-file-name nil))\r\r
- (goto-char (point-min))))\r\r
-\r\r
-(defun gnus-mime-inline-part (&optional charset)\r\r
- "Insert the MIME part under point into the current buffer."\r\r
- (interactive "P") ; For compatibility reasons we are not using "z".\r\r
- (gnus-article-check-buffer)\r\r
- (let* ((data (get-text-property (point) 'gnus-data))\r\r
- contents\r\r
- (url-standalone-mode (not gnus-plugged))\r\r
- (b (point))\r\r
- buffer-read-only)\r\r
- (if (mm-handle-undisplayer data)\r\r
- (mm-remove-part data)\r\r
- (setq contents (mm-get-part data))\r\r
- (forward-line 2)\r\r
- (when charset \r\r
- (unless (symbolp charset)\r\r
- (setq charset (mm-read-coding-system "Charset: ")))\r\r
- (setq contents (mm-decode-coding-string contents charset)))\r\r
- (mm-insert-inline data contents)\r\r
- (goto-char b))))\r\r
-\r\r
-(defun gnus-mime-externalize-part (&optional handle)\r\r
- "View the MIME part under point with an external viewer."\r\r
- (interactive)\r\r
- (gnus-article-check-buffer)\r\r
- (let* ((handle (or handle (get-text-property (point) 'gnus-data)))\r\r
- (url-standalone-mode (not gnus-plugged))\r\r
- (mm-user-display-methods nil)\r\r
- (mm-all-images-fit t)\r\r
- (rfc2047-default-charset gnus-newsgroup-default-charset)\r\r
- (mm-charset-iso-8859-1-forced gnus-newsgroup-iso-8859-1-forced))\r\r
- (if (mm-handle-undisplayer handle)\r\r
- (mm-remove-part handle)\r\r
- (mm-display-part handle))))\r\r
-\r\r
-(defun gnus-mime-internalize-part (&optional handle)\r\r
- "View the MIME part under point with an internal viewer."\r\r
- (interactive)\r\r
- (gnus-article-check-buffer)\r\r
- (let* ((handle (or handle (get-text-property (point) 'gnus-data)))\r\r
- (url-standalone-mode (not gnus-plugged))\r\r
- (mm-user-display-methods '((".*" . inline)))\r\r
- (mm-all-images-fit t)\r\r
- (rfc2047-default-charset gnus-newsgroup-default-charset)\r\r
- (mm-charset-iso-8859-1-forced gnus-newsgroup-iso-8859-1-forced))\r\r
- (if (mm-handle-undisplayer handle)\r\r
- (mm-remove-part handle)\r\r
- (mm-display-part handle))))\r\r
-\r\r
-(defun gnus-article-part-wrapper (n function)\r\r
- (save-current-buffer\r\r
- (set-buffer gnus-article-buffer)\r\r
- (when (> n (length gnus-article-mime-handle-alist))\r\r
- (error "No such part"))\r\r
- (let ((handle (cdr (assq n gnus-article-mime-handle-alist))))\r\r
- (funcall function handle))))\r\r
-\r\r
-(defun gnus-article-pipe-part (n)\r\r
- "Pipe MIME part N, which is the numerical prefix."\r\r
- (interactive "p")\r\r
- (gnus-article-part-wrapper n 'mm-pipe-part))\r\r
- \r\r
-(defun gnus-article-save-part (n)\r\r
- "Save MIME part N, which is the numerical prefix."\r\r
- (interactive "p")\r\r
- (gnus-article-part-wrapper n 'mm-save-part))\r\r
- \r\r
-(defun gnus-article-interactively-view-part (n)\r\r
- "Pipe MIME part N, which is the numerical prefix."\r\r
- (interactive "p")\r\r
- (gnus-article-part-wrapper n 'mm-interactively-view-part))\r\r
- \r\r
-(defun gnus-article-copy-part (n)\r\r
- "Pipe MIME part N, which is the numerical prefix."\r\r
- (interactive "p")\r\r
- (gnus-article-part-wrapper n 'gnus-mime-copy-part))\r\r
-\r\r
-(defun gnus-article-externalize-part (n)\r\r
- "Pipe MIME part N, which is the numerical prefix."\r\r
- (interactive "p")\r\r
- (gnus-article-part-wrapper n 'gnus-mime-externalize-part))\r\r
- \r\r
-(defun gnus-article-view-part (n)\r\r
- "View MIME part N, which is the numerical prefix."\r\r
- (interactive "p")\r\r
- (save-current-buffer\r\r
- (set-buffer gnus-article-buffer)\r\r
- (when (> n (length gnus-article-mime-handle-alist))\r\r
- (error "No such part"))\r\r
- (let ((handle (cdr (assq n gnus-article-mime-handle-alist))))\r\r
- (when (gnus-article-goto-part n)\r\r
- (if (equal (car handle) "multipart/alternative")\r\r
- (gnus-article-press-button)\r\r
- (when (eq (gnus-mm-display-part handle) 'internal)\r\r
- (gnus-set-window-start)))))))\r\r
-\r\r
-(defun gnus-mm-display-part (handle)\r\r
- "Display HANDLE and fix MIME button."\r\r
- (let ((id (get-text-property (point) 'gnus-part))\r\r
- (point (point))\r\r
- buffer-read-only)\r\r
- (delete-region (gnus-point-at-bol) (progn (forward-line 1) (point)))\r\r
- (gnus-insert-mime-button\r\r
- handle id (list (not (mm-handle-displayed-p handle))))\r\r
- (prog1\r\r
- (let ((window (selected-window))\r\r
- (rfc2047-default-charset gnus-newsgroup-default-charset)\r\r
- (mm-charset-iso-8859-1-forced gnus-newsgroup-iso-8859-1-forced))\r\r
- (save-excursion\r\r
- (unwind-protect\r\r
- (let ((win (get-buffer-window (current-buffer) t)))\r\r
- (if win\r\r
- (select-window win))\r\r
- (goto-char point)\r\r
- (forward-line)\r\r
- (mm-display-part handle))\r\r
- (select-window window))))\r\r
- (goto-char point))))\r\r
-\r\r
-(defun gnus-article-goto-part (n)\r\r
- "Go to MIME part N."\r\r
- (let ((point (text-property-any (point-min) (point-max) 'gnus-part n)))\r\r
- (when point\r\r
- (goto-char point))))\r\r
-\r\r
-(defun gnus-insert-mime-button (handle gnus-tmp-id &optional displayed)\r\r
- (let ((gnus-tmp-name\r\r
- (or (mail-content-type-get (mm-handle-type handle)\r\r
- 'name)\r\r
- (mail-content-type-get (mm-handle-disposition handle)\r\r
- 'filename)\r\r
- ""))\r\r
- (gnus-tmp-type (car (mm-handle-type handle)))\r\r
- (gnus-tmp-description (or (mm-handle-description handle)\r\r
- ""))\r\r
- (gnus-tmp-dots\r\r
- (if (if displayed (car displayed)\r\r
- (mm-handle-displayed-p handle))\r\r
- "" "..."))\r\r
- (gnus-tmp-length (with-current-buffer (mm-handle-buffer handle)\r\r
- (buffer-size)))\r\r
- gnus-tmp-type-long b e)\r\r
- (setq gnus-tmp-type-long (concat gnus-tmp-type\r\r
- (and (not (equal gnus-tmp-name ""))\r\r
- (concat "; " gnus-tmp-name))))\r\r
- (or (equal gnus-tmp-description "")\r\r
- (setq gnus-tmp-type-long (concat " --- " gnus-tmp-type-long)))\r\r
- (unless (bolp)\r\r
- (insert "\n"))\r\r
- (setq b (point))\r\r
- (gnus-eval-format\r\r
- gnus-mime-button-line-format gnus-mime-button-line-format-alist\r\r
- `(local-map ,gnus-mime-button-map\r\r
- keymap ,gnus-mime-button-map\r\r
- gnus-callback gnus-mm-display-part\r\r
- gnus-part ,gnus-tmp-id\r\r
- article-type annotation\r\r
- gnus-data ,handle))\r\r
- (setq e (point))\r\r
- (widget-convert-button 'link b e\r\r
- :mime-handle handle\r\r
- :action 'gnus-widget-press-button\r\r
- :button-keymap gnus-mime-button-map\r\r
- :help-echo\r\r
- (lambda (widget)\r\r
- ;; Needed to properly clear the message\r\r
- ;; due to a bug in wid-edit\r\r
- (setq help-echo-owns-message t)\r\r
- (format\r\r
- "Click to %s the MIME part; %s for more options"\r\r
- (if (mm-handle-displayed-p\r\r
- (widget-get widget :mime-handle))\r\r
- "hide" "show")\r\r
- (if gnus-xemacs "button3" "mouse-3"))))))\r\r
-\r\r
-(defun gnus-widget-press-button (elems el)\r\r
- (goto-char (widget-get elems :from))\r\r
- (let ((url-standalone-mode (not gnus-plugged)))\r\r
- (gnus-article-press-button)))\r\r
-\r\r
-(defun gnus-display-mime (&optional ihandles)\r\r
- "Insert MIME buttons in the buffer."\r\r
- (save-excursion\r\r
- (save-selected-window\r\r
- (let ((window (get-buffer-window gnus-article-buffer))\r\r
- (point (point)))\r\r
- (when window\r\r
- (select-window window)\r\r
- ;; We have to do this since selecting the window\r\r
- ;; may change the point. So we set the window point.\r\r
- (set-window-point window point)))\r\r
- (let* ((handles (or ihandles (mm-dissect-buffer) (mm-uu-dissect)))\r\r
- handle name type b e display)\r\r
- (unless ihandles\r\r
- ;; Top-level call; we clean up.\r\r
- (mm-destroy-parts gnus-article-mime-handles)\r\r
- (setq gnus-article-mime-handles handles\r\r
- gnus-article-mime-handle-alist nil)\r\r
- ;; We allow users to glean info from the handles.\r\r
- (when gnus-article-mime-part-function\r\r
- (gnus-mime-part-function handles)))\r\r
- (when (and handles\r\r
- (or (not (stringp (car handles)))\r\r
- (cdr handles)))\r\r
- (unless ihandles\r\r
- ;; Clean up for mime parts.\r\r
- (article-goto-body)\r\r
- (delete-region (point) (point-max)))\r\r
- (gnus-mime-display-part handles))))))\r\r
-\r\r
-(defun gnus-mime-display-part (handle)\r\r
- (cond\r\r
- ;; Single part.\r\r
- ((not (stringp (car handle)))\r\r
- (gnus-mime-display-single handle))\r\r
- ;; multipart/alternative\r\r
- ((equal (car handle) "multipart/alternative")\r\r
- (let ((id (1+ (length gnus-article-mime-handle-alist))))\r\r
- (push (cons id handle) gnus-article-mime-handle-alist)\r\r
- (gnus-mime-display-alternative (cdr handle) nil nil id)))\r\r
- ;; multipart/related\r\r
- ((equal (car handle) "multipart/related")\r\r
- ;;;!!!We should find the start part, but we just default\r\r
- ;;;!!!to the first part.\r\r
- (gnus-mime-display-part (cadr handle)))\r\r
- ;; Other multiparts are handled like multipart/mixed.\r\r
- (t\r\r
- (gnus-mime-display-mixed (cdr handle)))))\r\r
-\r\r
-(defun gnus-mime-part-function (handles)\r\r
- (if (stringp (car handles))\r\r
- (mapcar 'gnus-mime-part-function (cdr handles))\r\r
- (funcall gnus-article-mime-part-function handles)))\r\r
-\r\r
-(defun gnus-mime-display-mixed (handles)\r\r
- (mapcar 'gnus-mime-display-part handles))\r\r
-\r\r
-(defun gnus-mime-display-single (handle)\r\r
- (let ((type (car (mm-handle-type handle)))\r\r
- (ignored gnus-ignored-mime-types)\r\r
- (not-attachment t)\r\r
- (move nil)\r\r
- display text)\r\r
- (catch 'ignored\r\r
- (progn\r\r
- (while ignored\r\r
- (when (string-match (pop ignored) type)\r\r
- (throw 'ignored nil)))\r\r
- (if (and (setq not-attachment\r\r
- (or (not (mm-handle-disposition handle))\r\r
- (equal (car (mm-handle-disposition handle))\r\r
- "inline")))\r\r
- (mm-automatic-display-p type)\r\r
- (or (mm-inlinable-part-p type)\r\r
- (mm-automatic-external-display-p type)))\r\r
- (setq display t)\r\r
- (when (equal (car (split-string type "/"))\r\r
- "text")\r\r
- (setq text t)))\r\r
- (let ((id (1+ (length gnus-article-mime-handle-alist))))\r\r
- (push (cons id handle) gnus-article-mime-handle-alist)\r\r
- (when (or (not display)\r\r
- (not (gnus-unbuttonized-mime-type-p type)))\r\r
- (gnus-article-insert-newline)\r\r
- (gnus-insert-mime-button\r\r
- handle id (list (or display\r\r
- (and not-attachment text))))\r\r
- (gnus-article-insert-newline)\r\r
- (gnus-article-insert-newline)\r\r
- (setq move t)))\r\r
- (cond\r\r
- (display\r\r
- (when move\r\r
- (forward-line -2))\r\r
- (let ((rfc2047-default-charset gnus-newsgroup-default-charset)\r\r
- (mm-charset-iso-8859-1-forced \r\r
- gnus-newsgroup-iso-8859-1-forced))\r\r
- (mm-display-part handle t))\r\r
- (goto-char (point-max)))\r\r
- ((and text not-attachment)\r\r
- (when move\r\r
- (forward-line -2))\r\r
- (gnus-article-insert-newline)\r\r
- (mm-insert-inline handle (mm-get-part handle))\r\r
- (goto-char (point-max))))))))\r\r
-\r\r
-(defun gnus-unbuttonized-mime-type-p (type)\r\r
- "Say whether TYPE is to be unbuttonized."\r\r
- (unless gnus-inhibit-mime-unbuttonizing\r\r
- (catch 'found\r\r
- (let ((types gnus-unbuttonized-mime-types))\r\r
- (while types\r\r
- (when (string-match (pop types) type)\r\r
- (throw 'found t)))))))\r\r
-\r\r
-(defun gnus-article-insert-newline ()\r\r
- "Insert a newline, but mark it as undeletable."\r\r
- (gnus-put-text-property\r\r
- (point) (progn (insert "\n") (point)) 'gnus-undeletable t))\r\r
-\r\r
-(defun gnus-mime-display-alternative (handles &optional preferred ibegend id)\r\r
- (let* ((preferred (or preferred (mm-preferred-alternative handles)))\r\r
- (ihandles handles)\r\r
- (point (point))\r\r
- handle buffer-read-only from props begend not-pref)\r\r
- (save-window-excursion\r\r
- (save-restriction\r\r
- (when ibegend\r\r
- (narrow-to-region (car ibegend)\r\r
- (or (cdr ibegend)\r\r
- (progn\r\r
- (goto-char (car ibegend))\r\r
- (forward-line 2)\r\r
- (point))))\r\r
- (delete-region (point-min) (point-max))\r\r
- (mm-remove-parts handles))\r\r
- (setq begend (list (point-marker)))\r\r
- ;; Do the toggle.\r\r
- (unless (setq not-pref (cadr (member preferred ihandles)))\r\r
- (setq not-pref (car ihandles)))\r\r
- (when (or ibegend\r\r
- (not (gnus-unbuttonized-mime-type-p\r\r
- "multipart/alternative")))\r\r
- (gnus-add-text-properties\r\r
- (setq from (point))\r\r
- (progn\r\r
- (insert (format "%d. " id))\r\r
- (point))\r\r
- `(gnus-callback\r\r
- (lambda (handles)\r\r
- (unless ,(not ibegend)\r\r
- (setq gnus-article-mime-handle-alist\r\r
- ',gnus-article-mime-handle-alist))\r\r
- (gnus-mime-display-alternative\r\r
- ',ihandles ',not-pref ',begend ,id))\r\r
- local-map ,gnus-mime-button-map\r\r
- ,gnus-mouse-face-prop ,gnus-article-mouse-face\r\r
- face ,gnus-article-button-face\r\r
- keymap ,gnus-mime-button-map\r\r
- gnus-part ,id\r\r
- gnus-data ,handle))\r\r
- (widget-convert-button 'link from (point)\r\r
- :action 'gnus-widget-press-button\r\r
- :button-keymap gnus-widget-button-keymap)\r\r
- ;; Do the handles\r\r
- (while (setq handle (pop handles))\r\r
- (gnus-add-text-properties\r\r
- (setq from (point))\r\r
- (progn\r\r
- (insert (format "(%c) %-18s"\r\r
- (if (equal handle preferred) ?* ? )\r\r
- (if (stringp (car handle))\r\r
- (car handle)\r\r
- (car (mm-handle-type handle)))))\r\r
- (point))\r\r
- `(gnus-callback\r\r
- (lambda (handles)\r\r
- (unless ,(not ibegend)\r\r
- (setq gnus-article-mime-handle-alist\r\r
- ',gnus-article-mime-handle-alist))\r\r
- (gnus-mime-display-alternative\r\r
- ',ihandles ',handle ',begend ,id))\r\r
- local-map ,gnus-mime-button-map\r\r
- ,gnus-mouse-face-prop ,gnus-article-mouse-face\r\r
- face ,gnus-article-button-face\r\r
- keymap ,gnus-mime-button-map\r\r
- gnus-part ,id\r\r
- gnus-data ,handle))\r\r
- (widget-convert-button 'link from (point)\r\r
- :action 'gnus-widget-press-button\r\r
- :button-keymap gnus-widget-button-keymap)\r\r
- (insert " "))\r\r
- (insert "\n\n"))\r\r
- (when preferred\r\r
- (if (stringp (car preferred))\r\r
- (gnus-display-mime preferred)\r\r
- (let ((rfc2047-default-charset gnus-newsgroup-default-charset)\r\r
- (mm-charset-iso-8859-1-forced \r\r
- gnus-newsgroup-iso-8859-1-forced))\r\r
- (mm-display-part preferred)))\r\r
- (goto-char (point-max))\r\r
- (setcdr begend (point-marker)))))\r\r
- (when ibegend\r\r
- (goto-char point))))\r\r
-\r\r
-(defun gnus-article-wash-status ()\r\r
- "Return a string which display status of article washing."\r\r
- (save-excursion\r\r
- (set-buffer gnus-article-buffer)\r\r
- (let ((cite (gnus-article-hidden-text-p 'cite))\r\r
- (headers (gnus-article-hidden-text-p 'headers))\r\r
- (boring (gnus-article-hidden-text-p 'boring-headers))\r\r
- (pgp (gnus-article-hidden-text-p 'pgp))\r\r
- (pem (gnus-article-hidden-text-p 'pem))\r\r
- (signature (gnus-article-hidden-text-p 'signature))\r\r
- (overstrike (gnus-article-hidden-text-p 'overstrike))\r\r
- (emphasis (gnus-article-hidden-text-p 'emphasis))\r\r
- (mime gnus-show-mime))\r\r
- (format "%c%c%c%c%c%c%c"\r\r
- (if cite ?c ? )\r\r
- (if (or headers boring) ?h ? )\r\r
- (if (or pgp pem) ?p ? )\r\r
- (if signature ?s ? )\r\r
- (if overstrike ?o ? )\r\r
- (if mime ?m ? )\r\r
- (if emphasis ?e ? )))))\r\r
-\r\r
-(fset 'gnus-article-hide-headers-if-wanted 'gnus-article-maybe-hide-headers)\r\r
-\r\r
-(defun gnus-article-maybe-hide-headers ()\r\r
- "Hide unwanted headers if `gnus-have-all-headers' is nil.\r\r
-Provided for backwards compatibility."\r\r
- (or (save-excursion (set-buffer gnus-summary-buffer) gnus-have-all-headers)\r\r
- gnus-inhibit-hiding\r\r
- (gnus-article-hide-headers)))\r\r
-\r\r
-;;; Article savers.\r\r
-\r\r
-(defun gnus-output-to-file (file-name)\r\r
- "Append the current article to a file named FILE-NAME."\r\r
- (let ((artbuf (current-buffer)))\r\r
- (with-temp-buffer\r\r
- (insert-buffer-substring artbuf)\r\r
- ;; Append newline at end of the buffer as separator, and then\r\r
- ;; save it to file.\r\r
- (goto-char (point-max))\r\r
- (insert "\n")\r\r
- (append-to-file (point-min) (point-max) file-name)\r\r
- t)))\r\r
-\r\r
-(defun gnus-narrow-to-page (&optional arg)\r\r
- "Narrow the article buffer to a page.\r\r
-If given a numerical ARG, move forward ARG pages."\r\r
- (interactive "P")\r\r
- (setq arg (if arg (prefix-numeric-value arg) 0))\r\r
- (save-excursion\r\r
- (set-buffer gnus-article-buffer)\r\r
- (goto-char (point-min))\r\r
- (widen)\r\r
- ;; Remove any old next/prev buttons.\r\r
- (when (gnus-visual-p 'page-marker)\r\r
- (let ((buffer-read-only nil))\r\r
- (gnus-remove-text-with-property 'gnus-prev)\r\r
- (gnus-remove-text-with-property 'gnus-next)))\r\r
- (when\r\r
- (cond ((< arg 0)\r\r
- (re-search-backward page-delimiter nil 'move (1+ (abs arg))))\r\r
- ((> arg 0)\r\r
- (re-search-forward page-delimiter nil 'move arg)))\r\r
- (goto-char (match-end 0)))\r\r
- (narrow-to-region\r\r
- (point)\r\r
- (if (re-search-forward page-delimiter nil 'move)\r\r
- (match-beginning 0)\r\r
- (point)))\r\r
- (when (and (gnus-visual-p 'page-marker)\r\r
- (not (= (point-min) 1)))\r\r
- (save-excursion\r\r
- (goto-char (point-min))\r\r
- (gnus-insert-prev-page-button)))\r\r
- (when (and (gnus-visual-p 'page-marker)\r\r
- (< (+ (point-max) 2) (buffer-size)))\r\r
- (save-excursion\r\r
- (goto-char (point-max))\r\r
- (gnus-insert-next-page-button)))))\r\r
-\r\r
-;; Article mode commands\r\r
-\r\r
-(defun gnus-article-goto-next-page ()\r\r
- "Show the next page of the article."\r\r
- (interactive)\r\r
- (when (gnus-article-next-page)\r\r
- (goto-char (point-min))\r\r
- (gnus-article-read-summary-keys nil (gnus-character-to-event ?n))))\r\r
-\r\r
-(defun gnus-article-goto-prev-page ()\r\r
- "Show the next page of the article."\r\r
- (interactive)\r\r
- (if (bobp) (gnus-article-read-summary-keys nil (gnus-character-to-event ?p))\r\r
- (gnus-article-prev-page nil)))\r\r
-\r\r
-(defun gnus-article-next-page (&optional lines)\r\r
- "Show the next page of the current article.\r\r
-If end of article, return non-nil. Otherwise return nil.\r\r
-Argument LINES specifies lines to be scrolled up."\r\r
- (interactive "p")\r\r
- (move-to-window-line -1)\r\r
- (if (save-excursion\r\r
- (end-of-line)\r\r
- (and (pos-visible-in-window-p) ;Not continuation line.\r\r
- (eobp)))\r\r
- ;; Nothing in this page.\r\r
- (if (or (not gnus-page-broken)\r\r
- (save-excursion\r\r
- (save-restriction\r\r
- (widen) (forward-line 1) (eobp)))) ;Real end-of-buffer?\r\r
- t ;Nothing more.\r\r
- (gnus-narrow-to-page 1) ;Go to next page.\r\r
- nil)\r\r
- ;; More in this page.\r\r
- (let ((scroll-in-place nil))\r\r
- (condition-case ()\r\r
- (scroll-up lines)\r\r
- (end-of-buffer\r\r
- ;; Long lines may cause an end-of-buffer error.\r\r
- (goto-char (point-max)))))\r\r
- (move-to-window-line 0)\r\r
- nil))\r\r
-\r\r
-(defun gnus-article-prev-page (&optional lines)\r\r
- "Show previous page of current article.\r\r
-Argument LINES specifies lines to be scrolled down."\r\r
- (interactive "p")\r\r
- (move-to-window-line 0)\r\r
- (if (and gnus-page-broken\r\r
- (bobp)\r\r
- (not (save-restriction (widen) (bobp)))) ;Real beginning-of-buffer?\r\r
- (progn\r\r
- (gnus-narrow-to-page -1) ;Go to previous page.\r\r
- (goto-char (point-max))\r\r
- (recenter -1))\r\r
- (let ((scroll-in-place nil))\r\r
- (prog1\r\r
- (condition-case ()\r\r
- (scroll-down lines)\r\r
- (beginning-of-buffer\r\r
- (goto-char (point-min))))\r\r
- (move-to-window-line 0)))))\r\r
-\r\r
-(defun gnus-article-refer-article ()\r\r
- "Read article specified by message-id around point."\r\r
- (interactive)\r\r
- (let ((point (point)))\r\r
- (search-forward ">" nil t) ;Move point to end of "<....>".\r\r
- (if (re-search-backward "\\(<[^<> \t\n]+>\\)" nil t)\r\r
- (let ((message-id (match-string 1)))\r\r
- (goto-char point)\r\r
- (set-buffer gnus-summary-buffer)\r\r
- (gnus-summary-refer-article message-id))\r\r
- (goto-char (point))\r\r
- (error "No references around point"))))\r\r
-\r\r
-(defun gnus-article-show-summary ()\r\r
- "Reconfigure windows to show summary buffer."\r\r
- (interactive)\r\r
- (if (not (gnus-buffer-live-p gnus-summary-buffer))\r\r
- (error "There is no summary buffer for this article buffer")\r\r
- (gnus-article-set-globals)\r\r
- (gnus-configure-windows 'article)\r\r
- (gnus-summary-goto-subject gnus-current-article)\r\r
- (gnus-summary-position-point)))\r\r
-\r\r
-(defun gnus-article-describe-briefly ()\r\r
- "Describe article mode commands briefly."\r\r
- (interactive)\r\r
- (gnus-message 6\r\r
- (substitute-command-keys "\\<gnus-article-mode-map>\\[gnus-article-goto-next-page]:Next page \\[gnus-article-goto-prev-page]:Prev page \\[gnus-article-show-summary]:Show summary \\[gnus-info-find-node]:Run Info \\[gnus-article-describe-briefly]:This help")))\r\r
-\r\r
-(defun gnus-article-summary-command ()\r\r
- "Execute the last keystroke in the summary buffer."\r\r
- (interactive)\r\r
- (let ((obuf (current-buffer))\r\r
- (owin (current-window-configuration))\r\r
- func)\r\r
- (switch-to-buffer gnus-article-current-summary 'norecord)\r\r
- (setq func (lookup-key (current-local-map) (this-command-keys)))\r\r
- (call-interactively func)\r\r
- (set-buffer obuf)\r\r
- (set-window-configuration owin)\r\r
- (set-window-point (get-buffer-window (current-buffer)) (point))))\r\r
-\r\r
-(defun gnus-article-summary-command-nosave ()\r\r
- "Execute the last keystroke in the summary buffer."\r\r
- (interactive)\r\r
- (let (func)\r\r
- (pop-to-buffer gnus-article-current-summary 'norecord)\r\r
- (setq func (lookup-key (current-local-map) (this-command-keys)))\r\r
- (call-interactively func)))\r\r
-\r\r
-(defun gnus-article-check-buffer ()\r\r
- "Beep if not in an article buffer."\r\r
- (unless (equal major-mode 'gnus-article-mode)\r\r
- (error "Command invoked outside of a Gnus article buffer")))\r\r
-\r\r
-(defun gnus-article-read-summary-keys (&optional arg key not-restore-window)\r\r
- "Read a summary buffer key sequence and execute it from the article buffer."\r\r
- (interactive "P")\r\r
- (gnus-article-check-buffer)\r\r
- (let ((nosaves\r\r
- '("q" "Q" "c" "r" "R" "\C-c\C-f" "m" "a" "f" "F"\r\r
- "Zc" "ZC" "ZE" "ZQ" "ZZ" "Zn" "ZR" "ZG" "ZN" "ZP"\r\r
- "=" "^" "\M-^" "|"))\r\r
- (nosave-but-article\r\r
- '("A\r"))\r\r
- (nosave-in-article\r\r
- '("\C-d"))\r\r
- (up-to-top\r\r
- '("n" "Gn" "p" "Gp"))\r\r
- keys new-sum-point)\r\r
- (save-excursion\r\r
- (set-buffer gnus-article-current-summary)\r\r
- (let (gnus-pick-mode)\r\r
- (push (or key last-command-event) unread-command-events)\r\r
- (setq keys (read-key-sequence nil))))\r\r
- (message "")\r\r
-\r\r
- (if (or (member keys nosaves)\r\r
- (member keys nosave-but-article)\r\r
- (member keys nosave-in-article))\r\r
- (let (func)\r\r
- (save-window-excursion\r\r
- (pop-to-buffer gnus-article-current-summary 'norecord)\r\r
- ;; We disable the pick minor mode commands.\r\r
- (let (gnus-pick-mode)\r\r
- (setq func (lookup-key (current-local-map) keys))))\r\r
- (if (not func)\r\r
- (ding)\r\r
- (unless (member keys nosave-in-article)\r\r
- (set-buffer gnus-article-current-summary))\r\r
- (call-interactively func)\r\r
- (setq new-sum-point (point)))\r\r
- (when (member keys nosave-but-article)\r\r
- (pop-to-buffer gnus-article-buffer 'norecord)))\r\r
- ;; These commands should restore window configuration.\r\r
- (let ((obuf (current-buffer))\r\r
- (owin (current-window-configuration))\r\r
- (opoint (point))\r\r
- (summary gnus-article-current-summary)\r\r
- func in-buffer selected)\r\r
- (if not-restore-window\r\r
- (pop-to-buffer summary 'norecord)\r\r
- (switch-to-buffer summary 'norecord))\r\r
- (setq in-buffer (current-buffer))\r\r
- ;; We disable the pick minor mode commands.\r\r
- (if (setq func (let (gnus-pick-mode)\r\r
- (lookup-key (current-local-map) keys)))\r\r
- (progn\r\r
- (call-interactively func)\r\r
- (setq new-sum-point (point)))\r\r
- (ding))\r\r
- (when (eq in-buffer (current-buffer))\r\r
- (setq selected (gnus-summary-select-article))\r\r
- (set-buffer obuf)\r\r
- (unless not-restore-window\r\r
- (set-window-configuration owin))\r\r
- (unless (or (not (eq selected 'old)) (member keys up-to-top))\r\r
- (set-window-point (get-buffer-window (current-buffer))\r\r
- opoint))\r\r
- (let ((win (get-buffer-window gnus-article-current-summary)))\r\r
- (when win\r\r
- (set-window-point win new-sum-point))))))))\r\r
-\r\r
-(defun gnus-article-hide (&optional arg force)\r\r
- "Hide all the gruft in the current article.\r\r
-This means that PGP stuff, signatures, cited text and (some)\r\r
-headers will be hidden.\r\r
-If given a prefix, show the hidden text instead."\r\r
- (interactive (append (gnus-article-hidden-arg) (list 'force)))\r\r
- (gnus-article-hide-headers arg)\r\r
- (gnus-article-hide-pgp arg)\r\r
- (gnus-article-hide-citation-maybe arg force)\r\r
- (gnus-article-hide-signature arg))\r\r
-\r\r
-(defun gnus-article-maybe-highlight ()\r\r
- "Do some article highlighting if article highlighting is requested."\r\r
- (when (gnus-visual-p 'article-highlight 'highlight)\r\r
- (gnus-article-highlight-some)))\r\r
-\r\r
-(defun gnus-check-group-server ()\r\r
- ;; Make sure the connection to the server is alive.\r\r
- (unless (gnus-server-opened\r\r
- (gnus-find-method-for-group gnus-newsgroup-name))\r\r
- (gnus-check-server (gnus-find-method-for-group gnus-newsgroup-name))\r\r
- (gnus-request-group gnus-newsgroup-name t)))\r\r
-\r\r
-(defun gnus-request-article-this-buffer (article group)\r\r
- "Get an article and insert it into this buffer."\r\r
- (let (do-update-line sparse-header)\r\r
- (prog1\r\r
- (save-excursion\r\r
- (erase-buffer)\r\r
- (gnus-kill-all-overlays)\r\r
- (setq group (or group gnus-newsgroup-name))\r\r
-\r\r
- ;; Using `gnus-request-article' directly will insert the article into\r\r
- ;; `nntp-server-buffer' - so we'll save some time by not having to\r\r
- ;; copy it from the server buffer into the article buffer.\r\r
-\r\r
- ;; We only request an article by message-id when we do not have the\r\r
- ;; headers for it, so we'll have to get those.\r\r
- (when (stringp article)\r\r
- (let ((gnus-override-method gnus-refer-article-method))\r\r
- (gnus-read-header article)))\r\r
-\r\r
- ;; If the article number is negative, that means that this article\r\r
- ;; doesn't belong in this newsgroup (possibly), so we find its\r\r
- ;; message-id and request it by id instead of number.\r\r
- (when (and (numberp article)\r\r
- gnus-summary-buffer\r\r
- (get-buffer gnus-summary-buffer)\r\r
- (gnus-buffer-exists-p gnus-summary-buffer))\r\r
- (save-excursion\r\r
- (set-buffer gnus-summary-buffer)\r\r
- (let ((header (gnus-summary-article-header article)))\r\r
- (when (< article 0)\r\r
- (cond\r\r
- ((memq article gnus-newsgroup-sparse)\r\r
- ;; This is a sparse gap article.\r\r
- (setq do-update-line article)\r\r
- (setq article (mail-header-id header))\r\r
- (let ((gnus-override-method gnus-refer-article-method))\r\r
- (setq sparse-header (gnus-read-header article)))\r\r
- (setq gnus-newsgroup-sparse\r\r
- (delq article gnus-newsgroup-sparse)))\r\r
- ((vectorp header)\r\r
- ;; It's a real article.\r\r
- (setq article (mail-header-id header)))\r\r
- (t\r\r
- ;; It is an extracted pseudo-article.\r\r
- (setq article 'pseudo)\r\r
- (gnus-request-pseudo-article header))))\r\r
-\r\r
- (let ((method (gnus-find-method-for-group\r\r
- gnus-newsgroup-name)))\r\r
- (when (and (eq (car method) 'nneething)\r\r
- (vectorp header))\r\r
- (let ((dir (concat\r\r
- (file-name-as-directory\r\r
- (or (cadr (assq 'nneething-address method))\r\r
- (nth 1 method)))\r\r
- (mail-header-subject header))))\r\r
- (when (file-directory-p dir)\r\r
- (setq article 'nneething)\r\r
- (gnus-group-enter-directory dir))))))))\r\r
-\r\r
- (cond\r\r
- ;; Refuse to select canceled articles.\r\r
- ((and (numberp article)\r\r
- gnus-summary-buffer\r\r
- (get-buffer gnus-summary-buffer)\r\r
- (gnus-buffer-exists-p gnus-summary-buffer)\r\r
- (eq (cdr (save-excursion\r\r
- (set-buffer gnus-summary-buffer)\r\r
- (assq article gnus-newsgroup-reads)))\r\r
- gnus-canceled-mark))\r\r
- nil)\r\r
- ;; Check the backlog.\r\r
- ((and gnus-keep-backlog\r\r
- (gnus-backlog-request-article group article (current-buffer)))\r\r
- 'article)\r\r
- ;; Check asynchronous pre-fetch.\r\r
- ((gnus-async-request-fetched-article group article (current-buffer))\r\r
- (gnus-async-prefetch-next group article gnus-summary-buffer)\r\r
- (when (and (numberp article) gnus-keep-backlog)\r\r
- (gnus-backlog-enter-article group article (current-buffer)))\r\r
- 'article)\r\r
- ;; Check the cache.\r\r
- ((and gnus-use-cache\r\r
- (numberp article)\r\r
- (gnus-cache-request-article article group))\r\r
- 'article)\r\r
- ;; Get the article and put into the article buffer.\r\r
- ((or (stringp article) (numberp article))\r\r
- (let ((gnus-override-method\r\r
- (and (stringp article) gnus-refer-article-method))\r\r
- (buffer-read-only nil))\r\r
- (erase-buffer)\r\r
- (gnus-kill-all-overlays)\r\r
- (gnus-check-group-server)\r\r
- (when (gnus-request-article article group (current-buffer))\r\r
- (when (numberp article)\r\r
- (gnus-async-prefetch-next group article gnus-summary-buffer)\r\r
- (when gnus-keep-backlog\r\r
- (gnus-backlog-enter-article\r\r
- group article (current-buffer))))\r\r
- 'article)))\r\r
- ;; It was a pseudo.\r\r
- (t article)))\r\r
-\r\r
- ;; Associate this article with the current summary buffer.\r\r
- (setq gnus-article-current-summary gnus-summary-buffer)\r\r
-\r\r
- ;; Take the article from the original article buffer\r\r
- ;; and place it in the buffer it's supposed to be in.\r\r
- (when (and (get-buffer gnus-article-buffer)\r\r
- (equal (buffer-name (current-buffer))\r\r
- (buffer-name (get-buffer gnus-article-buffer))))\r\r
- (save-excursion\r\r
- (if (get-buffer gnus-original-article-buffer)\r\r
- (set-buffer gnus-original-article-buffer)\r\r
- (set-buffer (gnus-get-buffer-create gnus-original-article-buffer))\r\r
- (buffer-disable-undo)\r\r
- (setq major-mode 'gnus-original-article-mode)\r\r
- (setq buffer-read-only t))\r\r
- (let (buffer-read-only)\r\r
- (erase-buffer)\r\r
- (insert-buffer-substring gnus-article-buffer))\r\r
- (setq gnus-original-article (cons group article)))\r\r
-\r\r
- ;; Decode charsets.\r\r
- (run-hooks 'gnus-article-decode-hook)\r\r
- ;; Mark article as decoded or not.\r\r
- (setq gnus-article-decoded-p gnus-article-decode-hook))\r\r
-\r\r
- ;; Update sparse articles.\r\r
- (when (and do-update-line\r\r
- (or (numberp article)\r\r
- (stringp article)))\r\r
- (let ((buf (current-buffer)))\r\r
- (set-buffer gnus-summary-buffer)\r\r
- (gnus-summary-update-article do-update-line sparse-header)\r\r
- (gnus-summary-goto-subject do-update-line nil t)\r\r
- (set-window-point (get-buffer-window (current-buffer) t)\r\r
- (point))\r\r
- (set-buffer buf))))))\r\r
-\r\r
-;;;\r\r
-;;; Article editing\r\r
-;;;\r\r
-\r\r
-(defcustom gnus-article-edit-mode-hook nil\r\r
- "Hook run in article edit mode buffers."\r\r
- :group 'gnus-article-various\r\r
- :type 'hook)\r\r
-\r\r
-(defcustom gnus-article-edit-article-setup-function\r\r
- 'gnus-article-mime-edit-article-setup\r\r
- "Function called to setup an editing article buffer."\r\r
- :group 'gnus-article-various\r\r
- :type 'function)\r\r
-\r\r
-(defvar gnus-article-edit-done-function nil)\r\r
-\r\r
-(defvar gnus-article-edit-mode-map nil)\r\r
-\r\r
-;; Should we be using derived.el for this?\r\r
-(unless gnus-article-edit-mode-map\r\r
- (setq gnus-article-edit-mode-map (make-sparse-keymap))\r\r
- (set-keymap-parent gnus-article-edit-mode-map text-mode-map)\r\r
-\r\r
- (gnus-define-keys gnus-article-edit-mode-map\r\r
- "\C-c\C-c" gnus-article-edit-done\r\r
- "\C-c\C-k" gnus-article-edit-exit)\r\r
-\r\r
- (gnus-define-keys (gnus-article-edit-wash-map\r\r
- "\C-c\C-w" gnus-article-edit-mode-map)\r\r
- "f" gnus-article-edit-full-stops))\r\r
-\r\r
-(defun gnus-article-edit-mode ()\r\r
- "Major mode for editing articles.\r\r
-This is an extended text-mode.\r\r
-\r\r
-\\{gnus-article-edit-mode-map}"\r\r
- (interactive)\r\r
- (setq major-mode 'gnus-article-edit-mode)\r\r
- (setq mode-name "Article Edit")\r\r
- (use-local-map gnus-article-edit-mode-map)\r\r
- (make-local-variable 'gnus-article-edit-done-function)\r\r
- (make-local-variable 'gnus-prev-winconf)\r\r
- (setq buffer-read-only nil)\r\r
- (buffer-enable-undo)\r\r
- (widen)\r\r
- (gnus-run-hooks 'text-mode-hook 'gnus-article-edit-mode-hook))\r\r
-\r\r
-(defun gnus-article-edit (&optional force)\r\r
- "Edit the current article.\r\r
-This will have permanent effect only in mail groups.\r\r
-If FORCE is non-nil, allow editing of articles even in read-only\r\r
-groups."\r\r
- (interactive "P")\r\r
- (when (and (not force)\r\r
- (gnus-group-read-only-p))\r\r
- (error "The current newsgroup does not support article editing"))\r\r
- (gnus-article-date-original)\r\r
- (gnus-article-edit-article\r\r
- `(lambda (no-highlight)\r\r
- (gnus-summary-edit-article-done\r\r
- ,(or (mail-header-references gnus-current-headers) "")\r\r
- ,(gnus-group-read-only-p) ,gnus-summary-buffer no-highlight))))\r\r
-\r\r
-(defun gnus-article-edit-article (exit-func)\r\r
- "Start editing the contents of the current article buffer."\r\r
- (let ((winconf (current-window-configuration)))\r\r
- (set-buffer gnus-article-buffer)\r\r
- (gnus-article-edit-mode)\r\r
- (gnus-article-delete-text-of-type 'annotation)\r\r
- (gnus-set-text-properties (point-min) (point-max) nil)\r\r
- (gnus-configure-windows 'edit-article)\r\r
- (setq gnus-article-edit-done-function exit-func)\r\r
- (setq gnus-prev-winconf winconf)\r\r
- (when gnus-article-edit-article-setup-function\r\r
- (funcall gnus-article-edit-article-setup-function))\r\r
- (gnus-message 6 "C-c C-c to end edits")))\r\r
-\r\r
-(defun gnus-article-edit-done (&optional arg)\r\r
- "Update the article edits and exit."\r\r
- (interactive "P")\r\r
- (save-excursion\r\r
- (save-restriction\r\r
- (widen)\r\r
- (when (article-goto-body)\r\r
- (let ((lines (count-lines (point) (point-max)))\r\r
- (length (- (point-max) (point)))\r\r
- (case-fold-search t)\r\r
- (body (copy-marker (point))))\r\r
- (goto-char (point-min))\r\r
- (when (re-search-forward "^content-length:[ \t]\\([0-9]+\\)" body t)\r\r
- (delete-region (match-beginning 1) (match-end 1))\r\r
- (insert (number-to-string length)))\r\r
- (goto-char (point-min))\r\r
- (when (re-search-forward\r\r
- "^x-content-length:[ \t]\\([0-9]+\\)" body t)\r\r
- (delete-region (match-beginning 1) (match-end 1))\r\r
- (insert (number-to-string length)))\r\r
- (goto-char (point-min))\r\r
- (when (re-search-forward "^lines:[ \t]\\([0-9]+\\)" body t)\r\r
- (delete-region (match-beginning 1) (match-end 1))\r\r
- (insert (number-to-string lines)))))))\r\r
- (let ((func gnus-article-edit-done-function)\r\r
- (buf (current-buffer))\r\r
- (start (window-start)))\r\r
- (remove-hook 'gnus-article-mode-hook\r\r
- 'gnus-article-mime-edit-article-unwind)\r\r
- (gnus-article-edit-exit)\r\r
- (save-excursion\r\r
- (set-buffer buf)\r\r
- (let ((buffer-read-only nil))\r\r
- (funcall func arg))\r\r
- ;; The cache and backlog have to be flushed somewhat.\r\r
- (when gnus-keep-backlog\r\r
- (gnus-backlog-remove-article\r\r
- (car gnus-article-current) (cdr gnus-article-current)))\r\r
- ;; Flush original article as well.\r\r
- (save-excursion\r\r
- (when (get-buffer gnus-original-article-buffer)\r\r
- (set-buffer gnus-original-article-buffer)\r\r
- (setq gnus-original-article nil)))\r\r
- (when gnus-use-cache\r\r
- (gnus-cache-update-article\r\r
- (car gnus-article-current) (cdr gnus-article-current))))\r\r
- (set-buffer buf)\r\r
- (set-window-start (get-buffer-window buf) start)\r\r
- (set-window-point (get-buffer-window buf) (point))))\r\r
-\r\r
-(defun gnus-article-edit-exit ()\r\r
- "Exit the article editing without updating."\r\r
- (interactive)\r\r
- ;; We remove all text props from the article buffer.\r\r
- (let ((buf (format "%s" (buffer-string)))\r\r
- (curbuf (current-buffer))\r\r
- (p (point))\r\r
- (window-start (window-start)))\r\r
- (erase-buffer)\r\r
- (insert buf)\r\r
- (let ((winconf gnus-prev-winconf))\r\r
- (gnus-article-mode)\r\r
- (set-window-configuration winconf)\r\r
- ;; Tippy-toe some to make sure that point remains where it was.\r\r
- (save-current-buffer\r\r
- (set-buffer curbuf)\r\r
- (set-window-start (get-buffer-window (current-buffer)) window-start)\r\r
- (goto-char p)))))\r\r
-\r\r
-(defun gnus-article-edit-full-stops ()\r\r
- "Interactively repair spacing at end of sentences."\r\r
- (interactive)\r\r
- (save-excursion\r\r
- (goto-char (point-min))\r\r
- (search-forward-regexp "^$" nil t)\r\r
- (let ((case-fold-search nil))\r\r
- (query-replace-regexp "\\([.!?][])}]* \\)\\([[({A-Z]\\)" "\\1 \\2"))))\r\r
-\r\r
-;;;\r\r
-;;; Article editing with MIME-Edit\r\r
-;;;\r\r
-\r\r
-(defcustom gnus-article-mime-edit-article-setup-hook nil\r\r
- "Hook run after setting up a MIME editing article buffer."\r\r
- :group 'gnus-article-various\r\r
- :type 'hook)\r\r
-\r\r
-(defun gnus-article-mime-edit-article-unwind ()\r\r
- "Unwind `gnus-article-buffer' if article editing was given up."\r\r
- (remove-hook 'gnus-article-mode-hook 'gnus-article-mime-edit-article-unwind)\r\r
- (when mime-edit-mode-flag\r\r
- (mime-edit-exit 'nomime 'no-error)\r\r
- (message ""))\r\r
- (when (featurep 'font-lock)\r\r
- (setq font-lock-defaults nil)\r\r
- (font-lock-mode 0)))\r\r
-\r\r
-(defun gnus-article-mime-edit-article-setup ()\r\r
- "Convert current buffer to MIME-Edit buffer and turn on MIME-Edit mode\r\r
-after replacing with the original article."\r\r
- (setq gnus-show-mime t)\r\r
- (setq gnus-article-edit-done-function\r\r
- `(lambda (&rest args)\r\r
- (when mime-edit-mode-flag\r\r
- (mime-edit-exit)\r\r
- (message ""))\r\r
- (goto-char (point-min))\r\r
- (let (case-fold-search)\r\r
- (when (re-search-forward\r\r
- (format "^%s$" (regexp-quote mail-header-separator))\r\r
- nil t)\r\r
- (replace-match "")))\r\r
- (when (featurep 'font-lock)\r\r
- (setq font-lock-defaults nil)\r\r
- (font-lock-mode 0))\r\r
- (apply ,gnus-article-edit-done-function args)\r\r
- (set-buffer gnus-original-article-buffer)\r\r
- (erase-buffer)\r\r
- (insert-buffer gnus-article-buffer)\r\r
- (setq gnus-current-headers (gnus-article-make-full-mail-header))\r\r
- (gnus-article-prepare-display)))\r\r
- (substitute-key-definition\r\r
- 'gnus-article-edit-exit 'gnus-article-mime-edit-exit\r\r
- gnus-article-edit-mode-map)\r\r
- (erase-buffer)\r\r
- (insert-buffer gnus-original-article-buffer)\r\r
- (mime-edit-again)\r\r
- (when (featurep 'font-lock)\r\r
- (set (make-local-variable 'font-lock-defaults)\r\r
- '(message-font-lock-keywords t))\r\r
- (font-lock-set-defaults)\r\r
- (turn-on-font-lock))\r\r
- (add-hook 'gnus-article-mode-hook 'gnus-article-mime-edit-article-unwind)\r\r
- (gnus-run-hooks 'gnus-article-mime-edit-article-setup-hook))\r\r
-\r\r
-(defun gnus-article-mime-edit-exit ()\r\r
- "Exit the article MIME editing without updating."\r\r
- (interactive)\r\r
- (let ((winconf gnus-prev-winconf)\r\r
- buf)\r\r
- (when mime-edit-mode-flag\r\r
- (mime-edit-exit)\r\r
- (message ""))\r\r
- (goto-char (point-min))\r\r
- (let (case-fold-search)\r\r
- (when (re-search-forward\r\r
- (format "^%s$" (regexp-quote mail-header-separator)) nil t)\r\r
- (replace-match "")))\r\r
- (when (featurep 'font-lock)\r\r
- (setq font-lock-defaults nil)\r\r
- (font-lock-mode 0))\r\r
- ;; We remove all text props from the article buffer.\r\r
- (setq buf (format "%s" (buffer-string)))\r\r
- (set-buffer (get-buffer-create gnus-original-article-buffer))\r\r
- (erase-buffer)\r\r
- (insert buf)\r\r
- (setq gnus-current-headers (gnus-article-make-full-mail-header))\r\r
- (gnus-article-prepare-display)\r\r
- (set-window-configuration winconf)))\r\r
-\r\r
-;;;\r\r
-;;; Article highlights\r\r
-;;;\r\r
-\r\r
-;; Written by Per Abrahamsen <abraham@iesd.auc.dk>.\r\r
-\r\r
-;;; Internal Variables:\r\r
-\r\r
-(defcustom gnus-button-url-regexp "\\b\\(s?https?\\|ftp\\|file\\|gopher\\|news\\|telnet\\|wais\\|mailto\\):\\(//[-a-zA-Z0-9_.]+:[0-9]*\\)?\\([-a-zA-Z0-9_=!?#$@~`%&*+|\\/:;.,]\\|\\w\\)+\\([-a-zA-Z0-9_=#$@~`%&*+|\\/]\\|\\w\\)"\r\r
- "Regular expression that matches URLs."\r\r
- :group 'gnus-article-buttons\r\r
- :type 'regexp)\r\r
-\r\r
-(defcustom gnus-button-alist\r\r
- `(("<\\(url:[>\n\t ]*?\\)?news:[>\n\t ]*\\([^>\n\t ]*@[^>\n\t ]*\\)>"\r\r
- 0 t gnus-button-message-id 2)\r\r
- ("\\bnews:\\([^>\n\t ]*@[^>)!;:,\n\t ]*\\)" 0 t gnus-button-message-id 1)\r\r
- ("\\(\\b<\\(url:[>\n\t ]*\\)?news:[>\n\t ]*\\(//\\)?\\([^>\n\t ]*\\)>\\)"\r\r
- 1 t\r\r
- gnus-button-fetch-group 4)\r\r
- ("\\bnews:\\(//\\)?\\([^'\">\n\t ]+\\)" 0 t gnus-button-fetch-group 2)\r\r
- ("\\bin\\( +article\\| +message\\)? +\\(<\\([^\n @<>]+@[^\n @<>]+\\)>\\)" 2\r\r
- t gnus-button-message-id 3)\r\r
- ("\\(<URL: *\\)mailto: *\\([^> \n\t]+\\)>" 0 t gnus-url-mailto 2)\r\r
- ("mailto:\\([-a-zA-Z.@_+0-9%]+\\)" 0 t gnus-url-mailto 1)\r\r
- ("\\bmailto:\\([^ \n\t]+\\)" 0 t gnus-url-mailto 1)\r\r
- ;; This is how URLs _should_ be embedded in text...\r\r
- ("<URL: *\\([^>]*\\)>" 0 t gnus-button-embedded-url 1)\r\r
- ;; Raw URLs.\r\r
- (,gnus-button-url-regexp 0 t gnus-button-url 0))\r\r
- "*Alist of regexps matching buttons in article bodies.\r\r
-\r\r
-Each entry has the form (REGEXP BUTTON FORM CALLBACK PAR...), where\r\r
-REGEXP: is the string matching text around the button,\r\r
-BUTTON: is the number of the regexp grouping actually matching the button,\r\r
-FORM: is a lisp expression which must eval to true for the button to\r\r
-be added,\r\r
-CALLBACK: is the function to call when the user push this button, and each\r\r
-PAR: is a number of a regexp grouping whose text will be passed to CALLBACK.\r\r
-\r\r
-CALLBACK can also be a variable, in that case the value of that\r\r
-variable it the real callback function."\r\r
- :group 'gnus-article-buttons\r\r
- :type '(repeat (list regexp\r\r
- (integer :tag "Button")\r\r
- (sexp :tag "Form")\r\r
- (function :tag "Callback")\r\r
- (repeat :tag "Par"\r\r
- :inline t\r\r
- (integer :tag "Regexp group")))))\r\r
-\r\r
-(defcustom gnus-header-button-alist\r\r
- `(("^\\(References\\|Message-I[Dd]\\):" "<[^>]+>"\r\r
- 0 t gnus-button-message-id 0)\r\r
- ("^\\(From\\|Reply-To\\):" ": *\\(.+\\)$" 1 t gnus-button-reply 1)\r\r
- ("^\\(Cc\\|To\\):" "[^ \t\n<>,()\"]+@[^ \t\n<>,()\"]+"\r\r
- 0 t gnus-button-mailto 0)\r\r
- ("^X-[Uu][Rr][Ll]:" ,gnus-button-url-regexp 0 t gnus-button-url 0)\r\r
- ("^Subject:" ,gnus-button-url-regexp 0 t gnus-button-url 0)\r\r
- ("^[^:]+:" ,gnus-button-url-regexp 0 t gnus-button-url 0)\r\r
- ("^[^:]+:" "\\(<\\(url: \\)?news:\\([^>\n ]*\\)>\\)" 1 t\r\r
- gnus-button-message-id 3))\r\r
- "*Alist of headers and regexps to match buttons in article heads.\r\r
-\r\r
-This alist is very similar to `gnus-button-alist', except that each\r\r
-alist has an additional HEADER element first in each entry:\r\r
-\r\r
-\(HEADER REGEXP BUTTON FORM CALLBACK PAR)\r\r
-\r\r
-HEADER is a regexp to match a header. For a fuller explanation, see\r\r
-`gnus-button-alist'."\r\r
- :group 'gnus-article-buttons\r\r
- :group 'gnus-article-headers\r\r
- :type '(repeat (list (regexp :tag "Header")\r\r
- regexp\r\r
- (integer :tag "Button")\r\r
- (sexp :tag "Form")\r\r
- (function :tag "Callback")\r\r
- (repeat :tag "Par"\r\r
- :inline t\r\r
- (integer :tag "Regexp group")))))\r\r
-\r\r
-(defvar gnus-button-regexp nil)\r\r
-(defvar gnus-button-marker-list nil)\r\r
-;; Regexp matching any of the regexps from `gnus-button-alist'.\r\r
-\r\r
-(defvar gnus-button-last nil)\r\r
-;; The value of `gnus-button-alist' when `gnus-button-regexp' was build.\r\r
-\r\r
-;;; Commands:\r\r
-\r\r
-(defun gnus-article-push-button (event)\r\r
- "Check text under the mouse pointer for a callback function.\r\r
-If the text under the mouse pointer has a `gnus-callback' property,\r\r
-call it with the value of the `gnus-data' text property."\r\r
- (interactive "e")\r\r
- (set-buffer (window-buffer (posn-window (event-start event))))\r\r
- (let* ((pos (posn-point (event-start event)))\r\r
- (data (get-text-property pos 'gnus-data))\r\r
- (fun (get-text-property pos 'gnus-callback)))\r\r
- (goto-char pos)\r\r
- (when fun\r\r
- (funcall fun data))))\r\r
-\r\r
-(defun gnus-article-press-button ()\r\r
- "Check text at point for a callback function.\r\r
-If the text at point has a `gnus-callback' property,\r\r
-call it with the value of the `gnus-data' text property."\r\r
- (interactive)\r\r
- (let* ((data (get-text-property (point) 'gnus-data))\r\r
- (fun (get-text-property (point) 'gnus-callback)))\r\r
- (when fun\r\r
- (funcall fun data))))\r\r
-\r\r
-(defun gnus-article-prev-button (n)\r\r
- "Move point to N buttons backward.\r\r
-If N is negative, move forward instead."\r\r
- (interactive "p")\r\r
- (gnus-article-next-button (- n)))\r\r
-\r\r
-(defun gnus-article-next-button (n)\r\r
- "Move point to N buttons forward.\r\r
-If N is negative, move backward instead."\r\r
- (interactive "p")\r\r
- (let ((function (if (< n 0) 'previous-single-property-change\r\r
- 'next-single-property-change))\r\r
- (inhibit-point-motion-hooks t)\r\r
- (backward (< n 0))\r\r
- (limit (if (< n 0) (point-min) (point-max))))\r\r
- (setq n (abs n))\r\r
- (while (and (not (= limit (point)))\r\r
- (> n 0))\r\r
- ;; Skip past the current button.\r\r
- (when (get-text-property (point) 'gnus-callback)\r\r
- (goto-char (funcall function (point) 'gnus-callback nil limit)))\r\r
- ;; Go to the next (or previous) button.\r\r
- (gnus-goto-char (funcall function (point) 'gnus-callback nil limit))\r\r
- ;; Put point at the start of the button.\r\r
- (when (and backward (not (get-text-property (point) 'gnus-callback)))\r\r
- (goto-char (funcall function (point) 'gnus-callback nil limit)))\r\r
- ;; Skip past intangible buttons.\r\r
- (when (get-text-property (point) 'intangible)\r\r
- (incf n))\r\r
- (decf n))\r\r
- (unless (zerop n)\r\r
- (gnus-message 5 "No more buttons"))\r\r
- n))\r\r
-\r\r
-(defun gnus-article-highlight (&optional force)\r\r
- "Highlight current article.\r\r
-This function calls `gnus-article-highlight-headers',\r\r
-`gnus-article-highlight-citation',\r\r
-`gnus-article-highlight-signature', and `gnus-article-add-buttons' to\r\r
-do the highlighting. See the documentation for those functions."\r\r
- (interactive (list 'force))\r\r
- (gnus-article-highlight-headers)\r\r
- (gnus-article-highlight-citation force)\r\r
- (gnus-article-highlight-signature)\r\r
- (gnus-article-add-buttons force)\r\r
- (gnus-article-add-buttons-to-head))\r\r
-\r\r
-(defun gnus-article-highlight-some (&optional force)\r\r
- "Highlight current article.\r\r
-This function calls `gnus-article-highlight-headers',\r\r
-`gnus-article-highlight-signature', and `gnus-article-add-buttons' to\r\r
-do the highlighting. See the documentation for those functions."\r\r
- (interactive (list 'force))\r\r
- (gnus-article-highlight-headers)\r\r
- (gnus-article-highlight-signature)\r\r
- (gnus-article-add-buttons))\r\r
-\r\r
-(defun gnus-article-highlight-headers ()\r\r
- "Highlight article headers as specified by `gnus-header-face-alist'."\r\r
- (interactive)\r\r
- (save-excursion\r\r
- (set-buffer gnus-article-buffer)\r\r
- (save-restriction\r\r
- (let ((alist gnus-header-face-alist)\r\r
- (buffer-read-only nil)\r\r
- (case-fold-search t)\r\r
- (inhibit-point-motion-hooks t)\r\r
- entry regexp header-face field-face from hpoints fpoints)\r\r
- (message-narrow-to-head)\r\r
- (while (setq entry (pop alist))\r\r
- (goto-char (point-min))\r\r
- (setq regexp (concat "^\\("\r\r
- (if (string-equal "" (nth 0 entry))\r\r
- "[^\t ]"\r\r
- (nth 0 entry))\r\r
- "\\)")\r\r
- header-face (nth 1 entry)\r\r
- field-face (nth 2 entry))\r\r
- (while (and (re-search-forward regexp nil t)\r\r
- (not (eobp)))\r\r
- (beginning-of-line)\r\r
- (setq from (point))\r\r
- (unless (search-forward ":" nil t)\r\r
- (forward-char 1))\r\r
- (when (and header-face\r\r
- (not (memq (point) hpoints)))\r\r
- (push (point) hpoints)\r\r
- (gnus-put-text-property from (point) 'face header-face))\r\r
- (when (and field-face\r\r
- (not (memq (setq from (point)) fpoints)))\r\r
- (push from fpoints)\r\r
- (if (re-search-forward "^[^ \t]" nil t)\r\r
- (forward-char -2)\r\r
- (goto-char (point-max)))\r\r
- (gnus-put-text-property from (point) 'face field-face))))))))\r\r
-\r\r
-(defun gnus-article-highlight-signature ()\r\r
- "Highlight the signature in an article.\r\r
-It does this by highlighting everything after\r\r
-`gnus-signature-separator' using `gnus-signature-face'."\r\r
- (interactive)\r\r
- (save-excursion\r\r
- (set-buffer gnus-article-buffer)\r\r
- (let ((buffer-read-only nil)\r\r
- (inhibit-point-motion-hooks t))\r\r
- (save-restriction\r\r
- (when (and gnus-signature-face\r\r
- (gnus-article-narrow-to-signature))\r\r
- (gnus-overlay-put (gnus-make-overlay (point-min) (point-max))\r\r
- 'face gnus-signature-face)\r\r
- (widen)\r\r
- (gnus-article-search-signature)\r\r
- (let ((start (match-beginning 0))\r\r
- (end (set-marker (make-marker) (1+ (match-end 0)))))\r\r
- (gnus-article-add-button start (1- end) 'gnus-signature-toggle\r\r
- end)))))))\r\r
-\r\r
-(defun gnus-button-in-region-p (b e prop)\r\r
- "Say whether PROP exists in the region."\r\r
- (text-property-not-all b e prop nil))\r\r
-\r\r
-(defun gnus-article-add-buttons (&optional force)\r\r
- "Find external references in the article and make buttons of them.\r\r
-\"External references\" are things like Message-IDs and URLs, as\r\r
-specified by `gnus-button-alist'."\r\r
- (interactive (list 'force))\r\r
- (save-excursion\r\r
- (set-buffer gnus-article-buffer)\r\r
- (let ((buffer-read-only nil)\r\r
- (inhibit-point-motion-hooks t)\r\r
- (case-fold-search t)\r\r
- (alist gnus-button-alist)\r\r
- beg entry regexp)\r\r
- ;; Remove all old markers.\r\r
- (let (marker entry)\r\r
- (while (setq marker (pop gnus-button-marker-list))\r\r
- (goto-char marker)\r\r
- (when (setq entry (gnus-button-entry))\r\r
- (put-text-property (match-beginning (nth 1 entry))\r\r
- (match-end (nth 1 entry))\r\r
- 'gnus-callback nil))\r\r
- (set-marker marker nil)))\r\r
- ;; We skip the headers.\r\r
- (article-goto-body)\r\r
- (setq beg (point))\r\r
- (while (setq entry (pop alist))\r\r
- (setq regexp (car entry))\r\r
- (goto-char beg)\r\r
- (while (re-search-forward regexp nil t)\r\r
- (let* ((start (and entry (match-beginning (nth 1 entry))))\r\r
- (end (and entry (match-end (nth 1 entry))))\r\r
- (from (match-beginning 0)))\r\r
- (when (and (or (eq t (nth 2 entry))\r\r
- (eval (nth 2 entry)))\r\r
- (not (gnus-button-in-region-p\r\r
- start end 'gnus-callback)))\r\r
- ;; That optional form returned non-nil, so we add the\r\r
- ;; button.\r\r
- (gnus-article-add-button\r\r
- start end 'gnus-button-push\r\r
- (car (push (set-marker (make-marker) from)\r\r
- gnus-button-marker-list))))))))))\r\r
-\r\r
-;; Add buttons to the head of an article.\r\r
-(defun gnus-article-add-buttons-to-head ()\r\r
- "Add buttons to the head of the article."\r\r
- (interactive)\r\r
- (save-excursion\r\r
- (set-buffer gnus-article-buffer)\r\r
- (let ((buffer-read-only nil)\r\r
- (inhibit-point-motion-hooks t)\r\r
- (case-fold-search t)\r\r
- (alist gnus-header-button-alist)\r\r
- entry beg end)\r\r
- (nnheader-narrow-to-headers)\r\r
- (while alist\r\r
- ;; Each alist entry.\r\r
- (setq entry (car alist)\r\r
- alist (cdr alist))\r\r
- (goto-char (point-min))\r\r
- (while (re-search-forward (car entry) nil t)\r\r
- ;; Each header matching the entry.\r\r
- (setq beg (match-beginning 0))\r\r
- (setq end (or (and (re-search-forward "^[^ \t]" nil t)\r\r
- (match-beginning 0))\r\r
- (point-max)))\r\r
- (goto-char beg)\r\r
- (while (re-search-forward (nth 1 entry) end t)\r\r
- ;; Each match within a header.\r\r
- (let* ((entry (cdr entry))\r\r
- (start (match-beginning (nth 1 entry)))\r\r
- (end (match-end (nth 1 entry)))\r\r
- (form (nth 2 entry)))\r\r
- (goto-char (match-end 0))\r\r
- (when (eval form)\r\r
- (gnus-article-add-button\r\r
- start end (nth 3 entry)\r\r
- (buffer-substring (match-beginning (nth 4 entry))\r\r
- (match-end (nth 4 entry)))))))\r\r
- (goto-char end))))\r\r
- (widen)))\r\r
-\r\r
-;;; External functions:\r\r
-\r\r
-(defun gnus-article-add-button (from to fun &optional data)\r\r
- "Create a button between FROM and TO with callback FUN and data DATA."\r\r
- (when gnus-article-button-face\r\r
- (gnus-overlay-put (gnus-make-overlay from to)\r\r
- 'face gnus-article-button-face))\r\r
- (gnus-add-text-properties\r\r
- from to\r\r
- (nconc (and gnus-article-mouse-face\r\r
- (list gnus-mouse-face-prop gnus-article-mouse-face))\r\r
- (list 'gnus-callback fun)\r\r
- (and data (list 'gnus-data data)))))\r\r
-\r\r
-;;; Internal functions:\r\r
-\r\r
-(defun gnus-article-set-globals ()\r\r
- (save-excursion\r\r
- (set-buffer gnus-summary-buffer)\r\r
- (gnus-set-global-variables)))\r\r
-\r\r
-(defun gnus-signature-toggle (end)\r\r
- (save-excursion\r\r
- (set-buffer gnus-article-buffer)\r\r
- (let ((buffer-read-only nil)\r\r
- (inhibit-point-motion-hooks t))\r\r
- (if (get-text-property end 'invisible)\r\r
- (gnus-article-unhide-text end (point-max))\r\r
- (gnus-article-hide-text end (point-max) gnus-hidden-properties)))))\r\r
-\r\r
-(defun gnus-button-entry ()\r\r
- ;; Return the first entry in `gnus-button-alist' matching this place.\r\r
- (let ((alist gnus-button-alist)\r\r
- (entry nil))\r\r
- (while alist\r\r
- (setq entry (pop alist))\r\r
- (if (looking-at (car entry))\r\r
- (setq alist nil)\r\r
- (setq entry nil)))\r\r
- entry))\r\r
-\r\r
-(defun gnus-button-push (marker)\r\r
- ;; Push button starting at MARKER.\r\r
- (save-excursion\r\r
- (goto-char marker)\r\r
- (let* ((entry (gnus-button-entry))\r\r
- (inhibit-point-motion-hooks t)\r\r
- (fun (nth 3 entry))\r\r
- (args (mapcar (lambda (group)\r\r
- (let ((string (match-string group)))\r\r
- (gnus-set-text-properties\r\r
- 0 (length string) nil string)\r\r
- string))\r\r
- (nthcdr 4 entry))))\r\r
- (cond\r\r
- ((fboundp fun)\r\r
- (apply fun args))\r\r
- ((and (boundp fun)\r\r
- (fboundp (symbol-value fun)))\r\r
- (apply (symbol-value fun) args))\r\r
- (t\r\r
- (gnus-message 1 "You must define `%S' to use this button"\r\r
- (cons fun args)))))))\r\r
-\r\r
-(defun gnus-button-message-id (message-id)\r\r
- "Fetch MESSAGE-ID."\r\r
- (save-excursion\r\r
- (set-buffer gnus-summary-buffer)\r\r
- (gnus-summary-refer-article message-id)))\r\r
-\r\r
-(defun gnus-button-fetch-group (address)\r\r
- "Fetch GROUP specified by ADDRESS."\r\r
- (if (not (string-match "[:/]" address))\r\r
- ;; This is just a simple group url.\r\r
- (gnus-group-read-ephemeral-group address gnus-select-method)\r\r
- (if (not (string-match "^\\([^:/]+\\)\\(:\\([^/]+\\)/\\)?\\(.*\\)$"\r\r
- address))\r\r
- (error "Can't parse %s" address)\r\r
- (gnus-group-read-ephemeral-group\r\r
- (match-string 4 address)\r\r
- `(nntp ,(match-string 1 address)\r\r
- (nntp-address ,(match-string 1 address))\r\r
- (nntp-port-number ,(if (match-end 3)\r\r
- (match-string 3 address)\r\r
- "nntp")))))))\r\r
-\r\r
-(defun gnus-url-parse-query-string (query &optional downcase)\r\r
- (let (retval pairs cur key val)\r\r
- (setq pairs (split-string query "&"))\r\r
- (while pairs\r\r
- (setq cur (car pairs)\r\r
- pairs (cdr pairs))\r\r
- (if (not (string-match "=" cur))\r\r
- nil ; Grace\r\r
- (setq key (gnus-url-unhex-string (substring cur 0 (match-beginning 0)))\r\r
- val (gnus-url-unhex-string (substring cur (match-end 0) nil)))\r\r
- (if downcase\r\r
- (setq key (downcase key)))\r\r
- (setq cur (assoc key retval))\r\r
- (if cur\r\r
- (setcdr cur (cons val (cdr cur)))\r\r
- (setq retval (cons (list key val) retval)))))\r\r
- retval))\r\r
-\r\r
-(defun gnus-url-unhex (x)\r\r
- (if (> x ?9)\r\r
- (if (>= x ?a)\r\r
- (+ 10 (- x ?a))\r\r
- (+ 10 (- x ?A)))\r\r
- (- x ?0)))\r\r
-\r\r
-(defun gnus-url-unhex-string (str &optional allow-newlines)\r\r
- "Remove %XXX embedded spaces, etc in a url.\r\r
-If optional second argument ALLOW-NEWLINES is non-nil, then allow the\r\r
-decoding of carriage returns and line feeds in the string, which is normally\r\r
-forbidden in URL encoding."\r\r
- (setq str (or str ""))\r\r
- (let ((tmp "")\r\r
- (case-fold-search t))\r\r
- (while (string-match "%[0-9a-f][0-9a-f]" str)\r\r
- (let* ((start (match-beginning 0))\r\r
- (ch1 (gnus-url-unhex (elt str (+ start 1))))\r\r
- (code (+ (* 16 ch1)\r\r
- (gnus-url-unhex (elt str (+ start 2))))))\r\r
- (setq tmp (concat\r\r
- tmp (substring str 0 start)\r\r
- (cond\r\r
- (allow-newlines\r\r
- (char-to-string code))\r\r
- ((or (= code ?\n) (= code ?\r))\r\r
- " ")\r\r
- (t (char-to-string code))))\r\r
- str (substring str (match-end 0)))))\r\r
- (setq tmp (concat tmp str))\r\r
- tmp))\r\r
-\r\r
-(defun gnus-url-mailto (url)\r\r
- ;; Send mail to someone\r\r
- (when (string-match "mailto:/*\\(.*\\)" url)\r\r
- (setq url (substring url (match-beginning 1) nil)))\r\r
- (let (to args subject func)\r\r
- (if (string-match (regexp-quote "?") url)\r\r
- (setq to (gnus-url-unhex-string (substring url 0 (match-beginning 0)))\r\r
- args (gnus-url-parse-query-string\r\r
- (substring url (match-end 0) nil) t))\r\r
- (setq to (gnus-url-unhex-string url)))\r\r
- (setq args (cons (list "to" to) args)\r\r
- subject (cdr-safe (assoc "subject" args)))\r\r
- (gnus-setup-message 'reply\r\r
- (message-mail)\r\r
- (while args\r\r
- (setq func (intern-soft (concat "message-goto-" (downcase (caar args)))))\r\r
- (if (fboundp func)\r\r
- (funcall func)\r\r
- (message-position-on-field (caar args)))\r\r
- (insert (mapconcat 'identity (cdar args) ", "))\r\r
- (setq args (cdr args)))\r\r
- (if subject\r\r
- (message-goto-body)\r\r
- (message-goto-subject)))))\r\r
-\r\r
-(defun gnus-button-mailto (address)\r\r
- ;; Mail to ADDRESS.\r\r
- (set-buffer (gnus-copy-article-buffer))\r\r
- (gnus-setup-message 'reply\r\r
- (message-reply address)))\r\r
-\r\r
-(defun gnus-button-reply (address)\r\r
- ;; Reply to ADDRESS.\r\r
- (gnus-setup-message 'reply\r\r
- (message-reply address)))\r\r
-\r\r
-(defun gnus-button-url (address)\r\r
- "Browse ADDRESS."\r\r
- ;; In Emacs 20, `browse-url-browser-function' may be an alist.\r\r
- (if (listp browse-url-browser-function)\r\r
- (browse-url address)\r\r
- (funcall browse-url-browser-function address)))\r\r
-\r\r
-(defun gnus-button-embedded-url (address)\r\r
- "Browse ADDRESS."\r\r
- ;; In Emacs 20, `browse-url-browser-function' may be an alist.\r\r
- (if (listp browse-url-browser-function)\r\r
- (browse-url (gnus-strip-whitespace address))\r\r
- (funcall browse-url-browser-function (gnus-strip-whitespace address))))\r\r
-\r\r
-;;; Next/prev buttons in the article buffer.\r\r
-\r\r
-(defvar gnus-next-page-line-format "%{%(Next page...%)%}\n")\r\r
-(defvar gnus-prev-page-line-format "%{%(Previous page...%)%}\n")\r\r
-\r\r
-(defvar gnus-prev-page-map nil)\r\r
-(unless gnus-prev-page-map\r\r
- (setq gnus-prev-page-map (make-sparse-keymap))\r\r
- (define-key gnus-prev-page-map gnus-mouse-2 'gnus-button-prev-page)\r\r
- (define-key gnus-prev-page-map "\r" 'gnus-button-prev-page))\r\r
-\r\r
-(defun gnus-insert-prev-page-button ()\r\r
- (let ((buffer-read-only nil))\r\r
- (gnus-eval-format\r\r
- gnus-prev-page-line-format nil\r\r
- `(gnus-prev t local-map ,gnus-prev-page-map\r\r
- gnus-callback gnus-article-button-prev-page\r\r
- article-type annotation))))\r\r
-\r\r
-(defvar gnus-next-page-map nil)\r\r
-(unless gnus-next-page-map\r\r
- (setq gnus-next-page-map (make-keymap))\r\r
- (suppress-keymap gnus-prev-page-map)\r\r
- (define-key gnus-next-page-map gnus-mouse-2 'gnus-button-next-page)\r\r
- (define-key gnus-next-page-map "\r" 'gnus-button-next-page))\r\r
-\r\r
-(defun gnus-button-next-page ()\r\r
- "Go to the next page."\r\r
- (interactive)\r\r
- (let ((win (selected-window)))\r\r
- (select-window (get-buffer-window gnus-article-buffer t))\r\r
- (gnus-article-next-page)\r\r
- (select-window win)))\r\r
-\r\r
-(defun gnus-button-prev-page ()\r\r
- "Go to the prev page."\r\r
- (interactive)\r\r
- (let ((win (selected-window)))\r\r
- (select-window (get-buffer-window gnus-article-buffer t))\r\r
- (gnus-article-prev-page)\r\r
- (select-window win)))\r\r
-\r\r
-(defun gnus-insert-next-page-button ()\r\r
- (let ((buffer-read-only nil))\r\r
- (gnus-eval-format gnus-next-page-line-format nil\r\r
- `(gnus-next\r\r
- t local-map ,gnus-next-page-map\r\r
- gnus-callback gnus-article-button-next-page\r\r
- article-type annotation))))\r\r
-\r\r
-(defun gnus-article-button-next-page (arg)\r\r
- "Go to the next page."\r\r
- (interactive "P")\r\r
- (let ((win (selected-window)))\r\r
- (select-window (get-buffer-window gnus-article-buffer t))\r\r
- (gnus-article-next-page)\r\r
- (select-window win)))\r\r
-\r\r
-(defun gnus-article-button-prev-page (arg)\r\r
- "Go to the prev page."\r\r
- (interactive "P")\r\r
- (let ((win (selected-window)))\r\r
- (select-window (get-buffer-window gnus-article-buffer t))\r\r
- (gnus-article-prev-page)\r\r
- (select-window win)))\r\r
-\r\r
-(defvar gnus-decode-header-methods\r\r
- '(gnus-decode-with-mail-decode-encoded-word-region)\r\r
- "List of methods used to decode headers.\r\r
-\r\r
-This variable is a list of FUNCTION or (REGEXP . FUNCTION). If item is\r\r
-FUNCTION, FUNCTION will be apply to all newsgroups. If item is a\r\r
-(REGEXP . FUNCTION), FUNCTION will be only apply to thes newsgroups\r\r
-whose names match REGEXP.\r\r
-\r\r
-For example:\r\r
-((\"chinese\" . gnus-decode-encoded-word-region-by-guess)\r\r
- mail-decode-encoded-word-region\r\r
- (\"chinese\" . rfc1843-decode-region))\r\r
-")\r\r
-\r\r
-(defvar gnus-decode-header-methods-cache nil)\r\r
-\r\r
-(defun gnus-decode-with-mail-decode-encoded-word-region (start end)\r\r
- (let ((rfc2047-default-charset gnus-newsgroup-default-charset)\r\r
- (mm-charset-iso-8859-1-forced gnus-newsgroup-iso-8859-1-forced))\r\r
- (mail-decode-encoded-word-region start end)))\r\r
-\r\r
-(defun gnus-multi-decode-header (start end)\r\r
- "Apply the functions from `gnus-encoded-word-methods' that match."\r\r
- (unless (and gnus-decode-header-methods-cache\r\r
- (eq gnus-newsgroup-name\r\r
- (car gnus-decode-header-methods-cache)))\r\r
- (setq gnus-decode-header-methods-cache (list gnus-newsgroup-name))\r\r
- (mapc '(lambda (x)\r\r
- (if (symbolp x)\r\r
- (nconc gnus-decode-header-methods-cache (list x))\r\r
- (if (and gnus-newsgroup-name\r\r
- (string-match (car x) gnus-newsgroup-name))\r\r
- (nconc gnus-decode-header-methods-cache\r\r
- (list (cdr x))))))\r\r
- gnus-decode-header-methods))\r\r
- (let ((xlist gnus-decode-header-methods-cache))\r\r
- (pop xlist)\r\r
- (save-restriction\r\r
- (narrow-to-region start end)\r\r
- (while xlist\r\r
- (funcall (pop xlist) (point-min) (point-max))))))\r\r
-\r\r
-\r\r
-;;; @ for mime-view\r\r
-;;;\r\r
-\r\r
-(defun gnus-article-header-presentation-method (entity situation)\r\r
- (mime-insert-header entity)\r\r
- )\r\r
-\r\r
-(set-alist 'mime-header-presentation-method-alist\r\r
- 'gnus-original-article-mode\r\r
- #'gnus-article-header-presentation-method)\r\r
-\r\r
-(defun gnus-mime-preview-quitting-method ()\r\r
- (if gnus-show-mime\r\r
- (gnus-article-show-summary)\r\r
- (mime-preview-kill-buffer)\r\r
- (delete-other-windows)\r\r
- (gnus-article-show-summary)\r\r
- (gnus-summary-select-article nil t)\r\r
- ))\r\r
-\r\r
-(set-alist 'mime-preview-quitting-method-alist\r\r
- 'gnus-original-article-mode #'gnus-mime-preview-quitting-method)\r\r
-\r\r
-(defun gnus-following-method (buf)\r\r
- (set-buffer buf)\r\r
- (message-followup)\r\r
- (message-yank-original)\r\r
- (kill-buffer buf)\r\r
- (goto-char (point-min))\r\r
- )\r\r
-\r\r
-(set-alist 'mime-preview-following-method-alist\r\r
- 'gnus-original-article-mode #'gnus-following-method)\r\r
-\r\r
-\r\r
-;;; @ end\r\r
-;;;\r\r
-\r\r
-(gnus-ems-redefine)\r\r
-\r\r
-(provide 'gnus-art)\r\r
-\r\r
-(run-hooks 'gnus-art-load-hook)\r\r
-\r\r
-;;; gnus-art.el ends here\r\r
+;;; gnus-art.el --- article mode commands for Semi-gnus
+;; Copyright (C) 1996,97,98 Free Software Foundation, Inc.
+
+;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
+;; MORIOKA Tomohiko <morioka@jaist.ac.jp>
+;; Katsumi Yamaoka <yamaoka@jpl.org>
+;; Keywords: mail, news, MIME
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;;; Code:
+
+(eval-when-compile (require 'cl))
+
+(require 'custom)
+(require 'gnus)
+(require 'gnus-sum)
+(require 'gnus-spec)
+(require 'gnus-int)
+(require 'browse-url)
+(require 'alist)
+(require 'mime-view)
+
+;; Avoid byte-compile warnings.
+(eval-when-compile
+ (defvar gnus-article-decoded-p)
+ (defvar gnus-article-mime-handles)
+ (require 'mm-bodies)
+ (require 'mail-parse)
+ (require 'mm-decode)
+ (require 'mm-view)
+ (require 'wid-edit)
+ (require 'mm-uu)
+ )
+
+(defgroup gnus-article nil
+ "Article display."
+ :link '(custom-manual "(gnus)The Article Buffer")
+ :group 'gnus)
+
+(defgroup gnus-article-hiding nil
+ "Hiding article parts."
+ :link '(custom-manual "(gnus)Article Hiding")
+ :group 'gnus-article)
+
+(defgroup gnus-article-highlight nil
+ "Article highlighting."
+ :link '(custom-manual "(gnus)Article Highlighting")
+ :group 'gnus-article
+ :group 'gnus-visual)
+
+(defgroup gnus-article-signature nil
+ "Article signatures."
+ :link '(custom-manual "(gnus)Article Signature")
+ :group 'gnus-article)
+
+(defgroup gnus-article-headers nil
+ "Article headers."
+ :link '(custom-manual "(gnus)Hiding Headers")
+ :group 'gnus-article)
+
+(defgroup gnus-article-washing nil
+ "Special commands on articles."
+ :link '(custom-manual "(gnus)Article Washing")
+ :group 'gnus-article)
+
+(defgroup gnus-article-emphasis nil
+ "Fontisizing articles."
+ :link '(custom-manual "(gnus)Article Fontisizing")
+ :group 'gnus-article)
+
+(defgroup gnus-article-saving nil
+ "Saving articles."
+ :link '(custom-manual "(gnus)Saving Articles")
+ :group 'gnus-article)
+
+(defgroup gnus-article-mime nil
+ "Worshiping the MIME wonder."
+ :link '(custom-manual "(gnus)Using MIME")
+ :group 'gnus-article)
+
+(defgroup gnus-article-buttons nil
+ "Pushable buttons in the article buffer."
+ :link '(custom-manual "(gnus)Article Buttons")
+ :group 'gnus-article)
+
+(defgroup gnus-article-various nil
+ "Other article options."
+ :link '(custom-manual "(gnus)Misc Article")
+ :group 'gnus-article)
+
+(defcustom gnus-ignored-headers
+ '("^Path:" "^Expires:" "^Date-Received:" "^References:" "^Xref:" "^Lines:"
+ "^Relay-Version:" "^Message-ID:" "^Approved:" "^Sender:" "^Received:"
+ "^X-UIDL:" "^MIME-Version:" "^Return-Path:" "^In-Reply-To:"
+ "^Content-Type:" "^Content-Transfer-Encoding:" "^X-WebTV-Signature:"
+ "^X-MimeOLE:" "^X-MSMail-Priority:" "^X-Priority:" "^X-Loop:"
+ "^X-Authentication-Warning:" "^X-MIME-Autoconverted:" "^X-Face:"
+ "^X-Attribution:" "^X-Originating-IP:" "^Delivered-To:"
+ "^NNTP-[-A-Za-z]+:" "^Distribution:" "^X-no-archive:" "^X-Trace:"
+ "^X-Complaints-To:" "^X-NNTP-Posting-Host:" "^X-Orig.*:"
+ "^Abuse-Reports-To:" "^Cache-Post-Path:" "^X-Article-Creation-Date:"
+ "^X-Poster:" "^X-Mail2News-Path:" "^X-Server-Date:" "^X-Cache:"
+ "^Originator:" "^X-Problems-To:" "^X-Auth-User:" "^X-Post-Time:"
+ "^X-Admin:" "^X-UID:" "^Resent-[-A-Za-z]+:" "^X-Mailing-List:"
+ "^Precedence:" "^Original-[-A-Za-z]+:" "^X-filename:" "^X-Orcpt:"
+ "^Old-Received:" "^X-Pgp-Fingerprint:" "^X-Pgp-Key-Id:"
+ "^X-Pgp-Public-Key-Url:" "^X-Auth:" "^X-From-Line:"
+ "^X-Gnus-Article-Number:" "^X-Majordomo:" "^X-Url:" "^X-Sender:"
+ "^X-Mailing-List:" "^MBOX-Line" "^Priority:" "^X-Pgp" "^X400-[-A-Za-z]+:"
+ "^Status:")
+ "*All headers that start with this regexp will be hidden.
+This variable can also be a list of regexps of headers to be ignored.
+If `gnus-visible-headers' is non-nil, this variable will be ignored."
+ :type '(choice :custom-show nil
+ regexp
+ (repeat regexp))
+ :group 'gnus-article-hiding)
+
+(defcustom gnus-visible-headers
+ "From:\\|^Newsgroups:\\|^Subject:\\|^Date:\\|^\\(Mail-\\)?Followup-To:\\|^\\(Mail-\\)?Reply-To:\\|^Mail-Copies-To:\\|^Organization:\\|^Summary:\\|^Keywords:\\|^To:\\|^Cc:\\|^Posted-To:\\|^Apparently-To:\\|^Gnus-Warning:\\|^Resent-From:\\|X-Sent:"
+ "*All headers that do not match this regexp will be hidden.
+This variable can also be a list of regexp of headers to remain visible.
+If this variable is non-nil, `gnus-ignored-headers' will be ignored."
+ :type '(repeat :value-to-internal (lambda (widget value)
+ (custom-split-regexp-maybe value))
+ :match (lambda (widget value)
+ (or (stringp value)
+ (widget-editable-list-match widget value)))
+ regexp)
+ :group 'gnus-article-hiding)
+
+(defcustom gnus-sorted-header-list
+ '("^From:" "^Subject:" "^Summary:" "^Keywords:" "^Newsgroups:"
+ "^Followup-To:" "^To:" "^Cc:" "^Date:" "^Organization:")
+ "*This variable is a list of regular expressions.
+If it is non-nil, headers that match the regular expressions will
+be placed first in the article buffer in the sequence specified by
+this list."
+ :type '(repeat regexp)
+ :group 'gnus-article-hiding)
+
+(defcustom gnus-boring-article-headers '(empty followup-to reply-to)
+ "Headers that are only to be displayed if they have interesting data.
+Possible values in this list are `empty', `newsgroups', `followup-to',
+`reply-to', `date', `long-to', and `many-to'."
+ :type '(set (const :tag "Headers with no content." empty)
+ (const :tag "Newsgroups with only one group." newsgroups)
+ (const :tag "Followup-to identical to newsgroups." followup-to)
+ (const :tag "Reply-to identical to from." reply-to)
+ (const :tag "Date less than four days old." date)
+ (const :tag "Very long To header." long-to)
+ (const :tag "Multiple To headers." many-to))
+ :group 'gnus-article-hiding)
+
+(defcustom gnus-signature-separator '("^-- $" "^-- *$")
+ "Regexp matching signature separator.
+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)
+ :group 'gnus-article-signature)
+
+(defcustom gnus-signature-limit nil
+ "Provide a limit to what is considered a signature.
+If it is a number, no signature may not be longer (in characters) than
+that number. If it is a floating point number, no signature may be
+longer (in lines) than that number. If it is a function, the function
+will be called without any parameters, and if it returns nil, there is
+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."
+ :type '(choice (integer :value 200)
+ (number :value 4.0)
+ (function :value fun)
+ (regexp :value ".*"))
+ :group 'gnus-article-signature)
+
+(defcustom gnus-hidden-properties '(invisible t intangible t)
+ "Property list to use for hiding text."
+ :type 'sexp
+ :group 'gnus-article-hiding)
+
+(defcustom gnus-article-x-face-command
+ "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | xv -quit -"
+ "*String or function to be executed to display an X-Face header.
+If it is a string, the command will be executed in a sub-shell
+asynchronously. The compressed face will be piped to this command."
+ :type 'string ;Leave function case to Lisp.
+ :group 'gnus-article-washing)
+
+(defcustom gnus-article-x-face-too-ugly nil
+ "Regexp matching posters whose face shouldn't be shown automatically."
+ :type '(choice regexp (const nil))
+ :group 'gnus-article-washing)
+
+(defcustom gnus-emphasis-alist
+ (let ((format
+ "\\(\\s-\\|^\\|[-\"]\\|\\s(\\|\\s)\\)\\(%s\\(\\w+\\(\\s-+\\w+\\)*[.,]?\\)%s\\)\\(\\s-\\|[-?!.,;:\"]\\|\\s(\\|\\s)\\)")
+ (types
+ '(("_" "_" underline)
+ ("/" "/" italic)
+ ("\\*" "\\*" bold)
+ ("_/" "/_" underline-italic)
+ ("_\\*" "\\*_" underline-bold)
+ ("\\*/" "/\\*" bold-italic)
+ ("_\\*/" "/\\*_" underline-bold-italic))))
+ `(("\\(\\s-\\|^\\)\\(_\\(\\(\\w\\|_[^_]\\)+\\)_\\)\\(\\s-\\|[?!.,;]\\)"
+ 2 3 gnus-emphasis-underline)
+ ,@(mapcar
+ (lambda (spec)
+ (list
+ (format format (car spec) (cadr spec))
+ 2 3 (intern (format "gnus-emphasis-%s" (nth 2 spec)))))
+ types)))
+ "*Alist that says how to fontify certain phrases.
+Each item looks like this:
+
+ (\"_\\\\(\\\\w+\\\\)_\" 0 1 'underline)
+
+The first element is a regular expression to be matched. The second
+is a number that says what regular expression grouping used to find
+the entire emphasized word. The third is a number that says what
+regexp grouping should be displayed and highlighted. The fourth
+is the face used for highlighting."
+ :type '(repeat (list :value ("" 0 0 default)
+ regexp
+ (integer :tag "Match group")
+ (integer :tag "Emphasize group")
+ face))
+ :group 'gnus-article-emphasis)
+
+(defface gnus-emphasis-bold '((t (:bold t)))
+ "Face used for displaying strong emphasized text (*word*)."
+ :group 'gnus-article-emphasis)
+
+(defface gnus-emphasis-italic '((t (:italic t)))
+ "Face used for displaying italic emphasized text (/word/)."
+ :group 'gnus-article-emphasis)
+
+(defface gnus-emphasis-underline '((t (:underline t)))
+ "Face used for displaying underlined emphasized text (_word_)."
+ :group 'gnus-article-emphasis)
+
+(defface gnus-emphasis-underline-bold '((t (:bold t :underline t)))
+ "Face used for displaying underlined bold emphasized text (_*word*_)."
+ :group 'gnus-article-emphasis)
+
+(defface gnus-emphasis-underline-italic '((t (:italic t :underline t)))
+ "Face used for displaying underlined italic emphasized text (_*word*_)."
+ :group 'gnus-article-emphasis)
+
+(defface gnus-emphasis-bold-italic '((t (:bold t :italic t)))
+ "Face used for displaying bold italic emphasized text (/*word*/)."
+ :group 'gnus-article-emphasis)
+
+(defface gnus-emphasis-underline-bold-italic
+ '((t (:bold t :italic t :underline t)))
+ "Face used for displaying underlined bold italic emphasized text.
+Esample: (_/*word*/_)."
+ :group 'gnus-article-emphasis)
+
+(defcustom gnus-article-time-format "%a, %b %d %Y %T %Z"
+ "Format for display of Date headers in article bodies.
+See `format-time-string' for the possible values.
+
+The variable can also be function, which should return a complete Date
+header. The function is called with one argument, the time, which can
+be fed to `format-time-string'."
+ :type '(choice string symbol)
+ :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
+ :type 'boolean)
+
+(defcustom gnus-prompt-before-saving 'always
+ "*This variable says how much prompting is to be done when saving articles.
+If it is nil, no prompting will be done, and the articles will be
+saved to the default files. If this variable is `always', each and
+every article that is saved will be preceded by a prompt, even when
+saving large batches of articles. If this variable is neither nil not
+`always', there the user will be prompted once for a file name for
+each invocation of the saving commands."
+ :group 'gnus-article-saving
+ :type '(choice (item always)
+ (item :tag "never" nil)
+ (sexp :tag "once" :format "%t\n" :value t)))
+
+(defcustom gnus-saved-headers gnus-visible-headers
+ "Headers to keep if `gnus-save-all-headers' is nil.
+If `gnus-save-all-headers' is non-nil, this variable will be ignored.
+If that variable is nil, however, all headers that match this regexp
+will be kept while the rest will be deleted before saving."
+ :group 'gnus-article-saving
+ :type 'regexp)
+
+(defcustom gnus-default-article-saver 'gnus-summary-save-in-rmail
+ "A function to save articles in your favourite format.
+The function must be interactively callable (in other words, it must
+be an Emacs command).
+
+Gnus provides the following functions:
+
+* gnus-summary-save-in-rmail (Rmail format)
+* gnus-summary-save-in-mail (Unix mail format)
+* gnus-summary-save-in-folder (MH folder)
+* gnus-summary-save-in-file (article format)
+* gnus-summary-save-in-vm (use VM's folder format)
+* gnus-summary-write-to-file (article format -- overwrite)."
+ :group 'gnus-article-saving
+ :type '(radio (function-item gnus-summary-save-in-rmail)
+ (function-item gnus-summary-save-in-mail)
+ (function-item gnus-summary-save-in-folder)
+ (function-item gnus-summary-save-in-file)
+ (function-item gnus-summary-save-in-vm)
+ (function-item gnus-summary-write-to-file)))
+
+(defcustom gnus-rmail-save-name 'gnus-plain-save-name
+ "A function generating a file name to save articles in Rmail format.
+The function is called with NEWSGROUP, HEADERS, and optional LAST-FILE."
+ :group 'gnus-article-saving
+ :type 'function)
+
+(defcustom gnus-mail-save-name 'gnus-plain-save-name
+ "A function generating a file name to save articles in Unix mail format.
+The function is called with NEWSGROUP, HEADERS, and optional LAST-FILE."
+ :group 'gnus-article-saving
+ :type 'function)
+
+(defcustom gnus-folder-save-name 'gnus-folder-save-name
+ "A function generating a file name to save articles in MH folder.
+The function is called with NEWSGROUP, HEADERS, and optional LAST-FOLDER."
+ :group 'gnus-article-saving
+ :type 'function)
+
+(defcustom gnus-file-save-name 'gnus-numeric-save-name
+ "A function generating a file name to save articles in article format.
+The function is called with NEWSGROUP, HEADERS, and optional
+LAST-FILE."
+ :group 'gnus-article-saving
+ :type 'function)
+
+(defcustom gnus-split-methods
+ '((gnus-article-archive-name)
+ (gnus-article-nndoc-name))
+ "*Variable used to suggest where articles are to be saved.
+For instance, if you would like to save articles related to Gnus in
+the file \"gnus-stuff\", and articles related to VM in \"vm-stuff\",
+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.
+
+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.
+
+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))
+ (sexp :value nil))))
+
+(defcustom gnus-article-display-method-for-mime
+ 'gnus-article-display-mime-message
+ "Function to display a MIME message.
+The function is called from the article buffer."
+ :group 'gnus-article-mime
+ :type 'function)
+
+(defcustom gnus-article-display-method-for-traditional
+ 'gnus-article-display-traditional-message
+ "*Function to display a traditional message.
+The function is called from the article buffer."
+ :group 'gnus-article-mime
+ :type 'function)
+
+(defcustom gnus-page-delimiter "^\^L"
+ "*Regexp describing what to use as article page delimiters.
+The default value is \"^\^L\", which is a form linefeed at the
+beginning of a line."
+ :type 'regexp
+ :group 'gnus-article-various)
+
+(defcustom gnus-article-mode-line-format "Gnus: %g %S%m"
+ "*The format specification for the article mode line.
+See `gnus-summary-mode-line-format' for a closer description.
+
+The following additional specs are available:
+
+%w The article washing status.
+%m The number of MIME parts in the article."
+ :type 'string
+ :group 'gnus-article-various)
+
+(defcustom gnus-article-mode-hook nil
+ "*A hook for Gnus article mode."
+ :type 'hook
+ :group 'gnus-article-various)
+
+(defcustom gnus-article-menu-hook nil
+ "*Hook run after the creation of the article mode menu."
+ :type 'hook
+ :group 'gnus-article-various)
+
+(defcustom gnus-article-prepare-hook nil
+ "*A hook called after an article has been prepared in the article buffer.
+If you want to run a special decoding program like nkf, use this hook."
+ :type 'hook
+ :group 'gnus-article-various)
+
+(defcustom gnus-article-hide-pgp-hook nil
+ "*A hook called after successfully hiding a PGP signature."
+ :type 'hook
+ :group 'gnus-article-various)
+
+(defcustom gnus-article-button-face 'bold
+ "Face used for highlighting buttons in the article buffer.
+
+An article button is a piece of text that you can activate by pressing
+`RET' or `mouse-2' above it."
+ :type 'face
+ :group 'gnus-article-buttons)
+
+(defcustom gnus-article-mouse-face 'highlight
+ "Face used for mouse highlighting in the article buffer.
+
+Article buttons will be displayed in this face when the cursor is
+above them."
+ :type 'face
+ :group 'gnus-article-buttons)
+
+(defcustom gnus-signature-face 'gnus-signature-face
+ "Face used for highlighting a signature in the article buffer.
+Obsolete; use the face `gnus-signature-face' for customizations instead."
+ :type 'face
+ :group 'gnus-article-highlight
+ :group 'gnus-article-signature)
+
+(defface gnus-signature-face
+ '((((type x))
+ (:italic t)))
+ "Face used for highlighting a signature in the article buffer."
+ :group 'gnus-article-highlight
+ :group 'gnus-article-signature)
+
+(defface gnus-header-from-face
+ '((((class color)
+ (background dark))
+ (:foreground "spring green"))
+ (((class color)
+ (background light))
+ (:foreground "red3"))
+ (t
+ (:italic t)))
+ "Face used for displaying from headers."
+ :group 'gnus-article-headers
+ :group 'gnus-article-highlight)
+
+(defface gnus-header-subject-face
+ '((((class color)
+ (background dark))
+ (:foreground "SeaGreen3"))
+ (((class color)
+ (background light))
+ (:foreground "red4"))
+ (t
+ (:bold t :italic t)))
+ "Face used for displaying subject headers."
+ :group 'gnus-article-headers
+ :group 'gnus-article-highlight)
+
+(defface gnus-header-newsgroups-face
+ '((((class color)
+ (background dark))
+ (:foreground "yellow" :italic t))
+ (((class color)
+ (background light))
+ (:foreground "MidnightBlue" :italic t))
+ (t
+ (:italic t)))
+ "Face used for displaying newsgroups headers."
+ :group 'gnus-article-headers
+ :group 'gnus-article-highlight)
+
+(defface gnus-header-name-face
+ '((((class color)
+ (background dark))
+ (:foreground "SeaGreen"))
+ (((class color)
+ (background light))
+ (:foreground "maroon"))
+ (t
+ (:bold t)))
+ "Face used for displaying header names."
+ :group 'gnus-article-headers
+ :group 'gnus-article-highlight)
+
+(defface gnus-header-content-face
+ '((((class color)
+ (background dark))
+ (:foreground "forest green" :italic t))
+ (((class color)
+ (background light))
+ (:foreground "indianred4" :italic t))
+ (t
+ (:italic t))) "Face used for displaying header content."
+ :group 'gnus-article-headers
+ :group 'gnus-article-highlight)
+
+(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))
+ "*Controls highlighting of article header.
+
+An alist of the form (HEADER NAME CONTENT).
+
+HEADER is a regular expression which should match the name of an
+header header and NAME and CONTENT are either face names or nil.
+
+The name of each header field will be displayed using the face
+specified by the first element in the list where HEADER match the
+header name and NAME is non-nil. Similarly, the content will be
+displayed by the first non-nil matching CONTENT face."
+ :group 'gnus-article-headers
+ :group 'gnus-article-highlight
+ :type '(repeat (list (regexp :tag "Header")
+ (choice :tag "Name"
+ (item :tag "skip" nil)
+ (face :value default))
+ (choice :tag "Content"
+ (item :tag "skip" nil)
+ (face :value default)))))
+
+(defcustom gnus-article-decode-hook nil
+ "*Hook run to decode charsets in articles."
+ :group 'gnus-article-headers
+ :type 'hook)
+
+(defcustom gnus-display-mime-function 'gnus-display-mime
+ "Function to display MIME articles."
+ :group 'gnus-article-mime
+ :type 'function)
+
+(defvar gnus-decode-header-function 'mail-decode-encoded-word-region
+ "Function used to decode headers.")
+
+(defvar gnus-article-dumbquotes-map
+ '(("\202" ",")
+ ("\203" "f")
+ ("\204" ",,")
+ ("\205" "...")
+ ("\213" "<")
+ ("\214" "OE")
+ ("\205" "...")
+ ("\221" "`")
+ ("\222" "'")
+ ("\223" "``")
+ ("\224" "''")
+ ("\225" "*")
+ ("\226" "-")
+ ("\227" "-")
+ ("\231" "(TM)")
+ ("\233" ">")
+ ("\234" "oe")
+ ("\264" "'"))
+ "Table for MS-to-Latin1 translation.")
+
+(defcustom gnus-ignored-mime-types nil
+ "List of MIME types that should be ignored by Gnus."
+ :group 'gnus-article-mime
+ :type '(repeat regexp))
+
+(defcustom gnus-unbuttonized-mime-types '(".*/.*")
+ "List of MIME types that should not be given buttons when rendered."
+ :group 'gnus-article-mime
+ :type '(repeat regexp))
+
+(defcustom gnus-treat-body-highlight-signature t
+ "Highlight the signature."
+ :group 'gnus-article
+ :type '(choice (const :tag "Off" nil)
+ (const :tag "On" t)
+ (const :tag "Last" last)
+ (integer :tag "Less")
+ (sexp :tag "Predicate")))
+
+(defcustom gnus-article-mime-part-function nil
+ "Function called with a MIME handle as the argument."
+ :group 'gnus-article-mime
+ :type 'function)
+
+;;; Internal variables
+
+(defvar gnus-article-mime-handle-alist-1 nil)
+(defvar gnus-treatment-function-alist
+ '((gnus-treat-body-highlight-signature gnus-article-highlight-signature nil)
+ ))
+
+(defvar gnus-article-mime-handle-alist nil)
+(defvar article-lapsed-timer nil)
+(defvar gnus-article-current-summary nil)
+
+(defvar gnus-article-mode-syntax-table
+ (let ((table (copy-syntax-table text-mode-syntax-table)))
+ (modify-syntax-entry ?- "w" table)
+ (modify-syntax-entry ?> ")" table)
+ (modify-syntax-entry ?< "(" table)
+ table)
+ "Syntax table used in article mode buffers.
+Initialized from `text-mode-syntax-table.")
+
+(defvar gnus-save-article-buffer nil)
+
+(defvar gnus-article-mode-line-format-alist
+ (nconc '((?w (gnus-article-wash-status) ?s)
+ (?m (gnus-article-mime-part-status) ?s))
+ gnus-summary-mode-line-format-alist))
+
+(defvar gnus-number-of-articles-to-be-saved nil)
+
+(defvar gnus-inhibit-hiding nil)
+
+(defsubst gnus-article-hide-text (b e props)
+ "Set text PROPS on the B to E region, extending `intangible' 1 past B."
+ (add-text-properties b e props)
+ (when (memq 'intangible props)
+ (put-text-property
+ (max (1- b) (point-min))
+ b 'intangible (cddr (memq 'intangible props)))))
+
+(defmacro gnus-with-article (article &rest forms)
+ "Select ARTICLE and perform FORMS in the original article buffer.
+Then replace the article with the result."
+ `(progn
+ ;; We don't want the article to be marked as read.
+ (let (gnus-mark-article-hook)
+ (gnus-summary-select-article t t nil ,article))
+ (set-buffer gnus-original-article-buffer)
+ ,@forms
+ (if (not (gnus-check-backend-function
+ 'request-replace-article (car gnus-article-current)))
+ (gnus-message 5 "Read-only group; not replacing")
+ (unless (gnus-request-replace-article
+ ,article (car gnus-article-current)
+ (current-buffer) t)
+ (error "Couldn't replace article")))
+ ;; The cache and backlog have to be flushed somewhat.
+ (when gnus-keep-backlog
+ (gnus-backlog-remove-article
+ (car gnus-article-current) (cdr gnus-article-current)))
+ (when gnus-use-cache
+ (gnus-cache-update-article
+ (car gnus-article-current) (cdr gnus-article-current)))))
+
+(put 'gnus-with-article 'lisp-indent-function 1)
+(put 'gnus-with-article 'edebug-form-spec '(form body))
+
+(defsubst gnus-article-unhide-text (b e)
+ "Remove hidden text properties from region between B and E."
+ (remove-text-properties b e gnus-hidden-properties)
+ (when (memq 'intangible gnus-hidden-properties)
+ (put-text-property (max (1- b) (point-min))
+ b 'intangible nil)))
+
+(defun gnus-article-hide-text-type (b e type)
+ "Hide text of TYPE between B and E."
+ (gnus-article-hide-text
+ b e (cons 'article-type (cons type gnus-hidden-properties))))
+
+(defun gnus-article-unhide-text-type (b e type)
+ "Unhide text of TYPE between B and E."
+ (remove-text-properties
+ b e (cons 'article-type (cons type gnus-hidden-properties)))
+ (when (memq 'intangible gnus-hidden-properties)
+ (put-text-property (max (1- b) (point-min))
+ b 'intangible nil)))
+
+(defun gnus-article-hide-text-of-type (type)
+ "Hide text of TYPE in the current buffer."
+ (save-excursion
+ (let ((b (point-min))
+ (e (point-max)))
+ (while (setq b (text-property-any b e 'article-type type))
+ (add-text-properties b (incf b) gnus-hidden-properties)))))
+
+(defun gnus-article-delete-text-of-type (type)
+ "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)))))))
+
+(defun gnus-article-delete-invisible-text ()
+ "Delete all invisible text in the current buffer."
+ (save-excursion
+ (let ((b (point-min)))
+ (while (setq b (text-property-any b (point-max) 'invisible t))
+ (delete-region
+ b (or (text-property-not-all b (point-max) 'invisible t)
+ (point-max)))))))
+
+(defun gnus-article-text-type-exists-p (type)
+ "Say whether any text of type TYPE exists in the buffer."
+ (text-property-any (point-min) (point-max) 'article-type type))
+
+(defsubst gnus-article-header-rank ()
+ "Give the rank of the string HEADER as given by `gnus-sorted-header-list'."
+ (let ((list gnus-sorted-header-list)
+ (i 0))
+ (while list
+ (when (looking-at (car list))
+ (setq list nil))
+ (setq list (cdr list))
+ (incf i))
+ i))
+
+(defun article-hide-headers (&optional arg delete)
+ "Toggle whether to hide unwanted headers and possibly sort them as well.
+If given a negative prefix, always show; if given a positive prefix,
+always hide."
+ (interactive (gnus-article-hidden-arg))
+ (current-buffer)
+ (if (gnus-article-check-hidden-text 'headers arg)
+ ;; Show boring headers as well.
+ (gnus-article-show-hidden-text 'boring-headers)
+ ;; This function might be inhibited.
+ (unless gnus-inhibit-hiding
+ (save-excursion
+ (save-restriction
+ (let ((buffer-read-only nil)
+ (case-fold-search t)
+ (props (nconc (list 'article-type 'headers)
+ gnus-hidden-properties))
+ (max (1+ (length gnus-sorted-header-list)))
+ (ignored (when (not gnus-visible-headers)
+ (cond ((stringp gnus-ignored-headers)
+ gnus-ignored-headers)
+ ((listp gnus-ignored-headers)
+ (mapconcat 'identity gnus-ignored-headers
+ "\\|")))))
+ (visible
+ (cond ((stringp gnus-visible-headers)
+ gnus-visible-headers)
+ ((and gnus-visible-headers
+ (listp gnus-visible-headers))
+ (mapconcat 'identity gnus-visible-headers "\\|"))))
+ (inhibit-point-motion-hooks t)
+ beg)
+ ;; First we narrow to just the headers.
+ (widen)
+ (goto-char (point-min))
+ ;; Hide any "From " lines at the beginning of (mail) articles.
+ (while (looking-at "From ")
+ (forward-line 1))
+ (unless (bobp)
+ (if delete
+ (delete-region (point-min) (point))
+ (gnus-article-hide-text (point-min) (point) props)))
+ ;; Then treat the rest of the header lines.
+ (narrow-to-region
+ (point)
+ (if (search-forward "\n\n" nil t) ; if there's a body
+ (progn (forward-line -1) (point))
+ (point-max)))
+ ;; Then we use the two regular expressions
+ ;; `gnus-ignored-headers' and `gnus-visible-headers' to
+ ;; select which header lines is to remain visible in the
+ ;; article buffer.
+ (goto-char (point-min))
+ (while (re-search-forward "^[^ \t]*:" nil t)
+ (beginning-of-line)
+ ;; Mark the rank of the header.
+ (put-text-property
+ (point) (1+ (point)) 'message-rank
+ (if (or (and visible (looking-at visible))
+ (and ignored
+ (not (looking-at ignored))))
+ (gnus-article-header-rank)
+ (+ 2 max)))
+ (forward-line 1))
+ (message-sort-headers-1)
+ (when (setq beg (text-property-any
+ (point-min) (point-max) 'message-rank (+ 2 max)))
+ ;; We make the unwanted headers invisible.
+ (if delete
+ (delete-region beg (point-max))
+ ;; Suggested by Sudish Joseph <joseph@cis.ohio-state.edu>.
+ (gnus-article-hide-text-type beg (point-max) 'headers))
+ ;; Work around XEmacs lossage.
+ (put-text-property (point-min) beg 'invisible nil))))))))
+
+(defun article-hide-boring-headers (&optional arg)
+ "Toggle hiding of headers that aren't very interesting.
+If given a negative prefix, always show; if given a positive prefix,
+always hide."
+ (interactive (gnus-article-hidden-arg))
+ (when (and (not (gnus-article-check-hidden-text 'boring-headers arg))
+ (not gnus-show-all-headers))
+ (save-excursion
+ (save-restriction
+ (let ((buffer-read-only nil)
+ (list gnus-boring-article-headers)
+ (inhibit-point-motion-hooks t)
+ elem)
+ (nnheader-narrow-to-headers)
+ (while list
+ (setq elem (pop list))
+ (goto-char (point-min))
+ (cond
+ ;; Hide empty headers.
+ ((eq elem 'empty)
+ (while (re-search-forward "^[^:]+:[ \t]*\n[^ \t]" nil t)
+ (forward-line -1)
+ (gnus-article-hide-text-type
+ (progn (beginning-of-line) (point))
+ (progn
+ (end-of-line)
+ (if (re-search-forward "^[^ \t]" nil t)
+ (match-beginning 0)
+ (point-max)))
+ 'boring-headers)))
+ ;; Hide boring Newsgroups header.
+ ((eq elem 'newsgroups)
+ (when (equal (gnus-fetch-field "newsgroups")
+ (gnus-group-real-name
+ (if (boundp 'gnus-newsgroup-name)
+ gnus-newsgroup-name
+ "")))
+ (gnus-article-hide-header "newsgroups")))
+ ((eq elem 'followup-to)
+ (when (equal (message-fetch-field "followup-to")
+ (message-fetch-field "newsgroups"))
+ (gnus-article-hide-header "followup-to")))
+ ((eq elem 'reply-to)
+ (let ((from (message-fetch-field "from"))
+ (reply-to (message-fetch-field "reply-to")))
+ (when (and
+ from reply-to
+ (ignore-errors
+ (equal
+ (nth 1 (funcall gnus-extract-address-components from))
+ (nth 1 (funcall gnus-extract-address-components reply-to)))))
+ (gnus-article-hide-header "reply-to"))))
+ ((eq elem 'date)
+ (let ((date (message-fetch-field "date")))
+ (when (and date
+ (< (days-between (current-time-string) date)
+ 4))
+ (gnus-article-hide-header "date"))))
+ ((eq elem 'long-to)
+ (let ((to (message-fetch-field "to")))
+ (when (> (length to) 1024)
+ (gnus-article-hide-header "to"))))
+ ((eq elem 'many-to)
+ (let ((to-count 0))
+ (goto-char (point-min))
+ (while (re-search-forward "^to:" nil t)
+ (setq to-count (1+ to-count)))
+ (when (> to-count 1)
+ (while (> to-count 0)
+ (goto-char (point-min))
+ (save-restriction
+ (re-search-forward "^to:" nil nil to-count)
+ (forward-line -1)
+ (narrow-to-region (point) (point-max))
+ (gnus-article-hide-header "to"))
+ (setq to-count (1- to-count)))))))))))))
+
+(defun gnus-article-hide-header (header)
+ (save-excursion
+ (goto-char (point-min))
+ (when (re-search-forward (concat "^" header ":") nil t)
+ (gnus-article-hide-text-type
+ (progn (beginning-of-line) (point))
+ (progn
+ (end-of-line)
+ (if (re-search-forward "^[^ \t]" nil t)
+ (match-beginning 0)
+ (point-max)))
+ 'boring-headers))))
+
+(defvar gnus-article-normalized-header-length 40
+ "Length of normalized headers.")
+
+(defun article-normalize-headers ()
+ "Make all header lines 40 characters long."
+ (interactive)
+ (let ((buffer-read-only nil)
+ column)
+ (save-excursion
+ (save-restriction
+ (message-narrow-to-head)
+ (while (not (eobp))
+ (cond
+ ((< (setq column (- (gnus-point-at-eol) (point)))
+ gnus-article-normalized-header-length)
+ (end-of-line)
+ (insert (make-string
+ (- gnus-article-normalized-header-length column)
+ ? )))
+ ((> column gnus-article-normalized-header-length)
+ (gnus-put-text-property
+ (progn
+ (forward-char gnus-article-normalized-header-length)
+ (point))
+ (gnus-point-at-eol)
+ 'invisible t))
+ (t
+ ;; Do nothing.
+ ))
+ (forward-line 1))))))
+
+(defun article-treat-dumbquotes ()
+ "Translate M******** sm*rtq**t*s into proper text."
+ (interactive)
+ (article-translate-strings gnus-article-dumbquotes-map))
+
+(defun article-translate-characters (from to)
+ "Translate all characters in the body of the article according to FROM and TO.
+FROM is a string of characters to translate from; to is a string of
+characters to translate to."
+ (save-excursion
+ (when (article-goto-body)
+ (let ((buffer-read-only nil)
+ (x (make-string 225 ?x))
+ (i -1))
+ (while (< (incf i) (length x))
+ (aset x i i))
+ (setq i 0)
+ (while (< i (length from))
+ (aset x (aref from i) (aref to i))
+ (incf i))
+ (translate-region (point) (point-max) x)))))
+
+(defun article-translate-strings (map)
+ "Translate all string in the body of the article according to MAP.
+MAP is an alist where the elements are on the form (\"from\" \"to\")."
+ (save-excursion
+ (when (article-goto-body)
+ (let ((buffer-read-only nil)
+ elem)
+ (while (setq elem (pop map))
+ (save-excursion
+ (while (search-forward (car elem) nil t)
+ (replace-match (cadr elem)))))))))
+
+(defun article-treat-overstrike ()
+ "Translate overstrikes into bold text."
+ (interactive)
+ (save-excursion
+ (when (article-goto-body)
+ (let ((buffer-read-only nil))
+ (while (search-forward "\b" nil t)
+ (let ((next (char-after))
+ (previous (char-after (- (point) 2))))
+ ;; We do the boldification/underlining by hiding the
+ ;; overstrikes and putting the proper text property
+ ;; on the letters.
+ (cond
+ ((eq next previous)
+ (gnus-article-hide-text-type (- (point) 2) (point) 'overstrike)
+ (put-text-property (point) (1+ (point)) 'face 'bold))
+ ((eq next ?_)
+ (gnus-article-hide-text-type
+ (1- (point)) (1+ (point)) 'overstrike)
+ (put-text-property
+ (- (point) 2) (1- (point)) 'face 'underline))
+ ((eq previous ?_)
+ (gnus-article-hide-text-type (- (point) 2) (point) 'overstrike)
+ (put-text-property
+ (point) (1+ (point)) 'face 'underline)))))))))
+
+(defun article-fill ()
+ "Format too long lines."
+ (interactive)
+ (save-excursion
+ (let ((buffer-read-only nil))
+ (widen)
+ (article-goto-body)
+ (end-of-line 1)
+ (let ((paragraph-start "^[>|#:<;* ]*[ \t]*$")
+ (adaptive-fill-regexp "[ \t]*\\([|#:<;>*]+ *\\)?")
+ (adaptive-fill-mode t))
+ (while (not (eobp))
+ (and (>= (current-column) (min fill-column (window-width)))
+ (/= (preceding-char) ?:)
+ (fill-paragraph nil))
+ (end-of-line 2))))))
+
+(defun article-remove-cr ()
+ "Translate CRLF pairs into LF, and then CR into LF.."
+ (interactive)
+ (save-excursion
+ (let ((buffer-read-only nil))
+ (goto-char (point-min))
+ (while (search-forward "\r$" nil t)
+ (replace-match "" t t))
+ (goto-char (point-min))
+ (while (search-forward "\r" nil t)
+ (replace-match "\n" t t)))))
+
+(defun article-remove-trailing-blank-lines ()
+ "Remove all trailing blank lines from the article."
+ (interactive)
+ (save-excursion
+ (let ((buffer-read-only nil))
+ (goto-char (point-max))
+ (delete-region
+ (point)
+ (progn
+ (while (and (not (bobp))
+ (looking-at "^[ \t]*$")
+ (not (gnus-annotation-in-region-p
+ (point) (gnus-point-at-eol))))
+ (forward-line -1))
+ (forward-line 1)
+ (point))))))
+
+(defun article-display-x-face (&optional force)
+ "Look for an X-Face header and display it if present."
+ (interactive (list 'force))
+ (save-excursion
+ ;; Delete the old process, if any.
+ (when (process-status "article-x-face")
+ (delete-process "article-x-face"))
+ (let ((inhibit-point-motion-hooks t)
+ (case-fold-search t)
+ from last)
+ (save-restriction
+ (nnheader-narrow-to-headers)
+ (setq from (message-fetch-field "from"))
+ (goto-char (point-min))
+ (while (and gnus-article-x-face-command
+ (not last)
+ (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))))
+ ;; Has to be present.
+ (re-search-forward "^X-Face: " nil t))
+ ;; This used to try to do multiple faces (`while' instead of
+ ;; `when' above), but (a) sending multiple EOFs to xv doesn't
+ ;; work (b) it can crash some versions of Emacs (c) are
+ ;; multiple faces really something to encourage?
+ (when (stringp gnus-article-x-face-command)
+ (setq last t))
+ ;; We now have the area of the buffer where the X-Face is stored.
+ (save-excursion
+ (let ((beg (point))
+ (end (1- (re-search-forward "^\\($\\|[^ \t]\\)" nil t))))
+ ;; We display the face.
+ (if (symbolp gnus-article-x-face-command)
+ ;; The command is a lisp function, so we call it.
+ (if (gnus-functionp gnus-article-x-face-command)
+ (funcall gnus-article-x-face-command beg end)
+ (error "%s is not a function" 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))
+ (process-send-region "article-x-face" beg end)
+ (process-send-eof "article-x-face"))))))))))
+
+(defun article-decode-mime-words ()
+ "Decode all MIME-encoded words in the article."
+ (interactive)
+ (save-excursion
+ (set-buffer gnus-article-buffer)
+ (let ((inhibit-point-motion-hooks t)
+ buffer-read-only
+ (rfc2047-default-charset gnus-newsgroup-default-charset)
+ (mm-charset-iso-8859-1-forced gnus-newsgroup-iso-8859-1-forced))
+ (mail-decode-encoded-word-region (point-min) (point-max)))))
+
+(defun article-decode-charset (&optional prompt)
+ "Decode charset-encoded text in the article.
+If PROMPT (the prefix), prompt for a coding system to use."
+ (interactive "P")
+ (save-excursion
+ (save-restriction
+ (message-narrow-to-head)
+ (let* ((inhibit-point-motion-hooks t)
+ (case-fold-search t)
+ (ct (message-fetch-field "Content-Type" t))
+ (cte (message-fetch-field "Content-Transfer-Encoding" t))
+ (ctl (and ct (condition-case ()
+ (mail-header-parse-content-type ct)
+ (error nil))))
+ (charset (cond
+ (prompt
+ (mm-read-coding-system "Charset to decode: "))
+ (ctl
+ (mail-content-type-get ctl 'charset))))
+ (rfc2047-default-charset gnus-newsgroup-default-charset)
+ (mm-charset-iso-8859-1-forced gnus-newsgroup-iso-8859-1-forced)
+ buffer-read-only)
+ (goto-char (point-max))
+ (widen)
+ (forward-line 1)
+ (narrow-to-region (point) (point-max))
+ (when (and (or (not ctl)
+ (equal (car ctl) "text/plain"))
+ (not (mm-uu-test)))
+ (mm-decode-body
+ charset (and cte (intern (downcase
+ (gnus-strip-whitespace cte))))
+ (car ctl)))))))
+
+(defun article-decode-encoded-words ()
+ "Remove encoded-word encoding from headers."
+ (let (buffer-read-only)
+ (let ((charset (save-excursion
+ (set-buffer gnus-summary-buffer)
+ default-mime-charset)))
+ (mime-decode-header-in-buffer charset)
+ )))
+
+(defun article-de-quoted-unreadable (&optional force)
+ "Translate a quoted-printable-encoded article.
+If FORCE, decode the article whether it is marked as quoted-printable
+or not."
+ (interactive (list 'force))
+ (save-excursion
+ (let ((buffer-read-only nil)
+ (type (gnus-fetch-field "content-transfer-encoding"))
+ (charset
+ (or gnus-newsgroup-default-charset mm-default-coding-system))
+ (mm-charset-iso-8859-1-forced gnus-newsgroup-iso-8859-1-forced))
+ (when (or force
+ (and type (string-match "quoted-printable" (downcase type))))
+ (article-goto-body)
+ (save-restriction
+ (narrow-to-region (point) (point-max))
+ (quoted-printable-decode-region (point-min) (point-max))
+ (when charset
+ (mm-decode-body charset)))))))
+
+(defun article-hide-pgp (&optional arg)
+ "Toggle hiding of any PGP headers and signatures in the current article.
+If given a negative prefix, always show; if given a positive prefix,
+always hide."
+ (interactive (gnus-article-hidden-arg))
+ (unless (gnus-article-check-hidden-text 'pgp arg)
+ (save-excursion
+ (let ((inhibit-point-motion-hooks t)
+ buffer-read-only beg end)
+ (widen)
+ (goto-char (point-min))
+ ;; Hide the "header".
+ (when (search-forward "\n-----BEGIN PGP SIGNED MESSAGE-----\n" nil t)
+ (delete-region (1+ (match-beginning 0)) (match-end 0))
+ ;; PGP 5 and GNU PG add a `Hash: <>' comment, hide that too
+ (when (looking-at "Hash:.*$")
+ (delete-region (point) (1+ (gnus-point-at-eol))))
+ (setq beg (point))
+ ;; Hide the actual signature.
+ (and (search-forward "\n-----BEGIN PGP SIGNATURE-----\n" nil t)
+ (setq end (1+ (match-beginning 0)))
+ (delete-region
+ end
+ (if (search-forward "\n-----END PGP SIGNATURE-----\n" nil t)
+ (match-end 0)
+ ;; Perhaps we shouldn't hide to the end of the buffer
+ ;; if there is no end to the signature?
+ (point-max))))
+ ;; Hide "- " PGP quotation markers.
+ (when (and beg end)
+ (narrow-to-region beg end)
+ (goto-char (point-min))
+ (while (re-search-forward "^- " nil t)
+ (delete-region
+ (match-beginning 0) (match-end 0)))
+ (widen))
+ (gnus-run-hooks 'gnus-article-hide-pgp-hook))))))
+
+(defun article-hide-pem (&optional arg)
+ "Toggle hiding of any PEM headers and signatures in the current article.
+If given a negative prefix, always show; if given a positive prefix,
+always hide."
+ (interactive (gnus-article-hidden-arg))
+ (unless (gnus-article-check-hidden-text 'pem arg)
+ (save-excursion
+ (let (buffer-read-only end)
+ (widen)
+ (goto-char (point-min))
+ ;; hide the horrendously ugly "header".
+ (and (search-forward "\n-----BEGIN PRIVACY-ENHANCED MESSAGE-----\n"
+ nil
+ t)
+ (setq end (1+ (match-beginning 0)))
+ (gnus-article-hide-text-type
+ end
+ (if (search-forward "\n\n" nil t)
+ (match-end 0)
+ (point-max))
+ 'pem))
+ ;; hide the trailer as well
+ (and (search-forward "\n-----END PRIVACY-ENHANCED MESSAGE-----\n"
+ nil
+ t)
+ (gnus-article-hide-text-type
+ (match-beginning 0) (match-end 0) 'pem))))))
+
+(defun article-hide-signature (&optional arg)
+ "Hide the signature in the current article.
+If given a negative prefix, always show; if given a positive prefix,
+always hide."
+ (interactive (gnus-article-hidden-arg))
+ (unless (gnus-article-check-hidden-text 'signature arg)
+ (save-excursion
+ (save-restriction
+ (let ((buffer-read-only nil))
+ (when (gnus-article-narrow-to-signature)
+ (gnus-article-hide-text-type
+ (point-min) (point-max) 'signature)))))))
+
+(defun article-strip-leading-blank-lines ()
+ "Remove all blank lines from the beginning of the article."
+ (interactive)
+ (save-excursion
+ (let ((inhibit-point-motion-hooks t)
+ buffer-read-only)
+ (when (article-goto-body)
+ (while (and (not (eobp))
+ (looking-at "[ \t]*$"))
+ (gnus-delete-line))))))
+
+(defun article-goto-body ()
+ "Place point at the start of the body."
+ (goto-char (point-min))
+ (if (search-forward "\n\n" nil t)
+ t
+ (goto-char (point-max))
+ nil))
+
+(defun article-strip-multiple-blank-lines ()
+ "Replace consecutive blank lines with one empty line."
+ (interactive)
+ (save-excursion
+ (let ((inhibit-point-motion-hooks t)
+ buffer-read-only)
+ ;; First make all blank lines empty.
+ (article-goto-body)
+ (while (re-search-forward "^[ \t]+$" nil t)
+ (unless (gnus-annotation-in-region-p
+ (match-beginning 0) (match-end 0))
+ (replace-match "" nil t)))
+ ;; Then replace multiple empty lines with a single empty line.
+ (article-goto-body)
+ (while (re-search-forward "\n\n\n+" nil t)
+ (unless (gnus-annotation-in-region-p
+ (match-beginning 0) (match-end 0))
+ (replace-match "\n\n" t t))))))
+
+(defun article-strip-leading-space ()
+ "Remove all white space from the beginning of the lines in the article."
+ (interactive)
+ (save-excursion
+ (let ((inhibit-point-motion-hooks t)
+ buffer-read-only)
+ (article-goto-body)
+ (while (re-search-forward "^[ \t]+" nil t)
+ (replace-match "" t t)))))
+
+(defun article-strip-trailing-space ()
+ "Remove all white space from the end of the lines in the article."
+ (interactive)
+ (save-excursion
+ (let ((inhibit-point-motion-hooks t)
+ buffer-read-only)
+ (article-goto-body)
+ (while (re-search-forward "[ \t]+$" nil t)
+ (replace-match "" t t)))))
+
+(defun article-strip-blank-lines ()
+ "Strip leading, trailing and multiple blank lines."
+ (interactive)
+ (article-strip-leading-blank-lines)
+ (article-remove-trailing-blank-lines)
+ (article-strip-multiple-blank-lines))
+
+(defun article-strip-all-blank-lines ()
+ "Strip all blank lines."
+ (interactive)
+ (save-excursion
+ (let ((inhibit-point-motion-hooks t)
+ buffer-read-only)
+ (article-goto-body)
+ (while (re-search-forward "^[ \t]*\n" nil t)
+ (replace-match "" t t)))))
+
+(defun gnus-article-narrow-to-signature ()
+ "Narrow to the signature; return t if a signature is found, else nil."
+ (widen)
+ (let ((inhibit-point-motion-hooks t))
+ (when (gnus-article-search-signature)
+ (forward-line 1)
+ ;; Check whether we have some limits to what we consider
+ ;; to be a signature.
+ (let ((limits (if (listp gnus-signature-limit) gnus-signature-limit
+ (list gnus-signature-limit)))
+ limit limited)
+ (while (setq limit (pop limits))
+ (if (or (and (integerp limit)
+ (< (- (point-max) (point)) limit))
+ (and (floatp limit)
+ (< (count-lines (point) (point-max)) limit))
+ (and (gnus-functionp limit)
+ (funcall limit))
+ (and (stringp limit)
+ (not (re-search-forward limit nil t))))
+ () ; This limit did not succeed.
+ (setq limited t
+ limits nil)))
+ (unless limited
+ (narrow-to-region (point) (point-max))
+ t)))))
+
+(defun gnus-article-search-signature ()
+ "Search the current buffer for the signature separator.
+Put point at the beginning of the signature separator."
+ (let ((cur (point)))
+ (goto-char (point-max))
+ (if (if (stringp gnus-signature-separator)
+ (re-search-backward gnus-signature-separator nil t)
+ (let ((seps gnus-signature-separator))
+ (while (and seps
+ (not (re-search-backward (car seps) nil t)))
+ (pop seps))
+ seps))
+ t
+ (goto-char cur)
+ nil)))
+
+(eval-and-compile
+ (autoload 'w3-display "w3-parse")
+ (autoload 'w3-do-setup "w3" "" t)
+ (autoload 'w3-region "w3-display" "" t))
+
+(defun gnus-article-treat-html ()
+ "Render HTML."
+ (interactive)
+ (let ((cbuf (current-buffer)))
+ (set-buffer gnus-article-buffer)
+ (let (buf buffer-read-only b e)
+ (w3-do-setup)
+ (goto-char (point-min))
+ (narrow-to-region
+ (if (search-forward "\n\n" nil t)
+ (setq b (point))
+ (point-max))
+ (setq e (point-max)))
+ (with-temp-buffer
+ (insert-buffer-substring gnus-article-buffer b e)
+ (require 'url)
+ (save-window-excursion
+ (w3-region (point-min) (point-max))
+ (setq buf (buffer-substring-no-properties (point-min) (point-max)))))
+ (when buf
+ (delete-region (point-min) (point-max))
+ (insert buf))
+ (widen)
+ (goto-char (point-min))
+ (set-window-start (get-buffer-window (current-buffer)) (point-min))
+ (set-buffer cbuf))))
+
+(defun gnus-article-hidden-arg ()
+ "Return the current prefix arg as a number, or 0 if no prefix."
+ (list (if current-prefix-arg
+ (prefix-numeric-value current-prefix-arg)
+ 0)))
+
+(defun gnus-article-check-hidden-text (type arg)
+ "Return nil if hiding is necessary.
+Arg can be nil or a number. Nil and positive means hide, negative
+means show, 0 means toggle."
+ (save-excursion
+ (save-restriction
+ (widen)
+ (let ((hide (gnus-article-hidden-text-p type)))
+ (cond
+ ((or (null arg)
+ (> arg 0))
+ nil)
+ ((< arg 0)
+ (gnus-article-show-hidden-text type))
+ (t
+ (if (eq hide 'hidden)
+ (gnus-article-show-hidden-text type)
+ nil)))))))
+
+(defun gnus-article-hidden-text-p (type)
+ "Say whether the current buffer contains hidden text of type TYPE."
+ (let ((pos (text-property-any (point-min) (point-max) 'article-type type)))
+ (while (and pos
+ (not (get-text-property pos 'invisible)))
+ (setq pos
+ (text-property-any (1+ pos) (point-max) 'article-type type)))
+ (if pos
+ 'hidden
+ nil)))
+
+(defun gnus-article-show-hidden-text (type &optional hide)
+ "Show all hidden text of type TYPE.
+If HIDE, hide the text instead."
+ (save-excursion
+ (let ((buffer-read-only nil)
+ (inhibit-point-motion-hooks t)
+ (end (point-min))
+ beg)
+ (while (setq beg (text-property-any end (point-max) 'article-type type))
+ (goto-char beg)
+ (setq end (or
+ (text-property-not-all beg (point-max) 'article-type type)
+ (point-max)))
+ (if hide
+ (gnus-article-hide-text beg end gnus-hidden-properties)
+ (gnus-article-unhide-text beg end))
+ (goto-char end))
+ t)))
+
+(defconst article-time-units
+ `((year . ,(* 365.25 24 60 60))
+ (week . ,(* 7 24 60 60))
+ (day . ,(* 24 60 60))
+ (hour . ,(* 60 60))
+ (minute . 60)
+ (second . 1))
+ "Mapping from time units to seconds.")
+
+(defun article-date-ut (&optional type highlight header)
+ "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."
+ (interactive (list 'ut t))
+ (let* ((header (or header
+ (mail-header-date gnus-current-headers)
+ (message-fetch-field "date")
+ ""))
+ (date (if (vectorp header) (mail-header-date header)
+ header))
+ (date-regexp "^Date:[ \t]\\|^X-Sent:[ \t]")
+ (inhibit-point-motion-hooks t)
+ bface eface newline)
+ (when (and date (not (string= date "")))
+ (save-excursion
+ (save-restriction
+ (nnheader-narrow-to-headers)
+ (let ((buffer-read-only nil))
+ ;; Delete any old Date headers.
+ (if (re-search-forward date-regexp nil t)
+ (progn
+ (setq bface (get-text-property (gnus-point-at-bol) 'face)
+ eface (get-text-property (1- (gnus-point-at-eol))
+ 'face))
+ (delete-region (progn (beginning-of-line) (point))
+ (progn (end-of-line) (point)))
+ (beginning-of-line))
+ (goto-char (point-max))
+ (setq newline t))
+ (insert (article-make-date-line date type))
+ ;; 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))
+ (when newline
+ (end-of-line)
+ (insert "\n"))))))))
+
+(defun article-make-date-line (date type)
+ "Return a DATE line of TYPE."
+ (let ((time (condition-case ()
+ (date-to-time date)
+ (error '(0 0)))))
+ (cond
+ ;; Convert to the local timezone. We have to slap a
+ ;; `condition-case' round the calls to the timezone
+ ;; functions since they aren't particularly resistant to
+ ;; buggy dates.
+ ((eq type 'local)
+ (let ((tz (car (current-time-zone))))
+ (format "Date: %s %s%04d" (current-time-string time)
+ (if (> tz 0) "+" "-") (abs (/ tz 36)))))
+ ;; Convert to Universal Time.
+ ((eq type 'ut)
+ (concat "Date: "
+ (current-time-string
+ (let* ((e (parse-time-string date))
+ (tm (apply 'encode-time e))
+ (ms (car tm))
+ (ls (- (cadr tm) (car (current-time-zone)))))
+ (cond ((< ls 0) (list (1- ms) (+ ls 65536)))
+ ((> ls 65535) (list (1+ ms) (- ls 65536)))
+ (t (list ms ls)))))
+ " UT"))
+ ;; Get the original date from the article.
+ ((eq type 'original)
+ (concat "Date: " (if (string-match "\n+$" date)
+ (substring date 0 (match-beginning 0))
+ date)))
+ ;; Let the user define the format.
+ ((eq type 'user)
+ (if (gnus-functionp gnus-article-time-format)
+ (funcall gnus-article-time-format time)
+ (concat
+ "Date: "
+ (format-time-string gnus-article-time-format time))))
+ ;; ISO 8601.
+ ((eq type 'iso8601)
+ (concat
+ "Date: "
+ (format-time-string "%Y%M%DT%h%m%s" time)))
+ ;; Do an X-Sent lapsed format.
+ ((eq type 'lapsed)
+ ;; If the date is seriously mangled, the timezone functions are
+ ;; liable to bug out, so we ignore all errors.
+ (let* ((now (current-time))
+ (real-time (subtract-time now time))
+ (real-sec (and real-time
+ (+ (* (float (car real-time)) 65536)
+ (cadr real-time))))
+ (sec (and real-time (abs real-sec)))
+ num prev)
+ (cond
+ ((null real-time)
+ "X-Sent: Unknown")
+ ((zerop sec)
+ "X-Sent: Now")
+ (t
+ (concat
+ "X-Sent: "
+ ;; This is a bit convoluted, but basically we go
+ ;; through the time units for years, weeks, etc,
+ ;; and divide things to see whether that results
+ ;; in positive answers.
+ (mapconcat
+ (lambda (unit)
+ (if (zerop (setq num (ffloor (/ sec (cdr unit)))))
+ ;; The (remaining) seconds are too few to
+ ;; be divided into this time unit.
+ ""
+ ;; It's big enough, so we output it.
+ (setq sec (- sec (* num (cdr unit))))
+ (prog1
+ (concat (if prev ", " "") (int-to-string
+ (floor num))
+ " " (symbol-name (car unit))
+ (if (> num 1) "s" ""))
+ (setq prev t))))
+ article-time-units "")
+ ;; If dates are odd, then it might appear like the
+ ;; article was sent in the future.
+ (if (> real-sec 0)
+ " ago"
+ " in the future"))))))
+ (t
+ (error "Unknown conversion type: %s" type)))))
+
+(defun article-date-local (&optional highlight)
+ "Convert the current article date to the local timezone."
+ (interactive (list t))
+ (article-date-ut 'local highlight))
+
+(defun article-date-original (&optional highlight)
+ "Convert the current article date to what it was originally.
+This is only useful if you have used some other date conversion
+function and want to see what the date was before converting."
+ (interactive (list t))
+ (article-date-ut 'original highlight))
+
+(defun article-date-lapsed (&optional highlight)
+ "Convert the current article date to time lapsed since it was sent."
+ (interactive (list t))
+ (article-date-ut 'lapsed highlight))
+
+(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)
+ (goto-char (point-min))
+ (when (re-search-forward "^X-Sent:" nil t)
+ (article-date-lapsed t)))))))))
+
+(defun gnus-start-date-timer (&optional n)
+ "Start a timer to update the X-Sent header in the article buffers.
+The numerical prefix says how frequently (in seconds) the function
+is to run."
+ (interactive "p")
+ (unless n
+ (setq n 1))
+ (gnus-stop-date-timer)
+ (setq article-lapsed-timer
+ (nnheader-run-at-time 1 n 'article-update-date-lapsed)))
+
+(defun gnus-stop-date-timer ()
+ "Stop the X-Sent timer."
+ (interactive)
+ (when article-lapsed-timer
+ (nnheader-cancel-timer article-lapsed-timer)
+ (setq article-lapsed-timer nil)))
+
+(defun article-date-user (&optional highlight)
+ "Convert the current article date to the user-defined format.
+This format is defined by the `gnus-article-time-format' variable."
+ (interactive (list t))
+ (article-date-ut 'user highlight))
+
+(defun article-date-iso8601 (&optional highlight)
+ "Convert the current article date to ISO8601."
+ (interactive (list t))
+ (article-date-ut 'iso8601 highlight))
+
+(defun article-show-all ()
+ "Show all hidden text in the article buffer."
+ (interactive)
+ (save-excursion
+ (let ((buffer-read-only nil))
+ (gnus-article-unhide-text (point-min) (point-max)))))
+
+(defun article-emphasize (&optional arg)
+ "Emphasize text according to `gnus-emphasis-alist'."
+ (interactive (gnus-article-hidden-arg))
+ (unless (gnus-article-check-hidden-text 'emphasis arg)
+ (save-excursion
+ (let ((alist gnus-emphasis-alist)
+ (buffer-read-only nil)
+ (props (append '(article-type emphasis)
+ gnus-hidden-properties))
+ regexp elem beg invisible visible face)
+ (article-goto-body)
+ (setq beg (point))
+ (while (setq elem (pop alist))
+ (goto-char beg)
+ (setq regexp (car elem)
+ invisible (nth 1 elem)
+ visible (nth 2 elem)
+ face (nth 3 elem))
+ (while (re-search-forward regexp nil t)
+ (when (and (match-beginning visible) (match-beginning invisible))
+ (gnus-article-hide-text
+ (match-beginning invisible) (match-end invisible) props)
+ (gnus-article-unhide-text-type
+ (match-beginning visible) (match-end visible) 'emphasis)
+ (gnus-put-text-property-excluding-newlines
+ (match-beginning visible) (match-end visible) 'face face)
+ (goto-char (match-end invisible)))))))))
+
+(defvar gnus-summary-article-menu)
+(defvar gnus-summary-post-menu)
+
+;;; Saving functions.
+
+(defun gnus-article-save (save-buffer file &optional num)
+ "Save the currently selected article."
+ (unless gnus-save-all-headers
+ ;; Remove headers according to `gnus-saved-headers'.
+ (let ((gnus-visible-headers
+ (or gnus-saved-headers gnus-visible-headers))
+ (gnus-article-buffer save-buffer))
+ (save-excursion
+ (set-buffer save-buffer)
+ (article-hide-headers 1 t))))
+ (save-window-excursion
+ (if (not gnus-default-article-saver)
+ (error "No default saver is defined")
+ ;; !!! Magic! The saving functions all save
+ ;; `gnus-save-article-buffer' (or so they think), but we
+ ;; bind that variable to our save-buffer.
+ (set-buffer gnus-article-buffer)
+ (let* ((gnus-save-article-buffer save-buffer)
+ (filename
+ (cond
+ ((not gnus-prompt-before-saving) 'default)
+ ((eq gnus-prompt-before-saving 'always) nil)
+ (t file)))
+ (gnus-number-of-articles-to-be-saved
+ (when (eq gnus-prompt-before-saving t)
+ num))) ; Magic
+ (set-buffer gnus-article-current-summary)
+ (funcall gnus-default-article-saver filename)))))
+
+(defun gnus-read-save-file-name (prompt &optional filename
+ function group headers variable)
+ (let ((default-name
+ (funcall function group headers (symbol-value variable)))
+ result)
+ (setq
+ result
+ (cond
+ ((eq filename 'default)
+ default-name)
+ ((eq filename t)
+ default-name)
+ (filename filename)
+ (t
+ (let* ((split-name (gnus-get-split-value gnus-split-methods))
+ (prompt
+ (format prompt
+ (if (and gnus-number-of-articles-to-be-saved
+ (> gnus-number-of-articles-to-be-saved 1))
+ (format "these %d articles"
+ gnus-number-of-articles-to-be-saved)
+ "this article")))
+ (file
+ ;; Let the split methods have their say.
+ (cond
+ ;; No split name was found.
+ ((null split-name)
+ (read-file-name
+ (concat prompt " (default "
+ (file-name-nondirectory default-name) ") ")
+ (file-name-directory default-name)
+ default-name))
+ ;; A single group name is returned.
+ ((stringp split-name)
+ (setq default-name
+ (funcall function split-name headers
+ (symbol-value variable)))
+ (read-file-name
+ (concat prompt " (default "
+ (file-name-nondirectory default-name) ") ")
+ (file-name-directory default-name)
+ default-name))
+ ;; A single split name was found
+ ((= 1 (length split-name))
+ (let* ((name (expand-file-name
+ (car split-name) gnus-article-save-directory))
+ (dir (cond ((file-directory-p name)
+ (file-name-as-directory name))
+ ((file-exists-p name) name)
+ (t gnus-article-save-directory))))
+ (read-file-name
+ (concat prompt " (default " name ") ")
+ dir name)))
+ ;; A list of splits was found.
+ (t
+ (setq split-name (nreverse split-name))
+ (let (result)
+ (let ((file-name-history
+ (nconc split-name file-name-history)))
+ (setq result
+ (expand-file-name
+ (read-file-name
+ (concat prompt " (`M-p' for defaults) ")
+ gnus-article-save-directory
+ (car split-name))
+ gnus-article-save-directory)))
+ (car (push result file-name-history)))))))
+ ;; Create the directory.
+ (gnus-make-directory (file-name-directory file))
+ ;; If we have read a directory, we append the default file name.
+ (when (file-directory-p file)
+ (setq file (concat (file-name-as-directory file)
+ (file-name-nondirectory default-name))))
+ ;; Possibly translate some characters.
+ (nnheader-translate-file-chars file)))))
+ (gnus-make-directory (file-name-directory result))
+ (set variable result)))
+
+(defun gnus-article-archive-name (group)
+ "Return the first instance of an \"Archive-name\" in the current buffer."
+ (let ((case-fold-search t))
+ (when (re-search-forward "archive-name: *\\([^ \n\t]+\\)[ \t]*$" nil t)
+ (nnheader-concat gnus-article-save-directory
+ (match-string 1)))))
+
+(defun gnus-article-nndoc-name (group)
+ "If GROUP is an nndoc group, return the name of the parent group."
+ (when (eq (car (gnus-find-method-for-group group)) 'nndoc)
+ (gnus-group-get-parameter group 'save-article-group)))
+
+(defun gnus-summary-save-in-rmail (&optional filename)
+ "Append this article to Rmail file.
+Optional argument FILENAME specifies file name.
+Directory to save to is default to `gnus-article-save-directory'."
+ (setq filename (gnus-read-save-file-name
+ "Save %s in 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
+ (save-excursion
+ (save-restriction
+ (widen)
+ (gnus-output-to-rmail filename))))
+ filename)
+
+(defun gnus-summary-save-in-mail (&optional filename)
+ "Append this article to Unix mail file.
+Optional argument FILENAME specifies file name.
+Directory to save to is default to `gnus-article-save-directory'."
+ (setq filename (gnus-read-save-file-name
+ "Save %s in 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
+ (save-excursion
+ (save-restriction
+ (widen)
+ (if (and (file-readable-p filename)
+ (mail-file-babyl-p filename))
+ (rmail-output-to-rmail-file filename t)
+ (gnus-output-to-mail filename)))))
+ filename)
+
+(defun gnus-summary-save-in-file (&optional filename overwrite)
+ "Append this article to file.
+Optional argument FILENAME specifies file name.
+Directory to save to is default to `gnus-article-save-directory'."
+ (setq filename (gnus-read-save-file-name
+ "Save %s in file:" filename
+ gnus-file-save-name gnus-newsgroup-name
+ gnus-current-headers 'gnus-newsgroup-last-file))
+ (gnus-eval-in-buffer-window gnus-save-article-buffer
+ (save-excursion
+ (save-restriction
+ (widen)
+ (when (and overwrite
+ (file-exists-p filename))
+ (delete-file filename))
+ (gnus-output-to-file filename))))
+ filename)
+
+(defun gnus-summary-write-to-file (&optional filename)
+ "Write this article to a file.
+Optional argument FILENAME specifies file name.
+The directory to save in defaults to `gnus-article-save-directory'."
+ (gnus-summary-save-in-file nil t))
+
+(defun gnus-summary-save-body-in-file (&optional filename)
+ "Append this article body to a file.
+Optional argument FILENAME specifies file name.
+The directory to save in defaults to `gnus-article-save-directory'."
+ (setq filename (gnus-read-save-file-name
+ "Save %s body in file:" filename
+ gnus-file-save-name gnus-newsgroup-name
+ gnus-current-headers 'gnus-newsgroup-last-file))
+ (gnus-eval-in-buffer-window gnus-save-article-buffer
+ (save-excursion
+ (save-restriction
+ (widen)
+ (when (article-goto-body)
+ (narrow-to-region (point) (point-max)))
+ (gnus-output-to-file filename))))
+ filename)
+
+(defun gnus-summary-save-in-pipe (&optional command)
+ "Pipe this article to subprocess."
+ (setq command
+ (cond ((and (eq command 'default)
+ gnus-last-shell-command)
+ gnus-last-shell-command)
+ (command command)
+ (t (read-string
+ (format
+ "Shell command on %s: "
+ (if (and gnus-number-of-articles-to-be-saved
+ (> gnus-number-of-articles-to-be-saved 1))
+ (format "these %d articles"
+ gnus-number-of-articles-to-be-saved)
+ "this article"))
+ gnus-last-shell-command))))
+ (when (string-equal command "")
+ (setq command gnus-last-shell-command))
+ (gnus-eval-in-buffer-window gnus-article-buffer
+ (save-restriction
+ (widen)
+ (shell-command-on-region (point-min) (point-max) command nil)))
+ (setq gnus-last-shell-command command))
+
+;;; Article file names when saving.
+
+(defun gnus-capitalize-newsgroup (newsgroup)
+ "Capitalize NEWSGROUP name."
+ (when (not (zerop (length newsgroup)))
+ (concat (char-to-string (upcase (aref newsgroup 0)))
+ (substring newsgroup 1))))
+
+(defun gnus-Numeric-save-name (newsgroup headers &optional last-file)
+ "Generate file name from NEWSGROUP, HEADERS, and optional LAST-FILE.
+If variable `gnus-use-long-file-name' is non-nil, it is ~/News/News.group/num.
+Otherwise, it is like ~/News/news/group/num."
+ (let ((default
+ (expand-file-name
+ (concat (if (gnus-use-long-file-name 'not-save)
+ (gnus-capitalize-newsgroup newsgroup)
+ (gnus-newsgroup-directory-form newsgroup))
+ "/" (int-to-string (mail-header-number headers)))
+ gnus-article-save-directory)))
+ (if (and last-file
+ (string-equal (file-name-directory default)
+ (file-name-directory last-file))
+ (string-match "^[0-9]+$" (file-name-nondirectory last-file)))
+ default
+ (or last-file default))))
+
+(defun gnus-numeric-save-name (newsgroup headers &optional last-file)
+ "Generate file name from NEWSGROUP, HEADERS, and optional LAST-FILE.
+If variable `gnus-use-long-file-name' is non-nil, it is
+~/News/news.group/num. Otherwise, it is like ~/News/news/group/num."
+ (let ((default
+ (expand-file-name
+ (concat (if (gnus-use-long-file-name 'not-save)
+ newsgroup
+ (gnus-newsgroup-directory-form newsgroup))
+ "/" (int-to-string (mail-header-number headers)))
+ gnus-article-save-directory)))
+ (if (and last-file
+ (string-equal (file-name-directory default)
+ (file-name-directory last-file))
+ (string-match "^[0-9]+$" (file-name-nondirectory last-file)))
+ default
+ (or last-file default))))
+
+(defun gnus-Plain-save-name (newsgroup headers &optional last-file)
+ "Generate file name from NEWSGROUP, HEADERS, and optional LAST-FILE.
+If variable `gnus-use-long-file-name' is non-nil, it is
+~/News/News.group. Otherwise, it is like ~/News/news/group/news."
+ (or last-file
+ (expand-file-name
+ (if (gnus-use-long-file-name 'not-save)
+ (gnus-capitalize-newsgroup newsgroup)
+ (concat (gnus-newsgroup-directory-form newsgroup) "/news"))
+ gnus-article-save-directory)))
+
+(defun gnus-plain-save-name (newsgroup headers &optional last-file)
+ "Generate file name from NEWSGROUP, HEADERS, and optional LAST-FILE.
+If variable `gnus-use-long-file-name' is non-nil, it is
+~/News/news.group. Otherwise, it is like ~/News/news/group/news."
+ (or last-file
+ (expand-file-name
+ (if (gnus-use-long-file-name 'not-save)
+ newsgroup
+ (concat (gnus-newsgroup-directory-form newsgroup) "/news"))
+ gnus-article-save-directory)))
+
+(eval-and-compile
+ (mapcar
+ (lambda (func)
+ (let (afunc gfunc)
+ (if (consp func)
+ (setq afunc (car func)
+ gfunc (cdr func))
+ (setq afunc func
+ gfunc (intern (format "gnus-%s" func))))
+ (fset gfunc
+ (if (not (fboundp afunc))
+ nil
+ `(lambda (&optional interactive &rest args)
+ ,(documentation afunc t)
+ (interactive (list t))
+ (save-excursion
+ (set-buffer gnus-article-buffer)
+ (if interactive
+ (call-interactively ',afunc)
+ (apply ',afunc args))))))))
+ '(article-hide-headers
+ article-hide-boring-headers
+ article-treat-overstrike
+ (article-fill . gnus-article-word-wrap)
+ article-remove-cr
+ article-display-x-face
+ article-de-quoted-unreadable
+ article-mime-decode-quoted-printable
+ article-hide-pgp
+ article-hide-pem
+ article-hide-signature
+ article-remove-trailing-blank-lines
+ article-strip-leading-blank-lines
+ article-strip-multiple-blank-lines
+ article-strip-leading-space
+ article-strip-trailing-space
+ article-strip-blank-lines
+ article-strip-all-blank-lines
+ article-date-local
+ article-date-iso8601
+ article-date-original
+ article-date-ut
+ article-decode-mime-words
+ article-decode-charset
+ article-decode-encoded-words
+ article-date-user
+ article-date-lapsed
+ article-emphasize
+ article-treat-dumbquotes
+ article-normalize-headers
+ (article-show-all . gnus-article-show-all-headers))))
+\f
+;;;
+;;; Gnus article mode
+;;;
+
+(put 'gnus-article-mode 'mode-class 'special)
+
+(gnus-define-keys gnus-article-mode-map
+ " " gnus-article-goto-next-page
+ "\177" gnus-article-goto-prev-page
+ [delete] gnus-article-goto-prev-page
+ "\C-c^" gnus-article-refer-article
+ "h" gnus-article-show-summary
+ "s" gnus-article-show-summary
+ "\C-c\C-m" gnus-article-mail
+ "?" gnus-article-describe-briefly
+ gnus-mouse-2 gnus-article-push-button
+ "\r" gnus-article-press-button
+ "\t" gnus-article-next-button
+ "\M-\t" gnus-article-prev-button
+ "e" gnus-article-edit
+ "<" beginning-of-buffer
+ ">" end-of-buffer
+ "\C-c\C-i" gnus-info-find-node
+ "\C-c\C-b" gnus-bug
+
+ "\C-d" gnus-article-read-summary-keys
+ "\M-*" gnus-article-read-summary-keys
+ "\M-#" gnus-article-read-summary-keys
+ "\M-^" gnus-article-read-summary-keys
+ "\M-g" gnus-article-read-summary-keys)
+
+(substitute-key-definition
+ 'undefined 'gnus-article-read-summary-keys gnus-article-mode-map)
+
+(defun gnus-article-make-menu-bar ()
+ (gnus-turn-off-edit-menu 'article)
+ (unless (boundp 'gnus-article-article-menu)
+ (easy-menu-define
+ gnus-article-article-menu gnus-article-mode-map ""
+ '("Article"
+ ["Scroll forwards" gnus-article-goto-next-page t]
+ ["Scroll backwards" gnus-article-goto-prev-page t]
+ ["Show summary" gnus-article-show-summary t]
+ ["Fetch Message-ID at point" gnus-article-refer-article t]
+ ["Mail to address at point" gnus-article-mail t]
+ ["Send a bug report" gnus-bug t]))
+
+ (easy-menu-define
+ gnus-article-treatment-menu gnus-article-mode-map ""
+ '("Treatment"
+ ["Hide headers" gnus-article-hide-headers t]
+ ["Hide signature" gnus-article-hide-signature t]
+ ["Hide citation" gnus-article-hide-citation t]
+ ["Treat overstrike" gnus-article-treat-overstrike t]
+ ["Remove carriage return" gnus-article-remove-cr t]))
+
+ ;; Note "Commands" menu is defined in gnus-sum.el for consistency
+
+ (when (boundp 'gnus-summary-post-menu)
+ (define-key gnus-article-mode-map [menu-bar post]
+ (cons "Post" gnus-summary-post-menu)))
+
+ (gnus-run-hooks 'gnus-article-menu-hook)))
+
+(defun gnus-article-mode ()
+ "Major mode for displaying an article.
+
+All normal editing commands are switched off.
+
+The following commands are available in addition to all summary mode
+commands:
+\\<gnus-article-mode-map>
+\\[gnus-article-next-page]\t Scroll the article one page forwards
+\\[gnus-article-prev-page]\t Scroll the article one page backwards
+\\[gnus-article-refer-article]\t Go to the article referred to by an article id near point
+\\[gnus-article-show-summary]\t Display the summary buffer
+\\[gnus-article-mail]\t Send a reply to the address near point
+\\[gnus-article-describe-briefly]\t Describe the current mode briefly
+\\[gnus-info-find-node]\t Go to the Gnus info node"
+ (interactive)
+ (when (gnus-visual-p 'article-menu 'menu)
+ (gnus-article-make-menu-bar))
+ (gnus-simplify-mode-line)
+ (setq mode-name "Article")
+ (setq major-mode 'gnus-article-mode)
+ (make-local-variable 'minor-mode-alist)
+ (unless (assq 'gnus-show-mime minor-mode-alist)
+ (push (list 'gnus-show-mime " MIME") minor-mode-alist))
+ (use-local-map gnus-article-mode-map)
+ (gnus-update-format-specifications nil 'article-mode)
+ (set (make-local-variable 'page-delimiter) gnus-page-delimiter)
+ (make-local-variable 'gnus-page-broken)
+ (make-local-variable 'gnus-button-marker-list)
+ (make-local-variable 'gnus-article-current-summary)
+ (make-local-variable 'gnus-article-mime-handles)
+ (make-local-variable 'gnus-article-decoded-p)
+ (make-local-variable 'gnus-article-mime-handle-alist)
+ (gnus-set-default-directory)
+ (buffer-disable-undo)
+ (setq buffer-read-only t)
+ (set-syntax-table gnus-article-mode-syntax-table)
+ (gnus-run-hooks 'gnus-article-mode-hook))
+
+(defun gnus-article-setup-buffer ()
+ "Initialize the article buffer."
+ (let* ((name (if gnus-single-article-buffer "*Article*"
+ (concat "*Article " gnus-newsgroup-name "*")))
+ (original
+ (progn (string-match "\\*Article" name)
+ (concat " *Original Article"
+ (substring name (match-end 0))))))
+ (setq gnus-article-buffer name)
+ (setq gnus-original-article-buffer original)
+ (setq gnus-article-mime-handle-alist nil)
+ ;; This might be a variable local to the summary buffer.
+ (unless gnus-single-article-buffer
+ (save-excursion
+ (set-buffer gnus-summary-buffer)
+ (setq gnus-article-buffer name)
+ (setq gnus-original-article-buffer original)
+ (gnus-set-global-variables)))
+ ;; Init original article buffer.
+ (save-excursion
+ (set-buffer (gnus-get-buffer-create gnus-original-article-buffer))
+ (setq major-mode 'gnus-original-article-mode)
+ (make-local-variable 'gnus-original-article))
+ (if (get-buffer name)
+ (save-excursion
+ (set-buffer name)
+ (buffer-disable-undo)
+ (setq buffer-read-only t)
+ (unless (eq major-mode 'gnus-article-mode)
+ (gnus-article-mode))
+ (current-buffer))
+ (save-excursion
+ (set-buffer (gnus-get-buffer-create name))
+ (gnus-article-mode)
+ (make-local-variable 'gnus-summary-buffer)
+ (gnus-summary-set-local-parameters gnus-newsgroup-name)
+ (current-buffer)))))
+
+;; Set article window start at LINE, where LINE is the number of lines
+;; from the head of the article.
+(defun gnus-article-set-window-start (&optional line)
+ (set-window-start
+ (get-buffer-window gnus-article-buffer t)
+ (save-excursion
+ (set-buffer gnus-article-buffer)
+ (goto-char (point-min))
+ (if (not line)
+ (point-min)
+ (gnus-message 6 "Moved to bookmark")
+ (search-forward "\n\n" nil t)
+ (forward-line line)
+ (point)))))
+
+;;; @@ article filters
+;;;
+
+(defun gnus-article-display-mime-message ()
+ "Article display method for MIME message."
+ ;; called from `gnus-original-article-buffer'.
+ (let ((charset (with-current-buffer gnus-summary-buffer
+ default-mime-charset)))
+ (make-local-variable 'default-mime-charset)
+ (setq default-mime-charset charset)
+ (mime-display-message mime-message-structure
+ gnus-article-buffer nil gnus-article-mode-map)
+ (make-local-variable 'default-mime-charset)
+ (setq default-mime-charset charset)
+ )
+ ;; `mime-display-message' changes current buffer to `gnus-article-buffer'.
+ (make-local-variable 'mime-button-mother-dispatcher)
+ (setq mime-button-mother-dispatcher
+ (function gnus-article-push-button))
+ (run-hooks 'gnus-mime-article-prepare-hook))
+
+(defun gnus-article-display-traditional-message ()
+ "Article display method for traditional message."
+ (set-buffer gnus-article-buffer)
+ (let (buffer-read-only)
+ (erase-buffer)
+ (insert-buffer-substring gnus-original-article-buffer)))
+
+(defun gnus-article-make-full-mail-header (&optional number charset)
+ "Create a new mail header structure in a raw article buffer."
+ (unless (and number charset)
+ (save-current-buffer
+ (set-buffer gnus-summary-buffer)
+ (unless number
+ (setq number (or (cdr gnus-article-current) 0)))
+ (unless charset
+ (setq charset (or default-mime-charset 'x-ctext)))))
+ (goto-char (point-min))
+ (let ((header-end (if (search-forward "\n\n" nil t)
+ (1- (point))
+ (goto-char (point-max))))
+ (chars (- (point-max) (point)))
+ (lines (count-lines (point) (point-max)))
+ (default-mime-charset charset)
+ xref)
+ (narrow-to-region (point-min) header-end)
+ (setq xref (std11-fetch-field "xref"))
+ (prog1
+ (make-full-mail-header
+ number
+ (std11-fetch-field "subject")
+ (std11-fetch-field "from")
+ (std11-fetch-field "date")
+ (std11-fetch-field "message-id")
+ (std11-fetch-field "references")
+ chars
+ lines
+ (when xref (concat "Xref: " xref)))
+ (widen))))
+
+(defun gnus-article-prepare (article &optional all-headers header)
+ "Prepare ARTICLE in article mode buffer.
+ARTICLE should either be an article number or a Message-ID.
+If ARTICLE is an id, HEADER should be the article headers.
+If ALL-HEADERS is non-nil, no headers are hidden."
+ (save-excursion
+ ;; Make sure we start in a summary buffer.
+ (unless (eq major-mode 'gnus-summary-mode)
+ (set-buffer gnus-summary-buffer))
+ (setq gnus-summary-buffer (current-buffer))
+ (let* ((gnus-article (if header (mail-header-number header) article))
+ (summary-buffer (current-buffer))
+ (gnus-tmp-internal-hook gnus-article-internal-prepare-hook)
+ (group gnus-newsgroup-name)
+ result)
+ (save-excursion
+ (gnus-article-setup-buffer)
+ (set-buffer gnus-original-article-buffer)
+ ;; Deactivate active regions.
+ (when (and (boundp 'transient-mark-mode)
+ transient-mark-mode)
+ (setq mark-active nil))
+ (if (not (setq result (let ((buffer-read-only nil))
+ (gnus-request-article-this-buffer
+ article group))))
+ ;; There is no such article.
+ (save-excursion
+ (when (and (numberp article)
+ (not (memq article gnus-newsgroup-sparse)))
+ (setq gnus-article-current
+ (cons gnus-newsgroup-name article))
+ (set-buffer gnus-summary-buffer)
+ (setq gnus-current-article article)
+ (if (eq (gnus-article-mark article) gnus-undownloaded-mark)
+ (progn
+ (gnus-summary-set-agent-mark article)
+ (message "Message marked for downloading"))
+ (gnus-summary-mark-article article gnus-canceled-mark)
+ (unless (memq article gnus-newsgroup-sparse)
+ (gnus-error 1
+ "No such article (may have expired or been canceled)")))))
+ (if (or (eq result 'pseudo)
+ (eq result 'nneething))
+ (progn
+ (save-excursion
+ (set-buffer summary-buffer)
+ (push article gnus-newsgroup-history)
+ (setq gnus-last-article gnus-current-article
+ gnus-current-article 0
+ gnus-current-headers nil
+ gnus-article-current nil)
+ (if (eq result 'nneething)
+ (gnus-configure-windows 'summary)
+ (gnus-configure-windows 'article))
+ (gnus-set-global-variables))
+ (let ((gnus-article-mime-handle-alist-1
+ gnus-article-mime-handle-alist))
+ (gnus-set-mode-line 'article)))
+ ;; The result from the `request' was an actual article -
+ ;; or at least some text that is now displayed in the
+ ;; article buffer.
+ (when (and (numberp article)
+ (not (eq article gnus-current-article)))
+ ;; Seems like a new article has been selected.
+ ;; `gnus-current-article' must be an article number.
+ (save-excursion
+ (set-buffer summary-buffer)
+ (push article gnus-newsgroup-history)
+ (setq gnus-last-article gnus-current-article
+ gnus-current-article article
+ gnus-current-headers
+ (gnus-summary-article-header gnus-current-article)
+ gnus-article-current
+ (cons gnus-newsgroup-name gnus-current-article))
+ (unless (vectorp gnus-current-headers)
+ (setq gnus-current-headers nil))
+ (gnus-summary-goto-subject gnus-current-article)
+ (when (gnus-summary-show-thread)
+ ;; If the summary buffer really was folded, the
+ ;; previous goto may not actually have gone to
+ ;; the right article, but the thread root instead.
+ ;; So we go again.
+ (gnus-summary-goto-subject gnus-current-article))
+ (gnus-run-hooks 'gnus-mark-article-hook)
+ (gnus-set-mode-line 'summary)
+ (when (gnus-visual-p 'article-highlight 'highlight)
+ (gnus-run-hooks 'gnus-visual-mark-article-hook))
+ ;; Set the global newsgroup variables here.
+ ;; Suggested by Jim Sisolak
+ ;; <sisolak@trans4.neep.wisc.edu>.
+ (gnus-set-global-variables)
+ (setq gnus-have-all-headers
+ (or all-headers gnus-show-all-headers))))
+ (when (or (numberp article)
+ (stringp article))
+ (gnus-article-prepare-display)
+ ;; Do page break.
+ (goto-char (point-min))
+ (setq gnus-page-broken
+ (when gnus-break-pages
+ (gnus-narrow-to-page)
+ t)))
+ (let ((gnus-article-mime-handle-alist-1
+ gnus-article-mime-handle-alist))
+ (gnus-set-mode-line 'article))
+ (gnus-configure-windows 'article)
+ (article-goto-body)
+ (set-window-point (get-buffer-window (current-buffer)) (point))
+ t))))))
+
+(defun gnus-article-prepare-display ()
+ "Make the current buffer look like a nice article."
+ (let ((method
+ (if gnus-show-mime
+ (progn
+ (setq mime-message-structure gnus-current-headers)
+ gnus-article-display-method-for-mime)
+ gnus-article-display-method-for-traditional)))
+ (gnus-run-hooks 'gnus-tmp-internal-hook)
+ (gnus-run-hooks 'gnus-article-prepare-hook)
+ ;; Display message.
+ (funcall method)
+ ;; Associate this article with the current summary buffer.
+ (setq gnus-article-current-summary (current-buffer))
+ ;; Perform the article display hooks.
+ (gnus-run-hooks 'gnus-article-display-hook)))
+
+;;;
+;;; Gnus MIME viewing functions
+;;;
+
+(defvar gnus-mime-button-line-format "%{%([%p. %d%T]%)%}%e\n"
+ "The following specs can be used:
+%t The MIME type
+%T MIME type, along with additional info
+%n The `name' parameter
+%d The description, if any
+%l The length of the encoded part
+%p The part identifier number
+%e Dots if the part isn't displayed")
+
+(defvar gnus-mime-button-line-format-alist
+ '((?t gnus-tmp-type ?s)
+ (?T gnus-tmp-type-long ?s)
+ (?n gnus-tmp-name ?s)
+ (?d gnus-tmp-description ?s)
+ (?p gnus-tmp-id ?s)
+ (?l gnus-tmp-length ?d)
+ (?e gnus-tmp-dots ?s)))
+
+(defvar gnus-mime-button-commands
+ '((gnus-article-press-button "\r" "Toggle Display")
+ (gnus-mime-view-part "v" "View Interactively...")
+ (gnus-mime-save-part "o" "Save...")
+ (gnus-mime-copy-part "c" "View As Text, In Other Buffer")
+ (gnus-mime-inline-part "i" "View As Text, In This Buffer")
+ (gnus-mime-internalize-part "E" "View Internally")
+ (gnus-mime-externalize-part "e" "View Externally")
+ (gnus-mime-pipe-part "|" "Pipe To Command...")))
+
+(defun gnus-article-mime-part-status ()
+ (if gnus-article-mime-handle-alist-1
+ (format " (%d parts)" (length gnus-article-mime-handle-alist-1))
+ ""))
+
+(defvar gnus-mime-button-map nil)
+(unless gnus-mime-button-map
+ (setq gnus-mime-button-map (make-sparse-keymap))
+ (set-keymap-parent gnus-mime-button-map gnus-article-mode-map)
+ (define-key gnus-mime-button-map gnus-mouse-2 'gnus-article-push-button)
+ (define-key gnus-mime-button-map gnus-mouse-3 'gnus-mime-button-menu)
+ (mapcar (lambda (c)
+ (define-key gnus-mime-button-map (cadr c) (car c)))
+ gnus-mime-button-commands))
+
+(defun gnus-mime-button-menu (event)
+ "Construct a context-sensitive menu of MIME commands."
+ (interactive "e")
+ (gnus-article-check-buffer)
+ (let ((response (x-popup-menu
+ t `("MIME Part"
+ ("" ,@(mapcar (lambda (c)
+ (cons (caddr c) (car c)))
+ gnus-mime-button-commands)))))
+ (pos (event-start event)))
+ (when response
+ (set-buffer (window-buffer (posn-window pos)))
+ (goto-char (posn-point pos))
+ (funcall response))))
+
+(defun gnus-mime-view-all-parts (&optional handles)
+ "View all the MIME parts."
+ (interactive)
+ (save-current-buffer
+ (set-buffer gnus-article-buffer)
+ (let ((handles (or handles gnus-article-mime-handles))
+ (rfc2047-default-charset gnus-newsgroup-default-charset)
+ (mm-charset-iso-8859-1-forced gnus-newsgroup-iso-8859-1-forced))
+ (if (stringp (car handles))
+ (gnus-mime-view-all-parts (cdr handles))
+ (mapcar 'mm-display-part handles)))))
+
+(defun gnus-mime-save-part ()
+ "Save the MIME part under point."
+ (interactive)
+ (gnus-article-check-buffer)
+ (let ((data (get-text-property (point) 'gnus-data)))
+ (mm-save-part data)))
+
+(defun gnus-mime-pipe-part ()
+ "Pipe the MIME part under point to a process."
+ (interactive)
+ (gnus-article-check-buffer)
+ (let ((data (get-text-property (point) 'gnus-data)))
+ (mm-pipe-part data)))
+
+(defun gnus-mime-view-part ()
+ "Interactively choose a view method for the MIME part under point."
+ (interactive)
+ (gnus-article-check-buffer)
+ (let ((data (get-text-property (point) 'gnus-data))
+ (url-standalone-mode (not gnus-plugged)))
+ (mm-interactively-view-part data)))
+
+(defun gnus-mime-copy-part (&optional handle)
+ "Put the the MIME part under point into a new buffer."
+ (interactive)
+ (gnus-article-check-buffer)
+ (let* ((handle (or handle (get-text-property (point) 'gnus-data)))
+ (contents (mm-get-part handle))|
+ (base (file-name-nondirectory
+ (or
+ (mail-content-type-get (mm-handle-type handle) 'name)
+ (mail-content-type-get (mm-handle-type handle)
+ 'filename)
+ "*decoded*")))
+ (buffer (generate-new-buffer base)))
+ (switch-to-buffer buffer)
+ (insert contents)
+ ;; We do it this way to make `normal-mode' set the appropriate mode.
+ (unwind-protect
+ (progn
+ (setq buffer-file-name (expand-file-name base))
+ (normal-mode))
+ (setq buffer-file-name nil))
+ (goto-char (point-min))))
+
+(defun gnus-mime-inline-part (&optional charset)
+ "Insert the MIME part under point into the current buffer."
+ (interactive "P") ; For compatibility reasons we are not using "z".
+ (gnus-article-check-buffer)
+ (let* ((data (get-text-property (point) 'gnus-data))
+ contents
+ (url-standalone-mode (not gnus-plugged))
+ (b (point))
+ buffer-read-only)
+ (if (mm-handle-undisplayer data)
+ (mm-remove-part data)
+ (setq contents (mm-get-part data))
+ (forward-line 2)
+ (when charset
+ (unless (symbolp charset)
+ (setq charset (mm-read-coding-system "Charset: ")))
+ (setq contents (mm-decode-coding-string contents charset)))
+ (mm-insert-inline data contents)
+ (goto-char b))))
+
+(defun gnus-mime-externalize-part (&optional handle)
+ "View the MIME part under point with an external viewer."
+ (interactive)
+ (gnus-article-check-buffer)
+ (let* ((handle (or handle (get-text-property (point) 'gnus-data)))
+ (url-standalone-mode (not gnus-plugged))
+ (mm-user-display-methods nil)
+ (mm-all-images-fit t)
+ (rfc2047-default-charset gnus-newsgroup-default-charset)
+ (mm-charset-iso-8859-1-forced gnus-newsgroup-iso-8859-1-forced))
+ (if (mm-handle-undisplayer handle)
+ (mm-remove-part handle)
+ (mm-display-part handle))))
+
+(defun gnus-mime-internalize-part (&optional handle)
+ "View the MIME part under point with an internal viewer."
+ (interactive)
+ (gnus-article-check-buffer)
+ (let* ((handle (or handle (get-text-property (point) 'gnus-data)))
+ (url-standalone-mode (not gnus-plugged))
+ (mm-user-display-methods '((".*" . inline)))
+ (mm-all-images-fit t)
+ (rfc2047-default-charset gnus-newsgroup-default-charset)
+ (mm-charset-iso-8859-1-forced gnus-newsgroup-iso-8859-1-forced))
+ (if (mm-handle-undisplayer handle)
+ (mm-remove-part handle)
+ (mm-display-part handle))))
+
+(defun gnus-article-part-wrapper (n function)
+ (save-current-buffer
+ (set-buffer gnus-article-buffer)
+ (when (> n (length gnus-article-mime-handle-alist))
+ (error "No such part"))
+ (let ((handle (cdr (assq n gnus-article-mime-handle-alist))))
+ (funcall function handle))))
+
+(defun gnus-article-pipe-part (n)
+ "Pipe MIME part N, which is the numerical prefix."
+ (interactive "p")
+ (gnus-article-part-wrapper n 'mm-pipe-part))
+
+(defun gnus-article-save-part (n)
+ "Save MIME part N, which is the numerical prefix."
+ (interactive "p")
+ (gnus-article-part-wrapper n 'mm-save-part))
+
+(defun gnus-article-interactively-view-part (n)
+ "Pipe MIME part N, which is the numerical prefix."
+ (interactive "p")
+ (gnus-article-part-wrapper n 'mm-interactively-view-part))
+
+(defun gnus-article-copy-part (n)
+ "Pipe MIME part N, which is the numerical prefix."
+ (interactive "p")
+ (gnus-article-part-wrapper n 'gnus-mime-copy-part))
+
+(defun gnus-article-externalize-part (n)
+ "Pipe MIME part N, which is the numerical prefix."
+ (interactive "p")
+ (gnus-article-part-wrapper n 'gnus-mime-externalize-part))
+
+(defun gnus-article-view-part (n)
+ "View MIME part N, which is the numerical prefix."
+ (interactive "p")
+ (save-current-buffer
+ (set-buffer gnus-article-buffer)
+ (when (> n (length gnus-article-mime-handle-alist))
+ (error "No such part"))
+ (let ((handle (cdr (assq n gnus-article-mime-handle-alist))))
+ (when (gnus-article-goto-part n)
+ (if (equal (car handle) "multipart/alternative")
+ (gnus-article-press-button)
+ (when (eq (gnus-mm-display-part handle) 'internal)
+ (gnus-set-window-start)))))))
+
+(defun gnus-mm-display-part (handle)
+ "Display HANDLE and fix MIME button."
+ (let ((id (get-text-property (point) 'gnus-part))
+ (point (point))
+ buffer-read-only)
+ (delete-region (gnus-point-at-bol) (progn (forward-line 1) (point)))
+ (gnus-insert-mime-button
+ handle id (list (not (mm-handle-displayed-p handle))))
+ (prog1
+ (let ((window (selected-window))
+ (rfc2047-default-charset gnus-newsgroup-default-charset)
+ (mm-charset-iso-8859-1-forced gnus-newsgroup-iso-8859-1-forced))
+ (save-excursion
+ (unwind-protect
+ (let ((win (get-buffer-window (current-buffer) t)))
+ (if win
+ (select-window win))
+ (goto-char point)
+ (forward-line)
+ (mm-display-part handle))
+ (select-window window))))
+ (goto-char point))))
+
+(defun gnus-article-goto-part (n)
+ "Go to MIME part N."
+ (let ((point (text-property-any (point-min) (point-max) 'gnus-part n)))
+ (when point
+ (goto-char point))))
+
+(defun gnus-insert-mime-button (handle gnus-tmp-id &optional displayed)
+ (let ((gnus-tmp-name
+ (or (mail-content-type-get (mm-handle-type handle)
+ 'name)
+ (mail-content-type-get (mm-handle-disposition handle)
+ 'filename)
+ ""))
+ (gnus-tmp-type (car (mm-handle-type handle)))
+ (gnus-tmp-description (or (mm-handle-description handle)
+ ""))
+ (gnus-tmp-dots
+ (if (if displayed (car displayed)
+ (mm-handle-displayed-p handle))
+ "" "..."))
+ (gnus-tmp-length (with-current-buffer (mm-handle-buffer handle)
+ (buffer-size)))
+ gnus-tmp-type-long b e)
+ (setq gnus-tmp-type-long (concat gnus-tmp-type
+ (and (not (equal gnus-tmp-name ""))
+ (concat "; " gnus-tmp-name))))
+ (or (equal gnus-tmp-description "")
+ (setq gnus-tmp-type-long (concat " --- " gnus-tmp-type-long)))
+ (unless (bolp)
+ (insert "\n"))
+ (setq b (point))
+ (gnus-eval-format
+ gnus-mime-button-line-format gnus-mime-button-line-format-alist
+ `(local-map ,gnus-mime-button-map
+ keymap ,gnus-mime-button-map
+ gnus-callback gnus-mm-display-part
+ gnus-part ,gnus-tmp-id
+ article-type annotation
+ gnus-data ,handle))
+ (setq e (point))
+ (widget-convert-button 'link b e
+ :mime-handle handle
+ :action 'gnus-widget-press-button
+ :button-keymap gnus-mime-button-map
+ :help-echo
+ (lambda (widget)
+ ;; Needed to properly clear the message
+ ;; due to a bug in wid-edit
+ (setq help-echo-owns-message t)
+ (format
+ "Click to %s the MIME part; %s for more options"
+ (if (mm-handle-displayed-p
+ (widget-get widget :mime-handle))
+ "hide" "show")
+ (if gnus-xemacs "button3" "mouse-3"))))))
+
+(defun gnus-widget-press-button (elems el)
+ (goto-char (widget-get elems :from))
+ (let ((url-standalone-mode (not gnus-plugged)))
+ (gnus-article-press-button)))
+
+(defun gnus-display-mime (&optional ihandles)
+ "Insert MIME buttons in the buffer."
+ (save-excursion
+ (save-selected-window
+ (let ((window (get-buffer-window gnus-article-buffer))
+ (point (point)))
+ (when window
+ (select-window window)
+ ;; We have to do this since selecting the window
+ ;; may change the point. So we set the window point.
+ (set-window-point window point)))
+ (let* ((handles (or ihandles (mm-dissect-buffer) (mm-uu-dissect)))
+ handle name type b e display)
+ (unless ihandles
+ ;; Top-level call; we clean up.
+ (mm-destroy-parts gnus-article-mime-handles)
+ (setq gnus-article-mime-handles handles
+ gnus-article-mime-handle-alist nil)
+ ;; We allow users to glean info from the handles.
+ (when gnus-article-mime-part-function
+ (gnus-mime-part-function handles)))
+ (when (and handles
+ (or (not (stringp (car handles)))
+ (cdr handles)))
+ (unless ihandles
+ ;; Clean up for mime parts.
+ (article-goto-body)
+ (delete-region (point) (point-max)))
+ (gnus-mime-display-part handles))))))
+
+(defun gnus-mime-display-part (handle)
+ (cond
+ ;; Single part.
+ ((not (stringp (car handle)))
+ (gnus-mime-display-single handle))
+ ;; multipart/alternative
+ ((equal (car handle) "multipart/alternative")
+ (let ((id (1+ (length gnus-article-mime-handle-alist))))
+ (push (cons id handle) gnus-article-mime-handle-alist)
+ (gnus-mime-display-alternative (cdr handle) nil nil id)))
+ ;; multipart/related
+ ((equal (car handle) "multipart/related")
+ ;;;!!!We should find the start part, but we just default
+ ;;;!!!to the first part.
+ (gnus-mime-display-part (cadr handle)))
+ ;; Other multiparts are handled like multipart/mixed.
+ (t
+ (gnus-mime-display-mixed (cdr handle)))))
+
+(defun gnus-mime-part-function (handles)
+ (if (stringp (car handles))
+ (mapcar 'gnus-mime-part-function (cdr handles))
+ (funcall gnus-article-mime-part-function handles)))
+
+(defun gnus-mime-display-mixed (handles)
+ (mapcar 'gnus-mime-display-part handles))
+
+(defun gnus-mime-display-single (handle)
+ (let ((type (car (mm-handle-type handle)))
+ (ignored gnus-ignored-mime-types)
+ (not-attachment t)
+ (move nil)
+ display text)
+ (catch 'ignored
+ (progn
+ (while ignored
+ (when (string-match (pop ignored) type)
+ (throw 'ignored nil)))
+ (if (and (setq not-attachment
+ (or (not (mm-handle-disposition handle))
+ (equal (car (mm-handle-disposition handle))
+ "inline")))
+ (mm-automatic-display-p type)
+ (or (mm-inlinable-part-p type)
+ (mm-automatic-external-display-p type)))
+ (setq display t)
+ (when (equal (car (split-string type "/"))
+ "text")
+ (setq text t)))
+ (let ((id (1+ (length gnus-article-mime-handle-alist))))
+ (push (cons id handle) gnus-article-mime-handle-alist)
+ (when (or (not display)
+ (not (gnus-unbuttonized-mime-type-p type)))
+ (gnus-article-insert-newline)
+ (gnus-insert-mime-button
+ handle id (list (or display
+ (and not-attachment text))))
+ (gnus-article-insert-newline)
+ (gnus-article-insert-newline)
+ (setq move t)))
+ (cond
+ (display
+ (when move
+ (forward-line -2))
+ (let ((rfc2047-default-charset gnus-newsgroup-default-charset)
+ (mm-charset-iso-8859-1-forced
+ gnus-newsgroup-iso-8859-1-forced))
+ (mm-display-part handle t))
+ (goto-char (point-max)))
+ ((and text not-attachment)
+ (when move
+ (forward-line -2))
+ (gnus-article-insert-newline)
+ (mm-insert-inline handle (mm-get-part handle))
+ (goto-char (point-max))))))))
+
+(defun gnus-unbuttonized-mime-type-p (type)
+ "Say whether TYPE is to be unbuttonized."
+ (unless gnus-inhibit-mime-unbuttonizing
+ (catch 'found
+ (let ((types gnus-unbuttonized-mime-types))
+ (while types
+ (when (string-match (pop types) type)
+ (throw 'found t)))))))
+
+(defun gnus-article-insert-newline ()
+ "Insert a newline, but mark it as undeletable."
+ (gnus-put-text-property
+ (point) (progn (insert "\n") (point)) 'gnus-undeletable t))
+
+(defun gnus-mime-display-alternative (handles &optional preferred ibegend id)
+ (let* ((preferred (or preferred (mm-preferred-alternative handles)))
+ (ihandles handles)
+ (point (point))
+ handle buffer-read-only from props begend not-pref)
+ (save-window-excursion
+ (save-restriction
+ (when ibegend
+ (narrow-to-region (car ibegend)
+ (or (cdr ibegend)
+ (progn
+ (goto-char (car ibegend))
+ (forward-line 2)
+ (point))))
+ (delete-region (point-min) (point-max))
+ (mm-remove-parts handles))
+ (setq begend (list (point-marker)))
+ ;; Do the toggle.
+ (unless (setq not-pref (cadr (member preferred ihandles)))
+ (setq not-pref (car ihandles)))
+ (when (or ibegend
+ (not (gnus-unbuttonized-mime-type-p
+ "multipart/alternative")))
+ (gnus-add-text-properties
+ (setq from (point))
+ (progn
+ (insert (format "%d. " id))
+ (point))
+ `(gnus-callback
+ (lambda (handles)
+ (unless ,(not ibegend)
+ (setq gnus-article-mime-handle-alist
+ ',gnus-article-mime-handle-alist))
+ (gnus-mime-display-alternative
+ ',ihandles ',not-pref ',begend ,id))
+ local-map ,gnus-mime-button-map
+ ,gnus-mouse-face-prop ,gnus-article-mouse-face
+ face ,gnus-article-button-face
+ keymap ,gnus-mime-button-map
+ gnus-part ,id
+ gnus-data ,handle))
+ (widget-convert-button 'link from (point)
+ :action 'gnus-widget-press-button
+ :button-keymap gnus-widget-button-keymap)
+ ;; Do the handles
+ (while (setq handle (pop handles))
+ (gnus-add-text-properties
+ (setq from (point))
+ (progn
+ (insert (format "(%c) %-18s"
+ (if (equal handle preferred) ?* ? )
+ (if (stringp (car handle))
+ (car handle)
+ (car (mm-handle-type handle)))))
+ (point))
+ `(gnus-callback
+ (lambda (handles)
+ (unless ,(not ibegend)
+ (setq gnus-article-mime-handle-alist
+ ',gnus-article-mime-handle-alist))
+ (gnus-mime-display-alternative
+ ',ihandles ',handle ',begend ,id))
+ local-map ,gnus-mime-button-map
+ ,gnus-mouse-face-prop ,gnus-article-mouse-face
+ face ,gnus-article-button-face
+ keymap ,gnus-mime-button-map
+ gnus-part ,id
+ gnus-data ,handle))
+ (widget-convert-button 'link from (point)
+ :action 'gnus-widget-press-button
+ :button-keymap gnus-widget-button-keymap)
+ (insert " "))
+ (insert "\n\n"))
+ (when preferred
+ (if (stringp (car preferred))
+ (gnus-display-mime preferred)
+ (let ((rfc2047-default-charset gnus-newsgroup-default-charset)
+ (mm-charset-iso-8859-1-forced
+ gnus-newsgroup-iso-8859-1-forced))
+ (mm-display-part preferred)))
+ (goto-char (point-max))
+ (setcdr begend (point-marker)))))
+ (when ibegend
+ (goto-char point))))
+
+(defun gnus-article-wash-status ()
+ "Return a string which display status of article washing."
+ (save-excursion
+ (set-buffer gnus-article-buffer)
+ (let ((cite (gnus-article-hidden-text-p 'cite))
+ (headers (gnus-article-hidden-text-p 'headers))
+ (boring (gnus-article-hidden-text-p 'boring-headers))
+ (pgp (gnus-article-hidden-text-p 'pgp))
+ (pem (gnus-article-hidden-text-p 'pem))
+ (signature (gnus-article-hidden-text-p 'signature))
+ (overstrike (gnus-article-hidden-text-p 'overstrike))
+ (emphasis (gnus-article-hidden-text-p 'emphasis))
+ (mime gnus-show-mime))
+ (format "%c%c%c%c%c%c%c"
+ (if cite ?c ? )
+ (if (or headers boring) ?h ? )
+ (if (or pgp pem) ?p ? )
+ (if signature ?s ? )
+ (if overstrike ?o ? )
+ (if mime ?m ? )
+ (if emphasis ?e ? )))))
+
+(fset 'gnus-article-hide-headers-if-wanted 'gnus-article-maybe-hide-headers)
+
+(defun gnus-article-maybe-hide-headers ()
+ "Hide unwanted headers if `gnus-have-all-headers' is nil.
+Provided for backwards compatibility."
+ (or (save-excursion (set-buffer gnus-summary-buffer) gnus-have-all-headers)
+ gnus-inhibit-hiding
+ (gnus-article-hide-headers)))
+
+;;; Article savers.
+
+(defun gnus-output-to-file (file-name)
+ "Append the current article to a file named FILE-NAME."
+ (let ((artbuf (current-buffer)))
+ (with-temp-buffer
+ (insert-buffer-substring artbuf)
+ ;; Append newline at end of the buffer as separator, and then
+ ;; save it to file.
+ (goto-char (point-max))
+ (insert "\n")
+ (append-to-file (point-min) (point-max) file-name)
+ t)))
+
+(defun gnus-narrow-to-page (&optional arg)
+ "Narrow the article buffer to a page.
+If given a numerical ARG, move forward ARG pages."
+ (interactive "P")
+ (setq arg (if arg (prefix-numeric-value arg) 0))
+ (save-excursion
+ (set-buffer gnus-article-buffer)
+ (goto-char (point-min))
+ (widen)
+ ;; Remove any old next/prev buttons.
+ (when (gnus-visual-p 'page-marker)
+ (let ((buffer-read-only nil))
+ (gnus-remove-text-with-property 'gnus-prev)
+ (gnus-remove-text-with-property 'gnus-next)))
+ (when
+ (cond ((< arg 0)
+ (re-search-backward page-delimiter nil 'move (1+ (abs arg))))
+ ((> arg 0)
+ (re-search-forward page-delimiter nil 'move arg)))
+ (goto-char (match-end 0)))
+ (narrow-to-region
+ (point)
+ (if (re-search-forward page-delimiter nil 'move)
+ (match-beginning 0)
+ (point)))
+ (when (and (gnus-visual-p 'page-marker)
+ (not (= (point-min) 1)))
+ (save-excursion
+ (goto-char (point-min))
+ (gnus-insert-prev-page-button)))
+ (when (and (gnus-visual-p 'page-marker)
+ (< (+ (point-max) 2) (buffer-size)))
+ (save-excursion
+ (goto-char (point-max))
+ (gnus-insert-next-page-button)))))
+
+;; Article mode commands
+
+(defun gnus-article-goto-next-page ()
+ "Show the next page of the article."
+ (interactive)
+ (when (gnus-article-next-page)
+ (goto-char (point-min))
+ (gnus-article-read-summary-keys nil (gnus-character-to-event ?n))))
+
+(defun gnus-article-goto-prev-page ()
+ "Show the next page of the article."
+ (interactive)
+ (if (bobp) (gnus-article-read-summary-keys nil (gnus-character-to-event ?p))
+ (gnus-article-prev-page nil)))
+
+(defun gnus-article-next-page (&optional lines)
+ "Show the next page of the current article.
+If end of article, return non-nil. Otherwise return nil.
+Argument LINES specifies lines to be scrolled up."
+ (interactive "p")
+ (move-to-window-line -1)
+ (if (save-excursion
+ (end-of-line)
+ (and (pos-visible-in-window-p) ;Not continuation line.
+ (eobp)))
+ ;; Nothing in this page.
+ (if (or (not gnus-page-broken)
+ (save-excursion
+ (save-restriction
+ (widen) (forward-line 1) (eobp)))) ;Real end-of-buffer?
+ t ;Nothing more.
+ (gnus-narrow-to-page 1) ;Go to next page.
+ nil)
+ ;; More in this page.
+ (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)
+ nil))
+
+(defun gnus-article-prev-page (&optional lines)
+ "Show previous page of current article.
+Argument LINES specifies lines to be scrolled down."
+ (interactive "p")
+ (move-to-window-line 0)
+ (if (and gnus-page-broken
+ (bobp)
+ (not (save-restriction (widen) (bobp)))) ;Real beginning-of-buffer?
+ (progn
+ (gnus-narrow-to-page -1) ;Go to previous page.
+ (goto-char (point-max))
+ (recenter -1))
+ (let ((scroll-in-place nil))
+ (prog1
+ (condition-case ()
+ (scroll-down lines)
+ (beginning-of-buffer
+ (goto-char (point-min))))
+ (move-to-window-line 0)))))
+
+(defun gnus-article-refer-article ()
+ "Read article specified by message-id around point."
+ (interactive)
+ (let ((point (point)))
+ (search-forward ">" nil t) ;Move point to end of "<....>".
+ (if (re-search-backward "\\(<[^<> \t\n]+>\\)" nil t)
+ (let ((message-id (match-string 1)))
+ (goto-char point)
+ (set-buffer gnus-summary-buffer)
+ (gnus-summary-refer-article message-id))
+ (goto-char (point))
+ (error "No references around point"))))
+
+(defun gnus-article-show-summary ()
+ "Reconfigure windows to show summary buffer."
+ (interactive)
+ (if (not (gnus-buffer-live-p gnus-summary-buffer))
+ (error "There is no summary buffer for this article buffer")
+ (gnus-article-set-globals)
+ (gnus-configure-windows 'article)
+ (gnus-summary-goto-subject gnus-current-article)
+ (gnus-summary-position-point)))
+
+(defun gnus-article-describe-briefly ()
+ "Describe article mode commands briefly."
+ (interactive)
+ (gnus-message 6
+ (substitute-command-keys "\\<gnus-article-mode-map>\\[gnus-article-goto-next-page]:Next page \\[gnus-article-goto-prev-page]:Prev page \\[gnus-article-show-summary]:Show summary \\[gnus-info-find-node]:Run Info \\[gnus-article-describe-briefly]:This help")))
+
+(defun gnus-article-summary-command ()
+ "Execute the last keystroke in the summary buffer."
+ (interactive)
+ (let ((obuf (current-buffer))
+ (owin (current-window-configuration))
+ func)
+ (switch-to-buffer gnus-article-current-summary 'norecord)
+ (setq func (lookup-key (current-local-map) (this-command-keys)))
+ (call-interactively func)
+ (set-buffer obuf)
+ (set-window-configuration owin)
+ (set-window-point (get-buffer-window (current-buffer)) (point))))
+
+(defun gnus-article-summary-command-nosave ()
+ "Execute the last keystroke in the summary buffer."
+ (interactive)
+ (let (func)
+ (pop-to-buffer gnus-article-current-summary 'norecord)
+ (setq func (lookup-key (current-local-map) (this-command-keys)))
+ (call-interactively func)))
+
+(defun gnus-article-check-buffer ()
+ "Beep if not in an article buffer."
+ (unless (equal major-mode 'gnus-article-mode)
+ (error "Command invoked outside of a Gnus article buffer")))
+
+(defun gnus-article-read-summary-keys (&optional arg key not-restore-window)
+ "Read a summary buffer key sequence and execute it from the article buffer."
+ (interactive "P")
+ (gnus-article-check-buffer)
+ (let ((nosaves
+ '("q" "Q" "c" "r" "R" "\C-c\C-f" "m" "a" "f" "F"
+ "Zc" "ZC" "ZE" "ZQ" "ZZ" "Zn" "ZR" "ZG" "ZN" "ZP"
+ "=" "^" "\M-^" "|"))
+ (nosave-but-article
+ '("A\r"))
+ (nosave-in-article
+ '("\C-d"))
+ (up-to-top
+ '("n" "Gn" "p" "Gp"))
+ keys new-sum-point)
+ (save-excursion
+ (set-buffer gnus-article-current-summary)
+ (let (gnus-pick-mode)
+ (push (or key last-command-event) unread-command-events)
+ (setq keys (read-key-sequence nil))))
+ (message "")
+
+ (if (or (member keys nosaves)
+ (member keys nosave-but-article)
+ (member keys nosave-in-article))
+ (let (func)
+ (save-window-excursion
+ (pop-to-buffer gnus-article-current-summary 'norecord)
+ ;; We disable the pick minor mode commands.
+ (let (gnus-pick-mode)
+ (setq func (lookup-key (current-local-map) keys))))
+ (if (not func)
+ (ding)
+ (unless (member keys nosave-in-article)
+ (set-buffer gnus-article-current-summary))
+ (call-interactively func)
+ (setq new-sum-point (point)))
+ (when (member keys nosave-but-article)
+ (pop-to-buffer gnus-article-buffer 'norecord)))
+ ;; These commands should restore window configuration.
+ (let ((obuf (current-buffer))
+ (owin (current-window-configuration))
+ (opoint (point))
+ (summary gnus-article-current-summary)
+ func in-buffer selected)
+ (if not-restore-window
+ (pop-to-buffer summary 'norecord)
+ (switch-to-buffer summary 'norecord))
+ (setq in-buffer (current-buffer))
+ ;; We disable the pick minor mode commands.
+ (if (setq func (let (gnus-pick-mode)
+ (lookup-key (current-local-map) keys)))
+ (progn
+ (call-interactively func)
+ (setq new-sum-point (point)))
+ (ding))
+ (when (eq in-buffer (current-buffer))
+ (setq selected (gnus-summary-select-article))
+ (set-buffer obuf)
+ (unless not-restore-window
+ (set-window-configuration owin))
+ (unless (or (not (eq selected 'old)) (member keys up-to-top))
+ (set-window-point (get-buffer-window (current-buffer))
+ opoint))
+ (let ((win (get-buffer-window gnus-article-current-summary)))
+ (when win
+ (set-window-point win new-sum-point))))))))
+
+(defun gnus-article-hide (&optional arg force)
+ "Hide all the gruft in the current article.
+This means that PGP stuff, signatures, cited text and (some)
+headers will be hidden.
+If given a prefix, show the hidden text instead."
+ (interactive (append (gnus-article-hidden-arg) (list 'force)))
+ (gnus-article-hide-headers arg)
+ (gnus-article-hide-pgp arg)
+ (gnus-article-hide-citation-maybe arg force)
+ (gnus-article-hide-signature arg))
+
+(defun gnus-article-maybe-highlight ()
+ "Do some article highlighting if article highlighting is requested."
+ (when (gnus-visual-p 'article-highlight 'highlight)
+ (gnus-article-highlight-some)))
+
+(defun gnus-check-group-server ()
+ ;; Make sure the connection to the server is alive.
+ (unless (gnus-server-opened
+ (gnus-find-method-for-group gnus-newsgroup-name))
+ (gnus-check-server (gnus-find-method-for-group gnus-newsgroup-name))
+ (gnus-request-group gnus-newsgroup-name t)))
+
+(defun gnus-request-article-this-buffer (article group)
+ "Get an article and insert it into this buffer."
+ (let (do-update-line sparse-header)
+ (prog1
+ (save-excursion
+ (erase-buffer)
+ (gnus-kill-all-overlays)
+ (setq group (or group gnus-newsgroup-name))
+
+ ;; Using `gnus-request-article' directly will insert the article into
+ ;; `nntp-server-buffer' - so we'll save some time by not having to
+ ;; copy it from the server buffer into the article buffer.
+
+ ;; We only request an article by message-id when we do not have the
+ ;; headers for it, so we'll have to get those.
+ (when (stringp article)
+ (let ((gnus-override-method gnus-refer-article-method))
+ (gnus-read-header article)))
+
+ ;; If the article number is negative, that means that this article
+ ;; doesn't belong in this newsgroup (possibly), so we find its
+ ;; message-id and request it by id instead of number.
+ (when (and (numberp article)
+ gnus-summary-buffer
+ (get-buffer gnus-summary-buffer)
+ (gnus-buffer-exists-p gnus-summary-buffer))
+ (save-excursion
+ (set-buffer gnus-summary-buffer)
+ (let ((header (gnus-summary-article-header article)))
+ (when (< article 0)
+ (cond
+ ((memq article gnus-newsgroup-sparse)
+ ;; This is a sparse gap article.
+ (setq do-update-line article)
+ (setq article (mail-header-id header))
+ (let ((gnus-override-method gnus-refer-article-method))
+ (setq sparse-header (gnus-read-header article)))
+ (setq gnus-newsgroup-sparse
+ (delq article gnus-newsgroup-sparse)))
+ ((vectorp header)
+ ;; It's a real article.
+ (setq article (mail-header-id header)))
+ (t
+ ;; It is an extracted pseudo-article.
+ (setq article 'pseudo)
+ (gnus-request-pseudo-article header))))
+
+ (let ((method (gnus-find-method-for-group
+ gnus-newsgroup-name)))
+ (when (and (eq (car method) 'nneething)
+ (vectorp header))
+ (let ((dir (concat
+ (file-name-as-directory
+ (or (cadr (assq 'nneething-address method))
+ (nth 1 method)))
+ (mail-header-subject header))))
+ (when (file-directory-p dir)
+ (setq article 'nneething)
+ (gnus-group-enter-directory dir))))))))
+
+ (cond
+ ;; Refuse to select canceled articles.
+ ((and (numberp article)
+ gnus-summary-buffer
+ (get-buffer gnus-summary-buffer)
+ (gnus-buffer-exists-p gnus-summary-buffer)
+ (eq (cdr (save-excursion
+ (set-buffer gnus-summary-buffer)
+ (assq article gnus-newsgroup-reads)))
+ gnus-canceled-mark))
+ nil)
+ ;; Check the backlog.
+ ((and gnus-keep-backlog
+ (gnus-backlog-request-article group article (current-buffer)))
+ 'article)
+ ;; Check asynchronous pre-fetch.
+ ((gnus-async-request-fetched-article group article (current-buffer))
+ (gnus-async-prefetch-next group article gnus-summary-buffer)
+ (when (and (numberp article) gnus-keep-backlog)
+ (gnus-backlog-enter-article group article (current-buffer)))
+ 'article)
+ ;; Check the cache.
+ ((and gnus-use-cache
+ (numberp article)
+ (gnus-cache-request-article article group))
+ 'article)
+ ;; Get the article and put into the article buffer.
+ ((or (stringp article) (numberp article))
+ (let ((gnus-override-method
+ (and (stringp article) gnus-refer-article-method))
+ (buffer-read-only nil))
+ (erase-buffer)
+ (gnus-kill-all-overlays)
+ (gnus-check-group-server)
+ (when (gnus-request-article article group (current-buffer))
+ (when (numberp article)
+ (gnus-async-prefetch-next group article gnus-summary-buffer)
+ (when gnus-keep-backlog
+ (gnus-backlog-enter-article
+ group article (current-buffer))))
+ 'article)))
+ ;; It was a pseudo.
+ (t article)))
+
+ ;; Associate this article with the current summary buffer.
+ (setq gnus-article-current-summary gnus-summary-buffer)
+
+ ;; Take the article from the original article buffer
+ ;; and place it in the buffer it's supposed to be in.
+ (when (and (get-buffer gnus-article-buffer)
+ (equal (buffer-name (current-buffer))
+ (buffer-name (get-buffer gnus-article-buffer))))
+ (save-excursion
+ (if (get-buffer gnus-original-article-buffer)
+ (set-buffer gnus-original-article-buffer)
+ (set-buffer (gnus-get-buffer-create gnus-original-article-buffer))
+ (buffer-disable-undo)
+ (setq major-mode 'gnus-original-article-mode)
+ (setq buffer-read-only t))
+ (let (buffer-read-only)
+ (erase-buffer)
+ (insert-buffer-substring gnus-article-buffer))
+ (setq gnus-original-article (cons group article)))
+
+ ;; Decode charsets.
+ (run-hooks 'gnus-article-decode-hook)
+ ;; Mark article as decoded or not.
+ (setq gnus-article-decoded-p gnus-article-decode-hook))
+
+ ;; Update sparse articles.
+ (when (and do-update-line
+ (or (numberp article)
+ (stringp article)))
+ (let ((buf (current-buffer)))
+ (set-buffer gnus-summary-buffer)
+ (gnus-summary-update-article do-update-line sparse-header)
+ (gnus-summary-goto-subject do-update-line nil t)
+ (set-window-point (get-buffer-window (current-buffer) t)
+ (point))
+ (set-buffer buf))))))
+
+;;;
+;;; Article editing
+;;;
+
+(defcustom gnus-article-edit-mode-hook nil
+ "Hook run in article edit mode buffers."
+ :group 'gnus-article-various
+ :type 'hook)
+
+(defcustom gnus-article-edit-article-setup-function
+ 'gnus-article-mime-edit-article-setup
+ "Function called to setup an editing article buffer."
+ :group 'gnus-article-various
+ :type 'function)
+
+(defvar gnus-article-edit-done-function nil)
+
+(defvar gnus-article-edit-mode-map nil)
+
+;; Should we be using derived.el for this?
+(unless gnus-article-edit-mode-map
+ (setq gnus-article-edit-mode-map (make-sparse-keymap))
+ (set-keymap-parent gnus-article-edit-mode-map text-mode-map)
+
+ (gnus-define-keys gnus-article-edit-mode-map
+ "\C-c\C-c" gnus-article-edit-done
+ "\C-c\C-k" gnus-article-edit-exit)
+
+ (gnus-define-keys (gnus-article-edit-wash-map
+ "\C-c\C-w" gnus-article-edit-mode-map)
+ "f" gnus-article-edit-full-stops))
+
+(defun gnus-article-edit-mode ()
+ "Major mode for editing articles.
+This is an extended text-mode.
+
+\\{gnus-article-edit-mode-map}"
+ (interactive)
+ (setq major-mode 'gnus-article-edit-mode)
+ (setq mode-name "Article Edit")
+ (use-local-map gnus-article-edit-mode-map)
+ (make-local-variable 'gnus-article-edit-done-function)
+ (make-local-variable 'gnus-prev-winconf)
+ (setq buffer-read-only nil)
+ (buffer-enable-undo)
+ (widen)
+ (gnus-run-hooks 'text-mode-hook 'gnus-article-edit-mode-hook))
+
+(defun gnus-article-edit (&optional force)
+ "Edit the current article.
+This will have permanent effect only in mail groups.
+If FORCE is non-nil, allow editing of articles even in read-only
+groups."
+ (interactive "P")
+ (when (and (not force)
+ (gnus-group-read-only-p))
+ (error "The current newsgroup does not support article editing"))
+ (gnus-article-date-original)
+ (gnus-article-edit-article
+ `(lambda (no-highlight)
+ (gnus-summary-edit-article-done
+ ,(or (mail-header-references gnus-current-headers) "")
+ ,(gnus-group-read-only-p) ,gnus-summary-buffer no-highlight))))
+
+(defun gnus-article-edit-article (exit-func)
+ "Start editing the contents of the current article buffer."
+ (let ((winconf (current-window-configuration)))
+ (set-buffer gnus-article-buffer)
+ (gnus-article-edit-mode)
+ (gnus-article-delete-text-of-type 'annotation)
+ (gnus-set-text-properties (point-min) (point-max) nil)
+ (gnus-configure-windows 'edit-article)
+ (setq gnus-article-edit-done-function exit-func)
+ (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")))
+
+(defun gnus-article-edit-done (&optional arg)
+ "Update the article edits and exit."
+ (interactive "P")
+ (save-excursion
+ (save-restriction
+ (widen)
+ (when (article-goto-body)
+ (let ((lines (count-lines (point) (point-max)))
+ (length (- (point-max) (point)))
+ (case-fold-search t)
+ (body (copy-marker (point))))
+ (goto-char (point-min))
+ (when (re-search-forward "^content-length:[ \t]\\([0-9]+\\)" body t)
+ (delete-region (match-beginning 1) (match-end 1))
+ (insert (number-to-string length)))
+ (goto-char (point-min))
+ (when (re-search-forward
+ "^x-content-length:[ \t]\\([0-9]+\\)" body t)
+ (delete-region (match-beginning 1) (match-end 1))
+ (insert (number-to-string length)))
+ (goto-char (point-min))
+ (when (re-search-forward "^lines:[ \t]\\([0-9]+\\)" body t)
+ (delete-region (match-beginning 1) (match-end 1))
+ (insert (number-to-string lines)))))))
+ (let ((func gnus-article-edit-done-function)
+ (buf (current-buffer))
+ (start (window-start)))
+ (remove-hook 'gnus-article-mode-hook
+ 'gnus-article-mime-edit-article-unwind)
+ (gnus-article-edit-exit)
+ (save-excursion
+ (set-buffer buf)
+ (let ((buffer-read-only nil))
+ (funcall func arg))
+ ;; The cache and backlog have to be flushed somewhat.
+ (when gnus-keep-backlog
+ (gnus-backlog-remove-article
+ (car gnus-article-current) (cdr gnus-article-current)))
+ ;; Flush original article as well.
+ (save-excursion
+ (when (get-buffer gnus-original-article-buffer)
+ (set-buffer gnus-original-article-buffer)
+ (setq gnus-original-article nil)))
+ (when gnus-use-cache
+ (gnus-cache-update-article
+ (car gnus-article-current) (cdr gnus-article-current))))
+ (set-buffer buf)
+ (set-window-start (get-buffer-window buf) start)
+ (set-window-point (get-buffer-window buf) (point))))
+
+(defun gnus-article-edit-exit ()
+ "Exit the article editing without updating."
+ (interactive)
+ ;; We remove all text props from the article buffer.
+ (let ((buf (format "%s" (buffer-string)))
+ (curbuf (current-buffer))
+ (p (point))
+ (window-start (window-start)))
+ (erase-buffer)
+ (insert buf)
+ (let ((winconf gnus-prev-winconf))
+ (gnus-article-mode)
+ (set-window-configuration winconf)
+ ;; Tippy-toe some to make sure that point remains where it was.
+ (save-current-buffer
+ (set-buffer curbuf)
+ (set-window-start (get-buffer-window (current-buffer)) window-start)
+ (goto-char p)))))
+
+(defun gnus-article-edit-full-stops ()
+ "Interactively repair spacing at end of sentences."
+ (interactive)
+ (save-excursion
+ (goto-char (point-min))
+ (search-forward-regexp "^$" nil t)
+ (let ((case-fold-search nil))
+ (query-replace-regexp "\\([.!?][])}]* \\)\\([[({A-Z]\\)" "\\1 \\2"))))
+
+;;;
+;;; Article editing with MIME-Edit
+;;;
+
+(defcustom gnus-article-mime-edit-article-setup-hook nil
+ "Hook run after setting up a MIME editing article buffer."
+ :group 'gnus-article-various
+ :type 'hook)
+
+(defun gnus-article-mime-edit-article-unwind ()
+ "Unwind `gnus-article-buffer' if article editing was given up."
+ (remove-hook 'gnus-article-mode-hook 'gnus-article-mime-edit-article-unwind)
+ (when mime-edit-mode-flag
+ (mime-edit-exit 'nomime 'no-error)
+ (message ""))
+ (when (featurep 'font-lock)
+ (setq font-lock-defaults nil)
+ (font-lock-mode 0)))
+
+(defun gnus-article-mime-edit-article-setup ()
+ "Convert current buffer to MIME-Edit buffer and turn on MIME-Edit mode
+after replacing with the original article."
+ (setq gnus-show-mime t)
+ (setq gnus-article-edit-done-function
+ `(lambda (&rest args)
+ (when mime-edit-mode-flag
+ (mime-edit-exit)
+ (message ""))
+ (goto-char (point-min))
+ (let (case-fold-search)
+ (when (re-search-forward
+ (format "^%s$" (regexp-quote mail-header-separator))
+ nil t)
+ (replace-match "")))
+ (when (featurep 'font-lock)
+ (setq font-lock-defaults nil)
+ (font-lock-mode 0))
+ (apply ,gnus-article-edit-done-function args)
+ (set-buffer gnus-original-article-buffer)
+ (erase-buffer)
+ (insert-buffer gnus-article-buffer)
+ (setq gnus-current-headers (gnus-article-make-full-mail-header))
+ (gnus-article-prepare-display)))
+ (substitute-key-definition
+ 'gnus-article-edit-exit 'gnus-article-mime-edit-exit
+ gnus-article-edit-mode-map)
+ (erase-buffer)
+ (insert-buffer gnus-original-article-buffer)
+ (mime-edit-again)
+ (when (featurep 'font-lock)
+ (set (make-local-variable 'font-lock-defaults)
+ '(message-font-lock-keywords t))
+ (font-lock-set-defaults)
+ (turn-on-font-lock))
+ (add-hook 'gnus-article-mode-hook 'gnus-article-mime-edit-article-unwind)
+ (gnus-run-hooks 'gnus-article-mime-edit-article-setup-hook))
+
+(defun gnus-article-mime-edit-exit ()
+ "Exit the article MIME editing without updating."
+ (interactive)
+ (let ((winconf gnus-prev-winconf)
+ buf)
+ (when mime-edit-mode-flag
+ (mime-edit-exit)
+ (message ""))
+ (goto-char (point-min))
+ (let (case-fold-search)
+ (when (re-search-forward
+ (format "^%s$" (regexp-quote mail-header-separator)) nil t)
+ (replace-match "")))
+ (when (featurep 'font-lock)
+ (setq font-lock-defaults nil)
+ (font-lock-mode 0))
+ ;; We remove all text props from the article buffer.
+ (setq buf (format "%s" (buffer-string)))
+ (set-buffer (get-buffer-create gnus-original-article-buffer))
+ (erase-buffer)
+ (insert buf)
+ (setq gnus-current-headers (gnus-article-make-full-mail-header))
+ (gnus-article-prepare-display)
+ (set-window-configuration winconf)))
+
+;;;
+;;; Article highlights
+;;;
+
+;; Written by Per Abrahamsen <abraham@iesd.auc.dk>.
+
+;;; Internal Variables:
+
+(defcustom gnus-button-url-regexp "\\b\\(s?https?\\|ftp\\|file\\|gopher\\|news\\|telnet\\|wais\\|mailto\\):\\(//[-a-zA-Z0-9_.]+:[0-9]*\\)?\\([-a-zA-Z0-9_=!?#$@~`%&*+|\\/:;.,]\\|\\w\\)+\\([-a-zA-Z0-9_=#$@~`%&*+|\\/]\\|\\w\\)"
+ "Regular expression that matches URLs."
+ :group 'gnus-article-buttons
+ :type 'regexp)
+
+(defcustom gnus-button-alist
+ `(("<\\(url:[>\n\t ]*?\\)?news:[>\n\t ]*\\([^>\n\t ]*@[^>\n\t ]*\\)>"
+ 0 t gnus-button-message-id 2)
+ ("\\bnews:\\([^>\n\t ]*@[^>)!;:,\n\t ]*\\)" 0 t gnus-button-message-id 1)
+ ("\\(\\b<\\(url:[>\n\t ]*\\)?news:[>\n\t ]*\\(//\\)?\\([^>\n\t ]*\\)>\\)"
+ 1 t
+ gnus-button-fetch-group 4)
+ ("\\bnews:\\(//\\)?\\([^'\">\n\t ]+\\)" 0 t gnus-button-fetch-group 2)
+ ("\\bin\\( +article\\| +message\\)? +\\(<\\([^\n @<>]+@[^\n @<>]+\\)>\\)" 2
+ t gnus-button-message-id 3)
+ ("\\(<URL: *\\)mailto: *\\([^> \n\t]+\\)>" 0 t gnus-url-mailto 2)
+ ("mailto:\\([-a-zA-Z.@_+0-9%]+\\)" 0 t gnus-url-mailto 1)
+ ("\\bmailto:\\([^ \n\t]+\\)" 0 t gnus-url-mailto 1)
+ ;; This is how URLs _should_ be embedded in text...
+ ("<URL: *\\([^>]*\\)>" 0 t gnus-button-embedded-url 1)
+ ;; Raw URLs.
+ (,gnus-button-url-regexp 0 t gnus-button-url 0))
+ "*Alist of regexps matching buttons in article bodies.
+
+Each entry has the form (REGEXP BUTTON FORM CALLBACK PAR...), where
+REGEXP: is the string matching text around the button,
+BUTTON: is the number of the regexp grouping actually matching the button,
+FORM: is a lisp expression which must eval to true for the button to
+be added,
+CALLBACK: is the function to call when the user push this button, and each
+PAR: is a number of a regexp grouping whose text will be passed to CALLBACK.
+
+CALLBACK can also be a variable, in that case the value of that
+variable it the real callback function."
+ :group 'gnus-article-buttons
+ :type '(repeat (list regexp
+ (integer :tag "Button")
+ (sexp :tag "Form")
+ (function :tag "Callback")
+ (repeat :tag "Par"
+ :inline t
+ (integer :tag "Regexp group")))))
+
+(defcustom gnus-header-button-alist
+ `(("^\\(References\\|Message-I[Dd]\\):" "<[^>]+>"
+ 0 t gnus-button-message-id 0)
+ ("^\\(From\\|Reply-To\\):" ": *\\(.+\\)$" 1 t gnus-button-reply 1)
+ ("^\\(Cc\\|To\\):" "[^ \t\n<>,()\"]+@[^ \t\n<>,()\"]+"
+ 0 t gnus-button-mailto 0)
+ ("^X-[Uu][Rr][Ll]:" ,gnus-button-url-regexp 0 t gnus-button-url 0)
+ ("^Subject:" ,gnus-button-url-regexp 0 t gnus-button-url 0)
+ ("^[^:]+:" ,gnus-button-url-regexp 0 t gnus-button-url 0)
+ ("^[^:]+:" "\\(<\\(url: \\)?news:\\([^>\n ]*\\)>\\)" 1 t
+ gnus-button-message-id 3))
+ "*Alist of headers and regexps to match buttons in article heads.
+
+This alist is very similar to `gnus-button-alist', except that each
+alist has an additional HEADER element first in each entry:
+
+\(HEADER REGEXP BUTTON FORM CALLBACK PAR)
+
+HEADER is a regexp to match a header. For a fuller explanation, see
+`gnus-button-alist'."
+ :group 'gnus-article-buttons
+ :group 'gnus-article-headers
+ :type '(repeat (list (regexp :tag "Header")
+ regexp
+ (integer :tag "Button")
+ (sexp :tag "Form")
+ (function :tag "Callback")
+ (repeat :tag "Par"
+ :inline t
+ (integer :tag "Regexp group")))))
+
+(defvar gnus-button-regexp nil)
+(defvar gnus-button-marker-list nil)
+;; Regexp matching any of the regexps from `gnus-button-alist'.
+
+(defvar gnus-button-last nil)
+;; The value of `gnus-button-alist' when `gnus-button-regexp' was build.
+
+;;; Commands:
+
+(defun gnus-article-push-button (event)
+ "Check text under the mouse pointer for a callback function.
+If the text under the mouse pointer has a `gnus-callback' property,
+call it with the value of the `gnus-data' text property."
+ (interactive "e")
+ (set-buffer (window-buffer (posn-window (event-start event))))
+ (let* ((pos (posn-point (event-start event)))
+ (data (get-text-property pos 'gnus-data))
+ (fun (get-text-property pos 'gnus-callback)))
+ (goto-char pos)
+ (when fun
+ (funcall fun data))))
+
+(defun gnus-article-press-button ()
+ "Check text at point for a callback function.
+If the text at point has a `gnus-callback' property,
+call it with the value of the `gnus-data' text property."
+ (interactive)
+ (let* ((data (get-text-property (point) 'gnus-data))
+ (fun (get-text-property (point) 'gnus-callback)))
+ (when fun
+ (funcall fun data))))
+
+(defun gnus-article-prev-button (n)
+ "Move point to N buttons backward.
+If N is negative, move forward instead."
+ (interactive "p")
+ (gnus-article-next-button (- n)))
+
+(defun gnus-article-next-button (n)
+ "Move point to N buttons forward.
+If N is negative, move backward instead."
+ (interactive "p")
+ (let ((function (if (< n 0) 'previous-single-property-change
+ 'next-single-property-change))
+ (inhibit-point-motion-hooks t)
+ (backward (< n 0))
+ (limit (if (< n 0) (point-min) (point-max))))
+ (setq n (abs n))
+ (while (and (not (= limit (point)))
+ (> n 0))
+ ;; Skip past the current button.
+ (when (get-text-property (point) 'gnus-callback)
+ (goto-char (funcall function (point) 'gnus-callback nil limit)))
+ ;; Go to the next (or previous) button.
+ (gnus-goto-char (funcall function (point) 'gnus-callback nil limit))
+ ;; Put point at the start of the button.
+ (when (and backward (not (get-text-property (point) 'gnus-callback)))
+ (goto-char (funcall function (point) 'gnus-callback nil limit)))
+ ;; Skip past intangible buttons.
+ (when (get-text-property (point) 'intangible)
+ (incf n))
+ (decf n))
+ (unless (zerop n)
+ (gnus-message 5 "No more buttons"))
+ n))
+
+(defun gnus-article-highlight (&optional force)
+ "Highlight current article.
+This function calls `gnus-article-highlight-headers',
+`gnus-article-highlight-citation',
+`gnus-article-highlight-signature', and `gnus-article-add-buttons' to
+do the highlighting. See the documentation for those functions."
+ (interactive (list 'force))
+ (gnus-article-highlight-headers)
+ (gnus-article-highlight-citation force)
+ (gnus-article-highlight-signature)
+ (gnus-article-add-buttons force)
+ (gnus-article-add-buttons-to-head))
+
+(defun gnus-article-highlight-some (&optional force)
+ "Highlight current article.
+This function calls `gnus-article-highlight-headers',
+`gnus-article-highlight-signature', and `gnus-article-add-buttons' to
+do the highlighting. See the documentation for those functions."
+ (interactive (list 'force))
+ (gnus-article-highlight-headers)
+ (gnus-article-highlight-signature)
+ (gnus-article-add-buttons))
+
+(defun gnus-article-highlight-headers ()
+ "Highlight article headers as specified by `gnus-header-face-alist'."
+ (interactive)
+ (save-excursion
+ (set-buffer gnus-article-buffer)
+ (save-restriction
+ (let ((alist gnus-header-face-alist)
+ (buffer-read-only nil)
+ (case-fold-search t)
+ (inhibit-point-motion-hooks t)
+ entry regexp header-face field-face from hpoints fpoints)
+ (message-narrow-to-head)
+ (while (setq entry (pop alist))
+ (goto-char (point-min))
+ (setq regexp (concat "^\\("
+ (if (string-equal "" (nth 0 entry))
+ "[^\t ]"
+ (nth 0 entry))
+ "\\)")
+ header-face (nth 1 entry)
+ field-face (nth 2 entry))
+ (while (and (re-search-forward regexp nil t)
+ (not (eobp)))
+ (beginning-of-line)
+ (setq from (point))
+ (unless (search-forward ":" nil t)
+ (forward-char 1))
+ (when (and header-face
+ (not (memq (point) hpoints)))
+ (push (point) hpoints)
+ (gnus-put-text-property from (point) 'face header-face))
+ (when (and field-face
+ (not (memq (setq from (point)) fpoints)))
+ (push from fpoints)
+ (if (re-search-forward "^[^ \t]" nil t)
+ (forward-char -2)
+ (goto-char (point-max)))
+ (gnus-put-text-property from (point) 'face field-face))))))))
+
+(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'."
+ (interactive)
+ (save-excursion
+ (set-buffer gnus-article-buffer)
+ (let ((buffer-read-only nil)
+ (inhibit-point-motion-hooks t))
+ (save-restriction
+ (when (and gnus-signature-face
+ (gnus-article-narrow-to-signature))
+ (gnus-overlay-put (gnus-make-overlay (point-min) (point-max))
+ 'face gnus-signature-face)
+ (widen)
+ (gnus-article-search-signature)
+ (let ((start (match-beginning 0))
+ (end (set-marker (make-marker) (1+ (match-end 0)))))
+ (gnus-article-add-button start (1- end) 'gnus-signature-toggle
+ end)))))))
+
+(defun gnus-button-in-region-p (b e prop)
+ "Say whether PROP exists in the region."
+ (text-property-not-all b e prop nil))
+
+(defun gnus-article-add-buttons (&optional force)
+ "Find external references in the article and make buttons of them.
+\"External references\" are things like Message-IDs and URLs, as
+specified by `gnus-button-alist'."
+ (interactive (list 'force))
+ (save-excursion
+ (set-buffer gnus-article-buffer)
+ (let ((buffer-read-only nil)
+ (inhibit-point-motion-hooks t)
+ (case-fold-search t)
+ (alist gnus-button-alist)
+ beg entry regexp)
+ ;; Remove all old markers.
+ (let (marker entry)
+ (while (setq marker (pop gnus-button-marker-list))
+ (goto-char marker)
+ (when (setq entry (gnus-button-entry))
+ (put-text-property (match-beginning (nth 1 entry))
+ (match-end (nth 1 entry))
+ 'gnus-callback nil))
+ (set-marker marker nil)))
+ ;; We skip the headers.
+ (article-goto-body)
+ (setq beg (point))
+ (while (setq entry (pop alist))
+ (setq regexp (car entry))
+ (goto-char beg)
+ (while (re-search-forward regexp nil t)
+ (let* ((start (and entry (match-beginning (nth 1 entry))))
+ (end (and entry (match-end (nth 1 entry))))
+ (from (match-beginning 0)))
+ (when (and (or (eq t (nth 2 entry))
+ (eval (nth 2 entry)))
+ (not (gnus-button-in-region-p
+ start end 'gnus-callback)))
+ ;; That optional form returned non-nil, so we add the
+ ;; button.
+ (gnus-article-add-button
+ start end 'gnus-button-push
+ (car (push (set-marker (make-marker) from)
+ gnus-button-marker-list))))))))))
+
+;; Add buttons to the head of an article.
+(defun gnus-article-add-buttons-to-head ()
+ "Add buttons to the head of the article."
+ (interactive)
+ (save-excursion
+ (set-buffer gnus-article-buffer)
+ (let ((buffer-read-only nil)
+ (inhibit-point-motion-hooks t)
+ (case-fold-search t)
+ (alist gnus-header-button-alist)
+ entry beg end)
+ (nnheader-narrow-to-headers)
+ (while alist
+ ;; Each alist entry.
+ (setq entry (car alist)
+ alist (cdr alist))
+ (goto-char (point-min))
+ (while (re-search-forward (car entry) nil t)
+ ;; Each header matching the entry.
+ (setq beg (match-beginning 0))
+ (setq end (or (and (re-search-forward "^[^ \t]" nil t)
+ (match-beginning 0))
+ (point-max)))
+ (goto-char beg)
+ (while (re-search-forward (nth 1 entry) end t)
+ ;; Each match within a header.
+ (let* ((entry (cdr entry))
+ (start (match-beginning (nth 1 entry)))
+ (end (match-end (nth 1 entry)))
+ (form (nth 2 entry)))
+ (goto-char (match-end 0))
+ (when (eval form)
+ (gnus-article-add-button
+ start end (nth 3 entry)
+ (buffer-substring (match-beginning (nth 4 entry))
+ (match-end (nth 4 entry)))))))
+ (goto-char end))))
+ (widen)))
+
+;;; External functions:
+
+(defun gnus-article-add-button (from to fun &optional data)
+ "Create a button between FROM and TO with callback FUN and data DATA."
+ (when gnus-article-button-face
+ (gnus-overlay-put (gnus-make-overlay from to)
+ 'face gnus-article-button-face))
+ (gnus-add-text-properties
+ from to
+ (nconc (and gnus-article-mouse-face
+ (list gnus-mouse-face-prop gnus-article-mouse-face))
+ (list 'gnus-callback fun)
+ (and data (list 'gnus-data data)))))
+
+;;; Internal functions:
+
+(defun gnus-article-set-globals ()
+ (save-excursion
+ (set-buffer gnus-summary-buffer)
+ (gnus-set-global-variables)))
+
+(defun gnus-signature-toggle (end)
+ (save-excursion
+ (set-buffer gnus-article-buffer)
+ (let ((buffer-read-only nil)
+ (inhibit-point-motion-hooks t))
+ (if (get-text-property end 'invisible)
+ (gnus-article-unhide-text end (point-max))
+ (gnus-article-hide-text end (point-max) gnus-hidden-properties)))))
+
+(defun gnus-button-entry ()
+ ;; Return the first entry in `gnus-button-alist' matching this place.
+ (let ((alist gnus-button-alist)
+ (entry nil))
+ (while alist
+ (setq entry (pop alist))
+ (if (looking-at (car entry))
+ (setq alist nil)
+ (setq entry nil)))
+ entry))
+
+(defun gnus-button-push (marker)
+ ;; Push button starting at MARKER.
+ (save-excursion
+ (goto-char marker)
+ (let* ((entry (gnus-button-entry))
+ (inhibit-point-motion-hooks t)
+ (fun (nth 3 entry))
+ (args (mapcar (lambda (group)
+ (let ((string (match-string group)))
+ (gnus-set-text-properties
+ 0 (length string) nil string)
+ string))
+ (nthcdr 4 entry))))
+ (cond
+ ((fboundp fun)
+ (apply fun args))
+ ((and (boundp fun)
+ (fboundp (symbol-value fun)))
+ (apply (symbol-value fun) args))
+ (t
+ (gnus-message 1 "You must define `%S' to use this button"
+ (cons fun args)))))))
+
+(defun gnus-button-message-id (message-id)
+ "Fetch MESSAGE-ID."
+ (save-excursion
+ (set-buffer gnus-summary-buffer)
+ (gnus-summary-refer-article message-id)))
+
+(defun gnus-button-fetch-group (address)
+ "Fetch GROUP specified by ADDRESS."
+ (if (not (string-match "[:/]" address))
+ ;; This is just a simple group url.
+ (gnus-group-read-ephemeral-group address gnus-select-method)
+ (if (not (string-match "^\\([^:/]+\\)\\(:\\([^/]+\\)/\\)?\\(.*\\)$"
+ address))
+ (error "Can't parse %s" address)
+ (gnus-group-read-ephemeral-group
+ (match-string 4 address)
+ `(nntp ,(match-string 1 address)
+ (nntp-address ,(match-string 1 address))
+ (nntp-port-number ,(if (match-end 3)
+ (match-string 3 address)
+ "nntp")))))))
+
+(defun gnus-url-parse-query-string (query &optional downcase)
+ (let (retval pairs cur key val)
+ (setq pairs (split-string query "&"))
+ (while pairs
+ (setq cur (car pairs)
+ pairs (cdr pairs))
+ (if (not (string-match "=" cur))
+ nil ; Grace
+ (setq key (gnus-url-unhex-string (substring cur 0 (match-beginning 0)))
+ val (gnus-url-unhex-string (substring cur (match-end 0) nil)))
+ (if downcase
+ (setq key (downcase key)))
+ (setq cur (assoc key retval))
+ (if cur
+ (setcdr cur (cons val (cdr cur)))
+ (setq retval (cons (list key val) retval)))))
+ retval))
+
+(defun gnus-url-unhex (x)
+ (if (> x ?9)
+ (if (>= x ?a)
+ (+ 10 (- x ?a))
+ (+ 10 (- x ?A)))
+ (- x ?0)))
+
+(defun gnus-url-unhex-string (str &optional allow-newlines)
+ "Remove %XXX embedded spaces, etc in a url.
+If optional second argument ALLOW-NEWLINES is non-nil, then allow the
+decoding of carriage returns and line feeds in the string, which is normally
+forbidden in URL encoding."
+ (setq str (or str ""))
+ (let ((tmp "")
+ (case-fold-search t))
+ (while (string-match "%[0-9a-f][0-9a-f]" str)
+ (let* ((start (match-beginning 0))
+ (ch1 (gnus-url-unhex (elt str (+ start 1))))
+ (code (+ (* 16 ch1)
+ (gnus-url-unhex (elt str (+ start 2))))))
+ (setq tmp (concat
+ tmp (substring str 0 start)
+ (cond
+ (allow-newlines
+ (char-to-string code))
+ ((or (= code ?\n) (= code ?\r))
+ " ")
+ (t (char-to-string code))))
+ str (substring str (match-end 0)))))
+ (setq tmp (concat tmp str))
+ tmp))
+
+(defun gnus-url-mailto (url)
+ ;; Send mail to someone
+ (when (string-match "mailto:/*\\(.*\\)" url)
+ (setq url (substring url (match-beginning 1) nil)))
+ (let (to args subject func)
+ (if (string-match (regexp-quote "?") url)
+ (setq to (gnus-url-unhex-string (substring url 0 (match-beginning 0)))
+ args (gnus-url-parse-query-string
+ (substring url (match-end 0) nil) t))
+ (setq to (gnus-url-unhex-string url)))
+ (setq args (cons (list "to" to) args)
+ subject (cdr-safe (assoc "subject" args)))
+ (gnus-setup-message 'reply
+ (message-mail)
+ (while args
+ (setq func (intern-soft (concat "message-goto-" (downcase (caar args)))))
+ (if (fboundp func)
+ (funcall func)
+ (message-position-on-field (caar args)))
+ (insert (mapconcat 'identity (cdar args) ", "))
+ (setq args (cdr args)))
+ (if subject
+ (message-goto-body)
+ (message-goto-subject)))))
+
+(defun gnus-button-mailto (address)
+ ;; Mail to ADDRESS.
+ (set-buffer (gnus-copy-article-buffer))
+ (gnus-setup-message 'reply
+ (message-reply address)))
+
+(defun gnus-button-reply (address)
+ ;; Reply to ADDRESS.
+ (gnus-setup-message 'reply
+ (message-reply address)))
+
+(defun gnus-button-url (address)
+ "Browse ADDRESS."
+ ;; In Emacs 20, `browse-url-browser-function' may be an alist.
+ (if (listp browse-url-browser-function)
+ (browse-url address)
+ (funcall browse-url-browser-function address)))
+
+(defun gnus-button-embedded-url (address)
+ "Browse ADDRESS."
+ ;; In Emacs 20, `browse-url-browser-function' may be an alist.
+ (if (listp browse-url-browser-function)
+ (browse-url (gnus-strip-whitespace address))
+ (funcall browse-url-browser-function (gnus-strip-whitespace address))))
+
+;;; Next/prev buttons in the article buffer.
+
+(defvar gnus-next-page-line-format "%{%(Next page...%)%}\n")
+(defvar gnus-prev-page-line-format "%{%(Previous page...%)%}\n")
+
+(defvar gnus-prev-page-map nil)
+(unless gnus-prev-page-map
+ (setq gnus-prev-page-map (make-sparse-keymap))
+ (define-key gnus-prev-page-map gnus-mouse-2 'gnus-button-prev-page)
+ (define-key gnus-prev-page-map "\r" 'gnus-button-prev-page))
+
+(defun gnus-insert-prev-page-button ()
+ (let ((buffer-read-only nil))
+ (gnus-eval-format
+ gnus-prev-page-line-format nil
+ `(gnus-prev t local-map ,gnus-prev-page-map
+ gnus-callback gnus-article-button-prev-page
+ article-type annotation))))
+
+(defvar gnus-next-page-map nil)
+(unless gnus-next-page-map
+ (setq gnus-next-page-map (make-keymap))
+ (suppress-keymap gnus-prev-page-map)
+ (define-key gnus-next-page-map gnus-mouse-2 'gnus-button-next-page)
+ (define-key gnus-next-page-map "\r" 'gnus-button-next-page))
+
+(defun gnus-button-next-page ()
+ "Go to the next page."
+ (interactive)
+ (let ((win (selected-window)))
+ (select-window (get-buffer-window gnus-article-buffer t))
+ (gnus-article-next-page)
+ (select-window win)))
+
+(defun gnus-button-prev-page ()
+ "Go to the prev page."
+ (interactive)
+ (let ((win (selected-window)))
+ (select-window (get-buffer-window gnus-article-buffer t))
+ (gnus-article-prev-page)
+ (select-window win)))
+
+(defun gnus-insert-next-page-button ()
+ (let ((buffer-read-only nil))
+ (gnus-eval-format gnus-next-page-line-format nil
+ `(gnus-next
+ t local-map ,gnus-next-page-map
+ gnus-callback gnus-article-button-next-page
+ article-type annotation))))
+
+(defun gnus-article-button-next-page (arg)
+ "Go to the next page."
+ (interactive "P")
+ (let ((win (selected-window)))
+ (select-window (get-buffer-window gnus-article-buffer t))
+ (gnus-article-next-page)
+ (select-window win)))
+
+(defun gnus-article-button-prev-page (arg)
+ "Go to the prev page."
+ (interactive "P")
+ (let ((win (selected-window)))
+ (select-window (get-buffer-window gnus-article-buffer t))
+ (gnus-article-prev-page)
+ (select-window win)))
+
+(defvar gnus-decode-header-methods
+ '(gnus-decode-with-mail-decode-encoded-word-region)
+ "List of methods used to decode headers.
+
+This variable is a list of FUNCTION or (REGEXP . FUNCTION). If item is
+FUNCTION, FUNCTION will be apply to all newsgroups. If item is a
+(REGEXP . FUNCTION), FUNCTION will be only apply to thes newsgroups
+whose names match REGEXP.
+
+For example:
+((\"chinese\" . gnus-decode-encoded-word-region-by-guess)
+ mail-decode-encoded-word-region
+ (\"chinese\" . rfc1843-decode-region))
+")
+
+(defvar gnus-decode-header-methods-cache nil)
+
+(defun gnus-decode-with-mail-decode-encoded-word-region (start end)
+ (let ((rfc2047-default-charset gnus-newsgroup-default-charset)
+ (mm-charset-iso-8859-1-forced gnus-newsgroup-iso-8859-1-forced))
+ (mail-decode-encoded-word-region start end)))
+
+(defun gnus-multi-decode-header (start end)
+ "Apply the functions from `gnus-encoded-word-methods' that match."
+ (unless (and gnus-decode-header-methods-cache
+ (eq gnus-newsgroup-name
+ (car gnus-decode-header-methods-cache)))
+ (setq gnus-decode-header-methods-cache (list gnus-newsgroup-name))
+ (mapc '(lambda (x)
+ (if (symbolp x)
+ (nconc gnus-decode-header-methods-cache (list x))
+ (if (and gnus-newsgroup-name
+ (string-match (car x) gnus-newsgroup-name))
+ (nconc gnus-decode-header-methods-cache
+ (list (cdr x))))))
+ gnus-decode-header-methods))
+ (let ((xlist gnus-decode-header-methods-cache))
+ (pop xlist)
+ (save-restriction
+ (narrow-to-region start end)
+ (while xlist
+ (funcall (pop xlist) (point-min) (point-max))))))
+
+
+;;; @ for mime-view
+;;;
+
+(defun gnus-article-header-presentation-method (entity situation)
+ (mime-insert-header entity)
+ )
+
+(set-alist 'mime-header-presentation-method-alist
+ 'gnus-original-article-mode
+ #'gnus-article-header-presentation-method)
+
+(defun gnus-mime-preview-quitting-method ()
+ (if gnus-show-mime
+ (gnus-article-show-summary)
+ (mime-preview-kill-buffer)
+ (delete-other-windows)
+ (gnus-article-show-summary)
+ (gnus-summary-select-article nil t)
+ ))
+
+(set-alist 'mime-preview-quitting-method-alist
+ 'gnus-original-article-mode #'gnus-mime-preview-quitting-method)
+
+(defun gnus-following-method (buf)
+ (set-buffer buf)
+ (message-followup)
+ (message-yank-original)
+ (kill-buffer buf)
+ (goto-char (point-min))
+ )
+
+(set-alist 'mime-preview-following-method-alist
+ 'gnus-original-article-mode #'gnus-following-method)
+
+
+;;; @ end
+;;;
+
+(gnus-ems-redefine)
+
+(provide 'gnus-art)
+
+(run-hooks 'gnus-art-load-hook)
+
+;;; gnus-art.el ends here
projects / elisp / gnus.git- / commitdiff