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

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