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