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        ;; Not for Emacs 21: fixme better.
3522        ;; local-map ,gnus-mime-button-map
3523        gnus-callback gnus-mm-display-part
3524        gnus-part ,gnus-tmp-id
3525        article-type annotation
3526        gnus-data ,handle))
3527     (setq e (point))
3528     (widget-convert-button
3529      'link b e
3530      :mime-handle handle
3531      :action 'gnus-widget-press-button
3532      :button-keymap gnus-mime-button-map
3533      :help-echo
3534      (lambda (widget/window &optional overlay pos)
3535        ;; Needed to properly clear the message due to a bug in
3536        ;; wid-edit (XEmacs only).
3537        (if (boundp 'help-echo-owns-message)
3538            (setq help-echo-owns-message t))
3539        (format
3540         "%S: %s the MIME part; %S: more options"
3541         (aref gnus-mouse-2 0)
3542         ;; XEmacs will get a single widget arg; Emacs 21 will get
3543         ;; window, overlay, position.
3544         (if (mm-handle-displayed-p
3545              (if overlay
3546                  (with-current-buffer (gnus-overlay-buffer overlay)
3547                    (widget-get (widget-at (gnus-overlay-start overlay))
3548                                :mime-handle))
3549                (widget-get widget/window :mime-handle)))
3550             "hide" "show")
3551         (aref gnus-down-mouse-3 0))))))
3552
3553 (defun gnus-widget-press-button (elems el)
3554   (goto-char (widget-get elems :from))
3555   (gnus-article-press-button))
3556
3557 (defvar gnus-displaying-mime nil)
3558
3559 (defun gnus-display-mime (&optional ihandles)
3560   "Display the MIME parts."
3561   (save-excursion
3562     (save-selected-window
3563       (let ((window (get-buffer-window gnus-article-buffer))
3564             (point (point)))
3565         (when window
3566           (select-window window)
3567           ;; We have to do this since selecting the window
3568           ;; may change the point.  So we set the window point.
3569           (set-window-point window point)))
3570       (let* ((handles (or ihandles (mm-dissect-buffer) (mm-uu-dissect)))
3571              buffer-read-only handle name type b e display)
3572         (when (and (not ihandles)
3573                    (not gnus-displaying-mime))
3574           ;; Top-level call; we clean up.
3575           (when gnus-article-mime-handles
3576             (mm-destroy-parts gnus-article-mime-handles)
3577             (setq gnus-article-mime-handle-alist nil));; A trick.
3578           (setq gnus-article-mime-handles handles)
3579           ;; We allow users to glean info from the handles.
3580           (when gnus-article-mime-part-function
3581             (gnus-mime-part-function handles)))
3582         (if (and handles
3583                  (or (not (stringp (car handles)))
3584                      (cdr handles)))
3585             (progn
3586               (when (and (not ihandles)
3587                          (not gnus-displaying-mime))
3588                 ;; Clean up for mime parts.
3589                 (article-goto-body)
3590                 (delete-region (point) (point-max)))
3591               (let ((gnus-displaying-mime t))
3592                 (gnus-mime-display-part handles)))
3593           (save-restriction
3594             (article-goto-body)
3595             (narrow-to-region (point) (point-max))
3596             (gnus-treat-article nil 1 1)
3597             (widen)))
3598         (unless ihandles
3599           ;; Highlight the headers.
3600           (save-excursion
3601             (save-restriction
3602               (article-goto-body)
3603               (narrow-to-region (point-min) (point))
3604               (gnus-treat-article 'head))))))))
3605
3606 (defvar gnus-mime-display-multipart-as-mixed nil)
3607
3608 (defun gnus-mime-display-part (handle)
3609   (cond
3610    ;; Single part.
3611    ((not (stringp (car handle)))
3612     (gnus-mime-display-single handle))
3613    ;; User-defined multipart
3614    ((cdr (assoc (car handle) gnus-mime-multipart-functions))
3615     (funcall (cdr (assoc (car handle) gnus-mime-multipart-functions))
3616              handle))
3617    ;; multipart/alternative
3618    ((and (equal (car handle) "multipart/alternative")
3619          (not gnus-mime-display-multipart-as-mixed))
3620     (let ((id (1+ (length gnus-article-mime-handle-alist))))
3621       (push (cons id handle) gnus-article-mime-handle-alist)
3622       (gnus-mime-display-alternative (cdr handle) nil nil id)))
3623    ;; multipart/related
3624    ((and (equal (car handle) "multipart/related")
3625          (not gnus-mime-display-multipart-as-mixed))
3626     ;;;!!!We should find the start part, but we just default
3627     ;;;!!!to the first part.
3628     ;;(gnus-mime-display-part (cadr handle))
3629     ;;;!!! Most multipart/related is an HTML message plus images.
3630     ;;;!!! Unfortunately we are unable to let W3 display those
3631     ;;;!!! included images, so we just display it as a mixed multipart.
3632     (gnus-mime-display-mixed (cdr handle)))
3633    ((equal (car handle) "multipart/signed")
3634     (or (memq 'signed gnus-article-wash-types)
3635         (push 'signed gnus-article-wash-types))
3636     (gnus-mime-display-security handle))
3637    ((equal (car handle) "multipart/encrypted")
3638     (or (memq 'encrypted gnus-article-wash-types)
3639         (push 'encrypted gnus-article-wash-types))
3640     (gnus-mime-display-security handle))
3641    ;; Other multiparts are handled like multipart/mixed.
3642    (t
3643     (gnus-mime-display-mixed (cdr handle)))))
3644
3645 (defun gnus-mime-part-function (handles)
3646   (if (stringp (car handles))
3647       (mapcar 'gnus-mime-part-function (cdr handles))
3648     (funcall gnus-article-mime-part-function handles)))
3649
3650 (defun gnus-mime-display-mixed (handles)
3651   (mapcar 'gnus-mime-display-part handles))
3652
3653 (defun gnus-mime-display-single (handle)
3654   (let ((type (mm-handle-media-type handle))
3655         (ignored gnus-ignored-mime-types)
3656         (not-attachment t)
3657         (move nil)
3658         display text)
3659     (catch 'ignored
3660       (progn
3661         (while ignored
3662           (when (string-match (pop ignored) type)
3663             (throw 'ignored nil)))
3664         (if (and (setq not-attachment
3665                        (and (not (mm-inline-override-p handle))
3666                             (or (not (mm-handle-disposition handle))
3667                                 (equal (car (mm-handle-disposition handle))
3668                                        "inline")
3669                                 (mm-attachment-override-p handle))))
3670                  (mm-automatic-display-p handle)
3671                  (or (mm-inlined-p handle)
3672                      (mm-automatic-external-display-p type)))
3673             (setq display t)
3674           (when (equal (mm-handle-media-supertype handle) "text")
3675             (setq text t)))
3676         (let ((id (1+ (length gnus-article-mime-handle-alist)))
3677               beg)
3678           (push (cons id handle) gnus-article-mime-handle-alist)
3679           (when (or (not display)
3680                     (not (gnus-unbuttonized-mime-type-p type)))
3681             ;(gnus-article-insert-newline)
3682             (gnus-insert-mime-button
3683              handle id (list (or display (and not-attachment text))))
3684             (gnus-article-insert-newline)
3685             ;(gnus-article-insert-newline)
3686             ;; Remember modify the number of forward lines.
3687             (setq move t))
3688           (setq beg (point))
3689           (cond
3690            (display
3691             (when move
3692               (forward-line -1)
3693               (setq beg (point)))
3694             (let ((mail-parse-charset gnus-newsgroup-charset)
3695                   (mail-parse-ignored-charsets
3696                    (save-excursion (condition-case ()
3697                                        (set-buffer gnus-summary-buffer)
3698                                      (error))
3699                                    gnus-newsgroup-ignored-charsets)))
3700               (mm-display-part handle t))
3701             (goto-char (point-max)))
3702            ((and text not-attachment)
3703             (when move
3704               (forward-line -1)
3705               (setq beg (point)))
3706             (gnus-article-insert-newline)
3707             (mm-insert-inline handle (mm-get-part handle))
3708             (goto-char (point-max))))
3709           ;; Do highlighting.
3710           (save-excursion
3711             (save-restriction
3712               (narrow-to-region beg (point))
3713               (gnus-treat-article
3714                nil id
3715                (gnus-article-mime-total-parts)
3716                (mm-handle-media-type handle)))))))))
3717
3718 (defun gnus-unbuttonized-mime-type-p (type)
3719   "Say whether TYPE is to be unbuttonized."
3720   (unless gnus-inhibit-mime-unbuttonizing
3721     (catch 'found
3722       (let ((types gnus-unbuttonized-mime-types))
3723         (while types
3724           (when (string-match (pop types) type)
3725             (throw 'found t)))))))
3726
3727 (defun gnus-article-insert-newline ()
3728   "Insert a newline, but mark it as undeletable."
3729   (gnus-put-text-property
3730    (point) (progn (insert "\n") (point)) 'gnus-undeletable t))
3731
3732 (defun gnus-mime-display-alternative (handles &optional preferred ibegend id)
3733   (let* ((preferred (or preferred (mm-preferred-alternative handles)))
3734          (ihandles handles)
3735          (point (point))
3736          handle buffer-read-only from props begend not-pref)
3737     (save-window-excursion
3738       (save-restriction
3739         (when ibegend
3740           (narrow-to-region (car ibegend)
3741                             (or (cdr ibegend)
3742                                 (progn
3743                                   (goto-char (car ibegend))
3744                                   (forward-line 2)
3745                                   (point))))
3746           (delete-region (point-min) (point-max))
3747           (mm-remove-parts handles))
3748         (setq begend (list (point-marker)))
3749         ;; Do the toggle.
3750         (unless (setq not-pref (cadr (member preferred ihandles)))
3751           (setq not-pref (car ihandles)))
3752         (when (or ibegend
3753                   (not preferred)
3754                   (not (gnus-unbuttonized-mime-type-p
3755                         "multipart/alternative")))
3756           (gnus-add-text-properties
3757            (setq from (point))
3758            (progn
3759              (insert (format "%d.  " id))
3760              (point))
3761            `(gnus-callback
3762              (lambda (handles)
3763                (unless ,(not ibegend)
3764                  (setq gnus-article-mime-handle-alist
3765                        ',gnus-article-mime-handle-alist))
3766                (gnus-mime-display-alternative
3767                 ',ihandles ',not-pref ',begend ,id))
3768              ;; Not for Emacs 21: fixme better.
3769              ;; local-map ,gnus-mime-button-map
3770              ,gnus-mouse-face-prop ,gnus-article-mouse-face
3771              face ,gnus-article-button-face
3772              keymap ,gnus-mime-button-map
3773              gnus-part ,id
3774              gnus-data ,handle))
3775           (widget-convert-button 'link from (point)
3776                                  :action 'gnus-widget-press-button
3777                                  :button-keymap gnus-widget-button-keymap)
3778           ;; Do the handles
3779           (while (setq handle (pop handles))
3780             (gnus-add-text-properties
3781              (setq from (point))
3782              (progn
3783                (insert (format "(%c) %-18s"
3784                                (if (equal handle preferred) ?* ? )
3785                                (mm-handle-media-type handle)))
3786                (point))
3787              `(gnus-callback
3788                (lambda (handles)
3789                  (unless ,(not ibegend)
3790                    (setq gnus-article-mime-handle-alist
3791                          ',gnus-article-mime-handle-alist))
3792                  (gnus-mime-display-alternative
3793                   ',ihandles ',handle ',begend ,id))
3794                ;; Not for Emacs 21: fixme better.
3795                ;; local-map ,gnus-mime-button-map
3796                ,gnus-mouse-face-prop ,gnus-article-mouse-face
3797                face ,gnus-article-button-face
3798                keymap ,gnus-mime-button-map
3799                gnus-part ,id
3800                gnus-data ,handle))
3801             (widget-convert-button 'link from (point)
3802                                    :action 'gnus-widget-press-button
3803                                    :button-keymap gnus-widget-button-keymap)
3804             (insert "  "))
3805           (insert "\n\n"))
3806         (when preferred
3807           (if (stringp (car preferred))
3808               (gnus-display-mime preferred)
3809             (let ((mail-parse-charset gnus-newsgroup-charset)
3810                   (mail-parse-ignored-charsets
3811                    (save-excursion (set-buffer gnus-summary-buffer)
3812                                    gnus-newsgroup-ignored-charsets)))
3813               (mm-display-part preferred)
3814               ;; Do highlighting.
3815               (save-excursion
3816                 (save-restriction
3817                   (narrow-to-region (car begend) (point-max))
3818                   (gnus-treat-article
3819                    nil (length gnus-article-mime-handle-alist)
3820                    (gnus-article-mime-total-parts)
3821                    (mm-handle-media-type handle))))))
3822           (goto-char (point-max))
3823           (setcdr begend (point-marker)))))
3824     (when ibegend
3825       (goto-char point))))
3826
3827 (defun gnus-article-wash-status ()
3828   "Return a string which display status of article washing."
3829   (save-excursion
3830     (set-buffer gnus-article-buffer)
3831     (let ((cite (memq 'cite gnus-article-wash-types))
3832           (headers (memq 'headers gnus-article-wash-types))
3833           (boring (memq 'boring-headers gnus-article-wash-types))
3834           (pgp (memq 'pgp gnus-article-wash-types))
3835           (pem (memq 'pem gnus-article-wash-types))
3836           (signed (memq 'signed gnus-article-wash-types))
3837           (encrypted (memq 'encrypted gnus-article-wash-types))
3838           (signature (memq 'signature gnus-article-wash-types))
3839           (overstrike (memq 'overstrike gnus-article-wash-types))
3840           (emphasis (memq 'emphasis gnus-article-wash-types)))
3841       (format "%c%c%c%c%c%c"
3842               (if cite ?c ? )
3843               (if (or headers boring) ?h ? )
3844               (if (or pgp pem signed encrypted) ?p ? )
3845               (if signature ?s ? )
3846               (if overstrike ?o ? )
3847               (if emphasis ?e ? )))))
3848
3849 (defalias 'gnus-article-hide-headers-if-wanted 'gnus-article-maybe-hide-headers)
3850
3851 (defun gnus-article-maybe-hide-headers ()
3852   "Hide unwanted headers if `gnus-have-all-headers' is nil.
3853 Provided for backwards compatibility."
3854   (when (and (or (not (gnus-buffer-live-p gnus-summary-buffer))
3855                  (not (save-excursion (set-buffer gnus-summary-buffer)
3856                                       gnus-have-all-headers)))
3857              (not gnus-inhibit-hiding))
3858     (gnus-article-hide-headers)))
3859
3860 ;;; Article savers.
3861
3862 (defun gnus-output-to-file (file-name)
3863   "Append the current article to a file named FILE-NAME."
3864   (let ((artbuf (current-buffer)))
3865     (with-temp-buffer
3866       (insert-buffer-substring artbuf)
3867       ;; Append newline at end of the buffer as separator, and then
3868       ;; save it to file.
3869       (goto-char (point-max))
3870       (insert "\n")
3871       (mm-append-to-file (point-min) (point-max) file-name)
3872       t)))
3873
3874 (defun gnus-narrow-to-page (&optional arg)
3875   "Narrow the article buffer to a page.
3876 If given a numerical ARG, move forward ARG pages."
3877   (interactive "P")
3878   (setq arg (if arg (prefix-numeric-value arg) 0))
3879   (save-excursion
3880     (set-buffer gnus-article-buffer)
3881     (goto-char (point-min))
3882     (widen)
3883     ;; Remove any old next/prev buttons.
3884     (when (gnus-visual-p 'page-marker)
3885       (let ((buffer-read-only nil))
3886         (gnus-remove-text-with-property 'gnus-prev)
3887         (gnus-remove-text-with-property 'gnus-next)))
3888     (when
3889         (cond ((< arg 0)
3890                (re-search-backward page-delimiter nil 'move (1+ (abs arg))))
3891               ((> arg 0)
3892                (re-search-forward page-delimiter nil 'move arg)))
3893       (goto-char (match-end 0)))
3894     (narrow-to-region
3895      (point)
3896      (if (re-search-forward page-delimiter nil 'move)
3897          (match-beginning 0)
3898        (point)))
3899     (when (and (gnus-visual-p 'page-marker)
3900                (not (= (point-min) 1)))
3901       (save-excursion
3902         (goto-char (point-min))
3903         (gnus-insert-prev-page-button)))
3904     (when (and (gnus-visual-p 'page-marker)
3905                (< (+ (point-max) 2) (buffer-size)))
3906       (save-excursion
3907         (goto-char (point-max))
3908         (gnus-insert-next-page-button)))))
3909
3910 ;; Article mode commands
3911
3912 (defun gnus-article-goto-next-page ()
3913   "Show the next page of the article."
3914   (interactive)
3915   (when (gnus-article-next-page)
3916     (goto-char (point-min))
3917     (gnus-article-read-summary-keys nil (gnus-character-to-event ?n))))
3918
3919 (defun gnus-article-goto-prev-page ()
3920   "Show the next page of the article."
3921   (interactive)
3922   (if (bobp) (gnus-article-read-summary-keys nil (gnus-character-to-event ?p))
3923     (gnus-article-prev-page nil)))
3924
3925 (defun gnus-article-next-page (&optional lines)
3926   "Show the next page of the current article.
3927 If end of article, return non-nil.  Otherwise return nil.
3928 Argument LINES specifies lines to be scrolled up."
3929   (interactive "p")
3930   (move-to-window-line -1)
3931   (if (save-excursion
3932         (end-of-line)
3933         (and (pos-visible-in-window-p)  ;Not continuation line.
3934              (eobp)))
3935       ;; Nothing in this page.
3936       (if (or (not gnus-page-broken)
3937               (save-excursion
3938                 (save-restriction
3939                   (widen) (forward-line 1) (eobp)))) ;Real end-of-buffer?
3940           t                             ;Nothing more.
3941         (gnus-narrow-to-page 1)         ;Go to next page.
3942         nil)
3943     ;; More in this page.
3944     (let ((scroll-in-place nil))
3945       (condition-case ()
3946           (scroll-up lines)
3947         (end-of-buffer
3948          ;; Long lines may cause an end-of-buffer error.
3949          (goto-char (point-max)))))
3950     (move-to-window-line 0)
3951     nil))
3952
3953 (defun gnus-article-prev-page (&optional lines)
3954   "Show previous page of current article.
3955 Argument LINES specifies lines to be scrolled down."
3956   (interactive "p")
3957   (move-to-window-line 0)
3958   (if (and gnus-page-broken
3959            (bobp)
3960            (not (save-restriction (widen) (bobp)))) ;Real beginning-of-buffer?
3961       (progn
3962         (gnus-narrow-to-page -1)        ;Go to previous page.
3963         (goto-char (point-max))
3964         (recenter -1))
3965     (let ((scroll-in-place nil))
3966       (prog1
3967           (condition-case ()
3968               (scroll-down lines)
3969             (beginning-of-buffer
3970              (goto-char (point-min))))
3971         (move-to-window-line 0)))))
3972
3973 (defun gnus-article-refer-article ()
3974   "Read article specified by message-id around point."
3975   (interactive)
3976   (let ((point (point)))
3977     (search-forward ">" nil t)          ;Move point to end of "<....>".
3978     (if (re-search-backward "\\(<[^<> \t\n]+>\\)" nil t)
3979         (let ((message-id (match-string 1)))
3980           (goto-char point)
3981           (set-buffer gnus-summary-buffer)
3982           (gnus-summary-refer-article message-id))
3983       (goto-char (point))
3984       (error "No references around point"))))
3985
3986 (defun gnus-article-show-summary ()
3987   "Reconfigure windows to show summary buffer."
3988   (interactive)
3989   (if (not (gnus-buffer-live-p gnus-summary-buffer))
3990       (error "There is no summary buffer for this article buffer")
3991     (gnus-article-set-globals)
3992     (gnus-configure-windows 'article)
3993     (gnus-summary-goto-subject gnus-current-article)
3994     (gnus-summary-position-point)))
3995
3996 (defun gnus-article-describe-briefly ()
3997   "Describe article mode commands briefly."
3998   (interactive)
3999   (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")))
4000
4001 (defun gnus-article-summary-command ()
4002   "Execute the last keystroke in the summary buffer."
4003   (interactive)
4004   (let ((obuf (current-buffer))
4005         (owin (current-window-configuration))
4006         func)
4007     (switch-to-buffer gnus-article-current-summary 'norecord)
4008     (setq func (lookup-key (current-local-map) (this-command-keys)))
4009     (call-interactively func)
4010     (set-buffer obuf)
4011     (set-window-configuration owin)
4012     (set-window-point (get-buffer-window (current-buffer)) (point))))
4013
4014 (defun gnus-article-summary-command-nosave ()
4015   "Execute the last keystroke in the summary buffer."
4016   (interactive)
4017   (let (func)
4018     (pop-to-buffer gnus-article-current-summary 'norecord)
4019     (setq func (lookup-key (current-local-map) (this-command-keys)))
4020     (call-interactively func)))
4021
4022 (defun gnus-article-check-buffer ()
4023   "Beep if not in an article buffer."
4024   (unless (equal major-mode 'gnus-article-mode)
4025     (error "Command invoked outside of a Gnus article buffer")))
4026
4027 (defun gnus-article-read-summary-keys (&optional arg key not-restore-window)
4028   "Read a summary buffer key sequence and execute it from the article buffer."
4029   (interactive "P")
4030   (gnus-article-check-buffer)
4031   (let ((nosaves
4032          '("q" "Q"  "c" "r" "R" "\C-c\C-f" "m"  "a" "f" "F"
4033            "Zc" "ZC" "ZE" "ZQ" "ZZ" "Zn" "ZR" "ZG" "ZN" "ZP"
4034            "=" "^" "\M-^" "|"))
4035         (nosave-but-article
4036          '("A\r"))
4037         (nosave-in-article
4038          '("\C-d"))
4039         (up-to-top
4040          '("n" "Gn" "p" "Gp"))
4041         keys new-sum-point)
4042     (save-excursion
4043       (set-buffer gnus-article-current-summary)
4044       (let (gnus-pick-mode)
4045         (push (or key last-command-event) unread-command-events)
4046         (setq keys (if (featurep 'xemacs)
4047                        (events-to-keys (read-key-sequence nil))
4048                      (read-key-sequence nil)))))
4049
4050     (message "")
4051
4052     (if (or (member keys nosaves)
4053             (member keys nosave-but-article)
4054             (member keys nosave-in-article))
4055         (let (func)
4056           (save-window-excursion
4057             (pop-to-buffer gnus-article-current-summary 'norecord)
4058             ;; We disable the pick minor mode commands.
4059             (let (gnus-pick-mode)
4060               (setq func (lookup-key (current-local-map) keys))))
4061           (if (or (not func)
4062                   (numberp func))
4063               (ding)
4064             (unless (member keys nosave-in-article)
4065               (set-buffer gnus-article-current-summary))
4066             (call-interactively func)
4067             (setq new-sum-point (point)))
4068           (when (member keys nosave-but-article)
4069             (pop-to-buffer gnus-article-buffer 'norecord)))
4070       ;; These commands should restore window configuration.
4071       (let ((obuf (current-buffer))
4072             (owin (current-window-configuration))
4073             (opoint (point))
4074             (summary gnus-article-current-summary)
4075             func in-buffer selected)
4076         (if not-restore-window
4077             (pop-to-buffer summary 'norecord)
4078           (switch-to-buffer summary 'norecord))
4079         (setq in-buffer (current-buffer))
4080         ;; We disable the pick minor mode commands.
4081         (if (and (setq func (let (gnus-pick-mode)
4082                               (lookup-key (current-local-map) keys)))
4083                  (functionp func))
4084             (progn
4085               (call-interactively func)
4086               (setq new-sum-point (point))
4087               (when (eq in-buffer (current-buffer))
4088                 (setq selected (gnus-summary-select-article))
4089                 (set-buffer obuf)
4090                 (unless not-restore-window
4091                   (set-window-configuration owin))
4092                 (when (eq selected 'old)
4093                   (article-goto-body)
4094                   (set-window-start (get-buffer-window (current-buffer))
4095                                     1)
4096                   (set-window-point (get-buffer-window (current-buffer))
4097                                     (point)))
4098                 (let ((win (get-buffer-window gnus-article-current-summary)))
4099                   (when win
4100                     (set-window-point win new-sum-point))))    )
4101           (switch-to-buffer gnus-article-buffer)
4102           (ding))))))
4103
4104 (defun gnus-article-describe-key (key)
4105   "Display documentation of the function invoked by KEY.  KEY is a string."
4106   (interactive "kDescribe key: ")
4107   (gnus-article-check-buffer)
4108   (if (eq (key-binding key) 'gnus-article-read-summary-keys)
4109       (save-excursion
4110         (set-buffer gnus-article-current-summary)
4111         (let (gnus-pick-mode)
4112           (push (elt key 0) unread-command-events)
4113           (setq key (if (featurep 'xemacs)
4114                         (events-to-keys (read-key-sequence "Describe key: "))
4115                       (read-key-sequence "Describe key: "))))
4116         (describe-key key))
4117     (describe-key key)))
4118
4119 (defun gnus-article-describe-key-briefly (key &optional insert)
4120   "Display documentation of the function invoked by KEY.  KEY is a string."
4121   (interactive "kDescribe key: \nP")
4122   (gnus-article-check-buffer)
4123   (if (eq (key-binding key) 'gnus-article-read-summary-keys)
4124       (save-excursion
4125         (set-buffer gnus-article-current-summary)
4126         (let (gnus-pick-mode)
4127           (push (elt key 0) unread-command-events)
4128           (setq key (if (featurep 'xemacs)
4129                         (events-to-keys (read-key-sequence "Describe key: "))
4130                       (read-key-sequence "Describe key: "))))
4131         (describe-key-briefly key insert))
4132     (describe-key-briefly key insert)))
4133
4134 (defun gnus-article-hide (&optional arg force)
4135   "Hide all the gruft in the current article.
4136 This means that PGP stuff, signatures, cited text and (some)
4137 headers will be hidden.
4138 If given a prefix, show the hidden text instead."
4139   (interactive (append (gnus-article-hidden-arg) (list 'force)))
4140   (gnus-article-hide-headers arg)
4141   (gnus-article-hide-list-identifiers arg)
4142   (gnus-article-hide-pgp arg)
4143   (gnus-article-hide-citation-maybe arg force)
4144   (gnus-article-hide-signature arg))
4145
4146 (defun gnus-article-maybe-highlight ()
4147   "Do some article highlighting if article highlighting is requested."
4148   (when (gnus-visual-p 'article-highlight 'highlight)
4149     (gnus-article-highlight-some)))
4150
4151 (defun gnus-check-group-server ()
4152   ;; Make sure the connection to the server is alive.
4153   (unless (gnus-server-opened
4154            (gnus-find-method-for-group gnus-newsgroup-name))
4155     (gnus-check-server (gnus-find-method-for-group gnus-newsgroup-name))
4156     (gnus-request-group gnus-newsgroup-name t)))
4157
4158 (defun gnus-request-article-this-buffer (article group)
4159   "Get an article and insert it into this buffer."
4160   (let (do-update-line sparse-header)
4161     (prog1
4162         (save-excursion
4163           (erase-buffer)
4164           (gnus-kill-all-overlays)
4165           (setq group (or group gnus-newsgroup-name))
4166
4167           ;; Using `gnus-request-article' directly will insert the article into
4168           ;; `nntp-server-buffer' - so we'll save some time by not having to
4169           ;; copy it from the server buffer into the article buffer.
4170
4171           ;; We only request an article by message-id when we do not have the
4172           ;; headers for it, so we'll have to get those.
4173           (when (stringp article)
4174             (gnus-read-header article))
4175
4176           ;; If the article number is negative, that means that this article
4177           ;; doesn't belong in this newsgroup (possibly), so we find its
4178           ;; message-id and request it by id instead of number.
4179           (when (and (numberp article)
4180                      gnus-summary-buffer
4181                      (get-buffer gnus-summary-buffer)
4182                      (gnus-buffer-exists-p gnus-summary-buffer))
4183             (save-excursion
4184               (set-buffer gnus-summary-buffer)
4185               (let ((header (gnus-summary-article-header article)))
4186                 (when (< article 0)
4187                   (cond
4188                    ((memq article gnus-newsgroup-sparse)
4189                     ;; This is a sparse gap article.
4190                     (setq do-update-line article)
4191                     (setq article (mail-header-id header))
4192                     (setq sparse-header (gnus-read-header article))
4193                     (setq gnus-newsgroup-sparse
4194                           (delq article gnus-newsgroup-sparse)))
4195                    ((vectorp header)
4196                     ;; It's a real article.
4197                     (setq article (mail-header-id header)))
4198                    (t
4199                     ;; It is an extracted pseudo-article.
4200                     (setq article 'pseudo)
4201                     (gnus-request-pseudo-article header))))
4202
4203                 (let ((method (gnus-find-method-for-group
4204                                gnus-newsgroup-name)))
4205                   (when (and (eq (car method) 'nneething)
4206                              (vectorp header))
4207                     (let ((dir (expand-file-name
4208                                 (mail-header-subject header)
4209                                 (file-name-as-directory
4210                                  (or (cadr (assq 'nneething-address method))
4211                                      (nth 1 method))))))
4212                       (when (file-directory-p dir)
4213                         (setq article 'nneething)
4214                         (gnus-group-enter-directory dir))))))))
4215
4216           (cond
4217            ;; Refuse to select canceled articles.
4218            ((and (numberp article)
4219                  gnus-summary-buffer
4220                  (get-buffer gnus-summary-buffer)
4221                  (gnus-buffer-exists-p gnus-summary-buffer)
4222                  (eq (cdr (save-excursion
4223                             (set-buffer gnus-summary-buffer)
4224                             (assq article gnus-newsgroup-reads)))
4225                      gnus-canceled-mark))
4226             nil)
4227            ;; We first check `gnus-original-article-buffer'.
4228            ((and (get-buffer gnus-original-article-buffer)
4229                  (numberp article)
4230                  (save-excursion
4231                    (set-buffer gnus-original-article-buffer)
4232                    (and (equal (car gnus-original-article) group)
4233                         (eq (cdr gnus-original-article) article))))
4234             (insert-buffer-substring gnus-original-article-buffer)
4235             'article)
4236            ;; Check the backlog.
4237            ((and gnus-keep-backlog
4238                  (gnus-backlog-request-article group article (current-buffer)))
4239             'article)
4240            ;; Check asynchronous pre-fetch.
4241            ((gnus-async-request-fetched-article group article (current-buffer))
4242             (gnus-async-prefetch-next group article gnus-summary-buffer)
4243             (when (and (numberp article) gnus-keep-backlog)
4244               (gnus-backlog-enter-article group article (current-buffer)))
4245             'article)
4246            ;; Check the cache.
4247            ((and gnus-use-cache
4248                  (numberp article)
4249                  (gnus-cache-request-article article group))
4250             'article)
4251            ;; Get the article and put into the article buffer.
4252            ((or (stringp article)
4253                 (numberp article))
4254             (let ((gnus-override-method gnus-override-method)
4255                   (methods (and (stringp article)
4256                                 gnus-refer-article-method))
4257                   result
4258                   (buffer-read-only nil))
4259               (if (or (not (listp methods))
4260                       (and (symbolp (car methods))
4261                            (assq (car methods) nnoo-definition-alist)))
4262                   (setq methods (list methods)))
4263               (when (and (null gnus-override-method)
4264                          methods)
4265                 (setq gnus-override-method (pop methods)))
4266               (while (not result)
4267                 (when (eq gnus-override-method 'current)
4268                   (setq gnus-override-method gnus-current-select-method))
4269                 (erase-buffer)
4270                 (gnus-kill-all-overlays)
4271                 (let ((gnus-newsgroup-name group))
4272                   (gnus-check-group-server))
4273                 (when (gnus-request-article article group (current-buffer))
4274                   (when (numberp article)
4275                     (gnus-async-prefetch-next group article
4276                                               gnus-summary-buffer)
4277                     (when gnus-keep-backlog
4278                       (gnus-backlog-enter-article
4279                        group article (current-buffer))))
4280                   (setq result 'article))
4281                 (if (not result)
4282                     (if methods
4283                         (setq gnus-override-method (pop methods))
4284                       (setq result 'done))))
4285               (and (eq result 'article) 'article)))
4286            ;; It was a pseudo.
4287            (t article)))
4288
4289       ;; Associate this article with the current summary buffer.
4290       (setq gnus-article-current-summary gnus-summary-buffer)
4291
4292       ;; Take the article from the original article buffer
4293       ;; and place it in the buffer it's supposed to be in.
4294       (when (and (get-buffer gnus-article-buffer)
4295                  (equal (buffer-name (current-buffer))
4296                         (buffer-name (get-buffer gnus-article-buffer))))
4297         (save-excursion
4298           (if (get-buffer gnus-original-article-buffer)
4299               (set-buffer gnus-original-article-buffer)
4300             (set-buffer (gnus-get-buffer-create gnus-original-article-buffer))
4301             (buffer-disable-undo)
4302             (setq major-mode 'gnus-original-article-mode)
4303             (setq buffer-read-only t))
4304           (let (buffer-read-only)
4305             (erase-buffer)
4306             (insert-buffer-substring gnus-article-buffer))
4307           (setq gnus-original-article (cons group article)))
4308
4309         ;; Decode charsets.
4310         (run-hooks 'gnus-article-decode-hook)
4311         ;; Mark article as decoded or not.
4312         (setq gnus-article-decoded-p gnus-article-decode-hook))
4313
4314       ;; Update sparse articles.
4315       (when (and do-update-line
4316                  (or (numberp article)
4317                      (stringp article)))
4318         (let ((buf (current-buffer)))
4319           (set-buffer gnus-summary-buffer)
4320           (gnus-summary-update-article do-update-line sparse-header)
4321           (gnus-summary-goto-subject do-update-line nil t)
4322           (set-window-point (get-buffer-window (current-buffer) t)
4323                             (point))
4324           (set-buffer buf))))))
4325
4326 ;;;
4327 ;;; Article editing
4328 ;;;
4329
4330 (defcustom gnus-article-edit-mode-hook nil
4331   "Hook run in article edit mode buffers."
4332   :group 'gnus-article-various
4333   :type 'hook)
4334
4335 (defvar gnus-article-edit-done-function nil)
4336
4337 (defvar gnus-article-edit-mode-map nil)
4338
4339 ;; Should we be using derived.el for this?
4340 (unless gnus-article-edit-mode-map
4341   (setq gnus-article-edit-mode-map (make-sparse-keymap))
4342   (set-keymap-parent gnus-article-edit-mode-map text-mode-map)
4343
4344   (gnus-define-keys gnus-article-edit-mode-map
4345     "\C-c\C-c" gnus-article-edit-done
4346     "\C-c\C-k" gnus-article-edit-exit)
4347
4348   (gnus-define-keys (gnus-article-edit-wash-map
4349                      "\C-c\C-w" gnus-article-edit-mode-map)
4350     "f" gnus-article-edit-full-stops))
4351
4352 (defun gnus-article-edit-mode ()
4353   "Major mode for editing articles.
4354 This is an extended text-mode.
4355
4356 \\{gnus-article-edit-mode-map}"
4357   (interactive)
4358   (setq major-mode 'gnus-article-edit-mode)
4359   (setq mode-name "Article Edit")
4360   (use-local-map gnus-article-edit-mode-map)
4361   (make-local-variable 'gnus-article-edit-done-function)
4362   (make-local-variable 'gnus-prev-winconf)
4363   (setq buffer-read-only nil)
4364   (buffer-enable-undo)
4365   (widen)
4366   (gnus-run-hooks 'text-mode-hook 'gnus-article-edit-mode-hook))
4367
4368 (defun gnus-article-edit (&optional force)
4369   "Edit the current article.
4370 This will have permanent effect only in mail groups.
4371 If FORCE is non-nil, allow editing of articles even in read-only
4372 groups."
4373   (interactive "P")
4374   (when (and (not force)
4375              (gnus-group-read-only-p))
4376     (error "The current newsgroup does not support article editing"))
4377   (gnus-article-date-original)
4378   (gnus-article-edit-article
4379    'ignore
4380    `(lambda (no-highlight)
4381       'ignore
4382       (gnus-summary-edit-article-done
4383        ,(or (mail-header-references gnus-current-headers) "")
4384        ,(gnus-group-read-only-p) ,gnus-summary-buffer no-highlight))))
4385
4386 (defun gnus-article-edit-article (start-func exit-func)
4387   "Start editing the contents of the current article buffer."
4388   (let ((winconf (current-window-configuration)))
4389     (set-buffer gnus-article-buffer)
4390     (gnus-article-edit-mode)
4391     (funcall start-func)
4392     (gnus-configure-windows 'edit-article)
4393     (setq gnus-article-edit-done-function exit-func)
4394     (setq gnus-prev-winconf winconf)
4395     (gnus-message 6 "C-c C-c to end edits")))
4396
4397 (defun gnus-article-edit-done (&optional arg)
4398   "Update the article edits and exit."
4399   (interactive "P")
4400   (let ((func gnus-article-edit-done-function)
4401         (buf (current-buffer))
4402         (start (window-start)))
4403     (gnus-article-edit-exit)
4404     (save-excursion
4405       (set-buffer buf)
4406       (let ((buffer-read-only nil))
4407         (funcall func arg))
4408       ;; The cache and backlog have to be flushed somewhat.
4409       (when gnus-keep-backlog
4410         (gnus-backlog-remove-article
4411          (car gnus-article-current) (cdr gnus-article-current)))
4412       ;; Flush original article as well.
4413       (save-excursion
4414         (when (get-buffer gnus-original-article-buffer)
4415           (set-buffer gnus-original-article-buffer)
4416           (setq gnus-original-article nil)))
4417       (when gnus-use-cache
4418         (gnus-cache-update-article
4419          (car gnus-article-current) (cdr gnus-article-current))))
4420     (set-buffer buf)
4421     (set-window-start (get-buffer-window buf) start)
4422     (set-window-point (get-buffer-window buf) (point))))
4423
4424 (defun gnus-article-edit-exit ()
4425   "Exit the article editing without updating."
4426   (interactive)
4427   ;; We remove all text props from the article buffer.
4428   (let ((buf (buffer-substring-no-properties (point-min) (point-max)))
4429         (curbuf (current-buffer))
4430         (p (point))
4431         (window-start (window-start)))
4432     (erase-buffer)
4433     (insert buf)
4434     (let ((winconf gnus-prev-winconf))
4435       (gnus-article-mode)
4436       (set-window-configuration winconf)
4437       ;; Tippy-toe some to make sure that point remains where it was.
4438       (save-current-buffer
4439         (set-buffer curbuf)
4440         (set-window-start (get-buffer-window (current-buffer)) window-start)
4441         (goto-char p)))))
4442
4443 (defun gnus-article-edit-full-stops ()
4444   "Interactively repair spacing at end of sentences."
4445   (interactive)
4446   (save-excursion
4447     (goto-char (point-min))
4448     (search-forward-regexp "^$" nil t)
4449     (let ((case-fold-search nil))
4450       (query-replace-regexp "\\([.!?][])}]* \\)\\([[({A-Z]\\)" "\\1 \\2"))))
4451
4452 ;;;
4453 ;;; Article highlights
4454 ;;;
4455
4456 ;; Written by Per Abrahamsen <abraham@iesd.auc.dk>.
4457
4458 ;;; Internal Variables:
4459
4460 (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\\)\\)"
4461   "Regular expression that matches URLs."
4462   :group 'gnus-article-buttons
4463   :type 'regexp)
4464
4465 (defcustom gnus-button-alist
4466   `(("<\\(url:[>\n\t ]*?\\)?news:[>\n\t ]*\\([^>\n\t ]*@[^>\n\t ]*\\)>"
4467      0 t gnus-button-message-id 2)
4468     ("\\bnews:\\([^>\n\t ]*@[^>)!;:,\n\t ]*\\)" 0 t gnus-button-message-id 1)
4469     ("\\(\\b<\\(url:[>\n\t ]*\\)?news:[>\n\t ]*\\(//\\)?\\([^>\n\t ]*\\)>\\)"
4470      1 t
4471      gnus-button-fetch-group 4)
4472     ("\\bnews:\\(//\\)?\\([^'\">\n\t ]+\\)" 0 t gnus-button-fetch-group 2)
4473     ("\\bin\\( +article\\| +message\\)? +\\(<\\([^\n @<>]+@[^\n @<>]+\\)>\\)" 2
4474      t gnus-button-message-id 3)
4475     ("\\(<URL: *\\)mailto: *\\([^> \n\t]+\\)>" 0 t gnus-url-mailto 2)
4476     ("mailto:\\([-a-zA-Z.@_+0-9%]+\\)" 0 t gnus-url-mailto 1)
4477     ("\\bmailto:\\([^ \n\t]+\\)" 0 t gnus-url-mailto 1)
4478     ;; This is how URLs _should_ be embedded in text...
4479     ("<URL: *\\([^<>]*\\)>" 0 t gnus-button-embedded-url 1)
4480     ;; Raw URLs.
4481     (,gnus-button-url-regexp 0 t browse-url 0))
4482   "*Alist of regexps matching buttons in article bodies.
4483
4484 Each entry has the form (REGEXP BUTTON FORM CALLBACK PAR...), where
4485 REGEXP: is the string matching text around the button,
4486 BUTTON: is the number of the regexp grouping actually matching the button,
4487 FORM: is a lisp expression which must eval to true for the button to
4488 be added,
4489 CALLBACK: is the function to call when the user push this button, and each
4490 PAR: is a number of a regexp grouping whose text will be passed to CALLBACK.
4491
4492 CALLBACK can also be a variable, in that case the value of that
4493 variable it the real callback function."
4494   :group 'gnus-article-buttons
4495   :type '(repeat (list regexp
4496                        (integer :tag "Button")
4497                        (sexp :tag "Form")
4498                        (function :tag "Callback")
4499                        (repeat :tag "Par"
4500                                :inline t
4501                                (integer :tag "Regexp group")))))
4502
4503 (defcustom gnus-header-button-alist
4504   `(("^\\(References\\|Message-I[Dd]\\):" "<[^>]+>"
4505      0 t gnus-button-message-id 0)
4506     ("^\\(From\\|Reply-To\\):" ": *\\(.+\\)$" 1 t gnus-button-reply 1)
4507     ("^\\(Cc\\|To\\):" "[^ \t\n<>,()\"]+@[^ \t\n<>,()\"]+"
4508      0 t gnus-button-mailto 0)
4509     ("^X-[Uu][Rr][Ll]:" ,gnus-button-url-regexp 0 t browse-url 0)
4510     ("^Subject:" ,gnus-button-url-regexp 0 t browse-url 0)
4511     ("^[^:]+:" ,gnus-button-url-regexp 0 t browse-url 0)
4512     ("^[^:]+:" "\\(<\\(url: \\)?news:\\([^>\n ]*\\)>\\)" 1 t
4513      gnus-button-message-id 3))
4514   "*Alist of headers and regexps to match buttons in article heads.
4515
4516 This alist is very similar to `gnus-button-alist', except that each
4517 alist has an additional HEADER element first in each entry:
4518
4519 \(HEADER REGEXP BUTTON FORM CALLBACK PAR)
4520
4521 HEADER is a regexp to match a header.  For a fuller explanation, see
4522 `gnus-button-alist'."
4523   :group 'gnus-article-buttons
4524   :group 'gnus-article-headers
4525   :type '(repeat (list (regexp :tag "Header")
4526                        regexp
4527                        (integer :tag "Button")
4528                        (sexp :tag "Form")
4529                        (function :tag "Callback")
4530                        (repeat :tag "Par"
4531                                :inline t
4532                                (integer :tag "Regexp group")))))
4533
4534 (defvar gnus-button-regexp nil)
4535 (defvar gnus-button-marker-list nil)
4536 ;; Regexp matching any of the regexps from `gnus-button-alist'.
4537
4538 (defvar gnus-button-last nil)
4539 ;; The value of `gnus-button-alist' when `gnus-button-regexp' was build.
4540
4541 ;;; Commands:
4542
4543 (defun gnus-article-push-button (event)
4544   "Check text under the mouse pointer for a callback function.
4545 If the text under the mouse pointer has a `gnus-callback' property,
4546 call it with the value of the `gnus-data' text property."
4547   (interactive "e")
4548   (set-buffer (window-buffer (posn-window (event-start event))))
4549   (let* ((pos (posn-point (event-start event)))
4550          (data (get-text-property pos 'gnus-data))
4551          (fun (get-text-property pos 'gnus-callback)))
4552     (goto-char pos)
4553     (when fun
4554       (funcall fun data))))
4555
4556 (defun gnus-article-press-button ()
4557   "Check text at point for a callback function.
4558 If the text at point has a `gnus-callback' property,
4559 call it with the value of the `gnus-data' text property."
4560   (interactive)
4561   (let* ((data (get-text-property (point) 'gnus-data))
4562          (fun (get-text-property (point) 'gnus-callback)))
4563     (when fun
4564       (funcall fun data))))
4565
4566 (defun gnus-article-highlight (&optional force)
4567   "Highlight current article.
4568 This function calls `gnus-article-highlight-headers',
4569 `gnus-article-highlight-citation',
4570 `gnus-article-highlight-signature', and `gnus-article-add-buttons' to
4571 do the highlighting.  See the documentation for those functions."
4572   (interactive (list 'force))
4573   (gnus-article-highlight-headers)
4574   (gnus-article-highlight-citation force)
4575   (gnus-article-highlight-signature)
4576   (gnus-article-add-buttons force)
4577   (gnus-article-add-buttons-to-head))
4578
4579 (defun gnus-article-highlight-some (&optional force)
4580   "Highlight current article.
4581 This function calls `gnus-article-highlight-headers',
4582 `gnus-article-highlight-signature', and `gnus-article-add-buttons' to
4583 do the highlighting.  See the documentation for those functions."
4584   (interactive (list 'force))
4585   (gnus-article-highlight-headers)
4586   (gnus-article-highlight-signature)
4587   (gnus-article-add-buttons))
4588
4589 (defun gnus-article-highlight-headers ()
4590   "Highlight article headers as specified by `gnus-header-face-alist'."
4591   (interactive)
4592   (save-excursion
4593     (set-buffer gnus-article-buffer)
4594     (save-restriction
4595       (let ((alist gnus-header-face-alist)
4596             (buffer-read-only nil)
4597             (case-fold-search t)
4598             (inhibit-point-motion-hooks t)
4599             entry regexp header-face field-face from hpoints fpoints)
4600         (article-narrow-to-head)
4601         (while (setq entry (pop alist))
4602           (goto-char (point-min))
4603           (setq regexp (concat "^\\("
4604                                (if (string-equal "" (nth 0 entry))
4605                                    "[^\t ]"
4606                                  (nth 0 entry))
4607                                "\\)")
4608                 header-face (nth 1 entry)
4609                 field-face (nth 2 entry))
4610           (while (and (re-search-forward regexp nil t)
4611                       (not (eobp)))
4612             (beginning-of-line)
4613             (setq from (point))
4614             (unless (search-forward ":" nil t)
4615               (forward-char 1))
4616             (when (and header-face
4617                        (not (memq (point) hpoints)))
4618               (push (point) hpoints)
4619               (gnus-put-text-property from (point) 'face header-face))
4620             (when (and field-face
4621                        (not (memq (setq from (point)) fpoints)))
4622               (push from fpoints)
4623               (if (re-search-forward "^[^ \t]" nil t)
4624                   (forward-char -2)
4625                 (goto-char (point-max)))
4626               (gnus-put-text-property from (point) 'face field-face))))))))
4627
4628 (defun gnus-article-highlight-signature ()
4629   "Highlight the signature in an article.
4630 It does this by highlighting everything after
4631 `gnus-signature-separator' using `gnus-signature-face'."
4632   (interactive)
4633   (save-excursion
4634     (set-buffer gnus-article-buffer)
4635     (let ((buffer-read-only nil)
4636           (inhibit-point-motion-hooks t))
4637       (save-restriction
4638         (when (and gnus-signature-face
4639                    (gnus-article-narrow-to-signature))
4640           (gnus-overlay-put (gnus-make-overlay (point-min) (point-max))
4641                             'face gnus-signature-face)
4642           (widen)
4643           (gnus-article-search-signature)
4644           (let ((start (match-beginning 0))
4645                 (end (set-marker (make-marker) (1+ (match-end 0)))))
4646             (gnus-article-add-button start (1- end) 'gnus-signature-toggle
4647                                      end)))))))
4648
4649 (defun gnus-button-in-region-p (b e prop)
4650   "Say whether PROP exists in the region."
4651   (text-property-not-all b e prop nil))
4652
4653 (defun gnus-article-add-buttons (&optional force)
4654   "Find external references in the article and make buttons of them.
4655 \"External references\" are things like Message-IDs and URLs, as
4656 specified by `gnus-button-alist'."
4657   (interactive (list 'force))
4658   (save-excursion
4659     (set-buffer gnus-article-buffer)
4660     (let ((buffer-read-only nil)
4661           (inhibit-point-motion-hooks t)
4662           (case-fold-search t)
4663           (alist gnus-button-alist)
4664           beg entry regexp)
4665       ;; Remove all old markers.
4666       (let (marker entry new-list)
4667         (while (setq marker (pop gnus-button-marker-list))
4668           (if (or (< marker (point-min)) (>= marker (point-max)))
4669               (push marker new-list)
4670             (goto-char marker)
4671             (when (setq entry (gnus-button-entry))
4672               (put-text-property (match-beginning (nth 1 entry))
4673                                  (match-end (nth 1 entry))
4674                                  'gnus-callback nil))
4675             (set-marker marker nil)))
4676         (setq gnus-button-marker-list new-list))
4677       ;; We skip the headers.
4678       (article-goto-body)
4679       (setq beg (point))
4680       (while (setq entry (pop alist))
4681         (setq regexp (car entry))
4682         (goto-char beg)
4683         (while (re-search-forward regexp nil t)
4684           (let* ((start (and entry (match-beginning (nth 1 entry))))
4685                  (end (and entry (match-end (nth 1 entry))))
4686                  (from (match-beginning 0)))
4687             (when (and (or (eq t (nth 2 entry))
4688                            (eval (nth 2 entry)))
4689                        (not (gnus-button-in-region-p
4690                              start end 'gnus-callback)))
4691               ;; That optional form returned non-nil, so we add the
4692               ;; button.
4693               (gnus-article-add-button
4694                start end 'gnus-button-push
4695                (car (push (set-marker (make-marker) from)
4696                           gnus-button-marker-list))))))))))
4697
4698 ;; Add buttons to the head of an article.
4699 (defun gnus-article-add-buttons-to-head ()
4700   "Add buttons to the head of the article."
4701   (interactive)
4702   (save-excursion
4703     (set-buffer gnus-article-buffer)
4704     (save-restriction
4705       (let ((buffer-read-only nil)
4706             (inhibit-point-motion-hooks t)
4707             (case-fold-search t)
4708             (alist gnus-header-button-alist)
4709             entry beg end)
4710         (article-narrow-to-head)
4711         (while alist
4712           ;; Each alist entry.
4713           (setq entry (car alist)
4714                 alist (cdr alist))
4715           (goto-char (point-min))
4716           (while (re-search-forward (car entry) nil t)
4717             ;; Each header matching the entry.
4718             (setq beg (match-beginning 0))
4719             (setq end (or (and (re-search-forward "^[^ \t]" nil t)
4720                                (match-beginning 0))
4721                           (point-max)))
4722             (goto-char beg)
4723             (while (re-search-forward (nth 1 entry) end t)
4724               ;; Each match within a header.
4725               (let* ((entry (cdr entry))
4726                      (start (match-beginning (nth 1 entry)))
4727                      (end (match-end (nth 1 entry)))
4728                      (form (nth 2 entry)))
4729                 (goto-char (match-end 0))
4730                 (when (eval form)
4731                   (gnus-article-add-button
4732                    start end (nth 3 entry)
4733                    (buffer-substring (match-beginning (nth 4 entry))
4734                                      (match-end (nth 4 entry)))))))
4735             (goto-char end)))))))
4736
4737 ;;; External functions:
4738
4739 (defun gnus-article-add-button (from to fun &optional data)
4740   "Create a button between FROM and TO with callback FUN and data DATA."
4741   (when gnus-article-button-face
4742     (gnus-overlay-put (gnus-make-overlay from to)
4743                       'face gnus-article-button-face))
4744   (gnus-add-text-properties
4745    from to
4746    (nconc (and gnus-article-mouse-face
4747                (list gnus-mouse-face-prop gnus-article-mouse-face))
4748           (list 'gnus-callback fun)
4749           (and data (list 'gnus-data data))))
4750   (widget-convert-button 'link from to :action 'gnus-widget-press-button
4751                          :button-keymap gnus-widget-button-keymap))
4752
4753 ;;; Internal functions:
4754
4755 (defun gnus-article-set-globals ()
4756   (save-excursion
4757     (set-buffer gnus-summary-buffer)
4758     (gnus-set-global-variables)))
4759
4760 (defun gnus-signature-toggle (end)
4761   (save-excursion
4762     (set-buffer gnus-article-buffer)
4763     (let ((buffer-read-only nil)
4764           (inhibit-point-motion-hooks t))
4765       (if (text-property-any end (point-max) 'article-type 'signature)
4766           (gnus-remove-text-properties-when
4767            'article-type 'signature end (point-max)
4768            (cons 'article-type (cons 'signature
4769                                      gnus-hidden-properties)))
4770         (gnus-add-text-properties-when
4771          'article-type nil end (point-max)
4772          (cons 'article-type (cons 'signature
4773                                    gnus-hidden-properties)))))))
4774
4775 (defun gnus-button-entry ()
4776   ;; Return the first entry in `gnus-button-alist' matching this place.
4777   (let ((alist gnus-button-alist)
4778         (entry nil))
4779     (while alist
4780       (setq entry (pop alist))
4781       (if (looking-at (car entry))
4782           (setq alist nil)
4783         (setq entry nil)))
4784     entry))
4785
4786 (defun gnus-button-push (marker)
4787   ;; Push button starting at MARKER.
4788   (save-excursion
4789     (goto-char marker)
4790     (let* ((entry (gnus-button-entry))
4791            (inhibit-point-motion-hooks t)
4792            (fun (nth 3 entry))
4793            (args (mapcar (lambda (group)
4794                            (let ((string (match-string group)))
4795                              (gnus-set-text-properties
4796                               0 (length string) nil string)
4797                              string))
4798                          (nthcdr 4 entry))))
4799       (cond
4800        ((fboundp fun)
4801         (apply fun args))
4802        ((and (boundp fun)
4803              (fboundp (symbol-value fun)))
4804         (apply (symbol-value fun) args))
4805        (t
4806         (gnus-message 1 "You must define `%S' to use this button"
4807                       (cons fun args)))))))
4808
4809 (defun gnus-button-message-id (message-id)
4810   "Fetch MESSAGE-ID."
4811   (save-excursion
4812     (set-buffer gnus-summary-buffer)
4813     (gnus-summary-refer-article message-id)))
4814
4815 (defun gnus-button-fetch-group (address)
4816   "Fetch GROUP specified by ADDRESS."
4817   (if (not (string-match "[:/]" address))
4818       ;; This is just a simple group url.
4819       (gnus-group-read-ephemeral-group address gnus-select-method)
4820     (if (not (string-match "^\\([^:/]+\\)\\(:\\([^/]+\\)/\\)?\\(.*\\)$"
4821                            address))
4822         (error "Can't parse %s" address)
4823       (gnus-group-read-ephemeral-group
4824        (match-string 4 address)
4825        `(nntp ,(match-string 1 address)
4826               (nntp-address ,(match-string 1 address))
4827               (nntp-port-number ,(if (match-end 3)
4828                                      (match-string 3 address)
4829                                    "nntp")))))))
4830
4831 (defun gnus-url-parse-query-string (query &optional downcase)
4832   (let (retval pairs cur key val)
4833     (setq pairs (split-string query "&"))
4834     (while pairs
4835       (setq cur (car pairs)
4836             pairs (cdr pairs))
4837       (if (not (string-match "=" cur))
4838           nil                           ; Grace
4839         (setq key (gnus-url-unhex-string (substring cur 0 (match-beginning 0)))
4840               val (gnus-url-unhex-string (substring cur (match-end 0) nil)))
4841         (if downcase
4842             (setq key (downcase key)))
4843         (setq cur (assoc key retval))
4844         (if cur
4845             (setcdr cur (cons val (cdr cur)))
4846           (setq retval (cons (list key val) retval)))))
4847     retval))
4848
4849 (defun gnus-url-unhex (x)
4850   (if (> x ?9)
4851       (if (>= x ?a)
4852           (+ 10 (- x ?a))
4853         (+ 10 (- x ?A)))
4854     (- x ?0)))
4855
4856 (defun gnus-url-unhex-string (str &optional allow-newlines)
4857   "Remove %XXX embedded spaces, etc in a url.
4858 If optional second argument ALLOW-NEWLINES is non-nil, then allow the
4859 decoding of carriage returns and line feeds in the string, which is normally
4860 forbidden in URL encoding."
4861   (setq str (or str ""))
4862   (let ((tmp "")
4863         (case-fold-search t))
4864     (while (string-match "%[0-9a-f][0-9a-f]" str)
4865       (let* ((start (match-beginning 0))
4866              (ch1 (gnus-url-unhex (elt str (+ start 1))))
4867              (code (+ (* 16 ch1)
4868                       (gnus-url-unhex (elt str (+ start 2))))))
4869         (setq tmp (concat
4870                    tmp (substring str 0 start)
4871                    (cond
4872                     (allow-newlines
4873                      (char-to-string code))
4874                     ((or (= code ?\n) (= code ?\r))
4875                      " ")
4876                     (t (char-to-string code))))
4877               str (substring str (match-end 0)))))
4878     (setq tmp (concat tmp str))
4879     tmp))
4880
4881 (defun gnus-url-mailto (url)
4882   ;; Send mail to someone
4883   (when (string-match "mailto:/*\\(.*\\)" url)
4884     (setq url (substring url (match-beginning 1) nil)))
4885   (let (to args subject func)
4886     (if (string-match (regexp-quote "?") url)
4887         (setq to (gnus-url-unhex-string (substring url 0 (match-beginning 0)))
4888               args (gnus-url-parse-query-string
4889                     (substring url (match-end 0) nil) t))
4890       (setq to (gnus-url-unhex-string url)))
4891     (setq args (cons (list "to" to) args)
4892           subject (cdr-safe (assoc "subject" args)))
4893     (message-mail)
4894     (while args
4895       (setq func (intern-soft (concat "message-goto-" (downcase (caar args)))))
4896       (if (fboundp func)
4897           (funcall func)
4898         (message-position-on-field (caar args)))
4899       (insert (mapconcat 'identity (cdar args) ", "))
4900       (setq args (cdr args)))
4901     (if subject
4902         (message-goto-body)
4903       (message-goto-subject))))
4904
4905 (defun gnus-button-mailto (address)
4906   "Mail to ADDRESS."
4907   (set-buffer (gnus-copy-article-buffer))
4908   (message-reply address))
4909
4910 (defalias 'gnus-button-reply 'message-reply)
4911
4912 (defun gnus-button-embedded-url (address)
4913   "Activate ADDRESS with `browse-url'."
4914   (browse-url (gnus-strip-whitespace address)))
4915
4916 ;;; Next/prev buttons in the article buffer.
4917
4918 (defvar gnus-next-page-line-format "%{%(Next page...%)%}\n")
4919 (defvar gnus-prev-page-line-format "%{%(Previous page...%)%}\n")
4920
4921 (defvar gnus-prev-page-map nil)
4922 (unless gnus-prev-page-map
4923   (setq gnus-prev-page-map (make-sparse-keymap))
4924   (define-key gnus-prev-page-map gnus-mouse-2 'gnus-button-prev-page)
4925   (define-key gnus-prev-page-map "\r" 'gnus-button-prev-page))
4926
4927 (defun gnus-insert-prev-page-button ()
4928   (let ((buffer-read-only nil))
4929     (gnus-eval-format
4930      gnus-prev-page-line-format nil
4931      `(gnus-prev t local-map ,gnus-prev-page-map
4932                  gnus-callback gnus-article-button-prev-page
4933                  article-type annotation))))
4934
4935 (defvar gnus-next-page-map nil)
4936 (unless gnus-next-page-map
4937   (setq gnus-next-page-map (make-keymap))
4938   (suppress-keymap gnus-prev-page-map)
4939   (define-key gnus-next-page-map gnus-mouse-2 'gnus-button-next-page)
4940   (define-key gnus-next-page-map "\r" 'gnus-button-next-page))
4941
4942 (defun gnus-button-next-page ()
4943   "Go to the next page."
4944   (interactive)
4945   (let ((win (selected-window)))
4946     (select-window (get-buffer-window gnus-article-buffer t))
4947     (gnus-article-next-page)
4948     (select-window win)))
4949
4950 (defun gnus-button-prev-page ()
4951   "Go to the prev page."
4952   (interactive)
4953   (let ((win (selected-window)))
4954     (select-window (get-buffer-window gnus-article-buffer t))
4955     (gnus-article-prev-page)
4956     (select-window win)))
4957
4958 (defun gnus-insert-next-page-button ()
4959   (let ((buffer-read-only nil))
4960     (gnus-eval-format gnus-next-page-line-format nil
4961                       `(gnus-next
4962                         t local-map ,gnus-next-page-map
4963                         gnus-callback gnus-article-button-next-page
4964                         article-type annotation))))
4965
4966 (defun gnus-article-button-next-page (arg)
4967   "Go to the next page."
4968   (interactive "P")
4969   (let ((win (selected-window)))
4970     (select-window (get-buffer-window gnus-article-buffer t))
4971     (gnus-article-next-page)
4972     (select-window win)))
4973
4974 (defun gnus-article-button-prev-page (arg)
4975   "Go to the prev page."
4976   (interactive "P")
4977   (let ((win (selected-window)))
4978     (select-window (get-buffer-window gnus-article-buffer t))
4979     (gnus-article-prev-page)
4980     (select-window win)))
4981
4982 (defvar gnus-decode-header-methods
4983   '(mail-decode-encoded-word-region)
4984   "List of methods used to decode headers.
4985
4986 This variable is a list of FUNCTION or (REGEXP . FUNCTION).  If item
4987 is FUNCTION, FUNCTION will be apply to all newsgroups.  If item is a
4988 (REGEXP . FUNCTION), FUNCTION will be only apply to thes newsgroups
4989 whose names match REGEXP.
4990
4991 For example:
4992 ((\"chinese\" . gnus-decode-encoded-word-region-by-guess)
4993  mail-decode-encoded-word-region
4994  (\"chinese\" . rfc1843-decode-region))
4995 ")
4996
4997 (defvar gnus-decode-header-methods-cache nil)
4998
4999 (defun gnus-multi-decode-header (start end)
5000   "Apply the functions from `gnus-encoded-word-methods' that match."
5001   (unless (and gnus-decode-header-methods-cache
5002                (eq gnus-newsgroup-name
5003                    (car gnus-decode-header-methods-cache)))
5004     (setq gnus-decode-header-methods-cache (list gnus-newsgroup-name))
5005     (mapcar (lambda (x)
5006               (if (symbolp x)
5007                   (nconc gnus-decode-header-methods-cache (list x))
5008                 (if (and gnus-newsgroup-name
5009                          (string-match (car x) gnus-newsgroup-name))
5010                     (nconc gnus-decode-header-methods-cache
5011                            (list (cdr x))))))
5012           gnus-decode-header-methods))
5013   (let ((xlist gnus-decode-header-methods-cache))
5014     (pop xlist)
5015     (save-restriction
5016       (narrow-to-region start end)
5017       (while xlist
5018         (funcall (pop xlist) (point-min) (point-max))))))
5019
5020 ;;;
5021 ;;; Treatment top-level handling.
5022 ;;;
5023
5024 (defun gnus-treat-article (condition &optional part-number total-parts type)
5025   (let ((length (- (point-max) (point-min)))
5026         (alist gnus-treatment-function-alist)
5027         (article-goto-body-goes-to-point-min-p t)
5028         (treated-type
5029          (or (not type)
5030              (catch 'found
5031                (let ((list gnus-article-treat-types))
5032                  (while list
5033                    (when (string-match (pop list) type)
5034                      (throw 'found t)))))))
5035         (highlightp (gnus-visual-p 'article-highlight 'highlight))
5036         val elem)
5037     (gnus-run-hooks 'gnus-part-display-hook)
5038     (while (setq elem (pop alist))
5039       (setq val
5040             (save-excursion
5041               (if (gnus-buffer-live-p gnus-summary-buffer)
5042                   (set-buffer gnus-summary-buffer))
5043               (symbol-value (car elem))))
5044       (when (and (or (consp val)
5045                      treated-type)
5046                  (gnus-treat-predicate val)
5047                  (or (not (get (car elem) 'highlight))
5048                      highlightp))
5049         (save-restriction
5050           (funcall (cadr elem)))))))
5051
5052 ;; Dynamic variables.
5053 (eval-when-compile
5054   (defvar part-number)
5055   (defvar total-parts)
5056   (defvar type)
5057   (defvar condition)
5058   (defvar length))
5059
5060 (defun gnus-treat-predicate (val)
5061   (cond
5062    ((null val)
5063     nil)
5064    ((and (listp val)
5065          (stringp (car val)))
5066     (apply 'gnus-or (mapcar `(lambda (s)
5067                                (string-match s ,(or gnus-newsgroup-name "")))
5068                             val)))
5069    ((listp val)
5070     (let ((pred (pop val)))
5071       (cond
5072        ((eq pred 'or)
5073         (apply 'gnus-or (mapcar 'gnus-treat-predicate val)))
5074        ((eq pred 'and)
5075         (apply 'gnus-and (mapcar 'gnus-treat-predicate val)))
5076        ((eq pred 'not)
5077         (not (gnus-treat-predicate (car val))))
5078        ((eq pred 'typep)
5079         (equal (car val) type))
5080        (t
5081         (error "%S is not a valid predicate" pred)))))
5082    (condition
5083     (eq condition val))
5084    ((eq val t)
5085     t)
5086    ((eq val 'head)
5087     nil)
5088    ((eq val 'last)
5089     (eq part-number total-parts))
5090    ((numberp val)
5091     (< length val))
5092    (t
5093     (error "%S is not a valid value" val))))
5094
5095 (defun gnus-article-encrypt-body (protocol &optional n)
5096   "Encrypt the article body."
5097   (interactive
5098    (list
5099     (or gnus-article-encrypt-protocol
5100         (completing-read "Encrypt protocol: "
5101                          gnus-article-encrypt-protocol-alist
5102                          nil t))
5103     current-prefix-arg))
5104   (let ((func (cdr (assoc protocol gnus-article-encrypt-protocol-alist))))
5105     (unless func
5106       (error (format "Can't find the encrypt protocol %s" protocol)))
5107     (if (equal gnus-newsgroup-name "nndraft:drafts")
5108         (error "Can't encrypt the article in group nndraft:drafts."))
5109     (if (equal gnus-newsgroup-name "nndraft:queue")
5110         (error "Don't encrypt the article in group nndraft:queue."))
5111     (gnus-summary-iterate n
5112       (save-excursion
5113         (set-buffer gnus-summary-buffer)
5114         (let ((mail-parse-charset gnus-newsgroup-charset)
5115               (mail-parse-ignored-charsets gnus-newsgroup-ignored-charsets)
5116               (summary-buffer gnus-summary-buffer)
5117               references point)
5118           (gnus-set-global-variables)
5119           (when (gnus-group-read-only-p)
5120             (error "The current newsgroup does not support article encrypt"))
5121           (gnus-summary-show-article t)
5122           (setq references
5123               (or (mail-header-references gnus-current-headers) ""))
5124           (set-buffer gnus-article-buffer)
5125           (let* ((buffer-read-only nil)
5126                  (headers
5127                   (mapcar (lambda (field)
5128                             (and (save-restriction
5129                                    (message-narrow-to-head)
5130                                    (goto-char (point-min))
5131                                    (search-forward field nil t))
5132                                  (prog2
5133                                      (message-narrow-to-field)
5134                                      (buffer-substring (point-min) (point-max))
5135                                    (delete-region (point-min) (point-max))
5136                                    (widen))))
5137                           '("Content-Type:" "Content-Transfer-Encoding:"
5138                             "Content-Disposition:"))))
5139             (message-narrow-to-head)
5140             (message-remove-header "MIME-Version")
5141             (goto-char (point-max))
5142             (setq point (point))
5143             (insert (apply 'concat headers))
5144             (widen)
5145             (narrow-to-region point (point-max))
5146             (let ((message-options message-options))
5147               (message-options-set 'message-sender user-mail-address)
5148               (message-options-set 'message-recipients user-mail-address)
5149               (message-options-set 'message-sign-encrypt 'not)
5150               (funcall func))
5151             (goto-char (point-min))
5152             (insert "MIME-Version: 1.0\n")
5153             (widen)
5154             (gnus-summary-edit-article-done
5155              references nil summary-buffer t))
5156           (when gnus-keep-backlog
5157             (gnus-backlog-remove-article
5158              (car gnus-article-current) (cdr gnus-article-current)))
5159           (save-excursion
5160             (when (get-buffer gnus-original-article-buffer)
5161               (set-buffer gnus-original-article-buffer)
5162               (setq gnus-original-article nil)))
5163           (when gnus-use-cache
5164             (gnus-cache-update-article
5165              (car gnus-article-current) (cdr gnus-article-current))))))))
5166
5167 (defvar gnus-mime-security-button-line-format "%{%([[%t:%i]%D]%)%}\n"
5168   "The following specs can be used:
5169 %t  The security MIME type
5170 %i  Additional info
5171 %d  Details
5172 %D  Details if button is pressed")
5173
5174 (defvar gnus-mime-security-button-end-line-format "%{%([[End of %t]%D]%)%}\n"
5175   "The following specs can be used:
5176 %t  The security MIME type
5177 %i  Additional info
5178 %d  Details
5179 %D  Details if button is pressed")
5180
5181 (defvar gnus-mime-security-button-line-format-alist
5182   '((?t gnus-tmp-type ?s)
5183     (?i gnus-tmp-info ?s)
5184     (?d gnus-tmp-details ?s)
5185     (?D gnus-tmp-pressed-details ?s)))
5186
5187 (defvar gnus-mime-security-button-map
5188   (let ((map (make-sparse-keymap)))
5189     (set-keymap-parent map gnus-article-mode-map)
5190     (define-key map gnus-mouse-2 'gnus-article-push-button)
5191     (define-key map "\r" 'gnus-article-press-button)
5192     map))
5193
5194 (defvar gnus-mime-security-details-buffer nil)
5195
5196 (defvar gnus-mime-security-button-pressed nil)
5197
5198 (defvar gnus-mime-security-show-details-inline t
5199   "If non-nil, show details in the article buffer.")
5200
5201 (defun gnus-mime-security-verify-or-decrypt (handle)
5202   (mm-remove-parts (cdr handle))
5203   (let ((region (mm-handle-multipart-ctl-parameter handle 'gnus-region))
5204         buffer-read-only)
5205     (when region
5206       (delete-region (car region) (cdr region))
5207       (set-marker (car region) nil)
5208       (set-marker (cdr region) nil)))
5209   (with-current-buffer (mm-handle-multipart-original-buffer handle)
5210     (let* ((mm-verify-option 'known)
5211            (mm-decrypt-option 'known)
5212            (nparts (mm-possibly-verify-or-decrypt (cdr handle) handle)))
5213       (unless (eq nparts (cdr handle))
5214         (mm-destroy-parts (cdr handle))
5215         (setcdr handle nparts))))
5216   (let ((point (point))
5217         buffer-read-only)
5218     (gnus-mime-display-security handle)
5219     (goto-char point)))
5220
5221 (defun gnus-mime-security-show-details (handle)
5222   (let ((details (mm-handle-multipart-ctl-parameter handle 'gnus-details)))
5223     (if details
5224         (if gnus-mime-security-show-details-inline
5225             (let ((gnus-mime-security-button-pressed t)
5226                   (gnus-mime-security-button-line-format
5227                    (get-text-property (point) 'gnus-line-format))
5228                 buffer-read-only)
5229               (forward-char -1)
5230               (while (eq (get-text-property (point) 'gnus-line-format)
5231                          gnus-mime-security-button-line-format)
5232                 (forward-char -1))
5233               (forward-char)
5234               (delete-region (point)
5235                              (or (text-property-not-all
5236                                   (point) (point-max)
5237                                 'gnus-line-format
5238                                 gnus-mime-security-button-line-format)
5239                                  (point-max)))
5240               (gnus-insert-mime-security-button handle))
5241           (if (gnus-buffer-live-p gnus-mime-security-details-buffer)
5242               (with-current-buffer gnus-mime-security-details-buffer
5243                 (erase-buffer)
5244                 t)
5245             (setq gnus-mime-security-details-buffer
5246                   (gnus-get-buffer-create "*MIME Security Details*")))
5247           (with-current-buffer gnus-mime-security-details-buffer
5248             (insert details)
5249             (goto-char (point-min)))
5250           (pop-to-buffer gnus-mime-security-details-buffer))
5251       (gnus-message 5 "No details."))))
5252
5253 (defun gnus-mime-security-press-button (handle)
5254   (if (mm-handle-multipart-ctl-parameter handle 'gnus-info)
5255       (gnus-mime-security-show-details handle)
5256     (gnus-mime-security-verify-or-decrypt handle)))
5257
5258 (defun gnus-insert-mime-security-button (handle &optional displayed)
5259   (let* ((protocol (mm-handle-multipart-ctl-parameter handle 'protocol))
5260          (gnus-tmp-type
5261           (concat
5262            (or (nth 2 (assoc protocol mm-verify-function-alist))
5263                (nth 2 (assoc protocol mm-decrypt-function-alist))
5264                "Unknown")
5265            (if (equal (car handle) "multipart/signed")
5266                " Signed" " Encrypted")
5267            " Part"))
5268          (gnus-tmp-info
5269           (or (mm-handle-multipart-ctl-parameter handle 'gnus-info)
5270               "Undecided"))
5271          (gnus-tmp-details
5272           (mm-handle-multipart-ctl-parameter handle 'gnus-details))
5273          gnus-tmp-pressed-details
5274          b e)
5275     (setq gnus-tmp-details
5276           (if gnus-tmp-details
5277               (concat "\n" gnus-tmp-details) ""))
5278     (setq gnus-tmp-pressed-details
5279           (if gnus-mime-security-button-pressed gnus-tmp-details ""))
5280     (unless (bolp)
5281       (insert "\n"))
5282     (setq b (point))
5283     (gnus-eval-format
5284      gnus-mime-security-button-line-format
5285      gnus-mime-security-button-line-format-alist
5286      `(local-map ,gnus-mime-security-button-map
5287                  keymap ,gnus-mime-security-button-map
5288                  gnus-callback gnus-mime-security-press-button
5289                  gnus-line-format ,gnus-mime-security-button-line-format
5290                  article-type annotation
5291                  gnus-data ,handle))
5292     (setq e (point))
5293     (widget-convert-button
5294      'link b e
5295      :mime-handle handle
5296      :action 'gnus-widget-press-button
5297      :button-keymap gnus-mime-security-button-map
5298      :help-echo
5299      (lambda (widget/window &optional overlay pos)
5300        ;; Needed to properly clear the message due to a bug in
5301        ;; wid-edit (XEmacs only).
5302        (if (boundp 'help-echo-owns-message)
5303            (setq help-echo-owns-message t))
5304        (format
5305         "%S: show detail"
5306         (aref gnus-mouse-2 0))))))
5307
5308 (defun gnus-mime-display-security (handle)
5309   (save-restriction
5310     (narrow-to-region (point) (point))
5311     (gnus-insert-mime-security-button handle)
5312     (gnus-mime-display-mixed (cdr handle))
5313     (unless (bolp)
5314       (insert "\n"))
5315     (let ((gnus-mime-security-button-line-format
5316            gnus-mime-security-button-end-line-format))
5317       (gnus-insert-mime-security-button handle))
5318     (mm-set-handle-multipart-parameter handle 'gnus-region
5319                                        (cons (set-marker (make-marker)
5320                                                          (point-min))
5321                                              (set-marker (make-marker)
5322                                                          (point-max))))))
5323
5324 (gnus-ems-redefine)
5325
5326 (provide 'gnus-art)
5327
5328 (run-hooks 'gnus-art-load-hook)
5329
5330 ;;; gnus-art.el ends here