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

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