git.chise.org Git - elisp/gnus.git-/blob - lisp/gnus-art.el

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