cgit.sxemacs.org Git - gnus/blob - lisp/gnus-art.el

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