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

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