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

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