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