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

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