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 [%w] %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                   date (or (get-text-property (gnus-point-at-bol)
1836                                                 'original-date)
1837                              date)
1838                   eface (get-text-property (1- (gnus-point-at-eol))
1839                                            'face))
1840             (forward-line 1))
1841           (goto-char (point-min))
1842           (let ((buffer-read-only nil))
1843             ;; Delete any old Date headers.
1844             (while (re-search-forward date-regexp nil t)
1845               (if newline
1846                   (delete-region (progn (beginning-of-line) (point))
1847                                  (progn (end-of-line) (point)))
1848                 (delete-region (progn (beginning-of-line) (point))
1849                                (progn (forward-line 1) (point))))
1850               (setq newline nil))
1851             (when (re-search-forward tdate-regexp nil t)
1852               (forward-line 1))
1853             (insert (article-make-date-line date (or type 'ut)))
1854             (when newline
1855               (insert "\n")
1856               (forward-line -1))
1857             ;; Do highlighting.
1858             (beginning-of-line)
1859             (when (looking-at "\\([^:]+\\): *\\(.*\\)$")
1860               (put-text-property (match-beginning 1) (1+ (match-end 1))
1861                                  'original-date date)
1862               (put-text-property (match-beginning 1) (1+ (match-end 1))
1863                                  'face bface)
1864               (put-text-property (match-beginning 2) (match-end 2)
1865                                  'face eface))))))))
1866
1867 (defun article-make-date-line (date type)
1868   "Return a DATE line of TYPE."
1869   (let ((time (condition-case ()
1870                   (date-to-time date)
1871                 (error '(0 0)))))
1872     (cond
1873      ;; Convert to the local timezone.  We have to slap a
1874      ;; `condition-case' round the calls to the timezone
1875      ;; functions since they aren't particularly resistant to
1876      ;; buggy dates.
1877      ((eq type 'local)
1878       (let ((tz (car (current-time-zone time))))
1879         (format "Date: %s %s%02d%02d" (current-time-string time)
1880                 (if (> tz 0) "+" "-") (/ (abs tz) 3600)
1881                 (/ (% (abs tz) 3600) 60))))
1882      ;; Convert to Universal Time.
1883      ((eq type 'ut)
1884       (concat "Date: "
1885               (current-time-string
1886                (let* ((e (parse-time-string date))
1887                      (tm (apply 'encode-time e))
1888                      (ms (car tm))
1889                      (ls (- (cadr tm) (car (current-time-zone time)))))
1890                  (cond ((< ls 0) (list (1- ms) (+ ls 65536)))
1891                        ((> ls 65535) (list (1+ ms) (- ls 65536)))
1892                        (t (list ms ls)))))
1893               " UT"))
1894      ;; Get the original date from the article.
1895      ((eq type 'original)
1896       (concat "Date: " (if (string-match "\n+$" date)
1897                            (substring date 0 (match-beginning 0))
1898                          date)))
1899      ;; Let the user define the format.
1900      ((eq type 'user)
1901       (if (gnus-functionp gnus-article-time-format)
1902           (funcall gnus-article-time-format time)
1903         (concat
1904          "Date: "
1905          (format-time-string gnus-article-time-format time))))
1906      ;; ISO 8601.
1907      ((eq type 'iso8601)
1908       (concat
1909        "Date: "
1910        (format-time-string "%Y%m%dT%H%M%S" time)))
1911      ;; Do an X-Sent lapsed format.
1912      ((eq type 'lapsed)
1913       ;; If the date is seriously mangled, the timezone functions are
1914       ;; liable to bug out, so we ignore all errors.
1915       (let* ((now (current-time))
1916              (real-time (subtract-time now time))
1917              (real-sec (and real-time
1918                             (+ (* (float (car real-time)) 65536)
1919                                (cadr real-time))))
1920              (sec (and real-time (abs real-sec)))
1921              num prev)
1922         (cond
1923          ((null real-time)
1924           "X-Sent: Unknown")
1925          ((zerop sec)
1926           "X-Sent: Now")
1927          (t
1928           (concat
1929            "X-Sent: "
1930            ;; This is a bit convoluted, but basically we go
1931            ;; through the time units for years, weeks, etc,
1932            ;; and divide things to see whether that results
1933            ;; in positive answers.
1934            (mapconcat
1935             (lambda (unit)
1936               (if (zerop (setq num (ffloor (/ sec (cdr unit)))))
1937                   ;; The (remaining) seconds are too few to
1938                   ;; be divided into this time unit.
1939                   ""
1940                 ;; It's big enough, so we output it.
1941                 (setq sec (- sec (* num (cdr unit))))
1942                 (prog1
1943                     (concat (if prev ", " "") (int-to-string
1944                                                (floor num))
1945                             " " (symbol-name (car unit))
1946                             (if (> num 1) "s" ""))
1947                   (setq prev t))))
1948             article-time-units "")
1949            ;; If dates are odd, then it might appear like the
1950            ;; article was sent in the future.
1951            (if (> real-sec 0)
1952                " ago"
1953              " in the future"))))))
1954      (t
1955       (error "Unknown conversion type: %s" type)))))
1956
1957 (defun article-date-local (&optional highlight)
1958   "Convert the current article date to the local timezone."
1959   (interactive (list t))
1960   (article-date-ut 'local highlight))
1961
1962 (defun article-date-original (&optional highlight)
1963   "Convert the current article date to what it was originally.
1964 This is only useful if you have used some other date conversion
1965 function and want to see what the date was before converting."
1966   (interactive (list t))
1967   (article-date-ut 'original highlight))
1968
1969 (defun article-date-lapsed (&optional highlight)
1970   "Convert the current article date to time lapsed since it was sent."
1971   (interactive (list t))
1972   (article-date-ut 'lapsed highlight))
1973
1974 (defun article-update-date-lapsed ()
1975   "Function to be run from a timer to update the lapsed time line."
1976   (let (deactivate-mark)
1977     (save-excursion
1978       (ignore-errors
1979         (walk-windows
1980          (lambda (w)
1981            (set-buffer (window-buffer w))
1982            (when (eq major-mode 'gnus-article-mode)
1983              (goto-char (point-min))
1984              (when (re-search-forward "^X-Sent:" nil t)
1985                (article-date-lapsed t))))
1986          nil 'visible)))))
1987
1988 (defun gnus-start-date-timer (&optional n)
1989   "Start a timer to update the X-Sent header in the article buffers.
1990 The numerical prefix says how frequently (in seconds) the function
1991 is to run."
1992   (interactive "p")
1993   (unless n
1994     (setq n 1))
1995   (gnus-stop-date-timer)
1996   (setq article-lapsed-timer
1997         (nnheader-run-at-time 1 n 'article-update-date-lapsed)))
1998
1999 (defun gnus-stop-date-timer ()
2000   "Stop the X-Sent timer."
2001   (interactive)
2002   (when article-lapsed-timer
2003     (nnheader-cancel-timer article-lapsed-timer)
2004     (setq article-lapsed-timer nil)))
2005
2006 (defun article-date-user (&optional highlight)
2007   "Convert the current article date to the user-defined format.
2008 This format is defined by the `gnus-article-time-format' variable."
2009   (interactive (list t))
2010   (article-date-ut 'user highlight))
2011
2012 (defun article-date-iso8601 (&optional highlight)
2013   "Convert the current article date to ISO8601."
2014   (interactive (list t))
2015   (article-date-ut 'iso8601 highlight))
2016
2017 (defun article-show-all ()
2018   "Show all hidden text in the article buffer."
2019   (interactive)
2020   (save-excursion
2021     (let ((buffer-read-only nil))
2022       (gnus-article-unhide-text (point-min) (point-max)))))
2023
2024 (defun article-emphasize (&optional arg)
2025   "Emphasize text according to `gnus-emphasis-alist'."
2026   (interactive (gnus-article-hidden-arg))
2027   (unless (gnus-article-check-hidden-text 'emphasis arg)
2028     (save-excursion
2029       (let ((alist (or (with-current-buffer gnus-summary-buffer
2030                          gnus-article-emphasis-alist)
2031                        gnus-emphasis-alist))
2032             (buffer-read-only nil)
2033             (props (append '(article-type emphasis)
2034                            gnus-hidden-properties))
2035             regexp elem beg invisible visible face)
2036         (article-goto-body)
2037         (setq beg (point))
2038         (while (setq elem (pop alist))
2039           (goto-char beg)
2040           (setq regexp (car elem)
2041                 invisible (nth 1 elem)
2042                 visible (nth 2 elem)
2043                 face (nth 3 elem))
2044           (while (re-search-forward regexp nil t)
2045             (when (and (match-beginning visible) (match-beginning invisible))
2046               (gnus-article-hide-text
2047                (match-beginning invisible) (match-end invisible) props)
2048               (gnus-article-unhide-text-type
2049                (match-beginning visible) (match-end visible) 'emphasis)
2050               (gnus-put-text-property-excluding-newlines
2051                (match-beginning visible) (match-end visible) 'face face)
2052               (goto-char (match-end invisible)))))))))
2053
2054 (defun gnus-article-setup-highlight-words (&optional highlight-words)
2055   "Setup newsgroup emphasis alist."
2056   (unless gnus-article-emphasis-alist
2057     (let ((name (and gnus-newsgroup-name
2058                      (gnus-group-real-name gnus-newsgroup-name))))
2059       (make-local-variable 'gnus-article-emphasis-alist)
2060       (setq gnus-article-emphasis-alist
2061             (nconc
2062              (let ((alist gnus-group-highlight-words-alist) elem highlight)
2063                (while (setq elem (pop alist))
2064                  (when (and name (string-match (car elem) name))
2065                    (setq alist nil
2066                          highlight (copy-list (cdr elem)))))
2067                highlight)
2068              (copy-list highlight-words)
2069              (if gnus-newsgroup-name
2070                  (copy-list (gnus-group-find-parameter
2071                              gnus-newsgroup-name 'highlight-words t)))
2072              gnus-emphasis-alist)))))
2073
2074 (defvar gnus-summary-article-menu)
2075 (defvar gnus-summary-post-menu)
2076
2077 ;;; Saving functions.
2078
2079 (defun gnus-article-save (save-buffer file &optional num)
2080   "Save the currently selected article."
2081   (unless gnus-save-all-headers
2082     ;; Remove headers according to `gnus-saved-headers'.
2083     (let ((gnus-visible-headers
2084            (or gnus-saved-headers gnus-visible-headers))
2085           (gnus-article-buffer save-buffer))
2086       (save-excursion
2087         (set-buffer save-buffer)
2088         (article-hide-headers 1 t))))
2089   (save-window-excursion
2090     (if (not gnus-default-article-saver)
2091         (error "No default saver is defined")
2092       ;; !!! Magic!  The saving functions all save
2093       ;; `gnus-save-article-buffer' (or so they think), but we
2094       ;; bind that variable to our save-buffer.
2095       (set-buffer gnus-article-buffer)
2096       (let* ((gnus-save-article-buffer save-buffer)
2097              (filename
2098               (cond
2099                ((not gnus-prompt-before-saving) 'default)
2100                ((eq gnus-prompt-before-saving 'always) nil)
2101                (t file)))
2102              (gnus-number-of-articles-to-be-saved
2103               (when (eq gnus-prompt-before-saving t)
2104                 num)))                  ; Magic
2105         (set-buffer gnus-article-current-summary)
2106         (funcall gnus-default-article-saver filename)))))
2107
2108 (defun gnus-read-save-file-name (prompt &optional filename
2109                                         function group headers variable)
2110   (let ((default-name
2111           (funcall function group headers (symbol-value variable)))
2112         result)
2113     (setq
2114      result
2115      (cond
2116       ((eq filename 'default)
2117        default-name)
2118       ((eq filename t)
2119        default-name)
2120       (filename filename)
2121       (t
2122        (let* ((split-name (gnus-get-split-value gnus-split-methods))
2123               (prompt
2124                (format prompt
2125                        (if (and gnus-number-of-articles-to-be-saved
2126                                 (> gnus-number-of-articles-to-be-saved 1))
2127                            (format "these %d articles"
2128                                    gnus-number-of-articles-to-be-saved)
2129                          "this article")))
2130               (file
2131                ;; Let the split methods have their say.
2132                (cond
2133                 ;; No split name was found.
2134                 ((null split-name)
2135                  (read-file-name
2136                   (concat prompt " (default "
2137                           (file-name-nondirectory default-name) ") ")
2138                   (file-name-directory default-name)
2139                   default-name))
2140                 ;; A single group name is returned.
2141                 ((stringp split-name)
2142                  (setq default-name
2143                        (funcall function split-name headers
2144                                 (symbol-value variable)))
2145                  (read-file-name
2146                   (concat prompt " (default "
2147                           (file-name-nondirectory default-name) ") ")
2148                   (file-name-directory default-name)
2149                   default-name))
2150                 ;; A single split name was found
2151                 ((= 1 (length split-name))
2152                  (let* ((name (expand-file-name
2153                                (car split-name) gnus-article-save-directory))
2154                         (dir (cond ((file-directory-p name)
2155                                     (file-name-as-directory name))
2156                                    ((file-exists-p name) name)
2157                                    (t gnus-article-save-directory))))
2158                    (read-file-name
2159                     (concat prompt " (default " name ") ")
2160                     dir name)))
2161                 ;; A list of splits was found.
2162                 (t
2163                  (setq split-name (nreverse split-name))
2164                  (let (result)
2165                    (let ((file-name-history
2166                           (nconc split-name file-name-history)))
2167                      (setq result
2168                            (expand-file-name
2169                             (read-file-name
2170                              (concat prompt " (`M-p' for defaults) ")
2171                              gnus-article-save-directory
2172                              (car split-name))
2173                             gnus-article-save-directory)))
2174                    (car (push result file-name-history)))))))
2175          ;; Create the directory.
2176          (gnus-make-directory (file-name-directory file))
2177          ;; If we have read a directory, we append the default file name.
2178          (when (file-directory-p file)
2179            (setq file (concat (file-name-as-directory file)
2180                               (file-name-nondirectory default-name))))
2181          ;; Possibly translate some characters.
2182          (nnheader-translate-file-chars file)))))
2183     (gnus-make-directory (file-name-directory result))
2184     (set variable result)))
2185
2186 (defun gnus-article-archive-name (group)
2187   "Return the first instance of an \"Archive-name\" in the current buffer."
2188   (let ((case-fold-search t))
2189     (when (re-search-forward "archive-name: *\\([^ \n\t]+\\)[ \t]*$" nil t)
2190       (nnheader-concat gnus-article-save-directory
2191                        (match-string 1)))))
2192
2193 (defun gnus-article-nndoc-name (group)
2194   "If GROUP is an nndoc group, return the name of the parent group."
2195   (when (eq (car (gnus-find-method-for-group group)) 'nndoc)
2196     (gnus-group-get-parameter group 'save-article-group)))
2197
2198 (defun gnus-summary-save-in-rmail (&optional filename)
2199   "Append this article to Rmail file.
2200 Optional argument FILENAME specifies file name.
2201 Directory to save to is default to `gnus-article-save-directory'."
2202   (setq filename (gnus-read-save-file-name
2203                   "Save %s in rmail file:" filename
2204                   gnus-rmail-save-name gnus-newsgroup-name
2205                   gnus-current-headers 'gnus-newsgroup-last-rmail))
2206   (gnus-eval-in-buffer-window gnus-save-article-buffer
2207     (save-excursion
2208       (save-restriction
2209         (widen)
2210         (gnus-output-to-rmail filename))))
2211   filename)
2212
2213 (defun gnus-summary-save-in-mail (&optional filename)
2214   "Append this article to Unix mail file.
2215 Optional argument FILENAME specifies file name.
2216 Directory to save to is default to `gnus-article-save-directory'."
2217   (setq filename (gnus-read-save-file-name
2218                   "Save %s in Unix mail file:" filename
2219                   gnus-mail-save-name gnus-newsgroup-name
2220                   gnus-current-headers 'gnus-newsgroup-last-mail))
2221   (gnus-eval-in-buffer-window gnus-save-article-buffer
2222     (save-excursion
2223       (save-restriction
2224         (widen)
2225         (if (and (file-readable-p filename)
2226                  (mail-file-babyl-p filename))
2227             (rmail-output-to-rmail-file filename t)
2228           (gnus-output-to-mail filename)))))
2229   filename)
2230
2231 (defun gnus-summary-save-in-file (&optional filename overwrite)
2232   "Append this article to file.
2233 Optional argument FILENAME specifies file name.
2234 Directory to save to is default to `gnus-article-save-directory'."
2235   (setq filename (gnus-read-save-file-name
2236                   "Save %s in file:" filename
2237                   gnus-file-save-name gnus-newsgroup-name
2238                   gnus-current-headers 'gnus-newsgroup-last-file))
2239   (gnus-eval-in-buffer-window gnus-save-article-buffer
2240     (save-excursion
2241       (save-restriction
2242         (widen)
2243         (when (and overwrite
2244                    (file-exists-p filename))
2245           (delete-file filename))
2246         (gnus-output-to-file filename))))
2247   filename)
2248
2249 (defun gnus-summary-write-to-file (&optional filename)
2250   "Write this article to a file.
2251 Optional argument FILENAME specifies file name.
2252 The directory to save in defaults to `gnus-article-save-directory'."
2253   (gnus-summary-save-in-file nil t))
2254
2255 (defun gnus-summary-save-body-in-file (&optional filename)
2256   "Append this article body to a file.
2257 Optional argument FILENAME specifies file name.
2258 The directory to save in defaults to `gnus-article-save-directory'."
2259   (setq filename (gnus-read-save-file-name
2260                   "Save %s body in file:" filename
2261                   gnus-file-save-name gnus-newsgroup-name
2262                   gnus-current-headers 'gnus-newsgroup-last-file))
2263   (gnus-eval-in-buffer-window gnus-save-article-buffer
2264     (save-excursion
2265       (save-restriction
2266         (widen)
2267         (when (article-goto-body)
2268           (narrow-to-region (point) (point-max)))
2269         (gnus-output-to-file filename))))
2270   filename)
2271
2272 (defun gnus-summary-save-in-pipe (&optional command)
2273   "Pipe this article to subprocess."
2274   (setq command
2275         (cond ((and (eq command 'default)
2276                     gnus-last-shell-command)
2277                gnus-last-shell-command)
2278               (command command)
2279               (t (read-string
2280                   (format
2281                    "Shell command on %s: "
2282                    (if (and gnus-number-of-articles-to-be-saved
2283                             (> gnus-number-of-articles-to-be-saved 1))
2284                        (format "these %d articles"
2285                                gnus-number-of-articles-to-be-saved)
2286                      "this article"))
2287                   gnus-last-shell-command))))
2288   (when (string-equal command "")
2289     (setq command gnus-last-shell-command))
2290   (gnus-eval-in-buffer-window gnus-article-buffer
2291     (save-restriction
2292       (widen)
2293       (shell-command-on-region (point-min) (point-max) command nil)))
2294   (setq gnus-last-shell-command command))
2295
2296 ;;; Article file names when saving.
2297
2298 (defun gnus-capitalize-newsgroup (newsgroup)
2299   "Capitalize NEWSGROUP name."
2300   (when (not (zerop (length newsgroup)))
2301     (concat (char-to-string (upcase (aref newsgroup 0)))
2302             (substring newsgroup 1))))
2303
2304 (defun gnus-Numeric-save-name (newsgroup headers &optional last-file)
2305   "Generate file name from NEWSGROUP, HEADERS, and optional LAST-FILE.
2306 If variable `gnus-use-long-file-name' is non-nil, it is ~/News/News.group/num.
2307 Otherwise, it is like ~/News/news/group/num."
2308   (let ((default
2309           (expand-file-name
2310            (concat (if (gnus-use-long-file-name 'not-save)
2311                        (gnus-capitalize-newsgroup newsgroup)
2312                      (gnus-newsgroup-directory-form newsgroup))
2313                    "/" (int-to-string (mail-header-number headers)))
2314            gnus-article-save-directory)))
2315     (if (and last-file
2316              (string-equal (file-name-directory default)
2317                            (file-name-directory last-file))
2318              (string-match "^[0-9]+$" (file-name-nondirectory last-file)))
2319         default
2320       (or last-file default))))
2321
2322 (defun gnus-numeric-save-name (newsgroup headers &optional last-file)
2323   "Generate file name from NEWSGROUP, HEADERS, and optional LAST-FILE.
2324 If variable `gnus-use-long-file-name' is non-nil, it is
2325 ~/News/news.group/num.  Otherwise, it is like ~/News/news/group/num."
2326   (let ((default
2327           (expand-file-name
2328            (concat (if (gnus-use-long-file-name 'not-save)
2329                        newsgroup
2330                      (gnus-newsgroup-directory-form newsgroup))
2331                    "/" (int-to-string (mail-header-number headers)))
2332            gnus-article-save-directory)))
2333     (if (and last-file
2334              (string-equal (file-name-directory default)
2335                            (file-name-directory last-file))
2336              (string-match "^[0-9]+$" (file-name-nondirectory last-file)))
2337         default
2338       (or last-file default))))
2339
2340 (defun gnus-Plain-save-name (newsgroup headers &optional last-file)
2341   "Generate file name from NEWSGROUP, HEADERS, and optional LAST-FILE.
2342 If variable `gnus-use-long-file-name' is non-nil, it is
2343 ~/News/News.group.  Otherwise, it is like ~/News/news/group/news."
2344   (or last-file
2345       (expand-file-name
2346        (if (gnus-use-long-file-name 'not-save)
2347            (gnus-capitalize-newsgroup newsgroup)
2348          (concat (gnus-newsgroup-directory-form newsgroup) "/news"))
2349        gnus-article-save-directory)))
2350
2351 (defun gnus-plain-save-name (newsgroup headers &optional last-file)
2352   "Generate file name from NEWSGROUP, HEADERS, and optional LAST-FILE.
2353 If variable `gnus-use-long-file-name' is non-nil, it is
2354 ~/News/news.group.  Otherwise, it is like ~/News/news/group/news."
2355   (or last-file
2356       (expand-file-name
2357        (if (gnus-use-long-file-name 'not-save)
2358            newsgroup
2359          (concat (gnus-newsgroup-directory-form newsgroup) "/news"))
2360        gnus-article-save-directory)))
2361
2362 (eval-and-compile
2363   (mapcar
2364    (lambda (func)
2365      (let (afunc gfunc)
2366        (if (consp func)
2367            (setq afunc (car func)
2368                  gfunc (cdr func))
2369          (setq afunc func
2370                gfunc (intern (format "gnus-%s" func))))
2371        (fset gfunc
2372              (if (not (fboundp afunc))
2373                  nil
2374                `(lambda (&optional interactive &rest args)
2375                   ,(documentation afunc t)
2376                   (interactive (list t))
2377                   (save-excursion
2378                     (set-buffer gnus-article-buffer)
2379                     (if interactive
2380                         (call-interactively ',afunc)
2381                       (apply ',afunc args))))))))
2382    '(article-hide-headers
2383      article-hide-boring-headers
2384      article-treat-overstrike
2385      article-fill-long-lines
2386      article-capitalize-sentences
2387      article-remove-cr
2388      article-display-x-face
2389      article-de-quoted-unreadable
2390      article-mime-decode-quoted-printable
2391      article-hide-list-identifiers
2392      article-hide-pgp
2393      article-strip-banner
2394      article-babel
2395      article-hide-pem
2396      article-hide-signature
2397      article-strip-headers-in-body
2398      article-remove-trailing-blank-lines
2399      article-strip-leading-blank-lines
2400      article-strip-multiple-blank-lines
2401      article-strip-leading-space
2402      article-strip-trailing-space
2403      article-strip-blank-lines
2404      article-strip-all-blank-lines
2405      article-date-local
2406      article-date-iso8601
2407      article-date-original
2408      article-date-ut
2409      article-decode-mime-words
2410      article-decode-charset
2411      article-decode-encoded-words
2412      article-date-user
2413      article-date-lapsed
2414      article-emphasize
2415      article-treat-dumbquotes
2416      article-normalize-headers
2417      (article-show-all . gnus-article-show-all-headers))))
2418 \f
2419 ;;;
2420 ;;; Gnus article mode
2421 ;;;
2422
2423 (put 'gnus-article-mode 'mode-class 'special)
2424
2425 (set-keymap-parent gnus-article-mode-map widget-keymap)
2426
2427 (gnus-define-keys gnus-article-mode-map
2428   " " gnus-article-goto-next-page
2429   "\177" gnus-article-goto-prev-page
2430   [delete] gnus-article-goto-prev-page
2431   [backspace] gnus-article-goto-prev-page
2432   "\C-c^" gnus-article-refer-article
2433   "h" gnus-article-show-summary
2434   "s" gnus-article-show-summary
2435   "\C-c\C-m" gnus-article-mail
2436   "?" gnus-article-describe-briefly
2437   "e" gnus-article-edit
2438   "<" beginning-of-buffer
2439   ">" end-of-buffer
2440   "\C-c\C-i" gnus-info-find-node
2441   "\C-c\C-b" gnus-bug
2442
2443   "\C-d" gnus-article-read-summary-keys
2444   "\M-*" gnus-article-read-summary-keys
2445   "\M-#" gnus-article-read-summary-keys
2446   "\M-^" gnus-article-read-summary-keys
2447   "\M-g" gnus-article-read-summary-keys)
2448
2449 (substitute-key-definition
2450  'undefined 'gnus-article-read-summary-keys gnus-article-mode-map)
2451
2452 (defun gnus-article-make-menu-bar ()
2453   (gnus-turn-off-edit-menu 'article)
2454   (unless (boundp 'gnus-article-article-menu)
2455     (easy-menu-define
2456      gnus-article-article-menu gnus-article-mode-map ""
2457      '("Article"
2458        ["Scroll forwards" gnus-article-goto-next-page t]
2459        ["Scroll backwards" gnus-article-goto-prev-page t]
2460        ["Show summary" gnus-article-show-summary t]
2461        ["Fetch Message-ID at point" gnus-article-refer-article t]
2462        ["Mail to address at point" gnus-article-mail t]
2463        ["Send a bug report" gnus-bug t]))
2464
2465     (easy-menu-define
2466      gnus-article-treatment-menu gnus-article-mode-map ""
2467      '("Treatment"
2468        ["Hide headers" gnus-article-hide-headers t]
2469        ["Hide signature" gnus-article-hide-signature t]
2470        ["Hide citation" gnus-article-hide-citation t]
2471        ["Treat overstrike" gnus-article-treat-overstrike t]
2472        ["Remove carriage return" gnus-article-remove-cr t]
2473        ["Remove quoted-unreadable" gnus-article-de-quoted-unreadable t]))
2474
2475     ;; Note "Commands" menu is defined in gnus-sum.el for consistency
2476
2477     (when (boundp 'gnus-summary-post-menu)
2478       (define-key gnus-article-mode-map [menu-bar post]
2479         (cons "Post" gnus-summary-post-menu)))
2480
2481     (gnus-run-hooks 'gnus-article-menu-hook)))
2482
2483 (defun gnus-article-mode ()
2484   "Major mode for displaying an article.
2485
2486 All normal editing commands are switched off.
2487
2488 The following commands are available in addition to all summary mode
2489 commands:
2490 \\<gnus-article-mode-map>
2491 \\[gnus-article-next-page]\t Scroll the article one page forwards
2492 \\[gnus-article-prev-page]\t Scroll the article one page backwards
2493 \\[gnus-article-refer-article]\t Go to the article referred to by an article id near point
2494 \\[gnus-article-show-summary]\t Display the summary buffer
2495 \\[gnus-article-mail]\t Send a reply to the address near point
2496 \\[gnus-article-describe-briefly]\t Describe the current mode briefly
2497 \\[gnus-info-find-node]\t Go to the Gnus info node"
2498   (interactive)
2499   (when (gnus-visual-p 'article-menu 'menu)
2500     (gnus-article-make-menu-bar))
2501   (gnus-simplify-mode-line)
2502   (setq mode-name "Article")
2503   (setq major-mode 'gnus-article-mode)
2504   (make-local-variable 'minor-mode-alist)
2505   (use-local-map gnus-article-mode-map)
2506   (gnus-update-format-specifications nil 'article-mode)
2507   (set (make-local-variable 'page-delimiter) gnus-page-delimiter)
2508   (make-local-variable 'gnus-page-broken)
2509   (make-local-variable 'gnus-button-marker-list)
2510   (make-local-variable 'gnus-article-current-summary)
2511   (make-local-variable 'gnus-article-mime-handles)
2512   (make-local-variable 'gnus-article-decoded-p)
2513   (make-local-variable 'gnus-article-mime-handle-alist)
2514   (make-local-variable 'gnus-article-washed-types)
2515   (gnus-set-default-directory)
2516   (buffer-disable-undo)
2517   (setq buffer-read-only t)
2518   (set-syntax-table gnus-article-mode-syntax-table)
2519   (mm-enable-multibyte)
2520   (gnus-run-hooks 'gnus-article-mode-hook))
2521
2522 (defun gnus-article-setup-buffer ()
2523   "Initialize the article buffer."
2524   (let* ((name (if gnus-single-article-buffer "*Article*"
2525                  (concat "*Article " gnus-newsgroup-name "*")))
2526          (original
2527           (progn (string-match "\\*Article" name)
2528                  (concat " *Original Article"
2529                          (substring name (match-end 0))))))
2530     (setq gnus-article-buffer name)
2531     (setq gnus-original-article-buffer original)
2532     (setq gnus-article-mime-handle-alist nil)
2533     ;; This might be a variable local to the summary buffer.
2534     (unless gnus-single-article-buffer
2535       (save-excursion
2536         (set-buffer gnus-summary-buffer)
2537         (setq gnus-article-buffer name)
2538         (setq gnus-original-article-buffer original)
2539         (gnus-set-global-variables)))
2540     (gnus-article-setup-highlight-words)
2541     ;; Init original article buffer.
2542     (save-excursion
2543       (set-buffer (gnus-get-buffer-create gnus-original-article-buffer))
2544       (mm-enable-multibyte)
2545       (setq major-mode 'gnus-original-article-mode)
2546       (make-local-variable 'gnus-original-article))
2547     (if (get-buffer name)
2548         (save-excursion
2549           (set-buffer name)
2550           (kill-all-local-variables)
2551           (buffer-disable-undo)
2552           (setq buffer-read-only t)
2553           (unless (eq major-mode 'gnus-article-mode)
2554             (gnus-article-mode))
2555           (current-buffer))
2556       (save-excursion
2557         (set-buffer (gnus-get-buffer-create name))
2558         (gnus-article-mode)
2559         (make-local-variable 'gnus-summary-buffer)
2560         (gnus-summary-set-local-parameters gnus-newsgroup-name)
2561         (current-buffer)))))
2562
2563 ;; Set article window start at LINE, where LINE is the number of lines
2564 ;; from the head of the article.
2565 (defun gnus-article-set-window-start (&optional line)
2566   (set-window-start
2567    (get-buffer-window gnus-article-buffer t)
2568    (save-excursion
2569      (set-buffer gnus-article-buffer)
2570      (goto-char (point-min))
2571      (if (not line)
2572          (point-min)
2573        (gnus-message 6 "Moved to bookmark")
2574        (search-forward "\n\n" nil t)
2575        (forward-line line)
2576        (point)))))
2577
2578 (defun gnus-article-prepare (article &optional all-headers header)
2579   "Prepare ARTICLE in article mode buffer.
2580 ARTICLE should either be an article number or a Message-ID.
2581 If ARTICLE is an id, HEADER should be the article headers.
2582 If ALL-HEADERS is non-nil, no headers are hidden."
2583   (save-excursion
2584     ;; Make sure we start in a summary buffer.
2585     (unless (eq major-mode 'gnus-summary-mode)
2586       (set-buffer gnus-summary-buffer))
2587     (setq gnus-summary-buffer (current-buffer))
2588     (let* ((gnus-article (if header (mail-header-number header) article))
2589            (summary-buffer (current-buffer))
2590            (gnus-tmp-internal-hook gnus-article-internal-prepare-hook)
2591            (group gnus-newsgroup-name)
2592            result)
2593       (save-excursion
2594         (gnus-article-setup-buffer)
2595         (set-buffer gnus-article-buffer)
2596         ;; Deactivate active regions.
2597         (when (and (boundp 'transient-mark-mode)
2598                    transient-mark-mode)
2599           (setq mark-active nil))
2600         (if (not (setq result (let ((buffer-read-only nil))
2601                                 (gnus-request-article-this-buffer
2602                                  article group))))
2603             ;; There is no such article.
2604             (save-excursion
2605               (when (and (numberp article)
2606                          (not (memq article gnus-newsgroup-sparse)))
2607                 (setq gnus-article-current
2608                       (cons gnus-newsgroup-name article))
2609                 (set-buffer gnus-summary-buffer)
2610                 (setq gnus-current-article article)
2611                 (if (eq (gnus-article-mark article) gnus-undownloaded-mark)
2612                     (progn
2613                       (gnus-summary-set-agent-mark article)
2614                       (message "Message marked for downloading"))
2615                   (gnus-summary-mark-article article gnus-canceled-mark)
2616                   (unless (memq article gnus-newsgroup-sparse)
2617                     (gnus-error 1
2618                      "No such article (may have expired or been canceled)")))))
2619           (if (or (eq result 'pseudo)
2620                   (eq result 'nneething))
2621               (progn
2622                 (save-excursion
2623                   (set-buffer summary-buffer)
2624                   (push article gnus-newsgroup-history)
2625                   (setq gnus-last-article gnus-current-article
2626                         gnus-current-article 0
2627                         gnus-current-headers nil
2628                         gnus-article-current nil)
2629                   (if (eq result 'nneething)
2630                       (gnus-configure-windows 'summary)
2631                     (gnus-configure-windows 'article))
2632                   (gnus-set-global-variables))
2633                 (let ((gnus-article-mime-handle-alist-1
2634                        gnus-article-mime-handle-alist))
2635                   (gnus-set-mode-line 'article)))
2636             ;; The result from the `request' was an actual article -
2637             ;; or at least some text that is now displayed in the
2638             ;; article buffer.
2639             (when (and (numberp article)
2640                        (not (eq article gnus-current-article)))
2641               ;; Seems like a new article has been selected.
2642               ;; `gnus-current-article' must be an article number.
2643               (save-excursion
2644                 (set-buffer summary-buffer)
2645                 (push article gnus-newsgroup-history)
2646                 (setq gnus-last-article gnus-current-article
2647                       gnus-current-article article
2648                       gnus-current-headers
2649                       (gnus-summary-article-header gnus-current-article)
2650                       gnus-article-current
2651                       (cons gnus-newsgroup-name gnus-current-article))
2652                 (unless (vectorp gnus-current-headers)
2653                   (setq gnus-current-headers nil))
2654                 (gnus-summary-goto-subject gnus-current-article)
2655                 (when (gnus-summary-show-thread)
2656                   ;; If the summary buffer really was folded, the
2657                   ;; previous goto may not actually have gone to
2658                   ;; the right article, but the thread root instead.
2659                   ;; So we go again.
2660                   (gnus-summary-goto-subject gnus-current-article))
2661                 (gnus-run-hooks 'gnus-mark-article-hook)
2662                 (gnus-set-mode-line 'summary)
2663                 (when (gnus-visual-p 'article-highlight 'highlight)
2664                   (gnus-run-hooks 'gnus-visual-mark-article-hook))
2665                 ;; Set the global newsgroup variables here.
2666                 (gnus-set-global-variables)
2667                 (setq gnus-have-all-headers
2668                       (or all-headers gnus-show-all-headers))))
2669             (when (or (numberp article)
2670                       (stringp article))
2671               (gnus-article-prepare-display)
2672               ;; Do page break.
2673               (goto-char (point-min))
2674               (setq gnus-page-broken
2675                     (when gnus-break-pages
2676                       (gnus-narrow-to-page)
2677                       t)))
2678             (let ((gnus-article-mime-handle-alist-1
2679                    gnus-article-mime-handle-alist))
2680               (gnus-set-mode-line 'article))
2681             (article-goto-body)
2682             (set-window-point (get-buffer-window (current-buffer)) (point))
2683             (gnus-configure-windows 'article)
2684             t))))))
2685
2686 ;;;###autoload
2687 (defun gnus-article-prepare-display ()
2688   "Make the current buffer look like a nice article."
2689   ;; Hooks for getting information from the article.
2690   ;; This hook must be called before being narrowed.
2691   (let ((gnus-article-buffer (current-buffer))
2692         buffer-read-only)
2693     (unless (eq major-mode 'gnus-article-mode)
2694       (gnus-article-mode))
2695     (setq buffer-read-only nil
2696           gnus-article-wash-types nil)
2697     (gnus-run-hooks 'gnus-tmp-internal-hook)
2698     (gnus-run-hooks 'gnus-article-prepare-hook)
2699     (when gnus-display-mime-function
2700       (funcall gnus-display-mime-function))))
2701
2702 ;;;
2703 ;;; Gnus MIME viewing functions
2704 ;;;
2705
2706 (defvar gnus-mime-button-line-format "%{%([%p. %d%T]%)%}%e\n"
2707   "The following specs can be used:
2708 %t  The MIME type
2709 %T  MIME type, along with additional info
2710 %n  The `name' parameter
2711 %d  The description, if any
2712 %l  The length of the encoded part
2713 %p  The part identifier number
2714 %e  Dots if the part isn't displayed")
2715
2716 (defvar gnus-mime-button-line-format-alist
2717   '((?t gnus-tmp-type ?s)
2718     (?T gnus-tmp-type-long ?s)
2719     (?n gnus-tmp-name ?s)
2720     (?d gnus-tmp-description ?s)
2721     (?p gnus-tmp-id ?s)
2722     (?l gnus-tmp-length ?d)
2723     (?e gnus-tmp-dots ?s)))
2724
2725 (defvar gnus-mime-button-commands
2726   '((gnus-article-press-button "\r" "Toggle Display")
2727     (gnus-mime-view-part "v" "View Interactively...")
2728     (gnus-mime-view-part-as-type "t" "View As Type...")
2729     (gnus-mime-save-part "o" "Save...")
2730     (gnus-mime-copy-part "c" "View As Text, In Other Buffer")
2731     (gnus-mime-inline-part "i" "View As Text, In This Buffer")
2732     (gnus-mime-internalize-part "E" "View Internally")
2733     (gnus-mime-externalize-part "e" "View Externally")
2734     (gnus-mime-pipe-part "|" "Pipe To Command...")))
2735
2736 (defun gnus-article-mime-part-status ()
2737   (if gnus-article-mime-handle-alist-1
2738       (format " (%d parts)" (length gnus-article-mime-handle-alist-1))
2739     ""))
2740
2741 (defvar gnus-mime-button-map nil)
2742 (unless gnus-mime-button-map
2743   (setq gnus-mime-button-map (make-sparse-keymap))
2744   (set-keymap-parent gnus-mime-button-map gnus-article-mode-map)
2745   (define-key gnus-mime-button-map gnus-mouse-2 'gnus-article-push-button)
2746   (define-key gnus-mime-button-map gnus-down-mouse-3 'gnus-mime-button-menu)
2747   (mapcar (lambda (c)
2748             (define-key gnus-mime-button-map (cadr c) (car c)))
2749           gnus-mime-button-commands))
2750
2751 (defun gnus-mime-button-menu (event)
2752   "Construct a context-sensitive menu of MIME commands."
2753   (interactive "e")
2754   (save-excursion
2755     (let ((pos (event-start event)))
2756       (set-buffer (window-buffer (posn-window pos)))
2757       (goto-char (posn-point pos))
2758       (gnus-article-check-buffer)
2759       (let ((response (x-popup-menu
2760                        t `("MIME Part"
2761                            ("" ,@(mapcar (lambda (c)
2762                                            (cons (caddr c) (car c)))
2763                                          gnus-mime-button-commands))))))
2764         (if response
2765             (funcall response))))))
2766
2767 (defun gnus-mime-view-all-parts (&optional handles)
2768   "View all the MIME parts."
2769   (interactive)
2770   (save-current-buffer
2771     (set-buffer gnus-article-buffer)
2772     (let ((handles (or handles gnus-article-mime-handles))
2773           (mail-parse-charset gnus-newsgroup-charset)
2774           (mail-parse-ignored-charsets
2775            (save-excursion (set-buffer gnus-summary-buffer)
2776                            gnus-newsgroup-ignored-charsets)))
2777       (if (stringp (car handles))
2778           (gnus-mime-view-all-parts (cdr handles))
2779         (mapcar 'mm-display-part handles)))))
2780
2781 (defun gnus-mime-save-part ()
2782   "Save the MIME part under point."
2783   (interactive)
2784   (gnus-article-check-buffer)
2785   (let ((data (get-text-property (point) 'gnus-data)))
2786     (mm-save-part data)))
2787
2788 (defun gnus-mime-pipe-part ()
2789   "Pipe the MIME part under point to a process."
2790   (interactive)
2791   (gnus-article-check-buffer)
2792   (let ((data (get-text-property (point) 'gnus-data)))
2793     (mm-pipe-part data)))
2794
2795 (defun gnus-mime-view-part ()
2796   "Interactively choose a viewing method for the MIME part under point."
2797   (interactive)
2798   (gnus-article-check-buffer)
2799   (let ((data (get-text-property (point) 'gnus-data)))
2800     (mm-interactively-view-part data)))
2801
2802 (defun gnus-mime-view-part-as-type ()
2803   "Choose a MIME media type, and view the part as such."
2804   (interactive
2805    (list (completing-read "View as MIME type: " mailcap-mime-types)))
2806   (gnus-article-check-buffer)
2807   (let ((handle (get-text-property (point) 'gnus-data)))
2808     (gnus-mm-display-part handle)))
2809
2810 (defun gnus-mime-copy-part (&optional handle)
2811   "Put the the MIME part under point into a new buffer."
2812   (interactive)
2813   (gnus-article-check-buffer)
2814   (let* ((handle (or handle (get-text-property (point) 'gnus-data)))
2815          (contents (mm-get-part handle))|
2816          (base (file-name-nondirectory
2817                 (or
2818                  (mail-content-type-get (mm-handle-type handle) 'name)
2819                  (mail-content-type-get (mm-handle-type handle)
2820                                         'filename)
2821                  "*decoded*")))
2822          (buffer (generate-new-buffer base)))
2823     (switch-to-buffer buffer)
2824     (insert contents)
2825     ;; We do it this way to make `normal-mode' set the appropriate mode.
2826     (unwind-protect
2827         (progn
2828           (setq buffer-file-name (expand-file-name base))
2829           (normal-mode))
2830       (setq buffer-file-name nil))
2831     (goto-char (point-min))))
2832
2833 (defun gnus-mime-inline-part (&optional handle)
2834   "Insert the MIME part under point into the current buffer."
2835   (interactive)
2836   (gnus-article-check-buffer)
2837   (let* ((handle (or handle (get-text-property (point) 'gnus-data)))
2838          contents
2839          (b (point))
2840          buffer-read-only)
2841     (if (mm-handle-undisplayer handle)
2842         (mm-remove-part handle)
2843       (setq contents (mm-get-part handle))
2844       (forward-line 2)
2845       (mm-insert-inline handle contents)
2846       (goto-char b))))
2847
2848 (defun gnus-mime-externalize-part (&optional handle)
2849   "View the MIME part under point with an external viewer."
2850   (interactive)
2851   (gnus-article-check-buffer)
2852   (let* ((handle (or handle (get-text-property (point) 'gnus-data)))
2853          (mm-user-display-methods nil)
2854          (mm-inline-large-images nil)
2855          (mail-parse-charset gnus-newsgroup-charset)
2856          (mail-parse-ignored-charsets
2857           (save-excursion (set-buffer gnus-summary-buffer)
2858                           gnus-newsgroup-ignored-charsets)))
2859     (if (mm-handle-undisplayer handle)
2860         (mm-remove-part handle)
2861       (mm-display-part handle))))
2862
2863 (defun gnus-mime-internalize-part (&optional handle)
2864   "View the MIME part under point with an internal viewer."
2865   (interactive)
2866   (gnus-article-check-buffer)
2867   (let* ((handle (or handle (get-text-property (point) 'gnus-data)))
2868          (mm-user-display-methods '((".*" . inline)))
2869          (mm-inline-large-images t)
2870          (mail-parse-charset gnus-newsgroup-charset)
2871          (mail-parse-ignored-charsets
2872           (save-excursion (set-buffer gnus-summary-buffer)
2873                           gnus-newsgroup-ignored-charsets)))
2874     (if (mm-handle-undisplayer handle)
2875         (mm-remove-part handle)
2876       (mm-display-part handle))))
2877
2878 (defun gnus-article-part-wrapper (n function)
2879   (save-current-buffer
2880     (set-buffer gnus-article-buffer)
2881     (when (> n (length gnus-article-mime-handle-alist))
2882       (error "No such part"))
2883     (gnus-article-goto-part n)
2884     (let ((handle (cdr (assq n gnus-article-mime-handle-alist))))
2885       (funcall function handle))))
2886
2887 (defun gnus-article-pipe-part (n)
2888   "Pipe MIME part N, which is the numerical prefix."
2889   (interactive "p")
2890   (gnus-article-part-wrapper n 'mm-pipe-part))
2891
2892 (defun gnus-article-save-part (n)
2893   "Save MIME part N, which is the numerical prefix."
2894   (interactive "p")
2895   (gnus-article-part-wrapper n 'mm-save-part))
2896
2897 (defun gnus-article-interactively-view-part (n)
2898   "View MIME part N interactively, which is the numerical prefix."
2899   (interactive "p")
2900   (gnus-article-part-wrapper n 'mm-interactively-view-part))
2901
2902 (defun gnus-article-copy-part (n)
2903   "Copy MIME part N, which is the numerical prefix."
2904   (interactive "p")
2905   (gnus-article-part-wrapper n 'gnus-mime-copy-part))
2906
2907 (defun gnus-article-externalize-part (n)
2908   "View MIME part N externally, which is the numerical prefix."
2909   (interactive "p")
2910   (gnus-article-part-wrapper n 'gnus-mime-externalize-part))
2911
2912 (defun gnus-article-inline-part (n)
2913   "Inline MIME part N, which is the numerical prefix."
2914   (interactive "p")
2915   (gnus-article-part-wrapper n 'gnus-mime-inline-part))
2916
2917 (defun gnus-article-view-part (n)
2918   "View MIME part N, which is the numerical prefix."
2919   (interactive "p")
2920   (save-current-buffer
2921     (set-buffer gnus-article-buffer)
2922     (when (> n (length gnus-article-mime-handle-alist))
2923       (error "No such part"))
2924     (let ((handle (cdr (assq n gnus-article-mime-handle-alist))))
2925       (when (gnus-article-goto-part n)
2926         (if (equal (car handle) "multipart/alternative")
2927             (gnus-article-press-button)
2928           (when (eq (gnus-mm-display-part handle) 'internal)
2929             (gnus-set-window-start)))))))
2930
2931 (defun gnus-mm-display-part (handle)
2932   "Display HANDLE and fix MIME button."
2933   (let ((id (get-text-property (point) 'gnus-part))
2934         (point (point))
2935         buffer-read-only)
2936     (forward-line 1)
2937     (prog1
2938         (let ((window (selected-window))
2939               (mail-parse-charset gnus-newsgroup-charset)
2940               (mail-parse-ignored-charsets
2941                (save-excursion (set-buffer gnus-summary-buffer)
2942                                gnus-newsgroup-ignored-charsets)))
2943           (save-excursion
2944             (unwind-protect
2945                 (let ((win (get-buffer-window (current-buffer) t))
2946                       (beg (point)))
2947                   (when win
2948                     (select-window win))
2949                   (goto-char point)
2950                   (forward-line)
2951                   (if (mm-handle-displayed-p handle)
2952                       ;; This will remove the part.
2953                       (mm-display-part handle)
2954                     (save-restriction
2955                       (narrow-to-region (point) (1+ (point)))
2956                       (mm-display-part handle)
2957                       ;; We narrow to the part itself and
2958                       ;; then call the treatment functions.
2959                       (goto-char (point-min))
2960                       (forward-line 1)
2961                       (narrow-to-region (point) (point-max))
2962                       (gnus-treat-article
2963                        nil id
2964                        (1- (length gnus-article-mime-handles))
2965                        (mm-handle-media-type handle)))))
2966               (select-window window))))
2967       (goto-char point)
2968       (delete-region (gnus-point-at-bol) (progn (forward-line 1) (point)))
2969       (gnus-insert-mime-button
2970        handle id (list (mm-handle-displayed-p handle)))
2971       (goto-char point))))
2972
2973 (defun gnus-article-goto-part (n)
2974   "Go to MIME part N."
2975   (let ((point (text-property-any (point-min) (point-max) 'gnus-part n)))
2976     (when point
2977       (goto-char point))))
2978
2979 (defun gnus-insert-mime-button (handle gnus-tmp-id &optional displayed)
2980   (let ((gnus-tmp-name
2981          (or (mail-content-type-get (mm-handle-type handle)
2982                                     'name)
2983              (mail-content-type-get (mm-handle-disposition handle)
2984                                     'filename)
2985              ""))
2986         (gnus-tmp-type (mm-handle-media-type handle))
2987         (gnus-tmp-description
2988          (mail-decode-encoded-word-string (or (mm-handle-description handle)
2989                                               "")))
2990         (gnus-tmp-dots
2991          (if (if displayed (car displayed)
2992                (mm-handle-displayed-p handle))
2993              "" "..."))
2994         (gnus-tmp-length (with-current-buffer (mm-handle-buffer handle)
2995                            (buffer-size)))
2996         gnus-tmp-type-long b e)
2997     (when (string-match ".*/" gnus-tmp-name)
2998       (setq gnus-tmp-name (replace-match "" t t gnus-tmp-name)))
2999     (setq gnus-tmp-type-long (concat gnus-tmp-type
3000                                      (and (not (equal gnus-tmp-name ""))
3001                                           (concat "; " gnus-tmp-name))))
3002     (or (equal gnus-tmp-description "")
3003         (setq gnus-tmp-type-long (concat " --- " gnus-tmp-type-long)))
3004     (unless (bolp)
3005       (insert "\n"))
3006     (setq b (point))
3007     (gnus-eval-format
3008      gnus-mime-button-line-format gnus-mime-button-line-format-alist
3009      `(local-map ,gnus-mime-button-map
3010                  keymap ,gnus-mime-button-map
3011                  gnus-callback gnus-mm-display-part
3012                  gnus-part ,gnus-tmp-id
3013                  article-type annotation
3014                  gnus-data ,handle))
3015     (setq e (point))
3016     (widget-convert-button 'link b e
3017                            :mime-handle handle
3018                            :action 'gnus-widget-press-button
3019                            :button-keymap gnus-mime-button-map
3020                            :help-echo
3021                            (lambda (widget)
3022                              ;; Needed to properly clear the message
3023                              ;; due to a bug in wid-edit
3024                              (setq help-echo-owns-message t)
3025                              (format
3026                               "Click to %s the MIME part; %s for more options"
3027                               (if (mm-handle-displayed-p
3028                                    (widget-get widget :mime-handle))
3029                                   "hide" "show")
3030                               (if gnus-xemacs "button3" "mouse-3"))))))
3031
3032 (defun gnus-widget-press-button (elems el)
3033   (goto-char (widget-get elems :from))
3034   (gnus-article-press-button))
3035
3036 (defvar gnus-displaying-mime nil)
3037
3038 (defun gnus-display-mime (&optional ihandles)
3039   "Display the MIME parts."
3040   (save-excursion
3041     (save-selected-window
3042       (let ((window (get-buffer-window gnus-article-buffer))
3043             (point (point)))
3044         (when window
3045           (select-window window)
3046           ;; We have to do this since selecting the window
3047           ;; may change the point.  So we set the window point.
3048           (set-window-point window point)))
3049       (let* ((handles (or ihandles (mm-dissect-buffer) (mm-uu-dissect)))
3050              buffer-read-only handle name type b e display)
3051         (when (and (not ihandles)
3052                    (not gnus-displaying-mime))
3053           ;; Top-level call; we clean up.
3054           (when gnus-article-mime-handles
3055             (mm-destroy-parts gnus-article-mime-handles)
3056             (setq gnus-article-mime-handle-alist nil)) ;; A trick.
3057           (setq gnus-article-mime-handles handles)
3058           ;; We allow users to glean info from the handles.
3059           (when gnus-article-mime-part-function
3060             (gnus-mime-part-function handles)))
3061         (if (and handles
3062                  (or (not (stringp (car handles)))
3063                      (cdr handles)))
3064             (progn
3065               (when (and (not ihandles)
3066                          (not gnus-displaying-mime))
3067                 ;; Clean up for mime parts.
3068                 (article-goto-body)
3069                 (delete-region (point) (point-max)))
3070               (let ((gnus-displaying-mime t))
3071                 (gnus-mime-display-part handles)))
3072           (save-restriction
3073             (article-goto-body)
3074             (narrow-to-region (point) (point-max))
3075             (gnus-treat-article nil 1 1)
3076             (widen)))
3077         (if (not ihandles)
3078             ;; Highlight the headers.
3079             (save-excursion
3080               (save-restriction
3081                 (article-goto-body)
3082                 (narrow-to-region (point-min) (point))
3083                 (gnus-treat-article 'head))))))))
3084
3085 (defvar gnus-mime-display-multipart-as-mixed nil)
3086
3087 (defun gnus-mime-display-part (handle)
3088   (cond
3089    ;; Single part.
3090    ((not (stringp (car handle)))
3091     (gnus-mime-display-single handle))
3092    ;; User-defined multipart
3093    ((cdr (assoc (car handle) gnus-mime-multipart-functions))
3094     (funcall (cdr (assoc (car handle) gnus-mime-multipart-functions))
3095              handle))
3096    ;; multipart/alternative
3097    ((and (equal (car handle) "multipart/alternative")
3098          (not gnus-mime-display-multipart-as-mixed))
3099     (let ((id (1+ (length gnus-article-mime-handle-alist))))
3100       (push (cons id handle) gnus-article-mime-handle-alist)
3101       (gnus-mime-display-alternative (cdr handle) nil nil id)))
3102    ;; multipart/related
3103    ((and (equal (car handle) "multipart/related")
3104          (not gnus-mime-display-multipart-as-mixed))
3105     ;;;!!!We should find the start part, but we just default
3106     ;;;!!!to the first part.
3107     (gnus-mime-display-part (cadr handle)))
3108    ;; Other multiparts are handled like multipart/mixed.
3109    (t
3110     (gnus-mime-display-mixed (cdr handle)))))
3111
3112 (defun gnus-mime-part-function (handles)
3113   (if (stringp (car handles))
3114       (mapcar 'gnus-mime-part-function (cdr handles))
3115     (funcall gnus-article-mime-part-function handles)))
3116
3117 (defun gnus-mime-display-mixed (handles)
3118   (mapcar 'gnus-mime-display-part handles))
3119
3120 (defun gnus-mime-display-single (handle)
3121   (let ((type (mm-handle-media-type handle))
3122         (ignored gnus-ignored-mime-types)
3123         (not-attachment t)
3124         (move nil)
3125         display text)
3126     (catch 'ignored
3127       (progn
3128         (while ignored
3129           (when (string-match (pop ignored) type)
3130             (throw 'ignored nil)))
3131         (if (and (setq not-attachment
3132                        (or (not (mm-handle-disposition handle))
3133                            (equal (car (mm-handle-disposition handle))
3134                                   "inline")
3135                            (mm-attachment-override-p handle)))
3136                  (mm-automatic-display-p handle)
3137                  (or (mm-inlined-p handle)
3138                      (mm-automatic-external-display-p type)))
3139             (setq display t)
3140           (when (equal (mm-handle-media-supertype handle) "text")
3141             (setq text t)))
3142         (let ((id (1+ (length gnus-article-mime-handle-alist))))
3143           (push (cons id handle) gnus-article-mime-handle-alist)
3144           (when (or (not display)
3145                     (not (gnus-unbuttonized-mime-type-p type)))
3146             (gnus-article-insert-newline)
3147             (gnus-insert-mime-button
3148              handle id (list (or display (and not-attachment text))))
3149             (gnus-article-insert-newline)
3150             (gnus-article-insert-newline)
3151             (setq move t)))
3152         (let ((beg (point)))
3153           (cond
3154            (display
3155             (when move
3156               (forward-line -2)
3157               (setq beg (point)))
3158             (let ((mail-parse-charset gnus-newsgroup-charset)
3159                   (mail-parse-ignored-charsets
3160                    (save-excursion (set-buffer gnus-summary-buffer)
3161                                    gnus-newsgroup-ignored-charsets)))
3162               (mm-display-part handle t))
3163             (goto-char (point-max)))
3164            ((and text not-attachment)
3165             (when move
3166               (forward-line -2)
3167               (setq beg (point)))
3168             (gnus-article-insert-newline)
3169             (mm-insert-inline handle (mm-get-part handle))
3170             (goto-char (point-max))))
3171           ;; Do highlighting.
3172           (save-excursion
3173             (save-restriction
3174               (narrow-to-region beg (point))
3175               (gnus-treat-article
3176                nil (length gnus-article-mime-handle-alist)
3177                (1- (length gnus-article-mime-handles))
3178                (mm-handle-media-type handle)))))))))
3179
3180 (defun gnus-unbuttonized-mime-type-p (type)
3181   "Say whether TYPE is to be unbuttonized."
3182   (unless gnus-inhibit-mime-unbuttonizing
3183     (catch 'found
3184       (let ((types gnus-unbuttonized-mime-types))
3185         (while types
3186           (when (string-match (pop types) type)
3187             (throw 'found t)))))))
3188
3189 (defun gnus-article-insert-newline ()
3190   "Insert a newline, but mark it as undeletable."
3191   (gnus-put-text-property
3192    (point) (progn (insert "\n") (point)) 'gnus-undeletable t))
3193
3194 (defun gnus-mime-display-alternative (handles &optional preferred ibegend id)
3195   (let* ((preferred (or preferred (mm-preferred-alternative handles)))
3196          (ihandles handles)
3197          (point (point))
3198          handle buffer-read-only from props begend not-pref)
3199     (save-window-excursion
3200       (save-restriction
3201         (when ibegend
3202           (narrow-to-region (car ibegend)
3203                             (or (cdr ibegend)
3204                                 (progn
3205                                   (goto-char (car ibegend))
3206                                   (forward-line 2)
3207                                   (point))))
3208           (delete-region (point-min) (point-max))
3209           (mm-remove-parts handles))
3210         (setq begend (list (point-marker)))
3211         ;; Do the toggle.
3212         (unless (setq not-pref (cadr (member preferred ihandles)))
3213           (setq not-pref (car ihandles)))
3214         (when (or ibegend
3215                   (not (gnus-unbuttonized-mime-type-p
3216                         "multipart/alternative")))
3217           (gnus-add-text-properties
3218            (setq from (point))
3219            (progn
3220              (insert (format "%d.  " id))
3221              (point))
3222            `(gnus-callback
3223              (lambda (handles)
3224                (unless ,(not ibegend)
3225                  (setq gnus-article-mime-handle-alist
3226                        ',gnus-article-mime-handle-alist))
3227                (gnus-mime-display-alternative
3228                 ',ihandles ',not-pref ',begend ,id))
3229              local-map ,gnus-mime-button-map
3230              ,gnus-mouse-face-prop ,gnus-article-mouse-face
3231              face ,gnus-article-button-face
3232              keymap ,gnus-mime-button-map
3233              gnus-part ,id
3234              gnus-data ,handle))
3235           (widget-convert-button 'link from (point)
3236                                  :action 'gnus-widget-press-button
3237                                  :button-keymap gnus-widget-button-keymap)
3238           ;; Do the handles
3239           (while (setq handle (pop handles))
3240             (gnus-add-text-properties
3241              (setq from (point))
3242              (progn
3243                (insert (format "(%c) %-18s"
3244                                (if (equal handle preferred) ?* ? )
3245                                (mm-handle-media-type handle)))
3246                (point))
3247              `(gnus-callback
3248                (lambda (handles)
3249                  (unless ,(not ibegend)
3250                    (setq gnus-article-mime-handle-alist
3251                          ',gnus-article-mime-handle-alist))
3252                  (gnus-mime-display-alternative
3253                   ',ihandles ',handle ',begend ,id))
3254                local-map ,gnus-mime-button-map
3255                ,gnus-mouse-face-prop ,gnus-article-mouse-face
3256                face ,gnus-article-button-face
3257                keymap ,gnus-mime-button-map
3258                gnus-part ,id
3259                gnus-data ,handle))
3260             (widget-convert-button 'link from (point)
3261                                    :action 'gnus-widget-press-button
3262                                    :button-keymap gnus-widget-button-keymap)
3263             (insert "  "))
3264           (insert "\n\n"))
3265         (when preferred
3266           (if (stringp (car preferred))
3267               (gnus-display-mime preferred)
3268             (let ((mail-parse-charset gnus-newsgroup-charset)
3269                   (mail-parse-ignored-charsets
3270                    (save-excursion (set-buffer gnus-summary-buffer)
3271                                    gnus-newsgroup-ignored-charsets)))
3272               (mm-display-part preferred)
3273               ;; Do highlighting.
3274               (save-excursion
3275                 (save-restriction
3276                   (narrow-to-region (car begend) (point-max))
3277                   (gnus-treat-article
3278                    nil (length gnus-article-mime-handle-alist)
3279                    (1- (length gnus-article-mime-handles))
3280                    (mm-handle-media-type handle))))))
3281           (goto-char (point-max))
3282           (setcdr begend (point-marker)))))
3283     (when ibegend
3284       (goto-char point))))
3285
3286 (defun gnus-article-wash-status ()
3287   "Return a string which display status of article washing."
3288   (save-excursion
3289     (set-buffer gnus-article-buffer)
3290     (let ((cite (memq 'cite gnus-article-wash-types))
3291           (headers (memq 'headers gnus-article-wash-types))
3292           (boring (memq 'boring-headers gnus-article-wash-types))
3293           (pgp (memq 'pgp gnus-article-wash-types))
3294           (pem (memq 'pem gnus-article-wash-types))
3295           (signature (memq 'signature gnus-article-wash-types))
3296           (overstrike (memq 'overstrike gnus-article-wash-types))
3297           (emphasis (memq 'emphasis gnus-article-wash-types)))
3298       (format "%c%c%c%c%c%c"
3299               (if cite ?c ? )
3300               (if (or headers boring) ?h ? )
3301               (if (or pgp pem) ?p ? )
3302               (if signature ?s ? )
3303               (if overstrike ?o ? )
3304               (if emphasis ?e ? )))))
3305
3306 (fset 'gnus-article-hide-headers-if-wanted 'gnus-article-maybe-hide-headers)
3307
3308 (defun gnus-article-maybe-hide-headers ()
3309   "Hide unwanted headers if `gnus-have-all-headers' is nil.
3310 Provided for backwards compatibility."
3311   (when (and (or (not (gnus-buffer-live-p gnus-summary-buffer))
3312                  (not (save-excursion (set-buffer gnus-summary-buffer)
3313                                       gnus-have-all-headers)))
3314              (not gnus-inhibit-hiding))
3315     (gnus-article-hide-headers)))
3316
3317 ;;; Article savers.
3318
3319 (defun gnus-output-to-file (file-name)
3320   "Append the current article to a file named FILE-NAME."
3321   (let ((artbuf (current-buffer)))
3322     (with-temp-buffer
3323       (insert-buffer-substring artbuf)
3324       ;; Append newline at end of the buffer as separator, and then
3325       ;; save it to file.
3326       (goto-char (point-max))
3327       (insert "\n")
3328       (mm-append-to-file (point-min) (point-max) file-name)
3329       t)))
3330
3331 (defun gnus-narrow-to-page (&optional arg)
3332   "Narrow the article buffer to a page.
3333 If given a numerical ARG, move forward ARG pages."
3334   (interactive "P")
3335   (setq arg (if arg (prefix-numeric-value arg) 0))
3336   (save-excursion
3337     (set-buffer gnus-article-buffer)
3338     (goto-char (point-min))
3339     (widen)
3340     ;; Remove any old next/prev buttons.
3341     (when (gnus-visual-p 'page-marker)
3342       (let ((buffer-read-only nil))
3343         (gnus-remove-text-with-property 'gnus-prev)
3344         (gnus-remove-text-with-property 'gnus-next)))
3345     (when
3346         (cond ((< arg 0)
3347                (re-search-backward page-delimiter nil 'move (1+ (abs arg))))
3348               ((> arg 0)
3349                (re-search-forward page-delimiter nil 'move arg)))
3350       (goto-char (match-end 0)))
3351     (narrow-to-region
3352      (point)
3353      (if (re-search-forward page-delimiter nil 'move)
3354          (match-beginning 0)
3355        (point)))
3356     (when (and (gnus-visual-p 'page-marker)
3357                (not (= (point-min) 1)))
3358       (save-excursion
3359         (goto-char (point-min))
3360         (gnus-insert-prev-page-button)))
3361     (when (and (gnus-visual-p 'page-marker)
3362                (< (+ (point-max) 2) (buffer-size)))
3363       (save-excursion
3364         (goto-char (point-max))
3365         (gnus-insert-next-page-button)))))
3366
3367 ;; Article mode commands
3368
3369 (defun gnus-article-goto-next-page ()
3370   "Show the next page of the article."
3371   (interactive)
3372   (when (gnus-article-next-page)
3373     (goto-char (point-min))
3374     (gnus-article-read-summary-keys nil (gnus-character-to-event ?n))))
3375
3376 (defun gnus-article-goto-prev-page ()
3377   "Show the next page of the article."
3378   (interactive)
3379   (if (bobp) (gnus-article-read-summary-keys nil (gnus-character-to-event ?p))
3380     (gnus-article-prev-page nil)))
3381
3382 (defun gnus-article-next-page (&optional lines)
3383   "Show the next page of the current article.
3384 If end of article, return non-nil.  Otherwise return nil.
3385 Argument LINES specifies lines to be scrolled up."
3386   (interactive "p")
3387   (move-to-window-line -1)
3388   (if (save-excursion
3389         (end-of-line)
3390         (and (pos-visible-in-window-p)  ;Not continuation line.
3391              (eobp)))
3392       ;; Nothing in this page.
3393       (if (or (not gnus-page-broken)
3394               (save-excursion
3395                 (save-restriction
3396                   (widen) (forward-line 1) (eobp)))) ;Real end-of-buffer?
3397           t                             ;Nothing more.
3398         (gnus-narrow-to-page 1)         ;Go to next page.
3399         nil)
3400     ;; More in this page.
3401     (let ((scroll-in-place nil))
3402       (condition-case ()
3403           (scroll-up lines)
3404         (end-of-buffer
3405          ;; Long lines may cause an end-of-buffer error.
3406          (goto-char (point-max)))))
3407     (move-to-window-line 0)
3408     nil))
3409
3410 (defun gnus-article-prev-page (&optional lines)
3411   "Show previous page of current article.
3412 Argument LINES specifies lines to be scrolled down."
3413   (interactive "p")
3414   (move-to-window-line 0)
3415   (if (and gnus-page-broken
3416            (bobp)
3417            (not (save-restriction (widen) (bobp)))) ;Real beginning-of-buffer?
3418       (progn
3419         (gnus-narrow-to-page -1)        ;Go to previous page.
3420         (goto-char (point-max))
3421         (recenter -1))
3422     (let ((scroll-in-place nil))
3423       (prog1
3424           (condition-case ()
3425               (scroll-down lines)
3426             (beginning-of-buffer
3427              (goto-char (point-min))))
3428         (move-to-window-line 0)))))
3429
3430 (defun gnus-article-refer-article ()
3431   "Read article specified by message-id around point."
3432   (interactive)
3433   (let ((point (point)))
3434     (search-forward ">" nil t)          ;Move point to end of "<....>".
3435     (if (re-search-backward "\\(<[^<> \t\n]+>\\)" nil t)
3436         (let ((message-id (match-string 1)))
3437           (goto-char point)
3438           (set-buffer gnus-summary-buffer)
3439           (gnus-summary-refer-article message-id))
3440       (goto-char (point))
3441       (error "No references around point"))))
3442
3443 (defun gnus-article-show-summary ()
3444   "Reconfigure windows to show summary buffer."
3445   (interactive)
3446   (if (not (gnus-buffer-live-p gnus-summary-buffer))
3447       (error "There is no summary buffer for this article buffer")
3448     (gnus-article-set-globals)
3449     (gnus-configure-windows 'article)
3450     (gnus-summary-goto-subject gnus-current-article)
3451     (gnus-summary-position-point)))
3452
3453 (defun gnus-article-describe-briefly ()
3454   "Describe article mode commands briefly."
3455   (interactive)
3456   (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")))
3457
3458 (defun gnus-article-summary-command ()
3459   "Execute the last keystroke in the summary buffer."
3460   (interactive)
3461   (let ((obuf (current-buffer))
3462         (owin (current-window-configuration))
3463         func)
3464     (switch-to-buffer gnus-article-current-summary 'norecord)
3465     (setq func (lookup-key (current-local-map) (this-command-keys)))
3466     (call-interactively func)
3467     (set-buffer obuf)
3468     (set-window-configuration owin)
3469     (set-window-point (get-buffer-window (current-buffer)) (point))))
3470
3471 (defun gnus-article-summary-command-nosave ()
3472   "Execute the last keystroke in the summary buffer."
3473   (interactive)
3474   (let (func)
3475     (pop-to-buffer gnus-article-current-summary 'norecord)
3476     (setq func (lookup-key (current-local-map) (this-command-keys)))
3477     (call-interactively func)))
3478
3479 (defun gnus-article-check-buffer ()
3480   "Beep if not in an article buffer."
3481   (unless (equal major-mode 'gnus-article-mode)
3482     (error "Command invoked outside of a Gnus article buffer")))
3483
3484 (defun gnus-article-read-summary-keys (&optional arg key not-restore-window)
3485   "Read a summary buffer key sequence and execute it from the article buffer."
3486   (interactive "P")
3487   (gnus-article-check-buffer)
3488   (let ((nosaves
3489          '("q" "Q"  "c" "r" "R" "\C-c\C-f" "m"  "a" "f" "F"
3490            "Zc" "ZC" "ZE" "ZQ" "ZZ" "Zn" "ZR" "ZG" "ZN" "ZP"
3491            "=" "^" "\M-^" "|"))
3492         (nosave-but-article
3493          '("A\r"))
3494         (nosave-in-article
3495          '("\C-d"))
3496         (up-to-top
3497          '("n" "Gn" "p" "Gp"))
3498         keys new-sum-point)
3499     (save-excursion
3500       (set-buffer gnus-article-current-summary)
3501       (let (gnus-pick-mode)
3502         (push (or key last-command-event) unread-command-events)
3503         (setq keys (if gnus-xemacs
3504                        (events-to-keys (read-key-sequence nil))
3505                      (read-key-sequence nil)))))
3506
3507     (message "")
3508
3509     (if (or (member keys nosaves)
3510             (member keys nosave-but-article)
3511             (member keys nosave-in-article))
3512         (let (func)
3513           (save-window-excursion
3514             (pop-to-buffer gnus-article-current-summary 'norecord)
3515             ;; We disable the pick minor mode commands.
3516             (let (gnus-pick-mode)
3517               (setq func (lookup-key (current-local-map) keys))))
3518           (if (not func)
3519               (ding)
3520             (unless (member keys nosave-in-article)
3521               (set-buffer gnus-article-current-summary))
3522             (call-interactively func)
3523             (setq new-sum-point (point)))
3524           (when (member keys nosave-but-article)
3525             (pop-to-buffer gnus-article-buffer 'norecord)))
3526       ;; These commands should restore window configuration.
3527       (let ((obuf (current-buffer))
3528             (owin (current-window-configuration))
3529             (opoint (point))
3530             (summary gnus-article-current-summary)
3531             func in-buffer selected)
3532         (if not-restore-window
3533             (pop-to-buffer summary 'norecord)
3534           (switch-to-buffer summary 'norecord))
3535         (setq in-buffer (current-buffer))
3536         ;; We disable the pick minor mode commands.
3537         (if (setq func (let (gnus-pick-mode)
3538                          (lookup-key (current-local-map) keys)))
3539             (progn
3540               (call-interactively func)
3541               (setq new-sum-point (point)))
3542           (ding))
3543         (when (eq in-buffer (current-buffer))
3544           (setq selected (gnus-summary-select-article))
3545           (set-buffer obuf)
3546           (unless not-restore-window
3547             (set-window-configuration owin))
3548           (when (eq selected 'old)
3549             (article-goto-body)
3550             (set-window-start (get-buffer-window (current-buffer))
3551                               1)
3552             (set-window-point (get-buffer-window (current-buffer))
3553                               (point)))
3554           (let ((win (get-buffer-window gnus-article-current-summary)))
3555             (when win
3556               (set-window-point win new-sum-point))))))))
3557
3558 (defun gnus-article-hide (&optional arg force)
3559   "Hide all the gruft in the current article.
3560 This means that PGP stuff, signatures, cited text and (some)
3561 headers will be hidden.
3562 If given a prefix, show the hidden text instead."
3563   (interactive (append (gnus-article-hidden-arg) (list 'force)))
3564   (gnus-article-hide-headers arg)
3565   (gnus-article-hide-list-identifiers arg)
3566   (gnus-article-hide-pgp arg)
3567   (gnus-article-hide-citation-maybe arg force)
3568   (gnus-article-hide-signature arg))
3569
3570 (defun gnus-article-maybe-highlight ()
3571   "Do some article highlighting if article highlighting is requested."
3572   (when (gnus-visual-p 'article-highlight 'highlight)
3573     (gnus-article-highlight-some)))
3574
3575 (defun gnus-check-group-server ()
3576   ;; Make sure the connection to the server is alive.
3577   (unless (gnus-server-opened
3578            (gnus-find-method-for-group gnus-newsgroup-name))
3579     (gnus-check-server (gnus-find-method-for-group gnus-newsgroup-name))
3580     (gnus-request-group gnus-newsgroup-name t)))
3581
3582 (defun gnus-request-article-this-buffer (article group)
3583   "Get an article and insert it into this buffer."
3584   (let (do-update-line sparse-header)
3585     (prog1
3586         (save-excursion
3587           (erase-buffer)
3588           (gnus-kill-all-overlays)
3589           (setq group (or group gnus-newsgroup-name))
3590
3591           ;; Using `gnus-request-article' directly will insert the article into
3592           ;; `nntp-server-buffer' - so we'll save some time by not having to
3593           ;; copy it from the server buffer into the article buffer.
3594
3595           ;; We only request an article by message-id when we do not have the
3596           ;; headers for it, so we'll have to get those.
3597           (when (stringp article)
3598             (let ((gnus-override-method gnus-refer-article-method))
3599               (gnus-read-header article)))
3600
3601           ;; If the article number is negative, that means that this article
3602           ;; doesn't belong in this newsgroup (possibly), so we find its
3603           ;; message-id and request it by id instead of number.
3604           (when (and (numberp article)
3605                      gnus-summary-buffer
3606                      (get-buffer gnus-summary-buffer)
3607                      (gnus-buffer-exists-p gnus-summary-buffer))
3608             (save-excursion
3609               (set-buffer gnus-summary-buffer)
3610               (let ((header (gnus-summary-article-header article)))
3611                 (when (< article 0)
3612                   (cond
3613                    ((memq article gnus-newsgroup-sparse)
3614                     ;; This is a sparse gap article.
3615                     (setq do-update-line article)
3616                     (setq article (mail-header-id header))
3617                     (let ((gnus-override-method gnus-refer-article-method))
3618                       (setq sparse-header (gnus-read-header article)))
3619                     (setq gnus-newsgroup-sparse
3620                           (delq article gnus-newsgroup-sparse)))
3621                    ((vectorp header)
3622                     ;; It's a real article.
3623                     (setq article (mail-header-id header)))
3624                    (t
3625                     ;; It is an extracted pseudo-article.
3626                     (setq article 'pseudo)
3627                     (gnus-request-pseudo-article header))))
3628
3629                 (let ((method (gnus-find-method-for-group
3630                                gnus-newsgroup-name)))
3631                   (when (and (eq (car method) 'nneething)
3632                              (vectorp header))
3633                     (let ((dir (concat
3634                                 (file-name-as-directory
3635                                  (or (cadr (assq 'nneething-address method))
3636                                      (nth 1 method)))
3637                                 (mail-header-subject header))))
3638                       (when (file-directory-p dir)
3639                         (setq article 'nneething)
3640                         (gnus-group-enter-directory dir))))))))
3641
3642           (cond
3643            ;; Refuse to select canceled articles.
3644            ((and (numberp article)
3645                  gnus-summary-buffer
3646                  (get-buffer gnus-summary-buffer)
3647                  (gnus-buffer-exists-p gnus-summary-buffer)
3648                  (eq (cdr (save-excursion
3649                             (set-buffer gnus-summary-buffer)
3650                             (assq article gnus-newsgroup-reads)))
3651                      gnus-canceled-mark))
3652             nil)
3653            ;; We first check `gnus-original-article-buffer'.
3654            ((and (get-buffer gnus-original-article-buffer)
3655                  (numberp article)
3656                  (save-excursion
3657                    (set-buffer gnus-original-article-buffer)
3658                    (and (equal (car gnus-original-article) group)
3659                         (eq (cdr gnus-original-article) article))))
3660             (insert-buffer-substring gnus-original-article-buffer)
3661             'article)
3662            ;; Check the backlog.
3663            ((and gnus-keep-backlog
3664                  (gnus-backlog-request-article group article (current-buffer)))
3665             'article)
3666            ;; Check asynchronous pre-fetch.
3667            ((gnus-async-request-fetched-article group article (current-buffer))
3668             (gnus-async-prefetch-next group article gnus-summary-buffer)
3669             (when (and (numberp article) gnus-keep-backlog)
3670               (gnus-backlog-enter-article group article (current-buffer)))
3671             'article)
3672            ;; Check the cache.
3673            ((and gnus-use-cache
3674                  (numberp article)
3675                  (gnus-cache-request-article article group))
3676             'article)
3677            ;; Get the article and put into the article buffer.
3678            ((or (stringp article) (numberp article))
3679             (let ((gnus-override-method
3680                    (and (stringp article) gnus-refer-article-method))
3681                   (buffer-read-only nil))
3682               (erase-buffer)
3683               (gnus-kill-all-overlays)
3684               (gnus-check-group-server)
3685               (when (gnus-request-article article group (current-buffer))
3686                 (when (numberp article)
3687                   (gnus-async-prefetch-next group article gnus-summary-buffer)
3688                   (when gnus-keep-backlog
3689                     (gnus-backlog-enter-article
3690                      group article (current-buffer))))
3691                 'article)))
3692            ;; It was a pseudo.
3693            (t article)))
3694
3695       ;; Associate this article with the current summary buffer.
3696       (setq gnus-article-current-summary gnus-summary-buffer)
3697
3698       ;; Take the article from the original article buffer
3699       ;; and place it in the buffer it's supposed to be in.
3700       (when (and (get-buffer gnus-article-buffer)
3701                  (equal (buffer-name (current-buffer))
3702                         (buffer-name (get-buffer gnus-article-buffer))))
3703         (save-excursion
3704           (if (get-buffer gnus-original-article-buffer)
3705               (set-buffer gnus-original-article-buffer)
3706             (set-buffer (gnus-get-buffer-create gnus-original-article-buffer))
3707             (buffer-disable-undo)
3708             (setq major-mode 'gnus-original-article-mode)
3709             (setq buffer-read-only t))
3710           (let (buffer-read-only)
3711             (erase-buffer)
3712             (insert-buffer-substring gnus-article-buffer))
3713           (setq gnus-original-article (cons group article)))
3714
3715         ;; Decode charsets.
3716         (run-hooks 'gnus-article-decode-hook)
3717         ;; Mark article as decoded or not.
3718         (setq gnus-article-decoded-p gnus-article-decode-hook))
3719
3720       ;; Update sparse articles.
3721       (when (and do-update-line
3722                  (or (numberp article)
3723                      (stringp article)))
3724         (let ((buf (current-buffer)))
3725           (set-buffer gnus-summary-buffer)
3726           (gnus-summary-update-article do-update-line sparse-header)
3727           (gnus-summary-goto-subject do-update-line nil t)
3728           (set-window-point (get-buffer-window (current-buffer) t)
3729                             (point))
3730           (set-buffer buf))))))
3731
3732 ;;;
3733 ;;; Article editing
3734 ;;;
3735
3736 (defcustom gnus-article-edit-mode-hook nil
3737   "Hook run in article edit mode buffers."
3738   :group 'gnus-article-various
3739   :type 'hook)
3740
3741 (defvar gnus-article-edit-done-function nil)
3742
3743 (defvar gnus-article-edit-mode-map nil)
3744
3745 ;; Should we be using derived.el for this?
3746 (unless gnus-article-edit-mode-map
3747   (setq gnus-article-edit-mode-map (make-sparse-keymap))
3748   (set-keymap-parent gnus-article-edit-mode-map text-mode-map)
3749
3750   (gnus-define-keys gnus-article-edit-mode-map
3751     "\C-c\C-c" gnus-article-edit-done
3752     "\C-c\C-k" gnus-article-edit-exit)
3753
3754   (gnus-define-keys (gnus-article-edit-wash-map
3755                      "\C-c\C-w" gnus-article-edit-mode-map)
3756     "f" gnus-article-edit-full-stops))
3757
3758 (defun gnus-article-edit-mode ()
3759   "Major mode for editing articles.
3760 This is an extended text-mode.
3761
3762 \\{gnus-article-edit-mode-map}"
3763   (interactive)
3764   (setq major-mode 'gnus-article-edit-mode)
3765   (setq mode-name "Article Edit")
3766   (use-local-map gnus-article-edit-mode-map)
3767   (make-local-variable 'gnus-article-edit-done-function)
3768   (make-local-variable 'gnus-prev-winconf)
3769   (setq buffer-read-only nil)
3770   (buffer-enable-undo)
3771   (widen)
3772   (gnus-run-hooks 'text-mode-hook 'gnus-article-edit-mode-hook))
3773
3774 (defun gnus-article-edit (&optional force)
3775   "Edit the current article.
3776 This will have permanent effect only in mail groups.
3777 If FORCE is non-nil, allow editing of articles even in read-only
3778 groups."
3779   (interactive "P")
3780   (when (and (not force)
3781              (gnus-group-read-only-p))
3782     (error "The current newsgroup does not support article editing"))
3783   (gnus-article-date-original)
3784   (gnus-article-edit-article
3785    'ignore
3786    `(lambda (no-highlight)
3787       'ignore
3788       (gnus-summary-edit-article-done
3789        ,(or (mail-header-references gnus-current-headers) "")
3790        ,(gnus-group-read-only-p) ,gnus-summary-buffer no-highlight))))
3791
3792 (defun gnus-article-edit-article (start-func exit-func)
3793   "Start editing the contents of the current article buffer."
3794   (let ((winconf (current-window-configuration)))
3795     (set-buffer gnus-article-buffer)
3796     (gnus-article-edit-mode)
3797     (funcall start-func)
3798     (gnus-configure-windows 'edit-article)
3799     (setq gnus-article-edit-done-function exit-func)
3800     (setq gnus-prev-winconf winconf)
3801     (gnus-message 6 "C-c C-c to end edits")))
3802
3803 (defun gnus-article-edit-done (&optional arg)
3804   "Update the article edits and exit."
3805   (interactive "P")
3806   (save-excursion
3807     (save-restriction
3808       (widen)
3809       (when (article-goto-body)
3810         (let ((lines (count-lines (point) (point-max)))
3811               (length (- (point-max) (point)))
3812               (case-fold-search t)
3813               (body (copy-marker (point))))
3814           (goto-char (point-min))
3815           (when (re-search-forward "^content-length:[ \t]\\([0-9]+\\)" body t)
3816             (delete-region (match-beginning 1) (match-end 1))
3817             (insert (number-to-string length)))
3818           (goto-char (point-min))
3819           (when (re-search-forward
3820                  "^x-content-length:[ \t]\\([0-9]+\\)" body t)
3821             (delete-region (match-beginning 1) (match-end 1))
3822             (insert (number-to-string length)))
3823           (goto-char (point-min))
3824           (when (re-search-forward "^lines:[ \t]\\([0-9]+\\)" body t)
3825             (delete-region (match-beginning 1) (match-end 1))
3826             (insert (number-to-string lines)))))))
3827   (let ((func gnus-article-edit-done-function)
3828         (buf (current-buffer))
3829         (start (window-start)))
3830     (gnus-article-edit-exit)
3831     (save-excursion
3832       (set-buffer buf)
3833       (let ((buffer-read-only nil))
3834         (funcall func arg))
3835       ;; The cache and backlog have to be flushed somewhat.
3836       (when gnus-keep-backlog
3837         (gnus-backlog-remove-article
3838          (car gnus-article-current) (cdr gnus-article-current)))
3839       ;; Flush original article as well.
3840       (save-excursion
3841         (when (get-buffer gnus-original-article-buffer)
3842           (set-buffer gnus-original-article-buffer)
3843           (setq gnus-original-article nil)))
3844       (when gnus-use-cache
3845         (gnus-cache-update-article
3846          (car gnus-article-current) (cdr gnus-article-current))))
3847     (set-buffer buf)
3848     (set-window-start (get-buffer-window buf) start)
3849     (set-window-point (get-buffer-window buf) (point))))
3850
3851 (defun gnus-article-edit-exit ()
3852   "Exit the article editing without updating."
3853   (interactive)
3854   ;; We remove all text props from the article buffer.
3855   (let ((buf (format "%s" (buffer-string)))
3856         (curbuf (current-buffer))
3857         (p (point))
3858         (window-start (window-start)))
3859     (erase-buffer)
3860     (insert buf)
3861     (let ((winconf gnus-prev-winconf))
3862       (gnus-article-mode)
3863       (set-window-configuration winconf)
3864       ;; Tippy-toe some to make sure that point remains where it was.
3865       (save-current-buffer
3866         (set-buffer curbuf)
3867         (set-window-start (get-buffer-window (current-buffer)) window-start)
3868         (goto-char p)))))
3869
3870 (defun gnus-article-edit-full-stops ()
3871   "Interactively repair spacing at end of sentences."
3872   (interactive)
3873   (save-excursion
3874     (goto-char (point-min))
3875     (search-forward-regexp "^$" nil t)
3876     (let ((case-fold-search nil))
3877       (query-replace-regexp "\\([.!?][])}]* \\)\\([[({A-Z]\\)" "\\1 \\2"))))
3878
3879 ;;;
3880 ;;; Article highlights
3881 ;;;
3882
3883 ;; Written by Per Abrahamsen <abraham@iesd.auc.dk>.
3884
3885 ;;; Internal Variables:
3886
3887 (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\\)"
3888   "Regular expression that matches URLs."
3889   :group 'gnus-article-buttons
3890   :type 'regexp)
3891
3892 (defcustom gnus-button-alist
3893   `(("<\\(url:[>\n\t ]*?\\)?news:[>\n\t ]*\\([^>\n\t ]*@[^>\n\t ]*\\)>"
3894      0 t gnus-button-message-id 2)
3895     ("\\bnews:\\([^>\n\t ]*@[^>)!;:,\n\t ]*\\)" 0 t gnus-button-message-id 1)
3896     ("\\(\\b<\\(url:[>\n\t ]*\\)?news:[>\n\t ]*\\(//\\)?\\([^>\n\t ]*\\)>\\)"
3897      1 t
3898      gnus-button-fetch-group 4)
3899     ("\\bnews:\\(//\\)?\\([^'\">\n\t ]+\\)" 0 t gnus-button-fetch-group 2)
3900     ("\\bin\\( +article\\| +message\\)? +\\(<\\([^\n @<>]+@[^\n @<>]+\\)>\\)" 2
3901      t gnus-button-message-id 3)
3902     ("\\(<URL: *\\)mailto: *\\([^> \n\t]+\\)>" 0 t gnus-url-mailto 2)
3903     ("mailto:\\([-a-zA-Z.@_+0-9%]+\\)" 0 t gnus-url-mailto 1)
3904     ("\\bmailto:\\([^ \n\t]+\\)" 0 t gnus-url-mailto 1)
3905     ;; This is how URLs _should_ be embedded in text...
3906     ("<URL: *\\([^>]*\\)>" 0 t gnus-button-embedded-url 1)
3907     ;; Raw URLs.
3908     (,gnus-button-url-regexp 0 t gnus-button-url 0))
3909   "*Alist of regexps matching buttons in article bodies.
3910
3911 Each entry has the form (REGEXP BUTTON FORM CALLBACK PAR...), where
3912 REGEXP: is the string matching text around the button,
3913 BUTTON: is the number of the regexp grouping actually matching the button,
3914 FORM: is a lisp expression which must eval to true for the button to
3915 be added,
3916 CALLBACK: is the function to call when the user push this button, and each
3917 PAR: is a number of a regexp grouping whose text will be passed to CALLBACK.
3918
3919 CALLBACK can also be a variable, in that case the value of that
3920 variable it the real callback function."
3921   :group 'gnus-article-buttons
3922   :type '(repeat (list regexp
3923                        (integer :tag "Button")
3924                        (sexp :tag "Form")
3925                        (function :tag "Callback")
3926                        (repeat :tag "Par"
3927                                :inline t
3928                                (integer :tag "Regexp group")))))
3929
3930 (defcustom gnus-header-button-alist
3931   `(("^\\(References\\|Message-I[Dd]\\):" "<[^>]+>"
3932      0 t gnus-button-message-id 0)
3933     ("^\\(From\\|Reply-To\\):" ": *\\(.+\\)$" 1 t gnus-button-reply 1)
3934     ("^\\(Cc\\|To\\):" "[^ \t\n<>,()\"]+@[^ \t\n<>,()\"]+"
3935      0 t gnus-button-mailto 0)
3936     ("^X-[Uu][Rr][Ll]:" ,gnus-button-url-regexp 0 t gnus-button-url 0)
3937     ("^Subject:" ,gnus-button-url-regexp 0 t gnus-button-url 0)
3938     ("^[^:]+:" ,gnus-button-url-regexp 0 t gnus-button-url 0)
3939     ("^[^:]+:" "\\(<\\(url: \\)?news:\\([^>\n ]*\\)>\\)" 1 t
3940      gnus-button-message-id 3))
3941   "*Alist of headers and regexps to match buttons in article heads.
3942
3943 This alist is very similar to `gnus-button-alist', except that each
3944 alist has an additional HEADER element first in each entry:
3945
3946 \(HEADER REGEXP BUTTON FORM CALLBACK PAR)
3947
3948 HEADER is a regexp to match a header.  For a fuller explanation, see
3949 `gnus-button-alist'."
3950   :group 'gnus-article-buttons
3951   :group 'gnus-article-headers
3952   :type '(repeat (list (regexp :tag "Header")
3953                        regexp
3954                        (integer :tag "Button")
3955                        (sexp :tag "Form")
3956                        (function :tag "Callback")
3957                        (repeat :tag "Par"
3958                                :inline t
3959                                (integer :tag "Regexp group")))))
3960
3961 (defvar gnus-button-regexp nil)
3962 (defvar gnus-button-marker-list nil)
3963 ;; Regexp matching any of the regexps from `gnus-button-alist'.
3964
3965 (defvar gnus-button-last nil)
3966 ;; The value of `gnus-button-alist' when `gnus-button-regexp' was build.
3967
3968 ;;; Commands:
3969
3970 (defun gnus-article-push-button (event)
3971   "Check text under the mouse pointer for a callback function.
3972 If the text under the mouse pointer has a `gnus-callback' property,
3973 call it with the value of the `gnus-data' text property."
3974   (interactive "e")
3975   (set-buffer (window-buffer (posn-window (event-start event))))
3976   (let* ((pos (posn-point (event-start event)))
3977          (data (get-text-property pos 'gnus-data))
3978          (fun (get-text-property pos 'gnus-callback)))
3979     (goto-char pos)
3980     (when fun
3981       (funcall fun data))))
3982
3983 (defun gnus-article-press-button ()
3984   "Check text at point for a callback function.
3985 If the text at point has a `gnus-callback' property,
3986 call it with the value of the `gnus-data' text property."
3987   (interactive)
3988   (let* ((data (get-text-property (point) 'gnus-data))
3989          (fun (get-text-property (point) 'gnus-callback)))
3990     (when fun
3991       (funcall fun data))))
3992
3993 (defun gnus-article-highlight (&optional force)
3994   "Highlight current article.
3995 This function calls `gnus-article-highlight-headers',
3996 `gnus-article-highlight-citation',
3997 `gnus-article-highlight-signature', and `gnus-article-add-buttons' to
3998 do the highlighting.  See the documentation for those functions."
3999   (interactive (list 'force))
4000   (gnus-article-highlight-headers)
4001   (gnus-article-highlight-citation force)
4002   (gnus-article-highlight-signature)
4003   (gnus-article-add-buttons force)
4004   (gnus-article-add-buttons-to-head))
4005
4006 (defun gnus-article-highlight-some (&optional force)
4007   "Highlight current article.
4008 This function calls `gnus-article-highlight-headers',
4009 `gnus-article-highlight-signature', and `gnus-article-add-buttons' to
4010 do the highlighting.  See the documentation for those functions."
4011   (interactive (list 'force))
4012   (gnus-article-highlight-headers)
4013   (gnus-article-highlight-signature)
4014   (gnus-article-add-buttons))
4015
4016 (defun gnus-article-highlight-headers ()
4017   "Highlight article headers as specified by `gnus-header-face-alist'."
4018   (interactive)
4019   (save-excursion
4020     (set-buffer gnus-article-buffer)
4021     (save-restriction
4022       (let ((alist gnus-header-face-alist)
4023             (buffer-read-only nil)
4024             (case-fold-search t)
4025             (inhibit-point-motion-hooks t)
4026             entry regexp header-face field-face from hpoints fpoints)
4027         (article-narrow-to-head)
4028         (while (setq entry (pop alist))
4029           (goto-char (point-min))
4030           (setq regexp (concat "^\\("
4031                                (if (string-equal "" (nth 0 entry))
4032                                    "[^\t ]"
4033                                  (nth 0 entry))
4034                                "\\)")
4035                 header-face (nth 1 entry)
4036                 field-face (nth 2 entry))
4037           (while (and (re-search-forward regexp nil t)
4038                       (not (eobp)))
4039             (beginning-of-line)
4040             (setq from (point))
4041             (unless (search-forward ":" nil t)
4042               (forward-char 1))
4043             (when (and header-face
4044                        (not (memq (point) hpoints)))
4045               (push (point) hpoints)
4046               (gnus-put-text-property from (point) 'face header-face))
4047             (when (and field-face
4048                        (not (memq (setq from (point)) fpoints)))
4049               (push from fpoints)
4050               (if (re-search-forward "^[^ \t]" nil t)
4051                   (forward-char -2)
4052                 (goto-char (point-max)))
4053               (gnus-put-text-property from (point) 'face field-face))))))))
4054
4055 (defun gnus-article-highlight-signature ()
4056   "Highlight the signature in an article.
4057 It does this by highlighting everything after
4058 `gnus-signature-separator' using `gnus-signature-face'."
4059   (interactive)
4060   (save-excursion
4061     (set-buffer gnus-article-buffer)
4062     (let ((buffer-read-only nil)
4063           (inhibit-point-motion-hooks t))
4064       (save-restriction
4065         (when (and gnus-signature-face
4066                    (gnus-article-narrow-to-signature))
4067           (gnus-overlay-put (gnus-make-overlay (point-min) (point-max))
4068                             'face gnus-signature-face)
4069           (widen)
4070           (gnus-article-search-signature)
4071           (let ((start (match-beginning 0))
4072                 (end (set-marker (make-marker) (1+ (match-end 0)))))
4073             (gnus-article-add-button start (1- end) 'gnus-signature-toggle
4074                                      end)))))))
4075
4076 (defun gnus-button-in-region-p (b e prop)
4077   "Say whether PROP exists in the region."
4078   (text-property-not-all b e prop nil))
4079
4080 (defun gnus-article-add-buttons (&optional force)
4081   "Find external references in the article and make buttons of them.
4082 \"External references\" are things like Message-IDs and URLs, as
4083 specified by `gnus-button-alist'."
4084   (interactive (list 'force))
4085   (save-excursion
4086     (set-buffer gnus-article-buffer)
4087     (let ((buffer-read-only nil)
4088           (inhibit-point-motion-hooks t)
4089           (case-fold-search t)
4090           (alist gnus-button-alist)
4091           beg entry regexp)
4092       ;; Remove all old markers.
4093       (let (marker entry new-list)
4094         (while (setq marker (pop gnus-button-marker-list))
4095           (if (or (< marker (point-min)) (>= marker (point-max)))
4096               (push marker new-list)
4097             (goto-char marker)
4098             (when (setq entry (gnus-button-entry))
4099               (put-text-property (match-beginning (nth 1 entry))
4100                                  (match-end (nth 1 entry))
4101                                  'gnus-callback nil))
4102             (set-marker marker nil)))
4103         (setq gnus-button-marker-list new-list))
4104       ;; We skip the headers.
4105       (article-goto-body)
4106       (setq beg (point))
4107       (while (setq entry (pop alist))
4108         (setq regexp (car entry))
4109         (goto-char beg)
4110         (while (re-search-forward regexp nil t)
4111           (let* ((start (and entry (match-beginning (nth 1 entry))))
4112                  (end (and entry (match-end (nth 1 entry))))
4113                  (from (match-beginning 0)))
4114             (when (and (or (eq t (nth 2 entry))
4115                            (eval (nth 2 entry)))
4116                        (not (gnus-button-in-region-p
4117                              start end 'gnus-callback)))
4118               ;; That optional form returned non-nil, so we add the
4119               ;; button.
4120               (gnus-article-add-button
4121                start end 'gnus-button-push
4122                (car (push (set-marker (make-marker) from)
4123                           gnus-button-marker-list))))))))))
4124
4125 ;; Add buttons to the head of an article.
4126 (defun gnus-article-add-buttons-to-head ()
4127   "Add buttons to the head of the article."
4128   (interactive)
4129   (save-excursion
4130     (set-buffer gnus-article-buffer)
4131     (save-restriction
4132       (let ((buffer-read-only nil)
4133             (inhibit-point-motion-hooks t)
4134             (case-fold-search t)
4135             (alist gnus-header-button-alist)
4136             entry beg end)
4137         (article-narrow-to-head)
4138         (while alist
4139           ;; Each alist entry.
4140           (setq entry (car alist)
4141                 alist (cdr alist))
4142           (goto-char (point-min))
4143           (while (re-search-forward (car entry) nil t)
4144             ;; Each header matching the entry.
4145             (setq beg (match-beginning 0))
4146             (setq end (or (and (re-search-forward "^[^ \t]" nil t)
4147                                (match-beginning 0))
4148                           (point-max)))
4149             (goto-char beg)
4150             (while (re-search-forward (nth 1 entry) end t)
4151               ;; Each match within a header.
4152               (let* ((entry (cdr entry))
4153                      (start (match-beginning (nth 1 entry)))
4154                      (end (match-end (nth 1 entry)))
4155                      (form (nth 2 entry)))
4156                 (goto-char (match-end 0))
4157                 (when (eval form)
4158                   (gnus-article-add-button
4159                    start end (nth 3 entry)
4160                    (buffer-substring (match-beginning (nth 4 entry))
4161                                      (match-end (nth 4 entry)))))))
4162             (goto-char end)))))))
4163
4164 ;;; External functions:
4165
4166 (defun gnus-article-add-button (from to fun &optional data)
4167   "Create a button between FROM and TO with callback FUN and data DATA."
4168   (when gnus-article-button-face
4169     (gnus-overlay-put (gnus-make-overlay from to)
4170                       'face gnus-article-button-face))
4171   (gnus-add-text-properties
4172    from to
4173    (nconc (and gnus-article-mouse-face
4174                (list gnus-mouse-face-prop gnus-article-mouse-face))
4175           (list 'gnus-callback fun)
4176           (and data (list 'gnus-data data))))
4177   (widget-convert-button 'link from to :action 'gnus-widget-press-button
4178                          :button-keymap gnus-widget-button-keymap))
4179
4180 ;;; Internal functions:
4181
4182 (defun gnus-article-set-globals ()
4183   (save-excursion
4184     (set-buffer gnus-summary-buffer)
4185     (gnus-set-global-variables)))
4186
4187 (defun gnus-signature-toggle (end)
4188   (save-excursion
4189     (set-buffer gnus-article-buffer)
4190     (let ((buffer-read-only nil)
4191           (inhibit-point-motion-hooks t))
4192       (if (get-text-property end 'invisible)
4193           (gnus-article-unhide-text end (point-max))
4194         (gnus-article-hide-text end (point-max) gnus-hidden-properties)))))
4195
4196 (defun gnus-button-entry ()
4197   ;; Return the first entry in `gnus-button-alist' matching this place.
4198   (let ((alist gnus-button-alist)
4199         (entry nil))
4200     (while alist
4201       (setq entry (pop alist))
4202       (if (looking-at (car entry))
4203           (setq alist nil)
4204         (setq entry nil)))
4205     entry))
4206
4207 (defun gnus-button-push (marker)
4208   ;; Push button starting at MARKER.
4209   (save-excursion
4210     (goto-char marker)
4211     (let* ((entry (gnus-button-entry))
4212            (inhibit-point-motion-hooks t)
4213            (fun (nth 3 entry))
4214            (args (mapcar (lambda (group)
4215                            (let ((string (match-string group)))
4216                              (gnus-set-text-properties
4217                               0 (length string) nil string)
4218                              string))
4219                          (nthcdr 4 entry))))
4220       (cond
4221        ((fboundp fun)
4222         (apply fun args))
4223        ((and (boundp fun)
4224              (fboundp (symbol-value fun)))
4225         (apply (symbol-value fun) args))
4226        (t
4227         (gnus-message 1 "You must define `%S' to use this button"
4228                       (cons fun args)))))))
4229
4230 (defun gnus-button-message-id (message-id)
4231   "Fetch MESSAGE-ID."
4232   (save-excursion
4233     (set-buffer gnus-summary-buffer)
4234     (gnus-summary-refer-article message-id)))
4235
4236 (defun gnus-button-fetch-group (address)
4237   "Fetch GROUP specified by ADDRESS."
4238   (if (not (string-match "[:/]" address))
4239       ;; This is just a simple group url.
4240       (gnus-group-read-ephemeral-group address gnus-select-method)
4241     (if (not (string-match "^\\([^:/]+\\)\\(:\\([^/]+\\)/\\)?\\(.*\\)$"
4242                            address))
4243         (error "Can't parse %s" address)
4244       (gnus-group-read-ephemeral-group
4245        (match-string 4 address)
4246        `(nntp ,(match-string 1 address)
4247               (nntp-address ,(match-string 1 address))
4248               (nntp-port-number ,(if (match-end 3)
4249                                      (match-string 3 address)
4250                                    "nntp")))))))
4251
4252 (defun gnus-url-parse-query-string (query &optional downcase)
4253   (let (retval pairs cur key val)
4254     (setq pairs (split-string query "&"))
4255     (while pairs
4256       (setq cur (car pairs)
4257             pairs (cdr pairs))
4258       (if (not (string-match "=" cur))
4259           nil                           ; Grace
4260         (setq key (gnus-url-unhex-string (substring cur 0 (match-beginning 0)))
4261               val (gnus-url-unhex-string (substring cur (match-end 0) nil)))
4262         (if downcase
4263             (setq key (downcase key)))
4264         (setq cur (assoc key retval))
4265         (if cur
4266             (setcdr cur (cons val (cdr cur)))
4267           (setq retval (cons (list key val) retval)))))
4268     retval))
4269
4270 (defun gnus-url-unhex (x)
4271   (if (> x ?9)
4272       (if (>= x ?a)
4273           (+ 10 (- x ?a))
4274         (+ 10 (- x ?A)))
4275     (- x ?0)))
4276
4277 (defun gnus-url-unhex-string (str &optional allow-newlines)
4278   "Remove %XXX embedded spaces, etc in a url.
4279 If optional second argument ALLOW-NEWLINES is non-nil, then allow the
4280 decoding of carriage returns and line feeds in the string, which is normally
4281 forbidden in URL encoding."
4282   (setq str (or str ""))
4283   (let ((tmp "")
4284         (case-fold-search t))
4285     (while (string-match "%[0-9a-f][0-9a-f]" str)
4286       (let* ((start (match-beginning 0))
4287              (ch1 (gnus-url-unhex (elt str (+ start 1))))
4288              (code (+ (* 16 ch1)
4289                       (gnus-url-unhex (elt str (+ start 2))))))
4290         (setq tmp (concat
4291                    tmp (substring str 0 start)
4292                    (cond
4293                     (allow-newlines
4294                      (char-to-string code))
4295                     ((or (= code ?\n) (= code ?\r))
4296                      " ")
4297                     (t (char-to-string code))))
4298               str (substring str (match-end 0)))))
4299     (setq tmp (concat tmp str))
4300     tmp))
4301
4302 (defun gnus-url-mailto (url)
4303   ;; Send mail to someone
4304   (when (string-match "mailto:/*\\(.*\\)" url)
4305     (setq url (substring url (match-beginning 1) nil)))
4306   (let (to args subject func)
4307     (if (string-match (regexp-quote "?") url)
4308         (setq to (gnus-url-unhex-string (substring url 0 (match-beginning 0)))
4309               args (gnus-url-parse-query-string
4310                     (substring url (match-end 0) nil) t))
4311       (setq to (gnus-url-unhex-string url)))
4312     (setq args (cons (list "to" to) args)
4313           subject (cdr-safe (assoc "subject" args)))
4314     (message-mail)
4315     (while args
4316       (setq func (intern-soft (concat "message-goto-" (downcase (caar args)))))
4317       (if (fboundp func)
4318           (funcall func)
4319         (message-position-on-field (caar args)))
4320       (insert (mapconcat 'identity (cdar args) ", "))
4321       (setq args (cdr args)))
4322     (if subject
4323         (message-goto-body)
4324       (message-goto-subject))))
4325
4326 (defun gnus-button-mailto (address)
4327   ;; Mail to ADDRESS.
4328   (set-buffer (gnus-copy-article-buffer))
4329   (message-reply address))
4330
4331 (defun gnus-button-reply (address)
4332   ;; Reply to ADDRESS.
4333   (message-reply address))
4334
4335 (defun gnus-button-url (address)
4336   "Browse ADDRESS."
4337   ;; In Emacs 20, `browse-url-browser-function' may be an alist.
4338   (if (listp browse-url-browser-function)
4339       (browse-url address)
4340     (funcall browse-url-browser-function address)))
4341
4342 (defun gnus-button-embedded-url (address)
4343   "Browse ADDRESS."
4344   ;; In Emacs 20, `browse-url-browser-function' may be an alist.
4345   (if (listp browse-url-browser-function)
4346       (browse-url (gnus-strip-whitespace address))
4347     (funcall browse-url-browser-function (gnus-strip-whitespace address))))
4348
4349 ;;; Next/prev buttons in the article buffer.
4350
4351 (defvar gnus-next-page-line-format "%{%(Next page...%)%}\n")
4352 (defvar gnus-prev-page-line-format "%{%(Previous page...%)%}\n")
4353
4354 (defvar gnus-prev-page-map nil)
4355 (unless gnus-prev-page-map
4356   (setq gnus-prev-page-map (make-sparse-keymap))
4357   (define-key gnus-prev-page-map gnus-mouse-2 'gnus-button-prev-page)
4358   (define-key gnus-prev-page-map "\r" 'gnus-button-prev-page))
4359
4360 (defun gnus-insert-prev-page-button ()
4361   (let ((buffer-read-only nil))
4362     (gnus-eval-format
4363      gnus-prev-page-line-format nil
4364      `(gnus-prev t local-map ,gnus-prev-page-map
4365                  gnus-callback gnus-article-button-prev-page
4366                  article-type annotation))))
4367
4368 (defvar gnus-next-page-map nil)
4369 (unless gnus-next-page-map
4370   (setq gnus-next-page-map (make-keymap))
4371   (suppress-keymap gnus-prev-page-map)
4372   (define-key gnus-next-page-map gnus-mouse-2 'gnus-button-next-page)
4373   (define-key gnus-next-page-map "\r" 'gnus-button-next-page))
4374
4375 (defun gnus-button-next-page ()
4376   "Go to the next page."
4377   (interactive)
4378   (let ((win (selected-window)))
4379     (select-window (get-buffer-window gnus-article-buffer t))
4380     (gnus-article-next-page)
4381     (select-window win)))
4382
4383 (defun gnus-button-prev-page ()
4384   "Go to the prev page."
4385   (interactive)
4386   (let ((win (selected-window)))
4387     (select-window (get-buffer-window gnus-article-buffer t))
4388     (gnus-article-prev-page)
4389     (select-window win)))
4390
4391 (defun gnus-insert-next-page-button ()
4392   (let ((buffer-read-only nil))
4393     (gnus-eval-format gnus-next-page-line-format nil
4394                       `(gnus-next
4395                         t local-map ,gnus-next-page-map
4396                         gnus-callback gnus-article-button-next-page
4397                         article-type annotation))))
4398
4399 (defun gnus-article-button-next-page (arg)
4400   "Go to the next page."
4401   (interactive "P")
4402   (let ((win (selected-window)))
4403     (select-window (get-buffer-window gnus-article-buffer t))
4404     (gnus-article-next-page)
4405     (select-window win)))
4406
4407 (defun gnus-article-button-prev-page (arg)
4408   "Go to the prev page."
4409   (interactive "P")
4410   (let ((win (selected-window)))
4411     (select-window (get-buffer-window gnus-article-buffer t))
4412     (gnus-article-prev-page)
4413     (select-window win)))
4414
4415 (defvar gnus-decode-header-methods
4416   '(mail-decode-encoded-word-region)
4417   "List of methods used to decode headers.
4418
4419 This variable is a list of FUNCTION or (REGEXP . FUNCTION). If item is
4420 FUNCTION, FUNCTION will be apply to all newsgroups. If item is a
4421 (REGEXP . FUNCTION), FUNCTION will be only apply to thes newsgroups
4422 whose names match REGEXP.
4423
4424 For example:
4425 ((\"chinese\" . gnus-decode-encoded-word-region-by-guess)
4426  mail-decode-encoded-word-region
4427  (\"chinese\" . rfc1843-decode-region))
4428 ")
4429
4430 (defvar gnus-decode-header-methods-cache nil)
4431
4432 (defun gnus-multi-decode-header (start end)
4433   "Apply the functions from `gnus-encoded-word-methods' that match."
4434   (unless (and gnus-decode-header-methods-cache
4435                (eq gnus-newsgroup-name
4436                    (car gnus-decode-header-methods-cache)))
4437     (setq gnus-decode-header-methods-cache (list gnus-newsgroup-name))
4438     (mapc '(lambda (x)
4439              (if (symbolp x)
4440                  (nconc gnus-decode-header-methods-cache (list x))
4441                (if (and gnus-newsgroup-name
4442                         (string-match (car x) gnus-newsgroup-name))
4443                    (nconc gnus-decode-header-methods-cache
4444                           (list (cdr x))))))
4445           gnus-decode-header-methods))
4446   (let ((xlist gnus-decode-header-methods-cache))
4447     (pop xlist)
4448     (save-restriction
4449       (narrow-to-region start end)
4450       (while xlist
4451         (funcall (pop xlist) (point-min) (point-max))))))
4452
4453 ;;;
4454 ;;; Treatment top-level handling.
4455 ;;;
4456
4457 (defun gnus-treat-article (condition &optional part-number total-parts type)
4458   (let ((length (- (point-max) (point-min)))
4459         (alist gnus-treatment-function-alist)
4460         (article-goto-body-goes-to-point-min-p t)
4461         (treated-type
4462          (or (not type)
4463              (catch 'found
4464                (let ((list gnus-article-treat-types))
4465                  (while list
4466                    (when (string-match (pop list) type)
4467                      (throw 'found t)))))))
4468         (highlightp (gnus-visual-p 'article-highlight 'highlight))
4469         val elem)
4470     (gnus-run-hooks 'gnus-part-display-hook)
4471     (while (setq elem (pop alist))
4472       (setq val (symbol-value (car elem)))
4473       (when (and (or (consp val)
4474                      treated-type)
4475                  (gnus-treat-predicate val)
4476                  (or (not (get (car elem) 'highlight))
4477                      highlightp))
4478         (save-restriction
4479           (funcall (cadr elem)))))))
4480
4481 ;; Dynamic variables.
4482 (defvar part-number)
4483 (defvar total-parts)
4484 (defvar type)
4485 (defvar condition)
4486 (defvar length)
4487 (defun gnus-treat-predicate (val)
4488   (cond
4489    (condition
4490     (eq condition val))
4491    ((null val)
4492     nil)
4493    ((eq val t)
4494     t)
4495    ((eq val 'head)
4496     nil)
4497    ((eq val 'last)
4498     (eq part-number total-parts))
4499    ((numberp val)
4500     (< length val))
4501    ((and (listp val)
4502          (stringp (car val)))
4503     (apply 'gnus-or (mapcar `(lambda (s)
4504                                (string-match s ,(or gnus-newsgroup-name "")))
4505                             val)))
4506    ((listp val)
4507     (let ((pred (pop val)))
4508       (cond
4509        ((eq pred 'or)
4510         (apply 'gnus-or (mapcar 'gnus-treat-predicate val)))
4511        ((eq pred 'and)
4512         (apply 'gnus-and (mapcar 'gnus-treat-predicate val)))
4513        ((eq pred 'not)
4514         (not (gnus-treat-predicate (car val))))
4515        ((eq pred 'typep)
4516         (equal (cadr val) type))
4517        (t
4518         (error "%S is not a valid predicate" pred)))))
4519    (t
4520     (error "%S is not a valid value" val))))
4521
4522 (gnus-ems-redefine)
4523
4524 (provide 'gnus-art)
4525
4526 (run-hooks 'gnus-art-load-hook)
4527
4528 ;;; gnus-art.el ends here