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