cgit.sxemacs.org Git - gnus/blob - lisp/gnus-art.el

   1 ;;; gnus-art.el --- article mode commands for Gnus
   2 ;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001
   3 ;;        Free Software Foundation, Inc.
   4
   5 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
   6 ;; Keywords: news
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software; you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 2, or (at your option)
  13 ;; any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23 ;; Boston, MA 02111-1307, USA.
  24
  25 ;;; Commentary:
  26
  27 ;;; Code:
  28
  29 (eval-when-compile (require 'cl))
  30
  31 (require 'gnus)
  32 (require 'gnus-sum)
  33 (require 'gnus-spec)
  34 (require 'gnus-int)
  35 (require 'mm-bodies)
  36 (require 'mail-parse)
  37 (require 'mm-decode)
  38 (require 'mm-view)
  39 (require 'wid-edit)
  40 (require 'mm-uu)
  41
  42 (autoload 'gnus-msg-mail "gnus-msg" nil t)
  43 (autoload 'gnus-button-mailto "gnus-msg")
  44 (autoload 'gnus-button-reply "gnus-msg" nil t)
  45
  46 (defgroup gnus-article nil
  47   "Article display."
  48   :link '(custom-manual "(gnus)The Article Buffer")
  49   :group 'gnus)
  50
  51 (defgroup gnus-article-treat nil
  52   "Treating article parts."
  53   :link '(custom-manual "(gnus)Article Hiding")
  54   :group 'gnus-article)
  55
  56 (defgroup gnus-article-hiding nil
  57   "Hiding article parts."
  58   :link '(custom-manual "(gnus)Article Hiding")
  59   :group 'gnus-article)
  60
  61 (defgroup gnus-article-highlight nil
  62   "Article highlighting."
  63   :link '(custom-manual "(gnus)Article Highlighting")
  64   :group 'gnus-article
  65   :group 'gnus-visual)
  66
  67 (defgroup gnus-article-signature nil
  68   "Article signatures."
  69   :link '(custom-manual "(gnus)Article Signature")
  70   :group 'gnus-article)
  71
  72 (defgroup gnus-article-headers nil
  73   "Article headers."
  74   :link '(custom-manual "(gnus)Hiding Headers")
  75   :group 'gnus-article)
  76
  77 (defgroup gnus-article-washing nil
  78   "Special commands on articles."
  79   :link '(custom-manual "(gnus)Article Washing")
  80   :group 'gnus-article)
  81
  82 (defgroup gnus-article-emphasis nil
  83   "Fontisizing articles."
  84   :link '(custom-manual "(gnus)Article Fontisizing")
  85   :group 'gnus-article)
  86
  87 (defgroup gnus-article-saving nil
  88   "Saving articles."
  89   :link '(custom-manual "(gnus)Saving Articles")
  90   :group 'gnus-article)
  91
  92 (defgroup gnus-article-mime nil
  93   "Worshiping the MIME wonder."
  94   :link '(custom-manual "(gnus)Using MIME")
  95   :group 'gnus-article)
  96
  97 (defgroup gnus-article-buttons nil
  98   "Pushable buttons in the article buffer."
  99   :link '(custom-manual "(gnus)Article Buttons")
 100   :group 'gnus-article)
 101
 102 (defgroup gnus-article-various nil
 103   "Other article options."
 104   :link '(custom-manual "(gnus)Misc Article")
 105   :group 'gnus-article)
 106
 107 (defcustom gnus-ignored-headers
 108   '("^Path:" "^Expires:" "^Date-Received:" "^References:" "^Xref:" "^Lines:"
 109     "^Relay-Version:" "^Message-ID:" "^Approved:" "^Sender:" "^Received:"
 110     "^X-UIDL:" "^MIME-Version:" "^Return-Path:" "^In-Reply-To:"
 111     "^Content-Type:" "^Content-Transfer-Encoding:" "^X-WebTV-Signature:"
 112     "^X-MimeOLE:" "^X-MSMail-Priority:" "^X-Priority:" "^X-Loop:"
 113     "^X-Authentication-Warning:" "^X-MIME-Autoconverted:" "^X-Face:"
 114     "^X-Attribution:" "^X-Originating-IP:" "^Delivered-To:"
 115     "^NNTP-[-A-Za-z]+:" "^Distribution:" "^X-no-archive:" "^X-Trace:"
 116     "^X-Complaints-To:" "^X-NNTP-Posting-Host:" "^X-Orig.*:"
 117     "^Abuse-Reports-To:" "^Cache-Post-Path:" "^X-Article-Creation-Date:"
 118     "^X-Poster:" "^X-Mail2News-Path:" "^X-Server-Date:" "^X-Cache:"
 119     "^Originator:" "^X-Problems-To:" "^X-Auth-User:" "^X-Post-Time:"
 120     "^X-Admin:" "^X-UID:" "^Resent-[-A-Za-z]+:" "^X-Mailing-List:"
 121     "^Precedence:" "^Original-[-A-Za-z]+:" "^X-filename:" "^X-Orcpt:"
 122     "^Old-Received:" "^X-Pgp" "^X-Auth:" "^X-From-Line:"
 123     "^X-Gnus-Article-Number:" "^X-Majordomo:" "^X-Url:" "^X-Sender:"
 124     "^MBOX-Line" "^Priority:" "^X400-[-A-Za-z]+:"
 125     "^Status:" "^X-Gnus-Mail-Source:" "^Cancel-Lock:"
 126     "^X-FTN" "^X-EXP32-SerialNo:" "^Encoding:" "^Importance:"
 127     "^Autoforwarded:" "^Original-Encoded-Information-Types:" "^X-Ya-Pop3:"
 128     "^X-Face-Version:" "^X-Vms-To:" "^X-ML-NAME:" "^X-ML-COUNT:"
 129     "^Mailing-List:" "^X-finfo:" "^X-md5sum:" "^X-md5sum-Origin:"
 130     "^X-Sun-Charset:" "^X-Accept-Language:" "^X-Envelope-Sender:"
 131     "^List-[A-Za-z]+:" "^X-Listprocessor-Version:"
 132     "^X-Received:" "^X-Distribute:" "^X-Sequence:" "^X-Juno-Line-Breaks:"
 133     "^X-Notes-Item:" "^X-MS-TNEF-Correlator:" "^x-uunet-gateway:"
 134     "^X-Received:" "^Content-length:" "X-precedence:"
 135     "^X-Authenticated-User:" "^X-Comment" "^X-Report:" "^X-Abuse-Info:"
 136     "^X-HTTP-Proxy:" "^X-Mydeja-Info:" "^X-Copyright" "^X-No-Markup:"
 137     "^X-Abuse-Info:")
 138   "*All headers that start with this regexp will be hidden.
 139 This variable can also be a list of regexps of headers to be ignored.
 140 If `gnus-visible-headers' is non-nil, this variable will be ignored."
 141   :type '(choice :custom-show nil
 142                  regexp
 143                  (repeat regexp))
 144   :group 'gnus-article-hiding)
 145
 146 (defcustom gnus-visible-headers
 147   "^From:\\|^Newsgroups:\\|^Subject:\\|^Date:\\|^Followup-To:\\|^Reply-To:\\|^Organization:\\|^Summary:\\|^Keywords:\\|^To:\\|^[BGF]?Cc:\\|^Posted-To:\\|^Mail-Copies-To:\\|^Mail-Followup-To:\\|^Apparently-To:\\|^Gnus-Warning:\\|^Resent-From:\\|^X-Sent:"
 148   "*All headers that do not match this regexp will be hidden.
 149 This variable can also be a list of regexp of headers to remain visible.
 150 If this variable is non-nil, `gnus-ignored-headers' will be ignored."
 151   :type '(repeat :value-to-internal (lambda (widget value)
 152                                       (custom-split-regexp-maybe value))
 153                  :match (lambda (widget value)
 154                           (or (stringp value)
 155                               (widget-editable-list-match widget value)))
 156                  regexp)
 157   :group 'gnus-article-hiding)
 158
 159 (defcustom gnus-sorted-header-list
 160   '("^From:" "^Subject:" "^Summary:" "^Keywords:" "^Newsgroups:"
 161     "^Followup-To:" "^To:" "^Cc:" "^Date:" "^Organization:")
 162   "*This variable is a list of regular expressions.
 163 If it is non-nil, headers that match the regular expressions will
 164 be placed first in the article buffer in the sequence specified by
 165 this list."
 166   :type '(repeat regexp)
 167   :group 'gnus-article-hiding)
 168
 169 (defcustom gnus-boring-article-headers '(empty followup-to reply-to)
 170   "Headers that are only to be displayed if they have interesting data.
 171 Possible values in this list are `empty', `newsgroups', `followup-to',
 172 `to-address', `reply-to', `date', `long-to', and `many-to'."
 173   :type '(set (const :tag "Headers with no content." empty)
 174               (const :tag "Newsgroups with only one group." newsgroups)
 175               (const :tag "To identical to to-address." to-address)
 176               (const :tag "Followup-to identical to newsgroups." followup-to)
 177               (const :tag "Reply-to identical to from." reply-to)
 178               (const :tag "Date less than four days old." date)
 179               (const :tag "Very long To and/or Cc header." long-to)
 180               (const :tag "Multiple To and/or Cc headers." many-to))
 181   :group 'gnus-article-hiding)
 182
 183 (defcustom gnus-signature-separator '("^-- $" "^-- *$")
 184   "Regexp matching signature separator.
 185 This can also be a list of regexps.  In that case, it will be checked
 186 from head to tail looking for a separator.  Searches will be done from
 187 the end of the buffer."
 188   :type '(repeat string)
 189   :group 'gnus-article-signature)
 190
 191 (defcustom gnus-signature-limit nil
 192   "Provide a limit to what is considered a signature.
 193 If it is a number, no signature may not be longer (in characters) than
 194 that number.  If it is a floating point number, no signature may be
 195 longer (in lines) than that number.  If it is a function, the function
 196 will be called without any parameters, and if it returns nil, there is
 197 no signature in the buffer.  If it is a string, it will be used as a
 198 regexp.  If it matches, the text in question is not a signature."
 199   :type '(choice (integer :value 200)
 200                  (number :value 4.0)
 201                  (function :value fun)
 202                  (regexp :value ".*"))
 203   :group 'gnus-article-signature)
 204
 205 (defcustom gnus-hidden-properties '(invisible t intangible t)
 206   "Property list to use for hiding text."
 207   :type 'sexp
 208   :group 'gnus-article-hiding)
 209
 210 ;; Fixme: This isn't the right thing for mixed graphical and and
 211 ;; non-graphical frames in a session.
 212 ;; gnus-xmas.el overrides this for XEmacs.
 213 (defcustom gnus-article-x-face-command
 214   (if (and (fboundp 'image-type-available-p)
 215            (image-type-available-p 'xbm))
 216       'gnus-article-display-xface
 217     (if gnus-article-compface-xbm
 218         "{ echo '/* Width=48, Height=48 */'; uncompface; } | display -"
 219       "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | \
 220 display -"))
 221   "*String or function to be executed to display an X-Face header.
 222 If it is a string, the command will be executed in a sub-shell
 223 asynchronously.  The compressed face will be piped to this command."
 224   :type '(choice string
 225                  (function-item gnus-article-display-xface)
 226                  function)
 227   :version "21.1"
 228   :group 'gnus-article-washing)
 229
 230 (defcustom gnus-article-x-face-too-ugly nil
 231   "Regexp matching posters whose face shouldn't be shown automatically."
 232   :type '(choice regexp (const nil))
 233   :group 'gnus-article-washing)
 234
 235 (defcustom gnus-article-banner-alist nil
 236   "Banner alist for stripping.
 237 For example,
 238      ((egroups . \"^[ \\t\\n]*-------------------+\\\\( \\\\(e\\\\|Yahoo! \\\\)Groups Sponsor -+\\\\)?....\\n\\\\(.+\\n\\\\)+\"))"
 239   :version "21.1"
 240   :type '(repeat (cons symbol regexp))
 241   :group 'gnus-article-washing)
 242
 243 (gnus-define-group-parameter
 244  banner
 245  :variable-document
 246  "Alist of regexps (to match group names) and banner."
 247  :variable-group gnus-article-washing
 248  :parameter-type
 249  '(choice :tag "Banner"
 250           :value nil
 251           (const :tag "Remove signature" signature)
 252           (symbol :tag "Item in `gnus-article-banner-alist'" none)
 253           regexp
 254           (const :tag "None" nil))
 255  :parameter-document
 256  "If non-nil, specify how to remove `banners' from articles.
 257
 258 Symbol `signature' means to remove signatures delimited by
 259 `gnus-signature-separator'.  Any other symbol is used to look up a
 260 regular expression to match the banner in `gnus-article-banner-alist'.
 261 A string is used as a regular expression to match the banner
 262 directly.")
 263
 264 (defcustom gnus-emphasis-alist
 265   (let ((format
 266          "\\(\\s-\\|^\\|[-\"]\\|\\s(\\)\\(%s\\(\\w+\\(\\s-+\\w+\\)*[.,]?\\)%s\\)\\(\\s-\\|[-,;:\"]\\s-\\|[?!.]+\\s-\\|\\s)\\)")
 267         (types
 268          '(("_" "_" underline)
 269            ("/" "/" italic)
 270            ("\\*" "\\*" bold)
 271            ("_/" "/_" underline-italic)
 272            ("_\\*" "\\*_" underline-bold)
 273            ("\\*/" "/\\*" bold-italic)
 274            ("_\\*/" "/\\*_" underline-bold-italic))))
 275     `(("\\(\\s-\\|^\\)\\(_\\(\\(\\w\\|_[^_]\\)+\\)_\\)\\(\\s-\\|[?!.,;]\\)"
 276        2 3 gnus-emphasis-underline)
 277       ,@(mapcar
 278          (lambda (spec)
 279            (list
 280             (format format (car spec) (cadr spec))
 281             2 3 (intern (format "gnus-emphasis-%s" (nth 2 spec)))))
 282          types)))
 283   "*Alist that says how to fontify certain phrases.
 284 Each item looks like this:
 285
 286   (\"_\\\\(\\\\w+\\\\)_\" 0 1 'underline)
 287
 288 The first element is a regular expression to be matched.  The second
 289 is a number that says what regular expression grouping used to find
 290 the entire emphasized word.  The third is a number that says what
 291 regexp grouping should be displayed and highlighted.  The fourth
 292 is the face used for highlighting."
 293   :type '(repeat (list :value ("" 0 0 default)
 294                        regexp
 295                        (integer :tag "Match group")
 296                        (integer :tag "Emphasize group")
 297                        face))
 298   :group 'gnus-article-emphasis)
 299
 300 (defcustom gnus-emphasize-whitespace-regexp "^[ \t]+\\|[ \t]*\n"
 301   "A regexp to describe whitespace which should not be emphasized.
 302 Typical values are \"^[ \\t]+\\\\|[ \\t]*\\n\" and \"[ \\t]+\\\\|[ \\t]*\\n\".
 303 The former avoids underlining of leading and trailing whitespace,
 304 and the latter avoids underlining any whitespace at all."
 305   :version "21.1"
 306   :group 'gnus-article-emphasis
 307   :type 'regexp)
 308
 309 (defface gnus-emphasis-bold '((t (:bold t)))
 310   "Face used for displaying strong emphasized text (*word*)."
 311   :group 'gnus-article-emphasis)
 312
 313 (defface gnus-emphasis-italic '((t (:italic t)))
 314   "Face used for displaying italic emphasized text (/word/)."
 315   :group 'gnus-article-emphasis)
 316
 317 (defface gnus-emphasis-underline '((t (:underline t)))
 318   "Face used for displaying underlined emphasized text (_word_)."
 319   :group 'gnus-article-emphasis)
 320
 321 (defface gnus-emphasis-underline-bold '((t (:bold t :underline t)))
 322   "Face used for displaying underlined bold emphasized text (_*word*_)."
 323   :group 'gnus-article-emphasis)
 324
 325 (defface gnus-emphasis-underline-italic '((t (:italic t :underline t)))
 326   "Face used for displaying underlined italic emphasized text (_/word/_)."
 327   :group 'gnus-article-emphasis)
 328
 329 (defface gnus-emphasis-bold-italic '((t (:bold t :italic t)))
 330   "Face used for displaying bold italic emphasized text (/*word*/)."
 331   :group 'gnus-article-emphasis)
 332
 333 (defface gnus-emphasis-underline-bold-italic
 334   '((t (:bold t :italic t :underline t)))
 335   "Face used for displaying underlined bold italic emphasized text.
 336 Esample: (_/*word*/_)."
 337   :group 'gnus-article-emphasis)
 338
 339 (defface gnus-emphasis-highlight-words
 340   '((t (:background "black" :foreground "yellow")))
 341   "Face used for displaying highlighted words."
 342   :group 'gnus-article-emphasis)
 343
 344 (defcustom gnus-article-time-format "%a, %b %d %Y %T %Z"
 345   "Format for display of Date headers in article bodies.
 346 See `format-time-string' for the possible values.
 347
 348 The variable can also be function, which should return a complete Date
 349 header.  The function is called with one argument, the time, which can
 350 be fed to `format-time-string'."
 351   :type '(choice string symbol)
 352   :link '(custom-manual "(gnus)Article Date")
 353   :group 'gnus-article-washing)
 354
 355 (eval-and-compile
 356   (autoload 'mail-extract-address-components "mail-extr"))
 357
 358 (defcustom gnus-save-all-headers t
 359   "*If non-nil, don't remove any headers before saving."
 360   :group 'gnus-article-saving
 361   :type 'boolean)
 362
 363 (defcustom gnus-prompt-before-saving 'always
 364   "*This variable says how much prompting is to be done when saving articles.
 365 If it is nil, no prompting will be done, and the articles will be
 366 saved to the default files.  If this variable is `always', each and
 367 every article that is saved will be preceded by a prompt, even when
 368 saving large batches of articles.  If this variable is neither nil not
 369 `always', there the user will be prompted once for a file name for
 370 each invocation of the saving commands."
 371   :group 'gnus-article-saving
 372   :type '(choice (item always)
 373                  (item :tag "never" nil)
 374                  (sexp :tag "once" :format "%t\n" :value t)))
 375
 376 (defcustom gnus-saved-headers gnus-visible-headers
 377   "Headers to keep if `gnus-save-all-headers' is nil.
 378 If `gnus-save-all-headers' is non-nil, this variable will be ignored.
 379 If that variable is nil, however, all headers that match this regexp
 380 will be kept while the rest will be deleted before saving."
 381   :group 'gnus-article-saving
 382   :type 'regexp)
 383
 384 (defcustom gnus-default-article-saver 'gnus-summary-save-in-rmail
 385   "A function to save articles in your favourite format.
 386 The function must be interactively callable (in other words, it must
 387 be an Emacs command).
 388
 389 Gnus provides the following functions:
 390
 391 * gnus-summary-save-in-rmail (Rmail format)
 392 * gnus-summary-save-in-mail (Unix mail format)
 393 * gnus-summary-save-in-folder (MH folder)
 394 * gnus-summary-save-in-file (article format)
 395 * gnus-summary-save-in-vm (use VM's folder format)
 396 * gnus-summary-write-to-file (article format -- overwrite)."
 397   :group 'gnus-article-saving
 398   :type '(radio (function-item gnus-summary-save-in-rmail)
 399                 (function-item gnus-summary-save-in-mail)
 400                 (function-item gnus-summary-save-in-folder)
 401                 (function-item gnus-summary-save-in-file)
 402                 (function-item gnus-summary-save-in-vm)
 403                 (function-item gnus-summary-write-to-file)))
 404
 405 (defcustom gnus-rmail-save-name 'gnus-plain-save-name
 406   "A function generating a file name to save articles in Rmail format.
 407 The function is called with NEWSGROUP, HEADERS, and optional LAST-FILE."
 408   :group 'gnus-article-saving
 409   :type 'function)
 410
 411 (defcustom gnus-mail-save-name 'gnus-plain-save-name
 412   "A function generating a file name to save articles in Unix mail format.
 413 The function is called with NEWSGROUP, HEADERS, and optional LAST-FILE."
 414   :group 'gnus-article-saving
 415   :type 'function)
 416
 417 (defcustom gnus-folder-save-name 'gnus-folder-save-name
 418   "A function generating a file name to save articles in MH folder.
 419 The function is called with NEWSGROUP, HEADERS, and optional LAST-FOLDER."
 420   :group 'gnus-article-saving
 421   :type 'function)
 422
 423 (defcustom gnus-file-save-name 'gnus-numeric-save-name
 424   "A function generating a file name to save articles in article format.
 425 The function is called with NEWSGROUP, HEADERS, and optional
 426 LAST-FILE."
 427   :group 'gnus-article-saving
 428   :type 'function)
 429
 430 (defcustom gnus-split-methods
 431   '((gnus-article-archive-name)
 432     (gnus-article-nndoc-name))
 433   "*Variable used to suggest where articles are to be saved.
 434 For instance, if you would like to save articles related to Gnus in
 435 the file \"gnus-stuff\", and articles related to VM in \"vm-stuff\",
 436 you could set this variable to something like:
 437
 438  '((\"^Subject:.*gnus\\|^Newsgroups:.*gnus\" \"gnus-stuff\")
 439    (\"^Subject:.*vm\\|^Xref:.*vm\" \"vm-stuff\"))
 440
 441 This variable is an alist where the where the key is the match and the
 442 value is a list of possible files to save in if the match is non-nil.
 443
 444 If the match is a string, it is used as a regexp match on the
 445 article.  If the match is a symbol, that symbol will be funcalled
 446 from the buffer of the article to be saved with the newsgroup as the
 447 parameter.  If it is a list, it will be evaled in the same buffer.
 448
 449 If this form or function returns a string, this string will be used as
 450 a possible file name; and if it returns a non-nil list, that list will
 451 be used as possible file names."
 452   :group 'gnus-article-saving
 453   :type '(repeat (choice (list :value (fun) function)
 454                          (cons :value ("" "") regexp (repeat string))
 455                          (sexp :value nil))))
 456
 457 (defcustom gnus-page-delimiter "^\^L"
 458   "*Regexp describing what to use as article page delimiters.
 459 The default value is \"^\^L\", which is a form linefeed at the
 460 beginning of a line."
 461   :type 'regexp
 462   :group 'gnus-article-various)
 463
 464 (defcustom gnus-article-mode-line-format "Gnus: %g [%w] %S%m"
 465   "*The format specification for the article mode line.
 466 See `gnus-summary-mode-line-format' for a closer description.
 467
 468 The following additional specs are available:
 469
 470 %w  The article washing status.
 471 %m  The number of MIME parts in the article."
 472   :type 'string
 473   :group 'gnus-article-various)
 474
 475 (defcustom gnus-article-mode-hook nil
 476   "*A hook for Gnus article mode."
 477   :type 'hook
 478   :group 'gnus-article-various)
 479
 480 (when (featurep 'xemacs)
 481   ;; Extracted from gnus-xmas-define in order to preserve user settings
 482   (when (fboundp 'turn-off-scroll-in-place)
 483     (add-hook 'gnus-article-mode-hook 'turn-off-scroll-in-place))
 484   ;; Extracted from gnus-xmas-redefine in order to preserve user settings
 485   (add-hook 'gnus-article-mode-hook 'gnus-xmas-article-menu-add))
 486
 487 (defcustom gnus-article-menu-hook nil
 488   "*Hook run after the creation of the article mode menu."
 489   :type 'hook
 490   :group 'gnus-article-various)
 491
 492 (defcustom gnus-article-prepare-hook nil
 493   "*A hook called after an article has been prepared in the article buffer."
 494   :type 'hook
 495   :group 'gnus-article-various)
 496
 497 (defcustom gnus-article-hide-pgp-hook nil
 498   "*A hook called after successfully hiding a PGP signature."
 499   :type 'hook
 500   :group 'gnus-article-various)
 501
 502 (defcustom gnus-article-button-face 'bold
 503   "Face used for highlighting buttons in the article buffer.
 504
 505 An article button is a piece of text that you can activate by pressing
 506 `RET' or `mouse-2' above it."
 507   :type 'face
 508   :group 'gnus-article-buttons)
 509
 510 (defcustom gnus-article-mouse-face 'highlight
 511   "Face used for mouse highlighting in the article buffer.
 512
 513 Article buttons will be displayed in this face when the cursor is
 514 above them."
 515   :type 'face
 516   :group 'gnus-article-buttons)
 517
 518 (defcustom gnus-signature-face 'gnus-signature-face
 519   "Face used for highlighting a signature in the article buffer.
 520 Obsolete; use the face `gnus-signature-face' for customizations instead."
 521   :type 'face
 522   :group 'gnus-article-highlight
 523   :group 'gnus-article-signature)
 524
 525 (defface gnus-signature-face
 526   '((t
 527      (:italic t)))
 528   "Face used for highlighting a signature in the article buffer."
 529   :group 'gnus-article-highlight
 530   :group 'gnus-article-signature)
 531
 532 (defface gnus-header-from-face
 533   '((((class color)
 534       (background dark))
 535      (:foreground "spring green"))
 536     (((class color)
 537       (background light))
 538      (:foreground "red3"))
 539     (t
 540      (:italic t)))
 541   "Face used for displaying from headers."
 542   :group 'gnus-article-headers
 543   :group 'gnus-article-highlight)
 544
 545 (defface gnus-header-subject-face
 546   '((((class color)
 547       (background dark))
 548      (:foreground "SeaGreen3"))
 549     (((class color)
 550       (background light))
 551      (:foreground "red4"))
 552     (t
 553      (:bold t :italic t)))
 554   "Face used for displaying subject headers."
 555   :group 'gnus-article-headers
 556   :group 'gnus-article-highlight)
 557
 558 (defface gnus-header-newsgroups-face
 559   '((((class color)
 560       (background dark))
 561      (:foreground "yellow" :italic t))
 562     (((class color)
 563       (background light))
 564      (:foreground "MidnightBlue" :italic t))
 565     (t
 566      (:italic t)))
 567   "Face used for displaying newsgroups headers."
 568   :group 'gnus-article-headers
 569   :group 'gnus-article-highlight)
 570
 571 (defface gnus-header-name-face
 572   '((((class color)
 573       (background dark))
 574      (:foreground "SeaGreen"))
 575     (((class color)
 576       (background light))
 577      (:foreground "maroon"))
 578     (t
 579      (:bold t)))
 580   "Face used for displaying header names."
 581   :group 'gnus-article-headers
 582   :group 'gnus-article-highlight)
 583
 584 (defface gnus-header-content-face
 585   '((((class color)
 586       (background dark))
 587      (:foreground "forest green" :italic t))
 588     (((class color)
 589       (background light))
 590      (:foreground "indianred4" :italic t))
 591     (t
 592      (:italic t)))  "Face used for displaying header content."
 593   :group 'gnus-article-headers
 594   :group 'gnus-article-highlight)
 595
 596 (defcustom gnus-header-face-alist
 597   '(("From" nil gnus-header-from-face)
 598     ("Subject" nil gnus-header-subject-face)
 599     ("Newsgroups:.*," nil gnus-header-newsgroups-face)
 600     ("" gnus-header-name-face gnus-header-content-face))
 601   "*Controls highlighting of article header.
 602
 603 An alist of the form (HEADER NAME CONTENT).
 604
 605 HEADER is a regular expression which should match the name of an
 606 header header and NAME and CONTENT are either face names or nil.
 607
 608 The name of each header field will be displayed using the face
 609 specified by the first element in the list where HEADER match the
 610 header name and NAME is non-nil.  Similarly, the content will be
 611 displayed by the first non-nil matching CONTENT face."
 612   :group 'gnus-article-headers
 613   :group 'gnus-article-highlight
 614   :type '(repeat (list (regexp :tag "Header")
 615                        (choice :tag "Name"
 616                                (item :tag "skip" nil)
 617                                (face :value default))
 618                        (choice :tag "Content"
 619                                (item :tag "skip" nil)
 620                                (face :value default)))))
 621
 622 (defcustom gnus-article-decode-hook
 623   '(article-decode-charset article-decode-encoded-words)
 624   "*Hook run to decode charsets in articles."
 625   :group 'gnus-article-headers
 626   :type 'hook)
 627
 628 (defcustom gnus-display-mime-function 'gnus-display-mime
 629   "Function to display MIME articles."
 630   :group 'gnus-article-mime
 631   :type 'function)
 632
 633 (defvar gnus-decode-header-function 'mail-decode-encoded-word-region
 634   "Function used to decode headers.")
 635
 636 (defvar gnus-article-dumbquotes-map
 637   '(("\200" "EUR")
 638     ("\202" ",")
 639     ("\203" "f")
 640     ("\204" ",,")
 641     ("\205" "...")
 642     ("\213" "<")
 643     ("\214" "OE")
 644     ("\221" "`")
 645     ("\222" "'")
 646     ("\223" "``")
 647     ("\224" "\"")
 648     ("\225" "*")
 649     ("\226" "-")
 650     ("\227" "--")
 651     ("\231" "(TM)")
 652     ("\233" ">")
 653     ("\234" "oe")
 654     ("\264" "'"))
 655   "Table for MS-to-Latin1 translation.")
 656
 657 (defcustom gnus-ignored-mime-types nil
 658   "List of MIME types that should be ignored by Gnus."
 659   :version "21.1"
 660   :group 'gnus-article-mime
 661   :type '(repeat regexp))
 662
 663 (defcustom gnus-unbuttonized-mime-types '(".*/.*")
 664   "List of MIME types that should not be given buttons when rendered inline."
 665   :version "21.1"
 666   :group 'gnus-article-mime
 667   :type '(repeat regexp))
 668
 669 (defcustom gnus-article-mime-part-function nil
 670   "Function called with a MIME handle as the argument.
 671 This is meant for people who want to do something automatic based
 672 on parts -- for instance, adding Vcard info to a database."
 673   :group 'gnus-article-mime
 674   :type 'function)
 675
 676 (defcustom gnus-mime-multipart-functions nil
 677   "An alist of MIME types to functions to display them."
 678   :version "21.1"
 679   :group 'gnus-article-mime
 680   :type 'alist)
 681
 682 (defcustom gnus-article-date-lapsed-new-header nil
 683   "Whether the X-Sent and Date headers can coexist.
 684 When using `gnus-treat-date-lapsed', the \"X-Sent:\" header will
 685 either replace the old \"Date:\" header (if this variable is nil), or
 686 be added below it (otherwise)."
 687   :version "21.1"
 688   :group 'gnus-article-headers
 689   :type 'boolean)
 690
 691 (defcustom gnus-article-mime-match-handle-function 'undisplayed-alternative
 692   "Function called with a MIME handle as the argument.
 693 This is meant for people who want to view first matched part.
 694 For `undisplayed-alternative' (default), the first undisplayed
 695 part or alternative part is used.  For `undisplayed', the first
 696 undisplayed part is used.  For a function, the first part which
 697 the function return `t' is used.  For `nil', the first part is
 698 used."
 699   :version "21.1"
 700   :group 'gnus-article-mime
 701   :type '(choice
 702           (item :tag "first" :value nil)
 703           (item :tag "undisplayed" :value undisplayed)
 704           (item :tag "undisplayed or alternative"
 705                 :value undisplayed-alternative)
 706           (function)))
 707
 708 (defcustom gnus-mime-action-alist
 709   '(("save to file" . gnus-mime-save-part)
 710     ("save and strip" . gnus-mime-save-part-and-strip)
 711     ("display as text" . gnus-mime-inline-part)
 712     ("view the part" . gnus-mime-view-part)
 713     ("pipe to command" . gnus-mime-pipe-part)
 714     ("toggle display" . gnus-article-press-button)
 715     ("toggle display" . gnus-article-view-part-as-charset)
 716     ("view as type" . gnus-mime-view-part-as-type)
 717     ("internalize type" . gnus-mime-internalize-part)
 718     ("externalize type" . gnus-mime-externalize-part))
 719   "An alist of actions that run on the MIME attachment."
 720   :group 'gnus-article-mime
 721   :type '(repeat (cons (string :tag "name")
 722                        (function))))
 723
 724 (defcustom gnus-mime-action-alist
 725   '(("save to file" . gnus-mime-save-part)
 726     ("display as text" . gnus-mime-inline-part)
 727     ("view the part" . gnus-mime-view-part)
 728     ("pipe to command" . gnus-mime-pipe-part)
 729     ("toggle display" . gnus-article-press-button)
 730     ("view as type" . gnus-mime-view-part-as-type)
 731     ("internalize type" . gnus-mime-internalize-part)
 732     ("externalize type" . gnus-mime-externalize-part))
 733   "An alist of actions that run on the MIME attachment."
 734   :version "21.1"
 735   :group 'gnus-article-mime
 736   :type '(repeat (cons (string :tag "name")
 737                        (function))))
 738
 739 ;;;
 740 ;;; The treatment variables
 741 ;;;
 742
 743 (defvar gnus-part-display-hook nil
 744   "Hook called on parts that are to receive treatment.")
 745
 746 (defvar gnus-article-treat-custom
 747   '(choice (const :tag "Off" nil)
 748            (const :tag "On" t)
 749            (const :tag "Header" head)
 750            (const :tag "Last" last)
 751            (integer :tag "Less")
 752            (repeat :tag "Groups" regexp)
 753            (sexp :tag "Predicate")))
 754
 755 (defvar gnus-article-treat-head-custom
 756   '(choice (const :tag "Off" nil)
 757            (const :tag "Header" head)))
 758
 759 (defvar gnus-article-treat-types '("text/plain")
 760   "Parts to treat.")
 761
 762 (defvar gnus-inhibit-treatment nil
 763   "Whether to inhibit treatment.")
 764
 765 (defcustom gnus-treat-highlight-signature '(or last (typep "text/x-vcard"))
 766   "Highlight the signature.
 767 Valid values are nil, t, `head', `last', an integer or a predicate.
 768 See the manual for details."
 769   :group 'gnus-article-treat
 770   :type gnus-article-treat-custom)
 771 (put 'gnus-treat-highlight-signature 'highlight t)
 772
 773 (defcustom gnus-treat-buttonize 100000
 774   "Add buttons.
 775 Valid values are nil, t, `head', `last', an integer or a predicate.
 776 See the manual for details."
 777   :group 'gnus-article-treat
 778   :type gnus-article-treat-custom)
 779 (put 'gnus-treat-buttonize 'highlight t)
 780
 781 (defcustom gnus-treat-buttonize-head 'head
 782   "Add buttons to the head.
 783 Valid values are nil, t, `head', `last', an integer or a predicate.
 784 See the manual for details."
 785   :group 'gnus-article-treat
 786   :type gnus-article-treat-head-custom)
 787 (put 'gnus-treat-buttonize-head 'highlight t)
 788
 789 (defcustom gnus-treat-emphasize
 790   (and (or window-system
 791            (featurep 'xemacs)
 792            (>= (string-to-number emacs-version) 21))
 793        50000)
 794   "Emphasize text.
 795 Valid values are nil, t, `head', `last', an integer or a predicate.
 796 See the manual for details."
 797   :group 'gnus-article-treat
 798   :type gnus-article-treat-custom)
 799 (put 'gnus-treat-emphasize 'highlight t)
 800
 801 (defcustom gnus-treat-strip-cr nil
 802   "Remove carriage returns.
 803 Valid values are nil, t, `head', `last', an integer or a predicate.
 804 See the manual for details."
 805   :group 'gnus-article-treat
 806   :type gnus-article-treat-custom)
 807
 808 (defcustom gnus-treat-leading-whitespace nil
 809   "Remove leading whitespace in headers.
 810 Valid values are nil, t, `head', `last', an integer or a predicate.
 811 See the manual for details."
 812   :group 'gnus-article-treat
 813   :type gnus-article-treat-custom)
 814
 815 (defcustom gnus-treat-hide-headers 'head
 816   "Hide headers.
 817 Valid values are nil, t, `head', `last', an integer or a predicate.
 818 See the manual for details."
 819   :group 'gnus-article-treat
 820   :type gnus-article-treat-head-custom)
 821
 822 (defcustom gnus-treat-hide-boring-headers nil
 823   "Hide boring headers.
 824 Valid values are nil, t, `head', `last', an integer or a predicate.
 825 See the manual for details."
 826   :group 'gnus-article-treat
 827   :type gnus-article-treat-head-custom)
 828
 829 (defcustom gnus-treat-hide-signature nil
 830   "Hide the signature.
 831 Valid values are nil, t, `head', `last', an integer or a predicate.
 832 See the manual for details."
 833   :group 'gnus-article-treat
 834   :type gnus-article-treat-custom)
 835
 836 (defcustom gnus-treat-fill-article nil
 837   "Fill the article.
 838 Valid values are nil, t, `head', `last', an integer or a predicate.
 839 See the manual for details."
 840   :group 'gnus-article-treat
 841   :type gnus-article-treat-custom)
 842
 843 (defcustom gnus-treat-hide-citation nil
 844   "Hide cited text.
 845 Valid values are nil, t, `head', `last', an integer or a predicate.
 846 See the manual for details."
 847   :group 'gnus-article-treat
 848   :type gnus-article-treat-custom)
 849
 850 (defcustom gnus-treat-hide-citation-maybe nil
 851   "Hide cited text.
 852 Valid values are nil, t, `head', `last', an integer or a predicate.
 853 See the manual for details."
 854   :group 'gnus-article-treat
 855   :type gnus-article-treat-custom)
 856
 857 (defcustom gnus-treat-hide-citation-maybe nil
 858   "Hide cited text.
 859 Valid values are nil, t, `head', `last', an integer or a predicate.
 860 See the manual for details."
 861   :group 'gnus-article-treat
 862   :type gnus-article-treat-custom)
 863
 864 (defcustom gnus-treat-strip-list-identifiers 'head
 865   "Strip list identifiers from `gnus-list-identifiers`.
 866 Valid values are nil, t, `head', `last', an integer or a predicate.
 867 See the manual for details."
 868   :version "21.1"
 869   :group 'gnus-article-treat
 870   :type gnus-article-treat-custom)
 871
 872 (defcustom gnus-treat-strip-pgp t
 873   "Strip PGP signatures.
 874 Valid values are nil, t, `head', `last', an integer or a predicate.
 875 See the manual for details."
 876   :group 'gnus-article-treat
 877   :type gnus-article-treat-custom)
 878
 879 (defcustom gnus-treat-strip-pem nil
 880   "Strip PEM signatures.
 881 Valid values are nil, t, `head', `last', an integer or a predicate.
 882 See the manual for details."
 883   :group 'gnus-article-treat
 884   :type gnus-article-treat-custom)
 885
 886 (defcustom gnus-treat-strip-banner t
 887   "Strip banners from articles.
 888 The banner to be stripped is specified in the `banner' group parameter.
 889 Valid values are nil, t, `head', `last', an integer or a predicate.
 890 See the manual for details."
 891   :group 'gnus-article-treat
 892   :type gnus-article-treat-custom)
 893
 894 (defcustom gnus-treat-highlight-headers 'head
 895   "Highlight the headers.
 896 Valid values are nil, t, `head', `last', an integer or a predicate.
 897 See the manual for details."
 898   :group 'gnus-article-treat
 899   :type gnus-article-treat-head-custom)
 900 (put 'gnus-treat-highlight-headers 'highlight t)
 901
 902 (defcustom gnus-treat-highlight-citation t
 903   "Highlight cited text.
 904 Valid values are nil, t, `head', `last', an integer or a predicate.
 905 See the manual for details."
 906   :group 'gnus-article-treat
 907   :type gnus-article-treat-custom)
 908 (put 'gnus-treat-highlight-citation 'highlight t)
 909
 910 (defcustom gnus-treat-date-ut nil
 911   "Display the Date in UT (GMT).
 912 Valid values are nil, t, `head', `last', an integer or a predicate.
 913 See the manual for details."
 914   :group 'gnus-article-treat
 915   :type gnus-article-treat-head-custom)
 916
 917 (defcustom gnus-treat-date-local nil
 918   "Display the Date in the local timezone.
 919 Valid values are nil, t, `head', `last', an integer or a predicate.
 920 See the manual for details."
 921   :group 'gnus-article-treat
 922   :type gnus-article-treat-head-custom)
 923
 924 (defcustom gnus-treat-date-english nil
 925   "Display the Date in a format that can be read aloud in English.
 926 Valid values are nil, t, `head', `last', an integer or a predicate.
 927 See the manual for details."
 928   :group 'gnus-article-treat
 929   :type gnus-article-treat-head-custom)
 930
 931 (defcustom gnus-treat-date-lapsed nil
 932   "Display the Date header in a way that says how much time has elapsed.
 933 Valid values are nil, t, `head', `last', an integer or a predicate.
 934 See the manual for details."
 935   :group 'gnus-article-treat
 936   :type gnus-article-treat-head-custom)
 937
 938 (defcustom gnus-treat-date-original nil
 939   "Display the date in the original timezone.
 940 Valid values are nil, t, `head', `last', an integer or a predicate.
 941 See the manual for details."
 942   :group 'gnus-article-treat
 943   :type gnus-article-treat-head-custom)
 944
 945 (defcustom gnus-treat-date-iso8601 nil
 946   "Display the date in the ISO8601 format.
 947 Valid values are nil, t, `head', `last', an integer or a predicate.
 948 See the manual for details."
 949   :version "21.1"
 950   :group 'gnus-article-treat
 951   :type gnus-article-treat-head-custom)
 952
 953 (defcustom gnus-treat-date-user-defined nil
 954   "Display the date in a user-defined format.
 955 The format is defined by the `gnus-article-time-format' variable.
 956 Valid values are nil, t, `head', `last', an integer or a predicate.
 957 See the manual for details."
 958   :group 'gnus-article-treat
 959   :type gnus-article-treat-head-custom)
 960
 961 (defcustom gnus-treat-strip-headers-in-body t
 962   "Strip the X-No-Archive header line from the beginning of the body.
 963 Valid values are nil, t, `head', `last', an integer or a predicate.
 964 See the manual for details."
 965   :version "21.1"
 966   :group 'gnus-article-treat
 967   :type gnus-article-treat-custom)
 968
 969 (defcustom gnus-treat-strip-trailing-blank-lines nil
 970   "Strip trailing blank lines.
 971 Valid values are nil, t, `head', `last', an integer or a predicate.
 972 See the manual for details."
 973   :group 'gnus-article-treat
 974   :type gnus-article-treat-custom)
 975
 976 (defcustom gnus-treat-strip-leading-blank-lines nil
 977   "Strip leading blank lines.
 978 Valid values are nil, t, `head', `last', an integer or a predicate.
 979 See the manual for details."
 980   :group 'gnus-article-treat
 981   :type gnus-article-treat-custom)
 982
 983 (defcustom gnus-treat-strip-multiple-blank-lines nil
 984   "Strip multiple blank lines.
 985 Valid values are nil, t, `head', `last', an integer or a predicate.
 986 See the manual for details."
 987   :group 'gnus-article-treat
 988   :type gnus-article-treat-custom)
 989
 990 (defcustom gnus-treat-overstrike t
 991   "Treat overstrike highlighting.
 992 Valid values are nil, t, `head', `last', an integer or a predicate.
 993 See the manual for details."
 994   :group 'gnus-article-treat
 995   :type gnus-article-treat-custom)
 996 (put 'gnus-treat-overstrike 'highlight t)
 997
 998 (defcustom gnus-treat-display-xface
 999   (and (or (and (fboundp 'image-type-available-p)
1000                 (image-type-available-p 'xbm)
1001                 (string-match "^0x" (shell-command-to-string "uncompface")))
1002            (and (featurep 'xemacs) (featurep 'xface)))
1003        'head)
1004   "Display X-Face headers.
1005 Valid values are nil, t, `head', `last', an integer or a predicate.
1006 See the manual for details."
1007   :group 'gnus-article-treat
1008   :version "21.1"
1009   :type gnus-article-treat-head-custom)
1010 (put 'gnus-treat-display-xface 'highlight t)
1011
1012 (defcustom gnus-treat-display-smileys
1013   (if (or (and (featurep 'xemacs)
1014                (featurep 'xpm))
1015           (and (fboundp 'image-type-available-p)
1016                (image-type-available-p 'pbm)))
1017       t nil)
1018   "Display smileys.
1019 Valid values are nil, t, `head', `last', an integer or a predicate.
1020 See the manual for details."
1021   :group 'gnus-article-treat
1022   :version "21.1"
1023   :type gnus-article-treat-custom)
1024 (put 'gnus-treat-display-smileys 'highlight t)
1025
1026 (defcustom gnus-treat-display-picons (if (featurep 'xemacs) 'head nil)
1027   "Display picons.
1028 Valid values are nil, t, `head', `last', an integer or a predicate.
1029 See the manual for details."
1030   :group 'gnus-article-treat
1031   :type gnus-article-treat-head-custom)
1032 (put 'gnus-treat-display-picons 'highlight t)
1033
1034 (defcustom gnus-treat-capitalize-sentences nil
1035   "Capitalize sentence-starting words.
1036 Valid values are nil, t, `head', `last', an integer or a predicate.
1037 See the manual for details."
1038   :version "21.1"
1039   :group 'gnus-article-treat
1040   :type gnus-article-treat-custom)
1041
1042 (defcustom gnus-treat-fill-long-lines nil
1043   "Fill long lines.
1044 Valid values are nil, t, `head', `last', an integer or a predicate.
1045 See the manual for details."
1046   :group 'gnus-article-treat
1047   :type gnus-article-treat-custom)
1048
1049 (defcustom gnus-treat-play-sounds nil
1050   "Play sounds.
1051 Valid values are nil, t, `head', `last', an integer or a predicate.
1052 See the manual for details."
1053   :version "21.1"
1054   :group 'gnus-article-treat
1055   :type gnus-article-treat-custom)
1056
1057 (defcustom gnus-treat-translate nil
1058   "Translate articles from one language to another.
1059 Valid values are nil, t, `head', `last', an integer or a predicate.
1060 See the manual for details."
1061   :version "21.1"
1062   :group 'gnus-article-treat
1063   :type gnus-article-treat-custom)
1064
1065 (defcustom gnus-treat-x-pgp-sig nil
1066   "Verify X-PGP-Sig.
1067 To automatically treat X-PGP-Sig, set it to head.
1068 Valid values are nil, t, `head', `last', an integer or a predicate.
1069 See the manual for details."
1070   :group 'gnus-article-treat
1071   :group 'mime-security
1072   :type gnus-article-treat-custom)
1073
1074 (defvar gnus-article-encrypt-protocol-alist
1075   '(("PGP" . mml2015-self-encrypt)))
1076
1077 ;; Set to nil if more than one protocol added to
1078 ;; gnus-article-encrypt-protocol-alist.
1079 (defcustom gnus-article-encrypt-protocol "PGP"
1080   "The protocol used for encrypt articles.
1081 It is a string, such as \"PGP\". If nil, ask user."
1082   :type 'string
1083   :group 'mime-security)
1084
1085 ;;; Internal variables
1086
1087 (defvar gnus-english-month-names
1088   '("January" "February" "March" "April" "May" "June" "July" "August"
1089     "September" "October" "November" "December"))
1090
1091 (defvar article-goto-body-goes-to-point-min-p nil)
1092 (defvar gnus-article-wash-types nil)
1093 (defvar gnus-article-emphasis-alist nil)
1094
1095 (defvar gnus-article-mime-handle-alist-1 nil)
1096 (defvar gnus-treatment-function-alist
1097   '((gnus-treat-x-pgp-sig gnus-article-verify-x-pgp-sig)
1098     (gnus-treat-strip-banner gnus-article-strip-banner)
1099     (gnus-treat-strip-headers-in-body gnus-article-strip-headers-in-body)
1100     (gnus-treat-highlight-signature gnus-article-highlight-signature)
1101     (gnus-treat-buttonize gnus-article-add-buttons)
1102     (gnus-treat-fill-article gnus-article-fill-cited-article)
1103     (gnus-treat-fill-long-lines gnus-article-fill-long-lines)
1104     (gnus-treat-strip-cr gnus-article-remove-cr)
1105     (gnus-treat-emphasize gnus-article-emphasize)
1106     (gnus-treat-display-xface gnus-article-display-x-face)
1107     (gnus-treat-date-ut gnus-article-date-ut)
1108     (gnus-treat-date-local gnus-article-date-local)
1109     (gnus-treat-date-english gnus-article-date-english)
1110     (gnus-treat-date-lapsed gnus-article-date-lapsed)
1111     (gnus-treat-date-original gnus-article-date-original)
1112     (gnus-treat-date-user-defined gnus-article-date-user)
1113     (gnus-treat-date-iso8601 gnus-article-date-iso8601)
1114     (gnus-treat-hide-headers gnus-article-maybe-hide-headers)
1115     (gnus-treat-hide-boring-headers gnus-article-hide-boring-headers)
1116     (gnus-treat-hide-signature gnus-article-hide-signature)
1117     (gnus-treat-hide-citation gnus-article-hide-citation)
1118     (gnus-treat-hide-citation-maybe gnus-article-hide-citation-maybe)
1119     (gnus-treat-strip-list-identifiers gnus-article-hide-list-identifiers)
1120     (gnus-treat-leading-whitespace gnus-article-remove-leading-whitespace)
1121     (gnus-treat-strip-pgp gnus-article-hide-pgp)
1122     (gnus-treat-strip-pem gnus-article-hide-pem)
1123     (gnus-treat-highlight-headers gnus-article-highlight-headers)
1124     (gnus-treat-highlight-citation gnus-article-highlight-citation)
1125     (gnus-treat-highlight-signature gnus-article-highlight-signature)
1126     (gnus-treat-strip-trailing-blank-lines
1127      gnus-article-remove-trailing-blank-lines)
1128     (gnus-treat-strip-leading-blank-lines
1129      gnus-article-strip-leading-blank-lines)
1130     (gnus-treat-strip-multiple-blank-lines
1131      gnus-article-strip-multiple-blank-lines)
1132     (gnus-treat-overstrike gnus-article-treat-overstrike)
1133     (gnus-treat-buttonize-head gnus-article-add-buttons-to-head)
1134     (gnus-treat-display-smileys gnus-smiley-display)
1135     (gnus-treat-capitalize-sentences gnus-article-capitalize-sentences)
1136     (gnus-treat-display-picons gnus-article-display-picons)
1137     (gnus-treat-play-sounds gnus-earcon-display)))
1138
1139 (defvar gnus-article-mime-handle-alist nil)
1140 (defvar article-lapsed-timer nil)
1141 (defvar gnus-article-current-summary nil)
1142
1143 (defvar gnus-article-mode-syntax-table
1144   (let ((table (copy-syntax-table text-mode-syntax-table)))
1145     ;; This causes the citation match run O(2^n).
1146     ;; (modify-syntax-entry ?- "w" table)
1147     (modify-syntax-entry ?> ")" table)
1148     (modify-syntax-entry ?< "(" table)
1149     table)
1150   "Syntax table used in article mode buffers.
1151 Initialized from `text-mode-syntax-table.")
1152
1153 (defvar gnus-save-article-buffer nil)
1154
1155 (defvar gnus-article-mode-line-format-alist
1156   (nconc '((?w (gnus-article-wash-status) ?s)
1157            (?m (gnus-article-mime-part-status) ?s))
1158          gnus-summary-mode-line-format-alist))
1159
1160 (defvar gnus-number-of-articles-to-be-saved nil)
1161
1162 (defvar gnus-inhibit-hiding nil)
1163
1164 (defsubst gnus-article-hide-text (b e props)
1165   "Set text PROPS on the B to E region, extending `intangible' 1 past B."
1166   (gnus-add-text-properties-when 'article-type nil b e props)
1167   (when (memq 'intangible props)
1168     (put-text-property
1169      (max (1- b) (point-min))
1170      b 'intangible (cddr (memq 'intangible props)))))
1171
1172 (defsubst gnus-article-unhide-text (b e)
1173   "Remove hidden text properties from region between B and E."
1174   (remove-text-properties b e gnus-hidden-properties)
1175   (when (memq 'intangible gnus-hidden-properties)
1176     (put-text-property (max (1- b) (point-min))
1177                        b 'intangible nil)))
1178
1179 (defun gnus-article-hide-text-type (b e type)
1180   "Hide text of TYPE between B and E."
1181   (push type gnus-article-wash-types)
1182   (gnus-article-hide-text
1183    b e (cons 'article-type (cons type gnus-hidden-properties))))
1184
1185 (defun gnus-article-unhide-text-type (b e type)
1186   "Unhide text of TYPE between B and E."
1187   (setq gnus-article-wash-types
1188         (delq type gnus-article-wash-types))
1189   (remove-text-properties
1190    b e (cons 'article-type (cons type gnus-hidden-properties)))
1191   (when (memq 'intangible gnus-hidden-properties)
1192     (put-text-property (max (1- b) (point-min))
1193                        b 'intangible nil)))
1194
1195 (defun gnus-article-hide-text-of-type (type)
1196   "Hide text of TYPE in the current buffer."
1197   (save-excursion
1198     (let ((b (point-min))
1199           (e (point-max)))
1200       (while (setq b (text-property-any b e 'article-type type))
1201         (add-text-properties b (incf b) gnus-hidden-properties)))))
1202
1203 (defun gnus-article-delete-text-of-type (type)
1204   "Delete text of TYPE in the current buffer."
1205   (save-excursion
1206     (let ((b (point-min)))
1207       (while (setq b (text-property-any b (point-max) 'article-type type))
1208         (delete-region
1209          b (or (text-property-not-all b (point-max) 'article-type type)
1210                (point-max)))))))
1211
1212 (defun gnus-article-delete-invisible-text ()
1213   "Delete all invisible text in the current buffer."
1214   (save-excursion
1215     (let ((b (point-min)))
1216       (while (setq b (text-property-any b (point-max) 'invisible t))
1217         (delete-region
1218          b (or (text-property-not-all b (point-max) 'invisible t)
1219                (point-max)))))))
1220
1221 (defun gnus-article-text-type-exists-p (type)
1222   "Say whether any text of type TYPE exists in the buffer."
1223   (text-property-any (point-min) (point-max) 'article-type type))
1224
1225 (defsubst gnus-article-header-rank ()
1226   "Give the rank of the string HEADER as given by `gnus-sorted-header-list'."
1227   (let ((list gnus-sorted-header-list)
1228         (i 0))
1229     (while list
1230       (when (looking-at (car list))
1231         (setq list nil))
1232       (setq list (cdr list))
1233       (incf i))
1234     i))
1235
1236 (defun article-hide-headers (&optional arg delete)
1237   "Hide unwanted headers and possibly sort them as well."
1238   (interactive)
1239   ;; This function might be inhibited.
1240   (unless gnus-inhibit-hiding
1241     (save-excursion
1242       (save-restriction
1243         (let ((buffer-read-only nil)
1244               (case-fold-search t)
1245               (max (1+ (length gnus-sorted-header-list)))
1246               (ignored (when (not gnus-visible-headers)
1247                          (cond ((stringp gnus-ignored-headers)
1248                                 gnus-ignored-headers)
1249                                ((listp gnus-ignored-headers)
1250                                 (mapconcat 'identity gnus-ignored-headers
1251                                            "\\|")))))
1252               (visible
1253                (cond ((stringp gnus-visible-headers)
1254                       gnus-visible-headers)
1255                      ((and gnus-visible-headers
1256                            (listp gnus-visible-headers))
1257                       (mapconcat 'identity gnus-visible-headers "\\|"))))
1258               (inhibit-point-motion-hooks t)
1259               beg)
1260           ;; First we narrow to just the headers.
1261           (article-narrow-to-head)
1262           ;; Hide any "From " lines at the beginning of (mail) articles.
1263           (while (looking-at "From ")
1264             (forward-line 1))
1265           (unless (bobp)
1266             (delete-region (point-min) (point)))
1267           ;; Then treat the rest of the header lines.
1268           ;; Then we use the two regular expressions
1269           ;; `gnus-ignored-headers' and `gnus-visible-headers' to
1270           ;; select which header lines is to remain visible in the
1271           ;; article buffer.
1272           (while (re-search-forward "^[^ \t]*:" nil t)
1273             (beginning-of-line)
1274             ;; Mark the rank of the header.
1275             (put-text-property
1276              (point) (1+ (point)) 'message-rank
1277              (if (or (and visible (looking-at visible))
1278                      (and ignored
1279                           (not (looking-at ignored))))
1280                  (gnus-article-header-rank)
1281                (+ 2 max)))
1282             (forward-line 1))
1283           (message-sort-headers-1)
1284           (when (setq beg (text-property-any
1285                            (point-min) (point-max) 'message-rank (+ 2 max)))
1286             ;; We delete the unwanted headers.
1287             (push 'headers gnus-article-wash-types)
1288             (add-text-properties (point-min) (+ 5 (point-min))
1289                                  '(article-type headers dummy-invisible t))
1290             (delete-region beg (point-max))))))))
1291
1292 (defun article-hide-boring-headers (&optional arg)
1293   "Toggle hiding of headers that aren't very interesting.
1294 If given a negative prefix, always show; if given a positive prefix,
1295 always hide."
1296   (interactive (gnus-article-hidden-arg))
1297   (when (and (not (gnus-article-check-hidden-text 'boring-headers arg))
1298              (not gnus-show-all-headers))
1299     (save-excursion
1300       (save-restriction
1301         (let ((buffer-read-only nil)
1302               (list gnus-boring-article-headers)
1303               (inhibit-point-motion-hooks t)
1304               elem)
1305           (article-narrow-to-head)
1306           (while list
1307             (setq elem (pop list))
1308             (goto-char (point-min))
1309             (cond
1310              ;; Hide empty headers.
1311              ((eq elem 'empty)
1312               (while (re-search-forward "^[^: \t]+:[ \t]*\n[^ \t]" nil t)
1313                 (forward-line -1)
1314                 (gnus-article-hide-text-type
1315                  (progn (beginning-of-line) (point))
1316                  (progn
1317                    (end-of-line)
1318                    (if (re-search-forward "^[^ \t]" nil t)
1319                        (match-beginning 0)
1320                      (point-max)))
1321                  'boring-headers)))
1322              ;; Hide boring Newsgroups header.
1323              ((eq elem 'newsgroups)
1324               (when (gnus-string-equal
1325                      (gnus-fetch-field "newsgroups")
1326                      (gnus-group-real-name
1327                       (if (boundp 'gnus-newsgroup-name)
1328                           gnus-newsgroup-name
1329                         "")))
1330                 (gnus-article-hide-header "newsgroups")))
1331              ((eq elem 'to-address)
1332               (let ((to (message-fetch-field "to"))
1333                     (to-address
1334                      (gnus-parameter-to-address
1335                       (if (boundp 'gnus-newsgroup-name)
1336                           gnus-newsgroup-name ""))))
1337                 (when (and to to-address
1338                            (ignore-errors
1339                              (gnus-string-equal
1340                               ;; only one address in To
1341                               (nth 1 (mail-extract-address-components to))
1342                               to-address)))
1343                   (gnus-article-hide-header "to"))))
1344              ((eq elem 'followup-to)
1345               (when (gnus-string-equal
1346                      (message-fetch-field "followup-to")
1347                      (message-fetch-field "newsgroups"))
1348                 (gnus-article-hide-header "followup-to")))
1349              ((eq elem 'reply-to)
1350               (let ((from (message-fetch-field "from"))
1351                     (reply-to (message-fetch-field "reply-to")))
1352                 (when (and
1353                        from reply-to
1354                        (ignore-errors
1355                          (gnus-string-equal
1356                           (nth 1 (mail-extract-address-components from))
1357                           (nth 1 (mail-extract-address-components reply-to)))))
1358                   (gnus-article-hide-header "reply-to"))))
1359              ((eq elem 'date)
1360               (let ((date (message-fetch-field "date")))
1361                 (when (and date
1362                            (< (days-between (current-time-string) date)
1363                               4))
1364                   (gnus-article-hide-header "date"))))
1365              ((eq elem 'long-to)
1366               (let ((to (message-fetch-field "to"))
1367                     (cc (message-fetch-field "cc")))
1368                 (when (> (length to) 1024)
1369                   (gnus-article-hide-header "to"))
1370                 (when (> (length cc) 1024)
1371                   (gnus-article-hide-header "cc"))))
1372              ((eq elem 'many-to)
1373               (let ((to-count 0)
1374                     (cc-count 0))
1375                 (goto-char (point-min))
1376                 (while (re-search-forward "^to:" nil t)
1377                   (setq to-count (1+ to-count)))
1378                 (when (> to-count 1)
1379                   (while (> to-count 0)
1380                     (goto-char (point-min))
1381                     (save-restriction
1382                       (re-search-forward "^to:" nil nil to-count)
1383                       (forward-line -1)
1384                       (narrow-to-region (point) (point-max))
1385                       (gnus-article-hide-header "to"))
1386                     (setq to-count (1- to-count))))
1387                 (goto-char (point-min))
1388                 (while (re-search-forward "^cc:" nil t)
1389                   (setq cc-count (1+ cc-count)))
1390                 (when (> cc-count 1)
1391                   (while (> cc-count 0)
1392                     (goto-char (point-min))
1393                     (save-restriction
1394                       (re-search-forward "^cc:" nil nil cc-count)
1395                       (forward-line -1)
1396                       (narrow-to-region (point) (point-max))
1397                       (gnus-article-hide-header "cc"))
1398                     (setq cc-count (1- cc-count)))))))))))))
1399
1400 (defun gnus-article-hide-header (header)
1401   (save-excursion
1402     (goto-char (point-min))
1403     (when (re-search-forward (concat "^" header ":") nil t)
1404       (gnus-article-hide-text-type
1405        (progn (beginning-of-line) (point))
1406        (progn
1407          (end-of-line)
1408          (if (re-search-forward "^[^ \t]" nil t)
1409              (match-beginning 0)
1410            (point-max)))
1411        'boring-headers))))
1412
1413 (defvar gnus-article-normalized-header-length 40
1414   "Length of normalized headers.")
1415
1416 (defun article-normalize-headers ()
1417   "Make all header lines 40 characters long."
1418   (interactive)
1419   (let ((buffer-read-only nil)
1420         column)
1421     (save-excursion
1422       (save-restriction
1423         (article-narrow-to-head)
1424         (while (not (eobp))
1425           (cond
1426            ((< (setq column (- (gnus-point-at-eol) (point)))
1427                gnus-article-normalized-header-length)
1428             (end-of-line)
1429             (insert (make-string
1430                      (- gnus-article-normalized-header-length column)
1431                      ? )))
1432            ((> column gnus-article-normalized-header-length)
1433             (gnus-put-text-property
1434              (progn
1435                (forward-char gnus-article-normalized-header-length)
1436                (point))
1437              (gnus-point-at-eol)
1438              'invisible t))
1439            (t
1440             ;; Do nothing.
1441             ))
1442           (forward-line 1))))))
1443
1444 (defun article-treat-dumbquotes ()
1445   "Translate M****s*** sm*rtq**t*s into proper text.
1446 Note that this function guesses whether a character is a sm*rtq**t* or
1447 not, so it should only be used interactively.
1448
1449 Sm*rtq**t*s are M****s***'s unilateral extension to the character map
1450 in an attempt to provide more quoting characters.  If you see
1451 something like \\222 or \\264 where you're expecting some kind of
1452 apostrophe or quotation mark, then try this wash."
1453   (interactive)
1454   (article-translate-strings gnus-article-dumbquotes-map))
1455
1456 (defun article-translate-characters (from to)
1457   "Translate all characters in the body of the article according to FROM and TO.
1458 FROM is a string of characters to translate from; to is a string of
1459 characters to translate to."
1460   (save-excursion
1461     (when (article-goto-body)
1462       (let ((buffer-read-only nil)
1463             (x (make-string 225 ?x))
1464             (i -1))
1465         (while (< (incf i) (length x))
1466           (aset x i i))
1467         (setq i 0)
1468         (while (< i (length from))
1469           (aset x (aref from i) (aref to i))
1470           (incf i))
1471         (translate-region (point) (point-max) x)))))
1472
1473 (defun article-translate-strings (map)
1474   "Translate all string in the body of the article according to MAP.
1475 MAP is an alist where the elements are on the form (\"from\" \"to\")."
1476   (save-excursion
1477     (when (article-goto-body)
1478       (let ((buffer-read-only nil)
1479             elem)
1480         (while (setq elem (pop map))
1481           (save-excursion
1482             (while (search-forward (car elem) nil t)
1483               (replace-match (cadr elem)))))))))
1484
1485 (defun article-treat-overstrike ()
1486   "Translate overstrikes into bold text."
1487   (interactive)
1488   (save-excursion
1489     (when (article-goto-body)
1490       (let ((buffer-read-only nil))
1491         (while (search-forward "\b" nil t)
1492           (let ((next (char-after))
1493                 (previous (char-after (- (point) 2))))
1494             ;; We do the boldification/underlining by hiding the
1495             ;; overstrikes and putting the proper text property
1496             ;; on the letters.
1497             (cond
1498              ((eq next previous)
1499               (gnus-article-hide-text-type (- (point) 2) (point) 'overstrike)
1500               (put-text-property (point) (1+ (point)) 'face 'bold))
1501              ((eq next ?_)
1502               (gnus-article-hide-text-type
1503                (1- (point)) (1+ (point)) 'overstrike)
1504               (put-text-property
1505                (- (point) 2) (1- (point)) 'face 'underline))
1506              ((eq previous ?_)
1507               (gnus-article-hide-text-type (- (point) 2) (point) 'overstrike)
1508               (put-text-property
1509                (point) (1+ (point)) 'face 'underline)))))))))
1510
1511 (defun article-fill-long-lines ()
1512   "Fill lines that are wider than the window width."
1513   (interactive)
1514   (save-excursion
1515     (let ((buffer-read-only nil)
1516           (width (window-width (get-buffer-window (current-buffer)))))
1517       (save-restriction
1518         (article-goto-body)
1519         (let ((adaptive-fill-mode nil))
1520           (while (not (eobp))
1521             (end-of-line)
1522             (when (>= (current-column) (min fill-column width))
1523               (narrow-to-region (point) (gnus-point-at-bol))
1524               (fill-paragraph nil)
1525               (goto-char (point-max))
1526               (widen))
1527             (forward-line 1)))))))
1528
1529 (defun article-capitalize-sentences ()
1530   "Capitalize the first word in each sentence."
1531   (interactive)
1532   (save-excursion
1533     (let ((buffer-read-only nil)
1534           (paragraph-start "^[\n\^L]"))
1535       (article-goto-body)
1536       (while (not (eobp))
1537         (capitalize-word 1)
1538         (forward-sentence)))))
1539
1540 (defun article-remove-cr ()
1541   "Remove trailing CRs and then translate remaining CRs into LFs."
1542   (interactive)
1543   (save-excursion
1544     (let ((buffer-read-only nil))
1545       (goto-char (point-min))
1546       (while (re-search-forward "\r+$" nil t)
1547         (replace-match "" t t))
1548       (goto-char (point-min))
1549       (while (search-forward "\r" nil t)
1550         (replace-match "\n" t t)))))
1551
1552 (defun article-remove-trailing-blank-lines ()
1553   "Remove all trailing blank lines from the article."
1554   (interactive)
1555   (save-excursion
1556     (let ((buffer-read-only nil))
1557       (goto-char (point-max))
1558       (delete-region
1559        (point)
1560        (progn
1561          (while (and (not (bobp))
1562                      (looking-at "^[ \t]*$")
1563                      (not (gnus-annotation-in-region-p
1564                            (point) (gnus-point-at-eol))))
1565            (forward-line -1))
1566          (forward-line 1)
1567          (point))))))
1568
1569 (defun article-display-x-face (&optional force)
1570   "Look for an X-Face header and display it if present."
1571   (interactive (list 'force))
1572   (save-excursion
1573     ;; Delete the old process, if any.
1574     (when (process-status "article-x-face")
1575       (delete-process "article-x-face"))
1576     (let ((inhibit-point-motion-hooks t)
1577           x-faces
1578           (case-fold-search t)
1579           from last)
1580       (save-restriction
1581         (article-narrow-to-head)
1582         (when (and buffer-read-only ;; When type `W f'
1583                    (progn
1584                      (goto-char (point-min))
1585                      (not (re-search-forward "^X-Face:[\t ]*" nil t)))
1586                    (gnus-buffer-live-p gnus-original-article-buffer))
1587           (with-current-buffer gnus-original-article-buffer
1588             (save-restriction
1589               (article-narrow-to-head)
1590               (while (re-search-forward "^X-Face:" nil t)
1591                 (setq x-faces
1592                       (concat
1593                        (or x-faces "")
1594                        (buffer-substring
1595                         (match-beginning 0)
1596                         (1- (re-search-forward
1597                              "^\\($\\|[^ \t]\\)" nil t))))))))
1598           (if x-faces
1599               (let (point start bface eface buffer-read-only)
1600                 (goto-char (point-max))
1601                 (forward-line -1)
1602                 (setq bface (get-text-property (gnus-point-at-bol) 'face)
1603                       eface (get-text-property (1- (gnus-point-at-eol)) 'face))
1604                 (goto-char (point-max))
1605                 (setq point (point))
1606                 (insert x-faces)
1607                 (goto-char point)
1608                 (while (looking-at "\\([^:]+\\): *")
1609                   (put-text-property (match-beginning 1) (1+ (match-end 1))
1610                                      'face bface)
1611                   (setq start (match-end 0))
1612                   (forward-line 1)
1613                   (while (looking-at "[\t ]")
1614                     (forward-line 1))
1615                   (put-text-property start (point)
1616                                      'face eface)))))
1617         (goto-char (point-min))
1618         (setq from (message-fetch-field "from"))
1619         (goto-char (point-min))
1620         (while (and gnus-article-x-face-command
1621                     (not last)
1622                     (or force
1623                         ;; Check whether this face is censored.
1624                         (not gnus-article-x-face-too-ugly)
1625                         (and gnus-article-x-face-too-ugly from
1626                              (not (string-match gnus-article-x-face-too-ugly
1627                                                 from))))
1628                     ;; Has to be present.
1629                     (re-search-forward "^X-Face:[\t ]*" nil t))
1630           ;; This used to try to do multiple faces (`while' instead of
1631           ;; `when' above), but (a) sending multiple EOFs to xv doesn't
1632           ;; work (b) it can crash some versions of Emacs (c) are
1633           ;; multiple faces really something to encourage?
1634           (when (stringp gnus-article-x-face-command)
1635             (setq last t))
1636           ;; We now have the area of the buffer where the X-Face is stored.
1637           (save-excursion
1638             (let ((beg (point))
1639                   (end (1- (re-search-forward "^\\($\\|[^ \t]\\)" nil t))))
1640               ;; We display the face.
1641               (if (symbolp gnus-article-x-face-command)
1642                   ;; The command is a lisp function, so we call it.
1643                   (if (gnus-functionp gnus-article-x-face-command)
1644                       (funcall gnus-article-x-face-command beg end)
1645                     (error "%s is not a function" gnus-article-x-face-command))
1646                 ;; The command is a string, so we interpret the command
1647                 ;; as a, well, command, and fork it off.
1648                 (let ((process-connection-type nil))
1649                   (process-kill-without-query
1650                    (start-process
1651                     "article-x-face" nil shell-file-name shell-command-switch
1652                     gnus-article-x-face-command))
1653                   (process-send-region "article-x-face" beg end)
1654                   (process-send-eof "article-x-face"))))))))))
1655
1656 (defun article-decode-mime-words ()
1657   "Decode all MIME-encoded words in the article."
1658   (interactive)
1659   (save-excursion
1660     (set-buffer gnus-article-buffer)
1661     (let ((inhibit-point-motion-hooks t)
1662           buffer-read-only
1663           (mail-parse-charset gnus-newsgroup-charset)
1664           (mail-parse-ignored-charsets
1665            (save-excursion (set-buffer gnus-summary-buffer)
1666                            gnus-newsgroup-ignored-charsets)))
1667       (mail-decode-encoded-word-region (point-min) (point-max)))))
1668
1669 (defun article-decode-charset (&optional prompt)
1670   "Decode charset-encoded text in the article.
1671 If PROMPT (the prefix), prompt for a coding system to use."
1672   (interactive "P")
1673   (let ((inhibit-point-motion-hooks t) (case-fold-search t)
1674         buffer-read-only
1675         (mail-parse-charset gnus-newsgroup-charset)
1676         (mail-parse-ignored-charsets
1677          (save-excursion (condition-case nil
1678                              (set-buffer gnus-summary-buffer)
1679                            (error))
1680                          gnus-newsgroup-ignored-charsets))
1681         ct cte ctl charset format)
1682   (save-excursion
1683     (save-restriction
1684       (article-narrow-to-head)
1685       (setq ct (message-fetch-field "Content-Type" t)
1686             cte (message-fetch-field "Content-Transfer-Encoding" t)
1687             ctl (and ct (ignore-errors
1688                           (mail-header-parse-content-type ct)))
1689             charset (cond
1690                      (prompt
1691                       (mm-read-coding-system "Charset to decode: "))
1692                      (ctl
1693                       (mail-content-type-get ctl 'charset)))
1694             format (and ctl (mail-content-type-get ctl 'format)))
1695       (when cte
1696         (setq cte (mail-header-strip cte)))
1697       (if (and ctl (not (string-match "/" (car ctl))))
1698           (setq ctl nil))
1699       (goto-char (point-max)))
1700     (forward-line 1)
1701     (save-restriction
1702       (narrow-to-region (point) (point-max))
1703       (when (and (eq mail-parse-charset 'gnus-decoded)
1704                  (eq (mm-body-7-or-8) '8bit))
1705         ;; The text code could have been decoded.
1706         (setq charset mail-parse-charset))
1707       (when (and (or (not ctl)
1708                      (equal (car ctl) "text/plain"))
1709                  (not format)) ;; article with format will decode later.
1710         (mm-decode-body
1711          charset (and cte (intern (downcase
1712                                    (gnus-strip-whitespace cte))))
1713          (car ctl)))))))
1714
1715 (defun article-decode-encoded-words ()
1716   "Remove encoded-word encoding from headers."
1717   (let ((inhibit-point-motion-hooks t)
1718         (mail-parse-charset gnus-newsgroup-charset)
1719         (mail-parse-ignored-charsets
1720          (save-excursion (condition-case nil
1721                              (set-buffer gnus-summary-buffer)
1722                            (error))
1723                          gnus-newsgroup-ignored-charsets))
1724         buffer-read-only)
1725     (save-restriction
1726       (article-narrow-to-head)
1727       (funcall gnus-decode-header-function (point-min) (point-max)))))
1728
1729 (defun article-de-quoted-unreadable (&optional force)
1730   "Translate a quoted-printable-encoded article.
1731 If FORCE, decode the article whether it is marked as quoted-printable
1732 or not."
1733   (interactive (list 'force))
1734   (save-excursion
1735     (let ((buffer-read-only nil) type charset)
1736       (if (gnus-buffer-live-p gnus-original-article-buffer)
1737           (with-current-buffer gnus-original-article-buffer
1738             (setq type
1739                   (gnus-fetch-field "content-transfer-encoding"))
1740             (let* ((ct (gnus-fetch-field "content-type"))
1741                    (ctl (and ct
1742                              (ignore-errors
1743                                (mail-header-parse-content-type ct)))))
1744               (setq charset (and ctl
1745                                  (mail-content-type-get ctl 'charset)))
1746               (if (stringp charset)
1747                   (setq charset (intern (downcase charset)))))))
1748       (unless charset
1749         (setq charset gnus-newsgroup-charset))
1750       (when (or force
1751                 (and type (let ((case-fold-search t))
1752                             (string-match "quoted-printable" type))))
1753         (article-goto-body)
1754         (quoted-printable-decode-region
1755          (point) (point-max) (mm-charset-to-coding-system charset))))))
1756
1757 (defun article-de-base64-unreadable (&optional force)
1758   "Translate a base64 article.
1759 If FORCE, decode the article whether it is marked as base64 not."
1760   (interactive (list 'force))
1761   (save-excursion
1762     (let ((buffer-read-only nil) type charset)
1763       (if (gnus-buffer-live-p gnus-original-article-buffer)
1764           (with-current-buffer gnus-original-article-buffer
1765             (setq type
1766                   (gnus-fetch-field "content-transfer-encoding"))
1767             (let* ((ct (gnus-fetch-field "content-type"))
1768                    (ctl (and ct
1769                              (ignore-errors
1770                                (mail-header-parse-content-type ct)))))
1771               (setq charset (and ctl
1772                                  (mail-content-type-get ctl 'charset)))
1773               (if (stringp charset)
1774                   (setq charset (intern (downcase charset)))))))
1775       (unless charset
1776         (setq charset gnus-newsgroup-charset))
1777       (when (or force
1778                 (and type (let ((case-fold-search t))
1779                             (string-match "base64" type))))
1780         (article-goto-body)
1781         (save-restriction
1782           (narrow-to-region (point) (point-max))
1783           (base64-decode-region (point-min) (point-max))
1784           (mm-decode-coding-region
1785            (point-min) (point-max) (mm-charset-to-coding-system charset)))))))
1786
1787 (eval-when-compile
1788   (require 'rfc1843))
1789
1790 (defun article-decode-HZ ()
1791   "Translate a HZ-encoded article."
1792   (interactive)
1793   (require 'rfc1843)
1794   (save-excursion
1795     (let ((buffer-read-only nil))
1796       (rfc1843-decode-region (point-min) (point-max)))))
1797
1798 (defun article-wash-html ()
1799   "Format an html article."
1800   (interactive)
1801   (save-excursion
1802     (let ((buffer-read-only nil)
1803           charset)
1804       (if (gnus-buffer-live-p gnus-original-article-buffer)
1805           (with-current-buffer gnus-original-article-buffer
1806             (let* ((ct (gnus-fetch-field "content-type"))
1807                    (ctl (and ct
1808                              (ignore-errors
1809                                (mail-header-parse-content-type ct)))))
1810               (setq charset (and ctl
1811                                  (mail-content-type-get ctl 'charset)))
1812               (if (stringp charset)
1813                   (setq charset (intern (downcase charset)))))))
1814       (unless charset
1815         (setq charset gnus-newsgroup-charset))
1816       (article-goto-body)
1817       (save-window-excursion
1818         (save-restriction
1819           (narrow-to-region (point) (point-max))
1820           (mm-setup-w3)
1821           (let ((w3-strict-width (window-width))
1822                 (url-standalone-mode t))
1823             (condition-case var
1824                 (w3-region (point-min) (point-max))
1825               (error))))))))
1826
1827 (defun article-hide-list-identifiers ()
1828   "Remove list identifies from the Subject header.
1829 The `gnus-list-identifiers' variable specifies what to do."
1830   (interactive)
1831   (let ((inhibit-point-motion-hooks t)
1832         (regexp (if (consp gnus-list-identifiers)
1833                     (mapconcat 'identity gnus-list-identifiers " *\\|")
1834                   gnus-list-identifiers))
1835         buffer-read-only)
1836     (when regexp
1837       (save-excursion
1838         (save-restriction
1839           (article-narrow-to-head)
1840           (goto-char (point-min))
1841           (while (re-search-forward
1842                   (concat "^Subject: +\\(R[Ee]: +\\)*\\(" regexp " *\\)")
1843                   nil t)
1844             (delete-region (match-beginning 2) (match-end 0))
1845             (beginning-of-line))
1846           (when (re-search-forward
1847                  "^Subject: +\\(\\(R[Ee]: +\\)+\\)R[Ee]: +" nil t)
1848             (delete-region (match-beginning 1) (match-end 1))))))))
1849
1850 (defun article-hide-pgp ()
1851   "Remove any PGP headers and signatures in the current article."
1852   (interactive)
1853   (save-excursion
1854     (save-restriction
1855       (let ((inhibit-point-motion-hooks t)
1856             buffer-read-only beg end)
1857         (article-goto-body)
1858         ;; Hide the "header".
1859         (when (re-search-forward "^-----BEGIN PGP SIGNED MESSAGE-----\n" nil t)
1860           (push 'pgp gnus-article-wash-types)
1861           (delete-region (match-beginning 0) (match-end 0))
1862           ;; Remove armor headers (rfc2440 6.2)
1863           (delete-region (point) (or (re-search-forward "^[ \t]*\n" nil t)
1864                                      (point)))
1865           (setq beg (point))
1866           ;; Hide the actual signature.
1867           (and (search-forward "\n-----BEGIN PGP SIGNATURE-----\n" nil t)
1868                (setq end (1+ (match-beginning 0)))
1869                (delete-region
1870                 end
1871                 (if (search-forward "\n-----END PGP SIGNATURE-----\n" nil t)
1872                     (match-end 0)
1873                   ;; Perhaps we shouldn't hide to the end of the buffer
1874                   ;; if there is no end to the signature?
1875                   (point-max))))
1876           ;; Hide "- " PGP quotation markers.
1877           (when (and beg end)
1878             (narrow-to-region beg end)
1879             (goto-char (point-min))
1880             (while (re-search-forward "^- " nil t)
1881               (delete-region
1882                (match-beginning 0) (match-end 0)))
1883             (widen))
1884           (gnus-run-hooks 'gnus-article-hide-pgp-hook))))))
1885
1886 (defun article-hide-pem (&optional arg)
1887   "Toggle hiding of any PEM headers and signatures in the current article.
1888 If given a negative prefix, always show; if given a positive prefix,
1889 always hide."
1890   (interactive (gnus-article-hidden-arg))
1891   (unless (gnus-article-check-hidden-text 'pem arg)
1892     (save-excursion
1893       (let (buffer-read-only end)
1894         (goto-char (point-min))
1895         ;; Hide the horrendously ugly "header".
1896         (when (and (search-forward
1897                     "\n-----BEGIN PRIVACY-ENHANCED MESSAGE-----\n"
1898                     nil t)
1899                    (setq end (1+ (match-beginning 0))))
1900           (push 'pem gnus-article-wash-types)
1901           (gnus-article-hide-text-type
1902            end
1903            (if (search-forward "\n\n" nil t)
1904                (match-end 0)
1905              (point-max))
1906            'pem)
1907           ;; Hide the trailer as well
1908           (when (search-forward "\n-----END PRIVACY-ENHANCED MESSAGE-----\n"
1909                                 nil t)
1910             (gnus-article-hide-text-type
1911              (match-beginning 0) (match-end 0) 'pem)))))))
1912
1913 (defun article-strip-banner ()
1914   "Strip the banner specified by the `banner' group parameter."
1915   (interactive)
1916   (save-excursion
1917     (save-restriction
1918       (let ((inhibit-point-motion-hooks t)
1919             (banner (gnus-parameter-banner gnus-newsgroup-name))
1920             (gnus-signature-limit nil)
1921             buffer-read-only beg end)
1922         (when banner
1923           (article-goto-body)
1924           (cond
1925            ((eq banner 'signature)
1926             (when (gnus-article-narrow-to-signature)
1927               (widen)
1928               (forward-line -1)
1929               (delete-region (point) (point-max))))
1930            ((symbolp banner)
1931             (if (setq banner (cdr (assq banner gnus-article-banner-alist)))
1932                 (while (re-search-forward banner nil t)
1933                   (delete-region (match-beginning 0) (match-end 0)))))
1934            ((stringp banner)
1935             (while (re-search-forward banner nil t)
1936               (delete-region (match-beginning 0) (match-end 0))))))))))
1937
1938 (defun article-babel ()
1939   "Translate article using an online translation service."
1940   (interactive)
1941   (require 'babel)
1942   (save-excursion
1943     (set-buffer gnus-article-buffer)
1944     (when (article-goto-body)
1945       (let* ((buffer-read-only nil)
1946              (start (point))
1947              (end (point-max))
1948              (orig (buffer-substring start end))
1949              (trans (babel-as-string orig)))
1950         (save-restriction
1951           (narrow-to-region start end)
1952           (delete-region start end)
1953           (insert trans))))))
1954
1955 (defun article-hide-signature (&optional arg)
1956   "Hide the signature in the current article.
1957 If given a negative prefix, always show; if given a positive prefix,
1958 always hide."
1959   (interactive (gnus-article-hidden-arg))
1960   (unless (gnus-article-check-hidden-text 'signature arg)
1961     (save-excursion
1962       (save-restriction
1963         (let ((buffer-read-only nil))
1964           (when (gnus-article-narrow-to-signature)
1965             (gnus-article-hide-text-type
1966              (point-min) (point-max) 'signature)))))))
1967
1968 (defun article-strip-headers-in-body ()
1969   "Strip offensive headers from bodies."
1970   (interactive)
1971   (save-excursion
1972     (article-goto-body)
1973     (let ((case-fold-search t))
1974       (when (looking-at "x-no-archive:")
1975         (gnus-delete-line)))))
1976
1977 (defun article-strip-leading-blank-lines ()
1978   "Remove all blank lines from the beginning of the article."
1979   (interactive)
1980   (save-excursion
1981     (let ((inhibit-point-motion-hooks t)
1982           buffer-read-only)
1983       (when (article-goto-body)
1984         (while (and (not (eobp))
1985                     (looking-at "[ \t]*$"))
1986           (gnus-delete-line))))))
1987
1988 (defun article-narrow-to-head ()
1989   "Narrow the buffer to the head of the message.
1990 Point is left at the beginning of the narrowed-to region."
1991   (narrow-to-region
1992    (goto-char (point-min))
1993    (if (search-forward "\n\n" nil 1)
1994        (1- (point))
1995      (point-max)))
1996   (goto-char (point-min)))
1997
1998 (defun article-goto-body ()
1999   "Place point at the start of the body."
2000   (goto-char (point-min))
2001   (cond
2002    ;; This variable is only bound when dealing with separate
2003    ;; MIME body parts.
2004    (article-goto-body-goes-to-point-min-p
2005     t)
2006    ((search-forward "\n\n" nil t)
2007     t)
2008    (t
2009     (goto-char (point-max))
2010     nil)))
2011
2012 (defun article-strip-multiple-blank-lines ()
2013   "Replace consecutive blank lines with one empty line."
2014   (interactive)
2015   (save-excursion
2016     (let ((inhibit-point-motion-hooks t)
2017           buffer-read-only)
2018       ;; First make all blank lines empty.
2019       (article-goto-body)
2020       (while (re-search-forward "^[ \t]+$" nil t)
2021         (unless (gnus-annotation-in-region-p
2022                  (match-beginning 0) (match-end 0))
2023           (replace-match "" nil t)))
2024       ;; Then replace multiple empty lines with a single empty line.
2025       (article-goto-body)
2026       (while (re-search-forward "\n\n\n+" nil t)
2027         (unless (gnus-annotation-in-region-p
2028                  (match-beginning 0) (match-end 0))
2029           (replace-match "\n\n" t t))))))
2030
2031 (defun article-strip-leading-space ()
2032   "Remove all white space from the beginning of the lines in the article."
2033   (interactive)
2034   (save-excursion
2035     (let ((inhibit-point-motion-hooks t)
2036           buffer-read-only)
2037       (article-goto-body)
2038       (while (re-search-forward "^[ \t]+" nil t)
2039         (replace-match "" t t)))))
2040
2041 (defun article-strip-trailing-space ()
2042   "Remove all white space from the end of the lines in the article."
2043   (interactive)
2044   (save-excursion
2045     (let ((inhibit-point-motion-hooks t)
2046           buffer-read-only)
2047       (article-goto-body)
2048       (while (re-search-forward "[ \t]+$" nil t)
2049         (replace-match "" t t)))))
2050
2051 (defun article-strip-blank-lines ()
2052   "Strip leading, trailing and multiple blank lines."
2053   (interactive)
2054   (article-strip-leading-blank-lines)
2055   (article-remove-trailing-blank-lines)
2056   (article-strip-multiple-blank-lines))
2057
2058 (defun article-strip-all-blank-lines ()
2059   "Strip all blank lines."
2060   (interactive)
2061   (save-excursion
2062     (let ((inhibit-point-motion-hooks t)
2063           buffer-read-only)
2064       (article-goto-body)
2065       (while (re-search-forward "^[ \t]*\n" nil t)
2066         (replace-match "" t t)))))
2067
2068 (defun gnus-article-narrow-to-signature ()
2069   "Narrow to the signature; return t if a signature is found, else nil."
2070   (let ((inhibit-point-motion-hooks t))
2071     (when (gnus-article-search-signature)
2072       (forward-line 1)
2073       ;; Check whether we have some limits to what we consider
2074       ;; to be a signature.
2075       (let ((limits (if (listp gnus-signature-limit) gnus-signature-limit
2076                       (list gnus-signature-limit)))
2077             limit limited)
2078         (while (setq limit (pop limits))
2079           (if (or (and (integerp limit)
2080                        (< (- (point-max) (point)) limit))
2081                   (and (floatp limit)
2082                        (< (count-lines (point) (point-max)) limit))
2083                   (and (gnus-functionp limit)
2084                        (funcall limit))
2085                   (and (stringp limit)
2086                        (not (re-search-forward limit nil t))))
2087               ()                        ; This limit did not succeed.
2088             (setq limited t
2089                   limits nil)))
2090         (unless limited
2091           (narrow-to-region (point) (point-max))
2092           t)))))
2093
2094 (defun gnus-article-search-signature ()
2095   "Search the current buffer for the signature separator.
2096 Put point at the beginning of the signature separator."
2097   (let ((cur (point)))
2098     (goto-char (point-max))
2099     (if (if (stringp gnus-signature-separator)
2100             (re-search-backward gnus-signature-separator nil t)
2101           (let ((seps gnus-signature-separator))
2102             (while (and seps
2103                         (not (re-search-backward (car seps) nil t)))
2104               (pop seps))
2105             seps))
2106         t
2107       (goto-char cur)
2108       nil)))
2109
2110 (defun gnus-article-hidden-arg ()
2111   "Return the current prefix arg as a number, or 0 if no prefix."
2112   (list (if current-prefix-arg
2113             (prefix-numeric-value current-prefix-arg)
2114           0)))
2115
2116 (defun gnus-article-check-hidden-text (type arg)
2117   "Return nil if hiding is necessary.
2118 Arg can be nil or a number.  Nil and positive means hide, negative
2119 means show, 0 means toggle."
2120   (save-excursion
2121     (save-restriction
2122       (let ((hide (gnus-article-hidden-text-p type)))
2123         (cond
2124          ((or (null arg)
2125               (> arg 0))
2126           nil)
2127          ((< arg 0)
2128           (gnus-article-show-hidden-text type)
2129           t)
2130          (t
2131           (if (eq hide 'hidden)
2132               (progn
2133                 (gnus-article-show-hidden-text type)
2134                 t)
2135             nil)))))))
2136
2137 (defun gnus-article-hidden-text-p (type)
2138   "Say whether the current buffer contains hidden text of type TYPE."
2139   (let ((pos (text-property-any (point-min) (point-max) 'article-type type)))
2140     (while (and pos
2141                 (not (get-text-property pos 'invisible))
2142                 (not (get-text-property pos 'dummy-invisible)))
2143       (setq pos
2144             (text-property-any (1+ pos) (point-max) 'article-type type)))
2145     (if pos
2146         'hidden
2147       nil)))
2148
2149 (defun gnus-article-show-hidden-text (type &optional dummy)
2150   "Show all hidden text of type TYPE.
2151 Originally it is hide instead of DUMMY."
2152   (let ((buffer-read-only nil)
2153         (inhibit-point-motion-hooks t))
2154     (gnus-remove-text-properties-when
2155      'article-type type
2156      (point-min) (point-max)
2157      (cons 'article-type (cons type
2158                                gnus-hidden-properties)))))
2159
2160 (defconst article-time-units
2161   `((year . ,(* 365.25 24 60 60))
2162     (week . ,(* 7 24 60 60))
2163     (day . ,(* 24 60 60))
2164     (hour . ,(* 60 60))
2165     (minute . 60)
2166     (second . 1))
2167   "Mapping from time units to seconds.")
2168
2169 (defun article-date-ut (&optional type highlight header)
2170   "Convert DATE date to universal time in the current article.
2171 If TYPE is `local', convert to local time; if it is `lapsed', output
2172 how much time has lapsed since DATE.  For `lapsed', the value of
2173 `gnus-article-date-lapsed-new-header' says whether the \"X-Sent:\" header
2174 should replace the \"Date:\" one, or should be added below it."
2175   (interactive (list 'ut t))
2176   (let* ((header (or header
2177                      (message-fetch-field "date")
2178                      ""))
2179          (tdate-regexp "^Date:[ \t]\\|^X-Sent:[ \t]")
2180          (date-regexp
2181           (cond
2182            ((not gnus-article-date-lapsed-new-header)
2183             tdate-regexp)
2184            ((eq type 'lapsed)
2185             "^X-Sent:[ \t]")
2186            (t
2187             "^Date:[ \t]")))
2188          (date (if (vectorp header) (mail-header-date header)
2189                  header))
2190          (inhibit-point-motion-hooks t)
2191          pos
2192          bface eface)
2193     (save-excursion
2194       (save-restriction
2195         (article-narrow-to-head)
2196         (when (re-search-forward tdate-regexp nil t)
2197           (setq bface (get-text-property (gnus-point-at-bol) 'face)
2198                 date (or (get-text-property (gnus-point-at-bol)
2199                                             'original-date)
2200                          date)
2201                 eface (get-text-property (1- (gnus-point-at-eol)) 'face))
2202           (forward-line 1))
2203         (when (and date (not (string= date "")))
2204           (goto-char (point-min))
2205           (let ((buffer-read-only nil))
2206             ;; Delete any old Date headers.
2207             (while (re-search-forward date-regexp nil t)
2208               (if pos
2209                   (delete-region (progn (beginning-of-line) (point))
2210                                  (progn (forward-line 1) (point)))
2211                 (delete-region (progn (beginning-of-line) (point))
2212                                (progn (end-of-line) (point)))
2213                 (setq pos (point))))
2214             (when (and (not pos) (re-search-forward tdate-regexp nil t))
2215               (forward-line 1))
2216             (if pos (goto-char pos))
2217             (insert (article-make-date-line date (or type 'ut)))
2218             (when (not pos)
2219               (insert "\n")
2220               (forward-line -1))
2221             ;; Do highlighting.
2222             (beginning-of-line)
2223             (when (looking-at "\\([^:]+\\): *\\(.*\\)$")
2224               (put-text-property (match-beginning 1) (1+ (match-end 1))
2225                                  'original-date date)
2226               (put-text-property (match-beginning 1) (1+ (match-end 1))
2227                                  'face bface)
2228               (put-text-property (match-beginning 2) (match-end 2)
2229                                  'face eface))))))))
2230
2231 (defun article-make-date-line (date type)
2232   "Return a DATE line of TYPE."
2233   (unless (memq type '(local ut original user iso8601 lapsed english))
2234     (error "Unknown conversion type: %s" type))
2235   (condition-case ()
2236       (let ((time (date-to-time date)))
2237         (cond
2238          ;; Convert to the local timezone.
2239          ((eq type 'local)
2240           (let ((tz (car (current-time-zone time))))
2241             (format "Date: %s %s%02d%02d" (current-time-string time)
2242                     (if (> tz 0) "+" "-") (/ (abs tz) 3600)
2243                     (/ (% (abs tz) 3600) 60))))
2244          ;; Convert to Universal Time.
2245          ((eq type 'ut)
2246           (concat "Date: "
2247                   (current-time-string
2248                    (let* ((e (parse-time-string date))
2249                           (tm (apply 'encode-time e))
2250                           (ms (car tm))
2251                           (ls (- (cadr tm) (car (current-time-zone time)))))
2252                      (cond ((< ls 0) (list (1- ms) (+ ls 65536)))
2253                            ((> ls 65535) (list (1+ ms) (- ls 65536)))
2254                            (t (list ms ls)))))
2255                   " UT"))
2256          ;; Get the original date from the article.
2257          ((eq type 'original)
2258           (concat "Date: " (if (string-match "\n+$" date)
2259                                (substring date 0 (match-beginning 0))
2260                              date)))
2261          ;; Let the user define the format.
2262          ((eq type 'user)
2263           (if (gnus-functionp gnus-article-time-format)
2264               (funcall gnus-article-time-format time)
2265             (concat
2266              "Date: "
2267              (format-time-string gnus-article-time-format time))))
2268          ;; ISO 8601.
2269          ((eq type 'iso8601)
2270           (let ((tz (car (current-time-zone time))))
2271             (concat
2272              "Date: "
2273              (format-time-string "%Y%m%dT%H%M%S" time)
2274              (format "%s%02d%02d"
2275                      (if (> tz 0) "+" "-") (/ (abs tz) 3600)
2276                      (/ (% (abs tz) 3600) 60)))))
2277          ;; Do an X-Sent lapsed format.
2278          ((eq type 'lapsed)
2279           ;; If the date is seriously mangled, the timezone functions are
2280           ;; liable to bug out, so we ignore all errors.
2281           (let* ((now (current-time))
2282                  (real-time (subtract-time now time))
2283                  (real-sec (and real-time
2284                                 (+ (* (float (car real-time)) 65536)
2285                                    (cadr real-time))))
2286                  (sec (and real-time (abs real-sec)))
2287                  num prev)
2288             (cond
2289              ((null real-time)
2290               "X-Sent: Unknown")
2291              ((zerop sec)
2292               "X-Sent: Now")
2293              (t
2294               (concat
2295                "X-Sent: "
2296                ;; This is a bit convoluted, but basically we go
2297                ;; through the time units for years, weeks, etc,
2298                ;; and divide things to see whether that results
2299                ;; in positive answers.
2300                (mapconcat
2301                 (lambda (unit)
2302                   (if (zerop (setq num (ffloor (/ sec (cdr unit)))))
2303                       ;; The (remaining) seconds are too few to
2304                       ;; be divided into this time unit.
2305                       ""
2306                     ;; It's big enough, so we output it.
2307                     (setq sec (- sec (* num (cdr unit))))
2308                     (prog1
2309                         (concat (if prev ", " "") (int-to-string
2310                                                    (floor num))
2311                                 " " (symbol-name (car unit))
2312                                 (if (> num 1) "s" ""))
2313                       (setq prev t))))
2314                 article-time-units "")
2315                ;; If dates are odd, then it might appear like the
2316                ;; article was sent in the future.
2317                (if (> real-sec 0)
2318                    " ago"
2319                  " in the future"))))))
2320          ;; Display the date in proper English
2321          ((eq type 'english)
2322           (let ((dtime (decode-time time)))
2323             (concat
2324              "Date: the "
2325              (number-to-string (nth 3 dtime))
2326              (let ((digit (% (nth 3 dtime) 10)))
2327                (cond
2328                 ((memq (nth 3 dtime) '(11 12 13)) "th")
2329                 ((= digit 1) "st")
2330                 ((= digit 2) "nd")
2331                 ((= digit 3) "rd")
2332                 (t "th")))
2333              " of "
2334              (nth (1- (nth 4 dtime)) gnus-english-month-names)
2335              " "
2336              (number-to-string (nth 5 dtime))
2337              " at "
2338              (format "%02d" (nth 2 dtime))
2339              ":"
2340              (format "%02d" (nth 1 dtime)))))))
2341         (error
2342          (format "Date: %s (from Oort)" date))))
2343
2344 (defun article-date-local (&optional highlight)
2345   "Convert the current article date to the local timezone."
2346   (interactive (list t))
2347   (article-date-ut 'local highlight))
2348
2349 (defun article-date-english (&optional highlight)
2350   "Convert the current article date to something that is proper English."
2351   (interactive (list t))
2352   (article-date-ut 'english highlight))
2353
2354 (defun article-date-original (&optional highlight)
2355   "Convert the current article date to what it was originally.
2356 This is only useful if you have used some other date conversion
2357 function and want to see what the date was before converting."
2358   (interactive (list t))
2359   (article-date-ut 'original highlight))
2360
2361 (defun article-date-lapsed (&optional highlight)
2362   "Convert the current article date to time lapsed since it was sent."
2363   (interactive (list t))
2364   (article-date-ut 'lapsed highlight))
2365
2366 (defun article-update-date-lapsed ()
2367   "Function to be run from a timer to update the lapsed time line."
2368   (let (deactivate-mark)
2369     (save-excursion
2370       (ignore-errors
2371         (walk-windows
2372          (lambda (w)
2373            (set-buffer (window-buffer w))
2374            (when (eq major-mode 'gnus-article-mode)
2375              (goto-char (point-min))
2376              (when (re-search-forward "^X-Sent:" nil t)
2377                (article-date-lapsed t))))
2378          nil 'visible)))))
2379
2380 (defun gnus-start-date-timer (&optional n)
2381   "Start a timer to update the X-Sent header in the article buffers.
2382 The numerical prefix says how frequently (in seconds) the function
2383 is to run."
2384   (interactive "p")
2385   (unless n
2386     (setq n 1))
2387   (gnus-stop-date-timer)
2388   (setq article-lapsed-timer
2389         (nnheader-run-at-time 1 n 'article-update-date-lapsed)))
2390
2391 (defun gnus-stop-date-timer ()
2392   "Stop the X-Sent timer."
2393   (interactive)
2394   (when article-lapsed-timer
2395     (nnheader-cancel-timer article-lapsed-timer)
2396     (setq article-lapsed-timer nil)))
2397
2398 (defun article-date-user (&optional highlight)
2399   "Convert the current article date to the user-defined format.
2400 This format is defined by the `gnus-article-time-format' variable."
2401   (interactive (list t))
2402   (article-date-ut 'user highlight))
2403
2404 (defun article-date-iso8601 (&optional highlight)
2405   "Convert the current article date to ISO8601."
2406   (interactive (list t))
2407   (article-date-ut 'iso8601 highlight))
2408
2409 (defun article-show-all ()
2410   "Show all hidden text in the article buffer."
2411   (interactive)
2412   (save-excursion
2413     (let ((buffer-read-only nil))
2414       (gnus-article-unhide-text (point-min) (point-max)))))
2415
2416 (defun article-remove-leading-whitespace ()
2417   "Remove excessive whitespace from all headers."
2418   (interactive)
2419   (save-excursion
2420     (save-restriction
2421       (let ((buffer-read-only nil))
2422         (article-narrow-to-head)
2423         (goto-char (point-min))
2424         (while (re-search-forward "^[^ :]+: \\([ \t]+\\)" nil t)
2425           (delete-region (match-beginning 1) (match-end 1)))))))
2426
2427 (defun article-emphasize (&optional arg)
2428   "Emphasize text according to `gnus-emphasis-alist'."
2429   (interactive (gnus-article-hidden-arg))
2430   (unless (gnus-article-check-hidden-text 'emphasis arg)
2431     (save-excursion
2432       (let ((alist (or
2433                     (condition-case nil
2434                         (with-current-buffer gnus-summary-buffer
2435                           gnus-article-emphasis-alist)
2436                       (error))
2437                     gnus-emphasis-alist))
2438             (buffer-read-only nil)
2439             (props (append '(article-type emphasis)
2440                            gnus-hidden-properties))
2441             regexp elem beg invisible visible face)
2442         (article-goto-body)
2443         (setq beg (point))
2444         (while (setq elem (pop alist))
2445           (goto-char beg)
2446           (setq regexp (car elem)
2447                 invisible (nth 1 elem)
2448                 visible (nth 2 elem)
2449                 face (nth 3 elem))
2450           (while (re-search-forward regexp nil t)
2451             (when (and (match-beginning visible) (match-beginning invisible))
2452               (push 'emphasis gnus-article-wash-types)
2453               (gnus-article-hide-text
2454                (match-beginning invisible) (match-end invisible) props)
2455               (gnus-article-unhide-text-type
2456                (match-beginning visible) (match-end visible) 'emphasis)
2457               (gnus-put-text-property-excluding-newlines
2458                (match-beginning visible) (match-end visible) 'face face)
2459               (goto-char (match-end invisible)))))))))
2460
2461 (defun gnus-article-setup-highlight-words (&optional highlight-words)
2462   "Setup newsgroup emphasis alist."
2463   (unless gnus-article-emphasis-alist
2464     (let ((name (and gnus-newsgroup-name
2465                      (gnus-group-real-name gnus-newsgroup-name))))
2466       (make-local-variable 'gnus-article-emphasis-alist)
2467       (setq gnus-article-emphasis-alist
2468             (nconc
2469              (let ((alist gnus-group-highlight-words-alist) elem highlight)
2470                (while (setq elem (pop alist))
2471                  (when (and name (string-match (car elem) name))
2472                    (setq alist nil
2473                          highlight (copy-sequence (cdr elem)))))
2474                highlight)
2475              (copy-sequence highlight-words)
2476              (if gnus-newsgroup-name
2477                  (copy-sequence (gnus-group-find-parameter
2478                                  gnus-newsgroup-name 'highlight-words t)))
2479              gnus-emphasis-alist)))))
2480
2481 (eval-when-compile
2482   (defvar gnus-summary-article-menu)
2483   (defvar gnus-summary-post-menu))
2484
2485 ;;; Saving functions.
2486
2487 (defun gnus-article-save (save-buffer file &optional num)
2488   "Save the currently selected article."
2489   (unless gnus-save-all-headers
2490     ;; Remove headers according to `gnus-saved-headers'.
2491     (let ((gnus-visible-headers
2492            (or gnus-saved-headers gnus-visible-headers))
2493           (gnus-article-buffer save-buffer))
2494       (save-excursion
2495         (set-buffer save-buffer)
2496         (article-hide-headers 1 t))))
2497   (save-window-excursion
2498     (if (not gnus-default-article-saver)
2499         (error "No default saver is defined")
2500       ;; !!! Magic!  The saving functions all save
2501       ;; `gnus-save-article-buffer' (or so they think), but we
2502       ;; bind that variable to our save-buffer.
2503       (set-buffer gnus-article-buffer)
2504       (let* ((gnus-save-article-buffer save-buffer)
2505              (filename
2506               (cond
2507                ((not gnus-prompt-before-saving) 'default)
2508                ((eq gnus-prompt-before-saving 'always) nil)
2509                (t file)))
2510              (gnus-number-of-articles-to-be-saved
2511               (when (eq gnus-prompt-before-saving t)
2512                 num)))                  ; Magic
2513         (set-buffer gnus-article-current-summary)
2514         (funcall gnus-default-article-saver filename)))))
2515
2516 (defun gnus-read-save-file-name (prompt &optional filename
2517                                         function group headers variable)
2518   (let ((default-name
2519           (funcall function group headers (symbol-value variable)))
2520         result)
2521     (setq result
2522           (expand-file-name
2523            (cond
2524             ((eq filename 'default)
2525              default-name)
2526             ((eq filename t)
2527              default-name)
2528             (filename filename)
2529             (t
2530              (let* ((split-name (gnus-get-split-value gnus-split-methods))
2531                     (prompt
2532                      (format prompt
2533                              (if (and gnus-number-of-articles-to-be-saved
2534                                       (> gnus-number-of-articles-to-be-saved 1))
2535                                  (format "these %d articles"
2536                                          gnus-number-of-articles-to-be-saved)
2537                                "this article")))
2538                     (file
2539                      ;; Let the split methods have their say.
2540                      (cond
2541                       ;; No split name was found.
2542                       ((null split-name)
2543                        (read-file-name
2544                         (concat prompt " (default "
2545                                 (file-name-nondirectory default-name) ") ")
2546                         (file-name-directory default-name)
2547                         default-name))
2548                       ;; A single group name is returned.
2549                       ((stringp split-name)
2550                        (setq default-name
2551                              (funcall function split-name headers
2552                                       (symbol-value variable)))
2553                        (read-file-name
2554                         (concat prompt " (default "
2555                                 (file-name-nondirectory default-name) ") ")
2556                         (file-name-directory default-name)
2557                         default-name))
2558                       ;; A single split name was found
2559                       ((= 1 (length split-name))
2560                        (let* ((name (expand-file-name
2561                                      (car split-name)
2562                                      gnus-article-save-directory))
2563                               (dir (cond ((file-directory-p name)
2564                                           (file-name-as-directory name))
2565                                          ((file-exists-p name) name)
2566                                          (t gnus-article-save-directory))))
2567                          (read-file-name
2568                           (concat prompt " (default " name ") ")
2569                           dir name)))
2570                       ;; A list of splits was found.
2571                       (t
2572                        (setq split-name (nreverse split-name))
2573                        (let (result)
2574                          (let ((file-name-history
2575                                 (nconc split-name file-name-history)))
2576                            (setq result
2577                                  (expand-file-name
2578                                   (read-file-name
2579                                    (concat prompt " (`M-p' for defaults) ")
2580                                    gnus-article-save-directory
2581                                    (car split-name))
2582                                   gnus-article-save-directory)))
2583                          (car (push result file-name-history)))))))
2584                ;; Create the directory.
2585                (gnus-make-directory (file-name-directory file))
2586       ;; If we have read a directory, we append the default file name.
2587                (when (file-directory-p file)
2588                  (setq file (expand-file-name (file-name-nondirectory
2589                                                default-name)
2590                                               (file-name-as-directory file))))
2591                ;; Possibly translate some characters.
2592                (nnheader-translate-file-chars file))))))
2593     (gnus-make-directory (file-name-directory result))
2594     (set variable result)))
2595
2596 (defun gnus-article-archive-name (group)
2597   "Return the first instance of an \"Archive-name\" in the current buffer."
2598   (let ((case-fold-search t))
2599     (when (re-search-forward "archive-name: *\\([^ \n\t]+\\)[ \t]*$" nil t)
2600       (nnheader-concat gnus-article-save-directory
2601                        (match-string 1)))))
2602
2603 (defun gnus-article-nndoc-name (group)
2604   "If GROUP is an nndoc group, return the name of the parent group."
2605   (when (eq (car (gnus-find-method-for-group group)) 'nndoc)
2606     (gnus-group-get-parameter group 'save-article-group)))
2607
2608 (defun gnus-summary-save-in-rmail (&optional filename)
2609   "Append this article to Rmail file.
2610 Optional argument FILENAME specifies file name.
2611 Directory to save to is default to `gnus-article-save-directory'."
2612   (setq filename (gnus-read-save-file-name
2613                   "Save %s in rmail file:" filename
2614                   gnus-rmail-save-name gnus-newsgroup-name
2615                   gnus-current-headers 'gnus-newsgroup-last-rmail))
2616   (gnus-eval-in-buffer-window gnus-save-article-buffer
2617     (save-excursion
2618       (save-restriction
2619         (widen)
2620         (gnus-output-to-rmail filename))))
2621   filename)
2622
2623 (defun gnus-summary-save-in-mail (&optional filename)
2624   "Append this article to Unix mail file.
2625 Optional argument FILENAME specifies file name.
2626 Directory to save to is default to `gnus-article-save-directory'."
2627   (setq filename (gnus-read-save-file-name
2628                   "Save %s in Unix mail file:" filename
2629                   gnus-mail-save-name gnus-newsgroup-name
2630                   gnus-current-headers 'gnus-newsgroup-last-mail))
2631   (gnus-eval-in-buffer-window gnus-save-article-buffer
2632     (save-excursion
2633       (save-restriction
2634         (widen)
2635         (if (and (file-readable-p filename)
2636                  (mail-file-babyl-p filename))
2637             (rmail-output-to-rmail-file filename t)
2638           (gnus-output-to-mail filename)))))
2639   filename)
2640
2641 (defun gnus-summary-save-in-file (&optional filename overwrite)
2642   "Append this article to file.
2643 Optional argument FILENAME specifies file name.
2644 Directory to save to is default to `gnus-article-save-directory'."
2645   (setq filename (gnus-read-save-file-name
2646                   "Save %s in file:" filename
2647                   gnus-file-save-name gnus-newsgroup-name
2648                   gnus-current-headers 'gnus-newsgroup-last-file))
2649   (gnus-eval-in-buffer-window gnus-save-article-buffer
2650     (save-excursion
2651       (save-restriction
2652         (widen)
2653         (when (and overwrite
2654                    (file-exists-p filename))
2655           (delete-file filename))
2656         (gnus-output-to-file filename))))
2657   filename)
2658
2659 (defun gnus-summary-write-to-file (&optional filename)
2660   "Write this article to a file.
2661 Optional argument FILENAME specifies file name.
2662 The directory to save in defaults to `gnus-article-save-directory'."
2663   (gnus-summary-save-in-file nil t))
2664
2665 (defun gnus-summary-save-body-in-file (&optional filename)
2666   "Append this article body to a file.
2667 Optional argument FILENAME specifies file name.
2668 The directory to save in defaults to `gnus-article-save-directory'."
2669   (setq filename (gnus-read-save-file-name
2670                   "Save %s body in file:" filename
2671                   gnus-file-save-name gnus-newsgroup-name
2672                   gnus-current-headers 'gnus-newsgroup-last-file))
2673   (gnus-eval-in-buffer-window gnus-save-article-buffer
2674     (save-excursion
2675       (save-restriction
2676         (widen)
2677         (when (article-goto-body)
2678           (narrow-to-region (point) (point-max)))
2679         (gnus-output-to-file filename))))
2680   filename)
2681
2682 (defun gnus-summary-save-in-pipe (&optional command)
2683   "Pipe this article to subprocess."
2684   (setq command
2685         (cond ((and (eq command 'default)
2686                     gnus-last-shell-command)
2687                gnus-last-shell-command)
2688               ((stringp command)
2689                command)
2690               (t (read-string
2691                   (format
2692                    "Shell command on %s: "
2693                    (if (and gnus-number-of-articles-to-be-saved
2694                             (> gnus-number-of-articles-to-be-saved 1))
2695                        (format "these %d articles"
2696                                gnus-number-of-articles-to-be-saved)
2697                      "this article"))
2698                   gnus-last-shell-command))))
2699   (when (string-equal command "")
2700     (if gnus-last-shell-command
2701         (setq command gnus-last-shell-command)
2702       (error "A command is required.")))
2703   (gnus-eval-in-buffer-window gnus-article-buffer
2704     (save-restriction
2705       (widen)
2706       (shell-command-on-region (point-min) (point-max) command nil)))
2707   (setq gnus-last-shell-command command))
2708
2709 ;;; Article file names when saving.
2710
2711 (defun gnus-capitalize-newsgroup (newsgroup)
2712   "Capitalize NEWSGROUP name."
2713   (when (not (zerop (length newsgroup)))
2714     (concat (char-to-string (upcase (aref newsgroup 0)))
2715             (substring newsgroup 1))))
2716
2717 (defun gnus-Numeric-save-name (newsgroup headers &optional last-file)
2718   "Generate file name from NEWSGROUP, HEADERS, and optional LAST-FILE.
2719 If variable `gnus-use-long-file-name' is non-nil, it is ~/News/News.group/num.
2720 Otherwise, it is like ~/News/news/group/num."
2721   (let ((default
2722           (expand-file-name
2723            (concat (if (gnus-use-long-file-name 'not-save)
2724                        (gnus-capitalize-newsgroup newsgroup)
2725                      (gnus-newsgroup-directory-form newsgroup))
2726                    "/" (int-to-string (mail-header-number headers)))
2727            gnus-article-save-directory)))
2728     (if (and last-file
2729              (string-equal (file-name-directory default)
2730                            (file-name-directory last-file))
2731              (string-match "^[0-9]+$" (file-name-nondirectory last-file)))
2732         default
2733       (or last-file default))))
2734
2735 (defun gnus-numeric-save-name (newsgroup headers &optional last-file)
2736   "Generate file name from NEWSGROUP, HEADERS, and optional LAST-FILE.
2737 If variable `gnus-use-long-file-name' is non-nil, it is
2738 ~/News/news.group/num.  Otherwise, it is like ~/News/news/group/num."
2739   (let ((default
2740           (expand-file-name
2741            (concat (if (gnus-use-long-file-name 'not-save)
2742                        newsgroup
2743                      (gnus-newsgroup-directory-form newsgroup))
2744                    "/" (int-to-string (mail-header-number headers)))
2745            gnus-article-save-directory)))
2746     (if (and last-file
2747              (string-equal (file-name-directory default)
2748                            (file-name-directory last-file))
2749              (string-match "^[0-9]+$" (file-name-nondirectory last-file)))
2750         default
2751       (or last-file default))))
2752
2753 (defun gnus-plain-save-name (newsgroup headers &optional last-file)
2754   "Generate file name from NEWSGROUP, HEADERS, and optional LAST-FILE.
2755 If variable `gnus-use-long-file-name' is non-nil, it is
2756 ~/News/news.group.  Otherwise, it is like ~/News/news/group/news."
2757   (or last-file
2758       (expand-file-name
2759        (if (gnus-use-long-file-name 'not-save)
2760            newsgroup
2761          (expand-file-name "news" (gnus-newsgroup-directory-form newsgroup)))
2762        gnus-article-save-directory)))
2763
2764 (defun gnus-sender-save-name (newsgroup headers &optional last-file)
2765   "Generate file name from sender."
2766   (let ((from (mail-header-from headers)))
2767     (expand-file-name
2768      (if (and from (string-match "\\([^ <]+\\)@" from))
2769          (match-string 1 from)
2770        "nobody")
2771      gnus-article-save-directory)))
2772
2773 (defun article-verify-x-pgp-sig ()
2774   "Verify X-PGP-Sig."
2775   (interactive)
2776   (if (gnus-buffer-live-p gnus-original-article-buffer)
2777       (let ((sig (with-current-buffer gnus-original-article-buffer
2778                    (gnus-fetch-field "X-PGP-Sig")))
2779             items info headers)
2780         (when (and sig
2781                    mml2015-use
2782                    (mml2015-clear-verify-function))
2783           (with-temp-buffer
2784             (insert-buffer gnus-original-article-buffer)
2785             (setq items (split-string sig))
2786             (message-narrow-to-head)
2787             (let ((inhibit-point-motion-hooks t)
2788                   (case-fold-search t))
2789               ;; Don't verify multiple headers.
2790               (setq headers (mapconcat (lambda (header)
2791                                          (concat header ": "
2792                                                  (mail-fetch-field header) "\n"))
2793                                        (split-string (nth 1 items) ",") "")))
2794             (delete-region (point-min) (point-max))
2795             (insert "-----BEGIN PGP SIGNED MESSAGE-----\n\n")
2796             (insert "X-Signed-Headers: " (nth 1 items) "\n")
2797             (insert headers)
2798             (widen)
2799             (forward-line)
2800             (while (not (eobp))
2801               (if (looking-at "^-")
2802                   (insert "- "))
2803               (forward-line))
2804             (insert "\n-----BEGIN PGP SIGNATURE-----\n")
2805             (insert "Version: " (car items) "\n\n")
2806             (insert (mapconcat 'identity (cddr items) "\n"))
2807             (insert "\n-----END PGP SIGNATURE-----\n")
2808             (let ((mm-security-handle (list (format "multipart/signed"))))
2809               (mml2015-clean-buffer)
2810               (let ((coding-system-for-write (or gnus-newsgroup-charset
2811                                                  'iso-8859-1)))
2812                 (funcall (mml2015-clear-verify-function)))
2813               (setq info
2814                     (or (mm-handle-multipart-ctl-parameter
2815                          mm-security-handle 'gnus-details)
2816                         (mm-handle-multipart-ctl-parameter
2817                          mm-security-handle 'gnus-info)))))
2818           (when info
2819             (let (buffer-read-only bface eface)
2820               (save-restriction
2821                 (message-narrow-to-head)
2822                 (goto-char (point-max))
2823                 (forward-line -1)
2824                 (setq bface (get-text-property (gnus-point-at-bol) 'face)
2825                       eface (get-text-property (1- (gnus-point-at-eol)) 'face))
2826                 (message-remove-header "X-Gnus-PGP-Verify")
2827                 (if (re-search-forward "^X-PGP-Sig:" nil t)
2828                     (forward-line)
2829                   (goto-char (point-max)))
2830                 (narrow-to-region (point) (point))
2831                 (insert "X-Gnus-PGP-Verify: " info "\n")
2832                 (goto-char (point-min))
2833                 (forward-line)
2834                 (while (not (eobp))
2835                   (if (not (looking-at "^[ \t]"))
2836                       (insert " "))
2837                   (forward-line))
2838                 ;; Do highlighting.
2839                 (goto-char (point-min))
2840                 (when (looking-at "\\([^:]+\\): *")
2841                   (put-text-property (match-beginning 1) (1+ (match-end 1))
2842                                      'face bface)
2843                   (put-text-property (match-end 0) (point-max)
2844                                      'face eface)))))))))
2845
2846 (eval-and-compile
2847   (mapcar
2848    (lambda (func)
2849      (let (afunc gfunc)
2850        (if (consp func)
2851            (setq afunc (car func)
2852                  gfunc (cdr func))
2853          (setq afunc func
2854                gfunc (intern (format "gnus-%s" func))))
2855        (defalias gfunc
2856          (if (fboundp afunc)
2857            `(lambda (&optional interactive &rest args)
2858               ,(documentation afunc t)
2859               (interactive (list t))
2860               (save-excursion
2861                 (set-buffer gnus-article-buffer)
2862                 (if interactive
2863                     (call-interactively ',afunc)
2864                   (apply ',afunc args))))))))
2865    '(article-hide-headers
2866      article-verify-x-pgp-sig
2867      article-hide-boring-headers
2868      article-treat-overstrike
2869      article-fill-long-lines
2870      article-capitalize-sentences
2871      article-remove-cr
2872      article-remove-leading-whitespace
2873      article-display-x-face
2874      article-de-quoted-unreadable
2875      article-de-base64-unreadable
2876      article-decode-HZ
2877      article-wash-html
2878      article-hide-list-identifiers
2879      article-hide-pgp
2880      article-strip-banner
2881      article-babel
2882      article-hide-pem
2883      article-hide-signature
2884      article-strip-headers-in-body
2885      article-remove-trailing-blank-lines
2886      article-strip-leading-blank-lines
2887      article-strip-multiple-blank-lines
2888      article-strip-leading-space
2889      article-strip-trailing-space
2890      article-strip-blank-lines
2891      article-strip-all-blank-lines
2892      article-replace-with-quoted-text
2893      article-date-local
2894      article-date-english
2895      article-date-iso8601
2896      article-date-original
2897      article-date-ut
2898      article-decode-mime-words
2899      article-decode-charset
2900      article-decode-encoded-words
2901      article-date-user
2902      article-date-lapsed
2903      article-emphasize
2904      article-treat-dumbquotes
2905      article-normalize-headers
2906      (article-show-all . gnus-article-show-all-headers))))
2907 \f
2908 ;;;
2909 ;;; Gnus article mode
2910 ;;;
2911
2912 (put 'gnus-article-mode 'mode-class 'special)
2913
2914 (set-keymap-parent gnus-article-mode-map widget-keymap)
2915
2916 (gnus-define-keys gnus-article-mode-map
2917   " " gnus-article-goto-next-page
2918   "\177" gnus-article-goto-prev-page
2919   [delete] gnus-article-goto-prev-page
2920   [backspace] gnus-article-goto-prev-page
2921   "\C-c^" gnus-article-refer-article
2922   "h" gnus-article-show-summary
2923   "s" gnus-article-show-summary
2924   "\C-c\C-m" gnus-article-mail
2925   "?" gnus-article-describe-briefly
2926   "e" gnus-summary-edit-article
2927   "<" beginning-of-buffer
2928   ">" end-of-buffer
2929   "\C-c\C-i" gnus-info-find-node
2930   "\C-c\C-b" gnus-bug
2931   "\C-hk" gnus-article-describe-key
2932   "\C-hc" gnus-article-describe-key-briefly
2933
2934   "\C-d" gnus-article-read-summary-keys
2935   "\M-*" gnus-article-read-summary-keys
2936   "\M-#" gnus-article-read-summary-keys
2937   "\M-^" gnus-article-read-summary-keys
2938   "\M-g" gnus-article-read-summary-keys)
2939
2940 (substitute-key-definition
2941  'undefined 'gnus-article-read-summary-keys gnus-article-mode-map)
2942
2943 (defun gnus-article-make-menu-bar ()
2944   (unless (boundp 'gnus-article-commands-menu)
2945     (gnus-summary-make-menu-bar))
2946   (gnus-turn-off-edit-menu 'article)
2947   (unless (boundp 'gnus-article-article-menu)
2948     (easy-menu-define
2949      gnus-article-article-menu gnus-article-mode-map ""
2950      '("Article"
2951        ["Scroll forwards" gnus-article-goto-next-page t]
2952        ["Scroll backwards" gnus-article-goto-prev-page t]
2953        ["Show summary" gnus-article-show-summary t]
2954        ["Fetch Message-ID at point" gnus-article-refer-article t]
2955        ["Mail to address at point" gnus-article-mail t]
2956        ["Send a bug report" gnus-bug t]))
2957
2958     (easy-menu-define
2959      gnus-article-treatment-menu gnus-article-mode-map ""
2960      ;; Fixme: this should use :active (and maybe :visible).
2961      '("Treatment"
2962        ["Hide headers" gnus-article-hide-headers t]
2963        ["Hide signature" gnus-article-hide-signature t]
2964        ["Hide citation" gnus-article-hide-citation t]
2965        ["Treat overstrike" gnus-article-treat-overstrike t]
2966        ["Remove carriage return" gnus-article-remove-cr t]
2967        ["Remove leading whitespace" gnus-article-remove-leading-whitespace t]
2968        ["Remove quoted-unreadable" gnus-article-de-quoted-unreadable t]
2969        ["Remove base64" gnus-article-de-base64-unreadable t]
2970        ["Treat html" gnus-article-wash-html t]
2971        ["Decode HZ" gnus-article-decode-HZ t]))
2972
2973     ;; Note "Commands" menu is defined in gnus-sum.el for consistency
2974
2975     ;; Note "Post" menu is defined in gnus-sum.el for consistency
2976
2977     (gnus-run-hooks 'gnus-article-menu-hook)))
2978
2979 ;; Fixme: do something for the Emacs tool bar in Article mode a la
2980 ;; Summary.
2981
2982 (defun gnus-article-mode ()
2983   "Major mode for displaying an article.
2984
2985 All normal editing commands are switched off.
2986
2987 The following commands are available in addition to all summary mode
2988 commands:
2989 \\<gnus-article-mode-map>
2990 \\[gnus-article-next-page]\t Scroll the article one page forwards
2991 \\[gnus-article-prev-page]\t Scroll the article one page backwards
2992 \\[gnus-article-refer-article]\t Go to the article referred to by an article id near point
2993 \\[gnus-article-show-summary]\t Display the summary buffer
2994 \\[gnus-article-mail]\t Send a reply to the address near point
2995 \\[gnus-article-describe-briefly]\t Describe the current mode briefly
2996 \\[gnus-info-find-node]\t Go to the Gnus info node"
2997   (interactive)
2998   (gnus-simplify-mode-line)
2999   (setq mode-name "Article")
3000   (setq major-mode 'gnus-article-mode)
3001   (make-local-variable 'minor-mode-alist)
3002   (use-local-map gnus-article-mode-map)
3003   (when (gnus-visual-p 'article-menu 'menu)
3004     (gnus-article-make-menu-bar))
3005   (gnus-update-format-specifications nil 'article-mode)
3006   (set (make-local-variable 'page-delimiter) gnus-page-delimiter)
3007   (make-local-variable 'gnus-page-broken)
3008   (make-local-variable 'gnus-button-marker-list)
3009   (make-local-variable 'gnus-article-current-summary)
3010   (make-local-variable 'gnus-article-mime-handles)
3011   (make-local-variable 'gnus-article-decoded-p)
3012   (make-local-variable 'gnus-article-mime-handle-alist)
3013   (make-local-variable 'gnus-article-wash-types)
3014   (make-local-variable 'gnus-article-charset)
3015   (make-local-variable 'gnus-article-ignored-charsets)
3016   (gnus-set-default-directory)
3017   (buffer-disable-undo)
3018   (setq buffer-read-only t)
3019   (set-syntax-table gnus-article-mode-syntax-table)
3020   (mm-enable-multibyte)
3021   (gnus-run-hooks 'gnus-article-mode-hook))
3022
3023 (defun gnus-article-setup-buffer ()
3024   "Initialize the article buffer."
3025   (let* ((name (if gnus-single-article-buffer "*Article*"
3026                  (concat "*Article " gnus-newsgroup-name "*")))
3027          (original
3028           (progn (string-match "\\*Article" name)
3029                  (concat " *Original Article"
3030                          (substring name (match-end 0))))))
3031     (setq gnus-article-buffer name)
3032     (setq gnus-original-article-buffer original)
3033     (setq gnus-article-mime-handle-alist nil)
3034     ;; This might be a variable local to the summary buffer.
3035     (unless gnus-single-article-buffer
3036       (save-excursion
3037         (set-buffer gnus-summary-buffer)
3038         (setq gnus-article-buffer name)
3039         (setq gnus-original-article-buffer original)
3040         (gnus-set-global-variables)))
3041     (gnus-article-setup-highlight-words)
3042     ;; Init original article buffer.
3043     (save-excursion
3044       (set-buffer (gnus-get-buffer-create gnus-original-article-buffer))
3045       (mm-enable-multibyte)
3046       (setq major-mode 'gnus-original-article-mode)
3047       (make-local-variable 'gnus-original-article))
3048     (if (get-buffer name)
3049         (save-excursion
3050           (set-buffer name)
3051           (when gnus-article-mime-handles
3052             (mm-destroy-parts gnus-article-mime-handles)
3053             (setq gnus-article-mime-handles nil))
3054           ;; Set it to nil in article-buffer!
3055           (setq gnus-article-mime-handle-alist nil)
3056           (buffer-disable-undo)
3057           (setq buffer-read-only t)
3058           (unless (eq major-mode 'gnus-article-mode)
3059             (gnus-article-mode))
3060           (current-buffer))
3061       (save-excursion
3062         (set-buffer (gnus-get-buffer-create name))
3063         (gnus-article-mode)
3064         (make-local-variable 'gnus-summary-buffer)
3065         (gnus-summary-set-local-parameters gnus-newsgroup-name)
3066         (current-buffer)))))
3067
3068 ;; Set article window start at LINE, where LINE is the number of lines
3069 ;; from the head of the article.
3070 (defun gnus-article-set-window-start (&optional line)
3071   (set-window-start
3072    (get-buffer-window gnus-article-buffer t)
3073    (save-excursion
3074      (set-buffer gnus-article-buffer)
3075      (goto-char (point-min))
3076      (if (not line)
3077          (point-min)
3078        (gnus-message 6 "Moved to bookmark")
3079        (search-forward "\n\n" nil t)
3080        (forward-line line)
3081        (point)))))
3082
3083 (defun gnus-article-prepare (article &optional all-headers header)
3084   "Prepare ARTICLE in article mode buffer.
3085 ARTICLE should either be an article number or a Message-ID.
3086 If ARTICLE is an id, HEADER should be the article headers.
3087 If ALL-HEADERS is non-nil, no headers are hidden."
3088   (save-excursion
3089     ;; Make sure we start in a summary buffer.
3090     (unless (eq major-mode 'gnus-summary-mode)
3091       (set-buffer gnus-summary-buffer))
3092     (setq gnus-summary-buffer (current-buffer))
3093     (let* ((gnus-article (if header (mail-header-number header) article))
3094            (summary-buffer (current-buffer))
3095            (gnus-tmp-internal-hook gnus-article-internal-prepare-hook)
3096            (group gnus-newsgroup-name)
3097            result)
3098       (save-excursion
3099         (gnus-article-setup-buffer)
3100         (set-buffer gnus-article-buffer)
3101         ;; Deactivate active regions.
3102         (when (and (boundp 'transient-mark-mode)
3103                    transient-mark-mode)
3104           (setq mark-active nil))
3105         (if (not (setq result (let ((buffer-read-only nil))
3106                                 (gnus-request-article-this-buffer
3107                                  article group))))
3108             ;; There is no such article.
3109             (save-excursion
3110               (when (and (numberp article)
3111                          (not (memq article gnus-newsgroup-sparse)))
3112                 (setq gnus-article-current
3113                       (cons gnus-newsgroup-name article))
3114                 (set-buffer gnus-summary-buffer)
3115                 (setq gnus-current-article article)
3116                 (if (eq (gnus-article-mark article) gnus-undownloaded-mark)
3117                     (progn
3118                       (gnus-summary-set-agent-mark article)
3119                       (message "Message marked for downloading"))
3120                   (gnus-summary-mark-article article gnus-canceled-mark)
3121                   (unless (memq article gnus-newsgroup-sparse)
3122                     (gnus-error 1 "No such article (may have expired or been canceled)")))))
3123           (if (or (eq result 'pseudo)
3124                   (eq result 'nneething))
3125               (progn
3126                 (save-excursion
3127                   (set-buffer summary-buffer)
3128                   (push article gnus-newsgroup-history)
3129                   (setq gnus-last-article gnus-current-article
3130                         gnus-current-article 0
3131                         gnus-current-headers nil
3132                         gnus-article-current nil)
3133                   (if (eq result 'nneething)
3134                       (gnus-configure-windows 'summary)
3135                     (gnus-configure-windows 'article))
3136                   (gnus-set-global-variables))
3137                 (let ((gnus-article-mime-handle-alist-1
3138                        gnus-article-mime-handle-alist))
3139                   (gnus-set-mode-line 'article)))
3140             ;; The result from the `request' was an actual article -
3141             ;; or at least some text that is now displayed in the
3142             ;; article buffer.
3143             (when (and (numberp article)
3144                        (not (eq article gnus-current-article)))
3145               ;; Seems like a new article has been selected.
3146               ;; `gnus-current-article' must be an article number.
3147               (save-excursion
3148                 (set-buffer summary-buffer)
3149                 (push article gnus-newsgroup-history)
3150                 (setq gnus-last-article gnus-current-article
3151                       gnus-current-article article
3152                       gnus-current-headers
3153                       (gnus-summary-article-header gnus-current-article)
3154                       gnus-article-current
3155                       (cons gnus-newsgroup-name gnus-current-article))
3156                 (unless (vectorp gnus-current-headers)
3157                   (setq gnus-current-headers nil))
3158                 (gnus-summary-goto-subject gnus-current-article)
3159                 (when (gnus-summary-show-thread)
3160                   ;; If the summary buffer really was folded, the
3161                   ;; previous goto may not actually have gone to
3162                   ;; the right article, but the thread root instead.
3163                   ;; So we go again.
3164                   (gnus-summary-goto-subject gnus-current-article))
3165                 (gnus-run-hooks 'gnus-mark-article-hook)
3166                 (gnus-set-mode-line 'summary)
3167                 (when (gnus-visual-p 'article-highlight 'highlight)
3168                   (gnus-run-hooks 'gnus-visual-mark-article-hook))
3169                 ;; Set the global newsgroup variables here.
3170                 (gnus-set-global-variables)
3171                 (setq gnus-have-all-headers
3172                       (or all-headers gnus-show-all-headers))))
3173             (save-excursion
3174               (gnus-configure-windows 'article))
3175             (when (or (numberp article)
3176                       (stringp article))
3177               (gnus-article-prepare-display)
3178               ;; Do page break.
3179               (goto-char (point-min))
3180               (setq gnus-page-broken
3181                     (when gnus-break-pages
3182                       (gnus-narrow-to-page)
3183                       t)))
3184             (let ((gnus-article-mime-handle-alist-1
3185                    gnus-article-mime-handle-alist))
3186               (gnus-set-mode-line 'article))
3187             (article-goto-body)
3188             (set-window-point (get-buffer-window (current-buffer)) (point))
3189             (gnus-configure-windows 'article)
3190             t))))))
3191
3192 ;;;###autoload
3193 (defun gnus-article-prepare-display ()
3194   "Make the current buffer look like a nice article."
3195   ;; Hooks for getting information from the article.
3196   ;; This hook must be called before being narrowed.
3197   (let ((gnus-article-buffer (current-buffer))
3198         buffer-read-only)
3199     (unless (eq major-mode 'gnus-article-mode)
3200       (gnus-article-mode))
3201     (setq buffer-read-only nil
3202           gnus-article-wash-types nil)
3203     (gnus-run-hooks 'gnus-tmp-internal-hook)
3204     (when gnus-display-mime-function
3205       (funcall gnus-display-mime-function))
3206     (gnus-run-hooks 'gnus-article-prepare-hook)))
3207
3208 ;;;
3209 ;;; Gnus MIME viewing functions
3210 ;;;
3211
3212 (defvar gnus-mime-button-line-format "%{%([%p. %d%T]%)%}%e\n"
3213   "The following specs can be used:
3214 %t  The MIME type
3215 %T  MIME type, along with additional info
3216 %n  The `name' parameter
3217 %d  The description, if any
3218 %l  The length of the encoded part
3219 %p  The part identifier number
3220 %e  Dots if the part isn't displayed")
3221
3222 (defvar gnus-mime-button-line-format-alist
3223   '((?t gnus-tmp-type ?s)
3224     (?T gnus-tmp-type-long ?s)
3225     (?n gnus-tmp-name ?s)
3226     (?d gnus-tmp-description ?s)
3227     (?p gnus-tmp-id ?s)
3228     (?l gnus-tmp-length ?d)
3229     (?e gnus-tmp-dots ?s)))
3230
3231 (defvar gnus-mime-button-commands
3232   '((gnus-article-press-button "\r" "Toggle Display")
3233     (gnus-mime-view-part "v" "View Interactively...")
3234     (gnus-mime-view-part-as-type "t" "View As Type...")
3235     (gnus-mime-view-part-as-charset "C" "View As charset...")
3236     (gnus-mime-save-part "o" "Save...")
3237     (gnus-mime-save-part-and-strip "\C-o" "Save and Strip")
3238     (gnus-mime-copy-part "c" "View As Text, In Other Buffer")
3239     (gnus-mime-inline-part "i" "View As Text, In This Buffer")
3240     (gnus-mime-internalize-part "E" "View Internally")
3241     (gnus-mime-externalize-part "e" "View Externally")
3242     (gnus-mime-pipe-part "|" "Pipe To Command...")
3243     (gnus-mime-action-on-part "." "Take action on the part")))
3244
3245 (defun gnus-article-mime-part-status ()
3246   (if gnus-article-mime-handle-alist-1
3247       (if (eq 1 (length gnus-article-mime-handle-alist-1))
3248           " (1 part)"
3249         (format " (%d parts)" (length gnus-article-mime-handle-alist-1)))
3250     ""))
3251
3252 (defvar gnus-mime-button-map
3253   (let ((map (make-sparse-keymap)))
3254     (unless (>= (string-to-number emacs-version) 21)
3255       ;; XEmacs doesn't care.
3256       (set-keymap-parent map gnus-article-mode-map))
3257     (define-key map gnus-mouse-2 'gnus-article-push-button)
3258     (define-key map gnus-down-mouse-3 'gnus-mime-button-menu)
3259     (dolist (c gnus-mime-button-commands)
3260       (define-key map (cadr c) (car c)))
3261     map))
3262
3263 (defun gnus-mime-button-menu (event)
3264   "Construct a context-sensitive menu of MIME commands."
3265   (interactive "e")
3266   (save-window-excursion
3267     (let ((pos (event-start event)))
3268       (select-window (posn-window pos))
3269       (goto-char (posn-point pos))
3270       (gnus-article-check-buffer)
3271       (let ((response (x-popup-menu
3272                        t `("MIME Part"
3273                            ("" ,@(mapcar (lambda (c)
3274                                            (cons (caddr c) (car c)))
3275                                          gnus-mime-button-commands))))))
3276         (if response
3277             (call-interactively response))))))
3278
3279 (defun gnus-mime-view-all-parts (&optional handles)
3280   "View all the MIME parts."
3281   (interactive)
3282   (save-current-buffer
3283     (set-buffer gnus-article-buffer)
3284     (let ((handles (or handles gnus-article-mime-handles))
3285           (mail-parse-charset gnus-newsgroup-charset)
3286           (mail-parse-ignored-charsets
3287            (with-current-buffer gnus-summary-buffer
3288              gnus-newsgroup-ignored-charsets)))
3289       (when handles
3290         (mm-remove-parts handles)
3291         (goto-char (point-min))
3292         (or (search-forward "\n\n") (goto-char (point-max)))
3293         (let (buffer-read-only)
3294           (delete-region (point) (point-max)))
3295         (mm-display-parts handles)))))
3296
3297 (defun gnus-mime-save-part-and-strip ()
3298   "Save the MIME part under point then replace it with an external body."
3299   (interactive)
3300   (gnus-article-check-buffer)
3301   (let* ((data (get-text-property (point) 'gnus-data))
3302          file param)
3303     (if (mm-multiple-handles gnus-article-mime-handles)
3304         (error "This function is not implemented."))
3305     (setq file (and data (mm-save-part data)))
3306     (when file
3307       (with-current-buffer (mm-handle-buffer data)
3308         (erase-buffer)
3309         (insert "Content-Type: " (mm-handle-media-type data))
3310         (mml-insert-parameter-string (cdr (mm-handle-type data))
3311                                      '(charset))
3312         (insert "\n")
3313         (insert "Content-ID: " (message-make-message-id) "\n")
3314         (insert "Content-Transfer-Encoding: binary\n")
3315         (insert "\n"))
3316       (setcdr data
3317               (cdr (mm-make-handle nil
3318                                    `("message/external-body"
3319                                      (access-type . "LOCAL-FILE")
3320                                      (name . ,file)))))
3321       (set-buffer gnus-summary-buffer)
3322       (gnus-article-edit-article
3323        `(lambda ()
3324            (erase-buffer)
3325            (let ((mail-parse-charset (or gnus-article-charset
3326                                          ',gnus-newsgroup-charset))
3327                  (mail-parse-ignored-charsets
3328                   (or gnus-article-ignored-charsets
3329                       ',gnus-newsgroup-ignored-charsets))
3330                  (mbl mml-buffer-list))
3331              (setq mml-buffer-list nil)
3332              (insert-buffer gnus-original-article-buffer)
3333              (mime-to-mml gnus-article-mime-handles)
3334              (setq gnus-article-mime-handles nil)
3335              (make-local-hook 'kill-buffer-hook)
3336              (let ((mbl1 mml-buffer-list))
3337                (setq mml-buffer-list mbl)
3338                (set (make-local-variable 'mml-buffer-list) mbl1))
3339              (add-hook 'kill-buffer-hook 'mml-destroy-buffers t t)))
3340        `(lambda (no-highlight)
3341           (let ((mail-parse-charset (or gnus-article-charset
3342                                         ',gnus-newsgroup-charset))
3343                 (message-options message-options)
3344                 (message-options-set-recipient)
3345                 (mail-parse-ignored-charsets
3346                  (or gnus-article-ignored-charsets
3347                      ',gnus-newsgroup-ignored-charsets)))
3348            (mml-to-mime)
3349            (mml-destroy-buffers)
3350            (remove-hook 'kill-buffer-hook
3351                         'mml-destroy-buffers t)
3352            (kill-local-variable 'mml-buffer-list))
3353           (gnus-summary-edit-article-done
3354            ,(or (mail-header-references gnus-current-headers) "")
3355            ,(gnus-group-read-only-p)
3356            ,gnus-summary-buffer no-highlight))))))
3357
3358 (defun gnus-mime-save-part ()
3359   "Save the MIME part under point."
3360   (interactive)
3361   (gnus-article-check-buffer)
3362   (let ((data (get-text-property (point) 'gnus-data)))
3363     (when data
3364       (mm-save-part data))))
3365
3366 (defun gnus-mime-pipe-part ()
3367   "Pipe the MIME part under point to a process."
3368   (interactive)
3369   (gnus-article-check-buffer)
3370   (let ((data (get-text-property (point) 'gnus-data)))
3371     (when data
3372       (mm-pipe-part data))))
3373
3374 (defun gnus-mime-view-part ()
3375   "Interactively choose a viewing method for the MIME part under point."
3376   (interactive)
3377   (gnus-article-check-buffer)
3378   (let ((data (get-text-property (point) 'gnus-data)))
3379     (when data
3380       (setq gnus-article-mime-handles
3381             (mm-merge-handles
3382              gnus-article-mime-handles (setq data (copy-sequence data))))
3383       (mm-interactively-view-part data))))
3384
3385 (defun gnus-mime-view-part-as-type-internal ()
3386   (gnus-article-check-buffer)
3387   (let* ((name (mail-content-type-get
3388                 (mm-handle-type (get-text-property (point) 'gnus-data))
3389                 'name))
3390          (def-type (and name (mm-default-file-encoding name))))
3391     (and def-type (cons def-type 0))))
3392
3393 (defun gnus-mime-view-part-as-type (&optional mime-type)
3394   "Choose a MIME media type, and view the part as such."
3395   (interactive)
3396   (unless mime-type
3397     (setq mime-type (completing-read
3398                      "View as MIME type: "
3399                      (mapcar #'list (mailcap-mime-types))
3400                      nil nil
3401                      (gnus-mime-view-part-as-type-internal))))
3402   (gnus-article-check-buffer)
3403   (let ((handle (get-text-property (point) 'gnus-data)))
3404     (when handle
3405       (setq handle
3406             (mm-make-handle (mm-handle-buffer handle)
3407                             (cons mime-type (cdr (mm-handle-type handle)))
3408                             (mm-handle-encoding handle)
3409                             (mm-handle-undisplayer handle)
3410                             (mm-handle-disposition handle)
3411                             (mm-handle-description handle)
3412                             (mm-handle-cache handle)
3413                             (mm-handle-id handle)))
3414       (setq gnus-article-mime-handles
3415             (mm-merge-handles gnus-article-mime-handles handle))
3416       (gnus-mm-display-part handle))))
3417
3418 (defun gnus-mime-copy-part (&optional handle)
3419   "Put the the MIME part under point into a new buffer."
3420   (interactive)
3421   (gnus-article-check-buffer)
3422   (let* ((handle (or handle (get-text-property (point) 'gnus-data)))
3423          (contents (and handle (mm-get-part handle)))
3424          (base (and handle
3425                     (file-name-nondirectory
3426                      (or
3427                       (mail-content-type-get (mm-handle-type handle) 'name)
3428                       (mail-content-type-get (mm-handle-type handle)
3429                                              'filename)
3430                       "*decoded*"))))
3431          (buffer (and base (generate-new-buffer base))))
3432     (when contents
3433       (switch-to-buffer buffer)
3434       (insert contents)
3435       ;; We do it this way to make `normal-mode' set the appropriate mode.
3436       (unwind-protect
3437           (progn
3438             (setq buffer-file-name (expand-file-name base))
3439             (normal-mode))
3440         (setq buffer-file-name nil))
3441       (goto-char (point-min)))))
3442
3443 (defun gnus-mime-inline-part (&optional handle arg)
3444   "Insert the MIME part under point into the current buffer."
3445   (interactive (list nil current-prefix-arg))
3446   (gnus-article-check-buffer)
3447   (let* ((handle (or handle (get-text-property (point) 'gnus-data)))
3448          contents charset
3449          (b (point))
3450          buffer-read-only)
3451     (when handle
3452       (if (and (not arg) (mm-handle-undisplayer handle))
3453           (mm-remove-part handle)
3454         (setq contents (mm-get-part handle))
3455         (cond
3456          ((not arg)
3457           (setq charset (or (mail-content-type-get
3458                              (mm-handle-type handle) 'charset)
3459                             gnus-newsgroup-charset)))
3460          ((numberp arg)
3461           (if (mm-handle-undisplayer handle)
3462               (mm-remove-part handle))
3463           (setq charset
3464                 (or (cdr (assq arg
3465                                gnus-summary-show-article-charset-alist))
3466                     (read-coding-system "Charset: ")))))
3467         (forward-line 2)
3468         (mm-insert-inline handle
3469                           (if (and charset
3470                                    (setq charset (mm-charset-to-coding-system
3471                                                   charset))
3472                                    (not (eq charset 'ascii)))
3473                               (mm-decode-coding-string contents charset)
3474                             contents))
3475         (goto-char b)))))
3476
3477 (defun gnus-mime-view-part-as-charset (&optional handle arg)
3478   "Insert the MIME part under point into the current buffer using the
3479 specified charset."
3480   (interactive (list nil current-prefix-arg))
3481   (gnus-article-check-buffer)
3482   (let* ((handle (or handle (get-text-property (point) 'gnus-data)))
3483          contents charset
3484          (b (point))
3485          buffer-read-only)
3486     (when handle
3487       (if (mm-handle-undisplayer handle)
3488           (mm-remove-part handle))
3489       (let ((gnus-newsgroup-charset
3490              (or (cdr (assq arg
3491                             gnus-summary-show-article-charset-alist))
3492                  (read-coding-system "Charset: ")))
3493           (gnus-newsgroup-ignored-charsets 'gnus-all))
3494         (gnus-article-press-button)))))
3495
3496 (defun gnus-mime-externalize-part (&optional handle)
3497   "View the MIME part under point with an external viewer."
3498   (interactive)
3499   (gnus-article-check-buffer)
3500   (let* ((handle (or handle (get-text-property (point) 'gnus-data)))
3501          (mm-user-display-methods nil)
3502          (mm-inlined-types nil)
3503          (mail-parse-charset gnus-newsgroup-charset)
3504          (mail-parse-ignored-charsets
3505           (save-excursion (set-buffer gnus-summary-buffer)
3506                           gnus-newsgroup-ignored-charsets)))
3507     (when handle
3508       (if (mm-handle-undisplayer handle)
3509           (mm-remove-part handle)
3510         (mm-display-part handle)))))
3511
3512 (defun gnus-mime-internalize-part (&optional handle)
3513   "View the MIME part under point with an internal viewer.
3514 If no internal viewer is available, use an external viewer."
3515   (interactive)
3516   (gnus-article-check-buffer)
3517   (let* ((handle (or handle (get-text-property (point) 'gnus-data)))
3518          (mm-inlined-types '(".*"))
3519          (mm-inline-large-images t)
3520          (mail-parse-charset gnus-newsgroup-charset)
3521          (mail-parse-ignored-charsets
3522           (save-excursion (set-buffer gnus-summary-buffer)
3523                           gnus-newsgroup-ignored-charsets)))
3524     (when handle
3525       (if (mm-handle-undisplayer handle)
3526           (mm-remove-part handle)
3527         (mm-display-part handle)))))
3528
3529 (defun gnus-mime-action-on-part (&optional action)
3530   "Do something with the MIME attachment at \(point\)."
3531   (interactive
3532    (list (completing-read "Action: " gnus-mime-action-alist)))
3533   (gnus-article-check-buffer)
3534   (let ((action-pair (assoc action gnus-mime-action-alist)))
3535     (if action-pair
3536         (funcall (cdr action-pair)))))
3537
3538 (defun gnus-article-part-wrapper (n function)
3539   (save-current-buffer
3540     (set-buffer gnus-article-buffer)
3541     (when (> n (length gnus-article-mime-handle-alist))
3542       (error "No such part"))
3543     (gnus-article-goto-part n)
3544     (let ((handle (cdr (assq n gnus-article-mime-handle-alist))))
3545       (funcall function handle))))
3546
3547 (defun gnus-article-pipe-part (n)
3548   "Pipe MIME part N, which is the numerical prefix."
3549   (interactive "p")
3550   (gnus-article-part-wrapper n 'mm-pipe-part))
3551
3552 (defun gnus-article-save-part (n)
3553   "Save MIME part N, which is the numerical prefix."
3554   (interactive "p")
3555   (gnus-article-part-wrapper n 'mm-save-part))
3556
3557 (defun gnus-article-interactively-view-part (n)
3558   "View MIME part N interactively, which is the numerical prefix."
3559   (interactive "p")
3560   (gnus-article-part-wrapper n 'mm-interactively-view-part))
3561
3562 (defun gnus-article-copy-part (n)
3563   "Copy MIME part N, which is the numerical prefix."
3564   (interactive "p")
3565   (gnus-article-part-wrapper n 'gnus-mime-copy-part))
3566
3567 (defun gnus-article-view-part-as-charset (n)
3568   "Copy MIME part N, which is the numerical prefix."
3569   (interactive "p")
3570   (gnus-article-part-wrapper n 'gnus-mime-view-part-as-charset))
3571
3572 (defun gnus-article-externalize-part (n)
3573   "View MIME part N externally, which is the numerical prefix."
3574   (interactive "p")
3575   (gnus-article-part-wrapper n 'gnus-mime-externalize-part))
3576
3577 (defun gnus-article-inline-part (n)
3578   "Inline MIME part N, which is the numerical prefix."
3579   (interactive "p")
3580   (gnus-article-part-wrapper n 'gnus-mime-inline-part))
3581
3582 (defun gnus-article-mime-match-handle-first (condition)
3583   (if condition
3584       (let ((alist gnus-article-mime-handle-alist) ihandle n)
3585         (while (setq ihandle (pop alist))
3586           (if (and (cond
3587                     ((functionp condition)
3588                      (funcall condition (cdr ihandle)))
3589                     ((eq condition 'undisplayed)
3590                      (not (or (mm-handle-undisplayer (cdr ihandle))
3591                               (equal (mm-handle-media-type (cdr ihandle))
3592                                      "multipart/alternative"))))
3593                     ((eq condition 'undisplayed-alternative)
3594                      (not (mm-handle-undisplayer (cdr ihandle))))
3595                     (t t))
3596                    (gnus-article-goto-part (car ihandle))
3597                    (or (not n) (< (car ihandle) n)))
3598               (setq n (car ihandle))))
3599         (or n 1))
3600     1))
3601
3602 (defun gnus-article-view-part (&optional n)
3603   "View MIME part N, which is the numerical prefix."
3604   (interactive "P")
3605   (save-current-buffer
3606     (set-buffer gnus-article-buffer)
3607     (or (numberp n) (setq n (gnus-article-mime-match-handle-first
3608                              gnus-article-mime-match-handle-function)))
3609     (when (> n (length gnus-article-mime-handle-alist))
3610       (error "No such part"))
3611     (let ((handle (cdr (assq n gnus-article-mime-handle-alist))))
3612       (when (gnus-article-goto-part n)
3613         (if (equal (car handle) "multipart/alternative")
3614             (gnus-article-press-button)
3615           (when (eq (gnus-mm-display-part handle) 'internal)
3616             (gnus-set-window-start)))))))
3617
3618 (defsubst gnus-article-mime-total-parts ()
3619   (if (bufferp (car gnus-article-mime-handles))
3620       1 ;; single part
3621     (1- (length gnus-article-mime-handles))))
3622
3623 (defun gnus-mm-display-part (handle)
3624   "Display HANDLE and fix MIME button."
3625   (let ((id (get-text-property (point) 'gnus-part))
3626         (point (point))
3627         buffer-read-only)
3628     (forward-line 1)
3629     (prog1
3630         (let ((window (selected-window))
3631               (mail-parse-charset gnus-newsgroup-charset)
3632               (mail-parse-ignored-charsets
3633                (save-excursion (set-buffer gnus-summary-buffer)
3634                                gnus-newsgroup-ignored-charsets)))
3635           (save-excursion
3636             (unwind-protect
3637                 (let ((win (get-buffer-window (current-buffer) t))
3638                       (beg (point)))
3639                   (when win
3640                     (select-window win))
3641                   (goto-char point)
3642                   (forward-line)
3643                   (if (mm-handle-displayed-p handle)
3644                       ;; This will remove the part.
3645                       (mm-display-part handle)
3646                     (save-restriction
3647                       (narrow-to-region (point) (1+ (point)))
3648                       (mm-display-part handle)
3649                       ;; We narrow to the part itself and
3650                       ;; then call the treatment functions.
3651                       (goto-char (point-min))
3652                       (forward-line 1)
3653                       (narrow-to-region (point) (point-max))
3654                       (gnus-treat-article
3655                        nil id
3656                        (gnus-article-mime-total-parts)
3657                        (mm-handle-media-type handle)))))
3658               (select-window window))))
3659       (goto-char point)
3660       (delete-region (gnus-point-at-bol) (progn (forward-line 1) (point)))
3661       (gnus-insert-mime-button
3662        handle id (list (mm-handle-displayed-p handle)))
3663       (goto-char point))))
3664
3665 (defun gnus-article-goto-part (n)
3666   "Go to MIME part N."
3667   (let ((point (text-property-any (point-min) (point-max) 'gnus-part n)))
3668     (when point
3669       (goto-char point))))
3670
3671 (defun gnus-insert-mime-button (handle gnus-tmp-id &optional displayed)
3672   (let ((gnus-tmp-name
3673          (or (mail-content-type-get (mm-handle-type handle)
3674                                     'name)
3675              (mail-content-type-get (mm-handle-disposition handle)
3676                                     'filename)
3677              (mail-content-type-get (mm-handle-type handle)
3678                                     'url)
3679              ""))
3680         (gnus-tmp-type (mm-handle-media-type handle))
3681         (gnus-tmp-description
3682          (mail-decode-encoded-word-string (or (mm-handle-description handle)
3683                                               "")))
3684         (gnus-tmp-dots
3685          (if (if displayed (car displayed)
3686                (mm-handle-displayed-p handle))
3687              "" "..."))
3688         (gnus-tmp-length (with-current-buffer (mm-handle-buffer handle)
3689                            (buffer-size)))
3690         gnus-tmp-type-long b e)
3691     (when (string-match ".*/" gnus-tmp-name)
3692       (setq gnus-tmp-name (replace-match "" t t gnus-tmp-name)))
3693     (setq gnus-tmp-type-long (concat gnus-tmp-type
3694                                      (and (not (equal gnus-tmp-name ""))
3695                                           (concat "; " gnus-tmp-name))))
3696     (or (equal gnus-tmp-description "")
3697         (setq gnus-tmp-type-long (concat " --- " gnus-tmp-type-long)))
3698     (unless (bolp)
3699       (insert "\n"))
3700     (setq b (point))
3701     (gnus-eval-format
3702      gnus-mime-button-line-format gnus-mime-button-line-format-alist
3703      `(keymap ,gnus-mime-button-map
3704               ,@(if (>= (string-to-number emacs-version) 21)
3705                     nil
3706                   (list 'local-map gnus-mime-button-map))
3707               gnus-callback gnus-mm-display-part
3708               gnus-part ,gnus-tmp-id
3709               article-type annotation
3710               gnus-data ,handle))
3711     (setq e (point))
3712     (widget-convert-button
3713      'link b e
3714      :mime-handle handle
3715      :action 'gnus-widget-press-button
3716      :button-keymap gnus-mime-button-map
3717      :help-echo
3718      (lambda (widget/window &optional overlay pos)
3719        ;; Needed to properly clear the message due to a bug in
3720        ;; wid-edit (XEmacs only).
3721        (if (boundp 'help-echo-owns-message)
3722            (setq help-echo-owns-message t))
3723        (format
3724         "%S: %s the MIME part; %S: more options"
3725         (aref gnus-mouse-2 0)
3726         ;; XEmacs will get a single widget arg; Emacs 21 will get
3727         ;; window, overlay, position.
3728         (if (mm-handle-displayed-p
3729              (if overlay
3730                  (with-current-buffer (gnus-overlay-buffer overlay)
3731                    (widget-get (widget-at (gnus-overlay-start overlay))
3732                                :mime-handle))
3733                (widget-get widget/window :mime-handle)))
3734             "hide" "show")
3735         (aref gnus-down-mouse-3 0))))))
3736
3737 (defun gnus-widget-press-button (elems el)
3738   (goto-char (widget-get elems :from))
3739   (gnus-article-press-button))
3740
3741 (defvar gnus-displaying-mime nil)
3742
3743 (defun gnus-display-mime (&optional ihandles)
3744   "Display the MIME parts."
3745   (save-excursion
3746     (save-selected-window
3747       (let ((window (get-buffer-window gnus-article-buffer))
3748             (point (point)))
3749         (when window
3750           (select-window window)
3751           ;; We have to do this since selecting the window
3752           ;; may change the point.  So we set the window point.
3753           (set-window-point window point)))
3754       (let* ((handles (or ihandles (mm-dissect-buffer) (mm-uu-dissect)))
3755              buffer-read-only handle name type b e display)
3756         (when (and (not ihandles)
3757                    (not gnus-displaying-mime))
3758           ;; Top-level call; we clean up.
3759           (when gnus-article-mime-handles
3760             (mm-destroy-parts gnus-article-mime-handles)
3761             (setq gnus-article-mime-handle-alist nil));; A trick.
3762           (setq gnus-article-mime-handles handles)
3763           ;; We allow users to glean info from the handles.
3764           (when gnus-article-mime-part-function
3765             (gnus-mime-part-function handles)))
3766         (if (and handles
3767                  (or (not (stringp (car handles)))
3768                      (cdr handles)))
3769             (progn
3770               (when (and (not ihandles)
3771                          (not gnus-displaying-mime))
3772                 ;; Clean up for mime parts.
3773                 (article-goto-body)
3774                 (delete-region (point) (point-max)))
3775               (let ((gnus-displaying-mime t))
3776                 (gnus-mime-display-part handles)))
3777           (save-restriction
3778             (article-goto-body)
3779             (narrow-to-region (point) (point-max))
3780             (gnus-treat-article nil 1 1)
3781             (widen)))
3782         (unless ihandles
3783           ;; Highlight the headers.
3784           (save-excursion
3785             (save-restriction
3786               (article-goto-body)
3787               (narrow-to-region (point-min) (point))
3788               (gnus-treat-article 'head))))))))
3789
3790 (defvar gnus-mime-display-multipart-as-mixed nil)
3791 (defvar gnus-mime-display-multipart-alternative-as-mixed nil)
3792 (defvar gnus-mime-display-multipart-related-as-mixed nil)
3793
3794 (defun gnus-mime-display-part (handle)
3795   (cond
3796    ;; Single part.
3797    ((not (stringp (car handle)))
3798     (gnus-mime-display-single handle))
3799    ;; User-defined multipart
3800    ((cdr (assoc (car handle) gnus-mime-multipart-functions))
3801     (funcall (cdr (assoc (car handle) gnus-mime-multipart-functions))
3802              handle))
3803    ;; multipart/alternative
3804    ((and (equal (car handle) "multipart/alternative")
3805          (not (or gnus-mime-display-multipart-as-mixed
3806                   gnus-mime-display-multipart-alternative-as-mixed)))
3807     (let ((id (1+ (length gnus-article-mime-handle-alist))))
3808       (push (cons id handle) gnus-article-mime-handle-alist)
3809       (gnus-mime-display-alternative (cdr handle) nil nil id)))
3810    ;; multipart/related
3811    ((and (equal (car handle) "multipart/related")
3812          (not (or gnus-mime-display-multipart-as-mixed
3813                   gnus-mime-display-multipart-related-as-mixed)))
3814     ;;;!!!We should find the start part, but we just default
3815     ;;;!!!to the first part.
3816     ;;(gnus-mime-display-part (cadr handle))
3817     ;;;!!! Most multipart/related is an HTML message plus images.
3818     ;;;!!! Unfortunately we are unable to let W3 display those
3819     ;;;!!! included images, so we just display it as a mixed multipart.
3820     ;;(gnus-mime-display-mixed (cdr handle))
3821     ;;;!!! No, w3 can display everything just fine.
3822     (gnus-mime-display-part (cadr handle)))
3823    ((equal (car handle) "multipart/signed")
3824     (or (memq 'signed gnus-article-wash-types)
3825         (push 'signed gnus-article-wash-types))
3826     (gnus-mime-display-security handle))
3827    ((equal (car handle) "multipart/encrypted")
3828     (or (memq 'encrypted gnus-article-wash-types)
3829         (push 'encrypted gnus-article-wash-types))
3830     (gnus-mime-display-security handle))
3831    ;; Other multiparts are handled like multipart/mixed.
3832    (t
3833     (gnus-mime-display-mixed (cdr handle)))))
3834
3835 (defun gnus-mime-part-function (handles)
3836   (if (stringp (car handles))
3837       (mapcar 'gnus-mime-part-function (cdr handles))
3838     (funcall gnus-article-mime-part-function handles)))
3839
3840 (defun gnus-mime-display-mixed (handles)
3841   (mapcar 'gnus-mime-display-part handles))
3842
3843 (defun gnus-mime-display-single (handle)
3844   (let ((type (mm-handle-media-type handle))
3845         (ignored gnus-ignored-mime-types)
3846         (not-attachment t)
3847         (move nil)
3848         display text)
3849     (catch 'ignored
3850       (progn
3851         (while ignored
3852           (when (string-match (pop ignored) type)
3853             (throw 'ignored nil)))
3854         (if (and (setq not-attachment
3855                        (and (not (mm-inline-override-p handle))
3856                             (or (not (mm-handle-disposition handle))
3857                                 (equal (car (mm-handle-disposition handle))
3858                                        "inline")
3859                                 (mm-attachment-override-p handle))))
3860                  (mm-automatic-display-p handle)
3861                  (or (mm-inlined-p handle)
3862                      (mm-automatic-external-display-p type)))
3863             (setq display t)
3864           (when (equal (mm-handle-media-supertype handle) "text")
3865             (setq text t)))
3866         (let ((id (1+ (length gnus-article-mime-handle-alist)))
3867               beg)
3868           (push (cons id handle) gnus-article-mime-handle-alist)
3869           (when (or (not display)
3870                     (not (gnus-unbuttonized-mime-type-p type)))
3871             ;(gnus-article-insert-newline)
3872             (gnus-insert-mime-button
3873              handle id (list (or display (and not-attachment text))))
3874             (gnus-article-insert-newline)
3875             ;(gnus-article-insert-newline)
3876             ;; Remember modify the number of forward lines.
3877             (setq move t))
3878           (setq beg (point))
3879           (cond
3880            (display
3881             (when move
3882               (forward-line -1)
3883               (setq beg (point)))
3884             (let ((mail-parse-charset gnus-newsgroup-charset)
3885                   (mail-parse-ignored-charsets
3886                    (save-excursion (condition-case ()
3887                                        (set-buffer gnus-summary-buffer)
3888                                      (error))
3889                                    gnus-newsgroup-ignored-charsets)))
3890               (mm-display-part handle t))
3891             (goto-char (point-max)))
3892            ((and text not-attachment)
3893             (when move
3894               (forward-line -1)
3895               (setq beg (point)))
3896             (gnus-article-insert-newline)
3897             (mm-insert-inline handle (mm-get-part handle))
3898             (goto-char (point-max))))
3899           ;; Do highlighting.
3900           (save-excursion
3901             (save-restriction
3902               (narrow-to-region beg (point))
3903               (gnus-treat-article
3904                nil id
3905                (gnus-article-mime-total-parts)
3906                (mm-handle-media-type handle)))))))))
3907
3908 (defun gnus-unbuttonized-mime-type-p (type)
3909   "Say whether TYPE is to be unbuttonized."
3910   (unless gnus-inhibit-mime-unbuttonizing
3911     (catch 'found
3912       (let ((types gnus-unbuttonized-mime-types))
3913         (while types
3914           (when (string-match (pop types) type)
3915             (throw 'found t)))))))
3916
3917 (defun gnus-article-insert-newline ()
3918   "Insert a newline, but mark it as undeletable."
3919   (gnus-put-text-property
3920    (point) (progn (insert "\n") (point)) 'gnus-undeletable t))
3921
3922 (defun gnus-mime-display-alternative (handles &optional preferred ibegend id)
3923   (let* ((preferred (or preferred (mm-preferred-alternative handles)))
3924          (ihandles handles)
3925          (point (point))
3926          handle buffer-read-only from props begend not-pref)
3927     (save-window-excursion
3928       (save-restriction
3929         (when ibegend
3930           (narrow-to-region (car ibegend)
3931                             (or (cdr ibegend)
3932                                 (progn
3933                                   (goto-char (car ibegend))
3934                                   (forward-line 2)
3935                                   (point))))
3936           (delete-region (point-min) (point-max))
3937           (mm-remove-parts handles))
3938         (setq begend (list (point-marker)))
3939         ;; Do the toggle.
3940         (unless (setq not-pref (cadr (member preferred ihandles)))
3941           (setq not-pref (car ihandles)))
3942         (when (or ibegend
3943                   (not preferred)
3944                   (not (gnus-unbuttonized-mime-type-p
3945                         "multipart/alternative")))
3946           (gnus-add-text-properties
3947            (setq from (point))
3948            (progn
3949              (insert (format "%d.  " id))
3950              (point))
3951            `(gnus-callback
3952              (lambda (handles)
3953                (unless ,(not ibegend)
3954                  (setq gnus-article-mime-handle-alist
3955                        ',gnus-article-mime-handle-alist))
3956                (gnus-mime-display-alternative
3957                 ',ihandles ',not-pref ',begend ,id))
3958              ,@(if (>= (string-to-number emacs-version) 21)
3959                    nil ;; XEmacs doesn't care
3960                  (list 'local-map gnus-mime-button-map))
3961              ,gnus-mouse-face-prop ,gnus-article-mouse-face
3962              face ,gnus-article-button-face
3963              keymap ,gnus-mime-button-map
3964              gnus-part ,id
3965              gnus-data ,handle))
3966           (widget-convert-button 'link from (point)
3967                                  :action 'gnus-widget-press-button
3968                                  :button-keymap gnus-widget-button-keymap)
3969           ;; Do the handles
3970           (while (setq handle (pop handles))
3971             (gnus-add-text-properties
3972              (setq from (point))
3973              (progn
3974                (insert (format "(%c) %-18s"
3975                                (if (equal handle preferred) ?* ? )
3976                                (mm-handle-media-type handle)))
3977                (point))
3978              `(gnus-callback
3979                (lambda (handles)
3980                  (unless ,(not ibegend)
3981                    (setq gnus-article-mime-handle-alist
3982                          ',gnus-article-mime-handle-alist))
3983                  (gnus-mime-display-alternative
3984                   ',ihandles ',handle ',begend ,id))
3985                ,@(if (>= (string-to-number emacs-version) 21)
3986                      nil ;; XEmacs doesn't care
3987                    (list 'local-map gnus-mime-button-map))
3988                ,gnus-mouse-face-prop ,gnus-article-mouse-face
3989                face ,gnus-article-button-face
3990                keymap ,gnus-mime-button-map
3991                gnus-part ,id
3992                gnus-data ,handle))
3993             (widget-convert-button 'link from (point)
3994                                    :action 'gnus-widget-press-button
3995                                    :button-keymap gnus-widget-button-keymap)
3996             (insert "  "))
3997           (insert "\n\n"))
3998         (when preferred
3999           (if (stringp (car preferred))
4000               (gnus-display-mime preferred)
4001             (let ((mail-parse-charset gnus-newsgroup-charset)
4002                   (mail-parse-ignored-charsets
4003                    (save-excursion (set-buffer gnus-summary-buffer)
4004                                    gnus-newsgroup-ignored-charsets)))
4005               (mm-display-part preferred)
4006               ;; Do highlighting.
4007               (save-excursion
4008                 (save-restriction
4009                   (narrow-to-region (car begend) (point-max))
4010                   (gnus-treat-article
4011                    nil (length gnus-article-mime-handle-alist)
4012                    (gnus-article-mime-total-parts)
4013                    (mm-handle-media-type handle))))))
4014           (goto-char (point-max))
4015           (setcdr begend (point-marker)))))
4016     (when ibegend
4017       (goto-char point))))
4018
4019 (defun gnus-article-wash-status ()
4020   "Return a string which display status of article washing."
4021   (save-excursion
4022     (set-buffer gnus-article-buffer)
4023     (let ((cite (memq 'cite gnus-article-wash-types))
4024           (headers (memq 'headers gnus-article-wash-types))
4025           (boring (memq 'boring-headers gnus-article-wash-types))
4026           (pgp (memq 'pgp gnus-article-wash-types))
4027           (pem (memq 'pem gnus-article-wash-types))
4028           (signed (memq 'signed gnus-article-wash-types))
4029           (encrypted (memq 'encrypted gnus-article-wash-types))
4030           (signature (memq 'signature gnus-article-wash-types))
4031           (overstrike (memq 'overstrike gnus-article-wash-types))
4032           (emphasis (memq 'emphasis gnus-article-wash-types)))
4033       (format "%c%c%c%c%c%c"
4034               (if cite ?c ? )
4035               (if (or headers boring) ?h ? )
4036               (if (or pgp pem signed encrypted) ?p ? )
4037               (if signature ?s ? )
4038               (if overstrike ?o ? )
4039               (if emphasis ?e ? )))))
4040
4041 (defalias 'gnus-article-hide-headers-if-wanted 'gnus-article-maybe-hide-headers)
4042
4043 (defun gnus-article-maybe-hide-headers ()
4044   "Hide unwanted headers if `gnus-have-all-headers' is nil.
4045 Provided for backwards compatibility."
4046   (when (and (or (not (gnus-buffer-live-p gnus-summary-buffer))
4047                  (not (save-excursion (set-buffer gnus-summary-buffer)
4048                                       gnus-have-all-headers)))
4049              (not gnus-inhibit-hiding))
4050     (gnus-article-hide-headers)))
4051
4052 ;;; Article savers.
4053
4054 (defun gnus-output-to-file (file-name)
4055   "Append the current article to a file named FILE-NAME."
4056   (let ((artbuf (current-buffer)))
4057     (with-temp-buffer
4058       (insert-buffer-substring artbuf)
4059       ;; Append newline at end of the buffer as separator, and then
4060       ;; save it to file.
4061       (goto-char (point-max))
4062       (insert "\n")
4063       (mm-append-to-file (point-min) (point-max) file-name)
4064       t)))
4065
4066 (defun gnus-narrow-to-page (&optional arg)
4067   "Narrow the article buffer to a page.
4068 If given a numerical ARG, move forward ARG pages."
4069   (interactive "P")
4070   (setq arg (if arg (prefix-numeric-value arg) 0))
4071   (save-excursion
4072     (set-buffer gnus-article-buffer)
4073     (goto-char (point-min))
4074     (widen)
4075     ;; Remove any old next/prev buttons.
4076     (when (gnus-visual-p 'page-marker)
4077       (let ((buffer-read-only nil))
4078         (gnus-remove-text-with-property 'gnus-prev)
4079         (gnus-remove-text-with-property 'gnus-next)))
4080     (when
4081         (cond ((< arg 0)
4082                (re-search-backward page-delimiter nil 'move (1+ (abs arg))))
4083               ((> arg 0)
4084                (re-search-forward page-delimiter nil 'move arg)))
4085       (goto-char (match-end 0)))
4086     (narrow-to-region
4087      (point)
4088      (if (re-search-forward page-delimiter nil 'move)
4089          (match-beginning 0)
4090        (point)))
4091     (when (and (gnus-visual-p 'page-marker)
4092                (not (= (point-min) 1)))
4093       (save-excursion
4094         (goto-char (point-min))
4095         (gnus-insert-prev-page-button)))
4096     (when (and (gnus-visual-p 'page-marker)
4097                (< (+ (point-max) 2) (buffer-size)))
4098       (save-excursion
4099         (goto-char (point-max))
4100         (gnus-insert-next-page-button)))))
4101
4102 ;; Article mode commands
4103
4104 (defun gnus-article-goto-next-page ()
4105   "Show the next page of the article."
4106   (interactive)
4107   (when (gnus-article-next-page)
4108     (goto-char (point-min))
4109     (gnus-article-read-summary-keys nil (gnus-character-to-event ?n))))
4110
4111 (defun gnus-article-goto-prev-page ()
4112   "Show the next page of the article."
4113   (interactive)
4114   (if (bobp) (gnus-article-read-summary-keys nil (gnus-character-to-event ?p))
4115     (gnus-article-prev-page nil)))
4116
4117 (defun gnus-article-next-page (&optional lines)
4118   "Show the next page of the current article.
4119 If end of article, return non-nil.  Otherwise return nil.
4120 Argument LINES specifies lines to be scrolled up."
4121   (interactive "p")
4122   (move-to-window-line -1)
4123   (if (save-excursion
4124         (end-of-line)
4125         (and (pos-visible-in-window-p)  ;Not continuation line.
4126              (eobp)))
4127       ;; Nothing in this page.
4128       (if (or (not gnus-page-broken)
4129               (save-excursion
4130                 (save-restriction
4131                   (widen) (forward-line 1) (eobp)))) ;Real end-of-buffer?
4132           t                             ;Nothing more.
4133         (gnus-narrow-to-page 1)         ;Go to next page.
4134         nil)
4135     ;; More in this page.
4136     (let ((scroll-in-place nil))
4137       (condition-case ()
4138           (scroll-up lines)
4139         (end-of-buffer
4140          ;; Long lines may cause an end-of-buffer error.
4141          (goto-char (point-max)))))
4142     (move-to-window-line 0)
4143     nil))
4144
4145 (defun gnus-article-prev-page (&optional lines)
4146   "Show previous page of current article.
4147 Argument LINES specifies lines to be scrolled down."
4148   (interactive "p")
4149   (move-to-window-line 0)
4150   (if (and gnus-page-broken
4151            (bobp)
4152            (not (save-restriction (widen) (bobp)))) ;Real beginning-of-buffer?
4153       (progn
4154         (gnus-narrow-to-page -1)        ;Go to previous page.
4155         (goto-char (point-max))
4156         (recenter -1))
4157     (let ((scroll-in-place nil))
4158       (prog1
4159           (condition-case ()
4160               (scroll-down lines)
4161             (beginning-of-buffer
4162              (goto-char (point-min))))
4163         (move-to-window-line 0)))))
4164
4165 (defun gnus-article-refer-article ()
4166   "Read article specified by message-id around point."
4167   (interactive)
4168   (let ((point (point)))
4169     (search-forward ">" nil t)          ;Move point to end of "<....>".
4170     (if (re-search-backward "\\(<[^<> \t\n]+>\\)" nil t)
4171         (let ((message-id (match-string 1)))
4172           (goto-char point)
4173           (set-buffer gnus-summary-buffer)
4174           (gnus-summary-refer-article message-id))
4175       (goto-char (point))
4176       (error "No references around point"))))
4177
4178 (defun gnus-article-show-summary ()
4179   "Reconfigure windows to show summary buffer."
4180   (interactive)
4181   (if (not (gnus-buffer-live-p gnus-summary-buffer))
4182       (error "There is no summary buffer for this article buffer")
4183     (gnus-article-set-globals)
4184     (gnus-configure-windows 'article)
4185     (gnus-summary-goto-subject gnus-current-article)
4186     (gnus-summary-position-point)))
4187
4188 (defun gnus-article-describe-briefly ()
4189   "Describe article mode commands briefly."
4190   (interactive)
4191   (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")))
4192
4193 (defun gnus-article-summary-command ()
4194   "Execute the last keystroke in the summary buffer."
4195   (interactive)
4196   (let ((obuf (current-buffer))
4197         (owin (current-window-configuration))
4198         func)
4199     (switch-to-buffer gnus-article-current-summary 'norecord)
4200     (setq func (lookup-key (current-local-map) (this-command-keys)))
4201     (call-interactively func)
4202     (set-buffer obuf)
4203     (set-window-configuration owin)
4204     (set-window-point (get-buffer-window (current-buffer)) (point))))
4205
4206 (defun gnus-article-summary-command-nosave ()
4207   "Execute the last keystroke in the summary buffer."
4208   (interactive)
4209   (let (func)
4210     (pop-to-buffer gnus-article-current-summary 'norecord)
4211     (setq func (lookup-key (current-local-map) (this-command-keys)))
4212     (call-interactively func)))
4213
4214 (defun gnus-article-check-buffer ()
4215   "Beep if not in an article buffer."
4216   (unless (equal major-mode 'gnus-article-mode)
4217     (error "Command invoked outside of a Gnus article buffer")))
4218
4219 (defun gnus-article-read-summary-keys (&optional arg key not-restore-window)
4220   "Read a summary buffer key sequence and execute it from the article buffer."
4221   (interactive "P")
4222   (gnus-article-check-buffer)
4223   (let ((nosaves
4224          '("q" "Q"  "c" "r" "R" "\C-c\C-f" "m"  "a" "f" "F"
4225            "Zc" "ZC" "ZE" "ZQ" "ZZ" "Zn" "ZR" "ZG" "ZN" "ZP"
4226            "=" "^" "\M-^" "|"))
4227         (nosave-but-article
4228          '("A\r"))
4229         (nosave-in-article
4230          '("\C-d"))
4231         (up-to-top
4232          '("n" "Gn" "p" "Gp"))
4233         keys new-sum-point)
4234     (save-excursion
4235       (set-buffer gnus-article-current-summary)
4236       (let (gnus-pick-mode)
4237         (push (or key last-command-event) unread-command-events)
4238         (setq keys (if (featurep 'xemacs)
4239                        (events-to-keys (read-key-sequence nil))
4240                      (read-key-sequence nil)))))
4241
4242     (message "")
4243
4244     (if (or (member keys nosaves)
4245             (member keys nosave-but-article)
4246             (member keys nosave-in-article))
4247         (let (func)
4248           (save-window-excursion
4249             (pop-to-buffer gnus-article-current-summary 'norecord)
4250             ;; We disable the pick minor mode commands.
4251             (let (gnus-pick-mode)
4252               (setq func (lookup-key (current-local-map) keys))))
4253           (if (or (not func)
4254                   (numberp func))
4255               (ding)
4256             (unless (member keys nosave-in-article)
4257               (set-buffer gnus-article-current-summary))
4258             (call-interactively func)
4259             (setq new-sum-point (point)))
4260           (when (member keys nosave-but-article)
4261             (pop-to-buffer gnus-article-buffer 'norecord)))
4262       ;; These commands should restore window configuration.
4263       (let ((obuf (current-buffer))
4264             (owin (current-window-configuration))
4265             (opoint (point))
4266             (summary gnus-article-current-summary)
4267             func in-buffer selected)
4268         (if not-restore-window
4269             (pop-to-buffer summary 'norecord)
4270           (switch-to-buffer summary 'norecord))
4271         (setq in-buffer (current-buffer))
4272         ;; We disable the pick minor mode commands.
4273         (if (and (setq func (let (gnus-pick-mode)
4274                               (lookup-key (current-local-map) keys)))
4275                  (functionp func))
4276             (progn
4277               (call-interactively func)
4278               (setq new-sum-point (point))
4279               (when (eq in-buffer (current-buffer))
4280                 (setq selected (gnus-summary-select-article))
4281                 (set-buffer obuf)
4282                 (unless not-restore-window
4283                   (set-window-configuration owin))
4284                 (when (eq selected 'old)
4285                   (article-goto-body)
4286                   (set-window-start (get-buffer-window (current-buffer))
4287                                     1)
4288                   (set-window-point (get-buffer-window (current-buffer))
4289                                     (point)))
4290                 (let ((win (get-buffer-window gnus-article-current-summary)))
4291                   (when win
4292                     (set-window-point win new-sum-point))))    )
4293           (switch-to-buffer gnus-article-buffer)
4294           (ding))))))
4295
4296 (defun gnus-article-describe-key (key)
4297   "Display documentation of the function invoked by KEY.  KEY is a string."
4298   (interactive "kDescribe key: ")
4299   (gnus-article-check-buffer)
4300   (if (eq (key-binding key) 'gnus-article-read-summary-keys)
4301       (save-excursion
4302         (set-buffer gnus-article-current-summary)
4303         (let (gnus-pick-mode)
4304           (if (featurep 'xemacs)
4305               (progn
4306                 (push (elt key 0) unread-command-events)
4307                 (setq key (events-to-keys
4308                            (read-key-sequence "Describe key: "))))
4309             (setq unread-command-events
4310                   (mapcar
4311                    (lambda (x) (if (>= x 128) (list 'meta (- x 128)) x))
4312                    (string-to-list key)))
4313             (setq key (read-key-sequence "Describe key: "))))
4314         (describe-key key))
4315     (describe-key key)))
4316
4317 (defun gnus-article-describe-key-briefly (key &optional insert)
4318   "Display documentation of the function invoked by KEY.  KEY is a string."
4319   (interactive "kDescribe key: \nP")
4320   (gnus-article-check-buffer)
4321   (if (eq (key-binding key) 'gnus-article-read-summary-keys)
4322       (save-excursion
4323         (set-buffer gnus-article-current-summary)
4324         (let (gnus-pick-mode)
4325           (if (featurep 'xemacs)
4326               (progn
4327                 (push (elt key 0) unread-command-events)
4328                 (setq key (events-to-keys
4329                            (read-key-sequence "Describe key: "))))
4330             (setq unread-command-events
4331                   (mapcar
4332                    (lambda (x) (if (>= x 128) (list 'meta (- x 128)) x))
4333                    (string-to-list key)))
4334             (setq key (read-key-sequence "Describe key: "))))
4335         (describe-key-briefly key insert))
4336     (describe-key-briefly key insert)))
4337
4338 (defun gnus-article-hide (&optional arg force)
4339   "Hide all the gruft in the current article.
4340 This means that PGP stuff, signatures, cited text and (some)
4341 headers will be hidden.
4342 If given a prefix, show the hidden text instead."
4343   (interactive (append (gnus-article-hidden-arg) (list 'force)))
4344   (gnus-article-hide-headers arg)
4345   (gnus-article-hide-list-identifiers arg)
4346   (gnus-article-hide-pgp arg)
4347   (gnus-article-hide-citation-maybe arg force)
4348   (gnus-article-hide-signature arg))
4349
4350 (defun gnus-article-maybe-highlight ()
4351   "Do some article highlighting if article highlighting is requested."
4352   (when (gnus-visual-p 'article-highlight 'highlight)
4353     (gnus-article-highlight-some)))
4354
4355 (defun gnus-check-group-server ()
4356   ;; Make sure the connection to the server is alive.
4357   (unless (gnus-server-opened
4358            (gnus-find-method-for-group gnus-newsgroup-name))
4359     (gnus-check-server (gnus-find-method-for-group gnus-newsgroup-name))
4360     (gnus-request-group gnus-newsgroup-name t)))
4361
4362 (defun gnus-request-article-this-buffer (article group)
4363   "Get an article and insert it into this buffer."
4364   (let (do-update-line sparse-header)
4365     (prog1
4366         (save-excursion
4367           (erase-buffer)
4368           (gnus-kill-all-overlays)
4369           (setq group (or group gnus-newsgroup-name))
4370
4371           ;; Using `gnus-request-article' directly will insert the article into
4372           ;; `nntp-server-buffer' - so we'll save some time by not having to
4373           ;; copy it from the server buffer into the article buffer.
4374
4375           ;; We only request an article by message-id when we do not have the
4376           ;; headers for it, so we'll have to get those.
4377           (when (stringp article)
4378             (gnus-read-header article))
4379
4380           ;; If the article number is negative, that means that this article
4381           ;; doesn't belong in this newsgroup (possibly), so we find its
4382           ;; message-id and request it by id instead of number.
4383           (when (and (numberp article)
4384                      gnus-summary-buffer
4385                      (get-buffer gnus-summary-buffer)
4386                      (gnus-buffer-exists-p gnus-summary-buffer))
4387             (save-excursion
4388               (set-buffer gnus-summary-buffer)
4389               (let ((header (gnus-summary-article-header article)))
4390                 (when (< article 0)
4391                   (cond
4392                    ((memq article gnus-newsgroup-sparse)
4393                     ;; This is a sparse gap article.
4394                     (setq do-update-line article)
4395                     (setq article (mail-header-id header))
4396                     (setq sparse-header (gnus-read-header article))
4397                     (setq gnus-newsgroup-sparse
4398                           (delq article gnus-newsgroup-sparse)))
4399                    ((vectorp header)
4400                     ;; It's a real article.
4401                     (setq article (mail-header-id header)))
4402                    (t
4403                     ;; It is an extracted pseudo-article.
4404                     (setq article 'pseudo)
4405                     (gnus-request-pseudo-article header))))
4406
4407                 (let ((method (gnus-find-method-for-group
4408                                gnus-newsgroup-name)))
4409                   (when (and (eq (car method) 'nneething)
4410                              (vectorp header))
4411                     (let ((dir (expand-file-name
4412                                 (mail-header-subject header)
4413                                 (file-name-as-directory
4414                                  (or (cadr (assq 'nneething-address method))
4415                                      (nth 1 method))))))
4416                       (when (file-directory-p dir)
4417                         (setq article 'nneething)
4418                         (gnus-group-enter-directory dir))))))))
4419
4420           (cond
4421            ;; Refuse to select canceled articles.
4422            ((and (numberp article)
4423                  gnus-summary-buffer
4424                  (get-buffer gnus-summary-buffer)
4425                  (gnus-buffer-exists-p gnus-summary-buffer)
4426                  (eq (cdr (save-excursion
4427                             (set-buffer gnus-summary-buffer)
4428                             (assq article gnus-newsgroup-reads)))
4429                      gnus-canceled-mark))
4430             nil)
4431            ;; We first check `gnus-original-article-buffer'.
4432            ((and (get-buffer gnus-original-article-buffer)
4433                  (numberp article)
4434                  (save-excursion
4435                    (set-buffer gnus-original-article-buffer)
4436                    (and (equal (car gnus-original-article) group)
4437                         (eq (cdr gnus-original-article) article))))
4438             (insert-buffer-substring gnus-original-article-buffer)
4439             'article)
4440            ;; Check the backlog.
4441            ((and gnus-keep-backlog
4442                  (gnus-backlog-request-article group article (current-buffer)))
4443             'article)
4444            ;; Check asynchronous pre-fetch.
4445            ((gnus-async-request-fetched-article group article (current-buffer))
4446             (gnus-async-prefetch-next group article gnus-summary-buffer)
4447             (when (and (numberp article) gnus-keep-backlog)
4448               (gnus-backlog-enter-article group article (current-buffer)))
4449             'article)
4450            ;; Check the cache.
4451            ((and gnus-use-cache
4452                  (numberp article)
4453                  (gnus-cache-request-article article group))
4454             'article)
4455            ;; Get the article and put into the article buffer.
4456            ((or (stringp article)
4457                 (numberp article))
4458             (let ((gnus-override-method gnus-override-method)
4459                   (methods (and (stringp article)
4460                                 gnus-refer-article-method))
4461                   result
4462                   (buffer-read-only nil))
4463               (if (or (not (listp methods))
4464                       (and (symbolp (car methods))
4465                            (assq (car methods) nnoo-definition-alist)))
4466                   (setq methods (list methods)))
4467               (when (and (null gnus-override-method)
4468                          methods)
4469                 (setq gnus-override-method (pop methods)))
4470               (while (not result)
4471                 (when (eq gnus-override-method 'current)
4472                   (setq gnus-override-method gnus-current-select-method))
4473                 (erase-buffer)
4474                 (gnus-kill-all-overlays)
4475                 (let ((gnus-newsgroup-name group))
4476                   (gnus-check-group-server))
4477                 (when (gnus-request-article article group (current-buffer))
4478                   (when (numberp article)
4479                     (gnus-async-prefetch-next group article
4480                                               gnus-summary-buffer)
4481                     (when gnus-keep-backlog
4482                       (gnus-backlog-enter-article
4483                        group article (current-buffer))))
4484                   (setq result 'article))
4485                 (if (not result)
4486                     (if methods
4487                         (setq gnus-override-method (pop methods))
4488                       (setq result 'done))))
4489               (and (eq result 'article) 'article)))
4490            ;; It was a pseudo.
4491            (t article)))
4492
4493       ;; Associate this article with the current summary buffer.
4494       (setq gnus-article-current-summary gnus-summary-buffer)
4495
4496       ;; Take the article from the original article buffer
4497       ;; and place it in the buffer it's supposed to be in.
4498       (when (and (get-buffer gnus-article-buffer)
4499                  (equal (buffer-name (current-buffer))
4500                         (buffer-name (get-buffer gnus-article-buffer))))
4501         (save-excursion
4502           (if (get-buffer gnus-original-article-buffer)
4503               (set-buffer gnus-original-article-buffer)
4504             (set-buffer (gnus-get-buffer-create gnus-original-article-buffer))
4505             (buffer-disable-undo)
4506             (setq major-mode 'gnus-original-article-mode)
4507             (setq buffer-read-only t))
4508           (let (buffer-read-only)
4509             (erase-buffer)
4510             (insert-buffer-substring gnus-article-buffer))
4511           (setq gnus-original-article (cons group article)))
4512
4513         ;; Decode charsets.
4514         (run-hooks 'gnus-article-decode-hook)
4515         ;; Mark article as decoded or not.
4516         (setq gnus-article-decoded-p gnus-article-decode-hook))
4517
4518       ;; Update sparse articles.
4519       (when (and do-update-line
4520                  (or (numberp article)
4521                      (stringp article)))
4522         (let ((buf (current-buffer)))
4523           (set-buffer gnus-summary-buffer)
4524           (gnus-summary-update-article do-update-line sparse-header)
4525           (gnus-summary-goto-subject do-update-line nil t)
4526           (set-window-point (get-buffer-window (current-buffer) t)
4527                             (point))
4528           (set-buffer buf))))))
4529
4530 ;;;
4531 ;;; Article editing
4532 ;;;
4533
4534 (defcustom gnus-article-edit-mode-hook nil
4535   "Hook run in article edit mode buffers."
4536   :group 'gnus-article-various
4537   :type 'hook)
4538
4539 (defvar gnus-article-edit-done-function nil)
4540
4541 (defvar gnus-article-edit-mode-map nil)
4542
4543 ;; Should we be using derived.el for this?
4544 (unless gnus-article-edit-mode-map
4545   (setq gnus-article-edit-mode-map (make-sparse-keymap))
4546   (set-keymap-parent gnus-article-edit-mode-map text-mode-map)
4547
4548   (gnus-define-keys gnus-article-edit-mode-map
4549     "\C-c\C-c" gnus-article-edit-done
4550     "\C-c\C-k" gnus-article-edit-exit)
4551
4552   (gnus-define-keys (gnus-article-edit-wash-map
4553                      "\C-c\C-w" gnus-article-edit-mode-map)
4554     "f" gnus-article-edit-full-stops))
4555
4556 (defun gnus-article-edit-mode ()
4557   "Major mode for editing articles.
4558 This is an extended text-mode.
4559
4560 \\{gnus-article-edit-mode-map}"
4561   (interactive)
4562   (setq major-mode 'gnus-article-edit-mode)
4563   (setq mode-name "Article Edit")
4564   (use-local-map gnus-article-edit-mode-map)
4565   (make-local-variable 'gnus-article-edit-done-function)
4566   (make-local-variable 'gnus-prev-winconf)
4567   (setq buffer-read-only nil)
4568   (buffer-enable-undo)
4569   (widen)
4570   (gnus-run-hooks 'text-mode-hook 'gnus-article-edit-mode-hook))
4571
4572 (defun gnus-article-edit (&optional force)
4573   "Edit the current article.
4574 This will have permanent effect only in mail groups.
4575 If FORCE is non-nil, allow editing of articles even in read-only
4576 groups."
4577   (interactive "P")
4578   (when (and (not force)
4579              (gnus-group-read-only-p))
4580     (error "The current newsgroup does not support article editing"))
4581   (gnus-article-date-original)
4582   (gnus-article-edit-article
4583    'ignore
4584    `(lambda (no-highlight)
4585       'ignore
4586       (gnus-summary-edit-article-done
4587        ,(or (mail-header-references gnus-current-headers) "")
4588        ,(gnus-group-read-only-p) ,gnus-summary-buffer no-highlight))))
4589
4590 (defun gnus-article-edit-article (start-func exit-func)
4591   "Start editing the contents of the current article buffer."
4592   (let ((winconf (current-window-configuration)))
4593     (set-buffer gnus-article-buffer)
4594     (gnus-article-edit-mode)
4595     (funcall start-func)
4596     (set-buffer-modified-p nil)
4597     (gnus-configure-windows 'edit-article)
4598     (setq gnus-article-edit-done-function exit-func)
4599     (setq gnus-prev-winconf winconf)
4600     (gnus-message 6 "C-c C-c to end edits")))
4601
4602 (defun gnus-article-edit-done (&optional arg)
4603   "Update the article edits and exit."
4604   (interactive "P")
4605   (let ((func gnus-article-edit-done-function)
4606         (buf (current-buffer))
4607         (start (window-start)))
4608     ;; We remove all text props from the article buffer.
4609     (let ((content
4610            (buffer-substring-no-properties (point-min) (point-max)))
4611           (p (point)))
4612       (erase-buffer)
4613       (insert content)
4614       (let ((winconf gnus-prev-winconf))
4615         (gnus-article-mode)
4616         (set-window-configuration winconf)
4617         ;; Tippy-toe some to make sure that point remains where it was.
4618         (save-current-buffer
4619           (set-buffer buf)
4620           (set-window-start (get-buffer-window (current-buffer)) start)
4621           (goto-char p))))
4622     (save-excursion
4623       (set-buffer buf)
4624       (let ((buffer-read-only nil))
4625         (funcall func arg))
4626       ;; The cache and backlog have to be flushed somewhat.
4627       (when gnus-keep-backlog
4628         (gnus-backlog-remove-article
4629          (car gnus-article-current) (cdr gnus-article-current)))
4630       ;; Flush original article as well.
4631       (save-excursion
4632         (when (get-buffer gnus-original-article-buffer)
4633           (set-buffer gnus-original-article-buffer)
4634           (setq gnus-original-article nil)))
4635       (when gnus-use-cache
4636         (gnus-cache-update-article
4637          (car gnus-article-current) (cdr gnus-article-current))))
4638     (set-buffer buf)
4639     (set-window-start (get-buffer-window buf) start)
4640     (set-window-point (get-buffer-window buf) (point))))
4641
4642 (defun gnus-article-edit-exit ()
4643   "Exit the article editing without updating."
4644   (interactive)
4645   (when (or (not (buffer-modified-p))
4646             (yes-or-no-p "Article modified; kill anyway? "))
4647     (let ((curbuf (current-buffer))
4648           (p (point))
4649           (window-start (window-start)))
4650       (erase-buffer)
4651       (if (gnus-buffer-live-p gnus-original-article-buffer)
4652           (insert-buffer gnus-original-article-buffer))
4653       (let ((winconf gnus-prev-winconf))
4654         (gnus-article-mode)
4655         (set-window-configuration winconf)
4656         ;; Tippy-toe some to make sure that point remains where it was.
4657         (save-current-buffer
4658           (set-buffer curbuf)
4659           (set-window-start (get-buffer-window (current-buffer)) window-start)
4660           (goto-char p))))))
4661
4662 (defun gnus-article-edit-full-stops ()
4663   "Interactively repair spacing at end of sentences."
4664   (interactive)
4665   (save-excursion
4666     (goto-char (point-min))
4667     (search-forward-regexp "^$" nil t)
4668     (let ((case-fold-search nil))
4669       (query-replace-regexp "\\([.!?][])}]* \\)\\([[({A-Z]\\)" "\\1 \\2"))))
4670
4671 ;;;
4672 ;;; Article highlights
4673 ;;;
4674
4675 ;; Written by Per Abrahamsen <abraham@iesd.auc.dk>.
4676
4677 ;;; Internal Variables:
4678
4679 (defcustom gnus-button-url-regexp "\\b\\(\\(www\\.\\|\\(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\\)\\)"
4680   "Regular expression that matches URLs."
4681   :group 'gnus-article-buttons
4682   :type 'regexp)
4683
4684 (defcustom gnus-button-alist
4685   `(("<\\(url:[>\n\t ]*?\\)?\\(nntp\\|news\\):[>\n\t ]*\\([^>\n\t ]*@[^>\n\t ]*\\)>"
4686      0 t gnus-button-handle-news 3)
4687     ("\\b\\(nntp\\|news\\):\\([^>\n\t ]*@[^>)!;:,\n\t ]*\\)" 0 t
4688      gnus-button-handle-news 2)
4689     ("\\(\\b<\\(url:[>\n\t ]*\\)?news:[>\n\t ]*\\(//\\)?\\([^>\n\t ]*\\)>\\)"
4690      1 t
4691      gnus-button-fetch-group 4)
4692     ("\\bnews:\\(//\\)?\\([^'\">\n\t ]+\\)" 0 t gnus-button-fetch-group 2)
4693     ("\\bin\\( +article\\| +message\\)? +\\(<\\([^\n @<>]+@[^\n @<>]+\\)>\\)" 2
4694      t gnus-button-message-id 3)
4695     ("\\(<URL: *\\)mailto: *\\([^> \n\t]+\\)>" 0 t gnus-url-mailto 2)
4696     ("mailto:\\([-a-zA-Z.@_+0-9%=?]+\\)" 0 t gnus-url-mailto 1)
4697     ("\\bmailto:\\([^ \n\t]+\\)" 0 t gnus-url-mailto 1)
4698     ;; This is how URLs _should_ be embedded in text...
4699     ("<URL: *\\([^<>]*\\)>" 0 t gnus-button-embedded-url 1)
4700     ;; Raw URLs.
4701     (,gnus-button-url-regexp 0 t browse-url 0))
4702   "*Alist of regexps matching buttons in article bodies.
4703
4704 Each entry has the form (REGEXP BUTTON FORM CALLBACK PAR...), where
4705 REGEXP: is the string matching text around the button,
4706 BUTTON: is the number of the regexp grouping actually matching the button,
4707 FORM: is a lisp expression which must eval to true for the button to
4708 be added,
4709 CALLBACK: is the function to call when the user push this button, and each
4710 PAR: is a number of a regexp grouping whose text will be passed to CALLBACK.
4711
4712 CALLBACK can also be a variable, in that case the value of that
4713 variable it the real callback function."
4714   :group 'gnus-article-buttons
4715   :type '(repeat (list regexp
4716                        (integer :tag "Button")
4717                        (sexp :tag "Form")
4718                        (function :tag "Callback")
4719                        (repeat :tag "Par"
4720                                :inline t
4721                                (integer :tag "Regexp group")))))
4722
4723 (defcustom gnus-header-button-alist
4724   `(("^\\(References\\|Message-I[Dd]\\):" "<[^>]+>"
4725      0 t gnus-button-message-id 0)
4726     ("^\\(From\\|Reply-To\\):" ": *\\(.+\\)$" 1 t gnus-button-reply 1)
4727     ("^\\(Cc\\|To\\):" "[^ \t\n<>,()\"]+@[^ \t\n<>,()\"]+"
4728      0 t gnus-button-mailto 0)
4729     ("^X-[Uu][Rr][Ll]:" ,gnus-button-url-regexp 0 t browse-url 0)
4730     ("^Subject:" ,gnus-button-url-regexp 0 t browse-url 0)
4731     ("^[^:]+:" ,gnus-button-url-regexp 0 t browse-url 0)
4732     ("^[^:]+:" "\\(<\\(url: \\)?news:\\([^>\n ]*\\)>\\)" 1 t
4733      gnus-button-message-id 3))
4734   "*Alist of headers and regexps to match buttons in article heads.
4735
4736 This alist is very similar to `gnus-button-alist', except that each
4737 alist has an additional HEADER element first in each entry:
4738
4739 \(HEADER REGEXP BUTTON FORM CALLBACK PAR)
4740
4741 HEADER is a regexp to match a header.  For a fuller explanation, see
4742 `gnus-button-alist'."
4743   :group 'gnus-article-buttons
4744   :group 'gnus-article-headers
4745   :type '(repeat (list (regexp :tag "Header")
4746                        regexp
4747                        (integer :tag "Button")
4748                        (sexp :tag "Form")
4749                        (function :tag "Callback")
4750                        (repeat :tag "Par"
4751                                :inline t
4752                                (integer :tag "Regexp group")))))
4753
4754 (defvar gnus-button-regexp nil)
4755 (defvar gnus-button-marker-list nil)
4756 ;; Regexp matching any of the regexps from `gnus-button-alist'.
4757
4758 (defvar gnus-button-last nil)
4759 ;; The value of `gnus-button-alist' when `gnus-button-regexp' was build.
4760
4761 ;;; Commands:
4762
4763 (defun gnus-article-push-button (event)
4764   "Check text under the mouse pointer for a callback function.
4765 If the text under the mouse pointer has a `gnus-callback' property,
4766 call it with the value of the `gnus-data' text property."
4767   (interactive "e")
4768   (set-buffer (window-buffer (posn-window (event-start event))))
4769   (let* ((pos (posn-point (event-start event)))
4770          (data (get-text-property pos 'gnus-data))
4771          (fun (get-text-property pos 'gnus-callback)))
4772     (goto-char pos)
4773     (when fun
4774       (funcall fun data))))
4775
4776 (defun gnus-article-press-button ()
4777   "Check text at point for a callback function.
4778 If the text at point has a `gnus-callback' property,
4779 call it with the value of the `gnus-data' text property."
4780   (interactive)
4781   (let* ((data (get-text-property (point) 'gnus-data))
4782          (fun (get-text-property (point) 'gnus-callback)))
4783     (when fun
4784       (funcall fun data))))
4785
4786 (defun gnus-article-highlight (&optional force)
4787   "Highlight current article.
4788 This function calls `gnus-article-highlight-headers',
4789 `gnus-article-highlight-citation',
4790 `gnus-article-highlight-signature', and `gnus-article-add-buttons' to
4791 do the highlighting.  See the documentation for those functions."
4792   (interactive (list 'force))
4793   (gnus-article-highlight-headers)
4794   (gnus-article-highlight-citation force)
4795   (gnus-article-highlight-signature)
4796   (gnus-article-add-buttons force)
4797   (gnus-article-add-buttons-to-head))
4798
4799 (defun gnus-article-highlight-some (&optional force)
4800   "Highlight current article.
4801 This function calls `gnus-article-highlight-headers',
4802 `gnus-article-highlight-signature', and `gnus-article-add-buttons' to
4803 do the highlighting.  See the documentation for those functions."
4804   (interactive (list 'force))
4805   (gnus-article-highlight-headers)
4806   (gnus-article-highlight-signature)
4807   (gnus-article-add-buttons))
4808
4809 (defun gnus-article-highlight-headers ()
4810   "Highlight article headers as specified by `gnus-header-face-alist'."
4811   (interactive)
4812   (save-excursion
4813     (set-buffer gnus-article-buffer)
4814     (save-restriction
4815       (let ((alist gnus-header-face-alist)
4816             (buffer-read-only nil)
4817             (case-fold-search t)
4818             (inhibit-point-motion-hooks t)
4819             entry regexp header-face field-face from hpoints fpoints)
4820         (article-narrow-to-head)
4821         (while (setq entry (pop alist))
4822           (goto-char (point-min))
4823           (setq regexp (concat "^\\("
4824                                (if (string-equal "" (nth 0 entry))
4825                                    "[^\t ]"
4826                                  (nth 0 entry))
4827                                "\\)")
4828                 header-face (nth 1 entry)
4829                 field-face (nth 2 entry))
4830           (while (and (re-search-forward regexp nil t)
4831                       (not (eobp)))
4832             (beginning-of-line)
4833             (setq from (point))
4834             (unless (search-forward ":" nil t)
4835               (forward-char 1))
4836             (when (and header-face
4837                        (not (memq (point) hpoints)))
4838               (push (point) hpoints)
4839               (gnus-put-text-property from (point) 'face header-face))
4840             (when (and field-face
4841                        (not (memq (setq from (point)) fpoints)))
4842               (push from fpoints)
4843               (if (re-search-forward "^[^ \t]" nil t)
4844                   (forward-char -2)
4845                 (goto-char (point-max)))
4846               (gnus-put-text-property from (point) 'face field-face))))))))
4847
4848 (defun gnus-article-highlight-signature ()
4849   "Highlight the signature in an article.
4850 It does this by highlighting everything after
4851 `gnus-signature-separator' using `gnus-signature-face'."
4852   (interactive)
4853   (save-excursion
4854     (set-buffer gnus-article-buffer)
4855     (let ((buffer-read-only nil)
4856           (inhibit-point-motion-hooks t))
4857       (save-restriction
4858         (when (and gnus-signature-face
4859                    (gnus-article-narrow-to-signature))
4860           (gnus-overlay-put (gnus-make-overlay (point-min) (point-max))
4861                             'face gnus-signature-face)
4862           (widen)
4863           (gnus-article-search-signature)
4864           (let ((start (match-beginning 0))
4865                 (end (set-marker (make-marker) (1+ (match-end 0)))))
4866             (gnus-article-add-button start (1- end) 'gnus-signature-toggle
4867                                      end)))))))
4868
4869 (defun gnus-button-in-region-p (b e prop)
4870   "Say whether PROP exists in the region."
4871   (text-property-not-all b e prop nil))
4872
4873 (defun gnus-article-add-buttons (&optional force)
4874   "Find external references in the article and make buttons of them.
4875 \"External references\" are things like Message-IDs and URLs, as
4876 specified by `gnus-button-alist'."
4877   (interactive (list 'force))
4878   (save-excursion
4879     (set-buffer gnus-article-buffer)
4880     (let ((buffer-read-only nil)
4881           (inhibit-point-motion-hooks t)
4882           (case-fold-search t)
4883           (alist gnus-button-alist)
4884           beg entry regexp)
4885       ;; Remove all old markers.
4886       (let (marker entry new-list)
4887         (while (setq marker (pop gnus-button-marker-list))
4888           (if (or (< marker (point-min)) (>= marker (point-max)))
4889               (push marker new-list)
4890             (goto-char marker)
4891             (when (setq entry (gnus-button-entry))
4892               (put-text-property (match-beginning (nth 1 entry))
4893                                  (match-end (nth 1 entry))
4894                                  'gnus-callback nil))
4895             (set-marker marker nil)))
4896         (setq gnus-button-marker-list new-list))
4897       ;; We skip the headers.
4898       (article-goto-body)
4899       (setq beg (point))
4900       (while (setq entry (pop alist))
4901         (setq regexp (car entry))
4902         (goto-char beg)
4903         (while (re-search-forward regexp nil t)
4904           (let* ((start (and entry (match-beginning (nth 1 entry))))
4905                  (end (and entry (match-end (nth 1 entry))))
4906                  (from (match-beginning 0)))
4907             (when (and (or (eq t (nth 2 entry))
4908                            (eval (nth 2 entry)))
4909                        (not (gnus-button-in-region-p
4910                              start end 'gnus-callback)))
4911               ;; That optional form returned non-nil, so we add the
4912               ;; button.
4913               (gnus-article-add-button
4914                start end 'gnus-button-push
4915                (car (push (set-marker (make-marker) from)
4916                           gnus-button-marker-list))))))))))
4917
4918 ;; Add buttons to the head of an article.
4919 (defun gnus-article-add-buttons-to-head ()
4920   "Add buttons to the head of the article."
4921   (interactive)
4922   (save-excursion
4923     (set-buffer gnus-article-buffer)
4924     (save-restriction
4925       (let ((buffer-read-only nil)
4926             (inhibit-point-motion-hooks t)
4927             (case-fold-search t)
4928             (alist gnus-header-button-alist)
4929             entry beg end)
4930         (article-narrow-to-head)
4931         (while alist
4932           ;; Each alist entry.
4933           (setq entry (car alist)
4934                 alist (cdr alist))
4935           (goto-char (point-min))
4936           (while (re-search-forward (car entry) nil t)
4937             ;; Each header matching the entry.
4938             (setq beg (match-beginning 0))
4939             (setq end (or (and (re-search-forward "^[^ \t]" nil t)
4940                                (match-beginning 0))
4941                           (point-max)))
4942             (goto-char beg)
4943             (while (re-search-forward (nth 1 entry) end t)
4944               ;; Each match within a header.
4945               (let* ((entry (cdr entry))
4946                      (start (match-beginning (nth 1 entry)))
4947                      (end (match-end (nth 1 entry)))
4948                      (form (nth 2 entry)))
4949                 (goto-char (match-end 0))
4950                 (when (eval form)
4951                   (gnus-article-add-button
4952                    start end (nth 3 entry)
4953                    (buffer-substring (match-beginning (nth 4 entry))
4954                                      (match-end (nth 4 entry)))))))
4955             (goto-char end)))))))
4956
4957 ;;; External functions:
4958
4959 (defun gnus-article-add-button (from to fun &optional data)
4960   "Create a button between FROM and TO with callback FUN and data DATA."
4961   (when gnus-article-button-face
4962     (gnus-overlay-put (gnus-make-overlay from to)
4963                       'face gnus-article-button-face))
4964   (gnus-add-text-properties
4965    from to
4966    (nconc (and gnus-article-mouse-face
4967                (list gnus-mouse-face-prop gnus-article-mouse-face))
4968           (list 'gnus-callback fun)
4969           (and data (list 'gnus-data data))))
4970   (widget-convert-button 'link from to :action 'gnus-widget-press-button
4971                          :button-keymap gnus-widget-button-keymap))
4972
4973 ;;; Internal functions:
4974
4975 (defun gnus-article-set-globals ()
4976   (save-excursion
4977     (set-buffer gnus-summary-buffer)
4978     (gnus-set-global-variables)))
4979
4980 (defun gnus-signature-toggle (end)
4981   (save-excursion
4982     (set-buffer gnus-article-buffer)
4983     (let ((buffer-read-only nil)
4984           (inhibit-point-motion-hooks t))
4985       (if (text-property-any end (point-max) 'article-type 'signature)
4986           (gnus-remove-text-properties-when
4987            'article-type 'signature end (point-max)
4988            (cons 'article-type (cons 'signature
4989                                      gnus-hidden-properties)))
4990         (gnus-add-text-properties-when
4991          'article-type nil end (point-max)
4992          (cons 'article-type (cons 'signature
4993                                    gnus-hidden-properties)))))))
4994
4995 (defun gnus-button-entry ()
4996   ;; Return the first entry in `gnus-button-alist' matching this place.
4997   (let ((alist gnus-button-alist)
4998         (entry nil))
4999     (while alist
5000       (setq entry (pop alist))
5001       (if (looking-at (car entry))
5002           (setq alist nil)
5003         (setq entry nil)))
5004     entry))
5005
5006 (defun gnus-button-push (marker)
5007   ;; Push button starting at MARKER.
5008   (save-excursion
5009     (goto-char marker)
5010     (let* ((entry (gnus-button-entry))
5011            (inhibit-point-motion-hooks t)
5012            (fun (nth 3 entry))
5013            (args (mapcar (lambda (group)
5014                            (let ((string (match-string group)))
5015                              (gnus-set-text-properties
5016                               0 (length string) nil string)
5017                              string))
5018                          (nthcdr 4 entry))))
5019       (cond
5020        ((fboundp fun)
5021         (apply fun args))
5022        ((and (boundp fun)
5023              (fboundp (symbol-value fun)))
5024         (apply (symbol-value fun) args))
5025        (t
5026         (gnus-message 1 "You must define `%S' to use this button"
5027                       (cons fun args)))))))
5028
5029 (defun gnus-parse-news-url (url)
5030   (let (scheme server group message-id articles)
5031     (with-temp-buffer
5032       (insert url)
5033       (goto-char (point-min))
5034       (when (looking-at "\\([A-Za-z]+\\):")
5035         (setq scheme (match-string 1))
5036         (goto-char (match-end 0)))
5037       (when (looking-at "//\\([^/]+\\)/")
5038         (setq server (match-string 1))
5039         (goto-char (match-end 0)))
5040
5041       (cond
5042        ((looking-at "\\(.*@.*\\)")
5043         (setq message-id (match-string 1)))
5044        ((looking-at "\\([^/]+\\)/\\([-0-9]+\\)")
5045         (setq group (match-string 1)
5046               articles (split-string (match-string 2) "-")))
5047        ((looking-at "\\([^/]+\\)/?")
5048         (setq group (match-string 1)))
5049        (t
5050         (error "Unknown news URL syntax"))))
5051     (list scheme server group message-id articles)))
5052
5053 (defun gnus-button-handle-news (url)
5054   "Fetch a news URL."
5055   (destructuring-bind (scheme server group message-id articles)
5056       (gnus-parse-news-url url)
5057     (cond
5058      (message-id
5059       (save-excursion
5060         (set-buffer gnus-summary-buffer)
5061         (if server
5062             (let ((gnus-refer-article-method (list (list 'nntp server))))
5063               (gnus-summary-refer-article message-id))
5064           (gnus-summary-refer-article message-id))))
5065      (group
5066       (gnus-button-fetch-group url)))))
5067
5068 (defun gnus-button-message-id (message-id)
5069   "Fetch MESSAGE-ID."
5070   (save-excursion
5071     (set-buffer gnus-summary-buffer)
5072     (gnus-summary-refer-article message-id)))
5073
5074 (defun gnus-button-fetch-group (address)
5075   "Fetch GROUP specified by ADDRESS."
5076   (if (not (string-match "[:/]" address))
5077       ;; This is just a simple group url.
5078       (gnus-group-read-ephemeral-group address gnus-select-method)
5079     (if (not (string-match "^\\([^:/]+\\)\\(:\\([^/]+\\)/\\)?\\(.*\\)$"
5080                            address))
5081         (error "Can't parse %s" address)
5082       (gnus-group-read-ephemeral-group
5083        (match-string 4 address)
5084        `(nntp ,(match-string 1 address)
5085               (nntp-address ,(match-string 1 address))
5086               (nntp-port-number ,(if (match-end 3)
5087                                      (match-string 3 address)
5088                                    "nntp")))))))
5089
5090 (defun gnus-url-parse-query-string (query &optional downcase)
5091   (let (retval pairs cur key val)
5092     (setq pairs (split-string query "&"))
5093     (while pairs
5094       (setq cur (car pairs)
5095             pairs (cdr pairs))
5096       (if (not (string-match "=" cur))
5097           nil                           ; Grace
5098         (setq key (gnus-url-unhex-string (substring cur 0 (match-beginning 0)))
5099               val (gnus-url-unhex-string (substring cur (match-end 0) nil)))
5100         (if downcase
5101             (setq key (downcase key)))
5102         (setq cur (assoc key retval))
5103         (if cur
5104             (setcdr cur (cons val (cdr cur)))
5105           (setq retval (cons (list key val) retval)))))
5106     retval))
5107
5108 (defun gnus-url-unhex (x)
5109   (if (> x ?9)
5110       (if (>= x ?a)
5111           (+ 10 (- x ?a))
5112         (+ 10 (- x ?A)))
5113     (- x ?0)))
5114
5115 (defun gnus-url-unhex-string (str &optional allow-newlines)
5116   "Remove %XXX embedded spaces, etc in a url.
5117 If optional second argument ALLOW-NEWLINES is non-nil, then allow the
5118 decoding of carriage returns and line feeds in the string, which is normally
5119 forbidden in URL encoding."
5120   (setq str (or str ""))
5121   (let ((tmp "")
5122         (case-fold-search t))
5123     (while (string-match "%[0-9a-f][0-9a-f]" str)
5124       (let* ((start (match-beginning 0))
5125              (ch1 (gnus-url-unhex (elt str (+ start 1))))
5126              (code (+ (* 16 ch1)
5127                       (gnus-url-unhex (elt str (+ start 2))))))
5128         (setq tmp (concat
5129                    tmp (substring str 0 start)
5130                    (cond
5131                     (allow-newlines
5132                      (char-to-string code))
5133                     ((or (= code ?\n) (= code ?\r))
5134                      " ")
5135                     (t (char-to-string code))))
5136               str (substring str (match-end 0)))))
5137     (setq tmp (concat tmp str))
5138     tmp))
5139
5140 (defun gnus-url-mailto (url)
5141   ;; Send mail to someone
5142   (when (string-match "mailto:/*\\(.*\\)" url)
5143     (setq url (substring url (match-beginning 1) nil)))
5144   (let (to args subject func)
5145     (if (string-match (regexp-quote "?") url)
5146         (setq to (gnus-url-unhex-string (substring url 0 (match-beginning 0)))
5147               args (gnus-url-parse-query-string
5148                     (substring url (match-end 0) nil) t))
5149       (setq to (gnus-url-unhex-string url)))
5150     (setq args (cons (list "to" to) args)
5151           subject (cdr-safe (assoc "subject" args)))
5152     (gnus-msg-mail)
5153     (while args
5154       (setq func (intern-soft (concat "message-goto-" (downcase (caar args)))))
5155       (if (fboundp func)
5156           (funcall func)
5157         (message-position-on-field (caar args)))
5158       (insert (mapconcat 'identity (cdar args) ", "))
5159       (setq args (cdr args)))
5160     (if subject
5161         (message-goto-body)
5162       (message-goto-subject))))
5163
5164 (defun gnus-button-embedded-url (address)
5165   "Activate ADDRESS with `browse-url'."
5166   (browse-url (gnus-strip-whitespace address)))
5167
5168 ;;; Next/prev buttons in the article buffer.
5169
5170 (defvar gnus-next-page-line-format "%{%(Next page...%)%}\n")
5171 (defvar gnus-prev-page-line-format "%{%(Previous page...%)%}\n")
5172
5173 (defvar gnus-prev-page-map nil)
5174 (unless gnus-prev-page-map
5175   (setq gnus-prev-page-map (make-sparse-keymap))
5176   (define-key gnus-prev-page-map gnus-mouse-2 'gnus-button-prev-page)
5177   (define-key gnus-prev-page-map "\r" 'gnus-button-prev-page))
5178
5179 (defun gnus-insert-prev-page-button ()
5180   (let ((buffer-read-only nil))
5181     (gnus-eval-format
5182      gnus-prev-page-line-format nil
5183      `(gnus-prev t local-map ,gnus-prev-page-map
5184                  gnus-callback gnus-article-button-prev-page
5185                  article-type annotation))))
5186
5187 (defvar gnus-next-page-map nil)
5188 (unless gnus-next-page-map
5189   (setq gnus-next-page-map (make-keymap))
5190   (suppress-keymap gnus-prev-page-map)
5191   (define-key gnus-next-page-map gnus-mouse-2 'gnus-button-next-page)
5192   (define-key gnus-next-page-map "\r" 'gnus-button-next-page))
5193
5194 (defun gnus-button-next-page ()
5195   "Go to the next page."
5196   (interactive)
5197   (let ((win (selected-window)))
5198     (select-window (get-buffer-window gnus-article-buffer t))
5199     (gnus-article-next-page)
5200     (select-window win)))
5201
5202 (defun gnus-button-prev-page ()
5203   "Go to the prev page."
5204   (interactive)
5205   (let ((win (selected-window)))
5206     (select-window (get-buffer-window gnus-article-buffer t))
5207     (gnus-article-prev-page)
5208     (select-window win)))
5209
5210 (defun gnus-insert-next-page-button ()
5211   (let ((buffer-read-only nil))
5212     (gnus-eval-format gnus-next-page-line-format nil
5213                       `(gnus-next
5214                         t local-map ,gnus-next-page-map
5215                         gnus-callback gnus-article-button-next-page
5216                         article-type annotation))))
5217
5218 (defun gnus-article-button-next-page (arg)
5219   "Go to the next page."
5220   (interactive "P")
5221   (let ((win (selected-window)))
5222     (select-window (get-buffer-window gnus-article-buffer t))
5223     (gnus-article-next-page)
5224     (select-window win)))
5225
5226 (defun gnus-article-button-prev-page (arg)
5227   "Go to the prev page."
5228   (interactive "P")
5229   (let ((win (selected-window)))
5230     (select-window (get-buffer-window gnus-article-buffer t))
5231     (gnus-article-prev-page)
5232     (select-window win)))
5233
5234 (defvar gnus-decode-header-methods
5235   '(mail-decode-encoded-word-region)
5236   "List of methods used to decode headers.
5237
5238 This variable is a list of FUNCTION or (REGEXP . FUNCTION).  If item
5239 is FUNCTION, FUNCTION will be apply to all newsgroups.  If item is a
5240 (REGEXP . FUNCTION), FUNCTION will be only apply to thes newsgroups
5241 whose names match REGEXP.
5242
5243 For example:
5244 ((\"chinese\" . gnus-decode-encoded-word-region-by-guess)
5245  mail-decode-encoded-word-region
5246  (\"chinese\" . rfc1843-decode-region))
5247 ")
5248
5249 (defvar gnus-decode-header-methods-cache nil)
5250
5251 (defun gnus-multi-decode-header (start end)
5252   "Apply the functions from `gnus-encoded-word-methods' that match."
5253   (unless (and gnus-decode-header-methods-cache
5254                (eq gnus-newsgroup-name
5255                    (car gnus-decode-header-methods-cache)))
5256     (setq gnus-decode-header-methods-cache (list gnus-newsgroup-name))
5257     (mapcar (lambda (x)
5258               (if (symbolp x)
5259                   (nconc gnus-decode-header-methods-cache (list x))
5260                 (if (and gnus-newsgroup-name
5261                          (string-match (car x) gnus-newsgroup-name))
5262                     (nconc gnus-decode-header-methods-cache
5263                            (list (cdr x))))))
5264           gnus-decode-header-methods))
5265   (let ((xlist gnus-decode-header-methods-cache))
5266     (pop xlist)
5267     (save-restriction
5268       (narrow-to-region start end)
5269       (while xlist
5270         (funcall (pop xlist) (point-min) (point-max))))))
5271
5272 ;;;
5273 ;;; Treatment top-level handling.
5274 ;;;
5275
5276 (defun gnus-treat-article (condition &optional part-number total-parts type)
5277   (let ((length (- (point-max) (point-min)))
5278         (alist gnus-treatment-function-alist)
5279         (article-goto-body-goes-to-point-min-p t)
5280         (treated-type
5281          (or (not type)
5282              (catch 'found
5283                (let ((list gnus-article-treat-types))
5284                  (while list
5285                    (when (string-match (pop list) type)
5286                      (throw 'found t)))))))
5287         (highlightp (gnus-visual-p 'article-highlight 'highlight))
5288         val elem)
5289     (gnus-run-hooks 'gnus-part-display-hook)
5290     (while (setq elem (pop alist))
5291       (setq val
5292             (save-excursion
5293               (if (gnus-buffer-live-p gnus-summary-buffer)
5294                   (set-buffer gnus-summary-buffer))
5295               (symbol-value (car elem))))
5296       (when (and (or (consp val)
5297                      treated-type)
5298                  (gnus-treat-predicate val)
5299                  (or (not (get (car elem) 'highlight))
5300                      highlightp))
5301         (save-restriction
5302           (funcall (cadr elem)))))))
5303
5304 ;; Dynamic variables.
5305 (eval-when-compile
5306   (defvar part-number)
5307   (defvar total-parts)
5308   (defvar type)
5309   (defvar condition)
5310   (defvar length))
5311
5312 (defun gnus-treat-predicate (val)
5313   (cond
5314    ((null val)
5315     nil)
5316    ((and (listp val)
5317          (stringp (car val)))
5318     (apply 'gnus-or (mapcar `(lambda (s)
5319                                (string-match s ,(or gnus-newsgroup-name "")))
5320                             val)))
5321    ((listp val)
5322     (let ((pred (pop val)))
5323       (cond
5324        ((eq pred 'or)
5325         (apply 'gnus-or (mapcar 'gnus-treat-predicate val)))
5326        ((eq pred 'and)
5327         (apply 'gnus-and (mapcar 'gnus-treat-predicate val)))
5328        ((eq pred 'not)
5329         (not (gnus-treat-predicate (car val))))
5330        ((eq pred 'typep)
5331         (equal (car val) type))
5332        (t
5333         (error "%S is not a valid predicate" pred)))))
5334    (condition
5335     (eq condition val))
5336    ((eq val t)
5337     t)
5338    ((eq val 'head)
5339     nil)
5340    ((eq val 'last)
5341     (eq part-number total-parts))
5342    ((numberp val)
5343     (< length val))
5344    (t
5345     (error "%S is not a valid value" val))))
5346
5347 (defun gnus-article-encrypt-body (protocol &optional n)
5348   "Encrypt the article body."
5349   (interactive
5350    (list
5351     (or gnus-article-encrypt-protocol
5352         (completing-read "Encrypt protocol: "
5353                          gnus-article-encrypt-protocol-alist
5354                          nil t))
5355     current-prefix-arg))
5356   (let ((func (cdr (assoc protocol gnus-article-encrypt-protocol-alist))))
5357     (unless func
5358       (error (format "Can't find the encrypt protocol %s" protocol)))
5359     (if (equal gnus-newsgroup-name "nndraft:drafts")
5360         (error "Can't encrypt the article in group nndraft:drafts."))
5361     (if (equal gnus-newsgroup-name "nndraft:queue")
5362         (error "Don't encrypt the article in group nndraft:queue."))
5363     (gnus-summary-iterate n
5364       (save-excursion
5365         (set-buffer gnus-summary-buffer)
5366         (let ((mail-parse-charset gnus-newsgroup-charset)
5367               (mail-parse-ignored-charsets gnus-newsgroup-ignored-charsets)
5368               (summary-buffer gnus-summary-buffer)
5369               references point)
5370           (gnus-set-global-variables)
5371           (when (gnus-group-read-only-p)
5372             (error "The current newsgroup does not support article encrypt"))
5373           (gnus-summary-show-article t)
5374           (setq references
5375               (or (mail-header-references gnus-current-headers) ""))
5376           (set-buffer gnus-article-buffer)
5377           (let* ((buffer-read-only nil)
5378                  (headers
5379                   (mapcar (lambda (field)
5380                             (and (save-restriction
5381                                    (message-narrow-to-head)
5382                                    (goto-char (point-min))
5383                                    (search-forward field nil t))
5384                                  (prog2
5385                                      (message-narrow-to-field)
5386                                      (buffer-substring (point-min) (point-max))
5387                                    (delete-region (point-min) (point-max))
5388                                    (widen))))
5389                           '("Content-Type:" "Content-Transfer-Encoding:"
5390                             "Content-Disposition:"))))
5391             (message-narrow-to-head)
5392             (message-remove-header "MIME-Version")
5393             (goto-char (point-max))
5394             (setq point (point))
5395             (insert (apply 'concat headers))
5396             (widen)
5397             (narrow-to-region point (point-max))
5398             (let ((message-options message-options))
5399               (message-options-set 'message-sender user-mail-address)
5400               (message-options-set 'message-recipients user-mail-address)
5401               (message-options-set 'message-sign-encrypt 'not)
5402               (funcall func))
5403             (goto-char (point-min))
5404             (insert "MIME-Version: 1.0\n")
5405             (widen)
5406             (gnus-summary-edit-article-done
5407              references nil summary-buffer t))
5408           (when gnus-keep-backlog
5409             (gnus-backlog-remove-article
5410              (car gnus-article-current) (cdr gnus-article-current)))
5411           (save-excursion
5412             (when (get-buffer gnus-original-article-buffer)
5413               (set-buffer gnus-original-article-buffer)
5414               (setq gnus-original-article nil)))
5415           (when gnus-use-cache
5416             (gnus-cache-update-article
5417              (car gnus-article-current) (cdr gnus-article-current))))))))
5418
5419 (defvar gnus-mime-security-button-line-format "%{%([[%t:%i]%D]%)%}\n"
5420   "The following specs can be used:
5421 %t  The security MIME type
5422 %i  Additional info
5423 %d  Details
5424 %D  Details if button is pressed")
5425
5426 (defvar gnus-mime-security-button-end-line-format "%{%([[End of %t]%D]%)%}\n"
5427   "The following specs can be used:
5428 %t  The security MIME type
5429 %i  Additional info
5430 %d  Details
5431 %D  Details if button is pressed")
5432
5433 (defvar gnus-mime-security-button-line-format-alist
5434   '((?t gnus-tmp-type ?s)
5435     (?i gnus-tmp-info ?s)
5436     (?d gnus-tmp-details ?s)
5437     (?D gnus-tmp-pressed-details ?s)))
5438
5439 (defvar gnus-mime-security-button-map
5440   (let ((map (make-sparse-keymap)))
5441     (unless (>= (string-to-number emacs-version) 21)
5442       (set-keymap-parent map gnus-article-mode-map))
5443     (define-key map gnus-mouse-2 'gnus-article-push-button)
5444     (define-key map "\r" 'gnus-article-press-button)
5445     map))
5446
5447 (defvar gnus-mime-security-details-buffer nil)
5448
5449 (defvar gnus-mime-security-button-pressed nil)
5450
5451 (defvar gnus-mime-security-show-details-inline t
5452   "If non-nil, show details in the article buffer.")
5453
5454 (defun gnus-mime-security-verify-or-decrypt (handle)
5455   (mm-remove-parts (cdr handle))
5456   (let ((region (mm-handle-multipart-ctl-parameter handle 'gnus-region))
5457         buffer-read-only)
5458     (when region
5459       (delete-region (car region) (cdr region))
5460       (set-marker (car region) nil)
5461       (set-marker (cdr region) nil)))
5462   (with-current-buffer (mm-handle-multipart-original-buffer handle)
5463     (let* ((mm-verify-option 'known)
5464            (mm-decrypt-option 'known)
5465            (nparts (mm-possibly-verify-or-decrypt (cdr handle) handle)))
5466       (unless (eq nparts (cdr handle))
5467         (mm-destroy-parts (cdr handle))
5468         (setcdr handle nparts))))
5469   (let ((point (point))
5470         buffer-read-only)
5471     (gnus-mime-display-security handle)
5472     (goto-char point)))
5473
5474 (defun gnus-mime-security-show-details (handle)
5475   (let ((details (mm-handle-multipart-ctl-parameter handle 'gnus-details)))
5476     (if details
5477         (if gnus-mime-security-show-details-inline
5478             (let ((gnus-mime-security-button-pressed t)
5479                   (gnus-mime-security-button-line-format
5480                    (get-text-property (point) 'gnus-line-format))
5481                 buffer-read-only)
5482               (forward-char -1)
5483               (while (eq (get-text-property (point) 'gnus-line-format)
5484                          gnus-mime-security-button-line-format)
5485                 (forward-char -1))
5486               (forward-char)
5487               (delete-region (point)
5488                              (or (text-property-not-all
5489                                   (point) (point-max)
5490                                 'gnus-line-format
5491                                 gnus-mime-security-button-line-format)
5492                                  (point-max)))
5493               (gnus-insert-mime-security-button handle))
5494           (if (gnus-buffer-live-p gnus-mime-security-details-buffer)
5495               (with-current-buffer gnus-mime-security-details-buffer
5496                 (erase-buffer)
5497                 t)
5498             (setq gnus-mime-security-details-buffer
5499                   (gnus-get-buffer-create "*MIME Security Details*")))
5500           (with-current-buffer gnus-mime-security-details-buffer
5501             (insert details)
5502             (goto-char (point-min)))
5503           (pop-to-buffer gnus-mime-security-details-buffer))
5504       (gnus-message 5 "No details."))))
5505
5506 (defun gnus-mime-security-press-button (handle)
5507   (if (mm-handle-multipart-ctl-parameter handle 'gnus-info)
5508       (gnus-mime-security-show-details handle)
5509     (gnus-mime-security-verify-or-decrypt handle)))
5510
5511 (defun gnus-insert-mime-security-button (handle &optional displayed)
5512   (let* ((protocol (mm-handle-multipart-ctl-parameter handle 'protocol))
5513          (gnus-tmp-type
5514           (concat
5515            (or (nth 2 (assoc protocol mm-verify-function-alist))
5516                (nth 2 (assoc protocol mm-decrypt-function-alist))
5517                "Unknown")
5518            (if (equal (car handle) "multipart/signed")
5519                " Signed" " Encrypted")
5520            " Part"))
5521          (gnus-tmp-info
5522           (or (mm-handle-multipart-ctl-parameter handle 'gnus-info)
5523               "Undecided"))
5524          (gnus-tmp-details
5525           (mm-handle-multipart-ctl-parameter handle 'gnus-details))
5526          gnus-tmp-pressed-details
5527          b e)
5528     (setq gnus-tmp-details
5529           (if gnus-tmp-details
5530               (concat "\n" gnus-tmp-details) ""))
5531     (setq gnus-tmp-pressed-details
5532           (if gnus-mime-security-button-pressed gnus-tmp-details ""))
5533     (unless (bolp)
5534       (insert "\n"))
5535     (setq b (point))
5536     (gnus-eval-format
5537      gnus-mime-security-button-line-format
5538      gnus-mime-security-button-line-format-alist
5539      `(keymap ,gnus-mime-security-button-map
5540               ,@(if (>= (string-to-number emacs-version) 21)
5541                     nil ;; XEmacs doesn't care
5542                   (list 'local-map gnus-mime-security-button-map))
5543               gnus-callback gnus-mime-security-press-button
5544               gnus-line-format ,gnus-mime-security-button-line-format
5545               article-type annotation
5546               gnus-data ,handle))
5547     (setq e (point))
5548     (widget-convert-button
5549      'link b e
5550      :mime-handle handle
5551      :action 'gnus-widget-press-button
5552      :button-keymap gnus-mime-security-button-map
5553      :help-echo
5554      (lambda (widget/window &optional overlay pos)
5555        ;; Needed to properly clear the message due to a bug in
5556        ;; wid-edit (XEmacs only).
5557        (if (boundp 'help-echo-owns-message)
5558            (setq help-echo-owns-message t))
5559        (format
5560         "%S: show detail"
5561         (aref gnus-mouse-2 0))))))
5562
5563 (defun gnus-mime-display-security (handle)
5564   (save-restriction
5565     (narrow-to-region (point) (point))
5566     (gnus-insert-mime-security-button handle)
5567     (gnus-mime-display-mixed (cdr handle))
5568     (unless (bolp)
5569       (insert "\n"))
5570     (let ((gnus-mime-security-button-line-format
5571            gnus-mime-security-button-end-line-format))
5572       (gnus-insert-mime-security-button handle))
5573     (mm-set-handle-multipart-parameter
5574      handle 'gnus-region
5575      (cons (set-marker (make-marker) (point-min))
5576            (set-marker (make-marker) (point-max))))))
5577
5578 (gnus-ems-redefine)
5579
5580 (provide 'gnus-art)
5581
5582 (run-hooks 'gnus-art-load-hook)
5583
5584 ;;; gnus-art.el ends here