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 (eval-when-compile
2664   (defvar gnus-summary-article-menu)
2665   (defvar gnus-summary-post-menu))
2666
2667 ;;; Saving functions.
2668
2669 (defun gnus-article-save (save-buffer file &optional num)
2670   "Save the currently selected article."
2671   (unless gnus-save-all-headers
2672     ;; Remove headers according to `gnus-saved-headers'.
2673     (let ((gnus-visible-headers
2674            (or gnus-saved-headers gnus-visible-headers))
2675           (gnus-article-buffer save-buffer))
2676       (save-excursion
2677         (set-buffer save-buffer)
2678         (article-hide-headers 1 t))))
2679   (save-window-excursion
2680     (if (not gnus-default-article-saver)
2681         (error "No default saver is defined")
2682       ;; !!! Magic!  The saving functions all save
2683       ;; `gnus-save-article-buffer' (or so they think), but we
2684       ;; bind that variable to our save-buffer.
2685       (set-buffer gnus-article-buffer)
2686       (let* ((gnus-save-article-buffer save-buffer)
2687              (filename
2688               (cond
2689                ((not gnus-prompt-before-saving) 'default)
2690                ((eq gnus-prompt-before-saving 'always) nil)
2691                (t file)))
2692              (gnus-number-of-articles-to-be-saved
2693               (when (eq gnus-prompt-before-saving t)
2694                 num)))                  ; Magic
2695         (set-buffer gnus-article-current-summary)
2696         (funcall gnus-default-article-saver filename)))))
2697
2698 (defun gnus-read-save-file-name (prompt &optional filename
2699                                         function group headers variable)
2700   (let ((default-name
2701           (funcall function group headers (symbol-value variable)))
2702         result)
2703     (setq result
2704           (expand-file-name
2705            (cond
2706             ((eq filename 'default)
2707              default-name)
2708             ((eq filename t)
2709              default-name)
2710             (filename filename)
2711             (t
2712              (let* ((split-name (gnus-get-split-value gnus-split-methods))
2713                     (prompt
2714                      (format prompt
2715                              (if (and gnus-number-of-articles-to-be-saved
2716                                       (> gnus-number-of-articles-to-be-saved 1))
2717                                  (format "these %d articles"
2718                                          gnus-number-of-articles-to-be-saved)
2719                                "this article")))
2720                     (file
2721                      ;; Let the split methods have their say.
2722                      (cond
2723                       ;; No split name was found.
2724                       ((null split-name)
2725                        (read-file-name
2726                         (concat prompt " (default "
2727                                 (file-name-nondirectory default-name) ") ")
2728                         (file-name-directory default-name)
2729                         default-name))
2730                       ;; A single group name is returned.
2731                       ((stringp split-name)
2732                        (setq default-name
2733                              (funcall function split-name headers
2734                                       (symbol-value variable)))
2735                        (read-file-name
2736                         (concat prompt " (default "
2737                                 (file-name-nondirectory default-name) ") ")
2738                         (file-name-directory default-name)
2739                         default-name))
2740                       ;; A single split name was found
2741                       ((= 1 (length split-name))
2742                        (let* ((name (expand-file-name
2743                                      (car split-name)
2744                                      gnus-article-save-directory))
2745                               (dir (cond ((file-directory-p name)
2746                                           (file-name-as-directory name))
2747                                          ((file-exists-p name) name)
2748                                          (t gnus-article-save-directory))))
2749                          (read-file-name
2750                           (concat prompt " (default " name ") ")
2751                           dir name)))
2752                       ;; A list of splits was found.
2753                       (t
2754                        (setq split-name (nreverse split-name))
2755                        (let (result)
2756                          (let ((file-name-history
2757                                 (nconc split-name file-name-history)))
2758                            (setq result
2759                                  (expand-file-name
2760                                   (read-file-name
2761                                    (concat prompt " (`M-p' for defaults) ")
2762                                    gnus-article-save-directory
2763                                    (car split-name))
2764                                   gnus-article-save-directory)))
2765                          (car (push result file-name-history)))))))
2766                ;; Create the directory.
2767                (gnus-make-directory (file-name-directory file))
2768       ;; If we have read a directory, we append the default file name.
2769                (when (file-directory-p file)
2770                  (setq file (expand-file-name (file-name-nondirectory
2771                                                default-name)
2772                                               (file-name-as-directory file))))
2773                ;; Possibly translate some characters.
2774                (nnheader-translate-file-chars file))))))
2775     (gnus-make-directory (file-name-directory result))
2776     (set variable result)))
2777
2778 (defun gnus-article-archive-name (group)
2779   "Return the first instance of an \"Archive-name\" in the current buffer."
2780   (let ((case-fold-search t))
2781     (when (re-search-forward "archive-name: *\\([^ \n\t]+\\)[ \t]*$" nil t)
2782       (nnheader-concat gnus-article-save-directory
2783                        (match-string 1)))))
2784
2785 (defun gnus-article-nndoc-name (group)
2786   "If GROUP is an nndoc group, return the name of the parent group."
2787   (when (eq (car (gnus-find-method-for-group group)) 'nndoc)
2788     (gnus-group-get-parameter group 'save-article-group)))
2789
2790 (defun gnus-summary-save-in-rmail (&optional filename)
2791   "Append this article to Rmail file.
2792 Optional argument FILENAME specifies file name.
2793 Directory to save to is default to `gnus-article-save-directory'."
2794   (setq filename (gnus-read-save-file-name
2795                   "Save %s in rmail file:" filename
2796                   gnus-rmail-save-name gnus-newsgroup-name
2797                   gnus-current-headers 'gnus-newsgroup-last-rmail))
2798   (gnus-eval-in-buffer-window gnus-save-article-buffer
2799     (save-excursion
2800       (save-restriction
2801         (widen)
2802         (gnus-output-to-rmail filename))))
2803   filename)
2804
2805 (defun gnus-summary-save-in-mail (&optional filename)
2806   "Append this article to Unix mail file.
2807 Optional argument FILENAME specifies file name.
2808 Directory to save to is default to `gnus-article-save-directory'."
2809   (setq filename (gnus-read-save-file-name
2810                   "Save %s in Unix mail file:" filename
2811                   gnus-mail-save-name gnus-newsgroup-name
2812                   gnus-current-headers 'gnus-newsgroup-last-mail))
2813   (gnus-eval-in-buffer-window gnus-save-article-buffer
2814     (save-excursion
2815       (save-restriction
2816         (widen)
2817         (if (and (file-readable-p filename)
2818                  (mail-file-babyl-p filename))
2819             (rmail-output-to-rmail-file filename t)
2820           (gnus-output-to-mail filename)))))
2821   filename)
2822
2823 (defun gnus-summary-save-in-file (&optional filename overwrite)
2824   "Append this article to file.
2825 Optional argument FILENAME specifies file name.
2826 Directory to save to is default to `gnus-article-save-directory'."
2827   (setq filename (gnus-read-save-file-name
2828                   "Save %s in file:" filename
2829                   gnus-file-save-name gnus-newsgroup-name
2830                   gnus-current-headers 'gnus-newsgroup-last-file))
2831   (gnus-eval-in-buffer-window gnus-save-article-buffer
2832     (save-excursion
2833       (save-restriction
2834         (widen)
2835         (when (and overwrite
2836                    (file-exists-p filename))
2837           (delete-file filename))
2838         (gnus-output-to-file filename))))
2839   filename)
2840
2841 (defun gnus-summary-write-to-file (&optional filename)
2842   "Write this article to a file.
2843 Optional argument FILENAME specifies file name.
2844 The directory to save in defaults to `gnus-article-save-directory'."
2845   (gnus-summary-save-in-file nil t))
2846
2847 (defun gnus-summary-save-body-in-file (&optional filename)
2848   "Append this article body to a file.
2849 Optional argument FILENAME specifies file name.
2850 The directory to save in defaults to `gnus-article-save-directory'."
2851   (setq filename (gnus-read-save-file-name
2852                   "Save %s body in file:" filename
2853                   gnus-file-save-name gnus-newsgroup-name
2854                   gnus-current-headers 'gnus-newsgroup-last-file))
2855   (gnus-eval-in-buffer-window gnus-save-article-buffer
2856     (save-excursion
2857       (save-restriction
2858         (widen)
2859         (when (article-goto-body)
2860           (narrow-to-region (point) (point-max)))
2861         (gnus-output-to-file filename))))
2862   filename)
2863
2864 (defun gnus-summary-save-in-pipe (&optional command)
2865   "Pipe this article to subprocess."
2866   (setq command
2867         (cond ((and (eq command 'default)
2868                     gnus-last-shell-command)
2869                gnus-last-shell-command)
2870               ((stringp command)
2871                command)
2872               (t (read-string
2873                   (format
2874                    "Shell command on %s: "
2875                    (if (and gnus-number-of-articles-to-be-saved
2876                             (> gnus-number-of-articles-to-be-saved 1))
2877                        (format "these %d articles"
2878                                gnus-number-of-articles-to-be-saved)
2879                      "this article"))
2880                   gnus-last-shell-command))))
2881   (when (string-equal command "")
2882     (if gnus-last-shell-command
2883         (setq command gnus-last-shell-command)
2884       (error "A command is required.")))
2885   (gnus-eval-in-buffer-window gnus-article-buffer
2886     (save-restriction
2887       (widen)
2888       (shell-command-on-region (point-min) (point-max) command nil)))
2889   (setq gnus-last-shell-command command))
2890
2891 ;;; Article file names when saving.
2892
2893 (defun gnus-capitalize-newsgroup (newsgroup)
2894   "Capitalize NEWSGROUP name."
2895   (when (not (zerop (length newsgroup)))
2896     (concat (char-to-string (upcase (aref newsgroup 0)))
2897             (substring newsgroup 1))))
2898
2899 (defun gnus-Numeric-save-name (newsgroup headers &optional last-file)
2900   "Generate file name from NEWSGROUP, HEADERS, and optional LAST-FILE.
2901 If variable `gnus-use-long-file-name' is non-nil, it is ~/News/News.group/num.
2902 Otherwise, it is like ~/News/news/group/num."
2903   (let ((default
2904           (expand-file-name
2905            (concat (if (gnus-use-long-file-name 'not-save)
2906                        (gnus-capitalize-newsgroup newsgroup)
2907                      (gnus-newsgroup-directory-form newsgroup))
2908                    "/" (int-to-string (mail-header-number headers)))
2909            gnus-article-save-directory)))
2910     (if (and last-file
2911              (string-equal (file-name-directory default)
2912                            (file-name-directory last-file))
2913              (string-match "^[0-9]+$" (file-name-nondirectory last-file)))
2914         default
2915       (or last-file default))))
2916
2917 (defun gnus-numeric-save-name (newsgroup headers &optional last-file)
2918   "Generate file name from NEWSGROUP, HEADERS, and optional LAST-FILE.
2919 If variable `gnus-use-long-file-name' is non-nil, it is
2920 ~/News/news.group/num.  Otherwise, it is like ~/News/news/group/num."
2921   (let ((default
2922           (expand-file-name
2923            (concat (if (gnus-use-long-file-name 'not-save)
2924                        newsgroup
2925                      (gnus-newsgroup-directory-form newsgroup))
2926                    "/" (int-to-string (mail-header-number headers)))
2927            gnus-article-save-directory)))
2928     (if (and last-file
2929              (string-equal (file-name-directory default)
2930                            (file-name-directory last-file))
2931              (string-match "^[0-9]+$" (file-name-nondirectory last-file)))
2932         default
2933       (or last-file default))))
2934
2935 (defun gnus-plain-save-name (newsgroup headers &optional last-file)
2936   "Generate file name from NEWSGROUP, HEADERS, and optional LAST-FILE.
2937 If variable `gnus-use-long-file-name' is non-nil, it is
2938 ~/News/news.group.  Otherwise, it is like ~/News/news/group/news."
2939   (or last-file
2940       (expand-file-name
2941        (if (gnus-use-long-file-name 'not-save)
2942            newsgroup
2943          (expand-file-name "news" (gnus-newsgroup-directory-form newsgroup)))
2944        gnus-article-save-directory)))
2945
2946 (defun article-verify-x-pgp-sig ()
2947   "Verify X-PGP-Sig."
2948   (interactive)
2949   (if (gnus-buffer-live-p gnus-original-article-buffer)
2950       (let ((sig (with-current-buffer gnus-original-article-buffer
2951                    (gnus-fetch-field "X-PGP-Sig")))
2952             items info headers)
2953         (when (and sig
2954                    mml2015-use
2955                    (mml2015-clear-verify-function))
2956           (with-temp-buffer
2957             (insert-buffer gnus-original-article-buffer)
2958             (setq items (split-string sig))
2959             (message-narrow-to-head)
2960             (let ((inhibit-point-motion-hooks t)
2961                   (case-fold-search t))
2962               ;; Don't verify multiple headers.
2963               (setq headers (mapconcat (lambda (header)
2964                                          (concat header ": "
2965                                                  (mail-fetch-field header) "\n"))
2966                                        (split-string (nth 1 items) ",") "")))
2967             (delete-region (point-min) (point-max))
2968             (insert "-----BEGIN PGP SIGNED MESSAGE-----\n\n")
2969             (insert "X-Signed-Headers: " (nth 1 items) "\n")
2970             (insert headers)
2971             (widen)
2972             (forward-line)
2973             (while (not (eobp))
2974               (if (looking-at "^-")
2975                   (insert "- "))
2976               (forward-line))
2977             (insert "\n-----BEGIN PGP SIGNATURE-----\n")
2978             (insert "Version: " (car items) "\n\n")
2979             (insert (mapconcat 'identity (cddr items) "\n"))
2980             (insert "\n-----END PGP SIGNATURE-----\n")
2981             (let ((mm-security-handle (list (format "multipart/signed"))))
2982               (mml2015-clean-buffer)
2983               (let ((coding-system-for-write (or gnus-newsgroup-charset
2984                                                  'iso-8859-1)))
2985                 (funcall (mml2015-clear-verify-function)))
2986               (setq info
2987                     (or (mm-handle-multipart-ctl-parameter
2988                          mm-security-handle 'gnus-details)
2989                         (mm-handle-multipart-ctl-parameter
2990                          mm-security-handle 'gnus-info)))))
2991           (when info
2992             (let (buffer-read-only bface eface)
2993               (save-restriction
2994                 (message-narrow-to-head)
2995                 (goto-char (point-max))
2996                 (forward-line -1)
2997                 (setq bface (get-text-property (gnus-point-at-bol) 'face)
2998                       eface (get-text-property (1- (gnus-point-at-eol)) 'face))
2999                 (message-remove-header "X-Gnus-PGP-Verify")
3000                 (if (re-search-forward "^X-PGP-Sig:" nil t)
3001                     (forward-line)
3002                   (goto-char (point-max)))
3003                 (narrow-to-region (point) (point))
3004                 (insert "X-Gnus-PGP-Verify: " info "\n")
3005                 (goto-char (point-min))
3006                 (forward-line)
3007                 (while (not (eobp))
3008                   (if (not (looking-at "^[ \t]"))
3009                       (insert " "))
3010                   (forward-line))
3011                 ;; Do highlighting.
3012                 (goto-char (point-min))
3013                 (when (looking-at "\\([^:]+\\): *")
3014                   (put-text-property (match-beginning 1) (1+ (match-end 1))
3015                                      'face bface)
3016                   (put-text-property (match-end 0) (point-max)
3017                                      'face eface)))))))))
3018
3019 (eval-and-compile
3020   (mapcar
3021    (lambda (func)
3022      (let (afunc gfunc)
3023        (if (consp func)
3024            (setq afunc (car func)
3025                  gfunc (cdr func))
3026          (setq afunc func
3027                gfunc (intern (format "gnus-%s" func))))
3028        (defalias gfunc
3029          (if (fboundp afunc)
3030            `(lambda (&optional interactive &rest args)
3031               ,(documentation afunc t)
3032               (interactive (list t))
3033               (save-excursion
3034                 (set-buffer gnus-article-buffer)
3035                 (if interactive
3036                     (call-interactively ',afunc)
3037                   (apply ',afunc args))))))))
3038    '(article-hide-headers
3039      article-verify-x-pgp-sig
3040      article-hide-boring-headers
3041      article-toggle-headers
3042      article-treat-overstrike
3043      article-fill-long-lines
3044      article-capitalize-sentences
3045      article-remove-cr
3046      article-display-x-face
3047      article-de-quoted-unreadable
3048      article-de-base64-unreadable
3049      article-decode-HZ
3050      article-wash-html
3051      article-hide-list-identifiers
3052      article-hide-pgp
3053      article-strip-banner
3054      article-babel
3055      article-hide-pem
3056      article-hide-signature
3057      article-strip-headers-in-body
3058      article-remove-trailing-blank-lines
3059      article-strip-leading-blank-lines
3060      article-strip-multiple-blank-lines
3061      article-strip-leading-space
3062      article-strip-trailing-space
3063      article-strip-blank-lines
3064      article-strip-all-blank-lines
3065      article-date-local
3066      article-date-english
3067      article-date-iso8601
3068      article-date-original
3069      article-date-ut
3070      article-decode-mime-words
3071      article-decode-charset
3072      article-decode-encoded-words
3073      article-date-user
3074      article-date-lapsed
3075      article-emphasize
3076      article-treat-dumbquotes
3077      article-normalize-headers
3078      (article-show-all-headers . gnus-article-show-all-headers)
3079      (article-show-all . gnus-article-show-all))))
3080 \f
3081 ;;;
3082 ;;; Gnus article mode
3083 ;;;
3084
3085 (put 'gnus-article-mode 'mode-class 'special)
3086
3087 (gnus-define-keys gnus-article-mode-map
3088   " " gnus-article-goto-next-page
3089   "\177" gnus-article-goto-prev-page
3090   [delete] gnus-article-goto-prev-page
3091   [backspace] gnus-article-goto-prev-page
3092   "\C-c^" gnus-article-refer-article
3093   "h" gnus-article-show-summary
3094   "s" gnus-article-show-summary
3095   "\C-c\C-m" gnus-article-mail
3096   "?" gnus-article-describe-briefly
3097   "e" gnus-summary-edit-article
3098   "<" beginning-of-buffer
3099   ">" end-of-buffer
3100   "\C-c\C-i" gnus-info-find-node
3101   "\C-c\C-b" gnus-bug
3102   "\C-hk" gnus-article-describe-key
3103   "\C-hc" gnus-article-describe-key-briefly
3104
3105   "\C-d" gnus-article-read-summary-keys
3106   "\M-*" gnus-article-read-summary-keys
3107   "\M-#" gnus-article-read-summary-keys
3108   "\M-^" gnus-article-read-summary-keys
3109   "\M-g" gnus-article-read-summary-keys)
3110
3111 ;; Define almost undefined keys to `gnus-article-read-summary-keys'.
3112 (mapcar
3113  (lambda (key)
3114    (unless (lookup-key gnus-article-mode-map key)
3115      (define-key gnus-article-mode-map key
3116        'gnus-article-read-summary-keys)))
3117  (delq nil
3118        (append
3119         (mapcar
3120          (lambda (elt)
3121            (let ((key (car elt)))
3122              (and (> (length key) 0)
3123                   (not (eq 'menu-bar (aref key 0)))
3124                   (symbolp (lookup-key gnus-summary-mode-map key))
3125                   key)))
3126          (accessible-keymaps gnus-summary-mode-map))
3127         (let ((c 127)
3128               keys)
3129           (while (>= c 32)
3130             (push (char-to-string c) keys)
3131             (decf c))
3132           keys))))
3133
3134 (eval-when-compile
3135   (defvar gnus-article-commands-menu))
3136
3137 (defvar gnus-article-post-menu nil)
3138
3139 (defun gnus-article-make-menu-bar ()
3140   (gnus-turn-off-edit-menu 'article)
3141   (unless (boundp 'gnus-article-article-menu)
3142     (easy-menu-define
3143      gnus-article-article-menu gnus-article-mode-map ""
3144      '("Article"
3145        ["Scroll forwards" gnus-article-goto-next-page t]
3146        ["Scroll backwards" gnus-article-goto-prev-page t]
3147        ["Show summary" gnus-article-show-summary t]
3148        ["Fetch Message-ID at point" gnus-article-refer-article t]
3149        ["Mail to address at point" gnus-article-mail t]
3150        ["Send a bug report" gnus-bug t]))
3151
3152     (easy-menu-define
3153      gnus-article-treatment-menu gnus-article-mode-map ""
3154      ;; Fixme: this should use :active (and maybe :visible).
3155      '("Treatment"
3156        ["Hide headers" gnus-article-toggle-headers t]
3157        ["Hide signature" gnus-article-hide-signature t]
3158        ["Hide citation" gnus-article-hide-citation t]
3159        ["Treat overstrike" gnus-article-treat-overstrike t]
3160        ["Remove carriage return" gnus-article-remove-cr t]
3161        ["Decode HZ" gnus-article-decode-HZ t]))
3162
3163     ;; Note "Commands" menu is defined in gnus-sum.el for consistency
3164
3165     (when (boundp 'gnus-summary-post-menu)
3166       (cond
3167        ((not (keymapp gnus-summary-post-menu))
3168         (setq gnus-article-post-menu gnus-summary-post-menu))
3169        ((not gnus-article-post-menu)
3170         ;; Don't share post menu.
3171         (setq gnus-article-post-menu
3172               (copy-keymap gnus-summary-post-menu))))
3173       (define-key gnus-article-mode-map [menu-bar post]
3174         (cons "Post" gnus-article-post-menu)))
3175
3176     (gnus-run-hooks 'gnus-article-menu-hook))
3177   ;; Add the menu.
3178   (when (boundp 'gnus-article-commands-menu)
3179     (easy-menu-add gnus-article-commands-menu gnus-article-mode-map)))
3180
3181 ;; Fixme: do something for the Emacs tool bar in Article mode a la
3182 ;; Summary.
3183
3184 (defun gnus-article-mode ()
3185   "Major mode for displaying an article.
3186
3187 All normal editing commands are switched off.
3188
3189 The following commands are available in addition to all summary mode
3190 commands:
3191 \\<gnus-article-mode-map>
3192 \\[gnus-article-next-page]\t Scroll the article one page forwards
3193 \\[gnus-article-prev-page]\t Scroll the article one page backwards
3194 \\[gnus-article-refer-article]\t Go to the article referred to by an article id near point
3195 \\[gnus-article-show-summary]\t Display the summary buffer
3196 \\[gnus-article-mail]\t Send a reply to the address near point
3197 \\[gnus-article-describe-briefly]\t Describe the current mode briefly
3198 \\[gnus-info-find-node]\t Go to the Gnus info node"
3199   (interactive)
3200   (gnus-simplify-mode-line)
3201   (setq mode-name "Article")
3202   (setq major-mode 'gnus-article-mode)
3203   (make-local-variable 'minor-mode-alist)
3204   (unless (assq 'gnus-show-mime minor-mode-alist)
3205     (push (list 'gnus-show-mime " MIME") minor-mode-alist))
3206   (use-local-map gnus-article-mode-map)
3207   (when (gnus-visual-p 'article-menu 'menu)
3208     (gnus-article-make-menu-bar))
3209   (gnus-update-format-specifications nil 'article-mode)
3210   (set (make-local-variable 'page-delimiter) gnus-page-delimiter)
3211   (make-local-variable 'gnus-page-broken)
3212   (make-local-variable 'gnus-button-marker-list)
3213   (make-local-variable 'gnus-article-current-summary)
3214   (make-local-variable 'gnus-article-mime-handles)
3215   (make-local-variable 'gnus-article-decoded-p)
3216   (make-local-variable 'gnus-article-mime-handle-alist)
3217   (make-local-variable 'gnus-article-wash-types)
3218   (make-local-variable 'gnus-article-charset)
3219   (make-local-variable 'gnus-article-ignored-charsets)
3220   (gnus-set-default-directory)
3221   (buffer-disable-undo)
3222   (setq buffer-read-only t)
3223   (set-syntax-table gnus-article-mode-syntax-table)
3224   (gnus-run-hooks 'gnus-article-mode-hook))
3225
3226 (defun gnus-article-setup-buffer ()
3227   "Initialize the article buffer."
3228   (let* ((name (if gnus-single-article-buffer "*Article*"
3229                  (concat "*Article " gnus-newsgroup-name "*")))
3230          (original
3231           (progn (string-match "\\*Article" name)
3232                  (concat " *Original Article"
3233                          (substring name (match-end 0))))))
3234     (setq gnus-article-buffer name)
3235     (setq gnus-original-article-buffer original)
3236     (setq gnus-article-mime-handle-alist nil)
3237     ;; This might be a variable local to the summary buffer.
3238     (unless gnus-single-article-buffer
3239       (save-excursion
3240         (set-buffer gnus-summary-buffer)
3241         (setq gnus-article-buffer name)
3242         (setq gnus-original-article-buffer original)
3243         (gnus-set-global-variables)))
3244     (gnus-article-setup-highlight-words)
3245     ;; Init original article buffer.
3246     (save-excursion
3247       (set-buffer (gnus-get-buffer-create gnus-original-article-buffer))
3248       (set-buffer-multibyte nil)
3249       (setq major-mode 'gnus-original-article-mode)
3250       (make-local-variable 'gnus-original-article))
3251     (if (get-buffer name)
3252         (save-excursion
3253           (set-buffer name)
3254           (buffer-disable-undo)
3255           (setq buffer-read-only t)
3256           (unless (eq major-mode 'gnus-article-mode)
3257             (gnus-article-mode))
3258           (current-buffer))
3259       (save-excursion
3260         (set-buffer (gnus-get-buffer-create name))
3261         (gnus-article-mode)
3262         (make-local-variable 'gnus-summary-buffer)
3263         (gnus-summary-set-local-parameters gnus-newsgroup-name)
3264         (current-buffer)))))
3265
3266 ;; Set article window start at LINE, where LINE is the number of lines
3267 ;; from the head of the article.
3268 (defun gnus-article-set-window-start (&optional line)
3269   (set-window-start
3270    (get-buffer-window gnus-article-buffer t)
3271    (save-excursion
3272      (set-buffer gnus-article-buffer)
3273      (goto-char (point-min))
3274      (if (not line)
3275          (point-min)
3276        (gnus-message 6 "Moved to bookmark")
3277        (search-forward "\n\n" nil t)
3278        (forward-line line)
3279        (point)))))
3280
3281 ;;; @@ article filters
3282 ;;;
3283
3284 (defun gnus-article-display-mime-message ()
3285   "Article display method for MIME message."
3286   ;; called from `gnus-original-article-buffer'.
3287   (let (charset all-headers)
3288     (with-current-buffer gnus-summary-buffer
3289       (setq charset default-mime-charset
3290             all-headers gnus-have-all-headers))
3291     (make-local-variable 'default-mime-charset)
3292     (setq default-mime-charset charset)
3293     (with-current-buffer (get-buffer-create gnus-article-buffer)
3294       (make-local-variable 'default-mime-charset)
3295       (setq default-mime-charset charset))
3296     (mime-display-message mime-message-structure
3297                           gnus-article-buffer nil gnus-article-mode-map)
3298     (when all-headers
3299       (gnus-article-hide-headers nil -1)))
3300   (run-hooks 'gnus-mime-article-prepare-hook))
3301
3302 (defun gnus-article-display-traditional-message ()
3303   "Article display method for traditional message."
3304   (set-buffer gnus-article-buffer)
3305   (let (buffer-read-only)
3306     (erase-buffer)
3307     (insert-buffer-substring gnus-original-article-buffer)))
3308
3309 (defun gnus-article-make-full-mail-header (&optional number charset)
3310   "Create a new mail header structure in a raw article buffer."
3311   (unless (and number charset)
3312     (save-current-buffer
3313       (set-buffer gnus-summary-buffer)
3314       (unless number
3315         (setq number (or (cdr gnus-article-current) 0)))
3316       (unless charset
3317         (setq charset (or default-mime-charset 'x-ctext)))))
3318   (goto-char (point-min))
3319   (let ((header-end (if (search-forward "\n\n" nil t)
3320                         (1- (point))
3321                       (goto-char (point-max))))
3322         (chars (- (point-max) (point)))
3323         (lines (count-lines (point) (point-max)))
3324         (default-mime-charset charset)
3325         xref)
3326     (narrow-to-region (point-min) header-end)
3327     (setq xref (std11-fetch-field "xref"))
3328     (prog1
3329         (make-full-mail-header
3330          number
3331          (std11-fetch-field "subject")
3332          (std11-fetch-field "from")
3333          (std11-fetch-field "date")
3334          (std11-fetch-field "message-id")
3335          (std11-fetch-field "references")
3336          chars
3337          lines
3338          (when xref (concat "Xref: " xref)))
3339       (widen))))
3340
3341 (defun gnus-article-prepare (article &optional all-headers header)
3342   "Prepare ARTICLE in article mode buffer.
3343 ARTICLE should either be an article number or a Message-ID.
3344 If ARTICLE is an id, HEADER should be the article headers.
3345 If ALL-HEADERS is non-nil, no headers are hidden."
3346   (save-excursion
3347     ;; Make sure we start in a summary buffer.
3348     (unless (eq major-mode 'gnus-summary-mode)
3349       (set-buffer gnus-summary-buffer))
3350     (setq gnus-summary-buffer (current-buffer))
3351     (let* ((gnus-article (if header (mail-header-number header) article))
3352            (summary-buffer (current-buffer))
3353            (gnus-tmp-internal-hook gnus-article-internal-prepare-hook)
3354            (group gnus-newsgroup-name)
3355            result)
3356       (save-excursion
3357         (gnus-article-setup-buffer)
3358         (set-buffer gnus-original-article-buffer)
3359         ;; Deactivate active regions.
3360         (when (and (boundp 'transient-mark-mode)
3361                    transient-mark-mode)
3362           (setq mark-active nil))
3363         (if (not (setq result (let ((buffer-read-only nil))
3364                                 (gnus-request-article-this-buffer
3365                                  article group))))
3366             ;; There is no such article.
3367             (save-excursion
3368               (when (and (numberp article)
3369                          (not (memq article gnus-newsgroup-sparse)))
3370                 (setq gnus-article-current
3371                       (cons gnus-newsgroup-name article))
3372                 (set-buffer gnus-summary-buffer)
3373                 (setq gnus-current-article article)
3374                 (if (eq (gnus-article-mark article) gnus-undownloaded-mark)
3375                     (progn
3376                       (gnus-summary-set-agent-mark article)
3377                       (message "Message marked for downloading"))
3378                   (gnus-summary-mark-article article gnus-canceled-mark)
3379                   (unless (memq article gnus-newsgroup-sparse)
3380                     (gnus-error 1 "No such article (may have expired or been canceled)")))))
3381           (if (or (eq result 'pseudo)
3382                   (eq result 'nneething))
3383               (progn
3384                 (save-excursion
3385                   (set-buffer summary-buffer)
3386                   (push article gnus-newsgroup-history)
3387                   (setq gnus-last-article gnus-current-article
3388                         gnus-current-article 0
3389                         gnus-current-headers nil
3390                         gnus-article-current nil)
3391                   (if (eq result 'nneething)
3392                       (gnus-configure-windows 'summary)
3393                     (gnus-configure-windows 'article))
3394                   (gnus-set-global-variables))
3395                 (let ((gnus-article-mime-handle-alist-1
3396                        gnus-article-mime-handle-alist))
3397                   (gnus-set-mode-line 'article)))
3398             ;; The result from the `request' was an actual article -
3399             ;; or at least some text that is now displayed in the
3400             ;; article buffer.
3401             (when (and (numberp article)
3402                        (not (eq article gnus-current-article)))
3403               ;; Seems like a new article has been selected.
3404               ;; `gnus-current-article' must be an article number.
3405               (save-excursion
3406                 (set-buffer summary-buffer)
3407                 (push article gnus-newsgroup-history)
3408                 (setq gnus-last-article gnus-current-article
3409                       gnus-current-article article
3410                       gnus-current-headers
3411                       (gnus-summary-article-header gnus-current-article)
3412                       gnus-article-current
3413                       (cons gnus-newsgroup-name gnus-current-article))
3414                 (unless (vectorp gnus-current-headers)
3415                   (setq gnus-current-headers nil))
3416                 (gnus-summary-goto-subject gnus-current-article)
3417                 (when (gnus-summary-show-thread)
3418                   ;; If the summary buffer really was folded, the
3419                   ;; previous goto may not actually have gone to
3420                   ;; the right article, but the thread root instead.
3421                   ;; So we go again.
3422                   (gnus-summary-goto-subject gnus-current-article))
3423                 (gnus-run-hooks 'gnus-mark-article-hook)
3424                 (gnus-set-mode-line 'summary)
3425                 (when (gnus-visual-p 'article-highlight 'highlight)
3426                   (gnus-run-hooks 'gnus-visual-mark-article-hook))
3427                 ;; Set the global newsgroup variables here.
3428                 (gnus-set-global-variables)
3429                 (setq gnus-have-all-headers
3430                       (or all-headers gnus-show-all-headers))))
3431             (save-excursion
3432               (gnus-configure-windows 'article))
3433             (when (or (numberp article)
3434                       (stringp article))
3435               (gnus-article-prepare-display)
3436               ;; Do page break.
3437               (goto-char (point-min))
3438               (setq gnus-page-broken
3439                     (when gnus-break-pages
3440                       (gnus-narrow-to-page)
3441                       t)))
3442             (let ((gnus-article-mime-handle-alist-1
3443                    gnus-article-mime-handle-alist))
3444               (gnus-set-mode-line 'article))
3445             (article-goto-body)
3446             (set-window-point (get-buffer-window (current-buffer)) (point))
3447             (gnus-configure-windows 'article)
3448             t))))))
3449
3450 (defun gnus-article-prepare-mime-display (&optional number)
3451   (goto-char (point-min))
3452   (when (re-search-forward "^[^\t ]+:" nil t)
3453     (goto-char (match-beginning 0)))
3454   (let ((entity (if (eq 1 (point-min))
3455                     (get-text-property 1 'mime-view-entity)
3456                   (get-text-property (point) 'mime-view-entity)))
3457         last-entity child-entity next type)
3458     (setq child-entity (mime-entity-children entity))
3459     (if child-entity
3460         (setq last-entity (nth (1- (length child-entity))
3461                                child-entity))
3462       (setq last-entity entity))
3463     (save-restriction
3464       (narrow-to-region (point)
3465                         (if (search-forward "\n\n" nil t)
3466                             (point)
3467                           (point-max)))
3468       (gnus-treat-article 'head)
3469       (put-text-property (point-min) (point-max) 'article-treated-header t)
3470       (goto-char (point-max)))
3471     (while (and (not (eobp)) entity)
3472       (setq next (set-marker
3473                   (make-marker)
3474                   (next-single-property-change (point) 'mime-view-entity
3475                                                nil (point-max))))
3476       (let ((types (mime-entity-content-type entity)))
3477         (while (eq 'multipart (mime-content-type-primary-type types))
3478           (setq entity (car (mime-entity-children entity))
3479                 types (mime-entity-content-type entity)))
3480         (when types
3481           (setq type (format "%s/%s"
3482                              (mime-content-type-primary-type types)
3483                              (mime-content-type-subtype types)))))
3484       (if (string-equal type "message/rfc822")
3485           (progn
3486             (setq next (point))
3487             (let ((children (mime-entity-children entity))
3488                   last-children)
3489               (when children
3490                 (setq last-children (nth (1- (length children)) children))
3491                 (while
3492                     (and
3493                      (not (eq last-children
3494                               (get-text-property next 'mime-view-entity)))
3495                      (setq next
3496                            (next-single-property-change next
3497                                                         'mime-view-entity
3498                                                         nil (point-max)))))))
3499             (setq next (next-single-property-change next 'mime-view-entity
3500                                                     nil (point-max)))
3501             (save-restriction
3502               (narrow-to-region (point) next)
3503               (gnus-article-prepare-mime-display)
3504               (goto-char (point-max)))
3505             (setq entity (get-text-property (point) 'mime-view-entity)))
3506         (save-restriction
3507           (narrow-to-region (point) next)
3508           ;; Kludge. We have to count true number, but for now,
3509           ;; part number is here only to achieve `last'.
3510           (gnus-treat-article nil 1
3511                               (if (eq entity last-entity)
3512                                   1 2)
3513                               type)
3514           (goto-char (point-max)))
3515         (setq entity (get-text-property next 'mime-view-entity))))))
3516
3517 ;;;###autoload
3518 (defun gnus-article-prepare-display ()
3519   "Make the current buffer look like a nice article."
3520   (setq gnus-article-wash-types nil)
3521   (gnus-run-hooks 'gnus-tmp-internal-hook)
3522   (gnus-run-hooks 'gnus-article-prepare-hook)
3523   ;; Display message.
3524   (let (mime-display-header-hook mime-display-text/plain-hook)
3525     (funcall (if gnus-show-mime
3526                  (progn
3527                    (setq mime-message-structure gnus-current-headers)
3528                    (mime-buffer-entity-set-buffer-internal
3529                     mime-message-structure
3530                     gnus-original-article-buffer)
3531                    (mime-entity-set-representation-type-internal
3532                     mime-message-structure 'mime-buffer-entity)
3533                    (luna-send mime-message-structure
3534                               'initialize-instance
3535                               mime-message-structure)
3536                    gnus-article-display-method-for-mime)
3537                gnus-article-display-method-for-traditional)))
3538   ;; Associate this article with the current summary buffer.
3539   (setq gnus-article-current-summary gnus-summary-buffer)
3540   ;; Call the treatment functions.
3541   (let ((inhibit-read-only t)
3542         buffer-read-only)
3543     (save-restriction
3544       (widen)
3545       (if gnus-show-mime
3546           (gnus-article-prepare-mime-display)
3547         (narrow-to-region (goto-char (point-min))
3548                           (if (search-forward "\n\n" nil t)
3549                               (point)
3550                             (point-max)))
3551         (gnus-treat-article 'head)
3552         (put-text-property (point-min) (point-max) 'article-treated-header t)
3553         (goto-char (point-max))
3554         (widen)
3555         (narrow-to-region (point) (point-max))
3556         (gnus-treat-article nil))
3557       (put-text-property (point-min) (point-max) 'read-only nil)))
3558   ;; Perform the article display hooks.  Incidentally, this hook is
3559   ;; an obsolete variable by now.
3560   (gnus-run-hooks 'gnus-article-display-hook))
3561
3562 (defun gnus-article-decode-article-as-default-mime-charset ()
3563   "Decode an article as `default-mime-charset'.  It won't work if the
3564 value of the variable `gnus-show-mime' is non-nil."
3565   (unless gnus-show-mime
3566     (decode-mime-charset-region (point-min) (point-max)
3567                                 (with-current-buffer gnus-summary-buffer
3568                                   default-mime-charset))))
3569
3570 ;;;
3571 ;;; Gnus MIME viewing functions
3572 ;;;
3573
3574 (defvar gnus-mime-button-line-format "%{%([%p. %d%T]%)%}%e\n"
3575   "The following specs can be used:
3576 %t  The MIME type
3577 %T  MIME type, along with additional info
3578 %n  The `name' parameter
3579 %d  The description, if any
3580 %l  The length of the encoded part
3581 %p  The part identifier number
3582 %e  Dots if the part isn't displayed")
3583
3584 (defvar gnus-mime-button-line-format-alist
3585   '((?t gnus-tmp-type ?s)
3586     (?T gnus-tmp-type-long ?s)
3587     (?n gnus-tmp-name ?s)
3588     (?d gnus-tmp-description ?s)
3589     (?p gnus-tmp-id ?s)
3590     (?l gnus-tmp-length ?d)
3591     (?e gnus-tmp-dots ?s)))
3592
3593 (defvar gnus-mime-button-commands
3594   '((gnus-article-press-button "\r" "Toggle Display")
3595     (gnus-mime-view-part "v" "View Interactively...")
3596     (gnus-mime-view-part-as-type "t" "View As Type...")
3597     (gnus-mime-view-part-as-charset "C" "View As charset...")
3598     (gnus-mime-save-part "o" "Save...")
3599     (gnus-mime-save-part-and-strip "\C-o" "Save and Strip")
3600     (gnus-mime-copy-part "c" "View As Text, In Other Buffer")
3601     (gnus-mime-inline-part "i" "View As Text, In This Buffer")
3602     (gnus-mime-internalize-part "E" "View Internally")
3603     (gnus-mime-externalize-part "e" "View Externally")
3604     (gnus-mime-pipe-part "|" "Pipe To Command...")
3605     (gnus-mime-action-on-part "." "Take action on the part")))
3606
3607 (defun gnus-article-mime-part-status ()
3608   (with-current-buffer gnus-article-buffer
3609     (let ((entity (get-text-property (point-min) 'mime-view-entity)))
3610       (if (and entity (mime-entity-children entity))
3611           (format " (%d parts)" (length (mime-entity-children entity)))
3612         ""))))
3613
3614 (defvar gnus-mime-button-map
3615   (let ((map (make-sparse-keymap)))
3616     (unless (>= (string-to-number emacs-version) 21)
3617       ;; XEmacs doesn't care.
3618       (set-keymap-parent map gnus-article-mode-map))
3619     (define-key map gnus-mouse-2 'gnus-article-push-button)
3620     (define-key map gnus-down-mouse-3 'gnus-mime-button-menu)
3621     (dolist (c gnus-mime-button-commands)
3622       (define-key map (cadr c) (car c)))
3623     map))
3624
3625 (defun gnus-mime-button-menu (event)
3626   "Construct a context-sensitive menu of MIME commands."
3627   (interactive "e")
3628   (save-window-excursion
3629     (let ((pos (event-start event)))
3630       (select-window (posn-window pos))
3631       (goto-char (posn-point pos))
3632       (gnus-article-check-buffer)
3633       (let ((response (x-popup-menu
3634                        t `("MIME Part"
3635                            ("" ,@(mapcar (lambda (c)
3636                                            (cons (caddr c) (car c)))
3637                                          gnus-mime-button-commands))))))
3638         (if response
3639             (call-interactively response))))))
3640
3641 (defun gnus-mime-view-all-parts (&optional handles)
3642   "View all the MIME parts."
3643   (interactive)
3644   (save-current-buffer
3645     (set-buffer gnus-article-buffer)
3646     (let ((handles (or handles gnus-article-mime-handles))
3647           (mail-parse-charset gnus-newsgroup-charset)
3648           (mail-parse-ignored-charsets
3649            (with-current-buffer gnus-summary-buffer
3650              gnus-newsgroup-ignored-charsets)))
3651       (when handles
3652         (mm-remove-parts handles)
3653         (goto-char (point-min))
3654         (or (search-forward "\n\n") (goto-char (point-max)))
3655         (let (buffer-read-only)
3656           (delete-region (point) (point-max)))
3657         (mm-display-parts handles)))))
3658
3659 (defun gnus-mime-save-part-and-strip ()
3660   "Save the MIME part under point then replace it with an external body."
3661   (interactive)
3662   (gnus-article-check-buffer)
3663   (let* ((data (get-text-property (point) 'gnus-data))
3664          (file (and data (mm-save-part data)))
3665          param)
3666     (when file
3667       (with-current-buffer (mm-handle-buffer data)
3668         (erase-buffer)
3669         (insert "Content-Type: " (mm-handle-media-type data))
3670         (mml-insert-parameter-string (cdr (mm-handle-type data))
3671                                      '(charset))
3672         (insert "\n")
3673         (insert "Content-ID: " (message-make-message-id) "\n")
3674         (insert "Content-Transfer-Encoding: binary\n")
3675         (insert "\n"))
3676       (setcdr data
3677               (cdr (mm-make-handle nil
3678                                    `("message/external-body"
3679                                      (access-type . "LOCAL-FILE")
3680                                      (name . ,file)))))
3681       (set-buffer gnus-summary-buffer)
3682       (gnus-article-edit-article
3683        `(lambda ()
3684            (erase-buffer)
3685            (let ((mail-parse-charset (or gnus-article-charset
3686                                          ',gnus-newsgroup-charset))
3687                  (mail-parse-ignored-charsets
3688                   (or gnus-article-ignored-charsets
3689                       ',gnus-newsgroup-ignored-charsets))
3690                  (mbl mml-buffer-list))
3691              (setq mml-buffer-list nil)
3692              (insert-buffer gnus-original-article-buffer)
3693              (mime-to-mml gnus-article-mime-handles)
3694              (setq gnus-article-mime-handles nil)
3695              (make-local-hook 'kill-buffer-hook)
3696              (let ((mbl1 mml-buffer-list))
3697                (setq mml-buffer-list mbl)
3698                (set (make-local-variable 'mml-buffer-list) mbl1))
3699              (add-hook 'kill-buffer-hook 'mml-destroy-buffers t t)))
3700        `(lambda (no-highlight)
3701           (let ((mail-parse-charset (or gnus-article-charset
3702                                         ',gnus-newsgroup-charset))
3703                 (message-options message-options)
3704                 (message-options-set-recipient)
3705                 (mail-parse-ignored-charsets
3706                  (or gnus-article-ignored-charsets
3707                      ',gnus-newsgroup-ignored-charsets)))
3708            (mml-to-mime)
3709            (mml-destroy-buffers)
3710            (remove-hook 'kill-buffer-hook
3711                         'mml-destroy-buffers t)
3712            (kill-local-variable 'mml-buffer-list))
3713           (gnus-summary-edit-article-done
3714            ,(or (mail-header-references gnus-current-headers) "")
3715            ,(gnus-group-read-only-p)
3716            ,gnus-summary-buffer no-highlight))))))
3717
3718 (defun gnus-mime-save-part ()
3719   "Save the MIME part under point."
3720   (interactive)
3721   (gnus-article-check-buffer)
3722   (let ((data (get-text-property (point) 'gnus-data)))
3723     (when data
3724       (mm-save-part data))))
3725
3726 (defun gnus-mime-pipe-part ()
3727   "Pipe the MIME part under point to a process."
3728   (interactive)
3729   (gnus-article-check-buffer)
3730   (let ((data (get-text-property (point) 'gnus-data)))
3731     (when data
3732       (mm-pipe-part data))))
3733
3734 (defun gnus-mime-view-part ()
3735   "Interactively choose a viewing method for the MIME part under point."
3736   (interactive)
3737   (gnus-article-check-buffer)
3738   (let ((data (get-text-property (point) 'gnus-data)))
3739     (when data
3740       (push (setq data (copy-sequence data)) gnus-article-mime-handles)
3741       (mm-interactively-view-part data))))
3742
3743 (defun gnus-mime-view-part-as-type-internal ()
3744   (gnus-article-check-buffer)
3745   (let* ((name (mail-content-type-get
3746                 (mm-handle-type (get-text-property (point) 'gnus-data))
3747                 'name))
3748          (def-type (and name (mm-default-file-encoding name))))
3749     (and def-type (cons def-type 0))))
3750
3751 (defun gnus-mime-view-part-as-type (&optional mime-type)
3752   "Choose a MIME media type, and view the part as such."
3753   (interactive)
3754   (unless mime-type
3755     (setq mime-type (completing-read
3756                      "View as MIME type: "
3757                      (mapcar #'list (mailcap-mime-types))
3758                      nil nil
3759                      (gnus-mime-view-part-as-type-internal))))
3760   (gnus-article-check-buffer)
3761   (let ((handle (get-text-property (point) 'gnus-data)))
3762     (when handle
3763       (setq handle
3764             (mm-make-handle (mm-handle-buffer handle)
3765                             (cons mime-type (cdr (mm-handle-type handle)))
3766                             (mm-handle-encoding handle)
3767                             (mm-handle-undisplayer handle)
3768                             (mm-handle-disposition handle)
3769                             (mm-handle-description handle)
3770                             (mm-handle-cache handle)
3771                             (mm-handle-id handle)))
3772       (push handle gnus-article-mime-handles)
3773       (gnus-mm-display-part handle))))
3774
3775 (defun gnus-mime-copy-part (&optional handle)
3776   "Put the the MIME part under point into a new buffer."
3777   (interactive)
3778   (gnus-article-check-buffer)
3779   (let* ((handle (or handle (get-text-property (point) 'gnus-data)))
3780          (contents (and handle (mm-get-part handle)))
3781          (base (and handle
3782                     (file-name-nondirectory
3783                      (or
3784                       (mail-content-type-get (mm-handle-type handle) 'name)
3785                       (mail-content-type-get (mm-handle-type handle)
3786                                              'filename)
3787                       "*decoded*"))))
3788          (buffer (and base (generate-new-buffer base))))
3789     (when contents
3790       (switch-to-buffer buffer)
3791       (insert contents)
3792       ;; We do it this way to make `normal-mode' set the appropriate mode.
3793       (unwind-protect
3794           (progn
3795             (setq buffer-file-name (expand-file-name base))
3796             (normal-mode))
3797         (setq buffer-file-name nil))
3798       (goto-char (point-min)))))
3799
3800 (defun gnus-mime-inline-part (&optional handle arg)
3801   "Insert the MIME part under point into the current buffer."
3802   (interactive (list nil current-prefix-arg))
3803   (gnus-article-check-buffer)
3804   (let* ((handle (or handle (get-text-property (point) 'gnus-data)))
3805          contents charset
3806          (b (point))
3807          buffer-read-only)
3808     (when handle
3809       (if (and (not arg) (mm-handle-undisplayer handle))
3810           (mm-remove-part handle)
3811         (setq contents (mm-get-part handle))
3812         (cond
3813          ((not arg)
3814           (setq charset (or (mail-content-type-get
3815                              (mm-handle-type handle) 'charset)
3816                             gnus-newsgroup-charset)))
3817          ((numberp arg)
3818           (if (mm-handle-undisplayer handle)
3819               (mm-remove-part handle))
3820           (setq charset
3821                 (or (cdr (assq arg
3822                                gnus-summary-show-article-charset-alist))
3823                     (read-coding-system "Charset: ")))))
3824         (forward-line 2)
3825         (mm-insert-inline handle
3826                           (if (and charset
3827                                    (setq charset (mm-charset-to-coding-system
3828                                                   charset))
3829                                    (not (eq charset 'ascii)))
3830                               (mm-decode-coding-string contents charset)
3831                             contents))
3832         (goto-char b)))))
3833
3834 (defun gnus-mime-view-part-as-charset (&optional handle arg)
3835   "Insert the MIME part under point into the current buffer."
3836   (interactive (list nil current-prefix-arg))
3837   (gnus-article-check-buffer)
3838   (let* ((handle (or handle (get-text-property (point) 'gnus-data)))
3839          contents charset
3840          (b (point))
3841          buffer-read-only)
3842     (when handle
3843       (if (mm-handle-undisplayer handle)
3844           (mm-remove-part handle))
3845       (let ((gnus-newsgroup-charset
3846              (or (cdr (assq arg
3847                             gnus-summary-show-article-charset-alist))
3848                  (read-coding-system "Charset: ")))
3849           (gnus-newsgroup-ignored-charsets 'gnus-all))
3850         (gnus-article-press-button)))))
3851
3852 (defun gnus-mime-externalize-part (&optional handle)
3853   "View the MIME part under point with an external viewer."
3854   (interactive)
3855   (gnus-article-check-buffer)
3856   (let* ((handle (or handle (get-text-property (point) 'gnus-data)))
3857          (mm-user-display-methods nil)
3858          (mm-inlined-types nil)
3859          (mail-parse-charset gnus-newsgroup-charset)
3860          (mail-parse-ignored-charsets
3861           (save-excursion (set-buffer gnus-summary-buffer)
3862                           gnus-newsgroup-ignored-charsets)))
3863     (when handle
3864       (if (mm-handle-undisplayer handle)
3865           (mm-remove-part handle)
3866         (mm-display-part handle)))))
3867
3868 (defun gnus-mime-internalize-part (&optional handle)
3869   "View the MIME part under point with an internal viewer.
3870 In no internal viewer is available, use an external viewer."
3871   (interactive)
3872   (gnus-article-check-buffer)
3873   (let* ((handle (or handle (get-text-property (point) 'gnus-data)))
3874          (mm-inlined-types '(".*"))
3875          (mm-inline-large-images t)
3876          (mail-parse-charset gnus-newsgroup-charset)
3877          (mail-parse-ignored-charsets
3878           (save-excursion (set-buffer gnus-summary-buffer)
3879                           gnus-newsgroup-ignored-charsets)))
3880     (when handle
3881       (if (mm-handle-undisplayer handle)
3882           (mm-remove-part handle)
3883         (mm-display-part handle)))))
3884
3885 (defun gnus-mime-action-on-part (&optional action)
3886   "Do something with the MIME attachment at \(point\)."
3887   (interactive
3888    (list (completing-read "Action: " gnus-mime-action-alist)))
3889   (gnus-article-check-buffer)
3890   (let ((action-pair (assoc action gnus-mime-action-alist)))
3891     (if action-pair
3892         (funcall (cdr action-pair)))))
3893
3894 (defun gnus-article-part-wrapper (n function)
3895   (save-current-buffer
3896     (set-buffer gnus-article-buffer)
3897     (when (> n (length gnus-article-mime-handle-alist))
3898       (error "No such part"))
3899     (gnus-article-goto-part n)
3900     (let ((handle (cdr (assq n gnus-article-mime-handle-alist))))
3901       (funcall function handle))))
3902
3903 (defun gnus-article-pipe-part (n)
3904   "Pipe MIME part N, which is the numerical prefix."
3905   (interactive "p")
3906   (gnus-article-part-wrapper n 'mm-pipe-part))
3907
3908 (defun gnus-article-save-part (n)
3909   "Save MIME part N, which is the numerical prefix."
3910   (interactive "p")
3911   (gnus-article-part-wrapper n 'mm-save-part))
3912
3913 (defun gnus-article-interactively-view-part (n)
3914   "View MIME part N interactively, which is the numerical prefix."
3915   (interactive "p")
3916   (gnus-article-part-wrapper n 'mm-interactively-view-part))
3917
3918 (defun gnus-article-copy-part (n)
3919   "Copy MIME part N, which is the numerical prefix."
3920   (interactive "p")
3921   (gnus-article-part-wrapper n 'gnus-mime-copy-part))
3922
3923 (defun gnus-article-view-part-as-charset (n)
3924   "Copy MIME part N, which is the numerical prefix."
3925   (interactive "p")
3926   (gnus-article-part-wrapper n 'gnus-mime-view-part-as-charset))
3927
3928 (defun gnus-article-externalize-part (n)
3929   "View MIME part N externally, which is the numerical prefix."
3930   (interactive "p")
3931   (gnus-article-part-wrapper n 'gnus-mime-externalize-part))
3932
3933 (defun gnus-article-inline-part (n)
3934   "Inline MIME part N, which is the numerical prefix."
3935   (interactive "p")
3936   (gnus-article-part-wrapper n 'gnus-mime-inline-part))
3937
3938 (defun gnus-article-mime-match-handle-first (condition)
3939   (if condition
3940       (let ((alist gnus-article-mime-handle-alist) ihandle n)
3941         (while (setq ihandle (pop alist))
3942           (if (and (cond
3943                     ((functionp condition)
3944                      (funcall condition (cdr ihandle)))
3945                     ((eq condition 'undisplayed)
3946                      (not (or (mm-handle-undisplayer (cdr ihandle))
3947                               (equal (mm-handle-media-type (cdr ihandle))
3948                                      "multipart/alternative"))))
3949                     ((eq condition 'undisplayed-alternative)
3950                      (not (mm-handle-undisplayer (cdr ihandle))))
3951                     (t t))
3952                    (gnus-article-goto-part (car ihandle))
3953                    (or (not n) (< (car ihandle) n)))
3954               (setq n (car ihandle))))
3955         (or n 1))
3956     1))
3957
3958 (defun gnus-article-view-part (&optional n)
3959   "View MIME part N, which is the numerical prefix."
3960   (interactive "P")
3961   (save-current-buffer
3962     (set-buffer gnus-article-buffer)
3963     (or (numberp n) (setq n (gnus-article-mime-match-handle-first
3964                              gnus-article-mime-match-handle-function)))
3965     (when (> n (length gnus-article-mime-handle-alist))
3966       (error "No such part"))
3967     (let ((handle (cdr (assq n gnus-article-mime-handle-alist))))
3968       (when (gnus-article-goto-part n)
3969         (if (equal (car handle) "multipart/alternative")
3970             (gnus-article-press-button)
3971           (when (eq (gnus-mm-display-part handle) 'internal)
3972             (gnus-set-window-start)))))))
3973
3974 (defsubst gnus-article-mime-total-parts ()
3975   (if (bufferp (car gnus-article-mime-handles))
3976       1 ;; single part
3977     (1- (length gnus-article-mime-handles))))
3978
3979 (defun gnus-mm-display-part (handle)
3980   "Display HANDLE and fix MIME button."
3981   (let ((id (get-text-property (point) 'gnus-part))
3982         (point (point))
3983         buffer-read-only)
3984     (forward-line 1)
3985     (prog1
3986         (let ((window (selected-window))
3987               (mail-parse-charset gnus-newsgroup-charset)
3988               (mail-parse-ignored-charsets
3989                (save-excursion (set-buffer gnus-summary-buffer)
3990                                gnus-newsgroup-ignored-charsets)))
3991           (save-excursion
3992             (unwind-protect
3993                 (let ((win (get-buffer-window (current-buffer) t))
3994                       (beg (point)))
3995                   (when win
3996                     (select-window win))
3997                   (goto-char point)
3998                   (forward-line)
3999                   (if (mm-handle-displayed-p handle)
4000                       ;; This will remove the part.
4001                       (mm-display-part handle)
4002                     (save-restriction
4003                       (narrow-to-region (point) (1+ (point)))
4004                       (mm-display-part handle)
4005                       ;; We narrow to the part itself and
4006                       ;; then call the treatment functions.
4007                       (goto-char (point-min))
4008                       (forward-line 1)
4009                       (narrow-to-region (point) (point-max))
4010                       (gnus-treat-article
4011                        nil id
4012                        (gnus-article-mime-total-parts)
4013                        (mm-handle-media-type handle)))))
4014               (select-window window))))
4015       (goto-char point)
4016       (delete-region (gnus-point-at-bol) (progn (forward-line 1) (point)))
4017       (gnus-insert-mime-button
4018        handle id (list (mm-handle-displayed-p handle)))
4019       (goto-char point))))
4020
4021 (defun gnus-article-goto-part (n)
4022   "Go to MIME part N."
4023   (let ((point (text-property-any (point-min) (point-max) 'gnus-part n)))
4024     (when point
4025       (goto-char point))))
4026
4027 (defun gnus-insert-mime-button (handle gnus-tmp-id &optional displayed)
4028   (let ((gnus-tmp-name
4029          (or (mail-content-type-get (mm-handle-type handle)
4030                                     'name)
4031              (mail-content-type-get (mm-handle-disposition handle)
4032                                     'filename)
4033              (mail-content-type-get (mm-handle-type handle)
4034                                     'url)
4035              ""))
4036         (gnus-tmp-type (mm-handle-media-type handle))
4037         (gnus-tmp-description
4038          (mail-decode-encoded-word-string (or (mm-handle-description handle)
4039                                               "")))
4040         (gnus-tmp-dots
4041          (if (if displayed (car displayed)
4042                (mm-handle-displayed-p handle))
4043              "" "..."))
4044         (gnus-tmp-length (with-current-buffer (mm-handle-buffer handle)
4045                            (buffer-size)))
4046         gnus-tmp-type-long b e)
4047     (when (string-match ".*/" gnus-tmp-name)
4048       (setq gnus-tmp-name (replace-match "" t t gnus-tmp-name)))
4049     (setq gnus-tmp-type-long (concat gnus-tmp-type
4050                                      (and (not (equal gnus-tmp-name ""))
4051                                           (concat "; " gnus-tmp-name))))
4052     (or (equal gnus-tmp-description "")
4053         (setq gnus-tmp-type-long (concat " --- " gnus-tmp-type-long)))
4054     (unless (bolp)
4055       (insert "\n"))
4056     (setq b (point))
4057     (gnus-eval-format
4058      gnus-mime-button-line-format gnus-mime-button-line-format-alist
4059      `(keymap ,gnus-mime-button-map
4060               ,@(if (>= (string-to-number emacs-version) 21)
4061                     nil
4062                   (list 'local-map gnus-mime-button-map))
4063               gnus-callback gnus-mm-display-part
4064               gnus-part ,gnus-tmp-id
4065               article-type annotation
4066               gnus-data ,handle))
4067     (setq e (point))
4068     (widget-convert-button
4069      'link b e
4070      :mime-handle handle
4071      :action 'gnus-widget-press-button
4072      :button-keymap gnus-mime-button-map
4073      :help-echo
4074      (lambda (widget/window &optional overlay pos)
4075        ;; Needed to properly clear the message due to a bug in
4076        ;; wid-edit (XEmacs only).
4077        (if (boundp 'help-echo-owns-message)
4078            (setq help-echo-owns-message t))
4079        (format
4080         "%S: %s the MIME part; %S: more options"
4081         (aref gnus-mouse-2 0)
4082         ;; XEmacs will get a single widget arg; Emacs 21 will get
4083         ;; window, overlay, position.
4084         (if (mm-handle-displayed-p
4085              (if overlay
4086                  (with-current-buffer (gnus-overlay-buffer overlay)
4087                    (widget-get (widget-at (gnus-overlay-start overlay))
4088                                :mime-handle))
4089                (widget-get widget/window :mime-handle)))
4090             "hide" "show")
4091         (aref gnus-down-mouse-3 0))))))
4092
4093 (defun gnus-widget-press-button (elems el)
4094   (goto-char (widget-get elems :from))
4095   (gnus-article-press-button))
4096
4097 (defvar gnus-displaying-mime nil)
4098
4099 (defun gnus-display-mime (&optional ihandles)
4100   "Display the MIME parts."
4101   (save-excursion
4102     (save-selected-window
4103       (let ((window (get-buffer-window gnus-article-buffer))
4104             (point (point)))
4105         (when window
4106           (select-window window)
4107           ;; We have to do this since selecting the window
4108           ;; may change the point.  So we set the window point.
4109           (set-window-point window point)))
4110       (let* ((handles (or ihandles (mm-dissect-buffer) (mm-uu-dissect)))
4111              buffer-read-only handle name type b e display)
4112         (when (and (not ihandles)
4113                    (not gnus-displaying-mime))
4114           ;; Top-level call; we clean up.
4115           (when gnus-article-mime-handles
4116             (mm-destroy-parts gnus-article-mime-handles)
4117             (setq gnus-article-mime-handle-alist nil));; A trick.
4118           (setq gnus-article-mime-handles handles)
4119           ;; We allow users to glean info from the handles.
4120           (when gnus-article-mime-part-function
4121             (gnus-mime-part-function handles)))
4122         (if (and handles
4123                  (or (not (stringp (car handles)))
4124                      (cdr handles)))
4125             (progn
4126               (when (and (not ihandles)
4127                          (not gnus-displaying-mime))
4128                 ;; Clean up for mime parts.
4129                 (article-goto-body)
4130                 (delete-region (point) (point-max)))
4131               (let ((gnus-displaying-mime t))
4132                 (gnus-mime-display-part handles)))
4133           (save-restriction
4134             (article-goto-body)
4135             (narrow-to-region (point) (point-max))
4136             (gnus-treat-article nil 1 1)
4137             (widen)))
4138         (unless ihandles
4139           ;; Highlight the headers.
4140           (save-excursion
4141             (save-restriction
4142               (article-goto-body)
4143               (narrow-to-region (point-min) (point))
4144               (gnus-treat-article 'head))))))))
4145
4146 (defvar gnus-mime-display-multipart-as-mixed nil)
4147
4148 (defun gnus-mime-display-part (handle)
4149   (cond
4150    ;; Single part.
4151    ((not (stringp (car handle)))
4152     (gnus-mime-display-single handle))
4153    ;; User-defined multipart
4154    ((cdr (assoc (car handle) gnus-mime-multipart-functions))
4155     (funcall (cdr (assoc (car handle) gnus-mime-multipart-functions))
4156              handle))
4157    ;; multipart/alternative
4158    ((and (equal (car handle) "multipart/alternative")
4159          (not gnus-mime-display-multipart-as-mixed))
4160     (let ((id (1+ (length gnus-article-mime-handle-alist))))
4161       (push (cons id handle) gnus-article-mime-handle-alist)
4162       (gnus-mime-display-alternative (cdr handle) nil nil id)))
4163    ;; multipart/related
4164    ((and (equal (car handle) "multipart/related")
4165          (not gnus-mime-display-multipart-as-mixed))
4166     ;;;!!!We should find the start part, but we just default
4167     ;;;!!!to the first part.
4168     ;;(gnus-mime-display-part (cadr handle))
4169     ;;;!!! Most multipart/related is an HTML message plus images.
4170     ;;;!!! Unfortunately we are unable to let W3 display those
4171     ;;;!!! included images, so we just display it as a mixed multipart.
4172     ;;(gnus-mime-display-mixed (cdr handle))
4173     ;;;!!! No, w3 can display everything just fine.
4174     (gnus-mime-display-part (cadr handle)))
4175    ((equal (car handle) "multipart/signed")
4176     (or (memq 'signed gnus-article-wash-types)
4177         (push 'signed gnus-article-wash-types))
4178     (gnus-mime-display-security handle))
4179    ((equal (car handle) "multipart/encrypted")
4180     (or (memq 'encrypted gnus-article-wash-types)
4181         (push 'encrypted gnus-article-wash-types))
4182     (gnus-mime-display-security handle))
4183    ;; Other multiparts are handled like multipart/mixed.
4184    (t
4185     (gnus-mime-display-mixed (cdr handle)))))
4186
4187 (defun gnus-mime-part-function (handles)
4188   (if (stringp (car handles))
4189       (mapcar 'gnus-mime-part-function (cdr handles))
4190     (funcall gnus-article-mime-part-function handles)))
4191
4192 (defun gnus-mime-display-mixed (handles)
4193   (mapcar 'gnus-mime-display-part handles))
4194
4195 (defun gnus-mime-display-single (handle)
4196   (let ((type (mm-handle-media-type handle))
4197         (ignored gnus-ignored-mime-types)
4198         (not-attachment t)
4199         (move nil)
4200         display text)
4201     (catch 'ignored
4202       (progn
4203         (while ignored
4204           (when (string-match (pop ignored) type)
4205             (throw 'ignored nil)))
4206         (if (and (setq not-attachment
4207                        (and (not (mm-inline-override-p handle))
4208                             (or (not (mm-handle-disposition handle))
4209                                 (equal (car (mm-handle-disposition handle))
4210                                        "inline")
4211                                 (mm-attachment-override-p handle))))
4212                  (mm-automatic-display-p handle)
4213                  (or (mm-inlined-p handle)
4214                      (mm-automatic-external-display-p type)))
4215             (setq display t)
4216           (when (equal (mm-handle-media-supertype handle) "text")
4217             (setq text t)))
4218         (let ((id (1+ (length gnus-article-mime-handle-alist)))
4219               beg)
4220           (push (cons id handle) gnus-article-mime-handle-alist)
4221           (when (or (not display)
4222                     (not (gnus-unbuttonized-mime-type-p type)))
4223             ;(gnus-article-insert-newline)
4224             (gnus-insert-mime-button
4225              handle id (list (or display (and not-attachment text))))
4226             (gnus-article-insert-newline)
4227             ;(gnus-article-insert-newline)
4228             ;; Remember modify the number of forward lines.
4229             (setq move t))
4230           (setq beg (point))
4231           (cond
4232            (display
4233             (when move
4234               (forward-line -1)
4235               (setq beg (point)))
4236             (let ((mail-parse-charset gnus-newsgroup-charset)
4237                   (mail-parse-ignored-charsets
4238                    (save-excursion (condition-case ()
4239                                        (set-buffer gnus-summary-buffer)
4240                                      (error))
4241                                    gnus-newsgroup-ignored-charsets)))
4242               (mm-display-part handle t))
4243             (goto-char (point-max)))
4244            ((and text not-attachment)
4245             (when move
4246               (forward-line -1)
4247               (setq beg (point)))
4248             (gnus-article-insert-newline)
4249             (mm-insert-inline handle (mm-get-part handle))
4250             (goto-char (point-max))))
4251           ;; Do highlighting.
4252           (save-excursion
4253             (save-restriction
4254               (narrow-to-region beg (point))
4255               (gnus-treat-article
4256                nil id
4257                (gnus-article-mime-total-parts)
4258                (mm-handle-media-type handle)))))))))
4259
4260 (defun gnus-unbuttonized-mime-type-p (type)
4261   "Say whether TYPE is to be unbuttonized."
4262   (unless gnus-inhibit-mime-unbuttonizing
4263     (catch 'found
4264       (let ((types gnus-unbuttonized-mime-types))
4265         (while types
4266           (when (string-match (pop types) type)
4267             (throw 'found t)))))))
4268
4269 (defun gnus-article-insert-newline ()
4270   "Insert a newline, but mark it as undeletable."
4271   (gnus-put-text-property
4272    (point) (progn (insert "\n") (point)) 'gnus-undeletable t))
4273
4274 (defun gnus-mime-display-alternative (handles &optional preferred ibegend id)
4275   (let* ((preferred (or preferred (mm-preferred-alternative handles)))
4276          (ihandles handles)
4277          (point (point))
4278          handle buffer-read-only from props begend not-pref)
4279     (save-window-excursion
4280       (save-restriction
4281         (when ibegend
4282           (narrow-to-region (car ibegend)
4283                             (or (cdr ibegend)
4284                                 (progn
4285                                   (goto-char (car ibegend))
4286                                   (forward-line 2)
4287                                   (point))))
4288           (delete-region (point-min) (point-max))
4289           (mm-remove-parts handles))
4290         (setq begend (list (point-marker)))
4291         ;; Do the toggle.
4292         (unless (setq not-pref (cadr (member preferred ihandles)))
4293           (setq not-pref (car ihandles)))
4294         (when (or ibegend
4295                   (not preferred)
4296                   (not (gnus-unbuttonized-mime-type-p
4297                         "multipart/alternative")))
4298           (gnus-add-text-properties
4299            (setq from (point))
4300            (progn
4301              (insert (format "%d.  " id))
4302              (point))
4303            `(gnus-callback
4304              (lambda (handles)
4305                (unless ,(not ibegend)
4306                  (setq gnus-article-mime-handle-alist
4307                        ',gnus-article-mime-handle-alist))
4308                (gnus-mime-display-alternative
4309                 ',ihandles ',not-pref ',begend ,id))
4310              ,@(if (>= (string-to-number emacs-version) 21)
4311                    nil ;; XEmacs doesn't care
4312                  (list 'local-map gnus-mime-button-map))
4313              ,gnus-mouse-face-prop ,gnus-article-mouse-face
4314              face ,gnus-article-button-face
4315              keymap ,gnus-mime-button-map
4316              gnus-part ,id
4317              gnus-data ,handle))
4318           (widget-convert-button 'link from (point)
4319                                  :action 'gnus-widget-press-button
4320                                  :button-keymap gnus-widget-button-keymap)
4321           ;; Do the handles
4322           (while (setq handle (pop handles))
4323             (gnus-add-text-properties
4324              (setq from (point))
4325              (progn
4326                (insert (format "(%c) %-18s"
4327                                (if (equal handle preferred) ?* ? )
4328                                (mm-handle-media-type handle)))
4329                (point))
4330              `(gnus-callback
4331                (lambda (handles)
4332                  (unless ,(not ibegend)
4333                    (setq gnus-article-mime-handle-alist
4334                          ',gnus-article-mime-handle-alist))
4335                  (gnus-mime-display-alternative
4336                   ',ihandles ',handle ',begend ,id))
4337                ,@(if (>= (string-to-number emacs-version) 21)
4338                      nil ;; XEmacs doesn't care
4339                    (list 'local-map gnus-mime-button-map))
4340                ,gnus-mouse-face-prop ,gnus-article-mouse-face
4341                face ,gnus-article-button-face
4342                keymap ,gnus-mime-button-map
4343                gnus-part ,id
4344                gnus-data ,handle))
4345             (widget-convert-button 'link from (point)
4346                                    :action 'gnus-widget-press-button
4347                                    :button-keymap gnus-widget-button-keymap)
4348             (insert "  "))
4349           (insert "\n\n"))
4350         (when preferred
4351           (if (stringp (car preferred))
4352               (gnus-display-mime preferred)
4353             (let ((mail-parse-charset gnus-newsgroup-charset)
4354                   (mail-parse-ignored-charsets
4355                    (save-excursion (set-buffer gnus-summary-buffer)
4356                                    gnus-newsgroup-ignored-charsets)))
4357               (mm-display-part preferred)
4358               ;; Do highlighting.
4359               (save-excursion
4360                 (save-restriction
4361                   (narrow-to-region (car begend) (point-max))
4362                   (gnus-treat-article
4363                    nil (length gnus-article-mime-handle-alist)
4364                    (gnus-article-mime-total-parts)
4365                    (mm-handle-media-type handle))))))
4366           (goto-char (point-max))
4367           (setcdr begend (point-marker)))))
4368     (when ibegend
4369       (goto-char point))))
4370
4371 (defun gnus-article-wash-status ()
4372   "Return a string which display status of article washing."
4373   (save-excursion
4374     (set-buffer gnus-article-buffer)
4375     (let ((cite (memq 'cite gnus-article-wash-types))
4376           (headers (memq 'headers gnus-article-wash-types))
4377           (boring (memq 'boring-headers gnus-article-wash-types))
4378           (pgp (memq 'pgp gnus-article-wash-types))
4379           (pem (memq 'pem gnus-article-wash-types))
4380           (signed (memq 'signed gnus-article-wash-types))
4381           (encrypted (memq 'encrypted gnus-article-wash-types))
4382           (signature (memq 'signature gnus-article-wash-types))
4383           (overstrike (memq 'overstrike gnus-article-wash-types))
4384           (emphasis (memq 'emphasis gnus-article-wash-types)))
4385       (format "%c%c%c%c%c%c%c"
4386               (if cite ?c ? )
4387               (if (or headers boring) ?h ? )
4388               (if (or pgp pem signed encrypted) ?p ? )
4389               (if signature ?s ? )
4390               (if overstrike ?o ? )
4391               (if gnus-show-mime ?m ? )
4392               (if emphasis ?e ? )))))
4393
4394 (defalias 'gnus-article-hide-headers-if-wanted 'gnus-article-maybe-hide-headers)
4395
4396 (defun gnus-article-maybe-hide-headers ()
4397   "Hide unwanted headers if `gnus-have-all-headers' is nil.
4398 Provided for backwards compatibility."
4399   (when (and (or (not (gnus-buffer-live-p gnus-summary-buffer))
4400                  (not (save-excursion (set-buffer gnus-summary-buffer)
4401                                       gnus-have-all-headers)))
4402              (not gnus-inhibit-hiding))
4403     (gnus-article-hide-headers)))
4404
4405 ;;; Article savers.
4406
4407 (defun gnus-output-to-file (file-name)
4408   "Append the current article to a file named FILE-NAME."
4409   (let ((artbuf (current-buffer)))
4410     (with-temp-buffer
4411       (insert-buffer-substring artbuf)
4412       ;; Append newline at end of the buffer as separator, and then
4413       ;; save it to file.
4414       (goto-char (point-max))
4415       (insert "\n")
4416       (write-region-as-binary (point-min) (point-max) file-name 'append)
4417       t)))
4418
4419 (defun gnus-narrow-to-page (&optional arg)
4420   "Narrow the article buffer to a page.
4421 If given a numerical ARG, move forward ARG pages."
4422   (interactive "P")
4423   (setq arg (if arg (prefix-numeric-value arg) 0))
4424   (save-excursion
4425     (set-buffer gnus-article-buffer)
4426     (goto-char (point-min))
4427     (widen)
4428     ;; Remove any old next/prev buttons.
4429     (when (gnus-visual-p 'page-marker)
4430       (let ((buffer-read-only nil))
4431         (gnus-remove-text-with-property 'gnus-prev)
4432         (gnus-remove-text-with-property 'gnus-next)))
4433     (when
4434         (cond ((< arg 0)
4435                (re-search-backward page-delimiter nil 'move (1+ (abs arg))))
4436               ((> arg 0)
4437                (re-search-forward page-delimiter nil 'move arg)))
4438       (goto-char (match-end 0)))
4439     (narrow-to-region
4440      (point)
4441      (if (re-search-forward page-delimiter nil 'move)
4442          (match-beginning 0)
4443        (point)))
4444     (when (and (gnus-visual-p 'page-marker)
4445                (not (= (point-min) 1)))
4446       (save-excursion
4447         (goto-char (point-min))
4448         (gnus-insert-prev-page-button)))
4449     (when (and (gnus-visual-p 'page-marker)
4450                (< (+ (point-max) 2) (buffer-size)))
4451       (save-excursion
4452         (goto-char (point-max))
4453         (gnus-insert-next-page-button)))))
4454
4455 ;; Article mode commands
4456
4457 (defun gnus-article-goto-next-page ()
4458   "Show the next page of the article."
4459   (interactive)
4460   (when (gnus-article-next-page)
4461     (goto-char (point-min))
4462     (gnus-article-read-summary-keys nil (gnus-character-to-event ?n))))
4463
4464 (defun gnus-article-goto-prev-page ()
4465   "Show the next page of the article."
4466   (interactive)
4467   (if (bobp) (gnus-article-read-summary-keys nil (gnus-character-to-event ?p))
4468     (gnus-article-prev-page nil)))
4469
4470 (defun gnus-article-next-page (&optional lines)
4471   "Show the next page of the current article.
4472 If end of article, return non-nil.  Otherwise return nil.
4473 Argument LINES specifies lines to be scrolled up."
4474   (interactive "p")
4475   (let ((start (window-start))
4476         end-of-buffer end-of-page)
4477     (save-excursion
4478       (move-to-window-line -1)
4479       (if (<= (point) start)
4480           (progn
4481             (forward-line 2)
4482             (setq start (point)))
4483         (forward-line 1)
4484         (setq start nil))
4485       (unless (or (cond ((eq (1+ (buffer-size)) (point))
4486                          (and (pos-visible-in-window-p)
4487                               (setq end-of-buffer t)))
4488                         ((eobp)
4489                          (setq end-of-page t)))
4490                   (not lines))
4491         (move-to-window-line lines)
4492         (unless (search-backward "\n\n" nil t)
4493           (setq start (point)))))
4494     (cond (end-of-buffer t)
4495           (end-of-page
4496            (gnus-narrow-to-page 1)
4497            nil)
4498           (t
4499            (if start
4500                (set-window-start (selected-window) start)
4501              (let (window-pixel-scroll-increment)
4502                (scroll-up lines)))
4503            nil))))
4504
4505 (defun gnus-article-prev-page (&optional lines)
4506   "Show previous page of current article.
4507 Argument LINES specifies lines to be scrolled down."
4508   (interactive "p")
4509   (let (beginning-of-buffer beginning-of-page)
4510     (save-excursion
4511       (move-to-window-line 0)
4512       (cond ((eq 1 (point))
4513              (setq beginning-of-buffer t))
4514             ((bobp)
4515              (setq beginning-of-page t))))
4516     (cond (beginning-of-buffer)
4517           (beginning-of-page
4518            (gnus-narrow-to-page -1))
4519           (t
4520            (condition-case nil
4521                (let (window-pixel-scroll-increment)
4522                  (scroll-down lines))
4523              (beginning-of-buffer
4524               (goto-char (point-min))))))))
4525
4526 (defun gnus-article-refer-article ()
4527   "Read article specified by message-id around point."
4528   (interactive)
4529   (let ((point (point)))
4530     (search-forward ">" nil t)          ;Move point to end of "<....>".
4531     (if (re-search-backward "\\(<[^<> \t\n]+>\\)" nil t)
4532         (let ((message-id (match-string 1)))
4533           (goto-char point)
4534           (set-buffer gnus-summary-buffer)
4535           (gnus-summary-refer-article message-id))
4536       (goto-char (point))
4537       (error "No references around point"))))
4538
4539 (defun gnus-article-show-summary ()
4540   "Reconfigure windows to show summary buffer."
4541   (interactive)
4542   (if (not (gnus-buffer-live-p gnus-summary-buffer))
4543       (error "There is no summary buffer for this article buffer")
4544     (gnus-article-set-globals)
4545     (gnus-configure-windows 'article)
4546     (gnus-summary-goto-subject gnus-current-article)
4547     (gnus-summary-position-point)))
4548
4549 (defun gnus-article-describe-briefly ()
4550   "Describe article mode commands briefly."
4551   (interactive)
4552   (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")))
4553
4554 (defun gnus-article-summary-command ()
4555   "Execute the last keystroke in the summary buffer."
4556   (interactive)
4557   (let ((obuf (current-buffer))
4558         (owin (current-window-configuration))
4559         func)
4560     (switch-to-buffer gnus-article-current-summary 'norecord)
4561     (setq func (lookup-key (current-local-map) (this-command-keys)))
4562     (call-interactively func)
4563     (set-buffer obuf)
4564     (set-window-configuration owin)
4565     (set-window-point (get-buffer-window (current-buffer)) (point))))
4566
4567 (defun gnus-article-summary-command-nosave ()
4568   "Execute the last keystroke in the summary buffer."
4569   (interactive)
4570   (let (func)
4571     (pop-to-buffer gnus-article-current-summary 'norecord)
4572     (setq func (lookup-key (current-local-map) (this-command-keys)))
4573     (call-interactively func)))
4574
4575 (defun gnus-article-check-buffer ()
4576   "Beep if not in an article buffer."
4577   (unless (eq (get-buffer gnus-article-buffer) (current-buffer))
4578     (error "Command invoked outside of a Gnus article buffer")))
4579
4580 (defun gnus-article-read-summary-keys (&optional arg key not-restore-window)
4581   "Read a summary buffer key sequence and execute it from the article buffer."
4582   (interactive "P")
4583   (gnus-article-check-buffer)
4584   (let ((nosaves
4585          '("q" "Q"  "c" "r" "R" "\C-c\C-f" "m"  "a" "f" "F"
4586            "Zc" "ZC" "ZE" "ZJ" "ZQ" "ZZ" "Zn" "ZR" "ZG" "ZN" "ZP"
4587            "=" "^" "\M-^" "|"))
4588         (nosave-but-article
4589          '("A\r"))
4590         (nosave-in-article
4591          '("\C-d"))
4592         (up-to-top
4593          '("n" "Gn" "p" "Gp"))
4594         keys new-sum-point)
4595     (save-excursion
4596       (set-buffer gnus-article-current-summary)
4597       (let (gnus-pick-mode)
4598         (push (or key last-command-event) unread-command-events)
4599         (setq keys (static-if (featurep 'xemacs)
4600                        (events-to-keys (read-key-sequence nil))
4601                      (read-key-sequence nil)))))
4602     (message "")
4603
4604     (if (or (member keys nosaves)
4605             (member keys nosave-but-article)
4606             (member keys nosave-in-article))
4607         (let (func)
4608           (save-window-excursion
4609             (pop-to-buffer gnus-article-current-summary 'norecord)
4610             ;; We disable the pick minor mode commands.
4611             (let (gnus-pick-mode)
4612               (setq func (lookup-key (current-local-map) keys))))
4613           (if (or (not func)
4614                   (numberp func))
4615               (ding)
4616             (unless (member keys nosave-in-article)
4617               (set-buffer gnus-article-current-summary))
4618             (call-interactively func)
4619             (setq new-sum-point (point)))
4620           (when (member keys nosave-but-article)
4621             (pop-to-buffer gnus-article-buffer 'norecord)))
4622       ;; These commands should restore window configuration.
4623       (let ((obuf (current-buffer))
4624             (owin (current-window-configuration))
4625             (opoint (point))
4626             (summary gnus-article-current-summary)
4627             func in-buffer selected)
4628         (if not-restore-window
4629             (pop-to-buffer summary 'norecord)
4630           (switch-to-buffer summary 'norecord))
4631         (setq in-buffer (current-buffer))
4632         ;; We disable the pick minor mode commands.
4633         (if (and (setq func (let (gnus-pick-mode)
4634                               (lookup-key (current-local-map) keys)))
4635                  (functionp func))
4636             (progn
4637               (call-interactively func)
4638               (setq new-sum-point (point))
4639               (when (eq in-buffer (current-buffer))
4640                 (setq selected (gnus-summary-select-article))
4641                 (set-buffer obuf)
4642                 (unless not-restore-window
4643                   (set-window-configuration owin))
4644                 (when (eq selected 'old)
4645                   (article-goto-body)
4646                   (set-window-start (get-buffer-window (current-buffer))
4647                                     1)
4648                   (set-window-point (get-buffer-window (current-buffer))
4649                                     (point)))
4650                 (let ((win (get-buffer-window gnus-article-current-summary)))
4651                   (when win
4652                     (set-window-point win new-sum-point))))    )
4653           (switch-to-buffer gnus-article-buffer)
4654           (ding))))))
4655
4656 (defun gnus-article-describe-key (key)
4657   "Display documentation of the function invoked by KEY.  KEY is a string."
4658   (interactive "kDescribe key: ")
4659   (gnus-article-check-buffer)
4660   (if (eq (key-binding key) 'gnus-article-read-summary-keys)
4661       (save-excursion
4662         (set-buffer gnus-article-current-summary)
4663         (let (gnus-pick-mode)
4664           (push (elt key 0) unread-command-events)
4665           (setq key (if (featurep 'xemacs)
4666                         (events-to-keys (read-key-sequence "Describe key: "))
4667                       (read-key-sequence "Describe key: "))))
4668         (describe-key key))
4669     (describe-key key)))
4670
4671 (defun gnus-article-describe-key-briefly (key &optional insert)
4672   "Display documentation of the function invoked by KEY.  KEY is a string."
4673   (interactive "kDescribe key: \nP")
4674   (gnus-article-check-buffer)
4675   (if (eq (key-binding key) 'gnus-article-read-summary-keys)
4676       (save-excursion
4677         (set-buffer gnus-article-current-summary)
4678         (let (gnus-pick-mode)
4679           (push (elt key 0) unread-command-events)
4680           (setq key (if (featurep 'xemacs)
4681                         (events-to-keys (read-key-sequence "Describe key: "))
4682                       (read-key-sequence "Describe key: "))))
4683         (describe-key-briefly key insert))
4684     (describe-key-briefly key insert)))
4685
4686 (defun gnus-article-hide (&optional arg force)
4687   "Hide all the gruft in the current article.
4688 This means that PGP stuff, signatures, cited text and (some)
4689 headers will be hidden.
4690 If given a prefix, show the hidden text instead."
4691   (interactive (append (gnus-article-hidden-arg) (list 'force)))
4692   (gnus-article-hide-headers arg)
4693   (gnus-article-hide-list-identifiers arg)
4694   (gnus-article-hide-pgp arg)
4695   (gnus-article-hide-citation-maybe arg force)
4696   (gnus-article-hide-signature arg))
4697
4698 (defun gnus-article-maybe-highlight ()
4699   "Do some article highlighting if article highlighting is requested."
4700   (when (gnus-visual-p 'article-highlight 'highlight)
4701     (gnus-article-highlight-some)))
4702
4703 (defun gnus-check-group-server ()
4704   ;; Make sure the connection to the server is alive.
4705   (unless (gnus-server-opened
4706            (gnus-find-method-for-group gnus-newsgroup-name))
4707     (gnus-check-server (gnus-find-method-for-group gnus-newsgroup-name))
4708     (gnus-request-group gnus-newsgroup-name t)))
4709
4710 (defun gnus-request-article-this-buffer (article group)
4711   "Get an article and insert it into this buffer."
4712   (let (do-update-line sparse-header)
4713     (prog1
4714         (save-excursion
4715           (erase-buffer)
4716           (gnus-kill-all-overlays)
4717           (setq group (or group gnus-newsgroup-name))
4718
4719           ;; Using `gnus-request-article' directly will insert the article into
4720           ;; `nntp-server-buffer' - so we'll save some time by not having to
4721           ;; copy it from the server buffer into the article buffer.
4722
4723           ;; We only request an article by message-id when we do not have the
4724           ;; headers for it, so we'll have to get those.
4725           (when (stringp article)
4726             (gnus-read-header article))
4727
4728           ;; If the article number is negative, that means that this article
4729           ;; doesn't belong in this newsgroup (possibly), so we find its
4730           ;; message-id and request it by id instead of number.
4731           (when (and (numberp article)
4732                      gnus-summary-buffer
4733                      (get-buffer gnus-summary-buffer)
4734                      (gnus-buffer-exists-p gnus-summary-buffer))
4735             (save-excursion
4736               (set-buffer gnus-summary-buffer)
4737               (let ((header (gnus-summary-article-header article)))
4738                 (when (< article 0)
4739                   (cond
4740                    ((memq article gnus-newsgroup-sparse)
4741                     ;; This is a sparse gap article.
4742                     (setq do-update-line article)
4743                     (setq article (mail-header-id header))
4744                     (setq sparse-header (gnus-read-header article))
4745                     (setq gnus-newsgroup-sparse
4746                           (delq article gnus-newsgroup-sparse)))
4747                    ((vectorp header)
4748                     ;; It's a real article.
4749                     (setq article (mail-header-id header)))
4750                    (t
4751                     ;; It is an extracted pseudo-article.
4752                     (setq article 'pseudo)
4753                     (gnus-request-pseudo-article header))))
4754
4755                 (let ((method (gnus-find-method-for-group
4756                                gnus-newsgroup-name)))
4757                   (when (and (eq (car method) 'nneething)
4758                              (vectorp header))
4759                     (let ((dir (expand-file-name
4760                                 (mail-header-subject header)
4761                                 (file-name-as-directory
4762                                  (or (cadr (assq 'nneething-address method))
4763                                      (nth 1 method))))))
4764                       (when (file-directory-p dir)
4765                         (setq article 'nneething)
4766                         (gnus-group-enter-directory dir))))))))
4767
4768           (cond
4769            ;; Refuse to select canceled articles.
4770            ((and (numberp article)
4771                  gnus-summary-buffer
4772                  (get-buffer gnus-summary-buffer)
4773                  (gnus-buffer-exists-p gnus-summary-buffer)
4774                  (eq (cdr (save-excursion
4775                             (set-buffer gnus-summary-buffer)
4776                             (assq article gnus-newsgroup-reads)))
4777                      gnus-canceled-mark))
4778             nil)
4779            ;; Check the backlog.
4780            ((and gnus-keep-backlog
4781                  (gnus-backlog-request-article group article (current-buffer)))
4782             'article)
4783            ;; Check asynchronous pre-fetch.
4784            ((gnus-async-request-fetched-article group article (current-buffer))
4785             (gnus-async-prefetch-next group article gnus-summary-buffer)
4786             (when (and (numberp article) gnus-keep-backlog)
4787               (gnus-backlog-enter-article group article (current-buffer)))
4788             'article)
4789            ;; Check the cache.
4790            ((and gnus-use-cache
4791                  (numberp article)
4792                  (gnus-cache-request-article article group))
4793             'article)
4794            ;; Get the article and put into the article buffer.
4795            ((or (stringp article)
4796                 (numberp article))
4797             (let ((gnus-override-method gnus-override-method)
4798                   (methods (and (stringp article)
4799                                 gnus-refer-article-method))
4800                   result
4801                   (buffer-read-only nil))
4802               (if (or (not (listp methods))
4803                       (and (symbolp (car methods))
4804                            (assq (car methods) nnoo-definition-alist)))
4805                   (setq methods (list methods)))
4806               (when (and (null gnus-override-method)
4807                          methods)
4808                 (setq gnus-override-method (pop methods)))
4809               (while (not result)
4810                 (when (eq gnus-override-method 'current)
4811                   (setq gnus-override-method gnus-current-select-method))
4812                 (erase-buffer)
4813                 (gnus-kill-all-overlays)
4814                 (let ((gnus-newsgroup-name group))
4815                   (gnus-check-group-server))
4816                 (when (gnus-request-article article group (current-buffer))
4817                   (when (numberp article)
4818                     (gnus-async-prefetch-next group article
4819                                               gnus-summary-buffer)
4820                     (when gnus-keep-backlog
4821                       (gnus-backlog-enter-article
4822                        group article (current-buffer))))
4823                   (setq result 'article))
4824                 (if (not result)
4825                     (if methods
4826                         (setq gnus-override-method (pop methods))
4827                       (setq result 'done))))
4828               (and (eq result 'article) 'article)))
4829            ;; It was a pseudo.
4830            (t article)))
4831
4832       ;; Associate this article with the current summary buffer.
4833       (setq gnus-article-current-summary gnus-summary-buffer)
4834
4835       ;; Take the article from the original article buffer
4836       ;; and place it in the buffer it's supposed to be in.
4837       (when (and (get-buffer gnus-article-buffer)
4838                  (equal (buffer-name (current-buffer))
4839                         (buffer-name (get-buffer gnus-article-buffer))))
4840         (save-excursion
4841           (if (get-buffer gnus-original-article-buffer)
4842               (set-buffer gnus-original-article-buffer)
4843             (set-buffer (gnus-get-buffer-create gnus-original-article-buffer))
4844             (set-buffer-multibyte nil)
4845             (buffer-disable-undo)
4846             (setq major-mode 'gnus-original-article-mode)
4847             (setq buffer-read-only t))
4848           (let (buffer-read-only)
4849             (erase-buffer)
4850             (insert-buffer-substring gnus-article-buffer))
4851           (setq gnus-original-article (cons group article)))
4852
4853         ;; Decode charsets.
4854         (run-hooks 'gnus-article-decode-hook)
4855         ;; Mark article as decoded or not.
4856         (setq gnus-article-decoded-p gnus-article-decode-hook))
4857
4858       ;; Update sparse articles.
4859       (when (and do-update-line
4860                  (or (numberp article)
4861                      (stringp article)))
4862         (let ((buf (current-buffer)))
4863           (set-buffer gnus-summary-buffer)
4864           (gnus-summary-update-article do-update-line sparse-header)
4865           (gnus-summary-goto-subject do-update-line nil t)
4866           (set-window-point (get-buffer-window (current-buffer) t)
4867                             (point))
4868           (set-buffer buf))))))
4869
4870 ;;;
4871 ;;; Article editing
4872 ;;;
4873
4874 (defcustom gnus-article-edit-mode-hook nil
4875   "Hook run in article edit mode buffers."
4876   :group 'gnus-article-various
4877   :type 'hook)
4878
4879 (defcustom gnus-article-edit-article-setup-function
4880   'gnus-article-mime-edit-article-setup
4881   "Function called to setup an editing article buffer."
4882   :group 'gnus-article-various
4883   :type 'function)
4884
4885 (defvar gnus-article-edit-done-function nil)
4886
4887 (defvar gnus-article-edit-mode-map nil)
4888
4889 ;; Should we be using derived.el for this?
4890 (unless gnus-article-edit-mode-map
4891   (setq gnus-article-edit-mode-map (make-sparse-keymap))
4892   (set-keymap-parent gnus-article-edit-mode-map text-mode-map)
4893
4894   (gnus-define-keys gnus-article-edit-mode-map
4895     "\C-c\C-c" gnus-article-edit-done
4896     "\C-c\C-k" gnus-article-edit-exit)
4897
4898   (gnus-define-keys (gnus-article-edit-wash-map
4899                      "\C-c\C-w" gnus-article-edit-mode-map)
4900     "f" gnus-article-edit-full-stops))
4901
4902 (defun gnus-article-edit-mode ()
4903   "Major mode for editing articles.
4904 This is an extended text-mode.
4905
4906 \\{gnus-article-edit-mode-map}"
4907   (interactive)
4908   (setq major-mode 'gnus-article-edit-mode)
4909   (setq mode-name "Article Edit")
4910   (use-local-map gnus-article-edit-mode-map)
4911   (make-local-variable 'gnus-article-edit-done-function)
4912   (make-local-variable 'gnus-prev-winconf)
4913   (setq buffer-read-only nil)
4914   (buffer-enable-undo)
4915   (widen)
4916   (gnus-run-hooks 'text-mode-hook 'gnus-article-edit-mode-hook))
4917
4918 (defun gnus-article-edit (&optional force)
4919   "Edit the current article.
4920 This will have permanent effect only in mail groups.
4921 If FORCE is non-nil, allow editing of articles even in read-only
4922 groups."
4923   (interactive "P")
4924   (when (and (not force)
4925              (gnus-group-read-only-p))
4926     (error "The current newsgroup does not support article editing"))
4927   (gnus-article-date-original)
4928   (gnus-article-edit-article
4929    'ignore
4930    `(lambda (no-highlight)
4931       'ignore
4932       (gnus-summary-edit-article-done
4933        ,(or (mail-header-references gnus-current-headers) "")
4934        ,(gnus-group-read-only-p) ,gnus-summary-buffer no-highlight))))
4935
4936 (defun gnus-article-edit-article (start-func exit-func)
4937   "Start editing the contents of the current article buffer."
4938   (let ((winconf (current-window-configuration)))
4939     (set-buffer gnus-article-buffer)
4940     (gnus-article-edit-mode)
4941     (funcall start-func)
4942     (gnus-configure-windows 'edit-article)
4943     (setq gnus-article-edit-done-function exit-func)
4944     (setq gnus-prev-winconf winconf)
4945     (when gnus-article-edit-article-setup-function
4946       (funcall gnus-article-edit-article-setup-function))
4947     (gnus-message 6 "C-c C-c to end edits")))
4948
4949 (defun gnus-article-edit-done (&optional arg)
4950   "Update the article edits and exit."
4951   (interactive "P")
4952   (let ((func gnus-article-edit-done-function)
4953         (buf (current-buffer))
4954         (start (window-start)))
4955     (remove-hook 'gnus-article-mode-hook
4956                  'gnus-article-mime-edit-article-unwind)
4957     (gnus-article-edit-exit)
4958     (save-excursion
4959       (set-buffer buf)
4960       (let ((buffer-read-only nil))
4961         (funcall func arg))
4962       ;; The cache and backlog have to be flushed somewhat.
4963       (when gnus-keep-backlog
4964         (gnus-backlog-remove-article
4965          (car gnus-article-current) (cdr gnus-article-current)))
4966       ;; Flush original article as well.
4967       (save-excursion
4968         (when (get-buffer gnus-original-article-buffer)
4969           (set-buffer gnus-original-article-buffer)
4970           (setq gnus-original-article nil)))
4971       (when gnus-use-cache
4972         (gnus-cache-update-article
4973          (car gnus-article-current) (cdr gnus-article-current))))
4974     (set-buffer buf)
4975     (set-window-start (get-buffer-window buf) start)
4976     (set-window-point (get-buffer-window buf) (point))))
4977
4978 (defun gnus-article-edit-exit ()
4979   "Exit the article editing without updating."
4980   (interactive)
4981   ;; We remove all text props from the article buffer.
4982   (let ((buf (buffer-substring-no-properties (point-min) (point-max)))
4983         (curbuf (current-buffer))
4984         (p (point))
4985         (window-start (window-start)))
4986     (erase-buffer)
4987     (insert buf)
4988     (let ((winconf gnus-prev-winconf))
4989       (gnus-article-mode)
4990       (set-window-configuration winconf)
4991       ;; Tippy-toe some to make sure that point remains where it was.
4992       (save-current-buffer
4993         (set-buffer curbuf)
4994         (set-window-start (get-buffer-window (current-buffer)) window-start)
4995         (goto-char p)))))
4996
4997 (defun gnus-article-edit-full-stops ()
4998   "Interactively repair spacing at end of sentences."
4999   (interactive)
5000   (save-excursion
5001     (goto-char (point-min))
5002     (search-forward-regexp "^$" nil t)
5003     (let ((case-fold-search nil))
5004       (query-replace-regexp "\\([.!?][])}]* \\)\\([[({A-Z]\\)" "\\1 \\2"))))
5005
5006 ;;;
5007 ;;; Article editing with MIME-Edit
5008 ;;;
5009
5010 (defcustom gnus-article-mime-edit-article-setup-hook nil
5011   "Hook run after setting up a MIME editing article buffer."
5012   :group 'gnus-article-various
5013   :type 'hook)
5014
5015 (defun gnus-article-mime-edit-article-unwind ()
5016   "Unwind `gnus-article-buffer' if article editing was given up."
5017   (remove-hook 'gnus-article-mode-hook 'gnus-article-mime-edit-article-unwind)
5018   (when mime-edit-mode-flag
5019     (mime-edit-exit 'nomime 'no-error)
5020     (message ""))
5021   (when (featurep 'font-lock)
5022     (setq font-lock-defaults nil)
5023     (font-lock-mode 0)))
5024
5025 (defun gnus-article-mime-edit-article-setup ()
5026   "Convert current buffer to MIME-Edit buffer and turn on MIME-Edit mode
5027 after replacing with the original article."
5028   (setq gnus-show-mime t)
5029   (setq gnus-article-edit-done-function
5030         `(lambda (&rest args)
5031            (when mime-edit-mode-flag
5032              (mime-edit-exit)
5033              (message ""))
5034            (goto-char (point-min))
5035            (let (case-fold-search)
5036              (when (re-search-forward
5037                     (format "^%s$" (regexp-quote mail-header-separator))
5038                     nil t)
5039                (replace-match "")))
5040            (when (featurep 'font-lock)
5041              (setq font-lock-defaults nil)
5042              (font-lock-mode 0))
5043            (apply ,gnus-article-edit-done-function args)
5044            (set-buffer gnus-original-article-buffer)
5045            (erase-buffer)
5046            (insert-buffer gnus-article-buffer)
5047            (setq gnus-current-headers (gnus-article-make-full-mail-header))
5048            (gnus-article-prepare-display)))
5049   (substitute-key-definition
5050    'gnus-article-edit-exit 'gnus-article-mime-edit-exit
5051    gnus-article-edit-mode-map)
5052   (erase-buffer)
5053   (insert-buffer gnus-original-article-buffer)
5054   (mime-edit-again)
5055   (when (featurep 'font-lock)
5056     (set (make-local-variable 'font-lock-defaults)
5057          '(message-font-lock-keywords t))
5058     (font-lock-set-defaults)
5059     (turn-on-font-lock))
5060   (add-hook 'gnus-article-mode-hook 'gnus-article-mime-edit-article-unwind)
5061   (gnus-run-hooks 'gnus-article-mime-edit-article-setup-hook))
5062
5063 (defun gnus-article-mime-edit-exit ()
5064   "Exit the article MIME editing without updating."
5065   (interactive)
5066   (let ((winconf gnus-prev-winconf)
5067         buf)
5068     (when mime-edit-mode-flag
5069       (mime-edit-exit)
5070       (message ""))
5071     (goto-char (point-min))
5072     (let (case-fold-search)
5073       (when (re-search-forward
5074              (format "^%s$" (regexp-quote mail-header-separator)) nil t)
5075         (replace-match "")))
5076     (when (featurep 'font-lock)
5077       (setq font-lock-defaults nil)
5078       (font-lock-mode 0))
5079     ;; We remove all text props from the article buffer.
5080     (setq buf (buffer-substring-no-properties (point-min) (point-max)))
5081     (set-buffer (get-buffer-create gnus-original-article-buffer))
5082     (erase-buffer)
5083     (insert buf)
5084     (setq gnus-current-headers (gnus-article-make-full-mail-header))
5085     (gnus-article-prepare-display)
5086     (set-window-configuration winconf)))
5087
5088 ;;;
5089 ;;; Article highlights
5090 ;;;
5091
5092 ;; Written by Per Abrahamsen <abraham@iesd.auc.dk>.
5093
5094 ;;; Internal Variables:
5095
5096 (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\\)\\)"
5097   "Regular expression that matches URLs."
5098   :group 'gnus-article-buttons
5099   :type 'regexp)
5100
5101 (defcustom gnus-button-alist
5102   `(("<\\(url:[>\n\t ]*?\\)?news:[>\n\t ]*\\([^>\n\t ]*@[^>\n\t ]*\\)>"
5103      0 t gnus-button-message-id 2)
5104     ("\\bnews:\\([^>\n\t ]*@[^>)!;:,\n\t ]*\\)" 0 t gnus-button-message-id 1)
5105     ("\\(\\b<\\(url:[>\n\t ]*\\)?news:[>\n\t ]*\\(//\\)?\\([^>\n\t ]*\\)>\\)"
5106      1 t
5107      gnus-button-fetch-group 4)
5108     ("\\bnews:\\(//\\)?\\([^'\">\n\t ]+\\)" 0 t gnus-button-fetch-group 2)
5109     ("\\bin\\( +article\\| +message\\)? +\\(<\\([^\n @<>]+@[^\n @<>]+\\)>\\)" 2
5110      t gnus-button-message-id 3)
5111     ("\\(<URL: *\\)mailto: *\\([^> \n\t]+\\)>" 0 t gnus-url-mailto 2)
5112     ("mailto:\\([-a-zA-Z.@_+0-9%=?]+\\)" 0 t gnus-url-mailto 1)
5113     ("\\bmailto:\\([^ \n\t]+\\)" 0 t gnus-url-mailto 1)
5114     ;; This is how URLs _should_ be embedded in text...
5115     ("<URL: *\\([^<>]*\\)>" 0 t gnus-button-embedded-url 1)
5116     ;; Raw URLs.
5117     (,gnus-button-url-regexp 0 t browse-url 0))
5118   "*Alist of regexps matching buttons in article bodies.
5119
5120 Each entry has the form (REGEXP BUTTON FORM CALLBACK PAR...), where
5121 REGEXP: is the string matching text around the button,
5122 BUTTON: is the number of the regexp grouping actually matching the button,
5123 FORM: is a lisp expression which must eval to true for the button to
5124 be added,
5125 CALLBACK: is the function to call when the user push this button, and each
5126 PAR: is a number of a regexp grouping whose text will be passed to CALLBACK.
5127
5128 CALLBACK can also be a variable, in that case the value of that
5129 variable it the real callback function."
5130   :group 'gnus-article-buttons
5131   :type '(repeat (list regexp
5132                        (integer :tag "Button")
5133                        (sexp :tag "Form")
5134                        (function :tag "Callback")
5135                        (repeat :tag "Par"
5136                                :inline t
5137                                (integer :tag "Regexp group")))))
5138
5139 (defcustom gnus-header-button-alist
5140   `(("^\\(References\\|Message-I[Dd]\\):" "<[^>]+>"
5141      0 t gnus-button-message-id 0)
5142     ("^\\(From\\|Reply-To\\):" ": *\\(.+\\)$" 1 t gnus-button-reply 1)
5143     ("^\\(Cc\\|To\\):" "[^ \t\n<>,()\"]+@[^ \t\n<>,()\"]+"
5144      0 t gnus-button-mailto 0)
5145     ("^X-[Uu][Rr][Ll]:" ,gnus-button-url-regexp 0 t browse-url 0)
5146     ("^Subject:" ,gnus-button-url-regexp 0 t browse-url 0)
5147     ("^[^:]+:" ,gnus-button-url-regexp 0 t browse-url 0)
5148     ("^[^:]+:" "\\(<\\(url: \\)?news:\\([^>\n ]*\\)>\\)" 1 t
5149      gnus-button-message-id 3))
5150   "*Alist of headers and regexps to match buttons in article heads.
5151
5152 This alist is very similar to `gnus-button-alist', except that each
5153 alist has an additional HEADER element first in each entry:
5154
5155 \(HEADER REGEXP BUTTON FORM CALLBACK PAR)
5156
5157 HEADER is a regexp to match a header.  For a fuller explanation, see
5158 `gnus-button-alist'."
5159   :group 'gnus-article-buttons
5160   :group 'gnus-article-headers
5161   :type '(repeat (list (regexp :tag "Header")
5162                        regexp
5163                        (integer :tag "Button")
5164                        (sexp :tag "Form")
5165                        (function :tag "Callback")
5166                        (repeat :tag "Par"
5167                                :inline t
5168                                (integer :tag "Regexp group")))))
5169
5170 (defvar gnus-button-regexp nil)
5171 (defvar gnus-button-marker-list nil)
5172 ;; Regexp matching any of the regexps from `gnus-button-alist'.
5173
5174 (defvar gnus-button-last nil)
5175 ;; The value of `gnus-button-alist' when `gnus-button-regexp' was build.
5176
5177 ;;; Commands:
5178
5179 (defun gnus-article-push-button (event)
5180   "Check text under the mouse pointer for a callback function.
5181 If the text under the mouse pointer has a `gnus-callback' property,
5182 call it with the value of the `gnus-data' text property."
5183   (interactive "e")
5184   (set-buffer (window-buffer (posn-window (event-start event))))
5185   (let* ((pos (posn-point (event-start event)))
5186          (data (get-text-property pos 'gnus-data))
5187          (fun (get-text-property pos 'gnus-callback)))
5188     (goto-char pos)
5189     (when fun
5190       (funcall fun data))))
5191
5192 (defun gnus-article-press-button ()
5193   "Check text at point for a callback function.
5194 If the text at point has a `gnus-callback' property,
5195 call it with the value of the `gnus-data' text property."
5196   (interactive)
5197   (let* ((data (get-text-property (point) 'gnus-data))
5198          (fun (get-text-property (point) 'gnus-callback)))
5199     (when fun
5200       (funcall fun data))))
5201
5202 (defun gnus-article-prev-button (n)
5203   "Move point to N buttons backward.
5204 If N is negative, move forward instead."
5205   (interactive "p")
5206   (gnus-article-next-button (- n)))
5207
5208 (defun gnus-article-next-button (n)
5209   "Move point to N buttons forward.
5210 If N is negative, move backward instead."
5211   (interactive "p")
5212   (let ((function (if (< n 0) 'previous-single-property-change
5213                     'next-single-property-change))
5214         (inhibit-point-motion-hooks t)
5215         (backward (< n 0))
5216         (limit (if (< n 0) (point-min) (point-max))))
5217     (setq n (abs n))
5218     (while (and (not (= limit (point)))
5219                 (> n 0))
5220       ;; Skip past the current button.
5221       (when (get-text-property (point) 'gnus-callback)
5222         (goto-char (funcall function (point) 'gnus-callback nil limit)))
5223       ;; Go to the next (or previous) button.
5224       (gnus-goto-char (funcall function (point) 'gnus-callback nil limit))
5225       ;; Put point at the start of the button.
5226       (when (and backward (not (get-text-property (point) 'gnus-callback)))
5227         (goto-char (funcall function (point) 'gnus-callback nil limit)))
5228       ;; Skip past intangible buttons.
5229       (when (get-text-property (point) 'intangible)
5230         (incf n))
5231       (decf n))
5232     (unless (zerop n)
5233       (gnus-message 5 "No more buttons"))
5234     n))
5235
5236 (defun gnus-article-highlight (&optional force)
5237   "Highlight current article.
5238 This function calls `gnus-article-highlight-headers',
5239 `gnus-article-highlight-citation',
5240 `gnus-article-highlight-signature', and `gnus-article-add-buttons' to
5241 do the highlighting.  See the documentation for those functions."
5242   (interactive (list 'force))
5243   (gnus-article-highlight-headers)
5244   (gnus-article-highlight-citation force)
5245   (gnus-article-highlight-signature)
5246   (gnus-article-add-buttons force)
5247   (gnus-article-add-buttons-to-head))
5248
5249 (defun gnus-article-highlight-some (&optional force)
5250   "Highlight current article.
5251 This function calls `gnus-article-highlight-headers',
5252 `gnus-article-highlight-signature', and `gnus-article-add-buttons' to
5253 do the highlighting.  See the documentation for those functions."
5254   (interactive (list 'force))
5255   (gnus-article-highlight-headers)
5256   (gnus-article-highlight-signature)
5257   (gnus-article-add-buttons))
5258
5259 (defun gnus-article-highlight-headers ()
5260   "Highlight article headers as specified by `gnus-header-face-alist'."
5261   (interactive)
5262   (save-excursion
5263     (set-buffer gnus-article-buffer)
5264     (save-restriction
5265       (let ((alist gnus-header-face-alist)
5266             (buffer-read-only nil)
5267             (case-fold-search t)
5268             (inhibit-point-motion-hooks t)
5269             entry regexp header-face field-face from hpoints fpoints)
5270         (article-narrow-to-head)
5271         (while (setq entry (pop alist))
5272           (goto-char (point-min))
5273           (setq regexp (concat "^\\("
5274                                (if (string-equal "" (nth 0 entry))
5275                                    "[^\t ]"
5276                                  (nth 0 entry))
5277                                "\\)")
5278                 header-face (nth 1 entry)
5279                 field-face (nth 2 entry))
5280           (while (and (re-search-forward regexp nil t)
5281                       (not (eobp)))
5282             (beginning-of-line)
5283             (setq from (point))
5284             (unless (search-forward ":" nil t)
5285               (forward-char 1))
5286             (when (and header-face
5287                        (not (memq (point) hpoints)))
5288               (push (point) hpoints)
5289               (gnus-put-text-property from (point) 'face header-face))
5290             (when (and field-face
5291                        (not (memq (setq from (point)) fpoints)))
5292               (push from fpoints)
5293               (if (re-search-forward "^[^ \t]" nil t)
5294                   (forward-char -2)
5295                 (goto-char (point-max)))
5296               (gnus-put-text-property from (point) 'face field-face))))))))
5297
5298 (defun gnus-article-highlight-signature ()
5299   "Highlight the signature in an article.
5300 It does this by highlighting everything after
5301 `gnus-signature-separator' using `gnus-signature-face'."
5302   (interactive)
5303   (when gnus-signature-face
5304     (save-excursion
5305       (set-buffer gnus-article-buffer)
5306       (let ((buffer-read-only nil)
5307             (inhibit-point-motion-hooks t))
5308         (save-restriction
5309           (when (gnus-article-narrow-to-signature)
5310             (gnus-overlay-put (gnus-make-overlay (point-min) (point-max))
5311                               'face gnus-signature-face)))))))
5312
5313 (defun gnus-article-buttonize-signature ()
5314   "Add button to the signature."
5315   (interactive)
5316   (save-excursion
5317     (set-buffer gnus-article-buffer)
5318     (let ((buffer-read-only nil)
5319           (inhibit-point-motion-hooks t))
5320       (when (gnus-article-search-signature)
5321         (gnus-article-add-button (match-beginning 0) (match-end 0)
5322                                  'gnus-signature-toggle
5323                                  (set-marker (make-marker)
5324                                              (1+ (match-end 0))))))))
5325
5326 (defun gnus-button-in-region-p (b e prop)
5327   "Say whether PROP exists in the region."
5328   (text-property-not-all b e prop nil))
5329
5330 (defun gnus-article-add-buttons (&optional force)
5331   "Find external references in the article and make buttons of them.
5332 \"External references\" are things like Message-IDs and URLs, as
5333 specified by `gnus-button-alist'."
5334   (interactive (list 'force))
5335   (save-excursion
5336     (set-buffer gnus-article-buffer)
5337     (let ((buffer-read-only nil)
5338           (inhibit-point-motion-hooks t)
5339           (case-fold-search t)
5340           (alist gnus-button-alist)
5341           beg entry regexp)
5342       ;; Remove all old markers.
5343       (let (marker entry new-list)
5344         (while (setq marker (pop gnus-button-marker-list))
5345           (if (or (< marker (point-min)) (>= marker (point-max)))
5346               (push marker new-list)
5347             (goto-char marker)
5348             (when (setq entry (gnus-button-entry))
5349               (put-text-property (match-beginning (nth 1 entry))
5350                                  (match-end (nth 1 entry))
5351                                  'gnus-callback nil))
5352             (set-marker marker nil)))
5353         (setq gnus-button-marker-list new-list))
5354       ;; We skip the headers.
5355       (article-goto-body)
5356       (setq beg (point))
5357       (while (setq entry (pop alist))
5358         (setq regexp (car entry))
5359         (goto-char beg)
5360         (while (re-search-forward regexp nil t)
5361           (let* ((start (and entry (match-beginning (nth 1 entry))))
5362                  (end (and entry (match-end (nth 1 entry))))
5363                  (from (match-beginning 0)))
5364             (when (and (or (eq t (nth 2 entry))
5365                            (eval (nth 2 entry)))
5366                        (not (gnus-button-in-region-p
5367                              start end 'gnus-callback)))
5368               ;; That optional form returned non-nil, so we add the
5369               ;; button.
5370               (gnus-article-add-button
5371                start end 'gnus-button-push
5372                (car (push (set-marker (make-marker) from)
5373                           gnus-button-marker-list))))))))))
5374
5375 ;; Add buttons to the head of an article.
5376 (defun gnus-article-add-buttons-to-head ()
5377   "Add buttons to the head of the article."
5378   (interactive)
5379   (save-excursion
5380     (set-buffer gnus-article-buffer)
5381     (save-restriction
5382       (let ((buffer-read-only nil)
5383             (inhibit-point-motion-hooks t)
5384             (case-fold-search t)
5385             (alist gnus-header-button-alist)
5386             entry beg end)
5387         (article-narrow-to-head)
5388         (while alist
5389           ;; Each alist entry.
5390           (setq entry (car alist)
5391                 alist (cdr alist))
5392           (goto-char (point-min))
5393           (while (re-search-forward (car entry) nil t)
5394             ;; Each header matching the entry.
5395             (setq beg (match-beginning 0))
5396             (setq end (or (and (re-search-forward "^[^ \t]" nil t)
5397                                (match-beginning 0))
5398                           (point-max)))
5399             (goto-char beg)
5400             (while (re-search-forward (nth 1 entry) end t)
5401               ;; Each match within a header.
5402               (let* ((entry (cdr entry))
5403                      (start (match-beginning (nth 1 entry)))
5404                      (end (match-end (nth 1 entry)))
5405                      (form (nth 2 entry)))
5406                 (goto-char (match-end 0))
5407                 (when (eval form)
5408                   (gnus-article-add-button
5409                    start end (nth 3 entry)
5410                    (buffer-substring (match-beginning (nth 4 entry))
5411                                      (match-end (nth 4 entry)))))))
5412             (goto-char end)))))))
5413
5414 ;;; External functions:
5415
5416 (defun gnus-article-add-button (from to fun &optional data)
5417   "Create a button between FROM and TO with callback FUN and data DATA."
5418   (when gnus-article-button-face
5419     (gnus-overlay-put (gnus-make-overlay from to)
5420                       'face gnus-article-button-face))
5421   (gnus-add-text-properties
5422    from to
5423    (nconc (and gnus-article-mouse-face
5424                (list gnus-mouse-face-prop gnus-article-mouse-face))
5425           (list 'gnus-callback fun)
5426           (and data (list 'gnus-data data))))
5427   (widget-convert-button 'link from to :action 'gnus-widget-press-button
5428                          ;; Quote `:button-keymap' for Mule 2.3
5429                          ;; but it won't work.
5430                          ':button-keymap gnus-widget-button-keymap))
5431
5432 ;;; Internal functions:
5433
5434 (defun gnus-article-set-globals ()
5435   (save-excursion
5436     (set-buffer gnus-summary-buffer)
5437     (gnus-set-global-variables)))
5438
5439 (defun gnus-signature-toggle (end)
5440   (save-excursion
5441     (set-buffer gnus-article-buffer)
5442     (let ((buffer-read-only nil)
5443           (inhibit-point-motion-hooks t)
5444           (limit (next-single-property-change end 'mime-view-entity
5445                                               nil (point-max))))
5446       (if (text-property-any end limit 'article-type 'signature)
5447           (gnus-remove-text-properties-when
5448            'article-type 'signature end limit
5449            (cons 'article-type (cons 'signature
5450                                      gnus-hidden-properties)))
5451         (gnus-add-text-properties-when
5452          'article-type nil end limit
5453          (cons 'article-type (cons 'signature
5454                                    gnus-hidden-properties)))))))
5455
5456 (defun gnus-button-entry ()
5457   ;; Return the first entry in `gnus-button-alist' matching this place.
5458   (let ((alist gnus-button-alist)
5459         (entry nil))
5460     (while alist
5461       (setq entry (pop alist))
5462       (if (looking-at (car entry))
5463           (setq alist nil)
5464         (setq entry nil)))
5465     entry))
5466
5467 (defun gnus-button-push (marker)
5468   ;; Push button starting at MARKER.
5469   (save-excursion
5470     (goto-char marker)
5471     (let* ((entry (gnus-button-entry))
5472            (inhibit-point-motion-hooks t)
5473            (fun (nth 3 entry))
5474            (args (mapcar (lambda (group)
5475                            (let ((string (match-string group)))
5476                              (gnus-set-text-properties
5477                               0 (length string) nil string)
5478                              string))
5479                          (nthcdr 4 entry))))
5480       (cond
5481        ((fboundp fun)
5482         (apply fun args))
5483        ((and (boundp fun)
5484              (fboundp (symbol-value fun)))
5485         (apply (symbol-value fun) args))
5486        (t
5487         (gnus-message 1 "You must define `%S' to use this button"
5488                       (cons fun args)))))))
5489
5490 (defun gnus-button-message-id (message-id)
5491   "Fetch MESSAGE-ID."
5492   (save-excursion
5493     (set-buffer gnus-summary-buffer)
5494     (gnus-summary-refer-article message-id)))
5495
5496 (defun gnus-button-fetch-group (address)
5497   "Fetch GROUP specified by ADDRESS."
5498   (if (not (string-match "[:/]" address))
5499       ;; This is just a simple group url.
5500       (gnus-group-read-ephemeral-group address gnus-select-method)
5501     (if (not (string-match "^\\([^:/]+\\)\\(:\\([^/]+\\)/\\)?\\(.*\\)$"
5502                            address))
5503         (error "Can't parse %s" address)
5504       (gnus-group-read-ephemeral-group
5505        (match-string 4 address)
5506        `(nntp ,(match-string 1 address)
5507               (nntp-address ,(match-string 1 address))
5508               (nntp-port-number ,(if (match-end 3)
5509                                      (match-string 3 address)
5510                                    "nntp")))))))
5511
5512 (defun gnus-url-parse-query-string (query &optional downcase)
5513   (let (retval pairs cur key val)
5514     (setq pairs (split-string query "&"))
5515     (while pairs
5516       (setq cur (car pairs)
5517             pairs (cdr pairs))
5518       (if (not (string-match "=" cur))
5519           nil                           ; Grace
5520         (setq key (gnus-url-unhex-string (substring cur 0 (match-beginning 0)))
5521               val (gnus-url-unhex-string (substring cur (match-end 0) nil)))
5522         (if downcase
5523             (setq key (downcase key)))
5524         (setq cur (assoc key retval))
5525         (if cur
5526             (setcdr cur (cons val (cdr cur)))
5527           (setq retval (cons (list key val) retval)))))
5528     retval))
5529
5530 (defun gnus-url-unhex (x)
5531   (if (> x ?9)
5532       (if (>= x ?a)
5533           (+ 10 (- x ?a))
5534         (+ 10 (- x ?A)))
5535     (- x ?0)))
5536
5537 (defun gnus-url-unhex-string (str &optional allow-newlines)
5538   "Remove %XXX embedded spaces, etc in a url.
5539 If optional second argument ALLOW-NEWLINES is non-nil, then allow the
5540 decoding of carriage returns and line feeds in the string, which is normally
5541 forbidden in URL encoding."
5542   (setq str (or str ""))
5543   (let ((tmp "")
5544         (case-fold-search t))
5545     (while (string-match "%[0-9a-f][0-9a-f]" str)
5546       (let* ((start (match-beginning 0))
5547              (ch1 (gnus-url-unhex (elt str (+ start 1))))
5548              (code (+ (* 16 ch1)
5549                       (gnus-url-unhex (elt str (+ start 2))))))
5550         (setq tmp (concat
5551                    tmp (substring str 0 start)
5552                    (cond
5553                     (allow-newlines
5554                      (char-to-string code))
5555                     ((or (= code ?\n) (= code ?\r))
5556                      " ")
5557                     (t (char-to-string code))))
5558               str (substring str (match-end 0)))))
5559     (setq tmp (concat tmp str))
5560     tmp))
5561
5562 (defun gnus-url-mailto (url)
5563   ;; Send mail to someone
5564   (when (string-match "mailto:/*\\(.*\\)" url)
5565     (setq url (substring url (match-beginning 1) nil)))
5566   (let (to args subject func)
5567     (if (string-match (regexp-quote "?") url)
5568         (setq to (gnus-url-unhex-string (substring url 0 (match-beginning 0)))
5569               args (gnus-url-parse-query-string
5570                     (substring url (match-end 0) nil) t))
5571       (setq to (gnus-url-unhex-string url)))
5572     (setq args (cons (list "to" to) args)
5573           subject (cdr-safe (assoc "subject" args)))
5574     (gnus-msg-mail)
5575     (while args
5576       (setq func (intern-soft (concat "message-goto-" (downcase (caar args)))))
5577       (if (fboundp func)
5578           (funcall func)
5579         (message-position-on-field (caar args)))
5580       (insert (mapconcat 'identity (cdar args) ", "))
5581       (setq args (cdr args)))
5582     (if subject
5583         (message-goto-body)
5584       (message-goto-subject))))
5585
5586 (defun gnus-button-embedded-url (address)
5587   "Activate ADDRESS with `browse-url'."
5588   (browse-url (gnus-strip-whitespace address)))
5589
5590 (eval-when-compile
5591   ;; Silence the byte-compiler.
5592   (autoload 'smiley-toggle-buffer "gnus-bitmap"))
5593 (defun gnus-article-smiley-display ()
5594   "Display \"smileys\" as small graphical icons."
5595   (smiley-toggle-buffer 1 (current-buffer) (point-min) (point-max)))
5596
5597 ;;; Next/prev buttons in the article buffer.
5598
5599 (defvar gnus-next-page-line-format "%{%(Next page...%)%}\n")
5600 (defvar gnus-prev-page-line-format "%{%(Previous page...%)%}\n")
5601
5602 (defvar gnus-prev-page-map nil)
5603 (unless gnus-prev-page-map
5604   (setq gnus-prev-page-map (make-sparse-keymap))
5605   (define-key gnus-prev-page-map gnus-mouse-2 'gnus-button-prev-page)
5606   (define-key gnus-prev-page-map "\r" 'gnus-button-prev-page))
5607
5608 (static-if (featurep 'xemacs)
5609     (defun gnus-insert-prev-page-button ()
5610       (let ((buffer-read-only nil))
5611         (gnus-eval-format
5612          gnus-prev-page-line-format nil
5613          `(gnus-prev t local-map ,gnus-prev-page-map
5614                      gnus-callback gnus-article-button-prev-page
5615                      article-type annotation))))
5616   (defun gnus-insert-prev-page-button ()
5617     (let ((buffer-read-only nil)
5618           (situation (get-text-property (point-min) 'mime-view-situation)))
5619       (set-keymap-parent gnus-prev-page-map (current-local-map))
5620       (gnus-eval-format
5621        gnus-prev-page-line-format nil
5622        `(gnus-prev t local-map ,gnus-prev-page-map
5623                    gnus-callback gnus-article-button-prev-page
5624                    article-type annotation
5625                    mime-view-situation ,situation))))
5626   )
5627
5628 (defvar gnus-next-page-map nil)
5629 (unless gnus-next-page-map
5630   (setq gnus-next-page-map (make-sparse-keymap))
5631   (define-key gnus-next-page-map gnus-mouse-2 'gnus-button-next-page)
5632   (define-key gnus-next-page-map "\r" 'gnus-button-next-page))
5633
5634 (defun gnus-button-next-page ()
5635   "Go to the next page."
5636   (interactive)
5637   (let ((win (selected-window)))
5638     (select-window (get-buffer-window gnus-article-buffer t))
5639     (gnus-article-next-page)
5640     (select-window win)))
5641
5642 (defun gnus-button-prev-page ()
5643   "Go to the prev page."
5644   (interactive)
5645   (let ((win (selected-window)))
5646     (select-window (get-buffer-window gnus-article-buffer t))
5647     (gnus-article-prev-page)
5648     (select-window win)))
5649
5650 (static-if (featurep 'xemacs)
5651     (defun gnus-insert-next-page-button ()
5652       (let ((buffer-read-only nil))
5653         (gnus-eval-format gnus-next-page-line-format nil
5654                           `(gnus-next
5655                             t local-map ,gnus-next-page-map
5656                             gnus-callback gnus-article-button-next-page
5657                             article-type annotation))))
5658   (defun gnus-insert-next-page-button ()
5659     (let ((buffer-read-only nil)
5660           (situation (get-text-property (point-min) 'mime-view-situation)))
5661       (set-keymap-parent gnus-next-page-map (current-local-map))
5662       (gnus-eval-format gnus-next-page-line-format nil
5663                         `(gnus-next
5664                           t local-map ,gnus-next-page-map
5665                           gnus-callback gnus-article-button-next-page
5666                           article-type annotation
5667                           mime-view-situation ,situation))))
5668   )
5669
5670 (defun gnus-article-button-next-page (arg)
5671   "Go to the next page."
5672   (interactive "P")
5673   (let ((win (selected-window)))
5674     (select-window (get-buffer-window gnus-article-buffer t))
5675     (gnus-article-next-page)
5676     (select-window win)))
5677
5678 (defun gnus-article-button-prev-page (arg)
5679   "Go to the prev page."
5680   (interactive "P")
5681   (let ((win (selected-window)))
5682     (select-window (get-buffer-window gnus-article-buffer t))
5683     (gnus-article-prev-page)
5684     (select-window win)))
5685
5686 (defvar gnus-decode-header-methods
5687   '(mail-decode-encoded-word-region)
5688   "List of methods used to decode headers.
5689
5690 This variable is a list of FUNCTION or (REGEXP . FUNCTION).  If item
5691 is FUNCTION, FUNCTION will be apply to all newsgroups.  If item is a
5692 (REGEXP . FUNCTION), FUNCTION will be only apply to thes newsgroups
5693 whose names match REGEXP.
5694
5695 For example:
5696 ((\"chinese\" . gnus-decode-encoded-word-region-by-guess)
5697  mail-decode-encoded-word-region
5698  (\"chinese\" . rfc1843-decode-region))
5699 ")
5700
5701 (defvar gnus-decode-header-methods-cache nil)
5702
5703 (defun gnus-multi-decode-header (start end)
5704   "Apply the functions from `gnus-encoded-word-methods' that match."
5705   (unless (and gnus-decode-header-methods-cache
5706                (eq gnus-newsgroup-name
5707                    (car gnus-decode-header-methods-cache)))
5708     (setq gnus-decode-header-methods-cache (list gnus-newsgroup-name))
5709     (mapcar (lambda (x)
5710               (if (symbolp x)
5711                   (nconc gnus-decode-header-methods-cache (list x))
5712                 (if (and gnus-newsgroup-name
5713                          (string-match (car x) gnus-newsgroup-name))
5714                     (nconc gnus-decode-header-methods-cache
5715                            (list (cdr x))))))
5716           gnus-decode-header-methods))
5717   (let ((xlist gnus-decode-header-methods-cache))
5718     (pop xlist)
5719     (save-restriction
5720       (narrow-to-region start end)
5721       (while xlist
5722         (funcall (pop xlist) (point-min) (point-max))))))
5723
5724 ;;;
5725 ;;; Treatment top-level handling.
5726 ;;;
5727
5728 (defun gnus-treat-article (condition &optional part-number total-parts type)
5729   (let ((length (- (point-max) (point-min)))
5730         (alist gnus-treatment-function-alist)
5731         (article-goto-body-goes-to-point-min-p t)
5732         (treated-type
5733          (or (not type)
5734              (catch 'found
5735                (let ((list gnus-article-treat-types))
5736                  (while list
5737                    (when (string-match (pop list) type)
5738                      (throw 'found t)))))))
5739         (highlightp (gnus-visual-p 'article-highlight 'highlight))
5740         (entity (static-unless (featurep 'xemacs)
5741                   (when (eq 'head condition)
5742                     (get-text-property (point-min) 'mime-view-entity))))
5743         val elem buttonized)
5744     (gnus-run-hooks 'gnus-part-display-hook)
5745     (unless gnus-inhibit-treatment
5746       (while (setq elem (pop alist))
5747         (setq val
5748               (save-excursion
5749                 (if (gnus-buffer-live-p gnus-summary-buffer)
5750                     (set-buffer gnus-summary-buffer))
5751                 (symbol-value (car elem))))
5752         (when (and (or (consp val)
5753                        treated-type)
5754                    (gnus-treat-predicate val)
5755                    (or (not (get (car elem) 'highlight))
5756                        highlightp))
5757           (when (and (not buttonized)
5758                      (memq (car elem)
5759                            '(gnus-treat-hide-signature
5760                              gnus-treat-highlight-signature)))
5761             (gnus-article-buttonize-signature)
5762             (setq buttonized t))
5763           (save-restriction
5764             (funcall (cadr elem)))))
5765       ;; FSF Emacsen does not inherit the existing text properties
5766       ;; in the new text, so we should do it for `mime-view-entity'.
5767       (static-unless (featurep 'xemacs)
5768         (when entity
5769           (put-text-property (point-min) (point-max)
5770                              'mime-view-entity entity))))))
5771
5772 ;; Dynamic variables.
5773 (eval-when-compile
5774   (defvar part-number)
5775   (defvar total-parts)
5776   (defvar type)
5777   (defvar condition)
5778   (defvar length))
5779
5780 (defun gnus-treat-predicate (val)
5781   (cond
5782    ((null val)
5783     nil)
5784    ((and (listp val)
5785          (stringp (car val)))
5786     (apply 'gnus-or (mapcar `(lambda (s)
5787                                (string-match s ,(or gnus-newsgroup-name "")))
5788                             val)))
5789    ((listp val)
5790     (let ((pred (pop val)))
5791       (cond
5792        ((eq pred 'or)
5793         (apply 'gnus-or (mapcar 'gnus-treat-predicate val)))
5794        ((eq pred 'and)
5795         (apply 'gnus-and (mapcar 'gnus-treat-predicate val)))
5796        ((eq pred 'not)
5797         (not (gnus-treat-predicate (car val))))
5798        ((eq pred 'typep)
5799         (equal (car val) type))
5800        (t
5801         (error "%S is not a valid predicate" pred)))))
5802    ((eq val 'mime)
5803     gnus-show-mime)
5804    (condition
5805     (eq condition val))
5806    ((eq val t)
5807     t)
5808    ((eq val 'head)
5809     nil)
5810    ((eq val 'last)
5811     (eq part-number total-parts))
5812    ((numberp val)
5813     (< length val))
5814    (t
5815     (error "%S is not a valid value" val))))
5816
5817 (defun gnus-article-encrypt-body (protocol &optional n)
5818   "Encrypt the article body."
5819   (interactive
5820    (list
5821     (or gnus-article-encrypt-protocol
5822         (completing-read "Encrypt protocol: "
5823                          gnus-article-encrypt-protocol-alist
5824                          nil t))
5825     current-prefix-arg))
5826   (let ((func (cdr (assoc protocol gnus-article-encrypt-protocol-alist))))
5827     (unless func
5828       (error (format "Can't find the encrypt protocol %s" protocol)))
5829     (if (equal gnus-newsgroup-name "nndraft:drafts")
5830         (error "Can't encrypt the article in group nndraft:drafts."))
5831     (if (equal gnus-newsgroup-name "nndraft:queue")
5832         (error "Don't encrypt the article in group nndraft:queue."))
5833     (gnus-summary-iterate n
5834       (save-excursion
5835         (set-buffer gnus-summary-buffer)
5836         (let ((mail-parse-charset gnus-newsgroup-charset)
5837               (mail-parse-ignored-charsets gnus-newsgroup-ignored-charsets)
5838               (summary-buffer gnus-summary-buffer)
5839               references point)
5840           (gnus-set-global-variables)
5841           (when (gnus-group-read-only-p)
5842             (error "The current newsgroup does not support article encrypt"))
5843           (gnus-summary-show-article t)
5844           (setq references
5845               (or (mail-header-references gnus-current-headers) ""))
5846           (set-buffer gnus-article-buffer)
5847           (let* ((buffer-read-only nil)
5848                  (headers
5849                   (mapcar (lambda (field)
5850                             (and (save-restriction
5851                                    (message-narrow-to-head)
5852                                    (goto-char (point-min))
5853                                    (search-forward field nil t))
5854                                  (prog2
5855                                      (message-narrow-to-field)
5856                                      (buffer-substring (point-min) (point-max))
5857                                    (delete-region (point-min) (point-max))
5858                                    (widen))))
5859                           '("Content-Type:" "Content-Transfer-Encoding:"
5860                             "Content-Disposition:"))))
5861             (message-narrow-to-head)
5862             (message-remove-header "MIME-Version")
5863             (goto-char (point-max))
5864             (setq point (point))
5865             (insert (apply 'concat headers))
5866             (widen)
5867             (narrow-to-region point (point-max))
5868             (let ((message-options message-options))
5869               (message-options-set 'message-sender user-mail-address)
5870               (message-options-set 'message-recipients user-mail-address)
5871               (message-options-set 'message-sign-encrypt 'not)
5872               (funcall func))
5873             (goto-char (point-min))
5874             (insert "MIME-Version: 1.0\n")
5875             (widen)
5876             (gnus-summary-edit-article-done
5877              references nil summary-buffer t))
5878           (when gnus-keep-backlog
5879             (gnus-backlog-remove-article
5880              (car gnus-article-current) (cdr gnus-article-current)))
5881           (save-excursion
5882             (when (get-buffer gnus-original-article-buffer)
5883               (set-buffer gnus-original-article-buffer)
5884               (setq gnus-original-article nil)))
5885           (when gnus-use-cache
5886             (gnus-cache-update-article
5887              (car gnus-article-current) (cdr gnus-article-current))))))))
5888
5889 (defvar gnus-mime-security-button-line-format "%{%([[%t:%i]%D]%)%}\n"
5890   "The following specs can be used:
5891 %t  The security MIME type
5892 %i  Additional info
5893 %d  Details
5894 %D  Details if button is pressed")
5895
5896 (defvar gnus-mime-security-button-end-line-format "%{%([[End of %t]%D]%)%}\n"
5897   "The following specs can be used:
5898 %t  The security MIME type
5899 %i  Additional info
5900 %d  Details
5901 %D  Details if button is pressed")
5902
5903 (defvar gnus-mime-security-button-line-format-alist
5904   '((?t gnus-tmp-type ?s)
5905     (?i gnus-tmp-info ?s)
5906     (?d gnus-tmp-details ?s)
5907     (?D gnus-tmp-pressed-details ?s)))
5908
5909 (defvar gnus-mime-security-button-map
5910   (let ((map (make-sparse-keymap)))
5911     (unless (>= (string-to-number emacs-version) 21)
5912       (set-keymap-parent map gnus-article-mode-map))
5913     (define-key map gnus-mouse-2 'gnus-article-push-button)
5914     (define-key map "\r" 'gnus-article-press-button)
5915     map))
5916
5917 (defvar gnus-mime-security-details-buffer nil)
5918
5919 (defvar gnus-mime-security-button-pressed nil)
5920
5921 (defvar gnus-mime-security-show-details-inline t
5922   "If non-nil, show details in the article buffer.")
5923
5924 (defun gnus-mime-security-verify-or-decrypt (handle)
5925   (mm-remove-parts (cdr handle))
5926   (let ((region (mm-handle-multipart-ctl-parameter handle 'gnus-region))
5927         buffer-read-only)
5928     (when region
5929       (delete-region (car region) (cdr region))
5930       (set-marker (car region) nil)
5931       (set-marker (cdr region) nil)))
5932   (with-current-buffer (mm-handle-multipart-original-buffer handle)
5933     (let* ((mm-verify-option 'known)
5934            (mm-decrypt-option 'known)
5935            (nparts (mm-possibly-verify-or-decrypt (cdr handle) handle)))
5936       (unless (eq nparts (cdr handle))
5937         (mm-destroy-parts (cdr handle))
5938         (setcdr handle nparts))))
5939   (let ((point (point))
5940         buffer-read-only)
5941     (gnus-mime-display-security handle)
5942     (goto-char point)))
5943
5944 (defun gnus-mime-security-show-details (handle)
5945   (let ((details (mm-handle-multipart-ctl-parameter handle 'gnus-details)))
5946     (if details
5947         (if gnus-mime-security-show-details-inline
5948             (let ((gnus-mime-security-button-pressed t)
5949                   (gnus-mime-security-button-line-format
5950                    (get-text-property (point) 'gnus-line-format))
5951                 buffer-read-only)
5952               (forward-char -1)
5953               (while (eq (get-text-property (point) 'gnus-line-format)
5954                          gnus-mime-security-button-line-format)
5955                 (forward-char -1))
5956               (forward-char)
5957               (delete-region (point)
5958                              (or (text-property-not-all
5959                                   (point) (point-max)
5960                                 'gnus-line-format
5961                                 gnus-mime-security-button-line-format)
5962                                  (point-max)))
5963               (gnus-insert-mime-security-button handle))
5964           (if (gnus-buffer-live-p gnus-mime-security-details-buffer)
5965               (with-current-buffer gnus-mime-security-details-buffer
5966                 (erase-buffer)
5967                 t)
5968             (setq gnus-mime-security-details-buffer
5969                   (gnus-get-buffer-create "*MIME Security Details*")))
5970           (with-current-buffer gnus-mime-security-details-buffer
5971             (insert details)
5972             (goto-char (point-min)))
5973           (pop-to-buffer gnus-mime-security-details-buffer))
5974       (gnus-message 5 "No details."))))
5975
5976 (defun gnus-mime-security-press-button (handle)
5977   (if (mm-handle-multipart-ctl-parameter handle 'gnus-info)
5978       (gnus-mime-security-show-details handle)
5979     (gnus-mime-security-verify-or-decrypt handle)))
5980
5981 (defun gnus-insert-mime-security-button (handle &optional displayed)
5982   (let* ((protocol (mm-handle-multipart-ctl-parameter handle 'protocol))
5983          (gnus-tmp-type
5984           (concat
5985            (or (nth 2 (assoc protocol mm-verify-function-alist))
5986                (nth 2 (assoc protocol mm-decrypt-function-alist))
5987                "Unknown")
5988            (if (equal (car handle) "multipart/signed")
5989                " Signed" " Encrypted")
5990            " Part"))
5991          (gnus-tmp-info
5992           (or (mm-handle-multipart-ctl-parameter handle 'gnus-info)
5993               "Undecided"))
5994          (gnus-tmp-details
5995           (mm-handle-multipart-ctl-parameter handle 'gnus-details))
5996          gnus-tmp-pressed-details
5997          b e)
5998     (setq gnus-tmp-details
5999           (if gnus-tmp-details
6000               (concat "\n" gnus-tmp-details) ""))
6001     (setq gnus-tmp-pressed-details
6002           (if gnus-mime-security-button-pressed gnus-tmp-details ""))
6003     (unless (bolp)
6004       (insert "\n"))
6005     (setq b (point))
6006     (gnus-eval-format
6007      gnus-mime-security-button-line-format
6008      gnus-mime-security-button-line-format-alist
6009      `(keymap ,gnus-mime-security-button-map
6010               ,@(if (>= (string-to-number emacs-version) 21)
6011                     nil ;; XEmacs doesn't care
6012                   (list 'local-map gnus-mime-security-button-map))
6013               gnus-callback gnus-mime-security-press-button
6014               gnus-line-format ,gnus-mime-security-button-line-format
6015               article-type annotation
6016               gnus-data ,handle))
6017     (setq e (point))
6018     (widget-convert-button
6019      'link b e
6020      :mime-handle handle
6021      :action 'gnus-widget-press-button
6022      :button-keymap gnus-mime-security-button-map
6023      :help-echo
6024      (lambda (widget/window &optional overlay pos)
6025        ;; Needed to properly clear the message due to a bug in
6026        ;; wid-edit (XEmacs only).
6027        (if (boundp 'help-echo-owns-message)
6028            (setq help-echo-owns-message t))
6029        (format
6030         "%S: show detail"
6031         (aref gnus-mouse-2 0))))))
6032
6033 (defun gnus-mime-display-security (handle)
6034   (save-restriction
6035     (narrow-to-region (point) (point))
6036     (gnus-insert-mime-security-button handle)
6037     (gnus-mime-display-mixed (cdr handle))
6038     (unless (bolp)
6039       (insert "\n"))
6040     (let ((gnus-mime-security-button-line-format
6041            gnus-mime-security-button-end-line-format))
6042       (gnus-insert-mime-security-button handle))
6043     (mm-set-handle-multipart-parameter
6044      handle 'gnus-region
6045      (cons (set-marker (make-marker) (point-min))
6046            (set-marker (make-marker) (point-max))))))
6047
6048
6049 ;;; @ for mime-view
6050 ;;;
6051
6052 (defun gnus-article-header-presentation-method (entity situation)
6053   (mime-insert-header entity)
6054   )
6055
6056 (set-alist 'mime-header-presentation-method-alist
6057            'gnus-original-article-mode
6058            #'gnus-article-header-presentation-method)
6059
6060 (defun gnus-mime-preview-quitting-method ()
6061   (mime-preview-kill-buffer)
6062   (delete-other-windows)
6063   (gnus-article-show-summary)
6064   (gnus-summary-select-article gnus-show-all-headers t))
6065
6066 (set-alist 'mime-preview-quitting-method-alist
6067            'gnus-original-article-mode #'gnus-mime-preview-quitting-method)
6068
6069 (set-alist 'mime-preview-following-method-alist
6070            'gnus-original-article-mode #'gnus-following-method)
6071
6072 (set-alist 'mime-preview-over-to-previous-method-alist
6073            'gnus-original-article-mode
6074            (lambda ()
6075              (if (> (point-min) 1)
6076                  (gnus-article-prev-page)
6077                (gnus-article-read-summary-keys
6078                 nil (gnus-character-to-event ?P)))))
6079
6080 (set-alist 'mime-preview-over-to-next-method-alist
6081            'gnus-original-article-mode'
6082            (lambda ()
6083              (if (< (point-max) (buffer-size))
6084                  (gnus-article-next-page)
6085                (gnus-article-read-summary-keys
6086                 nil (gnus-character-to-event ?N)))))
6087
6088
6089 ;;; @ end
6090 ;;;
6091
6092 (gnus-ems-redefine)
6093
6094 (provide 'gnus-art)
6095
6096 (run-hooks 'gnus-art-load-hook)
6097
6098 ;;; gnus-art.el ends here