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