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."
3857   (interactive (list nil current-prefix-arg))
3858   (gnus-article-check-buffer)
3859   (let* ((handle (or handle (get-text-property (point) 'gnus-data)))
3860          contents charset
3861          (b (point))
3862          buffer-read-only)
3863     (when handle
3864       (if (mm-handle-undisplayer handle)
3865           (mm-remove-part handle))
3866       (let ((gnus-newsgroup-charset
3867              (or (cdr (assq arg
3868                             gnus-summary-show-article-charset-alist))
3869                  (read-coding-system "Charset: ")))
3870           (gnus-newsgroup-ignored-charsets 'gnus-all))
3871         (gnus-article-press-button)))))
3872
3873 (defun gnus-mime-externalize-part (&optional handle)
3874   "View the MIME part under point with an external viewer."
3875   (interactive)
3876   (gnus-article-check-buffer)
3877   (let* ((handle (or handle (get-text-property (point) 'gnus-data)))
3878          (mm-user-display-methods nil)
3879          (mm-inlined-types nil)
3880          (mail-parse-charset gnus-newsgroup-charset)
3881          (mail-parse-ignored-charsets
3882           (save-excursion (set-buffer gnus-summary-buffer)
3883                           gnus-newsgroup-ignored-charsets)))
3884     (when handle
3885       (if (mm-handle-undisplayer handle)
3886           (mm-remove-part handle)
3887         (mm-display-part handle)))))
3888
3889 (defun gnus-mime-internalize-part (&optional handle)
3890   "View the MIME part under point with an internal viewer.
3891 In no internal viewer is available, use an external viewer."
3892   (interactive)
3893   (gnus-article-check-buffer)
3894   (let* ((handle (or handle (get-text-property (point) 'gnus-data)))
3895          (mm-inlined-types '(".*"))
3896          (mm-inline-large-images t)
3897          (mail-parse-charset gnus-newsgroup-charset)
3898          (mail-parse-ignored-charsets
3899           (save-excursion (set-buffer gnus-summary-buffer)
3900                           gnus-newsgroup-ignored-charsets)))
3901     (when handle
3902       (if (mm-handle-undisplayer handle)
3903           (mm-remove-part handle)
3904         (mm-display-part handle)))))
3905
3906 (defun gnus-mime-action-on-part (&optional action)
3907   "Do something with the MIME attachment at \(point\)."
3908   (interactive
3909    (list (completing-read "Action: " gnus-mime-action-alist)))
3910   (gnus-article-check-buffer)
3911   (let ((action-pair (assoc action gnus-mime-action-alist)))
3912     (if action-pair
3913         (funcall (cdr action-pair)))))
3914
3915 (defun gnus-article-part-wrapper (n function)
3916   (save-current-buffer
3917     (set-buffer gnus-article-buffer)
3918     (when (> n (length gnus-article-mime-handle-alist))
3919       (error "No such part"))
3920     (gnus-article-goto-part n)
3921     (let ((handle (cdr (assq n gnus-article-mime-handle-alist))))
3922       (funcall function handle))))
3923
3924 (defun gnus-article-pipe-part (n)
3925   "Pipe MIME part N, which is the numerical prefix."
3926   (interactive "p")
3927   (gnus-article-part-wrapper n 'mm-pipe-part))
3928
3929 (defun gnus-article-save-part (n)
3930   "Save MIME part N, which is the numerical prefix."
3931   (interactive "p")
3932   (gnus-article-part-wrapper n 'mm-save-part))
3933
3934 (defun gnus-article-interactively-view-part (n)
3935   "View MIME part N interactively, which is the numerical prefix."
3936   (interactive "p")
3937   (gnus-article-part-wrapper n 'mm-interactively-view-part))
3938
3939 (defun gnus-article-copy-part (n)
3940   "Copy MIME part N, which is the numerical prefix."
3941   (interactive "p")
3942   (gnus-article-part-wrapper n 'gnus-mime-copy-part))
3943
3944 (defun gnus-article-view-part-as-charset (n)
3945   "Copy MIME part N, which is the numerical prefix."
3946   (interactive "p")
3947   (gnus-article-part-wrapper n 'gnus-mime-view-part-as-charset))
3948
3949 (defun gnus-article-externalize-part (n)
3950   "View MIME part N externally, which is the numerical prefix."
3951   (interactive "p")
3952   (gnus-article-part-wrapper n 'gnus-mime-externalize-part))
3953
3954 (defun gnus-article-inline-part (n)
3955   "Inline MIME part N, which is the numerical prefix."
3956   (interactive "p")
3957   (gnus-article-part-wrapper n 'gnus-mime-inline-part))
3958
3959 (defun gnus-article-mime-match-handle-first (condition)
3960   (if condition
3961       (let ((alist gnus-article-mime-handle-alist) ihandle n)
3962         (while (setq ihandle (pop alist))
3963           (if (and (cond
3964                     ((functionp condition)
3965                      (funcall condition (cdr ihandle)))
3966                     ((eq condition 'undisplayed)
3967                      (not (or (mm-handle-undisplayer (cdr ihandle))
3968                               (equal (mm-handle-media-type (cdr ihandle))
3969                                      "multipart/alternative"))))
3970                     ((eq condition 'undisplayed-alternative)
3971                      (not (mm-handle-undisplayer (cdr ihandle))))
3972                     (t t))
3973                    (gnus-article-goto-part (car ihandle))
3974                    (or (not n) (< (car ihandle) n)))
3975               (setq n (car ihandle))))
3976         (or n 1))
3977     1))
3978
3979 (defun gnus-article-view-part (&optional n)
3980   "View MIME part N, which is the numerical prefix."
3981   (interactive "P")
3982   (save-current-buffer
3983     (set-buffer gnus-article-buffer)
3984     (or (numberp n) (setq n (gnus-article-mime-match-handle-first
3985                              gnus-article-mime-match-handle-function)))
3986     (when (> n (length gnus-article-mime-handle-alist))
3987       (error "No such part"))
3988     (let ((handle (cdr (assq n gnus-article-mime-handle-alist))))
3989       (when (gnus-article-goto-part n)
3990         (if (equal (car handle) "multipart/alternative")
3991             (gnus-article-press-button)
3992           (when (eq (gnus-mm-display-part handle) 'internal)
3993             (gnus-set-window-start)))))))
3994
3995 (defsubst gnus-article-mime-total-parts ()
3996   (if (bufferp (car gnus-article-mime-handles))
3997       1 ;; single part
3998     (1- (length gnus-article-mime-handles))))
3999
4000 (defun gnus-mm-display-part (handle)
4001   "Display HANDLE and fix MIME button."
4002   (let ((id (get-text-property (point) 'gnus-part))
4003         (point (point))
4004         buffer-read-only)
4005     (forward-line 1)
4006     (prog1
4007         (let ((window (selected-window))
4008               (mail-parse-charset gnus-newsgroup-charset)
4009               (mail-parse-ignored-charsets
4010                (save-excursion (set-buffer gnus-summary-buffer)
4011                                gnus-newsgroup-ignored-charsets)))
4012           (save-excursion
4013             (unwind-protect
4014                 (let ((win (get-buffer-window (current-buffer) t))
4015                       (beg (point)))
4016                   (when win
4017                     (select-window win))
4018                   (goto-char point)
4019                   (forward-line)
4020                   (if (mm-handle-displayed-p handle)
4021                       ;; This will remove the part.
4022                       (mm-display-part handle)
4023                     (save-restriction
4024                       (narrow-to-region (point) (1+ (point)))
4025                       (mm-display-part handle)
4026                       ;; We narrow to the part itself and
4027                       ;; then call the treatment functions.
4028                       (goto-char (point-min))
4029                       (forward-line 1)
4030                       (narrow-to-region (point) (point-max))
4031                       (gnus-treat-article
4032                        nil id
4033                        (gnus-article-mime-total-parts)
4034                        (mm-handle-media-type handle)))))
4035               (select-window window))))
4036       (goto-char point)
4037       (delete-region (gnus-point-at-bol) (progn (forward-line 1) (point)))
4038       (gnus-insert-mime-button
4039        handle id (list (mm-handle-displayed-p handle)))
4040       (goto-char point))))
4041
4042 (defun gnus-article-goto-part (n)
4043   "Go to MIME part N."
4044   (let ((point (text-property-any (point-min) (point-max) 'gnus-part n)))
4045     (when point
4046       (goto-char point))))
4047
4048 (defun gnus-insert-mime-button (handle gnus-tmp-id &optional displayed)
4049   (let ((gnus-tmp-name
4050          (or (mail-content-type-get (mm-handle-type handle)
4051                                     'name)
4052              (mail-content-type-get (mm-handle-disposition handle)
4053                                     'filename)
4054              (mail-content-type-get (mm-handle-type handle)
4055                                     'url)
4056              ""))
4057         (gnus-tmp-type (mm-handle-media-type handle))
4058         (gnus-tmp-description
4059          (mail-decode-encoded-word-string (or (mm-handle-description handle)
4060                                               "")))
4061         (gnus-tmp-dots
4062          (if (if displayed (car displayed)
4063                (mm-handle-displayed-p handle))
4064              "" "..."))
4065         (gnus-tmp-length (with-current-buffer (mm-handle-buffer handle)
4066                            (buffer-size)))
4067         gnus-tmp-type-long b e)
4068     (when (string-match ".*/" gnus-tmp-name)
4069       (setq gnus-tmp-name (replace-match "" t t gnus-tmp-name)))
4070     (setq gnus-tmp-type-long (concat gnus-tmp-type
4071                                      (and (not (equal gnus-tmp-name ""))
4072                                           (concat "; " gnus-tmp-name))))
4073     (or (equal gnus-tmp-description "")
4074         (setq gnus-tmp-type-long (concat " --- " gnus-tmp-type-long)))
4075     (unless (bolp)
4076       (insert "\n"))
4077     (setq b (point))
4078     (gnus-eval-format
4079      gnus-mime-button-line-format gnus-mime-button-line-format-alist
4080      `(keymap ,gnus-mime-button-map
4081               ,@(if (>= (string-to-number emacs-version) 21)
4082                     nil
4083                   (list 'local-map gnus-mime-button-map))
4084               gnus-callback gnus-mm-display-part
4085               gnus-part ,gnus-tmp-id
4086               article-type annotation
4087               gnus-data ,handle))
4088     (setq e (point))
4089     (widget-convert-button
4090      'link b e
4091      :mime-handle handle
4092      :action 'gnus-widget-press-button
4093      :button-keymap gnus-mime-button-map
4094      :help-echo
4095      (lambda (widget/window &optional overlay pos)
4096        ;; Needed to properly clear the message due to a bug in
4097        ;; wid-edit (XEmacs only).
4098        (if (boundp 'help-echo-owns-message)
4099            (setq help-echo-owns-message t))
4100        (format
4101         "%S: %s the MIME part; %S: more options"
4102         (aref gnus-mouse-2 0)
4103         ;; XEmacs will get a single widget arg; Emacs 21 will get
4104         ;; window, overlay, position.
4105         (if (mm-handle-displayed-p
4106              (if overlay
4107                  (with-current-buffer (gnus-overlay-buffer overlay)
4108                    (widget-get (widget-at (gnus-overlay-start overlay))
4109                                :mime-handle))
4110                (widget-get widget/window :mime-handle)))
4111             "hide" "show")
4112         (aref gnus-down-mouse-3 0))))))
4113
4114 (defun gnus-widget-press-button (elems el)
4115   (goto-char (widget-get elems :from))
4116   (gnus-article-press-button))
4117
4118 (defvar gnus-displaying-mime nil)
4119
4120 (defun gnus-display-mime (&optional ihandles)
4121   "Display the MIME parts."
4122   (save-excursion
4123     (save-selected-window
4124       (let ((window (get-buffer-window gnus-article-buffer))
4125             (point (point)))
4126         (when window
4127           (select-window window)
4128           ;; We have to do this since selecting the window
4129           ;; may change the point.  So we set the window point.
4130           (set-window-point window point)))
4131       (let* ((handles (or ihandles (mm-dissect-buffer) (mm-uu-dissect)))
4132              buffer-read-only handle name type b e display)
4133         (when (and (not ihandles)
4134                    (not gnus-displaying-mime))
4135           ;; Top-level call; we clean up.
4136           (when gnus-article-mime-handles
4137             (mm-destroy-parts gnus-article-mime-handles)
4138             (setq gnus-article-mime-handle-alist nil));; A trick.
4139           (setq gnus-article-mime-handles handles)
4140           ;; We allow users to glean info from the handles.
4141           (when gnus-article-mime-part-function
4142             (gnus-mime-part-function handles)))
4143         (if (and handles
4144                  (or (not (stringp (car handles)))
4145                      (cdr handles)))
4146             (progn
4147               (when (and (not ihandles)
4148                          (not gnus-displaying-mime))
4149                 ;; Clean up for mime parts.
4150                 (article-goto-body)
4151                 (delete-region (point) (point-max)))
4152               (let ((gnus-displaying-mime t))
4153                 (gnus-mime-display-part handles)))
4154           (save-restriction
4155             (article-goto-body)
4156             (narrow-to-region (point) (point-max))
4157             (gnus-treat-article nil 1 1)
4158             (widen)))
4159         (unless ihandles
4160           ;; Highlight the headers.
4161           (save-excursion
4162             (save-restriction
4163               (article-goto-body)
4164               (narrow-to-region (point-min) (point))
4165               (gnus-treat-article 'head))))))))
4166
4167 (defvar gnus-mime-display-multipart-as-mixed nil)
4168 (defvar gnus-mime-display-multipart-alternative-as-mixed nil)
4169 (defvar gnus-mime-display-multipart-related-as-mixed nil)
4170
4171 (defun gnus-mime-display-part (handle)
4172   (cond
4173    ;; Single part.
4174    ((not (stringp (car handle)))
4175     (gnus-mime-display-single handle))
4176    ;; User-defined multipart
4177    ((cdr (assoc (car handle) gnus-mime-multipart-functions))
4178     (funcall (cdr (assoc (car handle) gnus-mime-multipart-functions))
4179              handle))
4180    ;; multipart/alternative
4181    ((and (equal (car handle) "multipart/alternative")
4182          (not (or gnus-mime-display-multipart-as-mixed
4183                   gnus-mime-display-multipart-alternative-as-mixed)))
4184     (let ((id (1+ (length gnus-article-mime-handle-alist))))
4185       (push (cons id handle) gnus-article-mime-handle-alist)
4186       (gnus-mime-display-alternative (cdr handle) nil nil id)))
4187    ;; multipart/related
4188    ((and (equal (car handle) "multipart/related")
4189          (not (or gnus-mime-display-multipart-as-mixed
4190                   gnus-mime-display-multipart-related-as-mixed)))
4191     ;;;!!!We should find the start part, but we just default
4192     ;;;!!!to the first part.
4193     ;;(gnus-mime-display-part (cadr handle))
4194     ;;;!!! Most multipart/related is an HTML message plus images.
4195     ;;;!!! Unfortunately we are unable to let W3 display those
4196     ;;;!!! included images, so we just display it as a mixed multipart.
4197     ;;(gnus-mime-display-mixed (cdr handle))
4198     ;;;!!! No, w3 can display everything just fine.
4199     (gnus-mime-display-part (cadr handle)))
4200    ((equal (car handle) "multipart/signed")
4201     (or (memq 'signed gnus-article-wash-types)
4202         (push 'signed gnus-article-wash-types))
4203     (gnus-mime-display-security handle))
4204    ((equal (car handle) "multipart/encrypted")
4205     (or (memq 'encrypted gnus-article-wash-types)
4206         (push 'encrypted gnus-article-wash-types))
4207     (gnus-mime-display-security handle))
4208    ;; Other multiparts are handled like multipart/mixed.
4209    (t
4210     (gnus-mime-display-mixed (cdr handle)))))
4211
4212 (defun gnus-mime-part-function (handles)
4213   (if (stringp (car handles))
4214       (mapcar 'gnus-mime-part-function (cdr handles))
4215     (funcall gnus-article-mime-part-function handles)))
4216
4217 (defun gnus-mime-display-mixed (handles)
4218   (mapcar 'gnus-mime-display-part handles))
4219
4220 (defun gnus-mime-display-single (handle)
4221   (let ((type (mm-handle-media-type handle))
4222         (ignored gnus-ignored-mime-types)
4223         (not-attachment t)
4224         (move nil)
4225         display text)
4226     (catch 'ignored
4227       (progn
4228         (while ignored
4229           (when (string-match (pop ignored) type)
4230             (throw 'ignored nil)))
4231         (if (and (setq not-attachment
4232                        (and (not (mm-inline-override-p handle))
4233                             (or (not (mm-handle-disposition handle))
4234                                 (equal (car (mm-handle-disposition handle))
4235                                        "inline")
4236                                 (mm-attachment-override-p handle))))
4237                  (mm-automatic-display-p handle)
4238                  (or (mm-inlined-p handle)
4239                      (mm-automatic-external-display-p type)))
4240             (setq display t)
4241           (when (equal (mm-handle-media-supertype handle) "text")
4242             (setq text t)))
4243         (let ((id (1+ (length gnus-article-mime-handle-alist)))
4244               beg)
4245           (push (cons id handle) gnus-article-mime-handle-alist)
4246           (when (or (not display)
4247                     (not (gnus-unbuttonized-mime-type-p type)))
4248             ;(gnus-article-insert-newline)
4249             (gnus-insert-mime-button
4250              handle id (list (or display (and not-attachment text))))
4251             (gnus-article-insert-newline)
4252             ;(gnus-article-insert-newline)
4253             ;; Remember modify the number of forward lines.
4254             (setq move t))
4255           (setq beg (point))
4256           (cond
4257            (display
4258             (when move
4259               (forward-line -1)
4260               (setq beg (point)))
4261             (let ((mail-parse-charset gnus-newsgroup-charset)
4262                   (mail-parse-ignored-charsets
4263                    (save-excursion (condition-case ()
4264                                        (set-buffer gnus-summary-buffer)
4265                                      (error))
4266                                    gnus-newsgroup-ignored-charsets)))
4267               (mm-display-part handle t))
4268             (goto-char (point-max)))
4269            ((and text not-attachment)
4270             (when move
4271               (forward-line -1)
4272               (setq beg (point)))
4273             (gnus-article-insert-newline)
4274             (mm-insert-inline handle (mm-get-part handle))
4275             (goto-char (point-max))))
4276           ;; Do highlighting.
4277           (save-excursion
4278             (save-restriction
4279               (narrow-to-region beg (point))
4280               (gnus-treat-article
4281                nil id
4282                (gnus-article-mime-total-parts)
4283                (mm-handle-media-type handle)))))))))
4284
4285 (defun gnus-unbuttonized-mime-type-p (type)
4286   "Say whether TYPE is to be unbuttonized."
4287   (unless gnus-inhibit-mime-unbuttonizing
4288     (catch 'found
4289       (let ((types gnus-unbuttonized-mime-types))
4290         (while types
4291           (when (string-match (pop types) type)
4292             (throw 'found t)))))))
4293
4294 (defun gnus-article-insert-newline ()
4295   "Insert a newline, but mark it as undeletable."
4296   (gnus-put-text-property
4297    (point) (progn (insert "\n") (point)) 'gnus-undeletable t))
4298
4299 (defun gnus-mime-display-alternative (handles &optional preferred ibegend id)
4300   (let* ((preferred (or preferred (mm-preferred-alternative handles)))
4301          (ihandles handles)
4302          (point (point))
4303          handle buffer-read-only from props begend not-pref)
4304     (save-window-excursion
4305       (save-restriction
4306         (when ibegend
4307           (narrow-to-region (car ibegend)
4308                             (or (cdr ibegend)
4309                                 (progn
4310                                   (goto-char (car ibegend))
4311                                   (forward-line 2)
4312                                   (point))))
4313           (delete-region (point-min) (point-max))
4314           (mm-remove-parts handles))
4315         (setq begend (list (point-marker)))
4316         ;; Do the toggle.
4317         (unless (setq not-pref (cadr (member preferred ihandles)))
4318           (setq not-pref (car ihandles)))
4319         (when (or ibegend
4320                   (not preferred)
4321                   (not (gnus-unbuttonized-mime-type-p
4322                         "multipart/alternative")))
4323           (gnus-add-text-properties
4324            (setq from (point))
4325            (progn
4326              (insert (format "%d.  " id))
4327              (point))
4328            `(gnus-callback
4329              (lambda (handles)
4330                (unless ,(not ibegend)
4331                  (setq gnus-article-mime-handle-alist
4332                        ',gnus-article-mime-handle-alist))
4333                (gnus-mime-display-alternative
4334                 ',ihandles ',not-pref ',begend ,id))
4335              ,@(if (>= (string-to-number emacs-version) 21)
4336                    nil ;; XEmacs doesn't care
4337                  (list 'local-map gnus-mime-button-map))
4338              ,gnus-mouse-face-prop ,gnus-article-mouse-face
4339              face ,gnus-article-button-face
4340              keymap ,gnus-mime-button-map
4341              gnus-part ,id
4342              gnus-data ,handle))
4343           (widget-convert-button 'link from (point)
4344                                  :action 'gnus-widget-press-button
4345                                  :button-keymap gnus-widget-button-keymap)
4346           ;; Do the handles
4347           (while (setq handle (pop handles))
4348             (gnus-add-text-properties
4349              (setq from (point))
4350              (progn
4351                (insert (format "(%c) %-18s"
4352                                (if (equal handle preferred) ?* ? )
4353                                (mm-handle-media-type handle)))
4354                (point))
4355              `(gnus-callback
4356                (lambda (handles)
4357                  (unless ,(not ibegend)
4358                    (setq gnus-article-mime-handle-alist
4359                          ',gnus-article-mime-handle-alist))
4360                  (gnus-mime-display-alternative
4361                   ',ihandles ',handle ',begend ,id))
4362                ,@(if (>= (string-to-number emacs-version) 21)
4363                      nil ;; XEmacs doesn't care
4364                    (list 'local-map gnus-mime-button-map))
4365                ,gnus-mouse-face-prop ,gnus-article-mouse-face
4366                face ,gnus-article-button-face
4367                keymap ,gnus-mime-button-map
4368                gnus-part ,id
4369                gnus-data ,handle))
4370             (widget-convert-button 'link from (point)
4371                                    :action 'gnus-widget-press-button
4372                                    :button-keymap gnus-widget-button-keymap)
4373             (insert "  "))
4374           (insert "\n\n"))
4375         (when preferred
4376           (if (stringp (car preferred))
4377               (gnus-display-mime preferred)
4378             (let ((mail-parse-charset gnus-newsgroup-charset)
4379                   (mail-parse-ignored-charsets
4380                    (save-excursion (set-buffer gnus-summary-buffer)
4381                                    gnus-newsgroup-ignored-charsets)))
4382               (mm-display-part preferred)
4383               ;; Do highlighting.
4384               (save-excursion
4385                 (save-restriction
4386                   (narrow-to-region (car begend) (point-max))
4387                   (gnus-treat-article
4388                    nil (length gnus-article-mime-handle-alist)
4389                    (gnus-article-mime-total-parts)
4390                    (mm-handle-media-type handle))))))
4391           (goto-char (point-max))
4392           (setcdr begend (point-marker)))))
4393     (when ibegend
4394       (goto-char point))))
4395
4396 (defun gnus-article-wash-status ()
4397   "Return a string which display status of article washing."
4398   (save-excursion
4399     (set-buffer gnus-article-buffer)
4400     (let ((cite (memq 'cite gnus-article-wash-types))
4401           (headers (memq 'headers gnus-article-wash-types))
4402           (boring (memq 'boring-headers gnus-article-wash-types))
4403           (pgp (memq 'pgp gnus-article-wash-types))
4404           (pem (memq 'pem gnus-article-wash-types))
4405           (signed (memq 'signed gnus-article-wash-types))
4406           (encrypted (memq 'encrypted gnus-article-wash-types))
4407           (signature (memq 'signature gnus-article-wash-types))
4408           (overstrike (memq 'overstrike gnus-article-wash-types))
4409           (emphasis (memq 'emphasis gnus-article-wash-types)))
4410       (format "%c%c%c%c%c%c%c"
4411               (if cite ?c ? )
4412               (if (or headers boring) ?h ? )
4413               (if (or pgp pem signed encrypted) ?p ? )
4414               (if signature ?s ? )
4415               (if overstrike ?o ? )
4416               (if gnus-show-mime ?m ? )
4417               (if emphasis ?e ? )))))
4418
4419 (defalias 'gnus-article-hide-headers-if-wanted 'gnus-article-maybe-hide-headers)
4420
4421 (defun gnus-article-maybe-hide-headers ()
4422   "Hide unwanted headers if `gnus-have-all-headers' is nil.
4423 Provided for backwards compatibility."
4424   (when (and (or (not (gnus-buffer-live-p gnus-summary-buffer))
4425                  (not (save-excursion (set-buffer gnus-summary-buffer)
4426                                       gnus-have-all-headers)))
4427              (not gnus-inhibit-hiding))
4428     (gnus-article-hide-headers)))
4429
4430 ;;; Article savers.
4431
4432 (defun gnus-output-to-file (file-name)
4433   "Append the current article to a file named FILE-NAME."
4434   (let ((artbuf (current-buffer)))
4435     (with-temp-buffer
4436       (insert-buffer-substring artbuf)
4437       ;; Append newline at end of the buffer as separator, and then
4438       ;; save it to file.
4439       (goto-char (point-max))
4440       (insert "\n")
4441       (write-region-as-binary (point-min) (point-max) file-name 'append)
4442       t)))
4443
4444 (defun gnus-narrow-to-page (&optional arg)
4445   "Narrow the article buffer to a page.
4446 If given a numerical ARG, move forward ARG pages."
4447   (interactive "P")
4448   (setq arg (if arg (prefix-numeric-value arg) 0))
4449   (save-excursion
4450     (set-buffer gnus-article-buffer)
4451     (goto-char (point-min))
4452     (widen)
4453     ;; Remove any old next/prev buttons.
4454     (when (gnus-visual-p 'page-marker)
4455       (let ((buffer-read-only nil))
4456         (gnus-remove-text-with-property 'gnus-prev)
4457         (gnus-remove-text-with-property 'gnus-next)))
4458     (when
4459         (cond ((< arg 0)
4460                (re-search-backward page-delimiter nil 'move (1+ (abs arg))))
4461               ((> arg 0)
4462                (re-search-forward page-delimiter nil 'move arg)))
4463       (goto-char (match-end 0)))
4464     (narrow-to-region
4465      (point)
4466      (if (re-search-forward page-delimiter nil 'move)
4467          (match-beginning 0)
4468        (point)))
4469     (when (and (gnus-visual-p 'page-marker)
4470                (not (= (point-min) 1)))
4471       (save-excursion
4472         (goto-char (point-min))
4473         (gnus-insert-prev-page-button)))
4474     (when (and (gnus-visual-p 'page-marker)
4475                (< (+ (point-max) 2) (buffer-size)))
4476       (save-excursion
4477         (goto-char (point-max))
4478         (gnus-insert-next-page-button)))))
4479
4480 ;; Article mode commands
4481
4482 (defun gnus-article-goto-next-page ()
4483   "Show the next page of the article."
4484   (interactive)
4485   (when (gnus-article-next-page)
4486     (goto-char (point-min))
4487     (gnus-article-read-summary-keys nil (gnus-character-to-event ?n))))
4488
4489 (defun gnus-article-goto-prev-page ()
4490   "Show the next page of the article."
4491   (interactive)
4492   (if (bobp) (gnus-article-read-summary-keys nil (gnus-character-to-event ?p))
4493     (gnus-article-prev-page nil)))
4494
4495 (defun gnus-article-next-page (&optional lines)
4496   "Show the next page of the current article.
4497 If end of article, return non-nil.  Otherwise return nil.
4498 Argument LINES specifies lines to be scrolled up."
4499   (interactive "p")
4500   (let ((start (window-start))
4501         end-of-buffer end-of-page)
4502     (save-excursion
4503       (move-to-window-line -1)
4504       (if (<= (point) start)
4505           (progn
4506             (forward-line 2)
4507             (setq start (point)))
4508         (forward-line 1)
4509         (setq start nil))
4510       (unless (or (cond ((eq (1+ (buffer-size)) (point))
4511                          (and (pos-visible-in-window-p)
4512                               (setq end-of-buffer t)))
4513                         ((eobp)
4514                          (setq end-of-page t)))
4515                   (not lines))
4516         (move-to-window-line lines)
4517         (unless (search-backward "\n\n" nil t)
4518           (setq start (point)))))
4519     (cond (end-of-buffer t)
4520           (end-of-page
4521            (gnus-narrow-to-page 1)
4522            nil)
4523           (t
4524            (if start
4525                (set-window-start (selected-window) start)
4526              (let (window-pixel-scroll-increment)
4527                (scroll-up lines)))
4528            nil))))
4529
4530 (defun gnus-article-prev-page (&optional lines)
4531   "Show previous page of current article.
4532 Argument LINES specifies lines to be scrolled down."
4533   (interactive "p")
4534   (let (beginning-of-buffer beginning-of-page)
4535     (save-excursion
4536       (move-to-window-line 0)
4537       (cond ((eq 1 (point))
4538              (setq beginning-of-buffer t))
4539             ((bobp)
4540              (setq beginning-of-page t))))
4541     (cond (beginning-of-buffer)
4542           (beginning-of-page
4543            (gnus-narrow-to-page -1))
4544           (t
4545            (condition-case nil
4546                (let (window-pixel-scroll-increment)
4547                  (scroll-down lines))
4548              (beginning-of-buffer
4549               (goto-char (point-min))))))))
4550
4551 (defun gnus-article-refer-article ()
4552   "Read article specified by message-id around point."
4553   (interactive)
4554   (let ((point (point)))
4555     (search-forward ">" nil t)          ;Move point to end of "<....>".
4556     (if (re-search-backward "\\(<[^<> \t\n]+>\\)" nil t)
4557         (let ((message-id (match-string 1)))
4558           (goto-char point)
4559           (set-buffer gnus-summary-buffer)
4560           (gnus-summary-refer-article message-id))
4561       (goto-char (point))
4562       (error "No references around point"))))
4563
4564 (defun gnus-article-show-summary ()
4565   "Reconfigure windows to show summary buffer."
4566   (interactive)
4567   (if (not (gnus-buffer-live-p gnus-summary-buffer))
4568       (error "There is no summary buffer for this article buffer")
4569     (gnus-article-set-globals)
4570     (gnus-configure-windows 'article)
4571     (gnus-summary-goto-subject gnus-current-article)
4572     (gnus-summary-position-point)))
4573
4574 (defun gnus-article-describe-briefly ()
4575   "Describe article mode commands briefly."
4576   (interactive)
4577   (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")))
4578
4579 (defun gnus-article-summary-command ()
4580   "Execute the last keystroke in the summary buffer."
4581   (interactive)
4582   (let ((obuf (current-buffer))
4583         (owin (current-window-configuration))
4584         func)
4585     (switch-to-buffer gnus-article-current-summary 'norecord)
4586     (setq func (lookup-key (current-local-map) (this-command-keys)))
4587     (call-interactively func)
4588     (set-buffer obuf)
4589     (set-window-configuration owin)
4590     (set-window-point (get-buffer-window (current-buffer)) (point))))
4591
4592 (defun gnus-article-summary-command-nosave ()
4593   "Execute the last keystroke in the summary buffer."
4594   (interactive)
4595   (let (func)
4596     (pop-to-buffer gnus-article-current-summary 'norecord)
4597     (setq func (lookup-key (current-local-map) (this-command-keys)))
4598     (call-interactively func)))
4599
4600 (defun gnus-article-check-buffer ()
4601   "Beep if not in an article buffer."
4602   (unless (eq (get-buffer gnus-article-buffer) (current-buffer))
4603     (error "Command invoked outside of a Gnus article buffer")))
4604
4605 (defun gnus-article-read-summary-keys (&optional arg key not-restore-window)
4606   "Read a summary buffer key sequence and execute it from the article buffer."
4607   (interactive "P")
4608   (gnus-article-check-buffer)
4609   (let ((nosaves
4610          '("q" "Q"  "c" "r" "R" "\C-c\C-f" "m"  "a" "f" "F"
4611            "Zc" "ZC" "ZE" "ZJ" "ZQ" "ZZ" "Zn" "ZR" "ZG" "ZN" "ZP"
4612            "=" "^" "\M-^" "|"))
4613         (nosave-but-article
4614          '("A\r"))
4615         (nosave-in-article
4616          '("\C-d"))
4617         (up-to-top
4618          '("n" "Gn" "p" "Gp"))
4619         keys new-sum-point)
4620     (save-excursion
4621       (set-buffer gnus-article-current-summary)
4622       (let (gnus-pick-mode)
4623         (push (or key last-command-event) unread-command-events)
4624         (setq keys (static-if (featurep 'xemacs)
4625                        (events-to-keys (read-key-sequence nil))
4626                      (read-key-sequence nil)))))
4627     (message "")
4628
4629     (if (or (member keys nosaves)
4630             (member keys nosave-but-article)
4631             (member keys nosave-in-article))
4632         (let (func)
4633           (save-window-excursion
4634             (pop-to-buffer gnus-article-current-summary 'norecord)
4635             ;; We disable the pick minor mode commands.
4636             (let (gnus-pick-mode)
4637               (setq func (lookup-key (current-local-map) keys))))
4638           (if (or (not func)
4639                   (numberp func))
4640               (ding)
4641             (unless (member keys nosave-in-article)
4642               (set-buffer gnus-article-current-summary))
4643             (call-interactively func)
4644             (setq new-sum-point (point)))
4645           (when (member keys nosave-but-article)
4646             (pop-to-buffer gnus-article-buffer 'norecord)))
4647       ;; These commands should restore window configuration.
4648       (let ((obuf (current-buffer))
4649             (owin (current-window-configuration))
4650             (opoint (point))
4651             (summary gnus-article-current-summary)
4652             func in-buffer selected)
4653         (if not-restore-window
4654             (pop-to-buffer summary 'norecord)
4655           (switch-to-buffer summary 'norecord))
4656         (setq in-buffer (current-buffer))
4657         ;; We disable the pick minor mode commands.
4658         (if (and (setq func (let (gnus-pick-mode)
4659                               (lookup-key (current-local-map) keys)))
4660                  (functionp func))
4661             (progn
4662               (call-interactively func)
4663               (setq new-sum-point (point))
4664               (when (eq in-buffer (current-buffer))
4665                 (setq selected (gnus-summary-select-article))
4666                 (set-buffer obuf)
4667                 (unless not-restore-window
4668                   (set-window-configuration owin))
4669                 (when (eq selected 'old)
4670                   (article-goto-body)
4671                   (set-window-start (get-buffer-window (current-buffer))
4672                                     1)
4673                   (set-window-point (get-buffer-window (current-buffer))
4674                                     (point)))
4675                 (let ((win (get-buffer-window gnus-article-current-summary)))
4676                   (when win
4677                     (set-window-point win new-sum-point))))    )
4678           (switch-to-buffer gnus-article-buffer)
4679           (ding))))))
4680
4681 (defun gnus-article-describe-key (key)
4682   "Display documentation of the function invoked by KEY.  KEY is a string."
4683   (interactive "kDescribe key: ")
4684   (gnus-article-check-buffer)
4685   (if (eq (key-binding key) 'gnus-article-read-summary-keys)
4686       (save-excursion
4687         (set-buffer gnus-article-current-summary)
4688         (let (gnus-pick-mode)
4689           (if (featurep 'xemacs)
4690               (progn
4691                 (push (elt key 0) unread-command-events)
4692                 (setq key (events-to-keys
4693                            (read-key-sequence "Describe key: "))))
4694             (setq unread-command-events
4695                   (mapcar
4696                    (lambda (x) (if (>= x 128) (list 'meta (- x 128)) x))
4697                    key))
4698             (setq key (read-key-sequence "Describe key: "))))
4699         (describe-key key))
4700     (describe-key key)))
4701
4702 (defun gnus-article-describe-key-briefly (key &optional insert)
4703   "Display documentation of the function invoked by KEY.  KEY is a string."
4704   (interactive "kDescribe key: \nP")
4705   (gnus-article-check-buffer)
4706   (if (eq (key-binding key) 'gnus-article-read-summary-keys)
4707       (save-excursion
4708         (set-buffer gnus-article-current-summary)
4709         (let (gnus-pick-mode)
4710           (if (featurep 'xemacs)
4711               (progn
4712                 (push (elt key 0) unread-command-events)
4713                 (setq key (events-to-keys
4714                            (read-key-sequence "Describe key: "))))
4715             (setq unread-command-events
4716                   (mapcar
4717                    (lambda (x) (if (>= x 128) (list 'meta (- x 128)) x))
4718                    key))
4719             (setq key (read-key-sequence "Describe key: "))))
4720         (describe-key-briefly key insert))
4721     (describe-key-briefly key insert)))
4722
4723 (defun gnus-article-hide (&optional arg force)
4724   "Hide all the gruft in the current article.
4725 This means that PGP stuff, signatures, cited text and (some)
4726 headers will be hidden.
4727 If given a prefix, show the hidden text instead."
4728   (interactive (append (gnus-article-hidden-arg) (list 'force)))
4729   (gnus-article-hide-headers arg)
4730   (gnus-article-hide-list-identifiers arg)
4731   (gnus-article-hide-pgp arg)
4732   (gnus-article-hide-citation-maybe arg force)
4733   (gnus-article-hide-signature arg))
4734
4735 (defun gnus-article-maybe-highlight ()
4736   "Do some article highlighting if article highlighting is requested."
4737   (when (gnus-visual-p 'article-highlight 'highlight)
4738     (gnus-article-highlight-some)))
4739
4740 (defun gnus-check-group-server ()
4741   ;; Make sure the connection to the server is alive.
4742   (unless (gnus-server-opened
4743            (gnus-find-method-for-group gnus-newsgroup-name))
4744     (gnus-check-server (gnus-find-method-for-group gnus-newsgroup-name))
4745     (gnus-request-group gnus-newsgroup-name t)))
4746
4747 (defun gnus-request-article-this-buffer (article group)
4748   "Get an article and insert it into this buffer."
4749   (let (do-update-line sparse-header)
4750     (prog1
4751         (save-excursion
4752           (erase-buffer)
4753           (gnus-kill-all-overlays)
4754           (setq group (or group gnus-newsgroup-name))
4755
4756           ;; Using `gnus-request-article' directly will insert the article into
4757           ;; `nntp-server-buffer' - so we'll save some time by not having to
4758           ;; copy it from the server buffer into the article buffer.
4759
4760           ;; We only request an article by message-id when we do not have the
4761           ;; headers for it, so we'll have to get those.
4762           (when (stringp article)
4763             (gnus-read-header article))
4764
4765           ;; If the article number is negative, that means that this article
4766           ;; doesn't belong in this newsgroup (possibly), so we find its
4767           ;; message-id and request it by id instead of number.
4768           (when (and (numberp article)
4769                      gnus-summary-buffer
4770                      (get-buffer gnus-summary-buffer)
4771                      (gnus-buffer-exists-p gnus-summary-buffer))
4772             (save-excursion
4773               (set-buffer gnus-summary-buffer)
4774               (let ((header (gnus-summary-article-header article)))
4775                 (when (< article 0)
4776                   (cond
4777                    ((memq article gnus-newsgroup-sparse)
4778                     ;; This is a sparse gap article.
4779                     (setq do-update-line article)
4780                     (setq article (mail-header-id header))
4781                     (setq sparse-header (gnus-read-header article))
4782                     (setq gnus-newsgroup-sparse
4783                           (delq article gnus-newsgroup-sparse)))
4784                    ((vectorp header)
4785                     ;; It's a real article.
4786                     (setq article (mail-header-id header)))
4787                    (t
4788                     ;; It is an extracted pseudo-article.
4789                     (setq article 'pseudo)
4790                     (gnus-request-pseudo-article header))))
4791
4792                 (let ((method (gnus-find-method-for-group
4793                                gnus-newsgroup-name)))
4794                   (when (and (eq (car method) 'nneething)
4795                              (vectorp header))
4796                     (let ((dir (expand-file-name
4797                                 (mail-header-subject header)
4798                                 (file-name-as-directory
4799                                  (or (cadr (assq 'nneething-address method))
4800                                      (nth 1 method))))))
4801                       (when (file-directory-p dir)
4802                         (setq article 'nneething)
4803                         (gnus-group-enter-directory dir))))))))
4804
4805           (cond
4806            ;; Refuse to select canceled articles.
4807            ((and (numberp article)
4808                  gnus-summary-buffer
4809                  (get-buffer gnus-summary-buffer)
4810                  (gnus-buffer-exists-p gnus-summary-buffer)
4811                  (eq (cdr (save-excursion
4812                             (set-buffer gnus-summary-buffer)
4813                             (assq article gnus-newsgroup-reads)))
4814                      gnus-canceled-mark))
4815             nil)
4816            ;; Check the backlog.
4817            ((and gnus-keep-backlog
4818                  (gnus-backlog-request-article group article (current-buffer)))
4819             'article)
4820            ;; Check asynchronous pre-fetch.
4821            ((gnus-async-request-fetched-article group article (current-buffer))
4822             (gnus-async-prefetch-next group article gnus-summary-buffer)
4823             (when (and (numberp article) gnus-keep-backlog)
4824               (gnus-backlog-enter-article group article (current-buffer)))
4825             'article)
4826            ;; Check the cache.
4827            ((and gnus-use-cache
4828                  (numberp article)
4829                  (gnus-cache-request-article article group))
4830             'article)
4831            ;; Get the article and put into the article buffer.
4832            ((or (stringp article)
4833                 (numberp article))
4834             (let ((gnus-override-method gnus-override-method)
4835                   (methods (and (stringp article)
4836                                 gnus-refer-article-method))
4837                   result
4838                   (buffer-read-only nil))
4839               (if (or (not (listp methods))
4840                       (and (symbolp (car methods))
4841                            (assq (car methods) nnoo-definition-alist)))
4842                   (setq methods (list methods)))
4843               (when (and (null gnus-override-method)
4844                          methods)
4845                 (setq gnus-override-method (pop methods)))
4846               (while (not result)
4847                 (when (eq gnus-override-method 'current)
4848                   (setq gnus-override-method gnus-current-select-method))
4849                 (erase-buffer)
4850                 (gnus-kill-all-overlays)
4851                 (let ((gnus-newsgroup-name group))
4852                   (gnus-check-group-server))
4853                 (when (gnus-request-article article group (current-buffer))
4854                   (when (numberp article)
4855                     (gnus-async-prefetch-next group article
4856                                               gnus-summary-buffer)
4857                     (when gnus-keep-backlog
4858                       (gnus-backlog-enter-article
4859                        group article (current-buffer))))
4860                   (setq result 'article))
4861                 (if (not result)
4862                     (if methods
4863                         (setq gnus-override-method (pop methods))
4864                       (setq result 'done))))
4865               (and (eq result 'article) 'article)))
4866            ;; It was a pseudo.
4867            (t article)))
4868
4869       ;; Associate this article with the current summary buffer.
4870       (setq gnus-article-current-summary gnus-summary-buffer)
4871
4872       ;; Take the article from the original article buffer
4873       ;; and place it in the buffer it's supposed to be in.
4874       (when (and (get-buffer gnus-article-buffer)
4875                  (equal (buffer-name (current-buffer))
4876                         (buffer-name (get-buffer gnus-article-buffer))))
4877         (save-excursion
4878           (if (get-buffer gnus-original-article-buffer)
4879               (set-buffer gnus-original-article-buffer)
4880             (set-buffer (gnus-get-buffer-create gnus-original-article-buffer))
4881             (set-buffer-multibyte nil)
4882             (buffer-disable-undo)
4883             (setq major-mode 'gnus-original-article-mode)
4884             (setq buffer-read-only t))
4885           (let (buffer-read-only)
4886             (erase-buffer)
4887             (insert-buffer-substring gnus-article-buffer))
4888           (setq gnus-original-article (cons group article)))
4889
4890         ;; Decode charsets.
4891         (run-hooks 'gnus-article-decode-hook)
4892         ;; Mark article as decoded or not.
4893         (setq gnus-article-decoded-p gnus-article-decode-hook))
4894
4895       ;; Update sparse articles.
4896       (when (and do-update-line
4897                  (or (numberp article)
4898                      (stringp article)))
4899         (let ((buf (current-buffer)))
4900           (set-buffer gnus-summary-buffer)
4901           (gnus-summary-update-article do-update-line sparse-header)
4902           (gnus-summary-goto-subject do-update-line nil t)
4903           (set-window-point (get-buffer-window (current-buffer) t)
4904                             (point))
4905           (set-buffer buf))))))
4906
4907 ;;;
4908 ;;; Article editing
4909 ;;;
4910
4911 (defcustom gnus-article-edit-mode-hook nil
4912   "Hook run in article edit mode buffers."
4913   :group 'gnus-article-various
4914   :type 'hook)
4915
4916 (defcustom gnus-article-edit-article-setup-function
4917   'gnus-article-mime-edit-article-setup
4918   "Function called to setup an editing article buffer."
4919   :group 'gnus-article-various
4920   :type 'function)
4921
4922 (defvar gnus-article-edit-done-function nil)
4923
4924 (defvar gnus-article-edit-mode-map nil)
4925
4926 ;; Should we be using derived.el for this?
4927 (unless gnus-article-edit-mode-map
4928   (setq gnus-article-edit-mode-map (make-sparse-keymap))
4929   (set-keymap-parent gnus-article-edit-mode-map text-mode-map)
4930
4931   (gnus-define-keys gnus-article-edit-mode-map
4932     "\C-c\C-c" gnus-article-edit-done
4933     "\C-c\C-k" gnus-article-edit-exit)
4934
4935   (gnus-define-keys (gnus-article-edit-wash-map
4936                      "\C-c\C-w" gnus-article-edit-mode-map)
4937     "f" gnus-article-edit-full-stops))
4938
4939 (defun gnus-article-edit-mode ()
4940   "Major mode for editing articles.
4941 This is an extended text-mode.
4942
4943 \\{gnus-article-edit-mode-map}"
4944   (interactive)
4945   (setq major-mode 'gnus-article-edit-mode)
4946   (setq mode-name "Article Edit")
4947   (use-local-map gnus-article-edit-mode-map)
4948   (make-local-variable 'gnus-article-edit-done-function)
4949   (make-local-variable 'gnus-prev-winconf)
4950   (setq buffer-read-only nil)
4951   (buffer-enable-undo)
4952   (widen)
4953   (gnus-run-hooks 'text-mode-hook 'gnus-article-edit-mode-hook))
4954
4955 (defun gnus-article-edit (&optional force)
4956   "Edit the current article.
4957 This will have permanent effect only in mail groups.
4958 If FORCE is non-nil, allow editing of articles even in read-only
4959 groups."
4960   (interactive "P")
4961   (when (and (not force)
4962              (gnus-group-read-only-p))
4963     (error "The current newsgroup does not support article editing"))
4964   (gnus-article-date-original)
4965   (gnus-article-edit-article
4966    'ignore
4967    `(lambda (no-highlight)
4968       'ignore
4969       (gnus-summary-edit-article-done
4970        ,(or (mail-header-references gnus-current-headers) "")
4971        ,(gnus-group-read-only-p) ,gnus-summary-buffer no-highlight))))
4972
4973 (defun gnus-article-edit-article (start-func exit-func)
4974   "Start editing the contents of the current article buffer."
4975   (let ((winconf (current-window-configuration)))
4976     (set-buffer gnus-article-buffer)
4977     (gnus-article-edit-mode)
4978     (funcall start-func)
4979     (set-buffer-modified-p nil)
4980     (gnus-configure-windows 'edit-article)
4981     (setq gnus-article-edit-done-function exit-func)
4982     (setq gnus-prev-winconf winconf)
4983     (when gnus-article-edit-article-setup-function
4984       (funcall gnus-article-edit-article-setup-function))
4985     (gnus-message 6 "C-c C-c to end edits; C-c C-k to exit")))
4986
4987 (defun gnus-article-edit-done (&optional arg)
4988   "Update the article edits and exit."
4989   (interactive "P")
4990   (let ((func gnus-article-edit-done-function)
4991         (buf (current-buffer))
4992         (start (window-start)))
4993     (remove-hook 'gnus-article-mode-hook
4994                  'gnus-article-mime-edit-article-unwind)
4995     ;; We remove all text props from the article buffer.
4996     (let ((content
4997            (buffer-substring-no-properties (point-min) (point-max)))
4998           (p (point)))
4999       (erase-buffer)
5000       (insert content)
5001       (let ((winconf gnus-prev-winconf))
5002         (gnus-article-mode)
5003         (set-window-configuration winconf)
5004         ;; Tippy-toe some to make sure that point remains where it was.
5005         (save-current-buffer
5006           (set-buffer buf)
5007           (set-window-start (get-buffer-window (current-buffer)) start)
5008           (goto-char p))))
5009     (save-excursion
5010       (set-buffer buf)
5011       (let ((buffer-read-only nil))
5012         (funcall func arg))
5013       ;; The cache and backlog have to be flushed somewhat.
5014       (when gnus-keep-backlog
5015         (gnus-backlog-remove-article
5016          (car gnus-article-current) (cdr gnus-article-current)))
5017       ;; Flush original article as well.
5018       (save-excursion
5019         (when (get-buffer gnus-original-article-buffer)
5020           (set-buffer gnus-original-article-buffer)
5021           (setq gnus-original-article nil)))
5022       (when gnus-use-cache
5023         (gnus-cache-update-article
5024          (car gnus-article-current) (cdr gnus-article-current))))
5025     (set-buffer buf)
5026     (set-window-start (get-buffer-window buf) start)
5027     (set-window-point (get-buffer-window buf) (point))))
5028
5029 (defun gnus-article-edit-exit ()
5030   "Exit the article editing without updating."
5031   (interactive)
5032   (when (or (not (buffer-modified-p))
5033             (yes-or-no-p "Article modified; kill anyway? "))
5034     (let ((curbuf (current-buffer))
5035           (p (point))
5036           (window-start (window-start)))
5037       (erase-buffer)
5038       (if (gnus-buffer-live-p gnus-original-article-buffer)
5039           (insert-buffer gnus-original-article-buffer))
5040       (let ((winconf gnus-prev-winconf))
5041         (gnus-article-mode)
5042         (set-window-configuration winconf)
5043         ;; Tippy-toe some to make sure that point remains where it was.
5044         (save-current-buffer
5045           (set-buffer curbuf)
5046           (set-window-start (get-buffer-window (current-buffer)) window-start)
5047           (goto-char p))))))
5048
5049 (defun gnus-article-edit-full-stops ()
5050   "Interactively repair spacing at end of sentences."
5051   (interactive)
5052   (save-excursion
5053     (goto-char (point-min))
5054     (search-forward-regexp "^$" nil t)
5055     (let ((case-fold-search nil))
5056       (query-replace-regexp "\\([.!?][])}]* \\)\\([[({A-Z]\\)" "\\1 \\2"))))
5057
5058 ;;;
5059 ;;; Article editing with MIME-Edit
5060 ;;;
5061
5062 (defcustom gnus-article-mime-edit-article-setup-hook nil
5063   "Hook run after setting up a MIME editing article buffer."
5064   :group 'gnus-article-various
5065   :type 'hook)
5066
5067 (defun gnus-article-mime-edit-article-unwind ()
5068   "Unwind `gnus-article-buffer' if article editing was given up."
5069   (remove-hook 'gnus-article-mode-hook 'gnus-article-mime-edit-article-unwind)
5070   (when (featurep 'font-lock)
5071     (setq font-lock-defaults nil)
5072     (font-lock-mode -1))
5073   (when mime-edit-mode-flag
5074     (mime-edit-exit 'nomime 'no-error)
5075     (message "")))
5076
5077 (defun gnus-article-mime-edit-article-setup ()
5078   "Convert current buffer to MIME-Edit buffer and turn on MIME-Edit mode
5079 after replacing with the original article."
5080   (setq gnus-show-mime t)
5081   (setq gnus-article-edit-done-function
5082         `(lambda (&rest args)
5083            (when mime-edit-mode-flag
5084              (let (mime-edit-insert-user-agent-field)
5085                (mime-edit-exit))
5086              (message ""))
5087            (goto-char (point-min))
5088            (let (case-fold-search)
5089              (when (re-search-forward
5090                     (format "^%s$" (regexp-quote mail-header-separator))
5091                     nil t)
5092                (replace-match "")))
5093            (apply ,gnus-article-edit-done-function args)
5094            (insert
5095             (prog1
5096                 (buffer-substring-no-properties (point-min) (point-max))
5097               (set-buffer (get-buffer-create gnus-original-article-buffer))
5098               (erase-buffer)))
5099            (setq gnus-current-headers (gnus-article-make-full-mail-header))
5100            (set-buffer gnus-article-buffer)
5101            (gnus-article-prepare-display)))
5102   (substitute-key-definition 'gnus-article-edit-done
5103                              'gnus-article-mime-edit-done
5104                              gnus-article-edit-mode-map)
5105   (substitute-key-definition 'gnus-article-edit-exit
5106                              'gnus-article-mime-edit-exit
5107                              gnus-article-edit-mode-map)
5108   (erase-buffer)
5109   (insert-buffer gnus-original-article-buffer)
5110   (let ((ofn (symbol-function 'mime-edit-decode-single-part-in-buffer)))
5111     (fset 'mime-edit-decode-single-part-in-buffer
5112           (lambda (&rest args)
5113             (if (let ((content-type (car args)))
5114                   (and (eq 'message (mime-content-type-primary-type
5115                                      content-type))
5116                        (eq 'rfc822 (mime-content-type-subtype content-type))))
5117                 (setcar (cdr args) 'not-decode-text))
5118             (apply ofn args)))
5119     (unwind-protect
5120         (mime-edit-again)
5121       (fset 'mime-edit-decode-single-part-in-buffer ofn)))
5122   (when (featurep 'font-lock)
5123     (set (make-local-variable 'font-lock-defaults)
5124          '(message-font-lock-keywords t))
5125     (font-lock-set-defaults)
5126     (turn-on-font-lock))
5127   (set-buffer-modified-p nil)
5128   (delete-other-windows)
5129   (add-hook 'gnus-article-mode-hook 'gnus-article-mime-edit-article-unwind)
5130   (gnus-run-hooks 'gnus-article-mime-edit-article-setup-hook))
5131
5132 (defun gnus-article-mime-edit-done (&optional arg)
5133   "Update the article MIME edits and exit."
5134   (interactive "P")
5135   (when (featurep 'font-lock)
5136     (setq font-lock-defaults nil)
5137     (font-lock-mode -1))
5138   (gnus-article-edit-done arg))
5139
5140 (defun gnus-article-mime-edit-exit ()
5141   "Exit the article MIME editing without updating."
5142   (interactive)
5143   (when (or (not (buffer-modified-p))
5144             (yes-or-no-p "Article modified; kill anyway? "))
5145     (when (featurep 'font-lock)
5146       (setq font-lock-defaults nil)
5147       (font-lock-mode -1))
5148     (when mime-edit-mode-flag
5149       (let (mime-edit-insert-user-agent-field)
5150         (mime-edit-exit))
5151       (message ""))
5152     (goto-char (point-min))
5153     (let (case-fold-search)
5154       (when (re-search-forward
5155              (format "^%s$" (regexp-quote mail-header-separator)) nil t)
5156         (replace-match "")))
5157     (let ((winconf gnus-prev-winconf))
5158       (insert (prog1
5159                   (buffer-substring-no-properties (point-min) (point-max))
5160                 (set-buffer (get-buffer-create gnus-original-article-buffer))
5161                 (erase-buffer)))
5162       (setq gnus-current-headers (gnus-article-make-full-mail-header))
5163       (set-buffer gnus-article-buffer)
5164       (gnus-article-prepare-display)
5165       (set-window-configuration winconf))))
5166
5167 ;;;
5168 ;;; Article highlights
5169 ;;;
5170
5171 ;; Written by Per Abrahamsen <abraham@iesd.auc.dk>.
5172
5173 ;;; Internal Variables:
5174
5175 (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\\)\\)"
5176   "Regular expression that matches URLs."
5177   :group 'gnus-article-buttons
5178   :type 'regexp)
5179
5180 (defcustom gnus-button-alist
5181   `(("<\\(url:[>\n\t ]*?\\)?\\(nntp\\|news\\):[>\n\t ]*\\([^>\n\t ]*@[^>\n\t ]*\\)>"
5182      0 t gnus-button-handle-news 3)
5183     ("\\b\\(nntp\\|news\\):\\([^>\n\t ]*@[^>)!;:,\n\t ]*\\)" 0 t
5184      gnus-button-handle-news 2)
5185     ("\\(\\b<\\(url:[>\n\t ]*\\)?news:[>\n\t ]*\\(//\\)?\\([^>\n\t ]*\\)>\\)"
5186      1 t
5187      gnus-button-fetch-group 4)
5188     ("\\bnews:\\(//\\)?\\([^'\">\n\t ]+\\)" 0 t gnus-button-fetch-group 2)
5189     ("\\bin\\( +article\\| +message\\)? +\\(<\\([^\n @<>]+@[^\n @<>]+\\)>\\)" 2
5190      t gnus-button-message-id 3)
5191     ("\\(<URL: *\\)mailto: *\\([^> \n\t]+\\)>" 0 t gnus-url-mailto 2)
5192     ("mailto:\\([-a-zA-Z.@_+0-9%=?]+\\)" 0 t gnus-url-mailto 1)
5193     ("\\bmailto:\\([^ \n\t]+\\)" 0 t gnus-url-mailto 1)
5194     ;; This is how URLs _should_ be embedded in text...
5195     ("<URL: *\\([^<>]*\\)>" 0 t gnus-button-embedded-url 1)
5196     ;; Raw URLs.
5197     (,gnus-button-url-regexp 0 t browse-url 0))
5198   "*Alist of regexps matching buttons in article bodies.
5199
5200 Each entry has the form (REGEXP BUTTON FORM CALLBACK PAR...), where
5201 REGEXP: is the string matching text around the button,
5202 BUTTON: is the number of the regexp grouping actually matching the button,
5203 FORM: is a lisp expression which must eval to true for the button to
5204 be added,
5205 CALLBACK: is the function to call when the user push this button, and each
5206 PAR: is a number of a regexp grouping whose text will be passed to CALLBACK.
5207
5208 CALLBACK can also be a variable, in that case the value of that
5209 variable it the real callback function."
5210   :group 'gnus-article-buttons
5211   :type '(repeat (list regexp
5212                        (integer :tag "Button")
5213                        (sexp :tag "Form")
5214                        (function :tag "Callback")
5215                        (repeat :tag "Par"
5216                                :inline t
5217                                (integer :tag "Regexp group")))))
5218
5219 (defcustom gnus-header-button-alist
5220   `(("^\\(References\\|Message-I[Dd]\\):" "<[^>]+>"
5221      0 t gnus-button-message-id 0)
5222     ("^\\(From\\|Reply-To\\):" ": *\\(.+\\)$" 1 t gnus-button-reply 1)
5223     ("^\\(Cc\\|To\\):" "[^ \t\n<>,()\"]+@[^ \t\n<>,()\"]+"
5224      0 t gnus-button-mailto 0)
5225     ("^X-[Uu][Rr][Ll]:" ,gnus-button-url-regexp 0 t browse-url 0)
5226     ("^Subject:" ,gnus-button-url-regexp 0 t browse-url 0)
5227     ("^[^:]+:" ,gnus-button-url-regexp 0 t browse-url 0)
5228     ("^[^:]+:" "\\(<\\(url: \\)?news:\\([^>\n ]*\\)>\\)" 1 t
5229      gnus-button-message-id 3))
5230   "*Alist of headers and regexps to match buttons in article heads.
5231
5232 This alist is very similar to `gnus-button-alist', except that each
5233 alist has an additional HEADER element first in each entry:
5234
5235 \(HEADER REGEXP BUTTON FORM CALLBACK PAR)
5236
5237 HEADER is a regexp to match a header.  For a fuller explanation, see
5238 `gnus-button-alist'."
5239   :group 'gnus-article-buttons
5240   :group 'gnus-article-headers
5241   :type '(repeat (list (regexp :tag "Header")
5242                        regexp
5243                        (integer :tag "Button")
5244                        (sexp :tag "Form")
5245                        (function :tag "Callback")
5246                        (repeat :tag "Par"
5247                                :inline t
5248                                (integer :tag "Regexp group")))))
5249
5250 (defvar gnus-button-regexp nil)
5251 (defvar gnus-button-marker-list nil)
5252 ;; Regexp matching any of the regexps from `gnus-button-alist'.
5253
5254 (defvar gnus-button-last nil)
5255 ;; The value of `gnus-button-alist' when `gnus-button-regexp' was build.
5256
5257 ;;; Commands:
5258
5259 (defun gnus-article-push-button (event)
5260   "Check text under the mouse pointer for a callback function.
5261 If the text under the mouse pointer has a `gnus-callback' property,
5262 call it with the value of the `gnus-data' text property."
5263   (interactive "e")
5264   (set-buffer (window-buffer (posn-window (event-start event))))
5265   (let* ((pos (posn-point (event-start event)))
5266          (data (get-text-property pos 'gnus-data))
5267          (fun (get-text-property pos 'gnus-callback)))
5268     (goto-char pos)
5269     (when fun
5270       (funcall fun data))))
5271
5272 (defun gnus-article-press-button ()
5273   "Check text at point for a callback function.
5274 If the text at point has a `gnus-callback' property,
5275 call it with the value of the `gnus-data' text property."
5276   (interactive)
5277   (let* ((data (get-text-property (point) 'gnus-data))
5278          (fun (get-text-property (point) 'gnus-callback)))
5279     (when fun
5280       (funcall fun data))))
5281
5282 (defun gnus-article-prev-button (n)
5283   "Move point to N buttons backward.
5284 If N is negative, move forward instead."
5285   (interactive "p")
5286   (gnus-article-next-button (- n)))
5287
5288 (defun gnus-article-next-button (n)
5289   "Move point to N buttons forward.
5290 If N is negative, move backward instead."
5291   (interactive "p")
5292   (let ((function (if (< n 0) 'previous-single-property-change
5293                     'next-single-property-change))
5294         (inhibit-point-motion-hooks t)
5295         (backward (< n 0))
5296         (limit (if (< n 0) (point-min) (point-max))))
5297     (setq n (abs n))
5298     (while (and (not (= limit (point)))
5299                 (> n 0))
5300       ;; Skip past the current button.
5301       (when (get-text-property (point) 'gnus-callback)
5302         (goto-char (funcall function (point) 'gnus-callback nil limit)))
5303       ;; Go to the next (or previous) button.
5304       (gnus-goto-char (funcall function (point) 'gnus-callback nil limit))
5305       ;; Put point at the start of the button.
5306       (when (and backward (not (get-text-property (point) 'gnus-callback)))
5307         (goto-char (funcall function (point) 'gnus-callback nil limit)))
5308       ;; Skip past intangible buttons.
5309       (when (get-text-property (point) 'intangible)
5310         (incf n))
5311       (decf n))
5312     (unless (zerop n)
5313       (gnus-message 5 "No more buttons"))
5314     n))
5315
5316 (defun gnus-article-highlight (&optional force)
5317   "Highlight current article.
5318 This function calls `gnus-article-highlight-headers',
5319 `gnus-article-highlight-citation',
5320 `gnus-article-highlight-signature', and `gnus-article-add-buttons' to
5321 do the highlighting.  See the documentation for those functions."
5322   (interactive (list 'force))
5323   (gnus-article-highlight-headers)
5324   (gnus-article-highlight-citation force)
5325   (gnus-article-highlight-signature)
5326   (gnus-article-add-buttons force)
5327   (gnus-article-add-buttons-to-head))
5328
5329 (defun gnus-article-highlight-some (&optional force)
5330   "Highlight current article.
5331 This function calls `gnus-article-highlight-headers',
5332 `gnus-article-highlight-signature', and `gnus-article-add-buttons' to
5333 do the highlighting.  See the documentation for those functions."
5334   (interactive (list 'force))
5335   (gnus-article-highlight-headers)
5336   (gnus-article-highlight-signature)
5337   (gnus-article-add-buttons))
5338
5339 (defun gnus-article-highlight-headers ()
5340   "Highlight article headers as specified by `gnus-header-face-alist'."
5341   (interactive)
5342   (save-excursion
5343     (set-buffer gnus-article-buffer)
5344     (save-restriction
5345       (let ((alist gnus-header-face-alist)
5346             (buffer-read-only nil)
5347             (case-fold-search t)
5348             (inhibit-point-motion-hooks t)
5349             entry regexp header-face field-face from hpoints fpoints)
5350         (article-narrow-to-head)
5351         (while (setq entry (pop alist))
5352           (goto-char (point-min))
5353           (setq regexp (concat "^\\("
5354                                (if (string-equal "" (nth 0 entry))
5355                                    "[^\t ]"
5356                                  (nth 0 entry))
5357                                "\\)")
5358                 header-face (nth 1 entry)
5359                 field-face (nth 2 entry))
5360           (while (and (re-search-forward regexp nil t)
5361                       (not (eobp)))
5362             (beginning-of-line)
5363             (setq from (point))
5364             (unless (search-forward ":" nil t)
5365               (forward-char 1))
5366             (when (and header-face
5367                        (not (memq (point) hpoints)))
5368               (push (point) hpoints)
5369               (gnus-put-text-property from (point) 'face header-face))
5370             (when (and field-face
5371                        (not (memq (setq from (point)) fpoints)))
5372               (push from fpoints)
5373               (if (re-search-forward "^[^ \t]" nil t)
5374                   (forward-char -2)
5375                 (goto-char (point-max)))
5376               (gnus-put-text-property from (point) 'face field-face))))))))
5377
5378 (defun gnus-article-highlight-signature ()
5379   "Highlight the signature in an article.
5380 It does this by highlighting everything after
5381 `gnus-signature-separator' using `gnus-signature-face'."
5382   (interactive)
5383   (when gnus-signature-face
5384     (save-excursion
5385       (set-buffer gnus-article-buffer)
5386       (let ((buffer-read-only nil)
5387             (inhibit-point-motion-hooks t))
5388         (save-restriction
5389           (when (gnus-article-narrow-to-signature)
5390             (gnus-overlay-put (gnus-make-overlay (point-min) (point-max))
5391                               'face gnus-signature-face)))))))
5392
5393 (defun gnus-article-buttonize-signature ()
5394   "Add button to the signature."
5395   (interactive)
5396   (save-excursion
5397     (set-buffer gnus-article-buffer)
5398     (let ((buffer-read-only nil)
5399           (inhibit-point-motion-hooks t))
5400       (when (gnus-article-search-signature)
5401         (gnus-article-add-button (match-beginning 0) (match-end 0)
5402                                  'gnus-signature-toggle
5403                                  (set-marker (make-marker)
5404                                              (1+ (match-end 0))))))))
5405
5406 (defun gnus-button-in-region-p (b e prop)
5407   "Say whether PROP exists in the region."
5408   (text-property-not-all b e prop nil))
5409
5410 (defun gnus-article-add-buttons (&optional force)
5411   "Find external references in the article and make buttons of them.
5412 \"External references\" are things like Message-IDs and URLs, as
5413 specified by `gnus-button-alist'."
5414   (interactive (list 'force))
5415   (save-excursion
5416     (set-buffer gnus-article-buffer)
5417     (let ((buffer-read-only nil)
5418           (inhibit-point-motion-hooks t)
5419           (case-fold-search t)
5420           (alist gnus-button-alist)
5421           beg entry regexp)
5422       ;; Remove all old markers.
5423       (let (marker entry new-list)
5424         (while (setq marker (pop gnus-button-marker-list))
5425           (if (or (< marker (point-min)) (>= marker (point-max)))
5426               (push marker new-list)
5427             (goto-char marker)
5428             (when (setq entry (gnus-button-entry))
5429               (put-text-property (match-beginning (nth 1 entry))
5430                                  (match-end (nth 1 entry))
5431                                  'gnus-callback nil))
5432             (set-marker marker nil)))
5433         (setq gnus-button-marker-list new-list))
5434       ;; We skip the headers.
5435       (article-goto-body)
5436       (setq beg (point))
5437       (while (setq entry (pop alist))
5438         (setq regexp (car entry))
5439         (goto-char beg)
5440         (while (re-search-forward regexp nil t)
5441           (let* ((start (and entry (match-beginning (nth 1 entry))))
5442                  (end (and entry (match-end (nth 1 entry))))
5443                  (from (match-beginning 0)))
5444             (when (and (or (eq t (nth 2 entry))
5445                            (eval (nth 2 entry)))
5446                        (not (gnus-button-in-region-p
5447                              start end 'gnus-callback)))
5448               ;; That optional form returned non-nil, so we add the
5449               ;; button.
5450               (gnus-article-add-button
5451                start end 'gnus-button-push
5452                (car (push (set-marker (make-marker) from)
5453                           gnus-button-marker-list))))))))))
5454
5455 ;; Add buttons to the head of an article.
5456 (defun gnus-article-add-buttons-to-head ()
5457   "Add buttons to the head of the article."
5458   (interactive)
5459   (save-excursion
5460     (set-buffer gnus-article-buffer)
5461     (save-restriction
5462       (let ((buffer-read-only nil)
5463             (inhibit-point-motion-hooks t)
5464             (case-fold-search t)
5465             (alist gnus-header-button-alist)
5466             entry beg end)
5467         (article-narrow-to-head)
5468         (while alist
5469           ;; Each alist entry.
5470           (setq entry (car alist)
5471                 alist (cdr alist))
5472           (goto-char (point-min))
5473           (while (re-search-forward (car entry) nil t)
5474             ;; Each header matching the entry.
5475             (setq beg (match-beginning 0))
5476             (setq end (or (and (re-search-forward "^[^ \t]" nil t)
5477                                (match-beginning 0))
5478                           (point-max)))
5479             (goto-char beg)
5480             (while (re-search-forward (nth 1 entry) end t)
5481               ;; Each match within a header.
5482               (let* ((entry (cdr entry))
5483                      (start (match-beginning (nth 1 entry)))
5484                      (end (match-end (nth 1 entry)))
5485                      (form (nth 2 entry)))
5486                 (goto-char (match-end 0))
5487                 (when (eval form)
5488                   (gnus-article-add-button
5489                    start end (nth 3 entry)
5490                    (buffer-substring (match-beginning (nth 4 entry))
5491                                      (match-end (nth 4 entry)))))))
5492             (goto-char end)))))))
5493
5494 ;;; External functions:
5495
5496 (defun gnus-article-add-button (from to fun &optional data)
5497   "Create a button between FROM and TO with callback FUN and data DATA."
5498   (when gnus-article-button-face
5499     (gnus-overlay-put (gnus-make-overlay from to)
5500                       'face gnus-article-button-face))
5501   (gnus-add-text-properties
5502    from to
5503    (nconc (and gnus-article-mouse-face
5504                (list gnus-mouse-face-prop gnus-article-mouse-face))
5505           (list 'gnus-callback fun)
5506           (and data (list 'gnus-data data))))
5507   (widget-convert-button 'link from to :action 'gnus-widget-press-button
5508                          ;; Quote `:button-keymap' for Mule 2.3
5509                          ;; but it won't work.
5510                          ':button-keymap gnus-widget-button-keymap))
5511
5512 ;;; Internal functions:
5513
5514 (defun gnus-article-set-globals ()
5515   (save-excursion
5516     (set-buffer gnus-summary-buffer)
5517     (gnus-set-global-variables)))
5518
5519 (defun gnus-signature-toggle (end)
5520   (save-excursion
5521     (set-buffer gnus-article-buffer)
5522     (let ((buffer-read-only nil)
5523           (inhibit-point-motion-hooks t)
5524           (limit (next-single-property-change end 'mime-view-entity
5525                                               nil (point-max))))
5526       (if (text-property-any end limit 'article-type 'signature)
5527           (gnus-remove-text-properties-when
5528            'article-type 'signature end limit
5529            (cons 'article-type (cons 'signature
5530                                      gnus-hidden-properties)))
5531         (gnus-add-text-properties-when
5532          'article-type nil end limit
5533          (cons 'article-type (cons 'signature
5534                                    gnus-hidden-properties)))))))
5535
5536 (defun gnus-button-entry ()
5537   ;; Return the first entry in `gnus-button-alist' matching this place.
5538   (let ((alist gnus-button-alist)
5539         (entry nil))
5540     (while alist
5541       (setq entry (pop alist))
5542       (if (looking-at (car entry))
5543           (setq alist nil)
5544         (setq entry nil)))
5545     entry))
5546
5547 (defun gnus-button-push (marker)
5548   ;; Push button starting at MARKER.
5549   (save-excursion
5550     (goto-char marker)
5551     (let* ((entry (gnus-button-entry))
5552            (inhibit-point-motion-hooks t)
5553            (fun (nth 3 entry))
5554            (args (mapcar (lambda (group)
5555                            (let ((string (match-string group)))
5556                              (gnus-set-text-properties
5557                               0 (length string) nil string)
5558                              string))
5559                          (nthcdr 4 entry))))
5560       (cond
5561        ((fboundp fun)
5562         (apply fun args))
5563        ((and (boundp fun)
5564              (fboundp (symbol-value fun)))
5565         (apply (symbol-value fun) args))
5566        (t
5567         (gnus-message 1 "You must define `%S' to use this button"
5568                       (cons fun args)))))))
5569
5570 (defun gnus-parse-news-url (url)
5571   (let (scheme server group message-id articles)
5572     (with-temp-buffer
5573       (insert url)
5574       (goto-char (point-min))
5575       (when (looking-at "\\([A-Za-z]+\\):")
5576         (setq scheme (match-string 1))
5577         (goto-char (match-end 0)))
5578       (when (looking-at "//\\([^/]+\\)/")
5579         (setq server (match-string 1))
5580         (goto-char (match-end 0)))
5581
5582       (cond
5583        ((looking-at "\\(.*@.*\\)")
5584         (setq message-id (match-string 1)))
5585        ((looking-at "\\([^/]+\\)/\\([-0-9]+\\)")
5586         (setq group (match-string 1)
5587               articles (split-string (match-string 2) "-")))
5588        ((looking-at "\\([^/]+\\)/?")
5589         (setq group (match-string 1)))
5590        (t
5591         (error "Unknown news URL syntax"))))
5592     (list scheme server group message-id articles)))
5593
5594 (defun gnus-button-handle-news (url)
5595   "Fetch a news URL."
5596   (destructuring-bind (scheme server group message-id articles)
5597       (gnus-parse-news-url url)
5598     (cond
5599      (message-id
5600       (save-excursion
5601         (set-buffer gnus-summary-buffer)
5602         (if server
5603             (let ((gnus-refer-article-method (list (list 'nntp server))))
5604               (gnus-summary-refer-article message-id))
5605           (gnus-summary-refer-article message-id))))
5606      (group
5607       (gnus-button-fetch-group url)))))
5608
5609 (defun gnus-button-message-id (message-id)
5610   "Fetch MESSAGE-ID."
5611   (save-excursion
5612     (set-buffer gnus-summary-buffer)
5613     (gnus-summary-refer-article message-id)))
5614
5615 (defun gnus-button-fetch-group (address)
5616   "Fetch GROUP specified by ADDRESS."
5617   (if (not (string-match "[:/]" address))
5618       ;; This is just a simple group url.
5619       (gnus-group-read-ephemeral-group address gnus-select-method)
5620     (if (not (string-match "^\\([^:/]+\\)\\(:\\([^/]+\\)/\\)?\\(.*\\)$"
5621                            address))
5622         (error "Can't parse %s" address)
5623       (gnus-group-read-ephemeral-group
5624        (match-string 4 address)
5625        `(nntp ,(match-string 1 address)
5626               (nntp-address ,(match-string 1 address))
5627               (nntp-port-number ,(if (match-end 3)
5628                                      (match-string 3 address)
5629                                    "nntp")))))))
5630
5631 (defun gnus-url-parse-query-string (query &optional downcase)
5632   (let (retval pairs cur key val)
5633     (setq pairs (split-string query "&"))
5634     (while pairs
5635       (setq cur (car pairs)
5636             pairs (cdr pairs))
5637       (if (not (string-match "=" cur))
5638           nil                           ; Grace
5639         (setq key (gnus-url-unhex-string (substring cur 0 (match-beginning 0)))
5640               val (gnus-url-unhex-string (substring cur (match-end 0) nil)))
5641         (if downcase
5642             (setq key (downcase key)))
5643         (setq cur (assoc key retval))
5644         (if cur
5645             (setcdr cur (cons val (cdr cur)))
5646           (setq retval (cons (list key val) retval)))))
5647     retval))
5648
5649 (defun gnus-url-unhex (x)
5650   (if (> x ?9)
5651       (if (>= x ?a)
5652           (+ 10 (- x ?a))
5653         (+ 10 (- x ?A)))
5654     (- x ?0)))
5655
5656 (defun gnus-url-unhex-string (str &optional allow-newlines)
5657   "Remove %XXX embedded spaces, etc in a url.
5658 If optional second argument ALLOW-NEWLINES is non-nil, then allow the
5659 decoding of carriage returns and line feeds in the string, which is normally
5660 forbidden in URL encoding."
5661   (setq str (or str ""))
5662   (let ((tmp "")
5663         (case-fold-search t))
5664     (while (string-match "%[0-9a-f][0-9a-f]" str)
5665       (let* ((start (match-beginning 0))
5666              (ch1 (gnus-url-unhex (elt str (+ start 1))))
5667              (code (+ (* 16 ch1)
5668                       (gnus-url-unhex (elt str (+ start 2))))))
5669         (setq tmp (concat
5670                    tmp (substring str 0 start)
5671                    (cond
5672                     (allow-newlines
5673                      (char-to-string code))
5674                     ((or (= code ?\n) (= code ?\r))
5675                      " ")
5676                     (t (char-to-string code))))
5677               str (substring str (match-end 0)))))
5678     (setq tmp (concat tmp str))
5679     tmp))
5680
5681 (defun gnus-url-mailto (url)
5682   ;; Send mail to someone
5683   (when (string-match "mailto:/*\\(.*\\)" url)
5684     (setq url (substring url (match-beginning 1) nil)))
5685   (let (to args subject func)
5686     (if (string-match (regexp-quote "?") url)
5687         (setq to (gnus-url-unhex-string (substring url 0 (match-beginning 0)))
5688               args (gnus-url-parse-query-string
5689                     (substring url (match-end 0) nil) t))
5690       (setq to (gnus-url-unhex-string url)))
5691     (setq args (cons (list "to" to) args)
5692           subject (cdr-safe (assoc "subject" args)))
5693     (gnus-msg-mail)
5694     (while args
5695       (setq func (intern-soft (concat "message-goto-" (downcase (caar args)))))
5696       (if (fboundp func)
5697           (funcall func)
5698         (message-position-on-field (caar args)))
5699       (insert (mapconcat 'identity (cdar args) ", "))
5700       (setq args (cdr args)))
5701     (if subject
5702         (message-goto-body)
5703       (message-goto-subject))))
5704
5705 (defun gnus-button-embedded-url (address)
5706   "Activate ADDRESS with `browse-url'."
5707   (browse-url (gnus-strip-whitespace address)))
5708
5709 (eval-when-compile
5710   ;; Silence the byte-compiler.
5711   (autoload 'smiley-toggle-buffer "gnus-bitmap"))
5712 (defun gnus-article-smiley-display ()
5713   "Display \"smileys\" as small graphical icons."
5714   (smiley-toggle-buffer 1 (current-buffer) (point-min) (point-max)))
5715
5716 ;;; Next/prev buttons in the article buffer.
5717
5718 (defvar gnus-next-page-line-format "%{%(Next page...%)%}\n")
5719 (defvar gnus-prev-page-line-format "%{%(Previous page...%)%}\n")
5720
5721 (defvar gnus-prev-page-map nil)
5722 (unless gnus-prev-page-map
5723   (setq gnus-prev-page-map (make-sparse-keymap))
5724   (define-key gnus-prev-page-map gnus-mouse-2 'gnus-button-prev-page)
5725   (define-key gnus-prev-page-map "\r" 'gnus-button-prev-page))
5726
5727 (static-if (featurep 'xemacs)
5728     (defun gnus-insert-prev-page-button ()
5729       (let ((buffer-read-only nil))
5730         (gnus-eval-format
5731          gnus-prev-page-line-format nil
5732          `(gnus-prev t local-map ,gnus-prev-page-map
5733                      gnus-callback gnus-article-button-prev-page
5734                      article-type annotation))))
5735   (defun gnus-insert-prev-page-button ()
5736     (let ((buffer-read-only nil)
5737           (situation (get-text-property (point-min) 'mime-view-situation)))
5738       (set-keymap-parent gnus-prev-page-map (current-local-map))
5739       (gnus-eval-format
5740        gnus-prev-page-line-format nil
5741        `(gnus-prev t local-map ,gnus-prev-page-map
5742                    gnus-callback gnus-article-button-prev-page
5743                    article-type annotation
5744                    mime-view-situation ,situation))))
5745   )
5746
5747 (defvar gnus-next-page-map nil)
5748 (unless gnus-next-page-map
5749   (setq gnus-next-page-map (make-sparse-keymap))
5750   (define-key gnus-next-page-map gnus-mouse-2 'gnus-button-next-page)
5751   (define-key gnus-next-page-map "\r" 'gnus-button-next-page))
5752
5753 (defun gnus-button-next-page ()
5754   "Go to the next page."
5755   (interactive)
5756   (let ((win (selected-window)))
5757     (select-window (get-buffer-window gnus-article-buffer t))
5758     (gnus-article-next-page)
5759     (select-window win)))
5760
5761 (defun gnus-button-prev-page ()
5762   "Go to the prev page."
5763   (interactive)
5764   (let ((win (selected-window)))
5765     (select-window (get-buffer-window gnus-article-buffer t))
5766     (gnus-article-prev-page)
5767     (select-window win)))
5768
5769 (static-if (featurep 'xemacs)
5770     (defun gnus-insert-next-page-button ()
5771       (let ((buffer-read-only nil))
5772         (gnus-eval-format gnus-next-page-line-format nil
5773                           `(gnus-next
5774                             t local-map ,gnus-next-page-map
5775                             gnus-callback gnus-article-button-next-page
5776                             article-type annotation))))
5777   (defun gnus-insert-next-page-button ()
5778     (let ((buffer-read-only nil)
5779           (situation (get-text-property (point-min) 'mime-view-situation)))
5780       (set-keymap-parent gnus-next-page-map (current-local-map))
5781       (gnus-eval-format gnus-next-page-line-format nil
5782                         `(gnus-next
5783                           t local-map ,gnus-next-page-map
5784                           gnus-callback gnus-article-button-next-page
5785                           article-type annotation
5786                           mime-view-situation ,situation))))
5787   )
5788
5789 (defun gnus-article-button-next-page (arg)
5790   "Go to the next page."
5791   (interactive "P")
5792   (let ((win (selected-window)))
5793     (select-window (get-buffer-window gnus-article-buffer t))
5794     (gnus-article-next-page)
5795     (select-window win)))
5796
5797 (defun gnus-article-button-prev-page (arg)
5798   "Go to the prev page."
5799   (interactive "P")
5800   (let ((win (selected-window)))
5801     (select-window (get-buffer-window gnus-article-buffer t))
5802     (gnus-article-prev-page)
5803     (select-window win)))
5804
5805 (defvar gnus-decode-header-methods
5806   '(mail-decode-encoded-word-region)
5807   "List of methods used to decode headers.
5808
5809 This variable is a list of FUNCTION or (REGEXP . FUNCTION).  If item
5810 is FUNCTION, FUNCTION will be apply to all newsgroups.  If item is a
5811 (REGEXP . FUNCTION), FUNCTION will be only apply to thes newsgroups
5812 whose names match REGEXP.
5813
5814 For example:
5815 ((\"chinese\" . gnus-decode-encoded-word-region-by-guess)
5816  mail-decode-encoded-word-region
5817  (\"chinese\" . rfc1843-decode-region))
5818 ")
5819
5820 (defvar gnus-decode-header-methods-cache nil)
5821
5822 (defun gnus-multi-decode-header (start end)
5823   "Apply the functions from `gnus-encoded-word-methods' that match."
5824   (unless (and gnus-decode-header-methods-cache
5825                (eq gnus-newsgroup-name
5826                    (car gnus-decode-header-methods-cache)))
5827     (setq gnus-decode-header-methods-cache (list gnus-newsgroup-name))
5828     (mapcar (lambda (x)
5829               (if (symbolp x)
5830                   (nconc gnus-decode-header-methods-cache (list x))
5831                 (if (and gnus-newsgroup-name
5832                          (string-match (car x) gnus-newsgroup-name))
5833                     (nconc gnus-decode-header-methods-cache
5834                            (list (cdr x))))))
5835           gnus-decode-header-methods))
5836   (let ((xlist gnus-decode-header-methods-cache))
5837     (pop xlist)
5838     (save-restriction
5839       (narrow-to-region start end)
5840       (while xlist
5841         (funcall (pop xlist) (point-min) (point-max))))))
5842
5843 ;;;
5844 ;;; Treatment top-level handling.
5845 ;;;
5846
5847 (defun gnus-treat-article (condition &optional part-number total-parts type)
5848   (let ((length (- (point-max) (point-min)))
5849         (alist gnus-treatment-function-alist)
5850         (article-goto-body-goes-to-point-min-p t)
5851         (treated-type
5852          (or (not type)
5853              (catch 'found
5854                (let ((list gnus-article-treat-types))
5855                  (while list
5856                    (when (string-match (pop list) type)
5857                      (throw 'found t)))))))
5858         (highlightp (gnus-visual-p 'article-highlight 'highlight))
5859         (entity (static-unless (featurep 'xemacs)
5860                   (when (eq 'head condition)
5861                     (get-text-property (point-min) 'mime-view-entity))))
5862         val elem buttonized)
5863     (gnus-run-hooks 'gnus-part-display-hook)
5864     (unless gnus-inhibit-treatment
5865       (while (setq elem (pop alist))
5866         (setq val
5867               (save-excursion
5868                 (if (gnus-buffer-live-p gnus-summary-buffer)
5869                     (set-buffer gnus-summary-buffer))
5870                 (symbol-value (car elem))))
5871         (when (and (or (consp val)
5872                        treated-type)
5873                    (gnus-treat-predicate val)
5874                    (or (not (get (car elem) 'highlight))
5875                        highlightp))
5876           (when (and (not buttonized)
5877                      (memq (car elem)
5878                            '(gnus-treat-hide-signature
5879                              gnus-treat-highlight-signature)))
5880             (gnus-article-buttonize-signature)
5881             (setq buttonized t))
5882           (save-restriction
5883             (funcall (cadr elem)))))
5884       ;; FSF Emacsen does not inherit the existing text properties
5885       ;; in the new text, so we should do it for `mime-view-entity'.
5886       (static-unless (featurep 'xemacs)
5887         (when entity
5888           (put-text-property (point-min) (point-max)
5889                              'mime-view-entity entity))))))
5890
5891 ;; Dynamic variables.
5892 (eval-when-compile
5893   (defvar part-number)
5894   (defvar total-parts)
5895   (defvar type)
5896   (defvar condition)
5897   (defvar length))
5898
5899 (defun gnus-treat-predicate (val)
5900   (cond
5901    ((null val)
5902     nil)
5903    ((and (listp val)
5904          (stringp (car val)))
5905     (apply 'gnus-or (mapcar `(lambda (s)
5906                                (string-match s ,(or gnus-newsgroup-name "")))
5907                             val)))
5908    ((listp val)
5909     (let ((pred (pop val)))
5910       (cond
5911        ((eq pred 'or)
5912         (apply 'gnus-or (mapcar 'gnus-treat-predicate val)))
5913        ((eq pred 'and)
5914         (apply 'gnus-and (mapcar 'gnus-treat-predicate val)))
5915        ((eq pred 'not)
5916         (not (gnus-treat-predicate (car val))))
5917        ((eq pred 'typep)
5918         (equal (car val) type))
5919        (t
5920         (error "%S is not a valid predicate" pred)))))
5921    ((eq val 'mime)
5922     gnus-show-mime)
5923    (condition
5924     (eq condition val))
5925    ((eq val t)
5926     t)
5927    ((eq val 'head)
5928     nil)
5929    ((eq val 'last)
5930     (eq part-number total-parts))
5931    ((numberp val)
5932     (< length val))
5933    (t
5934     (error "%S is not a valid value" val))))
5935
5936 (defun gnus-article-encrypt-body (protocol &optional n)
5937   "Encrypt the article body."
5938   (interactive
5939    (list
5940     (or gnus-article-encrypt-protocol
5941         (completing-read "Encrypt protocol: "
5942                          gnus-article-encrypt-protocol-alist
5943                          nil t))
5944     current-prefix-arg))
5945   (let ((func (cdr (assoc protocol gnus-article-encrypt-protocol-alist))))
5946     (unless func
5947       (error (format "Can't find the encrypt protocol %s" protocol)))
5948     (if (equal gnus-newsgroup-name "nndraft:drafts")
5949         (error "Can't encrypt the article in group nndraft:drafts."))
5950     (if (equal gnus-newsgroup-name "nndraft:queue")
5951         (error "Don't encrypt the article in group nndraft:queue."))
5952     (gnus-summary-iterate n
5953       (save-excursion
5954         (set-buffer gnus-summary-buffer)
5955         (let ((mail-parse-charset gnus-newsgroup-charset)
5956               (mail-parse-ignored-charsets gnus-newsgroup-ignored-charsets)
5957               (summary-buffer gnus-summary-buffer)
5958               references point)
5959           (gnus-set-global-variables)
5960           (when (gnus-group-read-only-p)
5961             (error "The current newsgroup does not support article encrypt"))
5962           (gnus-summary-show-article t)
5963           (setq references
5964               (or (mail-header-references gnus-current-headers) ""))
5965           (set-buffer gnus-article-buffer)
5966           (let* ((buffer-read-only nil)
5967                  (headers
5968                   (mapcar (lambda (field)
5969                             (and (save-restriction
5970                                    (message-narrow-to-head)
5971                                    (goto-char (point-min))
5972                                    (search-forward field nil t))
5973                                  (prog2
5974                                      (message-narrow-to-field)
5975                                      (buffer-substring (point-min) (point-max))
5976                                    (delete-region (point-min) (point-max))
5977                                    (widen))))
5978                           '("Content-Type:" "Content-Transfer-Encoding:"
5979                             "Content-Disposition:"))))
5980             (message-narrow-to-head)
5981             (message-remove-header "MIME-Version")
5982             (goto-char (point-max))
5983             (setq point (point))
5984             (insert (apply 'concat headers))
5985             (widen)
5986             (narrow-to-region point (point-max))
5987             (let ((message-options message-options))
5988               (message-options-set 'message-sender user-mail-address)
5989               (message-options-set 'message-recipients user-mail-address)
5990               (message-options-set 'message-sign-encrypt 'not)
5991               (funcall func))
5992             (goto-char (point-min))
5993             (insert "MIME-Version: 1.0\n")
5994             (widen)
5995             (gnus-summary-edit-article-done
5996              references nil summary-buffer t))
5997           (when gnus-keep-backlog
5998             (gnus-backlog-remove-article
5999              (car gnus-article-current) (cdr gnus-article-current)))
6000           (save-excursion
6001             (when (get-buffer gnus-original-article-buffer)
6002               (set-buffer gnus-original-article-buffer)
6003               (setq gnus-original-article nil)))
6004           (when gnus-use-cache
6005             (gnus-cache-update-article
6006              (car gnus-article-current) (cdr gnus-article-current))))))))
6007
6008 (defvar gnus-mime-security-button-line-format "%{%([[%t:%i]%D]%)%}\n"
6009   "The following specs can be used:
6010 %t  The security MIME type
6011 %i  Additional info
6012 %d  Details
6013 %D  Details if button is pressed")
6014
6015 (defvar gnus-mime-security-button-end-line-format "%{%([[End of %t]%D]%)%}\n"
6016   "The following specs can be used:
6017 %t  The security MIME type
6018 %i  Additional info
6019 %d  Details
6020 %D  Details if button is pressed")
6021
6022 (defvar gnus-mime-security-button-line-format-alist
6023   '((?t gnus-tmp-type ?s)
6024     (?i gnus-tmp-info ?s)
6025     (?d gnus-tmp-details ?s)
6026     (?D gnus-tmp-pressed-details ?s)))
6027
6028 (defvar gnus-mime-security-button-map
6029   (let ((map (make-sparse-keymap)))
6030     (unless (>= (string-to-number emacs-version) 21)
6031       (set-keymap-parent map gnus-article-mode-map))
6032     (define-key map gnus-mouse-2 'gnus-article-push-button)
6033     (define-key map "\r" 'gnus-article-press-button)
6034     map))
6035
6036 (defvar gnus-mime-security-details-buffer nil)
6037
6038 (defvar gnus-mime-security-button-pressed nil)
6039
6040 (defvar gnus-mime-security-show-details-inline t
6041   "If non-nil, show details in the article buffer.")
6042
6043 (defun gnus-mime-security-verify-or-decrypt (handle)
6044   (mm-remove-parts (cdr handle))
6045   (let ((region (mm-handle-multipart-ctl-parameter handle 'gnus-region))
6046         buffer-read-only)
6047     (when region
6048       (delete-region (car region) (cdr region))
6049       (set-marker (car region) nil)
6050       (set-marker (cdr region) nil)))
6051   (with-current-buffer (mm-handle-multipart-original-buffer handle)
6052     (let* ((mm-verify-option 'known)
6053            (mm-decrypt-option 'known)
6054            (nparts (mm-possibly-verify-or-decrypt (cdr handle) handle)))
6055       (unless (eq nparts (cdr handle))
6056         (mm-destroy-parts (cdr handle))
6057         (setcdr handle nparts))))
6058   (let ((point (point))
6059         buffer-read-only)
6060     (gnus-mime-display-security handle)
6061     (goto-char point)))
6062
6063 (defun gnus-mime-security-show-details (handle)
6064   (let ((details (mm-handle-multipart-ctl-parameter handle 'gnus-details)))
6065     (if details
6066         (if gnus-mime-security-show-details-inline
6067             (let ((gnus-mime-security-button-pressed t)
6068                   (gnus-mime-security-button-line-format
6069                    (get-text-property (point) 'gnus-line-format))
6070                 buffer-read-only)
6071               (forward-char -1)
6072               (while (eq (get-text-property (point) 'gnus-line-format)
6073                          gnus-mime-security-button-line-format)
6074                 (forward-char -1))
6075               (forward-char)
6076               (delete-region (point)
6077                              (or (text-property-not-all
6078                                   (point) (point-max)
6079                                 'gnus-line-format
6080                                 gnus-mime-security-button-line-format)
6081                                  (point-max)))
6082               (gnus-insert-mime-security-button handle))
6083           (if (gnus-buffer-live-p gnus-mime-security-details-buffer)
6084               (with-current-buffer gnus-mime-security-details-buffer
6085                 (erase-buffer)
6086                 t)
6087             (setq gnus-mime-security-details-buffer
6088                   (gnus-get-buffer-create "*MIME Security Details*")))
6089           (with-current-buffer gnus-mime-security-details-buffer
6090             (insert details)
6091             (goto-char (point-min)))
6092           (pop-to-buffer gnus-mime-security-details-buffer))
6093       (gnus-message 5 "No details."))))
6094
6095 (defun gnus-mime-security-press-button (handle)
6096   (if (mm-handle-multipart-ctl-parameter handle 'gnus-info)
6097       (gnus-mime-security-show-details handle)
6098     (gnus-mime-security-verify-or-decrypt handle)))
6099
6100 (defun gnus-insert-mime-security-button (handle &optional displayed)
6101   (let* ((protocol (mm-handle-multipart-ctl-parameter handle 'protocol))
6102          (gnus-tmp-type
6103           (concat
6104            (or (nth 2 (assoc protocol mm-verify-function-alist))
6105                (nth 2 (assoc protocol mm-decrypt-function-alist))
6106                "Unknown")
6107            (if (equal (car handle) "multipart/signed")
6108                " Signed" " Encrypted")
6109            " Part"))
6110          (gnus-tmp-info
6111           (or (mm-handle-multipart-ctl-parameter handle 'gnus-info)
6112               "Undecided"))
6113          (gnus-tmp-details
6114           (mm-handle-multipart-ctl-parameter handle 'gnus-details))
6115          gnus-tmp-pressed-details
6116          b e)
6117     (setq gnus-tmp-details
6118           (if gnus-tmp-details
6119               (concat "\n" gnus-tmp-details) ""))
6120     (setq gnus-tmp-pressed-details
6121           (if gnus-mime-security-button-pressed gnus-tmp-details ""))
6122     (unless (bolp)
6123       (insert "\n"))
6124     (setq b (point))
6125     (gnus-eval-format
6126      gnus-mime-security-button-line-format
6127      gnus-mime-security-button-line-format-alist
6128      `(keymap ,gnus-mime-security-button-map
6129               ,@(if (>= (string-to-number emacs-version) 21)
6130                     nil ;; XEmacs doesn't care
6131                   (list 'local-map gnus-mime-security-button-map))
6132               gnus-callback gnus-mime-security-press-button
6133               gnus-line-format ,gnus-mime-security-button-line-format
6134               article-type annotation
6135               gnus-data ,handle))
6136     (setq e (point))
6137     (widget-convert-button
6138      'link b e
6139      :mime-handle handle
6140      :action 'gnus-widget-press-button
6141      :button-keymap gnus-mime-security-button-map
6142      :help-echo
6143      (lambda (widget/window &optional overlay pos)
6144        ;; Needed to properly clear the message due to a bug in
6145        ;; wid-edit (XEmacs only).
6146        (if (boundp 'help-echo-owns-message)
6147            (setq help-echo-owns-message t))
6148        (format
6149         "%S: show detail"
6150         (aref gnus-mouse-2 0))))))
6151
6152 (defun gnus-mime-display-security (handle)
6153   (save-restriction
6154     (narrow-to-region (point) (point))
6155     (gnus-insert-mime-security-button handle)
6156     (gnus-mime-display-mixed (cdr handle))
6157     (unless (bolp)
6158       (insert "\n"))
6159     (let ((gnus-mime-security-button-line-format
6160            gnus-mime-security-button-end-line-format))
6161       (gnus-insert-mime-security-button handle))
6162     (mm-set-handle-multipart-parameter
6163      handle 'gnus-region
6164      (cons (set-marker (make-marker) (point-min))
6165            (set-marker (make-marker) (point-max))))))
6166
6167
6168 ;;; @ for mime-view
6169 ;;;
6170
6171 (defun gnus-article-header-presentation-method (entity situation)
6172   (mime-insert-header entity)
6173   )
6174
6175 (set-alist 'mime-header-presentation-method-alist
6176            'gnus-original-article-mode
6177            #'gnus-article-header-presentation-method)
6178
6179 (defun gnus-mime-preview-quitting-method ()
6180   (mime-preview-kill-buffer)
6181   (delete-other-windows)
6182   (gnus-article-show-summary)
6183   (gnus-summary-select-article gnus-show-all-headers t))
6184
6185 (set-alist 'mime-preview-quitting-method-alist
6186            'gnus-original-article-mode #'gnus-mime-preview-quitting-method)
6187
6188 (set-alist 'mime-preview-following-method-alist
6189            'gnus-original-article-mode #'gnus-following-method)
6190
6191 (set-alist 'mime-preview-over-to-previous-method-alist
6192            'gnus-original-article-mode
6193            (lambda ()
6194              (if (> (point-min) 1)
6195                  (gnus-article-prev-page)
6196                (gnus-article-read-summary-keys
6197                 nil (gnus-character-to-event ?P)))))
6198
6199 (set-alist 'mime-preview-over-to-next-method-alist
6200            'gnus-original-article-mode'
6201            (lambda ()
6202              (if (< (point-max) (buffer-size))
6203                  (gnus-article-next-page)
6204                (gnus-article-read-summary-keys
6205                 nil (gnus-character-to-event ?N)))))
6206
6207
6208 ;;; @ end
6209 ;;;
6210
6211 (gnus-ems-redefine)
6212
6213 (provide 'gnus-art)
6214
6215 (run-hooks 'gnus-art-load-hook)
6216
6217 ;;; gnus-art.el ends here