git.chise.org Git - elisp/gnus.git-/blob - lisp/gnus-art.el

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