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           (gnus-mime-accumulate-hierarchy handle)
5071           ;;;!!!We should find the start part, but we just default
5072           ;;;!!!to the first part.
5073           ;;(gnus-mime-display-part (cadr handle))
5074           ;;;!!! Most multipart/related is an HTML message plus images.
5075           ;;;!!! Unfortunately we are unable to let W3 display those
5076           ;;;!!! included images, so we just display it as a mixed multipart.
5077           ;;(gnus-mime-display-mixed (cdr handle))
5078           ;;;!!! No, w3 can display everything just fine.
5079           (gnus-mime-display-part (cadr handle)))
5080          ((equal (car handle) "multipart/signed")
5081           (gnus-mime-accumulate-hierarchy handle)
5082           (gnus-add-wash-type 'signed)
5083           (gnus-mime-display-security handle))
5084          ((equal (car handle) "multipart/encrypted")
5085           (gnus-mime-accumulate-hierarchy handle)
5086           (gnus-add-wash-type 'encrypted)
5087           (gnus-mime-display-security handle))
5088          ;; Other multiparts are handled like multipart/mixed.
5089          (t
5090           (gnus-mime-display-mixed (cdr handle))))
5091       (gnus-mime-leave-multipart))))
5092
5093 (defun gnus-mime-part-function (handles)
5094   (if (stringp (car handles))
5095       (mapcar 'gnus-mime-part-function (cdr handles))
5096     (funcall gnus-article-mime-part-function handles)))
5097
5098 (defun gnus-mime-display-mixed (handles)
5099   (mapcar 'gnus-mime-display-part handles))
5100
5101 (defun gnus-mime-display-single (handle)
5102   (let ((type (mm-handle-media-type handle))
5103         (ignored gnus-ignored-mime-types)
5104         (not-attachment t)
5105         (move nil)
5106         display text)
5107     (catch 'ignored
5108       (progn
5109         (while ignored
5110           (when (string-match (pop ignored) type)
5111             (throw 'ignored nil)))
5112         (if (and (setq not-attachment
5113                        (and (not (mm-inline-override-p handle))
5114                             (or (not (mm-handle-disposition handle))
5115                                 (equal (car (mm-handle-disposition handle))
5116                                        "inline")
5117                                 (mm-attachment-override-p handle))))
5118                  (mm-automatic-display-p handle)
5119                  (or (and
5120                       (mm-inlinable-p handle)
5121                       (mm-inlined-p handle))
5122                      (mm-automatic-external-display-p type)))
5123             (setq display t)
5124           (when (equal (mm-handle-media-supertype handle) "text")
5125             (setq text t)))
5126         (let ((id (1+ (length gnus-article-mime-handle-alist)))
5127               beg)
5128           (push (cons id handle) gnus-article-mime-handle-alist)
5129           (when (or (not display)
5130                     (not (gnus-unbuttonized-mime-type-p type)))
5131             (gnus-insert-mime-button
5132              handle id (list (or display (and not-attachment text))))
5133             (gnus-article-insert-newline)
5134             ;; Remember modify the number of forward lines.
5135             (setq move t))
5136           (setq beg (point))
5137           (cond
5138            (display
5139             (when move
5140               (forward-line -1)
5141               (setq beg (point)))
5142             (let ((mail-parse-charset gnus-newsgroup-charset)
5143                   (mail-parse-ignored-charsets
5144                    (save-excursion (condition-case ()
5145                                        (set-buffer gnus-summary-buffer)
5146                                      (error))
5147                                    gnus-newsgroup-ignored-charsets)))
5148               (mm-display-part handle t))
5149             (goto-char (point-max)))
5150            ((and text not-attachment)
5151             (when move
5152               (forward-line -1)
5153               (setq beg (point)))
5154             (gnus-article-insert-newline)
5155             (mm-insert-inline handle (mm-get-part handle))
5156             (goto-char (point-max))))
5157           ;; Do highlighting.
5158           (save-excursion
5159             (save-restriction
5160               (narrow-to-region beg (point))
5161               (gnus-treat-article
5162                nil id
5163                (gnus-article-mime-total-parts)
5164                (mm-handle-media-type handle)))))))))
5165
5166 (defun gnus-unbuttonized-mime-type-p (type)
5167   "Say whether TYPE is to be unbuttonized."
5168   (unless gnus-inhibit-mime-unbuttonizing
5169     (when (catch 'found
5170             (let ((types gnus-unbuttonized-mime-types))
5171               (while types
5172                 (when (string-match (pop types) type)
5173                   (throw 'found t)))))
5174       (not (catch 'found
5175              (let ((types gnus-buttonized-mime-types))
5176                (while types
5177                  (when (string-match (pop types) type)
5178                    (throw 'found t)))))))))
5179
5180 (defun gnus-article-insert-newline ()
5181   "Insert a newline, but mark it as undeletable."
5182   (gnus-put-text-property
5183    (point) (progn (insert "\n") (point)) 'gnus-undeletable t))
5184
5185 (defun gnus-mime-display-alternative (handles &optional preferred ibegend id)
5186   (let* ((preferred (or preferred (mm-preferred-alternative handles)))
5187          (ihandles handles)
5188          (point (point))
5189          handle buffer-read-only from props begend not-pref)
5190     (save-window-excursion
5191       (save-restriction
5192         (when ibegend
5193           (narrow-to-region (car ibegend)
5194                             (or (cdr ibegend)
5195                                 (progn
5196                                   (goto-char (car ibegend))
5197                                   (forward-line 2)
5198                                   (point))))
5199           (delete-region (point-min) (point-max))
5200           (mm-remove-parts handles))
5201         (setq begend (list (point-marker)))
5202         ;; Do the toggle.
5203         (unless (setq not-pref (cadr (member preferred ihandles)))
5204           (setq not-pref (car ihandles)))
5205         (when (or ibegend
5206                   (not preferred)
5207                   (not (gnus-unbuttonized-mime-type-p
5208                         "multipart/alternative")))
5209           (gnus-add-text-properties
5210            (setq from (point))
5211            (progn
5212              (insert (format "%s.  "
5213                              (if gnus-mime-recompute-hierarchical-structure
5214                                  (mapconcat
5215                                   'number-to-string
5216                                   (car (nth (1- id)
5217                                             gnus-article-mime-hierarchy))
5218                                   ".")
5219                                id)))
5220              (point))
5221            `(gnus-callback
5222              (lambda (handles)
5223                (unless ,(not ibegend)
5224                  (setq gnus-article-mime-handle-alist
5225                        ',gnus-article-mime-handle-alist))
5226                (gnus-mime-display-alternative
5227                 ',ihandles ',not-pref ',begend ,id))
5228              keymap ,gnus-mime-button-map
5229              ,gnus-mouse-face-prop ,gnus-article-mouse-face
5230              face ,gnus-article-button-face
5231              gnus-part ,id
5232              gnus-data ,handle))
5233           (widget-convert-button 'link from (point)
5234                                  :action 'gnus-widget-press-button
5235                                  :button-keymap gnus-widget-button-keymap)
5236           ;; Do the handles
5237           (while (setq handle (pop handles))
5238             (gnus-add-text-properties
5239              (setq from (point))
5240              (progn
5241                (insert (format "(%c) %-18s"
5242                                (if (equal handle preferred) ?* ? )
5243                                (mm-handle-media-type handle)))
5244                (point))
5245              `(gnus-callback
5246                (lambda (handles)
5247                  (unless ,(not ibegend)
5248                    (setq gnus-article-mime-handle-alist
5249                          ',gnus-article-mime-handle-alist))
5250                  (gnus-mime-display-alternative
5251                   ',ihandles ',handle ',begend ,id))
5252                keymap ,gnus-mime-button-map
5253                ,gnus-mouse-face-prop ,gnus-article-mouse-face
5254                face ,gnus-article-button-face
5255                gnus-part ,id
5256                gnus-data ,handle))
5257             (widget-convert-button 'link from (point)
5258                                    :action 'gnus-widget-press-button
5259                                    :button-keymap gnus-widget-button-keymap)
5260             (insert "  "))
5261           (insert "\n\n"))
5262         (when preferred
5263           (if (stringp (car preferred))
5264               (gnus-display-mime preferred)
5265             (let ((mail-parse-charset gnus-newsgroup-charset)
5266                   (mail-parse-ignored-charsets
5267                    (with-current-buffer gnus-summary-buffer
5268                      gnus-newsgroup-ignored-charsets)))
5269               (mm-display-part preferred)
5270               ;; Do highlighting.
5271               (save-excursion
5272                 (save-restriction
5273                   (narrow-to-region (car begend) (point-max))
5274                   (gnus-treat-article
5275                    nil (length gnus-article-mime-handle-alist)
5276                    (gnus-article-mime-total-parts)
5277                    (mm-handle-media-type handle))))))
5278           (goto-char (point-max))
5279           (setcdr begend (point-marker)))))
5280     (when ibegend
5281       (goto-char point))))
5282
5283 (defconst gnus-article-wash-status-strings
5284   (let ((alist '((cite "c" "Possible hidden citation text"
5285                        " " "All citation text visible")
5286                  (headers "h" "Hidden headers"
5287                           " " "All headers visible.")
5288                  (pgp "p" "Encrypted or signed message status hidden"
5289                       " " "No hidden encryption nor digital signature status")
5290                  (signature "s" "Signature has been hidden"
5291                             " " "Signature is visible")
5292                  (overstrike "o" "Overstrike (^H) characters applied"
5293                              " " "No overstrike characters applied")
5294                  (gnus-show-mime "m" "Mime processing is activated"
5295                                  " " "Mime processing is not activated")
5296                  (emphasis "e" "/*_Emphasis_*/ characters applied"
5297                            " " "No /*_emphasis_*/ characters applied")))
5298         result)
5299     (dolist (entry alist result)
5300       (let ((key (nth 0 entry))
5301             (on (copy-sequence (nth 1 entry)))
5302             (on-help (nth 2 entry))
5303             (off (copy-sequence (nth 3 entry)))
5304             (off-help (nth 4 entry)))
5305         (put-text-property 0 1 'help-echo on-help on)
5306         (put-text-property 0 1 'help-echo off-help off)
5307         (push (list key on off) result))))
5308   "Alist of strings describing wash status in the mode line.
5309 Each entry has the form (KEY ON OF), where the KEY is a symbol
5310 representing the particular washing function, ON is the string to use
5311 in the article mode line when the washing function is active, and OFF
5312 is the string to use when it is inactive.")
5313
5314 (defun gnus-article-wash-status-entry (key value)
5315   (let ((entry (assoc key gnus-article-wash-status-strings)))
5316     (if value (nth 1 entry) (nth 2 entry))))
5317
5318 (defun gnus-article-wash-status ()
5319   "Return a string which display status of article washing."
5320   (with-current-buffer gnus-article-buffer
5321     (let ((cite (memq 'cite gnus-article-wash-types))
5322           (headers (memq 'headers gnus-article-wash-types))
5323           (boring (memq 'boring-headers gnus-article-wash-types))
5324           (pgp (memq 'pgp gnus-article-wash-types))
5325           (pem (memq 'pem gnus-article-wash-types))
5326           (signed (memq 'signed gnus-article-wash-types))
5327           (encrypted (memq 'encrypted gnus-article-wash-types))
5328           (signature (memq 'signature gnus-article-wash-types))
5329           (overstrike (memq 'overstrike gnus-article-wash-types))
5330           (emphasis (memq 'emphasis gnus-article-wash-types)))
5331       (concat
5332        (gnus-article-wash-status-entry 'cite cite)
5333        (gnus-article-wash-status-entry 'headers (or headers boring))
5334        (gnus-article-wash-status-entry 'pgp (or pgp pem signed encrypted))
5335        (gnus-article-wash-status-entry 'signature signature)
5336        (gnus-article-wash-status-entry 'overstrike overstrike)
5337        (gnus-article-wash-status-entry 'gnus-show-mime gnus-show-mime)
5338        (gnus-article-wash-status-entry 'emphasis emphasis)))))
5339
5340 (defun gnus-add-wash-type (type)
5341   "Add a washing of TYPE to the current status."
5342   (add-to-list 'gnus-article-wash-types type))
5343
5344 (defun gnus-delete-wash-type (type)
5345   "Add a washing of TYPE to the current status."
5346   (setq gnus-article-wash-types (delq type gnus-article-wash-types)))
5347
5348 (defun gnus-add-image (category image)
5349   "Add IMAGE of CATEGORY to the list of displayed images."
5350   (let ((entry (assq category gnus-article-image-alist)))
5351     (unless entry
5352       (setq entry (list category))
5353       (push entry gnus-article-image-alist))
5354     (nconc entry (list image))))
5355
5356 (defun gnus-delete-images (category)
5357   "Delete all images in CATEGORY."
5358   (let ((entry (assq category gnus-article-image-alist)))
5359     (dolist (image (cdr entry))
5360       (gnus-remove-image image category))
5361     (setq gnus-article-image-alist (delq entry gnus-article-image-alist))
5362     (gnus-delete-wash-type category)))
5363
5364 (defalias 'gnus-article-hide-headers-if-wanted 'gnus-article-maybe-hide-headers)
5365
5366 (defun gnus-article-maybe-hide-headers ()
5367   "Hide unwanted headers if `gnus-have-all-headers' is nil.
5368 Provided for backwards compatibility."
5369   (when (and (or (not (gnus-buffer-live-p gnus-summary-buffer))
5370                  (not (with-current-buffer gnus-summary-buffer
5371                         gnus-have-all-headers)))
5372              (not gnus-inhibit-hiding))
5373     (gnus-article-hide-headers)))
5374
5375 ;;; Article savers.
5376
5377 (defun gnus-output-to-file (file-name)
5378   "Append the current article to a file named FILE-NAME."
5379   (let ((artbuf (current-buffer)))
5380     (with-temp-buffer
5381       (insert-buffer-substring artbuf)
5382       ;; Append newline at end of the buffer as separator, and then
5383       ;; save it to file.
5384       (goto-char (point-max))
5385       (insert "\n")
5386       (let ((file-name-coding-system nnmail-pathname-coding-system))
5387         (write-region-as-binary (point-min) (point-max) file-name 'append))
5388       t)))
5389
5390 (defun gnus-narrow-to-page (&optional arg)
5391   "Narrow the article buffer to a page.
5392 If given a numerical ARG, move forward ARG pages."
5393   (interactive "P")
5394   (setq arg (if arg (prefix-numeric-value arg) 0))
5395   (save-excursion
5396     (set-buffer gnus-article-buffer)
5397     (goto-char (point-min))
5398     (widen)
5399     ;; Remove any old next/prev buttons.
5400     (when (gnus-visual-p 'page-marker)
5401       (let ((buffer-read-only nil))
5402         (gnus-remove-text-with-property 'gnus-prev)
5403         (gnus-remove-text-with-property 'gnus-next)))
5404     (if
5405         (cond ((< arg 0)
5406                (re-search-backward page-delimiter nil 'move (1+ (abs arg))))
5407               ((> arg 0)
5408                (re-search-forward page-delimiter nil 'move arg)))
5409         (goto-char (match-end 0))
5410       (save-excursion
5411         (goto-char (point-min))
5412         (setq gnus-page-broken
5413               (and (re-search-forward page-delimiter nil t) t))))
5414     (when gnus-page-broken
5415       (narrow-to-region
5416        (point)
5417        (if (re-search-forward page-delimiter nil 'move)
5418            (match-beginning 0)
5419          (point)))
5420       (when (and (gnus-visual-p 'page-marker)
5421                  (not (= (point-min) 1)))
5422         (save-excursion
5423           (goto-char (point-min))
5424           (gnus-insert-prev-page-button)))
5425       (when (and (gnus-visual-p 'page-marker)
5426                  (< (+ (point-max) 2) (buffer-size)))
5427         (save-excursion
5428           (goto-char (point-max))
5429           (gnus-insert-next-page-button))))))
5430
5431 ;; Article mode commands
5432
5433 (defun gnus-article-goto-next-page ()
5434   "Show the next page of the article."
5435   (interactive)
5436   (when (gnus-article-next-page)
5437     (goto-char (point-min))
5438     (gnus-article-read-summary-keys nil (gnus-character-to-event ?n))))
5439
5440
5441 (defun gnus-article-goto-prev-page ()
5442   "Show the previous page of the article."
5443   (interactive)
5444   (if (bobp)
5445       (gnus-article-read-summary-keys nil (gnus-character-to-event ?p))
5446     (gnus-article-prev-page nil)))
5447
5448 ;; This is cleaner but currently breaks `gnus-pick-mode':
5449 ;;
5450 ;; (defun gnus-article-goto-next-page ()
5451 ;;   "Show the next page of the article."
5452 ;;   (interactive)
5453 ;;   (gnus-eval-in-buffer-window gnus-summary-buffer
5454 ;;     (gnus-summary-next-page)))
5455 ;;
5456 ;; (defun gnus-article-goto-prev-page ()
5457 ;;   "Show the next page of the article."
5458 ;;   (interactive)
5459 ;;   (gnus-eval-in-buffer-window gnus-summary-buffer
5460 ;;     (gnus-summary-prev-page)))
5461
5462 (defun gnus-article-next-page (&optional lines)
5463   "Show the next page of the current article.
5464 If end of article, return non-nil.  Otherwise return nil.
5465 Argument LINES specifies lines to be scrolled up."
5466   (interactive "p")
5467   (move-to-window-line -1)
5468   (if (save-excursion
5469         (end-of-line)
5470         (and (pos-visible-in-window-p)  ;Not continuation line.
5471              (>= (1+ (point)) (point-max)))) ;Allow for trailing newline.
5472       ;; Nothing in this page.
5473       (if (or (not gnus-page-broken)
5474               (save-excursion
5475                 (save-restriction
5476                   (widen)
5477                   (eobp)))) ;Real end-of-buffer?
5478           (progn
5479             (when gnus-article-over-scroll
5480               (gnus-article-next-page-1 lines))
5481             t)                  ;Nothing more.
5482         (gnus-narrow-to-page 1)         ;Go to next page.
5483         nil)
5484     ;; More in this page.
5485     (gnus-article-next-page-1 lines)
5486     nil))
5487
5488 (defun gnus-article-next-page-1 (lines)
5489   (let ((scroll-in-place nil))
5490     (condition-case ()
5491         (scroll-up lines)
5492       (end-of-buffer
5493        ;; Long lines may cause an end-of-buffer error.
5494        (goto-char (point-max)))))
5495   (move-to-window-line 0))
5496
5497 (defun gnus-article-prev-page (&optional lines)
5498   "Show previous page of current article.
5499 Argument LINES specifies lines to be scrolled down."
5500   (interactive "p")
5501   (move-to-window-line 0)
5502   (if (and gnus-page-broken
5503            (bobp)
5504            (not (save-restriction (widen) (bobp)))) ;Real beginning-of-buffer?
5505       (progn
5506         (gnus-narrow-to-page -1)        ;Go to previous page.
5507         (goto-char (point-max))
5508         (recenter -1))
5509     (let ((scroll-in-place nil))
5510       (prog1
5511           (condition-case ()
5512               (scroll-down lines)
5513             (beginning-of-buffer
5514              (goto-char (point-min))))
5515         (move-to-window-line 0)))))
5516
5517 (defun gnus-article-only-boring-p ()
5518   "Decide whether there is only boring text remaining in the article.
5519 Something \"interesting\" is a word of at least two letters that does
5520 not have a face in `gnus-article-boring-faces'."
5521   (when (and gnus-article-skip-boring
5522              (boundp 'gnus-article-boring-faces)
5523              (symbol-value 'gnus-article-boring-faces))
5524     (save-excursion
5525       (catch 'only-boring
5526         (while (re-search-forward "\\b\\w\\w" nil t)
5527           (forward-char -1)
5528           (when (not (gnus-intersection
5529                       (gnus-faces-at (point))
5530                       (symbol-value 'gnus-article-boring-faces)))
5531             (throw 'only-boring nil)))
5532         (throw 'only-boring t)))))
5533
5534 (defun gnus-article-refer-article ()
5535   "Read article specified by message-id around point."
5536   (interactive)
5537   (save-excursion
5538     (re-search-backward "[ \t]\\|^" (point-at-bol) t)
5539     (re-search-forward "<?news:<?\\|<" (point-at-eol) t)
5540     (if (re-search-forward "[^@ ]+@[^ \t>]+" (point-at-eol) t)
5541         (let ((msg-id (concat "<" (match-string 0) ">")))
5542           (set-buffer gnus-summary-buffer)
5543           (gnus-summary-refer-article msg-id))
5544       (error "No references around point"))))
5545
5546 (defun gnus-article-show-summary ()
5547   "Reconfigure windows to show summary buffer."
5548   (interactive)
5549   (if (not (gnus-buffer-live-p gnus-summary-buffer))
5550       (error "There is no summary buffer for this article buffer")
5551     (gnus-article-set-globals)
5552     (gnus-configure-windows 'article)
5553     (gnus-summary-goto-subject gnus-current-article)
5554     (gnus-summary-position-point)))
5555
5556 (defun gnus-article-describe-briefly ()
5557   "Describe article mode commands briefly."
5558   (interactive)
5559   (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")))
5560
5561 (defun gnus-article-summary-command ()
5562   "Execute the last keystroke in the summary buffer."
5563   (interactive)
5564   (let ((obuf (current-buffer))
5565         (owin (current-window-configuration))
5566         func)
5567     (switch-to-buffer gnus-article-current-summary 'norecord)
5568     (setq func (lookup-key (current-local-map) (this-command-keys)))
5569     (call-interactively func)
5570     (set-buffer obuf)
5571     (set-window-configuration owin)
5572     (set-window-point (get-buffer-window (current-buffer)) (point))))
5573
5574 (defun gnus-article-summary-command-nosave ()
5575   "Execute the last keystroke in the summary buffer."
5576   (interactive)
5577   (let (func)
5578     (pop-to-buffer gnus-article-current-summary 'norecord)
5579     (setq func (lookup-key (current-local-map) (this-command-keys)))
5580     (call-interactively func)))
5581
5582 (defun gnus-article-check-buffer ()
5583   "Beep if not in an article buffer."
5584   (unless (eq (get-buffer gnus-article-buffer) (current-buffer))
5585     (error "Command invoked outside of a Gnus article buffer")))
5586
5587 (defun gnus-article-read-summary-keys (&optional arg key not-restore-window)
5588   "Read a summary buffer key sequence and execute it from the article buffer."
5589   (interactive "P")
5590   (gnus-article-check-buffer)
5591   (let ((nosaves
5592          '("q" "Q"  "c" "r" "\C-c\C-f" "m"  "a" "f"
5593            "Zc" "ZC" "ZE" "ZJ" "ZQ" "ZZ" "Zn" "ZR" "ZG" "ZN" "ZP"
5594            "=" "^" "\M-^" "|"))
5595         (nosave-but-article
5596          '("A\r"))
5597         (nosave-in-article
5598          '("\C-d"))
5599         (up-to-top
5600          '("n" "Gn" "p" "Gp"))
5601         keys new-sum-point)
5602     (save-excursion
5603       (set-buffer gnus-article-current-summary)
5604       (let (gnus-pick-mode)
5605         (push (or key last-command-event) unread-command-events)
5606         (setq keys (static-if (featurep 'xemacs)
5607                        (events-to-keys (read-key-sequence nil))
5608                      (read-key-sequence nil)))))
5609     (message "")
5610
5611     (if (or (member keys nosaves)
5612             (member keys nosave-but-article)
5613             (member keys nosave-in-article))
5614         (let (func)
5615           (save-window-excursion
5616             (pop-to-buffer gnus-article-current-summary 'norecord)
5617             ;; We disable the pick minor mode commands.
5618             (let (gnus-pick-mode)
5619               (setq func (lookup-key (current-local-map) keys))))
5620           (if (or (not func)
5621                   (numberp func))
5622               (ding)
5623             (unless (member keys nosave-in-article)
5624               (set-buffer gnus-article-current-summary))
5625             (call-interactively func)
5626             (setq new-sum-point (point)))
5627           (when (member keys nosave-but-article)
5628             (pop-to-buffer gnus-article-buffer 'norecord)))
5629       ;; These commands should restore window configuration.
5630       (let ((obuf (current-buffer))
5631             (owin (current-window-configuration))
5632             (opoint (point))
5633             win func in-buffer selected new-sum-start new-sum-hscroll)
5634         (cond (not-restore-window
5635                (pop-to-buffer gnus-article-current-summary 'norecord))
5636               ((setq win (get-buffer-window gnus-article-current-summary))
5637                (select-window win))
5638               (t
5639                (switch-to-buffer gnus-article-current-summary 'norecord)))
5640         (setq in-buffer (current-buffer))
5641         ;; We disable the pick minor mode commands.
5642         (if (and (setq func (let (gnus-pick-mode)
5643                               (lookup-key (current-local-map) keys)))
5644                  (functionp func))
5645             (progn
5646               (call-interactively func)
5647               (when (eq win (selected-window))
5648                 (setq new-sum-point (point)
5649                       new-sum-start (window-start win)
5650                       new-sum-hscroll (window-hscroll win))
5651               (when (eq in-buffer (current-buffer))
5652                 (setq selected (gnus-summary-select-article))
5653                 (set-buffer obuf)
5654                 (unless not-restore-window
5655                   (set-window-configuration owin))
5656                 (when (eq selected 'old)
5657                   (article-goto-body)
5658                   (set-window-start (get-buffer-window (current-buffer))
5659                                     1)
5660                   (set-window-point (get-buffer-window (current-buffer))
5661                                     (point)))
5662                 (when (and (not not-restore-window)
5663                            new-sum-point)
5664                   (set-window-point win new-sum-point)
5665                   (set-window-start win new-sum-start)
5666                   (set-window-hscroll win new-sum-hscroll)))))
5667           (set-window-configuration owin)
5668           (ding))))))
5669
5670 (defun gnus-article-describe-key (key)
5671   "Display documentation of the function invoked by KEY.  KEY is a string."
5672   (interactive "kDescribe key: ")
5673   (gnus-article-check-buffer)
5674   (if (eq (key-binding key) 'gnus-article-read-summary-keys)
5675       (save-excursion
5676         (set-buffer gnus-article-current-summary)
5677         (let (gnus-pick-mode)
5678           (if (featurep 'xemacs)
5679               (progn
5680                 (push (elt key 0) unread-command-events)
5681                 (setq key (events-to-keys
5682                            (read-key-sequence "Describe key: "))))
5683             (setq unread-command-events
5684                   (mapcar
5685                    (lambda (x) (if (>= x 128) (list 'meta (- x 128)) x))
5686                    key))
5687             (setq key (read-key-sequence "Describe key: "))))
5688         (describe-key key))
5689     (describe-key key)))
5690
5691 (defun gnus-article-describe-key-briefly (key &optional insert)
5692   "Display documentation of the function invoked by KEY.  KEY is a string."
5693   (interactive "kDescribe key: \nP")
5694   (gnus-article-check-buffer)
5695   (if (eq (key-binding key) 'gnus-article-read-summary-keys)
5696       (save-excursion
5697         (set-buffer gnus-article-current-summary)
5698         (let (gnus-pick-mode)
5699           (if (featurep 'xemacs)
5700               (progn
5701                 (push (elt key 0) unread-command-events)
5702                 (setq key (events-to-keys
5703                            (read-key-sequence "Describe key: "))))
5704             (setq unread-command-events
5705                   (mapcar
5706                    (lambda (x) (if (>= x 128) (list 'meta (- x 128)) x))
5707                    key))
5708             (setq key (read-key-sequence "Describe key: "))))
5709         (describe-key-briefly key insert))
5710     (describe-key-briefly key insert)))
5711
5712 (defun gnus-article-reply-with-original (&optional wide)
5713   "Start composing a reply mail to the current message.
5714 The text in the region will be yanked.  If the region isn't active,
5715 the entire article will be yanked."
5716   (interactive "P")
5717   (let ((article (cdr gnus-article-current))
5718         contents)
5719     (if (not (gnus-mark-active-p))
5720         (with-current-buffer gnus-summary-buffer
5721           (gnus-summary-reply (list (list article)) wide))
5722       (setq contents (buffer-substring (point) (mark t)))
5723       ;; Deactivate active regions.
5724       (when (and (boundp 'transient-mark-mode)
5725                  transient-mark-mode)
5726         (setq mark-active nil))
5727       (with-current-buffer gnus-summary-buffer
5728         (gnus-summary-reply
5729          (list (list article contents)) wide)))))
5730
5731 (defun gnus-article-followup-with-original ()
5732   "Compose a followup to the current article.
5733 The text in the region will be yanked.  If the region isn't active,
5734 the entire article will be yanked."
5735   (interactive)
5736   (let ((article (cdr gnus-article-current))
5737         contents)
5738       (if (not (gnus-mark-active-p))
5739           (with-current-buffer gnus-summary-buffer
5740             (gnus-summary-followup (list (list article))))
5741         (setq contents (buffer-substring (point) (mark t)))
5742         ;; Deactivate active regions.
5743         (when (and (boundp 'transient-mark-mode)
5744                    transient-mark-mode)
5745           (setq mark-active nil))
5746         (with-current-buffer gnus-summary-buffer
5747           (gnus-summary-followup
5748            (list (list article contents)))))))
5749
5750 (defun gnus-article-hide (&optional arg force)
5751   "Hide all the gruft in the current article.
5752 This means that signatures, cited text and (some) headers will be
5753 hidden.
5754 If given a prefix, show the hidden text instead."
5755   (interactive (append (gnus-article-hidden-arg) (list 'force)))
5756   (gnus-article-hide-headers arg)
5757   (gnus-article-hide-list-identifiers arg)
5758   (gnus-article-hide-citation-maybe arg force)
5759   (gnus-article-hide-signature arg))
5760
5761 (defun gnus-article-maybe-highlight ()
5762   "Do some article highlighting if article highlighting is requested."
5763   (when (gnus-visual-p 'article-highlight 'highlight)
5764     (gnus-article-highlight-some)))
5765
5766 (defun gnus-check-group-server ()
5767   ;; Make sure the connection to the server is alive.
5768   (unless (gnus-server-opened
5769            (gnus-find-method-for-group gnus-newsgroup-name))
5770     (gnus-check-server (gnus-find-method-for-group gnus-newsgroup-name))
5771     (gnus-request-group gnus-newsgroup-name t)))
5772
5773 (eval-when-compile
5774   (autoload 'nneething-get-file-name "nneething"))
5775
5776 (defun gnus-request-article-this-buffer (article group)
5777   "Get an article and insert it into this buffer."
5778   (let (do-update-line sparse-header)
5779     (prog1
5780         (save-excursion
5781           (erase-buffer)
5782           (gnus-kill-all-overlays)
5783           (setq group (or group gnus-newsgroup-name))
5784
5785           ;; Using `gnus-request-article' directly will insert the article into
5786           ;; `nntp-server-buffer' - so we'll save some time by not having to
5787           ;; copy it from the server buffer into the article buffer.
5788
5789           ;; We only request an article by message-id when we do not have the
5790           ;; headers for it, so we'll have to get those.
5791           (when (stringp article)
5792             (gnus-read-header article))
5793
5794           ;; If the article number is negative, that means that this article
5795           ;; doesn't belong in this newsgroup (possibly), so we find its
5796           ;; message-id and request it by id instead of number.
5797           (when (and (numberp article)
5798                      gnus-summary-buffer
5799                      (get-buffer gnus-summary-buffer)
5800                      (gnus-buffer-exists-p gnus-summary-buffer))
5801             (save-excursion
5802               (set-buffer gnus-summary-buffer)
5803               (let ((header (gnus-summary-article-header article)))
5804                 (when (< article 0)
5805                   (cond
5806                    ((memq article gnus-newsgroup-sparse)
5807                     ;; This is a sparse gap article.
5808                     (setq do-update-line article)
5809                     (setq article (mail-header-id header))
5810                     (setq sparse-header (gnus-read-header article))
5811                     (setq gnus-newsgroup-sparse
5812                           (delq article gnus-newsgroup-sparse)))
5813                    ((vectorp header)
5814                     ;; It's a real article.
5815                     (setq article (mail-header-id header)))
5816                    (t
5817                     ;; It is an extracted pseudo-article.
5818                     (setq article 'pseudo)
5819                     (gnus-request-pseudo-article header))))
5820
5821                 (let ((method (gnus-find-method-for-group
5822                                gnus-newsgroup-name)))
5823                   (when (and (eq (car method) 'nneething)
5824                              (vectorp header))
5825                     (let ((dir (nneething-get-file-name
5826                                 (mail-header-id header))))
5827                       (when (and (stringp dir)
5828                                  (file-directory-p dir))
5829                         (setq article 'nneething)
5830                         (gnus-group-enter-directory dir))))))))
5831
5832           (cond
5833            ;; Refuse to select canceled articles.
5834            ((and (numberp article)
5835                  gnus-summary-buffer
5836                  (get-buffer gnus-summary-buffer)
5837                  (gnus-buffer-exists-p gnus-summary-buffer)
5838                  (eq (cdr (with-current-buffer gnus-summary-buffer
5839                             (assq article gnus-newsgroup-reads)))
5840                      gnus-canceled-mark))
5841             nil)
5842            ;; We first check `gnus-original-article-buffer'.
5843            ((and (get-buffer gnus-original-article-buffer)
5844                  (numberp article)
5845                  (with-current-buffer gnus-original-article-buffer
5846                    (and (equal (car gnus-original-article) group)
5847                         (eq (cdr gnus-original-article) article))))
5848             (insert-buffer-substring gnus-original-article-buffer)
5849             'article)
5850            ;; Check the backlog.
5851            ((and gnus-keep-backlog
5852                  (gnus-backlog-request-article group article (current-buffer)))
5853             'article)
5854            ;; Check asynchronous pre-fetch.
5855            ((gnus-async-request-fetched-article group article (current-buffer))
5856             (gnus-async-prefetch-next group article gnus-summary-buffer)
5857             (when (and (numberp article) gnus-keep-backlog)
5858               (gnus-backlog-enter-article group article (current-buffer)))
5859             'article)
5860            ;; Check the cache.
5861            ((and gnus-use-cache
5862                  (numberp article)
5863                  (gnus-cache-request-article article group))
5864             'article)
5865            ;; Check the agent cache.
5866            ((gnus-agent-request-article article group)
5867             'article)
5868            ;; Get the article and put into the article buffer.
5869            ((or (stringp article)
5870                 (numberp article))
5871             (let ((gnus-override-method gnus-override-method)
5872                   (methods (and (stringp article)
5873                                 gnus-refer-article-method))
5874                   (backend (car (gnus-find-method-for-group
5875                                  gnus-newsgroup-name)))
5876                   result
5877                   (buffer-read-only nil))
5878               (if (or (not (listp methods))
5879                       (and (symbolp (car methods))
5880                            (assq (car methods) nnoo-definition-alist)))
5881                   (setq methods (list methods)))
5882               (when (and (null gnus-override-method)
5883                          methods)
5884                 (setq gnus-override-method (pop methods)))
5885               (while (not result)
5886                 (when (eq gnus-override-method 'current)
5887                   (setq gnus-override-method
5888                         (with-current-buffer gnus-summary-buffer
5889                           gnus-current-select-method)))
5890                 (erase-buffer)
5891                 (gnus-kill-all-overlays)
5892                 (let ((gnus-newsgroup-name group))
5893                   (gnus-check-group-server))
5894                 (cond
5895                  ((gnus-request-article article group (current-buffer))
5896                   (when (numberp article)
5897                     (gnus-async-prefetch-next group article
5898                                               gnus-summary-buffer)
5899                     (when gnus-keep-backlog
5900                       (gnus-backlog-enter-article
5901                        group article (current-buffer))))
5902                   (setq result 'article))
5903                  (methods
5904                   (setq gnus-override-method (pop methods)))
5905                  ((not (string-match "^400 "
5906                                      (nnheader-get-report backend)))
5907                   ;; If we get 400 server disconnect, reconnect and
5908                   ;; retry; otherwise, assume the article has expired.
5909                   (setq result 'done))))
5910               (and (eq result 'article) 'article)))
5911            ;; It was a pseudo.
5912            (t article)))
5913
5914       ;; Associate this article with the current summary buffer.
5915       (setq gnus-article-current-summary gnus-summary-buffer)
5916
5917       ;; Take the article from the original article buffer
5918       ;; and place it in the buffer it's supposed to be in.
5919       (when (and (get-buffer gnus-article-buffer)
5920                  (equal (buffer-name (current-buffer))
5921                         (buffer-name (get-buffer gnus-article-buffer))))
5922         (save-excursion
5923           (if (get-buffer gnus-original-article-buffer)
5924               (set-buffer gnus-original-article-buffer)
5925             (set-buffer (gnus-get-buffer-create gnus-original-article-buffer))
5926             (buffer-disable-undo)
5927             (setq major-mode 'gnus-original-article-mode)
5928             (setq buffer-read-only t))
5929           (let (buffer-read-only)
5930             (erase-buffer)
5931             (insert-buffer-substring gnus-article-buffer))
5932           (setq gnus-original-article (cons group article)))
5933
5934         ;; Decode charsets.
5935         (run-hooks 'gnus-article-decode-hook)
5936         ;; Mark article as decoded or not.
5937         (setq gnus-article-decoded-p gnus-article-decode-hook))
5938
5939       ;; Update sparse articles.
5940       (when (and do-update-line
5941                  (or (numberp article)
5942                      (stringp article)))
5943         (let ((buf (current-buffer)))
5944           (set-buffer gnus-summary-buffer)
5945           (gnus-summary-update-article do-update-line sparse-header)
5946           (gnus-summary-goto-subject do-update-line nil t)
5947           (set-window-point (gnus-get-buffer-window (current-buffer) t)
5948                             (point))
5949           (set-buffer buf))))))
5950
5951 ;;;
5952 ;;; Article editing
5953 ;;;
5954
5955 (defcustom gnus-article-edit-mode-hook nil
5956   "Hook run in article edit mode buffers."
5957   :group 'gnus-article-various
5958   :type 'hook)
5959
5960 (defcustom gnus-article-edit-article-setup-function
5961   'gnus-article-mime-edit-article-setup
5962   "Function called to setup an editing article buffer."
5963   :group 'gnus-article-various
5964   :type 'function)
5965
5966 (defvar gnus-article-edit-done-function nil)
5967
5968 (defvar gnus-article-edit-mode-map nil)
5969
5970 ;; Should we be using derived.el for this?
5971 (unless gnus-article-edit-mode-map
5972   (setq gnus-article-edit-mode-map (make-keymap))
5973   (set-keymap-parent gnus-article-edit-mode-map text-mode-map)
5974
5975   (gnus-define-keys gnus-article-edit-mode-map
5976     "\C-c?"    describe-mode
5977     "\C-c\C-c" gnus-article-edit-done
5978     "\C-c\C-k" gnus-article-edit-exit
5979     "\C-c\C-f\C-t" message-goto-to
5980     "\C-c\C-f\C-o" message-goto-from
5981     "\C-c\C-f\C-b" message-goto-bcc
5982     ;;"\C-c\C-f\C-w" message-goto-fcc
5983     "\C-c\C-f\C-c" message-goto-cc
5984     "\C-c\C-f\C-s" message-goto-subject
5985     "\C-c\C-f\C-r" message-goto-reply-to
5986     "\C-c\C-f\C-n" message-goto-newsgroups
5987     "\C-c\C-f\C-d" message-goto-distribution
5988     "\C-c\C-f\C-f" message-goto-followup-to
5989     "\C-c\C-f\C-m" message-goto-mail-followup-to
5990     "\C-c\C-f\C-k" message-goto-keywords
5991     "\C-c\C-f\C-u" message-goto-summary
5992     "\C-c\C-f\C-i" message-insert-or-toggle-importance
5993     "\C-c\C-f\C-a" message-generate-unsubscribed-mail-followup-to
5994     "\C-c\C-b" message-goto-body
5995     "\C-c\C-i" message-goto-signature
5996
5997     "\C-c\C-t" message-insert-to
5998     "\C-c\C-n" message-insert-newsgroups
5999     "\C-c\C-o" message-sort-headers
6000     "\C-c\C-e" message-elide-region
6001     "\C-c\C-v" message-delete-not-region
6002     "\C-c\C-z" message-kill-to-signature
6003     "\M-\r" message-newline-and-reformat
6004     "\C-c\C-a" mml-attach-file
6005     "\C-a" message-beginning-of-line
6006     "\t" message-tab
6007     "\M-;" comment-region)
6008
6009   (gnus-define-keys (gnus-article-edit-wash-map
6010                      "\C-c\C-w" gnus-article-edit-mode-map)
6011     "f" gnus-article-edit-full-stops))
6012
6013 (easy-menu-define
6014   gnus-article-edit-mode-field-menu gnus-article-edit-mode-map ""
6015   '("Field"
6016     ["Fetch To" message-insert-to t]
6017     ["Fetch Newsgroups" message-insert-newsgroups t]
6018     "----"
6019     ["To" message-goto-to t]
6020     ["From" message-goto-from t]
6021     ["Subject" message-goto-subject t]
6022     ["Cc" message-goto-cc t]
6023     ["Reply-To" message-goto-reply-to t]
6024     ["Summary" message-goto-summary t]
6025     ["Keywords" message-goto-keywords t]
6026     ["Newsgroups" message-goto-newsgroups t]
6027     ["Followup-To" message-goto-followup-to t]
6028     ["Mail-Followup-To" message-goto-mail-followup-to t]
6029     ["Distribution" message-goto-distribution t]
6030     ["Body" message-goto-body t]
6031     ["Signature" message-goto-signature t]))
6032
6033 (define-derived-mode gnus-article-edit-mode text-mode "Article Edit"
6034   "Major mode for editing articles.
6035 This is an extended text-mode.
6036
6037 \\{gnus-article-edit-mode-map}"
6038   (make-local-variable 'gnus-article-edit-done-function)
6039   (make-local-variable 'gnus-prev-winconf)
6040   (set (make-local-variable 'font-lock-defaults)
6041        '(message-font-lock-keywords t))
6042   (set (make-local-variable 'mail-header-separator) "")
6043   (set (make-local-variable 'gnus-article-edit-mode) t)
6044   (easy-menu-add message-mode-field-menu message-mode-map)
6045   (setq buffer-read-only nil)
6046   (buffer-enable-undo)
6047   (widen))
6048
6049 (defun gnus-article-edit (&optional force)
6050   "Edit the current article.
6051 This will have permanent effect only in mail groups.
6052 If FORCE is non-nil, allow editing of articles even in read-only
6053 groups."
6054   (interactive "P")
6055   (when (and (not force)
6056              (gnus-group-read-only-p))
6057     (error "The current newsgroup does not support article editing"))
6058   (gnus-article-date-original)
6059   (gnus-article-edit-article
6060    'ignore
6061    `(lambda (no-highlight)
6062       'ignore
6063       (gnus-summary-edit-article-done
6064        ,(or (mail-header-references gnus-current-headers) "")
6065        ,(gnus-group-read-only-p) ,gnus-summary-buffer no-highlight))))
6066
6067 (defun gnus-article-edit-article (start-func exit-func)
6068   "Start editing the contents of the current article buffer."
6069   (let ((winconf (current-window-configuration)))
6070     (set-buffer gnus-article-buffer)
6071     (gnus-article-edit-mode)
6072     (funcall start-func)
6073     (set-buffer-modified-p nil)
6074     (gnus-configure-windows 'edit-article)
6075     (setq gnus-article-edit-done-function exit-func)
6076     (setq gnus-prev-winconf winconf)
6077     (when gnus-article-edit-article-setup-function
6078       (funcall gnus-article-edit-article-setup-function))
6079     (gnus-message 6 "C-c C-c to end edits; C-c C-k to exit")))
6080
6081 (defun gnus-article-edit-done (&optional arg)
6082   "Update the article edits and exit."
6083   (interactive "P")
6084   (let ((func gnus-article-edit-done-function)
6085         (buf (current-buffer))
6086         (start (window-start))
6087         (p (point))
6088         (winconf gnus-prev-winconf))
6089     (remove-hook 'gnus-article-mode-hook
6090                  'gnus-article-mime-edit-article-unwind)
6091     (widen) ;; Widen it in case that users narrowed the buffer.
6092     (funcall func arg)
6093     (set-buffer buf)
6094     ;; The cache and backlog have to be flushed somewhat.
6095     (when gnus-keep-backlog
6096       (gnus-backlog-remove-article
6097        (car gnus-article-current) (cdr gnus-article-current)))
6098     ;; Flush original article as well.
6099     (save-excursion
6100       (when (get-buffer gnus-original-article-buffer)
6101         (set-buffer gnus-original-article-buffer)
6102         (setq gnus-original-article nil)))
6103     (when gnus-use-cache
6104       (gnus-cache-update-article
6105        (car gnus-article-current) (cdr gnus-article-current)))
6106     ;; We remove all text props from the article buffer.
6107     (kill-all-local-variables)
6108     (set-text-properties (point-min) (point-max) nil)
6109     (gnus-article-mode)
6110     (set-window-configuration winconf)
6111     (set-buffer buf)
6112     (set-window-start (get-buffer-window buf) start)
6113     (set-window-point (get-buffer-window buf) (point)))
6114   (gnus-summary-show-article))
6115
6116 (defun gnus-article-edit-exit ()
6117   "Exit the article editing without updating."
6118   (interactive)
6119   (when (or (not (buffer-modified-p))
6120             (yes-or-no-p "Article modified; kill anyway? "))
6121     (let ((curbuf (current-buffer))
6122           (p (point))
6123           (window-start (window-start)))
6124       (erase-buffer)
6125       (if (gnus-buffer-live-p gnus-original-article-buffer)
6126           (insert-buffer-substring gnus-original-article-buffer))
6127       (let ((winconf gnus-prev-winconf))
6128         (kill-all-local-variables)
6129         (gnus-article-mode)
6130         (set-window-configuration winconf)
6131         ;; Tippy-toe some to make sure that point remains where it was.
6132         (save-current-buffer
6133           (set-buffer curbuf)
6134           (set-window-start (get-buffer-window (current-buffer)) window-start)
6135           (goto-char p))))
6136     (gnus-summary-show-article)))
6137
6138 (defun gnus-article-edit-full-stops ()
6139   "Interactively repair spacing at end of sentences."
6140   (interactive)
6141   (save-excursion
6142     (goto-char (point-min))
6143     (search-forward-regexp "^$" nil t)
6144     (let ((case-fold-search nil))
6145       (query-replace-regexp "\\([.!?][])}]* \\)\\([[({A-Z]\\)" "\\1 \\2"))))
6146
6147 ;;;
6148 ;;; Article editing with MIME-Edit
6149 ;;;
6150
6151 (defcustom gnus-article-mime-edit-article-setup-hook nil
6152   "Hook run after setting up a MIME editing article buffer."
6153   :group 'gnus-article-various
6154   :type 'hook)
6155
6156 (defun gnus-article-mime-edit-article-unwind ()
6157   "Unwind `gnus-article-buffer' if article editing was given up."
6158   (remove-hook 'gnus-article-mode-hook 'gnus-article-mime-edit-article-unwind)
6159   (when (featurep 'font-lock)
6160     (setq font-lock-defaults nil)
6161     (font-lock-mode -1))
6162   (when mime-edit-mode-flag
6163     (mime-edit-exit 'nomime 'no-error)
6164     (message "")))
6165
6166 (defun gnus-article-mime-edit-article-setup ()
6167   "Convert current buffer to MIME-Edit buffer and turn on MIME-Edit mode
6168 after replacing with the original article."
6169   (setq gnus-show-mime t)
6170   (setq gnus-article-edit-done-function
6171         `(lambda (&rest args)
6172            (when mime-edit-mode-flag
6173              (let (mime-edit-insert-user-agent-field)
6174                (mime-edit-exit))
6175              (message ""))
6176            (goto-char (point-min))
6177            (let (case-fold-search)
6178              (when (re-search-forward
6179                     (format "^%s$" (regexp-quote mail-header-separator))
6180                     nil t)
6181                (replace-match "")))
6182            (apply ,gnus-article-edit-done-function args)
6183            (insert
6184             (prog1
6185                 (buffer-substring-no-properties (point-min) (point-max))
6186               (set-buffer (get-buffer-create gnus-original-article-buffer))
6187               (erase-buffer)))
6188            (setq gnus-current-headers (gnus-article-make-full-mail-header))
6189            (set-buffer gnus-article-buffer)
6190            (gnus-article-prepare-display)))
6191   (substitute-key-definition 'gnus-article-edit-done
6192                              'gnus-article-mime-edit-done
6193                              gnus-article-edit-mode-map)
6194   (substitute-key-definition 'gnus-article-edit-exit
6195                              'gnus-article-mime-edit-exit
6196                              gnus-article-edit-mode-map)
6197   (erase-buffer)
6198   (insert-buffer-substring gnus-original-article-buffer)
6199   (unless (member (with-current-buffer gnus-summary-buffer
6200                     gnus-newsgroup-name)
6201                   '("nndraft:delayed" "nndraft:drafts"))
6202     (let ((ofn (symbol-function 'mime-edit-decode-single-part-in-buffer)))
6203       (fset 'mime-edit-decode-single-part-in-buffer
6204             (lambda (&rest args)
6205               (if (let ((content-type (car args)))
6206                     (and (eq 'message (mime-content-type-primary-type
6207                                        content-type))
6208                          (eq 'rfc822 (mime-content-type-subtype
6209                                       content-type))))
6210                   (setcar (cdr args) 'not-decode-text))
6211               (apply ofn args)))
6212       (unwind-protect
6213           (mime-edit-again)
6214         (fset 'mime-edit-decode-single-part-in-buffer ofn))))
6215   (when (featurep 'font-lock)
6216     (set (make-local-variable 'font-lock-defaults)
6217          '(message-font-lock-keywords t))
6218     (font-lock-set-defaults)
6219     (turn-on-font-lock))
6220   (set-buffer-modified-p nil)
6221   (delete-other-windows)
6222   (add-hook 'gnus-article-mode-hook 'gnus-article-mime-edit-article-unwind)
6223   (gnus-run-hooks 'gnus-article-mime-edit-article-setup-hook))
6224
6225 (defun gnus-article-mime-edit-done (&optional arg)
6226   "Update the article MIME edits and exit."
6227   (interactive "P")
6228   (when (featurep 'font-lock)
6229     (setq font-lock-defaults nil)
6230     (font-lock-mode -1))
6231   (let ((inhibit-read-only t))
6232     (gnus-article-edit-done arg)))
6233
6234 (defun gnus-article-mime-edit-exit ()
6235   "Exit the article MIME editing without updating."
6236   (interactive)
6237   (when (or (not (buffer-modified-p))
6238             (yes-or-no-p "Article modified; kill anyway? "))
6239     (when (featurep 'font-lock)
6240       (setq font-lock-defaults nil)
6241       (font-lock-mode -1))
6242     (when mime-edit-mode-flag
6243       (let (mime-edit-insert-user-agent-field)
6244         (mime-edit-exit))
6245       (message ""))
6246     (goto-char (point-min))
6247     (let (case-fold-search)
6248       (when (re-search-forward
6249              (format "^%s$" (regexp-quote mail-header-separator)) nil t)
6250         (replace-match "")))
6251     (let ((winconf gnus-prev-winconf))
6252       (insert (prog1
6253                   (buffer-substring-no-properties (point-min) (point-max))
6254                 (set-buffer (get-buffer-create gnus-original-article-buffer))
6255                 (erase-buffer)))
6256       (setq gnus-current-headers (gnus-article-make-full-mail-header))
6257       (set-buffer gnus-article-buffer)
6258       (gnus-article-prepare-display)
6259       (set-window-configuration winconf))))
6260
6261 ;;;
6262 ;;; Article highlights
6263 ;;;
6264
6265 ;; Written by Per Abrahamsen <abraham@iesd.auc.dk>.
6266
6267 ;;; Internal Variables:
6268
6269 (defcustom gnus-button-url-regexp
6270   (if (string-match "[[:digit:]]" "1") ;; support POSIX?
6271       "\\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:]]\\)"
6272     "\\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\\)\\)")
6273   "Regular expression that matches URLs."
6274   :group 'gnus-article-buttons
6275   :type 'regexp)
6276
6277 (defcustom gnus-button-valid-fqdn-regexp
6278   message-valid-fqdn-regexp
6279   "Regular expression that matches a valid FQDN."
6280   :group 'gnus-article-buttons
6281   :type 'regexp)
6282
6283 (defcustom gnus-button-man-handler 'manual-entry
6284   "Function to use for displaying man pages.
6285 The function must take at least one argument with a string naming the
6286 man page."
6287   :type '(choice (function-item :tag "Man" manual-entry)
6288                  (function-item :tag "Woman" woman)
6289                  (function :tag "Other"))
6290   :group 'gnus-article-buttons)
6291
6292 (defcustom gnus-ctan-url "http://tug.ctan.org/tex-archive/"
6293   "Top directory of a CTAN \(Comprehensive TeX Archive Network\) archive.
6294 If the default site is too slow, try to find a CTAN mirror, see
6295 <URL:http://tug.ctan.org/tex-archive/CTAN.sites?action=/index.html>.  See also
6296 the variable `gnus-button-handle-ctan'."
6297   :group 'gnus-article-buttons
6298   :link '(custom-manual "(gnus)Group Parameters")
6299   :type '(choice (const "http://www.tex.ac.uk/tex-archive/")
6300                  (const "http://tug.ctan.org/tex-archive/")
6301                  (const "http://www.dante.de/CTAN/")
6302                  (string :tag "Other")))
6303
6304 (defcustom gnus-button-ctan-handler 'browse-url
6305   "Function to use for displaying CTAN links.
6306 The function must take one argument, the string naming the URL."
6307   :type '(choice (function-item :tag "Browse Url" browse-url)
6308                  (function :tag "Other"))
6309   :group 'gnus-article-buttons)
6310
6311 (defcustom gnus-button-handle-ctan-bogus-regexp "^/?tex-archive/\\|^/"
6312   "Bogus strings removed from CTAN URLs."
6313   :group 'gnus-article-buttons
6314   :type '(choice (const "^/?tex-archive/\\|/")
6315                  (regexp :tag "Other")))
6316
6317 (defcustom gnus-button-ctan-directory-regexp
6318   (concat
6319    "\\(?:"
6320    "biblio\\|digests\\|dviware\\|fonts\\|graphics\\|help\\|"
6321    "indexing\\|info\\|language\\|macros\\|support\\|systems\\|"
6322    "tds\\|tools\\|usergrps\\|web\\|nonfree\\|obsolete"
6323    "\\)")
6324   "Regular expression for ctan directories.
6325 It should match all directories in the top level of `gnus-ctan-url'."
6326   :group 'gnus-article-buttons
6327   :type 'regexp)
6328
6329 (defcustom gnus-button-mid-or-mail-regexp
6330   (concat "\\b\\(<?[a-z0-9$%(*-=?[_][^<>\")!;:,{}\n\t ]*@"
6331           ;; Felix Wiemann in <87oeuomcz9.fsf@news2.ososo.de>
6332           gnus-button-valid-fqdn-regexp
6333           ">?\\)\\b")
6334   "Regular expression that matches a message ID or a mail address."
6335   :group 'gnus-article-buttons
6336   :type 'regexp)
6337
6338 (defcustom gnus-button-prefer-mid-or-mail 'gnus-button-mid-or-mail-heuristic
6339   "What to do when the button on a string as \"foo123@bar.invalid\" is pushed.
6340 Strings like this can be either a message ID or a mail address.  If it is one
6341 of the symbols `mid' or `mail', Gnus will always assume that the string is a
6342 message ID or a mail address, respectively.  If this variable is set to the
6343 symbol `ask', always query the user what do do.  If it is a function, this
6344 function will be called with the string as it's only argument.  The function
6345 must return `mid', `mail', `invalid' or `ask'."
6346   :group 'gnus-article-buttons
6347   :type '(choice (function-item :tag "Heuristic function"
6348                                 gnus-button-mid-or-mail-heuristic)
6349                  (const ask)
6350                  (const mid)
6351                  (const mail)))
6352
6353 (defcustom gnus-button-mid-or-mail-heuristic-alist
6354   '((-10.0 . ".+\\$.+@")
6355     (-10.0 . "#")
6356     (-10.0 . "\\*")
6357     (-5.0  . "\\+[^+]*\\+.*@") ;; # two plus signs
6358     (-5.0  . "@[Nn][Ee][Ww][Ss]") ;; /\@news/i
6359     (-5.0  . "@.*[Dd][Ii][Aa][Ll][Uu][Pp]") ;; /\@.*dialup/i;
6360     (-1.0  . "^[^a-z]+@")
6361     ;;
6362     (-5.0  . "\\.[0-9][0-9]+.*@") ;; "\.[0-9]{2,}.*\@"
6363     (-5.0  . "[a-z].*[A-Z].*[a-z].*[A-Z].*@") ;; "([a-z].*[A-Z].*){2,}\@"
6364     (-3.0  . "[A-Z][A-Z][a-z][a-z].*@")
6365     (-5.0  . "\\...?.?@") ;; (-5.0 . "\..{1,3}\@")
6366     ;;
6367     (-2.0  . "^[0-9]")
6368     (-1.0  . "^[0-9][0-9]")
6369     ;;
6370     ;; -3.0 /^[0-9][0-9a-fA-F]{2,2}/;
6371     (-3.0  . "^[0-9][0-9a-fA-F][0-9a-fA-F][^0-9a-fA-F]")
6372     ;; -5.0 /^[0-9][0-9a-fA-F]{3,3}/;
6373     (-5.0  . "^[0-9][0-9a-fA-F][0-9a-fA-F][0-9a-fA-F][^0-9a-fA-F]")
6374     ;;
6375     (-3.0  .  "[0-9][0-9][0-9][0-9][0-9][^0-9].*@") ;; "[0-9]{5,}.*\@"
6376     (-3.0  .  "[0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][^0-9].*@")
6377     ;;       "[0-9]{8,}.*\@"
6378     (-3.0
6379      . "[0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9].*@")
6380     ;; "[0-9]{12,}.*\@"
6381     ;; compensation for TDMA dated mail addresses:
6382     (25.0  . "-dated-[0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9]+.*@")
6383     ;;
6384     (-20.0 . "\\.fsf@") ;; Gnus
6385     (-20.0 . "^slrn")
6386     (-20.0 . "^Pine")
6387     (-20.0 . "_-_") ;; Subject change in thread
6388     ;;
6389     (-20.0 . "\\.ln@") ;; leafnode
6390     (-30.0 . "@ID-[0-9]+\\.[a-zA-Z]+\\.dfncis\\.de")
6391     (-30.0 . "@4[Aa][Xx]\\.com") ;; Forte Agent
6392     ;;
6393     ;; (5.0 . "") ;; $local_part_len <= 7
6394     (10.0  . "^[^0-9]+@")
6395     (3.0   . "^[^0-9]+[0-9][0-9]?[0-9]?@")
6396     ;;      ^[^0-9]+[0-9]{1,3}\@ digits only at end of local part
6397     (3.0   . "\@stud")
6398     ;;
6399     (2.0   . "[a-z][a-z][._-][A-Z][a-z].*@")
6400     ;;
6401     (0.5   . "^[A-Z][a-z]")
6402     (0.5   . "^[A-Z][a-z][a-z]")
6403     (1.5   . "^[A-Z][a-z][A-Z][a-z][^a-z]") ;; ^[A-Z][a-z]{3,3}
6404     (2.0   . "^[A-Z][a-z][A-Z][a-z][a-z][^a-z]")) ;; ^[A-Z][a-z]{4,4}
6405   "An alist of \(RATE . REGEXP\) pairs for `gnus-button-mid-or-mail-heuristic'.
6406
6407 A negative RATE indicates a message IDs, whereas a positive indicates a mail
6408 address.  The REGEXP is processed with `case-fold-search' set to nil."
6409   :group 'gnus-article-buttons
6410   :type '(repeat (cons (number :tag "Rate")
6411                        (regexp :tag "Regexp"))))
6412
6413 (defun gnus-button-mid-or-mail-heuristic (mid-or-mail)
6414   "Guess whether MID-OR-MAIL is a message ID or a mail address.
6415 Returns `mid' if MID-OR-MAIL is a message IDs, `mail' if it's a mail
6416 address, `ask' if unsure and `invalid' if the string is invalid."
6417   (let ((case-fold-search nil)
6418         (list gnus-button-mid-or-mail-heuristic-alist)
6419         (result 0) rate regexp lpartlen elem)
6420     (setq lpartlen
6421           (length (gnus-replace-in-string mid-or-mail "^\\(.*\\)@.*$" "\\1")))
6422     (gnus-message 8 "`%s', length of local part=`%s'." mid-or-mail lpartlen)
6423     ;; Certain special cases...
6424     (when (string-match
6425            (concat
6426             "^0[0-9]+-[0-9][0-9][0-9][0-9]@t-online\\.de$\\|"
6427             "^[0-9]+\\.[0-9]+@compuserve\\|"
6428             "@public\\.gmane\\.org")
6429            mid-or-mail)
6430       (gnus-message 8 "`%s' is a known mail address." mid-or-mail)
6431       (setq result 'mail))
6432     (when (string-match "@.*@\\| " mid-or-mail)
6433       (gnus-message 8 "`%s' is invalid." mid-or-mail)
6434       (setq result 'invalid))
6435     ;; Nothing more to do, if result is not a number here...
6436     (when (numberp result)
6437       (while list
6438         (setq elem (car list)
6439               rate (car elem)
6440               regexp (cdr elem)
6441               list (cdr list))
6442         (when (string-match regexp mid-or-mail)
6443           (setq result (+ result rate))
6444           (gnus-message
6445            9 "`%s' matched `%s', rate `%s', result `%s'."
6446            mid-or-mail regexp rate result)))
6447       (when (<= lpartlen 7)
6448         (setq result (+ result 5.0))
6449         (gnus-message 9 "`%s' matched (<= lpartlen 7), result `%s'."
6450                       mid-or-mail result))
6451       (when (>= lpartlen 12)
6452         (gnus-message 9 "`%s' matched (>= lpartlen 12)" mid-or-mail)
6453         (cond
6454          ((string-match "[0-9][^0-9]+[0-9].*@" mid-or-mail)
6455           ;; Long local part should contain realname if e-mail address,
6456           ;; too many digits: message-id.
6457           ;; $score -= 5.0 + 0.1 * $local_part_len;
6458           (setq rate (* -1.0 (+ 5.0 (* 0.1 lpartlen))))
6459           (setq result (+ result rate))
6460           (gnus-message
6461            9 "Many digits in `%s', rate `%s', result `%s'."
6462            mid-or-mail rate result))
6463          ((string-match "[^aeiouy][^aeiouy][^aeiouy][^aeiouy]+.*\@"
6464                         mid-or-mail)
6465           ;; Too few vowels [^aeiouy]{4,}.*\@
6466           (setq result (+ result -5.0))
6467           (gnus-message
6468            9 "Few vowels in `%s', rate `%s', result `%s'."
6469            mid-or-mail -5.0 result))
6470          (t
6471           (setq result (+ result 5.0))
6472           (gnus-message
6473            9 "`%s', rate `%s', result `%s'." mid-or-mail 5.0 result)))))
6474     (gnus-message 8 "`%s': Final rate is `%s'." mid-or-mail result)
6475     ;; Maybe we should make this a customizable alist: (condition . 'result)
6476     (cond
6477      ((symbolp result) result)
6478      ;; Now convert number into proper results:
6479      ((< result -10.0) 'mid)
6480      ((> result  10.0) 'mail)
6481      (t 'ask))))
6482
6483 (defun gnus-button-handle-mid-or-mail (mid-or-mail)
6484   (let* ((pref gnus-button-prefer-mid-or-mail) guessed
6485          (url-mid (concat "news" ":" mid-or-mail))
6486          (url-mailto (concat "mailto" ":" mid-or-mail)))
6487     (gnus-message 9 "mid-or-mail=%s" mid-or-mail)
6488     (when (fboundp pref)
6489       (setq guessed
6490             ;; get rid of surrounding angles...
6491             (funcall pref
6492                      (gnus-replace-in-string mid-or-mail "^<\\|>$" "")))
6493       (if (or (eq 'mid guessed) (eq 'mail guessed))
6494           (setq pref guessed)
6495         (setq pref 'ask)))
6496     (if (eq pref 'ask)
6497         (save-window-excursion
6498           (if (y-or-n-p (concat "Is <" mid-or-mail "> a mail address? "))
6499               (setq pref 'mail)
6500             (setq pref 'mid))))
6501     (cond ((eq pref 'mid)
6502            (gnus-message 8 "calling `gnus-button-handle-news' %s" url-mid)
6503            (gnus-button-handle-news url-mid))
6504           ((eq pref 'mail)
6505            (gnus-message 8 "calling `gnus-url-mailto'  %s" url-mailto)
6506            (gnus-url-mailto url-mailto))
6507           (t (gnus-message 3 "Invalid string.")))))
6508
6509 (defun gnus-button-handle-custom (url)
6510   "Follow a Custom URL."
6511   (customize-apropos (gnus-url-unhex-string url)))
6512
6513 (defvar gnus-button-handle-describe-prefix "^\\(C-h\\|<?[Ff]1>?\\)")
6514
6515 ;; FIXME: Maybe we should merge some of the functions that do quite similar
6516 ;; stuff?
6517
6518 (defun gnus-button-handle-describe-function (url)
6519   "Call `describe-function' when pushing the corresponding URL button."
6520   (describe-function
6521    (intern
6522     (gnus-replace-in-string url gnus-button-handle-describe-prefix ""))))
6523
6524 (defun gnus-button-handle-describe-variable (url)
6525   "Call `describe-variable' when pushing the corresponding URL button."
6526   (describe-variable
6527    (intern
6528     (gnus-replace-in-string url gnus-button-handle-describe-prefix ""))))
6529
6530 (defun gnus-button-handle-symbol (url)
6531 "Display help on variable or function.
6532 Calls `describe-variable' or `describe-function'."
6533   (let ((sym (intern url)))
6534     (cond
6535      ((fboundp sym) (describe-function sym))
6536      ((boundp sym) (describe-variable sym))
6537      (t (gnus-message 3 "`%s' is not a known function of variable." url)))))
6538
6539 (defun gnus-button-handle-describe-key (url)
6540   "Call `describe-key' when pushing the corresponding URL button."
6541   (let* ((key-string
6542           (gnus-replace-in-string url gnus-button-handle-describe-prefix ""))
6543          (keys (ignore-errors (eval `(kbd ,key-string)))))
6544     (if keys
6545         (describe-key keys)
6546       (gnus-message 3 "Invalid key sequence in button: %s" key-string))))
6547
6548 (defun gnus-button-handle-apropos (url)
6549   "Call `apropos' when pushing the corresponding URL button."
6550   (apropos (gnus-replace-in-string url gnus-button-handle-describe-prefix "")))
6551
6552 (defun gnus-button-handle-apropos-command (url)
6553   "Call `apropos' when pushing the corresponding URL button."
6554   (apropos-command
6555    (gnus-replace-in-string url gnus-button-handle-describe-prefix "")))
6556
6557 (defun gnus-button-handle-apropos-variable (url)
6558   "Call `apropos' when pushing the corresponding URL button."
6559   (funcall
6560    (if (fboundp 'apropos-variable) 'apropos-variable 'apropos)
6561    (gnus-replace-in-string url gnus-button-handle-describe-prefix "")))
6562
6563 (defun gnus-button-handle-apropos-documentation (url)
6564   "Call `apropos' when pushing the corresponding URL button."
6565   (funcall
6566    (if (fboundp 'apropos-documentation) 'apropos-documentation 'apropos)
6567    (gnus-replace-in-string url gnus-button-handle-describe-prefix "")))
6568
6569 (defun gnus-button-handle-library (url)
6570   "Call `locate-library' when pushing the corresponding URL button."
6571   (gnus-message 9 "url=`%s'" url)
6572   (let* ((lib (locate-library url))
6573          (file (gnus-replace-in-string (or lib "") "\.elc" ".el")))
6574     (if (not lib)
6575         (gnus-message 1 "Cannot locale library `%s'." url)
6576       (find-file-read-only file))))
6577
6578 (defun gnus-button-handle-ctan (url)
6579   "Call `browse-url' when pushing a CTAN URL button."
6580   (funcall
6581    gnus-button-ctan-handler
6582    (concat
6583     gnus-ctan-url
6584     (gnus-replace-in-string url gnus-button-handle-ctan-bogus-regexp ""))))
6585
6586 (defcustom gnus-button-tex-level 5
6587   "*Integer that says how many TeX-related buttons Gnus will show.
6588 The higher the number, the more buttons will appear and the more false
6589 positives are possible.  Note that you can set this variable local to
6590 specific groups.  Setting it higher in TeX groups is probably a good idea.
6591 See Info node `(gnus)Group Parameters' and the variable `gnus-parameters' on
6592 how to set variables in specific groups."
6593   :group 'gnus-article-buttons
6594   :link '(custom-manual "(gnus)Group Parameters")
6595   :type 'integer)
6596
6597 (defcustom gnus-button-man-level 5
6598   "*Integer that says how many man-related buttons Gnus will show.
6599 The higher the number, the more buttons will appear and the more false
6600 positives are possible.  Note that you can set this variable local to
6601 specific groups.  Setting it higher in Unix groups is probably a good idea.
6602 See Info node `(gnus)Group Parameters' and the variable `gnus-parameters' on
6603 how to set variables in specific groups."
6604   :group 'gnus-article-buttons
6605   :link '(custom-manual "(gnus)Group Parameters")
6606   :type 'integer)
6607
6608 (defcustom gnus-button-emacs-level 5
6609   "*Integer that says how many emacs-related buttons Gnus will show.
6610 The higher the number, the more buttons will appear and the more false
6611 positives are possible.  Note that you can set this variable local to
6612 specific groups.  Setting it higher in Emacs or Gnus related groups is
6613 probably a good idea.  See Info node `(gnus)Group Parameters' and the variable
6614 `gnus-parameters' on how to set variables in specific groups."
6615   :group 'gnus-article-buttons
6616   :link '(custom-manual "(gnus)Group Parameters")
6617   :type 'integer)
6618
6619 (defcustom gnus-button-message-level 5
6620   "*Integer that says how many buttons for news or mail messages will appear.
6621 The higher the number, the more buttons will appear and the more false
6622 positives are possible."
6623   ;; mail addresses, MIDs, URLs for news, ...
6624   :group 'gnus-article-buttons
6625   :type 'integer)
6626
6627 (defcustom gnus-button-browse-level 5
6628   "*Integer that says how many buttons for browsing will appear.
6629 The higher the number, the more buttons will appear and the more false
6630 positives are possible."
6631   ;; stuff handled by `browse-url' or `gnus-button-embedded-url'
6632   :group 'gnus-article-buttons
6633   :type 'integer)
6634
6635 (defcustom gnus-button-alist
6636   '(("<\\(url:[>\n\t ]*?\\)?\\(nntp\\|news\\):[>\n\t ]*\\([^>\n\t ]*@[^>\n\t ]*\\)>"
6637      0 (>= gnus-button-message-level 0) gnus-button-handle-news 3)
6638     ("\\b\\(nntp\\|news\\):\\([^>\n\t ]*@[^>)!;:,\n\t ]*\\)" 0 t
6639      gnus-button-handle-news 2)
6640     ("\\(\\b<\\(url:[>\n\t ]*\\)?\\(nntp\\|news\\):[>\n\t ]*\\(//\\)?\\([^>\n\t ]*\\)>\\)"
6641      1 (>= gnus-button-message-level 0) gnus-button-fetch-group 5)
6642     ("\\b\\(nntp\\|news\\):\\(//\\)?\\([^'\">\n\t ]+\\)"
6643      0 (>= gnus-button-message-level 0) gnus-button-fetch-group 3)
6644     ;; RFC 2392 (Don't allow `/' in domain part --> CID)
6645     ("\\bmid:\\(//\\)?\\([^'\">\n\t ]+@[^'\">\n\t /]+\\)"
6646      0 (>= gnus-button-message-level 0) gnus-button-message-id 2)
6647     ("\\bin\\( +article\\| +message\\)? +\\(<\\([^\n @<>]+@[^\n @<>]+\\)>\\)"
6648      2 (>= gnus-button-message-level 0) gnus-button-message-id 3)
6649     ("\\(<URL: *\\)mailto: *\\([^> \n\t]+\\)>"
6650      0 (>= gnus-button-message-level 0) gnus-url-mailto 2)
6651     ;; RFC 2368 (The mailto URL scheme)
6652     ("\\bmailto:\\([-a-z.@_+0-9%=?&/]+\\)"
6653      0 (>= gnus-button-message-level 0) gnus-url-mailto 1)
6654     ("\\bmailto:\\([^ \n\t]+\\)"
6655      0 (>= gnus-button-message-level 0) gnus-url-mailto 1)
6656     ;; CTAN
6657     ((concat "\\bCTAN:[ \t\n]?[^>)!;:,'\n\t ]*\\("
6658              gnus-button-ctan-directory-regexp
6659              "[^][>)!;:,'\n\t ]+\\)")
6660      0 (>= gnus-button-tex-level 1) gnus-button-handle-ctan 1)
6661     ((concat "\\btex-archive/\\("
6662              gnus-button-ctan-directory-regexp
6663              "/[-_.a-z0-9/]+[-_./a-z0-9]+[/a-z0-9]\\)")
6664      1 (>= gnus-button-tex-level 6) gnus-button-handle-ctan 1)
6665     ((concat
6666       "\\b\\("
6667       gnus-button-ctan-directory-regexp
6668       "/[-_.a-z0-9]+/[-_./a-z0-9]+[/a-z0-9]\\)")
6669      1 (>= gnus-button-tex-level 8) gnus-button-handle-ctan 1)
6670     ;; This is info (home-grown style) <info://foo/bar+baz>
6671     ("\\binfo://\\([^'\">\n\t ]+\\)"
6672      0 (>= gnus-button-emacs-level 1) gnus-button-handle-info-url 1)
6673     ;; Info GNOME style <info:foo#bar_baz>
6674     ("\\binfo:\\([^('\n\t\r \"><][^'\n\t\r \"><]*\\)"
6675      0 (>= gnus-button-emacs-level 1) gnus-button-handle-info-url-gnome 1)
6676     ;; Info KDE style <info:(foo)bar baz>
6677     ("<\\(info:\\(([^)]+)[^>\n\r]*\\)\\)>"
6678      1 (>= gnus-button-emacs-level 1) gnus-button-handle-info-url-kde 2)
6679     ("\\((Info-goto-node\\|(info\\)[ \t\n]*\\(\"[^\"]*\"\\))" 0
6680      (>= gnus-button-emacs-level 1) gnus-button-handle-info-url 2)
6681     ("\\b\\(C-h\\|<?[Ff]1>?\\)[ \t\n]+i[ \t\n]+d?[ \t\n]?m[ \t\n]+\\([^ ]+ ?[^ ]+\\)[ \t\n]+RET"
6682      ;; Info links like `C-h i d m CC Mode RET'
6683      0 (>= gnus-button-emacs-level 1) gnus-button-handle-info-keystrokes 2)
6684     ;; This is custom
6685     ("\\bcustom:\\(//\\)?\\([^'\">\n\t ]+\\)"
6686      0 (>= gnus-button-emacs-level 5) gnus-button-handle-custom 2)
6687     ("M-x[ \t\n]customize-[^ ]+[ \t\n]RET[ \t\n]\\([^ ]+\\)[ \t\n]RET" 0
6688      (>= gnus-button-emacs-level 1) gnus-button-handle-custom 1)
6689     ;; Emacs help commands
6690     ("M-x[ \t\n]+apropos[ \t\n]+RET[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET"
6691      ;; regexp doesn't match arguments containing ` '.
6692      0 (>= gnus-button-emacs-level 1) gnus-button-handle-apropos 1)
6693     ("M-x[ \t\n]+apropos-command[ \t\n]+RET[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET"
6694      0 (>= gnus-button-emacs-level 1) gnus-button-handle-apropos-command 1)
6695     ("M-x[ \t\n]+apropos-variable[ \t\n]+RET[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET"
6696      0 (>= gnus-button-emacs-level 1) gnus-button-handle-apropos-variable 1)
6697     ("M-x[ \t\n]+apropos-documentation[ \t\n]+RET[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET"
6698      0 (>= gnus-button-emacs-level 1) gnus-button-handle-apropos-documentation 1)
6699     ;; The following entries may lead to many false positives so don't enable
6700     ;; them by default (use a high button level):
6701     ("/\\([a-z][-a-z0-9]+\\.el\\)\\>"
6702      1 (>= gnus-button-emacs-level 8) gnus-button-handle-library 1)
6703     ("`\\([a-z][-a-z0-9]+\\.el\\)'"
6704      1 (>= gnus-button-emacs-level 8) gnus-button-handle-library 1)
6705     ("`\\([a-z][a-z0-9]+-[a-z]+-[-a-z]+\\|\\(gnus\\|message\\)-[-a-z]+\\)'"
6706      0 (>= gnus-button-emacs-level 8) gnus-button-handle-symbol 1)
6707     ("`\\([a-z][a-z0-9]+-[a-z]+\\)'"
6708      0 (>= gnus-button-emacs-level 9) gnus-button-handle-symbol 1)
6709     ("(setq[ \t\n]+\\([a-z][a-z0-9]+-[-a-z0-9]+\\)[ \t\n]+.+)"
6710      1 (>= gnus-button-emacs-level 7) gnus-button-handle-describe-variable 1)
6711     ("\\bM-x[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET"
6712      1 (>= gnus-button-emacs-level 7) gnus-button-handle-describe-function 1)
6713     ("\\b\\(C-h\\|<?[Ff]1>?\\)[ \t\n]+f[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET"
6714      0 (>= gnus-button-emacs-level 1) gnus-button-handle-describe-function 2)
6715     ("\\b\\(C-h\\|<?[Ff]1>?\\)[ \t\n]+v[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET"
6716      0 (>= gnus-button-emacs-level 1) gnus-button-handle-describe-variable 2)
6717     ("`\\(\\b\\(C-h\\|<?[Ff]1>?\\)[ \t\n]+k[ \t\n]+\\([^']+\\)\\)'"
6718      ;; Unlike the other regexps we really have to require quoting
6719      ;; here to determine where it ends.
6720      1 (>= gnus-button-emacs-level 1) gnus-button-handle-describe-key 3)
6721     ;; This is how URLs _should_ be embedded in text (RFC 1738, RFC 2396)...
6722     ("<URL: *\\([^<>]*\\)>"
6723      1 (>= gnus-button-browse-level 0) gnus-button-embedded-url 1)
6724     ;; RFC 2396 (2.4.3., delims) ...
6725     ("\"URL: *\\([^\"]*\\)\""
6726      1 (>= gnus-button-browse-level 0) gnus-button-embedded-url 1)
6727     ;; RFC 2396 (2.4.3., delims) ...
6728     ("\"URL: *\\([^\"]*\\)\""
6729      1 (>= gnus-button-browse-level 0) gnus-button-embedded-url 1)
6730     ;; Raw URLs.
6731     (gnus-button-url-regexp
6732      0 (>= gnus-button-browse-level 0) browse-url 0)
6733     ;; man pages
6734     ("\\b\\([a-z][a-z]+\\)([1-9])\\W"
6735      0 (and (>= gnus-button-man-level 1) (< gnus-button-man-level 3))
6736      gnus-button-handle-man 1)
6737     ;; more man pages: resolv.conf(5), iso_8859-1(7), xterm(1x)
6738     ("\\b\\([a-z][-_.a-z0-9]+\\)([1-9])\\W"
6739      0 (and (>= gnus-button-man-level 3) (< gnus-button-man-level 5))
6740      gnus-button-handle-man 1)
6741     ;; even more: Apache::PerlRun(3pm), PDL::IO::FastRaw(3pm),
6742     ;; SoWWWAnchor(3iv), XSelectInput(3X11), X(1), X(7)
6743     ("\\b\\([a-z][-+_.:a-z0-9]+\\)([1-9][X1a-z]*)\\W\\|\\b\\(X\\)([1-9])\\W"
6744      0 (>= gnus-button-man-level 5) gnus-button-handle-man 1)
6745     ;; MID or mail: To avoid too many false positives we don't try to catch
6746     ;; all kind of allowed MIDs or mail addresses.  Domain part must contain
6747     ;; at least one dot.  TLD must contain two or three chars or be a know TLD
6748     ;; (info|name|...).  Put this entry near the _end_ of `gnus-button-alist'
6749     ;; so that non-ambiguous entries (see above) match first.
6750     (gnus-button-mid-or-mail-regexp
6751      0 (>= gnus-button-message-level 5) gnus-button-handle-mid-or-mail 1))
6752   "*Alist of regexps matching buttons in article bodies.
6753
6754 Each entry has the form (REGEXP BUTTON FORM CALLBACK PAR...), where
6755 REGEXP: is the string (case insensitive) matching text around the button (can
6756 also be Lisp expression evaluating to a string),
6757 BUTTON: is the number of the regexp grouping actually matching the button,
6758 FORM: is a Lisp expression which must eval to true for the button to
6759 be added,
6760 CALLBACK: is the function to call when the user push this button, and each
6761 PAR: is a number of a regexp grouping whose text will be passed to CALLBACK.
6762
6763 CALLBACK can also be a variable, in that case the value of that
6764 variable it the real callback function."
6765   :group 'gnus-article-buttons
6766   :type '(repeat (list (choice regexp variable sexp)
6767                        (integer :tag "Button")
6768                        (sexp :tag "Form")
6769                        (function :tag "Callback")
6770                        (repeat :tag "Par"
6771                                :inline t
6772                                (integer :tag "Regexp group")))))
6773
6774 (defcustom gnus-header-button-alist
6775   '(("^\\(References\\|Message-I[Dd]\\|^In-Reply-To\\):" "<[^<>]+>"
6776      0 (>= gnus-button-message-level 0) gnus-button-message-id 0)
6777     ("^\\(From\\|Reply-To\\):" ": *\\(.+\\)$"
6778      1 (>= gnus-button-message-level 0) gnus-button-reply 1)
6779     ("^\\(Cc\\|To\\):" "[^ \t\n<>,()\"]+@[^ \t\n<>,()\"]+"
6780      0 (>= gnus-button-message-level 0) gnus-button-mailto 0)
6781     ("^X-[Uu][Rr][Ll]:" gnus-button-url-regexp
6782      0 (>= gnus-button-browse-level 0) browse-url 0)
6783     ("^Subject:" gnus-button-url-regexp
6784      0 (>= gnus-button-browse-level 0) browse-url 0)
6785     ("^[^:]+:" gnus-button-url-regexp
6786      0 (>= gnus-button-browse-level 0) browse-url 0)
6787     ("^[^:]+:" "\\bmailto:\\([-a-z.@_+0-9%=?&/]+\\)"
6788      0 (>= gnus-button-message-level 0) gnus-url-mailto 1)
6789     ("^[^:]+:" "\\(<\\(url: \\)?\\(nntp\\|news\\):\\([^>\n ]*\\)>\\)"
6790      1 (>= gnus-button-message-level 0) gnus-button-message-id 4))
6791   "*Alist of headers and regexps to match buttons in article heads.
6792
6793 This alist is very similar to `gnus-button-alist', except that each
6794 alist has an additional HEADER element first in each entry:
6795
6796 \(HEADER REGEXP BUTTON FORM CALLBACK PAR)
6797
6798 HEADER is a regexp to match a header.  For a fuller explanation, see
6799 `gnus-button-alist'."
6800   :group 'gnus-article-buttons
6801   :group 'gnus-article-headers
6802   :type '(repeat (list (regexp :tag "Header")
6803                        (choice regexp variable)
6804                        (integer :tag "Button")
6805                        (sexp :tag "Form")
6806                        (function :tag "Callback")
6807                        (repeat :tag "Par"
6808                                :inline t
6809                                (integer :tag "Regexp group")))))
6810
6811 ;;; Commands:
6812
6813 (defun gnus-article-push-button (event)
6814   "Check text under the mouse pointer for a callback function.
6815 If the text under the mouse pointer has a `gnus-callback' property,
6816 call it with the value of the `gnus-data' text property."
6817   (interactive "e")
6818   (set-buffer (window-buffer (posn-window (event-start event))))
6819   (let* ((pos (posn-point (event-start event)))
6820          (data (get-text-property pos 'gnus-data))
6821          (fun (get-text-property pos 'gnus-callback)))
6822     (goto-char pos)
6823     (when fun
6824       (funcall fun data))))
6825
6826 (defun gnus-article-press-button ()
6827   "Check text at point for a callback function.
6828 If the text at point has a `gnus-callback' property,
6829 call it with the value of the `gnus-data' text property."
6830   (interactive)
6831   (let ((data (get-text-property (point) 'gnus-data))
6832         (fun (get-text-property (point) 'gnus-callback)))
6833     (when fun
6834       (funcall fun data))))
6835
6836 (defun gnus-article-prev-button (n)
6837   "Move point to N buttons backward.
6838 If N is negative, move forward instead."
6839   (interactive "p")
6840   (gnus-article-next-button (- n)))
6841
6842 (defun gnus-article-next-button (n)
6843   "Move point to N buttons forward.
6844 If N is negative, move backward instead."
6845   (interactive "p")
6846   (let ((function (if (< n 0) 'previous-single-property-change
6847                     'next-single-property-change))
6848         (inhibit-point-motion-hooks t)
6849         (backward (< n 0))
6850         (limit (if (< n 0) (point-min) (point-max))))
6851     (setq n (abs n))
6852     (while (and (not (= limit (point)))
6853                 (> n 0))
6854       ;; Skip past the current button.
6855       (when (get-text-property (point) 'gnus-callback)
6856         (goto-char (funcall function (point) 'gnus-callback nil limit)))
6857       ;; Go to the next (or previous) button.
6858       (gnus-goto-char (funcall function (point) 'gnus-callback nil limit))
6859       ;; Put point at the start of the button.
6860       (when (and backward (not (get-text-property (point) 'gnus-callback)))
6861         (goto-char (funcall function (point) 'gnus-callback nil limit)))
6862       ;; Skip past intangible buttons.
6863       (when (get-text-property (point) 'intangible)
6864         (incf n))
6865       (decf n))
6866     (unless (zerop n)
6867       (gnus-message 5 "No more buttons"))
6868     n))
6869
6870 (defun gnus-article-highlight (&optional force)
6871   "Highlight current article.
6872 This function calls `gnus-article-highlight-headers',
6873 `gnus-article-highlight-citation',
6874 `gnus-article-highlight-signature', and `gnus-article-add-buttons' to
6875 do the highlighting.  See the documentation for those functions."
6876   (interactive (list 'force))
6877   (gnus-article-highlight-headers)
6878   (gnus-article-highlight-citation force)
6879   (gnus-article-highlight-signature)
6880   (gnus-article-add-buttons force)
6881   (gnus-article-add-buttons-to-head))
6882
6883 (defun gnus-article-highlight-some (&optional force)
6884   "Highlight current article.
6885 This function calls `gnus-article-highlight-headers',
6886 `gnus-article-highlight-signature', and `gnus-article-add-buttons' to
6887 do the highlighting.  See the documentation for those functions."
6888   (interactive (list 'force))
6889   (gnus-article-highlight-headers)
6890   (gnus-article-highlight-signature)
6891   (gnus-article-add-buttons))
6892
6893 (defun gnus-article-highlight-headers ()
6894   "Highlight article headers as specified by `gnus-header-face-alist'."
6895   (interactive)
6896   (gnus-with-article-headers
6897     (let ((alist gnus-header-face-alist)
6898           entry regexp header-face field-face from hpoints fpoints)
6899       (while (setq entry (pop alist))
6900         (goto-char (point-min))
6901         (setq regexp (concat "^\\("
6902                              (if (string-equal "" (nth 0 entry))
6903                                  "[^\t ]"
6904                                (nth 0 entry))
6905                              "\\)")
6906               header-face (nth 1 entry)
6907               field-face (nth 2 entry))
6908         (while (and (re-search-forward regexp nil t)
6909                     (not (eobp)))
6910           (beginning-of-line)
6911           (setq from (point))
6912           (unless (search-forward ":" nil t)
6913             (forward-char 1))
6914           (when (and header-face
6915                      (not (memq (point) hpoints)))
6916             (push (point) hpoints)
6917             (gnus-put-text-property from (point) 'face header-face))
6918           (when (and field-face
6919                      (not (memq (setq from (point)) fpoints)))
6920             (push from fpoints)
6921             (if (re-search-forward "^[^ \t]" nil t)
6922                 (forward-char -2)
6923               (goto-char (point-max)))
6924             (gnus-put-text-property from (point) 'face field-face)))))))
6925
6926 (defun gnus-article-highlight-signature ()
6927   "Highlight the signature in an article.
6928 It does this by highlighting everything after
6929 `gnus-signature-separator' using `gnus-signature-face'."
6930   (interactive)
6931   (when gnus-signature-face
6932     (gnus-with-article-buffer
6933       (let ((inhibit-point-motion-hooks t))
6934         (save-restriction
6935           (when (gnus-article-narrow-to-signature)
6936             (gnus-overlay-put (gnus-make-overlay (point-min) (point-max))
6937                               'face gnus-signature-face)))))))
6938
6939 (defun gnus-article-buttonize-signature ()
6940   "Add button to the signature."
6941   (interactive)
6942   (save-excursion
6943     (set-buffer gnus-article-buffer)
6944     (let ((buffer-read-only nil)
6945           (inhibit-point-motion-hooks t))
6946       (when (gnus-article-search-signature)
6947         (gnus-article-add-button (match-beginning 0) (match-end 0)
6948                                  'gnus-signature-toggle
6949                                  (set-marker (make-marker)
6950                                              (1+ (match-end 0))))))))
6951
6952 (defun gnus-button-in-region-p (b e prop)
6953   "Say whether PROP exists in the region."
6954   (text-property-not-all b e prop nil))
6955
6956 (defun gnus-article-add-buttons (&optional force)
6957   "Find external references in the article and make buttons of them.
6958 \"External references\" are things like Message-IDs and URLs, as
6959 specified by `gnus-button-alist'."
6960   (interactive (list 'force))
6961   (gnus-with-article-buffer
6962     (let ((inhibit-point-motion-hooks t)
6963           (case-fold-search t)
6964           (alist gnus-button-alist)
6965           beg entry regexp)
6966       ;; Remove all old markers.
6967       (let (marker entry new-list)
6968         (while (setq marker (pop gnus-button-marker-list))
6969           (if (or (< marker (point-min)) (>= marker (point-max)))
6970               (push marker new-list)
6971             (goto-char marker)
6972             (when (setq entry (gnus-button-entry))
6973               (put-text-property (match-beginning (nth 1 entry))
6974                                  (match-end (nth 1 entry))
6975                                  'gnus-callback nil))
6976             (set-marker marker nil)))
6977         (setq gnus-button-marker-list new-list))
6978       ;; We skip the headers.
6979       (article-goto-body)
6980       (setq beg (point))
6981       (while (setq entry (pop alist))
6982         (setq regexp (eval (car entry)))
6983         (goto-char beg)
6984         (while (re-search-forward regexp nil t)
6985           (let* ((start (and entry (match-beginning (nth 1 entry))))
6986                  (end (and entry (match-end (nth 1 entry))))
6987                  (from (match-beginning 0)))
6988             (when (and (or (eq t (nth 2 entry))
6989                            (eval (nth 2 entry)))
6990                        (not (gnus-button-in-region-p
6991                              start end 'gnus-callback)))
6992               ;; That optional form returned non-nil, so we add the
6993               ;; button.
6994               (gnus-article-add-button
6995                start end 'gnus-button-push
6996                (car (push (set-marker (make-marker) from)
6997                           gnus-button-marker-list))))))))))
6998
6999 ;; Add buttons to the head of an article.
7000 (defun gnus-article-add-buttons-to-head ()
7001   "Add buttons to the head of the article."
7002   (interactive)
7003   (gnus-with-article-headers
7004     (let ((alist gnus-header-button-alist)
7005           entry beg end)
7006       (while alist
7007         ;; Each alist entry.
7008         (setq entry (pop alist))
7009         (goto-char (point-min))
7010         (while (re-search-forward (car entry) nil t)
7011           ;; Each header matching the entry.
7012           (setq beg (match-beginning 0))
7013           (setq end (or (and (re-search-forward "^[^ \t]" nil t)
7014                              (match-beginning 0))
7015                         (point-max)))
7016           (goto-char beg)
7017           (while (re-search-forward (eval (nth 1 entry)) end t)
7018             ;; Each match within a header.
7019             (let* ((entry (cdr entry))
7020                    (start (match-beginning (nth 1 entry)))
7021                    (end (match-end (nth 1 entry)))
7022                    (form (nth 2 entry)))
7023               (goto-char (match-end 0))
7024               (when (eval form)
7025                 (gnus-article-add-button
7026                  start end (nth 3 entry)
7027                  (buffer-substring (match-beginning (nth 4 entry))
7028                                    (match-end (nth 4 entry)))))))
7029           (goto-char end))))))
7030
7031 ;;; External functions:
7032
7033 (defun gnus-article-add-button (from to fun &optional data)
7034   "Create a button between FROM and TO with callback FUN and data DATA."
7035   (when gnus-article-button-face
7036     (gnus-overlay-put (gnus-make-overlay from to)
7037                       'face gnus-article-button-face))
7038   (gnus-add-text-properties
7039    from to
7040    (nconc (and gnus-article-mouse-face
7041                (list gnus-mouse-face-prop gnus-article-mouse-face))
7042           (list 'gnus-callback fun)
7043           (and data (list 'gnus-data data))))
7044   (widget-convert-button 'link from to :action 'gnus-widget-press-button
7045                          :button-keymap gnus-widget-button-keymap))
7046
7047 ;;; Internal functions:
7048
7049 (defun gnus-article-set-globals ()
7050   (with-current-buffer gnus-summary-buffer
7051     (gnus-set-global-variables)))
7052
7053 (defun gnus-signature-toggle (end)
7054   (gnus-with-article-buffer
7055     (let ((inhibit-point-motion-hooks t)
7056           (limit (next-single-property-change end 'mime-view-entity
7057                                               nil (point-max))))
7058       (if (text-property-any end limit 'article-type 'signature)
7059           (progn
7060             (gnus-delete-wash-type 'signature)
7061             (gnus-remove-text-properties-when
7062              'article-type 'signature end limit
7063              (cons 'article-type (cons 'signature
7064                                        gnus-hidden-properties))))
7065         (gnus-add-wash-type 'signature)
7066         (gnus-add-text-properties-when
7067          'article-type nil end limit
7068          (cons 'article-type (cons 'signature
7069                                    gnus-hidden-properties)))))
7070     (let ((gnus-article-mime-handle-alist-1 gnus-article-mime-handle-alist))
7071       (gnus-set-mode-line 'article))))
7072
7073 (defun gnus-button-entry ()
7074   ;; Return the first entry in `gnus-button-alist' matching this place.
7075   (let ((alist gnus-button-alist)
7076         (entry nil))
7077     (while alist
7078       (setq entry (pop alist))
7079       (if (looking-at (eval (car entry)))
7080           (setq alist nil)
7081         (setq entry nil)))
7082     entry))
7083
7084 (defun gnus-button-push (marker)
7085   ;; Push button starting at MARKER.
7086   (save-excursion
7087     (goto-char marker)
7088     (let* ((entry (gnus-button-entry))
7089            (inhibit-point-motion-hooks t)
7090            (fun (nth 3 entry))
7091            (args (mapcar (lambda (group)
7092                            (let ((string (match-string group)))
7093                              (set-text-properties
7094                               0 (length string) nil string)
7095                              string))
7096                          (nthcdr 4 entry))))
7097       (cond
7098        ((fboundp fun)
7099         (apply fun args))
7100        ((and (boundp fun)
7101              (fboundp (symbol-value fun)))
7102         (apply (symbol-value fun) args))
7103        (t
7104         (gnus-message 1 "You must define `%S' to use this button"
7105                       (cons fun args)))))))
7106
7107 (defun gnus-parse-news-url (url)
7108   (let (scheme server group message-id articles)
7109     (with-temp-buffer
7110       (insert url)
7111       (goto-char (point-min))
7112       (when (looking-at "\\([A-Za-z]+\\):")
7113         (setq scheme (match-string 1))
7114         (goto-char (match-end 0)))
7115       (when (looking-at "//\\([^/]+\\)/")
7116         (setq server (match-string 1))
7117         (goto-char (match-end 0)))
7118
7119       (cond
7120        ((looking-at "\\(.*@.*\\)")
7121         (setq message-id (match-string 1)))
7122        ((looking-at "\\([^/]+\\)/\\([-0-9]+\\)")
7123         (setq group (match-string 1)
7124               articles (split-string (match-string 2) "-")))
7125        ((looking-at "\\([^/]+\\)/?")
7126         (setq group (match-string 1)))
7127        (t
7128         (error "Unknown news URL syntax"))))
7129     (list scheme server group message-id articles)))
7130
7131 (defun gnus-button-handle-news (url)
7132   "Fetch a news URL."
7133   (destructuring-bind (scheme server group message-id articles)
7134       (gnus-parse-news-url url)
7135     (cond
7136      (message-id
7137       (save-excursion
7138         (set-buffer gnus-summary-buffer)
7139         (if server
7140             (let ((gnus-refer-article-method (list (list 'nntp server))))
7141               (gnus-summary-refer-article message-id))
7142           (gnus-summary-refer-article message-id))))
7143      (group
7144       (gnus-button-fetch-group url)))))
7145
7146 (defun gnus-button-handle-man (url)
7147   "Fetch a man page."
7148   (funcall gnus-button-man-handler url))
7149
7150 (defun gnus-button-handle-info-url (url)
7151   "Fetch an info URL."
7152   (setq url (mm-subst-char-in-string ?+ ?\  url))
7153   (cond
7154    ((string-match "^\\([^:/]+\\)?/\\(.*\\)" url)
7155     (gnus-info-find-node
7156      (concat "(" (or (gnus-url-unhex-string (match-string 1 url))
7157                      "Gnus")
7158              ")" (gnus-url-unhex-string (match-string 2 url)))))
7159    ((string-match "([^)\"]+)[^\"]+" url)
7160     (setq url
7161           (gnus-replace-in-string
7162            (gnus-replace-in-string url "[\n\t ]+" " ") "\"" ""))
7163     (gnus-info-find-node url))
7164    (t (error "Can't parse %s" url))))
7165
7166 (defun gnus-button-handle-info-url-gnome (url)
7167   "Fetch GNOME style info URL."
7168   (setq url (mm-subst-char-in-string ?_ ?\  url))
7169   (if (string-match "\\([^#]+\\)#?\\(.*\\)" url)
7170       (gnus-info-find-node
7171        (concat "("
7172                (gnus-url-unhex-string
7173                  (match-string 1 url))
7174                ")"
7175                (or (gnus-url-unhex-string
7176                     (match-string 2 url))
7177                    "Top")))
7178     (error "Can't parse %s" url)))
7179
7180 (defun gnus-button-handle-info-url-kde (url)
7181   "Fetch KDE style info URL."
7182   (gnus-info-find-node (gnus-url-unhex-string url)))
7183
7184 (defun gnus-button-handle-info-keystrokes (url)
7185   "Call `info' when pushing the corresponding URL button."
7186   ;; For links like `C-h i d m gnus RET', `C-h i d m CC Mode RET'.
7187   (info)
7188   (Info-directory)
7189   (Info-menu url))
7190
7191 (defun gnus-button-message-id (message-id)
7192   "Fetch MESSAGE-ID."
7193   (with-current-buffer gnus-summary-buffer
7194     (gnus-summary-refer-article message-id)))
7195
7196 (defun gnus-button-fetch-group (address)
7197   "Fetch GROUP specified by ADDRESS."
7198   (if (not (string-match "[:/]" address))
7199       ;; This is just a simple group url.
7200       (gnus-group-read-ephemeral-group address gnus-select-method)
7201     (if (not
7202          (string-match
7203           "^\\([^:/]+\\)\\(:\\([^/]+\\)\\)?/\\([^/]+\\)\\(/\\([0-9]+\\)\\)?"
7204           address))
7205         (error "Can't parse %s" address)
7206       (gnus-group-read-ephemeral-group
7207        (match-string 4 address)
7208        `(nntp ,(match-string 1 address)
7209               (nntp-address ,(match-string 1 address))
7210               (nntp-port-number ,(if (match-end 3)
7211                                      (match-string 3 address)
7212                                    "nntp")))
7213        nil nil nil
7214        (and (match-end 6) (list (string-to-int (match-string 6 address))))))))
7215
7216 (defun gnus-url-parse-query-string (query &optional downcase)
7217   (let (retval pairs cur key val)
7218     (setq pairs (split-string query "&"))
7219     (while pairs
7220       (setq cur (car pairs)
7221             pairs (cdr pairs))
7222       (if (not (string-match "=" cur))
7223           nil                           ; Grace
7224         (setq key (gnus-url-unhex-string (substring cur 0 (match-beginning 0)))
7225               val (gnus-url-unhex-string (substring cur (match-end 0) nil) t))
7226         (if downcase
7227             (setq key (downcase key)))
7228         (setq cur (assoc key retval))
7229         (if cur
7230             (setcdr cur (cons val (cdr cur)))
7231           (setq retval (cons (list key val) retval)))))
7232     retval))
7233
7234 (defun gnus-url-mailto (url)
7235   ;; Send mail to someone
7236   (when (string-match "mailto:/*\\(.*\\)" url)
7237     (setq url (substring url (match-beginning 1) nil)))
7238   (let (to args subject func)
7239     (setq args (gnus-url-parse-query-string
7240                 (if (string-match "^\\?" url)
7241                     (substring url 1)
7242                   (if (string-match "^\\([^?]+\\)\\?\\(.*\\)" url)
7243                       (concat "to=" (match-string 1 url) "&"
7244                               (match-string 2 url))
7245                     (concat "to=" url)))
7246                 t)
7247           subject (cdr-safe (assoc "subject" args)))
7248     (gnus-msg-mail)
7249     (while args
7250       (setq func (intern-soft (concat "message-goto-" (downcase (caar args)))))
7251       (if (fboundp func)
7252           (funcall func)
7253         (message-position-on-field (caar args)))
7254       (insert (gnus-replace-in-string
7255                (mapconcat 'identity (reverse (cdar args)) ", ")
7256                "\r\n" "\n" t))
7257       (setq args (cdr args)))
7258     (if subject
7259         (message-goto-body)
7260       (message-goto-subject))))
7261
7262 (defun gnus-button-embedded-url (address)
7263   "Activate ADDRESS with `browse-url'."
7264   (browse-url (gnus-strip-whitespace address)))
7265
7266 ;;; Next/prev buttons in the article buffer.
7267
7268 (defvar gnus-next-page-line-format "%{%(Next page...%)%}\n")
7269 (defvar gnus-prev-page-line-format "%{%(Previous page...%)%}\n")
7270
7271 (defvar gnus-prev-page-map
7272   (let ((map (make-sparse-keymap)))
7273     (define-key map gnus-mouse-2 'gnus-button-prev-page)
7274     (define-key map "\r" 'gnus-button-prev-page)
7275     map))
7276
7277 (defvar gnus-next-page-map
7278   (let ((map (make-sparse-keymap)))
7279     (define-key map gnus-mouse-2 'gnus-button-next-page)
7280     (define-key map "\r" 'gnus-button-next-page)
7281     map))
7282
7283 (defun gnus-insert-prev-page-button ()
7284   (let ((b (point))
7285         (buffer-read-only nil)
7286         (situation (get-text-property (point-min) 'mime-view-situation)))
7287     (gnus-eval-format
7288      gnus-prev-page-line-format nil
7289      `(keymap ,gnus-prev-page-map
7290          gnus-prev t
7291          gnus-callback gnus-article-button-prev-page
7292          article-type annotation
7293          mime-view-situation ,situation))
7294     (widget-convert-button
7295      'link b (if (bolp)
7296                  ;; Exclude a newline.
7297                  (1- (point))
7298                (point))
7299      :action 'gnus-button-prev-page
7300      :button-keymap gnus-prev-page-map)))
7301
7302 (defun gnus-button-next-page (&optional args more-args)
7303   "Go to the next page."
7304   (interactive)
7305   (let ((win (selected-window)))
7306     (select-window (gnus-get-buffer-window gnus-article-buffer t))
7307     (gnus-article-next-page)
7308     (select-window win)))
7309
7310 (defun gnus-button-prev-page (&optional args more-args)
7311   "Go to the prev page."
7312   (interactive)
7313   (let ((win (selected-window)))
7314     (select-window (gnus-get-buffer-window gnus-article-buffer t))
7315     (gnus-article-prev-page)
7316     (select-window win)))
7317
7318 (defun gnus-insert-next-page-button ()
7319   (let ((b (point))
7320         (buffer-read-only nil)
7321         (situation (get-text-property (point-min) 'mime-view-situation)))
7322     (gnus-eval-format gnus-next-page-line-format nil
7323                       `(keymap ,gnus-next-page-map
7324                           gnus-next t
7325                           gnus-callback gnus-article-button-next-page
7326                           article-type annotation
7327                           mime-view-situation ,situation))
7328     (widget-convert-button
7329      'link b (if (bolp)
7330                  ;; Exclude a newline.
7331                  (1- (point))
7332                (point))
7333      :action 'gnus-button-next-page
7334      :button-keymap gnus-next-page-map)))
7335
7336 (defun gnus-article-button-next-page (arg)
7337   "Go to the next page."
7338   (interactive "P")
7339   (let ((win (selected-window)))
7340     (select-window (gnus-get-buffer-window gnus-article-buffer t))
7341     (gnus-article-next-page)
7342     (select-window win)))
7343
7344 (defun gnus-article-button-prev-page (arg)
7345   "Go to the prev page."
7346   (interactive "P")
7347   (let ((win (selected-window)))
7348     (select-window (gnus-get-buffer-window gnus-article-buffer t))
7349     (gnus-article-prev-page)
7350     (select-window win)))
7351
7352 (defvar gnus-decode-header-methods
7353   '(mail-decode-encoded-word-region)
7354   "List of methods used to decode headers.
7355
7356 This variable is a list of FUNCTION or (REGEXP . FUNCTION).  If item
7357 is FUNCTION, FUNCTION will be apply to all newsgroups.  If item is a
7358 \(REGEXP . FUNCTION), FUNCTION will be only apply to the newsgroups
7359 whose names match REGEXP.
7360
7361 For example:
7362 \((\"chinese\" . gnus-decode-encoded-word-region-by-guess)
7363  mail-decode-encoded-word-region
7364  (\"chinese\" . rfc1843-decode-region))
7365 ")
7366
7367 (defvar gnus-decode-header-methods-cache nil)
7368
7369 (defun gnus-multi-decode-header (start end)
7370   "Apply the functions from `gnus-encoded-word-methods' that match."
7371   (unless (and gnus-decode-header-methods-cache
7372                (eq gnus-newsgroup-name
7373                    (car gnus-decode-header-methods-cache)))
7374     (setq gnus-decode-header-methods-cache (list gnus-newsgroup-name))
7375     (mapcar (lambda (x)
7376               (if (symbolp x)
7377                   (nconc gnus-decode-header-methods-cache (list x))
7378                 (if (and gnus-newsgroup-name
7379                          (string-match (car x) gnus-newsgroup-name))
7380                     (nconc gnus-decode-header-methods-cache
7381                            (list (cdr x))))))
7382             gnus-decode-header-methods))
7383   (let ((xlist gnus-decode-header-methods-cache))
7384     (pop xlist)
7385     (save-restriction
7386       (narrow-to-region start end)
7387       (while xlist
7388         (funcall (pop xlist) (point-min) (point-max))))))
7389
7390 ;;;
7391 ;;; Treatment top-level handling.
7392 ;;;
7393
7394 (defun gnus-treat-article (condition &optional part-number total-parts type)
7395   (let ((length (- (point-max) (point-min)))
7396         (alist gnus-treatment-function-alist)
7397         (article-goto-body-goes-to-point-min-p t)
7398         (treated-type
7399          (or (not type)
7400              (catch 'found
7401                (let ((list gnus-article-treat-types))
7402                  (while list
7403                    (when (string-match (pop list) type)
7404                      (throw 'found t)))))))
7405         (highlightp (gnus-visual-p 'article-highlight 'highlight))
7406         (entity (static-unless (featurep 'xemacs)
7407                   (when (eq 'head condition)
7408                     (get-text-property (point-min) 'mime-view-entity))))
7409         val elem buttonized)
7410     (gnus-run-hooks 'gnus-part-display-hook)
7411     (unless gnus-inhibit-treatment
7412       (dolist (elem alist)
7413         (setq val
7414               (save-excursion
7415                 (when (gnus-buffer-live-p gnus-summary-buffer)
7416                   (set-buffer gnus-summary-buffer))
7417                 (symbol-value (car elem))))
7418         (when (and (or (consp val)
7419                        treated-type)
7420                    (gnus-treat-predicate val)
7421                    (or (not (get (car elem) 'highlight))
7422                        highlightp))
7423           (when (and (not buttonized)
7424                      (memq (car elem)
7425                            '(gnus-treat-hide-signature
7426                              gnus-treat-highlight-signature)))
7427             (gnus-article-buttonize-signature)
7428             (setq buttonized t))
7429           (save-restriction
7430             (funcall (cadr elem)))))
7431       ;; FSF Emacsen does not inherit the existing text properties
7432       ;; in the new text, so we should do it for `mime-view-entity'.
7433       (static-unless (featurep 'xemacs)
7434         (when entity
7435           (put-text-property (point-min) (point-max)
7436                              'mime-view-entity entity))))))
7437
7438 ;; Dynamic variables.
7439 (eval-when-compile
7440   (defvar part-number)
7441   (defvar total-parts)
7442   (defvar type)
7443   (defvar condition)
7444   (defvar length))
7445
7446 (defun gnus-treat-predicate (val)
7447   (cond
7448    ((null val)
7449     nil)
7450    ((and (listp val)
7451          (stringp (car val)))
7452     (apply 'gnus-or (mapcar `(lambda (s)
7453                                (string-match s ,(or gnus-newsgroup-name "")))
7454                             val)))
7455    ((listp val)
7456     (let ((pred (pop val)))
7457       (cond
7458        ((eq pred 'or)
7459         (apply 'gnus-or (mapcar 'gnus-treat-predicate val)))
7460        ((eq pred 'and)
7461         (apply 'gnus-and (mapcar 'gnus-treat-predicate val)))
7462        ((eq pred 'not)
7463         (not (gnus-treat-predicate (car val))))
7464        ((eq pred 'typep)
7465         (equal (car val) type))
7466        (t
7467         (error "%S is not a valid predicate" pred)))))
7468    ((eq val 'mime)
7469     gnus-show-mime)
7470    (condition
7471     (eq condition val))
7472    ((eq val t)
7473     t)
7474    ((eq val 'head)
7475     nil)
7476    ((eq val 'last)
7477     (eq part-number total-parts))
7478    ((numberp val)
7479     (< length val))
7480    (t
7481     (error "%S is not a valid value" val))))
7482
7483 (defun gnus-article-encrypt-body (protocol &optional n)
7484   "Encrypt the article body."
7485   (interactive
7486    (list
7487     (or gnus-article-encrypt-protocol
7488         (completing-read "Encrypt protocol: "
7489                          gnus-article-encrypt-protocol-alist
7490                          nil t))
7491     current-prefix-arg))
7492   (let ((func (cdr (assoc protocol gnus-article-encrypt-protocol-alist))))
7493     (unless func
7494       (error (format "Can't find the encrypt protocol %s" protocol)))
7495     (if (member gnus-newsgroup-name '("nndraft:delayed"
7496                                       "nndraft:drafts"
7497                                       "nndraft:queue"))
7498         (error "Can't encrypt the article in group %s"
7499                gnus-newsgroup-name))
7500     (gnus-summary-iterate n
7501       (save-excursion
7502         (set-buffer gnus-summary-buffer)
7503         (let ((mail-parse-charset gnus-newsgroup-charset)
7504               (mail-parse-ignored-charsets gnus-newsgroup-ignored-charsets)
7505               (summary-buffer gnus-summary-buffer)
7506               references point)
7507           (gnus-set-global-variables)
7508           (when (gnus-group-read-only-p)
7509             (error "The current newsgroup does not support article encrypt"))
7510           (gnus-summary-show-article t)
7511           (setq references
7512                 (or (mail-header-references gnus-current-headers) ""))
7513           (set-buffer gnus-article-buffer)
7514           (let* ((buffer-read-only nil)
7515                  (headers
7516                   (mapcar (lambda (field)
7517                             (and (save-restriction
7518                                    (message-narrow-to-head)
7519                                    (goto-char (point-min))
7520                                    (search-forward field nil t))
7521                                  (prog2
7522                                      (message-narrow-to-field)
7523                                      (buffer-string)
7524                                    (delete-region (point-min) (point-max))
7525                                    (widen))))
7526                           '("Content-Type:" "Content-Transfer-Encoding:"
7527                             "Content-Disposition:"))))
7528             (message-narrow-to-head)
7529             (message-remove-header "MIME-Version")
7530             (goto-char (point-max))
7531             (setq point (point))
7532             (insert (apply 'concat headers))
7533             (widen)
7534             (narrow-to-region point (point-max))
7535             (let ((message-options message-options))
7536               (message-options-set 'message-sender user-mail-address)
7537               (message-options-set 'message-recipients user-mail-address)
7538               (message-options-set 'message-sign-encrypt 'not)
7539               (funcall func))
7540             (goto-char (point-min))
7541             (insert "MIME-Version: 1.0\n")
7542             (widen)
7543             (gnus-summary-edit-article-done
7544              references nil summary-buffer t))
7545           (when gnus-keep-backlog
7546             (gnus-backlog-remove-article
7547              (car gnus-article-current) (cdr gnus-article-current)))
7548           (save-excursion
7549             (when (get-buffer gnus-original-article-buffer)
7550               (set-buffer gnus-original-article-buffer)
7551               (setq gnus-original-article nil)))
7552           (when gnus-use-cache
7553             (gnus-cache-update-article
7554              (car gnus-article-current) (cdr gnus-article-current))))))))
7555
7556 (defvar gnus-mime-security-button-line-format "%{%([[%t:%i]%D]%)%}\n"
7557   "The following specs can be used:
7558 %t  The security MIME type
7559 %i  Additional info
7560 %d  Details
7561 %D  Details if button is pressed")
7562
7563 (defvar gnus-mime-security-button-end-line-format "%{%([[End of %t]%D]%)%}\n"
7564   "The following specs can be used:
7565 %t  The security MIME type
7566 %i  Additional info
7567 %d  Details
7568 %D  Details if button is pressed")
7569
7570 (defvar gnus-mime-security-button-line-format-alist
7571   '((?t gnus-tmp-type ?s)
7572     (?i gnus-tmp-info ?s)
7573     (?d gnus-tmp-details ?s)
7574     (?D gnus-tmp-pressed-details ?s)))
7575
7576 (defvar gnus-mime-security-button-map
7577   (let ((map (make-sparse-keymap)))
7578     (define-key map gnus-mouse-2 'gnus-article-push-button)
7579     (define-key map "\r" 'gnus-article-press-button)
7580     map))
7581
7582 (defvar gnus-mime-security-details-buffer nil)
7583
7584 (defvar gnus-mime-security-button-pressed nil)
7585
7586 (defvar gnus-mime-security-show-details-inline t
7587   "If non-nil, show details in the article buffer.")
7588
7589 (defun gnus-mime-security-verify-or-decrypt (handle)
7590   (mm-remove-parts (cdr handle))
7591   (let ((region (mm-handle-multipart-ctl-parameter handle 'gnus-region))
7592         point buffer-read-only)
7593     (if region
7594         (goto-char (car region)))
7595     (save-restriction
7596       (narrow-to-region (point) (point))
7597       (with-current-buffer (mm-handle-multipart-original-buffer handle)
7598         (let* ((mm-verify-option 'known)
7599                (mm-decrypt-option 'known)
7600                (nparts (mm-possibly-verify-or-decrypt (cdr handle) handle)))
7601           (unless (eq nparts (cdr handle))
7602             (mm-destroy-parts (cdr handle))
7603             (setcdr handle nparts))))
7604       (setq point (point))
7605       (gnus-mime-display-security handle)
7606       (goto-char (point-max)))
7607     (when region
7608       (delete-region (point) (cdr region))
7609       (set-marker (car region) nil)
7610       (set-marker (cdr region) nil))
7611     (goto-char point)))
7612
7613 (defun gnus-mime-security-show-details (handle)
7614   (let ((details (mm-handle-multipart-ctl-parameter handle 'gnus-details)))
7615     (if (not details)
7616         (gnus-message 5 "No details.")
7617       (if gnus-mime-security-show-details-inline
7618           (let ((gnus-mime-security-button-pressed
7619                  (not (get-text-property (point) 'gnus-mime-details)))
7620                 (gnus-mime-security-button-line-format
7621                  (get-text-property (point) 'gnus-line-format))
7622                 buffer-read-only)
7623             (forward-char -1)
7624             (while (eq (get-text-property (point) 'gnus-line-format)
7625                        gnus-mime-security-button-line-format)
7626               (forward-char -1))
7627             (forward-char)
7628             (save-restriction
7629               (narrow-to-region (point) (point))
7630               (gnus-insert-mime-security-button handle))
7631             (delete-region (point)
7632                            (or (text-property-not-all
7633                                 (point) (point-max)
7634                                 'gnus-line-format
7635                                 gnus-mime-security-button-line-format)
7636                                (point-max))))
7637         ;; Not inlined.
7638         (if (gnus-buffer-live-p gnus-mime-security-details-buffer)
7639             (with-current-buffer gnus-mime-security-details-buffer
7640               (erase-buffer)
7641               t)
7642           (setq gnus-mime-security-details-buffer
7643                 (gnus-get-buffer-create "*MIME Security Details*")))
7644         (with-current-buffer gnus-mime-security-details-buffer
7645           (insert details)
7646           (goto-char (point-min)))
7647         (pop-to-buffer gnus-mime-security-details-buffer)))))
7648
7649 (defun gnus-mime-security-press-button (handle)
7650   (save-excursion
7651     (if (mm-handle-multipart-ctl-parameter handle 'gnus-info)
7652         (gnus-mime-security-show-details handle)
7653       (gnus-mime-security-verify-or-decrypt handle))))
7654
7655 (defun gnus-insert-mime-security-button (handle &optional displayed)
7656   (let* ((protocol (mm-handle-multipart-ctl-parameter handle 'protocol))
7657          (gnus-tmp-type
7658           (concat
7659            (or (nth 2 (assoc protocol mm-verify-function-alist))
7660                (nth 2 (assoc protocol mm-decrypt-function-alist))
7661                "Unknown")
7662            (if (equal (car handle) "multipart/signed")
7663                " Signed" " Encrypted")
7664            " Part"))
7665          (gnus-tmp-info
7666           (or (mm-handle-multipart-ctl-parameter handle 'gnus-info)
7667               "Undecided"))
7668          (gnus-tmp-details
7669           (mm-handle-multipart-ctl-parameter handle 'gnus-details))
7670          gnus-tmp-pressed-details
7671          b e)
7672     (setq gnus-tmp-details
7673           (if gnus-tmp-details
7674               (concat "\n" gnus-tmp-details)
7675             ""))
7676     (setq gnus-tmp-pressed-details
7677           (if gnus-mime-security-button-pressed gnus-tmp-details ""))
7678     (unless (bolp)
7679       (insert "\n"))
7680     (setq b (point))
7681     (gnus-eval-format
7682      gnus-mime-security-button-line-format
7683      gnus-mime-security-button-line-format-alist
7684      `(keymap ,gnus-mime-security-button-map
7685          gnus-callback gnus-mime-security-press-button
7686          gnus-line-format ,gnus-mime-security-button-line-format
7687          gnus-mime-details ,gnus-mime-security-button-pressed
7688          article-type annotation
7689          gnus-data ,handle))
7690     (setq e (if (bolp)
7691                 ;; Exclude a newline.
7692                 (1- (point))
7693               (point)))
7694     (widget-convert-button
7695      'link b e
7696      :mime-handle handle
7697      :action 'gnus-widget-press-button
7698      :button-keymap gnus-mime-security-button-map
7699      :help-echo
7700      (lambda (widget/window &optional overlay pos)
7701        ;; Needed to properly clear the message due to a bug in
7702        ;; wid-edit (XEmacs only).
7703        (when (boundp 'help-echo-owns-message)
7704          (setq help-echo-owns-message t))
7705        (format
7706         "%S: show detail"
7707         (aref gnus-mouse-2 0))))))
7708
7709 (defun gnus-mime-display-security (handle)
7710   (save-restriction
7711     (narrow-to-region (point) (point))
7712     (unless (gnus-unbuttonized-mime-type-p (car handle))
7713       (gnus-insert-mime-security-button handle))
7714     (gnus-mime-display-mixed (cdr handle))
7715     (unless (bolp)
7716       (insert "\n"))
7717     (unless (gnus-unbuttonized-mime-type-p (car handle))
7718       (let ((gnus-mime-security-button-line-format
7719              gnus-mime-security-button-end-line-format))
7720         (gnus-insert-mime-security-button handle)))
7721     (mm-set-handle-multipart-parameter
7722      handle 'gnus-region
7723      (cons (set-marker (make-marker) (point-min))
7724            (set-marker (make-marker) (point-max))))))
7725
7726
7727 ;;; @ for mime-view
7728 ;;;
7729
7730 (defun gnus-article-header-presentation-method (entity situation)
7731   (mime-insert-header entity)
7732   (article-decode-group-name))
7733
7734 (set-alist 'mime-header-presentation-method-alist
7735            'gnus-original-article-mode
7736            #'gnus-article-header-presentation-method)
7737
7738 (defun gnus-mime-preview-quitting-method ()
7739   (mime-preview-kill-buffer)
7740   (delete-other-windows)
7741   (gnus-article-show-summary)
7742   (gnus-summary-select-article gnus-show-all-headers t))
7743
7744 (set-alist 'mime-preview-quitting-method-alist
7745            'gnus-original-article-mode #'gnus-mime-preview-quitting-method)
7746
7747 (set-alist 'mime-preview-following-method-alist
7748            'gnus-original-article-mode #'gnus-following-method)
7749
7750 (set-alist 'mime-preview-over-to-previous-method-alist
7751            'gnus-original-article-mode
7752            (lambda ()
7753              (if (> (point-min) 1)
7754                  (gnus-article-prev-page)
7755                (gnus-article-read-summary-keys
7756                 nil (gnus-character-to-event ?P)))))
7757
7758 (set-alist 'mime-preview-over-to-next-method-alist
7759            'gnus-original-article-mode'
7760            (lambda ()
7761              (if (< (point-max) (buffer-size))
7762                  (gnus-article-next-page)
7763                (gnus-article-read-summary-keys
7764                 nil (gnus-character-to-event ?N)))))
7765
7766
7767 ;;; @ end
7768 ;;;
7769
7770 (gnus-ems-redefine)
7771
7772 (provide 'gnus-art)
7773
7774 (run-hooks 'gnus-art-load-hook)
7775
7776 ;;; gnus-art.el ends here