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