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