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