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

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