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