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