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