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