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