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

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