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

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