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

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