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