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

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