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

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