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