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
2615                       (concat (mm-make-temp-file
2616                                ;; Do we need to care for 8.3 filenames?
2617                                (format "mm-") nil)  ".html")))
2618                  (mm-save-part-to-file handle tmp-file)
2619                  (browse-url tmp-file)
2620                  (setq showed t)))
2621               ;; If multipart, recurse
2622               ((and (stringp (car handle))
2623                     (string-match "^multipart/" (car handle))
2624                     (setq showed
2625                           (or showed
2626                               (gnus-article-browse-html-parts handle))))))))
2627     showed))
2628
2629 ;; TODO: Key binding; Remove temp files.
2630 (defun gnus-article-browse-html-article ()
2631   "View \"text/html\" parts of the current article with a WWW browser."
2632   (interactive)
2633   (save-window-excursion
2634     ;; Open raw article and select the buffer
2635     (gnus-summary-show-article t)
2636     (gnus-summary-select-article-buffer)
2637     (let ((parts (mm-dissect-buffer t t)))
2638       ;; If singlepart, enforce a list.
2639       (when (and (bufferp (car parts))
2640                  (stringp (car (mm-handle-type parts))))
2641         (setq parts (list parts)))
2642       ;; Process the list
2643       (unless (gnus-article-browse-html-parts parts)
2644         (gnus-error 3 "Mail doesn't contain a \"text/html\" part!"))
2645       (gnus-summary-show-article))))
2646
2647 (defun article-hide-list-identifiers ()
2648   "Remove list identifies from the Subject header.
2649 The `gnus-list-identifiers' variable specifies what to do."
2650   (interactive)
2651   (let ((inhibit-point-motion-hooks t)
2652         (regexp (if (consp gnus-list-identifiers)
2653                     (mapconcat 'identity gnus-list-identifiers " *\\|")
2654                   gnus-list-identifiers))
2655         (inhibit-read-only t))
2656     (when regexp
2657       (save-excursion
2658         (save-restriction
2659           (article-narrow-to-head)
2660           (goto-char (point-min))
2661           (while (re-search-forward
2662                   (concat "^Subject: +\\(R[Ee]: +\\)*\\(" regexp " *\\)")
2663                   nil t)
2664             (delete-region (match-beginning 2) (match-end 0))
2665             (beginning-of-line))
2666           (when (re-search-forward
2667                  "^Subject: +\\(\\(R[Ee]: +\\)+\\)R[Ee]: +" nil t)
2668             (delete-region (match-beginning 1) (match-end 1))))))))
2669
2670 (defun article-hide-pem (&optional arg)
2671   "Toggle hiding of any PEM headers and signatures in the current article.
2672 If given a negative prefix, always show; if given a positive prefix,
2673 always hide."
2674   (interactive (gnus-article-hidden-arg))
2675   (unless (gnus-article-check-hidden-text 'pem arg)
2676     (save-excursion
2677       (let ((inhibit-read-only t) end)
2678         (goto-char (point-min))
2679         ;; Hide the horrendously ugly "header".
2680         (when (and (search-forward
2681                     "\n-----BEGIN PRIVACY-ENHANCED MESSAGE-----\n"
2682                     nil t)
2683                    (setq end (1+ (match-beginning 0))))
2684           (gnus-add-wash-type 'pem)
2685           (gnus-article-hide-text-type
2686            end
2687            (if (search-forward "\n\n" nil t)
2688                (match-end 0)
2689              (point-max))
2690            'pem)
2691           ;; Hide the trailer as well
2692           (when (search-forward "\n-----END PRIVACY-ENHANCED MESSAGE-----\n"
2693                                 nil t)
2694             (gnus-article-hide-text-type
2695              (match-beginning 0) (match-end 0) 'pem)))))))
2696
2697 (defun article-strip-banner ()
2698   "Strip the banners specified by the `banner' group parameter and by
2699 `gnus-article-address-banner-alist'."
2700   (interactive)
2701   (save-excursion
2702     (save-restriction
2703       (let ((inhibit-point-motion-hooks t))
2704         (when (gnus-parameter-banner gnus-newsgroup-name)
2705           (article-really-strip-banner
2706            (gnus-parameter-banner gnus-newsgroup-name)))
2707         (when gnus-article-address-banner-alist
2708           ;; It is necessary to encode from fields before checking,
2709           ;; because `mail-header-parse-addresses' does not work
2710           ;; (reliably) on decoded headers.  And more, it is
2711           ;; impossible to use `gnus-fetch-original-field' here,
2712           ;; because `article-strip-banner' may be called in draft
2713           ;; buffers to preview them.
2714           (let ((from (save-restriction
2715                         (widen)
2716                         (article-narrow-to-head)
2717                         (mail-fetch-field "from"))))
2718             (when (and from
2719                        (setq from
2720                              (caar (mail-header-parse-addresses
2721                                     (mail-encode-encoded-word-string from)))))
2722               (catch 'found
2723                 (dolist (pair gnus-article-address-banner-alist)
2724                   (when (string-match (car pair) from)
2725                     (throw 'found
2726                            (article-really-strip-banner (cdr pair)))))))))))))
2727
2728 (defun article-really-strip-banner (banner)
2729   "Strip the banner specified by the argument."
2730   (save-excursion
2731     (save-restriction
2732       (let ((inhibit-point-motion-hooks t)
2733             (gnus-signature-limit nil)
2734             (inhibit-read-only t))
2735         (article-goto-body)
2736         (cond
2737          ((eq banner 'signature)
2738           (when (gnus-article-narrow-to-signature)
2739             (widen)
2740             (forward-line -1)
2741             (delete-region (point) (point-max))))
2742          ((symbolp banner)
2743           (if (setq banner (cdr (assq banner gnus-article-banner-alist)))
2744               (while (re-search-forward banner nil t)
2745                 (delete-region (match-beginning 0) (match-end 0)))))
2746          ((stringp banner)
2747           (while (re-search-forward banner nil t)
2748             (delete-region (match-beginning 0) (match-end 0)))))))))
2749
2750 (defun article-babel ()
2751   "Translate article using an online translation service."
2752   (interactive)
2753   (require 'babel)
2754   (gnus-with-article-buffer
2755     (when (article-goto-body)
2756       (let* ((start (point))
2757              (end (point-max))
2758              (orig (buffer-substring start end))
2759              (trans (babel-as-string orig)))
2760         (save-restriction
2761           (narrow-to-region start end)
2762           (delete-region start end)
2763           (insert trans))))))
2764
2765 (defun article-hide-signature (&optional arg)
2766   "Hide the signature in the current article.
2767 If given a negative prefix, always show; if given a positive prefix,
2768 always hide."
2769   (interactive (gnus-article-hidden-arg))
2770   (unless (gnus-article-check-hidden-text 'signature arg)
2771     (save-excursion
2772       (save-restriction
2773         (let ((inhibit-read-only t))
2774           (when (gnus-article-narrow-to-signature)
2775             (gnus-article-hide-text-type
2776              (point-min) (point-max) 'signature))))))
2777   (gnus-set-mode-line 'article))
2778
2779 (defun article-strip-headers-in-body ()
2780   "Strip offensive headers from bodies."
2781   (interactive)
2782   (save-excursion
2783     (article-goto-body)
2784     (let ((case-fold-search t))
2785       (when (looking-at "x-no-archive:")
2786         (gnus-delete-line)))))
2787
2788 (defun article-strip-leading-blank-lines ()
2789   "Remove all blank lines from the beginning of the article."
2790   (interactive)
2791   (save-excursion
2792     (let ((inhibit-point-motion-hooks t)
2793           (inhibit-read-only t))
2794       (when (article-goto-body)
2795         (while (and (not (eobp))
2796                     (looking-at "[ \t]*$"))
2797           (gnus-delete-line))))))
2798
2799 (defun article-narrow-to-head ()
2800   "Narrow the buffer to the head of the message.
2801 Point is left at the beginning of the narrowed-to region."
2802   (narrow-to-region
2803    (goto-char (point-min))
2804    (if (search-forward "\n\n" nil 1)
2805        (1- (point))
2806      (point-max)))
2807   (goto-char (point-min)))
2808
2809 (defun article-goto-body ()
2810   "Place point at the start of the body."
2811   (goto-char (point-min))
2812   (cond
2813    ;; This variable is only bound when dealing with separate
2814    ;; MIME body parts.
2815    (article-goto-body-goes-to-point-min-p
2816     t)
2817    ((search-forward "\n\n" nil t)
2818     t)
2819    (t
2820     (goto-char (point-max))
2821     nil)))
2822
2823 (defun article-strip-multiple-blank-lines ()
2824   "Replace consecutive blank lines with one empty line."
2825   (interactive)
2826   (save-excursion
2827     (let ((inhibit-point-motion-hooks t)
2828           (inhibit-read-only t))
2829       ;; First make all blank lines empty.
2830       (article-goto-body)
2831       (while (re-search-forward "^[ \t]+$" nil t)
2832         (unless (gnus-annotation-in-region-p
2833                  (match-beginning 0) (match-end 0))
2834           (replace-match "" nil t)))
2835       ;; Then replace multiple empty lines with a single empty line.
2836       (article-goto-body)
2837       (while (re-search-forward "\n\n\\(\n+\\)" nil t)
2838         (unless (gnus-annotation-in-region-p
2839                  (match-beginning 0) (match-end 0))
2840           (delete-region (match-beginning 1) (match-end 1)))))))
2841
2842 (defun article-strip-leading-space ()
2843   "Remove all white space from the beginning of the lines in the article."
2844   (interactive)
2845   (save-excursion
2846     (let ((inhibit-point-motion-hooks t)
2847           (inhibit-read-only t))
2848       (article-goto-body)
2849       (while (re-search-forward "^[ \t]+" nil t)
2850         (replace-match "" t t)))))
2851
2852 (defun article-strip-trailing-space ()
2853   "Remove all white space from the end of the lines in the article."
2854   (interactive)
2855   (save-excursion
2856     (let ((inhibit-point-motion-hooks t)
2857           (inhibit-read-only t))
2858       (article-goto-body)
2859       (while (re-search-forward "[ \t]+$" nil t)
2860         (replace-match "" t t)))))
2861
2862 (defun article-strip-blank-lines ()
2863   "Strip leading, trailing and multiple blank lines."
2864   (interactive)
2865   (article-strip-leading-blank-lines)
2866   (article-remove-trailing-blank-lines)
2867   (article-strip-multiple-blank-lines))
2868
2869 (defun article-strip-all-blank-lines ()
2870   "Strip all blank lines."
2871   (interactive)
2872   (save-excursion
2873     (let ((inhibit-point-motion-hooks t)
2874           (inhibit-read-only t))
2875       (article-goto-body)
2876       (while (re-search-forward "^[ \t]*\n" nil t)
2877         (replace-match "" t t)))))
2878
2879 (defun gnus-article-narrow-to-signature ()
2880   "Narrow to the signature; return t if a signature is found, else nil."
2881   (let ((inhibit-point-motion-hooks t))
2882     (when (gnus-article-search-signature)
2883       (forward-line 1)
2884       ;; Check whether we have some limits to what we consider
2885       ;; to be a signature.
2886       (let ((limits (if (listp gnus-signature-limit) gnus-signature-limit
2887                       (list gnus-signature-limit)))
2888             limit limited)
2889         (while (setq limit (pop limits))
2890           (if (or (and (integerp limit)
2891                        (< (- (point-max) (point)) limit))
2892                   (and (floatp limit)
2893                        (< (count-lines (point) (point-max)) limit))
2894                   (and (functionp limit)
2895                        (funcall limit))
2896                   (and (stringp limit)
2897                        (not (re-search-forward limit nil t))))
2898               ()                        ; This limit did not succeed.
2899             (setq limited t
2900                   limits nil)))
2901         (unless limited
2902           (narrow-to-region (point) (point-max))
2903           t)))))
2904
2905 (defun gnus-article-search-signature ()
2906   "Search the current buffer for the signature separator.
2907 Put point at the beginning of the signature separator."
2908   (let ((cur (point)))
2909     (goto-char (point-max))
2910     (if (if (stringp gnus-signature-separator)
2911             (re-search-backward gnus-signature-separator nil t)
2912           (let ((seps gnus-signature-separator))
2913             (while (and seps
2914                         (not (re-search-backward (car seps) nil t)))
2915               (pop seps))
2916             seps))
2917         t
2918       (goto-char cur)
2919       nil)))
2920
2921 (defun gnus-article-hidden-arg ()
2922   "Return the current prefix arg as a number, or 0 if no prefix."
2923   (list (if current-prefix-arg
2924             (prefix-numeric-value current-prefix-arg)
2925           0)))
2926
2927 (defun gnus-article-check-hidden-text (type arg)
2928   "Return nil if hiding is necessary.
2929 Arg can be nil or a number.  nil and positive means hide, negative
2930 means show, 0 means toggle."
2931   (save-excursion
2932     (save-restriction
2933       (let ((hide (gnus-article-hidden-text-p type)))
2934         (cond
2935          ((or (null arg)
2936               (> arg 0))
2937           nil)
2938          ((< arg 0)
2939           (gnus-article-show-hidden-text type)
2940           t)
2941          (t
2942           (if (eq hide 'hidden)
2943               (progn
2944                 (gnus-article-show-hidden-text type)
2945                 t)
2946             nil)))))))
2947
2948 (defun gnus-article-hidden-text-p (type)
2949   "Say whether the current buffer contains hidden text of type TYPE."
2950   (let ((pos (text-property-any (point-min) (point-max) 'article-type type)))
2951     (while (and pos
2952                 (not (get-text-property pos 'invisible))
2953                 (not (get-text-property pos 'dummy-invisible)))
2954       (setq pos
2955             (text-property-any (1+ pos) (point-max) 'article-type type)))
2956     (if pos
2957         'hidden
2958       nil)))
2959
2960 (defun gnus-article-show-hidden-text (type &optional dummy)
2961   "Show all hidden text of type TYPE.
2962 Originally it is hide instead of DUMMY."
2963   (let ((inhibit-read-only t)
2964         (inhibit-point-motion-hooks t))
2965     (gnus-remove-text-properties-when
2966      'article-type type
2967      (point-min) (point-max)
2968      (cons 'article-type (cons type
2969                                gnus-hidden-properties)))
2970     (gnus-delete-wash-type type)))
2971
2972 (defconst article-time-units
2973   `((year . ,(* 365.25 24 60 60))
2974     (week . ,(* 7 24 60 60))
2975     (day . ,(* 24 60 60))
2976     (hour . ,(* 60 60))
2977     (minute . 60)
2978     (second . 1))
2979   "Mapping from time units to seconds.")
2980
2981 (defun gnus-article-forward-header ()
2982   "Move point to the start of the next header.
2983 If the current header is a continuation header, this can be several
2984 lines forward."
2985   (let ((ended nil))
2986     (while (not ended)
2987       (forward-line 1)
2988       (if (looking-at "[ \t]+[^ \t]")
2989           (forward-line 1)
2990         (setq ended t)))))
2991
2992 (defun article-date-ut (&optional type highlight)
2993   "Convert DATE date to universal time in the current article.
2994 If TYPE is `local', convert to local time; if it is `lapsed', output
2995 how much time has lapsed since DATE.  For `lapsed', the value of
2996 `gnus-article-date-lapsed-new-header' says whether the \"X-Sent:\" header
2997 should replace the \"Date:\" one, or should be added below it."
2998   (interactive (list 'ut t))
2999   (let* ((tdate-regexp "^Date:[ \t]\\|^X-Sent:[ \t]")
3000          (date-regexp (cond ((not gnus-article-date-lapsed-new-header)
3001                              tdate-regexp)
3002                             ((eq type 'lapsed)
3003                              "^X-Sent:[ \t]")
3004                             (article-lapsed-timer
3005                              "^Date:[ \t]")
3006                             (t
3007                              tdate-regexp)))
3008          (case-fold-search t)
3009          (inhibit-read-only t)
3010          (inhibit-point-motion-hooks t)
3011          pos date bface eface)
3012     (save-excursion
3013       (save-restriction
3014         (widen)
3015         (goto-char (point-min))
3016         (while (or (setq date (get-text-property (setq pos (point))
3017                                                  'original-date))
3018                    (when (setq pos (next-single-property-change
3019                                     (point) 'original-date))
3020                      (setq date (get-text-property pos 'original-date))
3021                      t))
3022           (narrow-to-region pos (or (text-property-any pos (point-max)
3023                                                        'original-date nil)
3024                                     (point-max)))
3025           (goto-char (point-min))
3026           (when (re-search-forward tdate-regexp nil t)
3027             (setq bface (get-text-property (point-at-bol) 'face)
3028                   eface (get-text-property (1- (point-at-eol)) 'face)))
3029           (goto-char (point-min))
3030           (setq pos nil)
3031           ;; Delete any old Date headers.
3032           (while (re-search-forward date-regexp nil t)
3033             (if pos
3034                 (delete-region (point-at-bol) (progn
3035                                                 (gnus-article-forward-header)
3036                                                 (point)))
3037               (delete-region (point-at-bol) (progn
3038                                               (gnus-article-forward-header)
3039                                               (forward-char -1)
3040                                               (point)))
3041               (setq pos (point))))
3042           (when (and (not pos)
3043                      (re-search-forward tdate-regexp nil t))
3044             (forward-line 1))
3045           (gnus-goto-char pos)
3046           (insert (article-make-date-line date (or type 'ut)))
3047           (unless pos
3048             (insert "\n")
3049             (forward-line -1))
3050           ;; Do highlighting.
3051           (beginning-of-line)
3052           (when (looking-at "\\([^:]+\\): *\\(.*\\)$")
3053             (put-text-property (match-beginning 1) (1+ (match-end 1))
3054                                'face bface)
3055             (put-text-property (match-beginning 2) (match-end 2)
3056                                'face eface))
3057           (put-text-property (point-min) (1- (point-max)) 'original-date date)
3058           (goto-char (point-max))
3059           (widen))))))
3060
3061 (defun article-make-date-line (date type)
3062   "Return a DATE line of TYPE."
3063   (unless (memq type '(local ut original user iso8601 lapsed english))
3064     (error "Unknown conversion type: %s" type))
3065   (condition-case ()
3066       (let ((time (date-to-time date)))
3067         (cond
3068          ;; Convert to the local timezone.
3069          ((eq type 'local)
3070           (concat "Date: " (message-make-date time)))
3071          ;; Convert to Universal Time.
3072          ((eq type 'ut)
3073           (concat "Date: "
3074                   (substring
3075                    (message-make-date
3076                     (let* ((e (parse-time-string date))
3077                            (tm (apply 'encode-time e))
3078                            (ms (car tm))
3079                            (ls (- (cadr tm) (car (current-time-zone time)))))
3080                       (cond ((< ls 0) (list (1- ms) (+ ls 65536)))
3081                             ((> ls 65535) (list (1+ ms) (- ls 65536)))
3082                             (t (list ms ls)))))
3083                    0 -5)
3084                   "UT"))
3085          ;; Get the original date from the article.
3086          ((eq type 'original)
3087           (concat "Date: " (if (string-match "\n+$" date)
3088                                (substring date 0 (match-beginning 0))
3089                              date)))
3090          ;; Let the user define the format.
3091          ((eq type 'user)
3092           (let ((format (or (condition-case nil
3093                                 (with-current-buffer gnus-summary-buffer
3094                                   gnus-article-time-format)
3095                               (error nil))
3096                             gnus-article-time-format)))
3097             (if (functionp format)
3098                 (funcall format time)
3099               (concat "Date: " (format-time-string format time)))))
3100          ;; ISO 8601.
3101          ((eq type 'iso8601)
3102           (let ((tz (car (current-time-zone time))))
3103             (concat
3104              "Date: "
3105              (format-time-string "%Y%m%dT%H%M%S" time)
3106              (format "%s%02d%02d"
3107                      (if (> tz 0) "+" "-") (/ (abs tz) 3600)
3108                      (/ (% (abs tz) 3600) 60)))))
3109          ;; Do an X-Sent lapsed format.
3110          ((eq type 'lapsed)
3111           ;; If the date is seriously mangled, the timezone functions are
3112           ;; liable to bug out, so we ignore all errors.
3113           (let* ((now (current-time))
3114                  (real-time (subtract-time now time))
3115                  (real-sec (and real-time
3116                                 (+ (* (float (car real-time)) 65536)
3117                                    (cadr real-time))))
3118                  (sec (and real-time (abs real-sec)))
3119                  num prev)
3120             (cond
3121              ((null real-time)
3122               "X-Sent: Unknown")
3123              ((zerop sec)
3124               "X-Sent: Now")
3125              (t
3126               (concat
3127                "X-Sent: "
3128                ;; This is a bit convoluted, but basically we go
3129                ;; through the time units for years, weeks, etc,
3130                ;; and divide things to see whether that results
3131                ;; in positive answers.
3132                (mapconcat
3133                 (lambda (unit)
3134                   (if (zerop (setq num (ffloor (/ sec (cdr unit)))))
3135                       ;; The (remaining) seconds are too few to
3136                       ;; be divided into this time unit.
3137                       ""
3138                     ;; It's big enough, so we output it.
3139                     (setq sec (- sec (* num (cdr unit))))
3140                     (prog1
3141                         (concat (if prev ", " "") (int-to-string
3142                                                    (floor num))
3143                                 " " (symbol-name (car unit))
3144                                 (if (> num 1) "s" ""))
3145                       (setq prev t))))
3146                 article-time-units "")
3147                ;; If dates are odd, then it might appear like the
3148                ;; article was sent in the future.
3149                (if (> real-sec 0)
3150                    " ago"
3151                  " in the future"))))))
3152          ;; Display the date in proper English
3153          ((eq type 'english)
3154           (let ((dtime (decode-time time)))
3155             (concat
3156              "Date: the "
3157              (number-to-string (nth 3 dtime))
3158              (let ((digit (% (nth 3 dtime) 10)))
3159                (cond
3160                 ((memq (nth 3 dtime) '(11 12 13)) "th")
3161                 ((= digit 1) "st")
3162                 ((= digit 2) "nd")
3163                 ((= digit 3) "rd")
3164                 (t "th")))
3165              " of "
3166              (nth (1- (nth 4 dtime)) gnus-english-month-names)
3167              " "
3168              (number-to-string (nth 5 dtime))
3169              " at "
3170              (format "%02d" (nth 2 dtime))
3171              ":"
3172              (format "%02d" (nth 1 dtime)))))))
3173     (error
3174      (format "Date: %s (from Gnus)" date))))
3175
3176 (defun article-date-local (&optional highlight)
3177   "Convert the current article date to the local timezone."
3178   (interactive (list t))
3179   (article-date-ut 'local highlight))
3180
3181 (defun article-date-english (&optional highlight)
3182   "Convert the current article date to something that is proper English."
3183   (interactive (list t))
3184   (article-date-ut 'english highlight))
3185
3186 (defun article-date-original (&optional highlight)
3187   "Convert the current article date to what it was originally.
3188 This is only useful if you have used some other date conversion
3189 function and want to see what the date was before converting."
3190   (interactive (list t))
3191   (article-date-ut 'original highlight))
3192
3193 (defun article-date-lapsed (&optional highlight)
3194   "Convert the current article date to time lapsed since it was sent."
3195   (interactive (list t))
3196   (article-date-ut 'lapsed highlight))
3197
3198 (defun article-update-date-lapsed ()
3199   "Function to be run from a timer to update the lapsed time line."
3200   (save-match-data
3201     (let (deactivate-mark)
3202       (save-excursion
3203         (ignore-errors
3204          (walk-windows
3205           (lambda (w)
3206             (set-buffer (window-buffer w))
3207             (when (eq major-mode 'gnus-article-mode)
3208               (let ((mark (point-marker)))
3209                 (goto-char (point-min))
3210                 (when (re-search-forward "^X-Sent:" nil t)
3211                   (article-date-lapsed t))
3212                 (goto-char (marker-position mark))
3213                 (move-marker mark nil))))
3214           nil 'visible))))))
3215
3216 (defun gnus-start-date-timer (&optional n)
3217   "Start a timer to update the X-Sent header in the article buffers.
3218 The numerical prefix says how frequently (in seconds) the function
3219 is to run."
3220   (interactive "p")
3221   (unless n
3222     (setq n 1))
3223   (gnus-stop-date-timer)
3224   (setq article-lapsed-timer
3225         (run-at-time 1 n 'article-update-date-lapsed)))
3226
3227 (defun gnus-stop-date-timer ()
3228   "Stop the X-Sent timer."
3229   (interactive)
3230   (when article-lapsed-timer
3231     (nnheader-cancel-timer article-lapsed-timer)
3232     (setq article-lapsed-timer nil)))
3233
3234 (defun article-date-user (&optional highlight)
3235   "Convert the current article date to the user-defined format.
3236 This format is defined by the `gnus-article-time-format' variable."
3237   (interactive (list t))
3238   (article-date-ut 'user highlight))
3239
3240 (defun article-date-iso8601 (&optional highlight)
3241   "Convert the current article date to ISO8601."
3242   (interactive (list t))
3243   (article-date-ut 'iso8601 highlight))
3244
3245 (defmacro gnus-article-save-original-date (&rest forms)
3246   "Save the original date as a text property and evaluate FORMS."
3247   `(let* ((case-fold-search t)
3248           (start (progn
3249                    (goto-char (point-min))
3250                    (when (and (re-search-forward "^date:[\t\n ]+" nil t)
3251                               (not (bolp)))
3252                      (match-end 0))))
3253           (date (when (and start
3254                            (re-search-forward "[\t ]*\n\\(?:[^\t ]\\|\\'\\)"
3255                                               nil t))
3256                   (buffer-substring-no-properties start
3257                                                   (match-beginning 0)))))
3258      (goto-char (point-max))
3259      (skip-chars-backward "\n")
3260      (put-text-property (point-min) (point) 'original-date date)
3261      ,@forms
3262      (goto-char (point-max))
3263      (skip-chars-backward "\n")
3264      (put-text-property (point-min) (point) 'original-date date)))
3265
3266 ;; (defun article-show-all ()
3267 ;;   "Show all hidden text in the article buffer."
3268 ;;   (interactive)
3269 ;;   (save-excursion
3270 ;;     (let ((inhibit-read-only t))
3271 ;;       (gnus-article-unhide-text (point-min) (point-max)))))
3272
3273 (defun article-remove-leading-whitespace ()
3274   "Remove excessive whitespace from all headers."
3275   (interactive)
3276   (save-excursion
3277     (save-restriction
3278       (let ((inhibit-read-only t))
3279         (article-narrow-to-head)
3280         (goto-char (point-min))
3281         (while (re-search-forward "^[^ :]+: \\([ \t]+\\)" nil t)
3282           (delete-region (match-beginning 1) (match-end 1)))))))
3283
3284 (defun article-emphasize (&optional arg)
3285   "Emphasize text according to `gnus-emphasis-alist'."
3286   (interactive (gnus-article-hidden-arg))
3287   (unless (gnus-article-check-hidden-text 'emphasis arg)
3288     (save-excursion
3289       (let ((alist (or
3290                     (condition-case nil
3291                         (with-current-buffer gnus-summary-buffer
3292                           gnus-article-emphasis-alist)
3293                       (error))
3294                     gnus-emphasis-alist))
3295             (inhibit-read-only t)
3296             (props (append '(article-type emphasis)
3297                            gnus-hidden-properties))
3298             regexp elem beg invisible visible face)
3299         (article-goto-body)
3300         (setq beg (point))
3301         (while (setq elem (pop alist))
3302           (goto-char beg)
3303           (setq regexp (car elem)
3304                 invisible (nth 1 elem)
3305                 visible (nth 2 elem)
3306                 face (nth 3 elem))
3307           (while (re-search-forward regexp nil t)
3308             (when (and (match-beginning visible) (match-beginning invisible))
3309               (gnus-article-hide-text
3310                (match-beginning invisible) (match-end invisible) props)
3311               (gnus-article-unhide-text-type
3312                (match-beginning visible) (match-end visible) 'emphasis)
3313               (gnus-put-overlay-excluding-newlines
3314                (match-beginning visible) (match-end visible) 'face face)
3315               (gnus-add-wash-type 'emphasis)
3316               (goto-char (match-end invisible)))))))))
3317
3318 (defun gnus-article-setup-highlight-words (&optional highlight-words)
3319   "Setup newsgroup emphasis alist."
3320   (unless gnus-article-emphasis-alist
3321     (let ((name (and gnus-newsgroup-name
3322                      (gnus-group-real-name gnus-newsgroup-name))))
3323       (make-local-variable 'gnus-article-emphasis-alist)
3324       (setq gnus-article-emphasis-alist
3325             (nconc
3326              (let ((alist gnus-group-highlight-words-alist) elem highlight)
3327                (while (setq elem (pop alist))
3328                  (when (and name (string-match (car elem) name))
3329                    (setq alist nil
3330                          highlight (copy-sequence (cdr elem)))))
3331                highlight)
3332              (copy-sequence highlight-words)
3333              (if gnus-newsgroup-name
3334                  (copy-sequence (gnus-group-find-parameter
3335                                  gnus-newsgroup-name 'highlight-words t)))
3336              gnus-emphasis-alist)))))
3337
3338 (eval-when-compile
3339   (defvar gnus-summary-article-menu)
3340   (defvar gnus-summary-post-menu))
3341
3342 ;;; Saving functions.
3343
3344 (defun gnus-article-save (save-buffer file &optional num)
3345   "Save the currently selected article."
3346   (unless gnus-save-all-headers
3347     ;; Remove headers according to `gnus-saved-headers'.
3348     (let ((gnus-visible-headers
3349            (or gnus-saved-headers gnus-visible-headers))
3350           (gnus-article-buffer save-buffer))
3351       (save-excursion
3352         (set-buffer save-buffer)
3353         (article-hide-headers 1 t))))
3354   (save-window-excursion
3355     (if (not gnus-default-article-saver)
3356         (error "No default saver is defined")
3357       ;; !!! Magic!  The saving functions all save
3358       ;; `gnus-save-article-buffer' (or so they think), but we
3359       ;; bind that variable to our save-buffer.
3360       (set-buffer gnus-article-buffer)
3361       (let* ((gnus-save-article-buffer save-buffer)
3362              (filename
3363               (cond
3364                ((not gnus-prompt-before-saving) 'default)
3365                ((eq gnus-prompt-before-saving 'always) nil)
3366                (t file)))
3367              (gnus-number-of-articles-to-be-saved
3368               (when (eq gnus-prompt-before-saving t)
3369                 num)))                  ; Magic
3370         (set-buffer gnus-article-current-summary)
3371         (funcall gnus-default-article-saver filename)))))
3372
3373 (defun gnus-read-save-file-name (prompt &optional filename
3374                                         function group headers variable)
3375   (let ((default-name
3376           (funcall function group headers (symbol-value variable)))
3377         result)
3378     (setq result
3379           (expand-file-name
3380            (cond
3381             ((eq filename 'default)
3382              default-name)
3383             ((eq filename t)
3384              default-name)
3385             (filename filename)
3386             (t
3387              (let* ((split-name (gnus-get-split-value gnus-split-methods))
3388                     (prompt
3389                      (format prompt
3390                              (if (and gnus-number-of-articles-to-be-saved
3391                                       (> gnus-number-of-articles-to-be-saved 1))
3392                                  (format "these %d articles"
3393                                          gnus-number-of-articles-to-be-saved)
3394                                "this article")))
3395                     (file
3396                      ;; Let the split methods have their say.
3397                      (cond
3398                       ;; No split name was found.
3399                       ((null split-name)
3400                        (read-file-name
3401                         (concat prompt " (default "
3402                                 (file-name-nondirectory default-name) "): ")
3403                         (file-name-directory default-name)
3404                         default-name))
3405                       ;; A single group name is returned.
3406                       ((stringp split-name)
3407                        (setq default-name
3408                              (funcall function split-name headers
3409                                       (symbol-value variable)))
3410                        (read-file-name
3411                         (concat prompt " (default "
3412                                 (file-name-nondirectory default-name) "): ")
3413                         (file-name-directory default-name)
3414                         default-name))
3415                       ;; A single split name was found
3416                       ((= 1 (length split-name))
3417                        (let* ((name (expand-file-name
3418                                      (car split-name)
3419                                      gnus-article-save-directory))
3420                               (dir (cond ((file-directory-p name)
3421                                           (file-name-as-directory name))
3422                                          ((file-exists-p name) name)
3423                                          (t gnus-article-save-directory))))
3424                          (read-file-name
3425                           (concat prompt " (default " name "): ")
3426                           dir name)))
3427                       ;; A list of splits was found.
3428                       (t
3429                        (setq split-name (nreverse split-name))
3430                        (let (result)
3431                          (let ((file-name-history
3432                                 (nconc split-name file-name-history)))
3433                            (setq result
3434                                  (expand-file-name
3435                                   (read-file-name
3436                                    (concat prompt " (`M-p' for defaults): ")
3437                                    gnus-article-save-directory
3438                                    (car split-name))
3439                                   gnus-article-save-directory)))
3440                          (car (push result file-name-history)))))))
3441                ;; Create the directory.
3442                (gnus-make-directory (file-name-directory file))
3443                ;; If we have read a directory, we append the default file name.
3444                (when (file-directory-p file)
3445                  (setq file (expand-file-name (file-name-nondirectory
3446                                                default-name)
3447                                               (file-name-as-directory file))))
3448                ;; Possibly translate some characters.
3449                (nnheader-translate-file-chars file))))))
3450     (gnus-make-directory (file-name-directory result))
3451     (set variable result)))
3452
3453 (defun gnus-article-archive-name (group)
3454   "Return the first instance of an \"Archive-name\" in the current buffer."
3455   (let ((case-fold-search t))
3456     (when (re-search-forward "archive-name: *\\([^ \n\t]+\\)[ \t]*$" nil t)
3457       (nnheader-concat gnus-article-save-directory
3458                        (match-string 1)))))
3459
3460 (defun gnus-article-nndoc-name (group)
3461   "If GROUP is an nndoc group, return the name of the parent group."
3462   (when (eq (car (gnus-find-method-for-group group)) 'nndoc)
3463     (gnus-group-get-parameter group 'save-article-group)))
3464
3465 (defun gnus-summary-save-in-rmail (&optional filename)
3466   "Append this article to Rmail file.
3467 Optional argument FILENAME specifies file name.
3468 Directory to save to is default to `gnus-article-save-directory'."
3469   (setq filename (gnus-read-save-file-name
3470                   "Save %s in rmail file" filename
3471                   gnus-rmail-save-name gnus-newsgroup-name
3472                   gnus-current-headers 'gnus-newsgroup-last-rmail))
3473   (gnus-eval-in-buffer-window gnus-save-article-buffer
3474     (save-excursion
3475       (save-restriction
3476         (widen)
3477         (gnus-output-to-rmail filename))))
3478   filename)
3479
3480 (defun gnus-summary-save-in-mail (&optional filename)
3481   "Append this article to Unix mail file.
3482 Optional argument FILENAME specifies file name.
3483 Directory to save to is default to `gnus-article-save-directory'."
3484   (setq filename (gnus-read-save-file-name
3485                   "Save %s in Unix mail file" filename
3486                   gnus-mail-save-name gnus-newsgroup-name
3487                   gnus-current-headers 'gnus-newsgroup-last-mail))
3488   (gnus-eval-in-buffer-window gnus-save-article-buffer
3489     (save-excursion
3490       (save-restriction
3491         (widen)
3492         (if (and (file-readable-p filename)
3493                  (file-regular-p filename)
3494                  (mail-file-babyl-p filename))
3495             (rmail-output-to-rmail-file filename t)
3496           (gnus-output-to-mail filename)))))
3497   filename)
3498
3499 (defun gnus-summary-save-in-file (&optional filename overwrite)
3500   "Append this article to file.
3501 Optional argument FILENAME specifies file name.
3502 Directory to save to is default to `gnus-article-save-directory'."
3503   (setq filename (gnus-read-save-file-name
3504                   "Save %s in file" filename
3505                   gnus-file-save-name gnus-newsgroup-name
3506                   gnus-current-headers 'gnus-newsgroup-last-file))
3507   (gnus-eval-in-buffer-window gnus-save-article-buffer
3508     (save-excursion
3509       (save-restriction
3510         (widen)
3511         (when (and overwrite
3512                    (file-exists-p filename))
3513           (delete-file filename))
3514         (gnus-output-to-file filename))))
3515   filename)
3516
3517 (defun gnus-summary-write-to-file (&optional filename)
3518   "Write this article to a file, overwriting it if the file exists.
3519 Optional argument FILENAME specifies file name.
3520 The directory to save in defaults to `gnus-article-save-directory'."
3521   (gnus-summary-save-in-file nil t))
3522
3523 (defun gnus-summary-save-body-in-file (&optional filename)
3524   "Append this article body to a file.
3525 Optional argument FILENAME specifies file name.
3526 The directory to save in defaults to `gnus-article-save-directory'."
3527   (setq filename (gnus-read-save-file-name
3528                   "Save %s body in file" filename
3529                   gnus-file-save-name gnus-newsgroup-name
3530                   gnus-current-headers 'gnus-newsgroup-last-file))
3531   (gnus-eval-in-buffer-window gnus-save-article-buffer
3532     (save-excursion
3533       (save-restriction
3534         (widen)
3535         (when (article-goto-body)
3536           (narrow-to-region (point) (point-max)))
3537         (gnus-output-to-file filename))))
3538   filename)
3539
3540 (defun gnus-summary-save-in-pipe (&optional command)
3541   "Pipe this article to subprocess."
3542   (setq command
3543         (cond ((and (eq command 'default)
3544                     gnus-last-shell-command)
3545                gnus-last-shell-command)
3546               ((stringp command)
3547                command)
3548               (t (read-string
3549                   (format
3550                    "Shell command on %s: "
3551                    (if (and gnus-number-of-articles-to-be-saved
3552                             (> gnus-number-of-articles-to-be-saved 1))
3553                        (format "these %d articles"
3554                                gnus-number-of-articles-to-be-saved)
3555                      "this article"))
3556                   gnus-last-shell-command))))
3557   (when (string-equal command "")
3558     (if gnus-last-shell-command
3559         (setq command gnus-last-shell-command)
3560       (error "A command is required")))
3561   (gnus-eval-in-buffer-window gnus-article-buffer
3562     (save-restriction
3563       (widen)
3564       (shell-command-on-region (point-min) (point-max) command nil)))
3565   (setq gnus-last-shell-command command))
3566
3567 (defun gnus-summary-pipe-to-muttprint (&optional command)
3568   "Pipe this article to muttprint."
3569   (setq command (read-string
3570                  "Print using command: " gnus-summary-muttprint-program
3571                  nil gnus-summary-muttprint-program))
3572   (gnus-summary-save-in-pipe command))
3573
3574 ;;; Article file names when saving.
3575
3576 (defun gnus-capitalize-newsgroup (newsgroup)
3577   "Capitalize NEWSGROUP name."
3578   (when (not (zerop (length newsgroup)))
3579     (concat (char-to-string (upcase (aref newsgroup 0)))
3580             (substring newsgroup 1))))
3581
3582 (defun gnus-Numeric-save-name (newsgroup headers &optional last-file)
3583   "Generate file name from NEWSGROUP, HEADERS, and optional LAST-FILE.
3584 If variable `gnus-use-long-file-name' is non-nil, it is ~/News/News.group/num.
3585 Otherwise, it is like ~/News/news/group/num."
3586   (let ((default
3587           (expand-file-name
3588            (concat (if (gnus-use-long-file-name 'not-save)
3589                        (gnus-capitalize-newsgroup newsgroup)
3590                      (gnus-newsgroup-directory-form newsgroup))
3591                    "/" (int-to-string (mail-header-number headers)))
3592            gnus-article-save-directory)))
3593     (if (and last-file
3594              (string-equal (file-name-directory default)
3595                            (file-name-directory last-file))
3596              (string-match "^[0-9]+$" (file-name-nondirectory last-file)))
3597         default
3598       (or last-file default))))
3599
3600 (defun gnus-numeric-save-name (newsgroup headers &optional last-file)
3601   "Generate file name from NEWSGROUP, HEADERS, and optional LAST-FILE.
3602 If variable `gnus-use-long-file-name' is non-nil, it is
3603 ~/News/news.group/num.  Otherwise, it is like ~/News/news/group/num."
3604   (let ((default
3605           (expand-file-name
3606            (concat (if (gnus-use-long-file-name 'not-save)
3607                        newsgroup
3608                      (gnus-newsgroup-directory-form newsgroup))
3609                    "/" (int-to-string (mail-header-number headers)))
3610            gnus-article-save-directory)))
3611     (if (and last-file
3612              (string-equal (file-name-directory default)
3613                            (file-name-directory last-file))
3614              (string-match "^[0-9]+$" (file-name-nondirectory last-file)))
3615         default
3616       (or last-file default))))
3617
3618 (defun gnus-plain-save-name (newsgroup headers &optional last-file)
3619   "Generate file name from NEWSGROUP, HEADERS, and optional LAST-FILE.
3620 If variable `gnus-use-long-file-name' is non-nil, it is
3621 ~/News/news.group.  Otherwise, it is like ~/News/news/group/news."
3622   (or last-file
3623       (expand-file-name
3624        (if (gnus-use-long-file-name 'not-save)
3625            newsgroup
3626          (file-relative-name
3627           (expand-file-name "news" (gnus-newsgroup-directory-form newsgroup))
3628           default-directory))
3629        gnus-article-save-directory)))
3630
3631 (defun gnus-sender-save-name (newsgroup headers &optional last-file)
3632   "Generate file name from sender."
3633   (let ((from (mail-header-from headers)))
3634     (expand-file-name
3635      (if (and from (string-match "\\([^ <]+\\)@" from))
3636          (match-string 1 from)
3637        "nobody")
3638      gnus-article-save-directory)))
3639
3640 (defun article-verify-x-pgp-sig ()
3641   "Verify X-PGP-Sig."
3642   (interactive)
3643   (if (gnus-buffer-live-p gnus-original-article-buffer)
3644       (let ((sig (with-current-buffer gnus-original-article-buffer
3645                    (gnus-fetch-field "X-PGP-Sig")))
3646             items info headers)
3647         (when (and sig
3648                    mml2015-use
3649                    (mml2015-clear-verify-function))
3650           (with-temp-buffer
3651             (insert-buffer-substring gnus-original-article-buffer)
3652             (setq items (split-string sig))
3653             (message-narrow-to-head)
3654             (let ((inhibit-point-motion-hooks t)
3655                   (case-fold-search t))
3656               ;; Don't verify multiple headers.
3657               (setq headers (mapconcat (lambda (header)
3658                                          (concat header ": "
3659                                                  (mail-fetch-field header)
3660                                                  "\n"))
3661                                        (split-string (nth 1 items) ",") "")))
3662             (delete-region (point-min) (point-max))
3663             (insert "-----BEGIN PGP SIGNED MESSAGE-----\n\n")
3664             (insert "X-Signed-Headers: " (nth 1 items) "\n")
3665             (insert headers)
3666             (widen)
3667             (forward-line)
3668             (while (not (eobp))
3669               (if (looking-at "^-")
3670                   (insert "- "))
3671               (forward-line))
3672             (insert "\n-----BEGIN PGP SIGNATURE-----\n")
3673             (insert "Version: " (car items) "\n\n")
3674             (insert (mapconcat 'identity (cddr items) "\n"))
3675             (insert "\n-----END PGP SIGNATURE-----\n")
3676             (let ((mm-security-handle (list (format "multipart/signed"))))
3677               (mml2015-clean-buffer)
3678               (let ((coding-system-for-write (or gnus-newsgroup-charset
3679                                                  'iso-8859-1)))
3680                 (funcall (mml2015-clear-verify-function)))
3681               (setq info
3682                     (or (mm-handle-multipart-ctl-parameter
3683                          mm-security-handle 'gnus-details)
3684                         (mm-handle-multipart-ctl-parameter
3685                          mm-security-handle 'gnus-info)))))
3686           (when info
3687             (let ((inhibit-read-only t) bface eface)
3688               (save-restriction
3689                 (message-narrow-to-head)
3690                 (goto-char (point-max))
3691                 (forward-line -1)
3692                 (setq bface (get-text-property (point-at-bol) 'face)
3693                       eface (get-text-property (1- (point-at-eol)) 'face))
3694                 (message-remove-header "X-Gnus-PGP-Verify")
3695                 (if (re-search-forward "^X-PGP-Sig:" nil t)
3696                     (forward-line)
3697                   (goto-char (point-max)))
3698                 (narrow-to-region (point) (point))
3699                 (insert "X-Gnus-PGP-Verify: " info "\n")
3700                 (goto-char (point-min))
3701                 (forward-line)
3702                 (while (not (eobp))
3703                   (if (not (looking-at "^[ \t]"))
3704                       (insert " "))
3705                   (forward-line))
3706                 ;; Do highlighting.
3707                 (goto-char (point-min))
3708                 (when (looking-at "\\([^:]+\\): *")
3709                   (put-text-property (match-beginning 1) (1+ (match-end 1))
3710                                      'face bface)
3711                   (put-text-property (match-end 0) (point-max)
3712                                      'face eface)))))))))
3713
3714 (defun article-verify-cancel-lock ()
3715   "Verify Cancel-Lock header."
3716   (interactive)
3717   (if (gnus-buffer-live-p gnus-original-article-buffer)
3718       (canlock-verify gnus-original-article-buffer)))
3719
3720 (eval-and-compile
3721   (mapcar
3722    (lambda (func)
3723      (let (afunc gfunc)
3724        (if (consp func)
3725            (setq afunc (car func)
3726                  gfunc (cdr func))
3727          (setq afunc func
3728                gfunc (intern (format "gnus-%s" func))))
3729        (defalias gfunc
3730          (when (fboundp afunc)
3731            `(lambda (&optional interactive &rest args)
3732               ,(documentation afunc t)
3733               (interactive (list t))
3734               (save-excursion
3735                 (set-buffer gnus-article-buffer)
3736                 (if interactive
3737                     (call-interactively ',afunc)
3738                   (apply ',afunc args))))))))
3739    '(article-hide-headers
3740      article-verify-x-pgp-sig
3741      article-verify-cancel-lock
3742      article-hide-boring-headers
3743      article-treat-overstrike
3744      article-treat-ansi-sequences
3745      article-fill-long-lines
3746      article-capitalize-sentences
3747      article-remove-cr
3748      article-remove-leading-whitespace
3749      article-display-x-face
3750      article-display-face
3751      article-de-quoted-unreadable
3752      article-de-base64-unreadable
3753      article-decode-HZ
3754      article-wash-html
3755      article-unsplit-urls
3756      article-hide-list-identifiers
3757      article-strip-banner
3758      article-babel
3759      article-hide-pem
3760      article-hide-signature
3761      article-strip-headers-in-body
3762      article-remove-trailing-blank-lines
3763      article-strip-leading-blank-lines
3764      article-strip-multiple-blank-lines
3765      article-strip-leading-space
3766      article-strip-trailing-space
3767      article-strip-blank-lines
3768      article-strip-all-blank-lines
3769      article-date-local
3770      article-date-english
3771      article-date-iso8601
3772      article-date-original
3773      article-date-ut
3774      article-decode-mime-words
3775      article-decode-charset
3776      article-decode-encoded-words
3777      article-date-user
3778      article-date-lapsed
3779      article-emphasize
3780      article-treat-dumbquotes
3781      article-normalize-headers
3782 ;;     (article-show-all . gnus-article-show-all-headers)
3783      )))
3784 \f
3785 ;;;
3786 ;;; Gnus article mode
3787 ;;;
3788
3789 (put 'gnus-article-mode 'mode-class 'special)
3790
3791 (set-keymap-parent gnus-article-mode-map widget-keymap)
3792
3793 (gnus-define-keys gnus-article-mode-map
3794   " " gnus-article-goto-next-page
3795   "\177" gnus-article-goto-prev-page
3796   [delete] gnus-article-goto-prev-page
3797   [backspace] gnus-article-goto-prev-page
3798   "\C-c^" gnus-article-refer-article
3799   "h" gnus-article-show-summary
3800   "s" gnus-article-show-summary
3801   "\C-c\C-m" gnus-article-mail
3802   "?" gnus-article-describe-briefly
3803   "e" gnus-summary-edit-article
3804   "<" beginning-of-buffer
3805   ">" end-of-buffer
3806   "\C-c\C-i" gnus-info-find-node
3807   "\C-c\C-b" gnus-bug
3808   "R" gnus-article-reply-with-original
3809   "F" gnus-article-followup-with-original
3810   "\C-hk" gnus-article-describe-key
3811   "\C-hc" gnus-article-describe-key-briefly
3812
3813   "\C-d" gnus-article-read-summary-keys
3814   "\M-*" gnus-article-read-summary-keys
3815   "\M-#" gnus-article-read-summary-keys
3816   "\M-^" gnus-article-read-summary-keys
3817   "\M-g" gnus-article-read-summary-keys)
3818
3819 (substitute-key-definition
3820  'undefined 'gnus-article-read-summary-keys gnus-article-mode-map)
3821
3822 (defun gnus-article-make-menu-bar ()
3823   (unless (boundp 'gnus-article-commands-menu)
3824     (gnus-summary-make-menu-bar))
3825   (gnus-turn-off-edit-menu 'article)
3826   (unless (boundp 'gnus-article-article-menu)
3827     (easy-menu-define
3828      gnus-article-article-menu gnus-article-mode-map ""
3829      '("Article"
3830        ["Scroll forwards" gnus-article-goto-next-page t]
3831        ["Scroll backwards" gnus-article-goto-prev-page t]
3832        ["Show summary" gnus-article-show-summary t]
3833        ["Fetch Message-ID at point" gnus-article-refer-article t]
3834        ["Mail to address at point" gnus-article-mail t]
3835        ["Send a bug report" gnus-bug t]))
3836
3837     (easy-menu-define
3838      gnus-article-treatment-menu gnus-article-mode-map ""
3839      ;; Fixme: this should use :active (and maybe :visible).
3840      '("Treatment"
3841        ["Hide headers" gnus-article-hide-headers t]
3842        ["Hide signature" gnus-article-hide-signature t]
3843        ["Hide citation" gnus-article-hide-citation t]
3844        ["Treat overstrike" gnus-article-treat-overstrike t]
3845        ["Treat ANSI sequences" gnus-article-treat-ansi-sequences t]
3846        ["Remove carriage return" gnus-article-remove-cr t]
3847        ["Remove leading whitespace" gnus-article-remove-leading-whitespace t]
3848        ["Remove quoted-unreadable" gnus-article-de-quoted-unreadable t]
3849        ["Remove base64" gnus-article-de-base64-unreadable t]
3850        ["Treat html" gnus-article-wash-html t]
3851        ["Remove newlines from within URLs" gnus-article-unsplit-urls t]
3852        ["Decode HZ" gnus-article-decode-HZ t]))
3853
3854     ;; Note "Commands" menu is defined in gnus-sum.el for consistency
3855
3856     ;; Note "Post" menu is defined in gnus-sum.el for consistency
3857
3858     (gnus-run-hooks 'gnus-article-menu-hook)))
3859
3860 (defun gnus-article-mode ()
3861   "Major mode for displaying an article.
3862
3863 All normal editing commands are switched off.
3864
3865 The following commands are available in addition to all summary mode
3866 commands:
3867 \\<gnus-article-mode-map>
3868 \\[gnus-article-next-page]\t Scroll the article one page forwards
3869 \\[gnus-article-prev-page]\t Scroll the article one page backwards
3870 \\[gnus-article-refer-article]\t Go to the article referred to by an article id near point
3871 \\[gnus-article-show-summary]\t Display the summary buffer
3872 \\[gnus-article-mail]\t Send a reply to the address near point
3873 \\[gnus-article-describe-briefly]\t Describe the current mode briefly
3874 \\[gnus-info-find-node]\t Go to the Gnus info node"
3875   (interactive)
3876   (kill-all-local-variables)
3877   (gnus-simplify-mode-line)
3878   (setq mode-name "Article")
3879   (setq major-mode 'gnus-article-mode)
3880   (make-local-variable 'minor-mode-alist)
3881   (use-local-map gnus-article-mode-map)
3882   (when (gnus-visual-p 'article-menu 'menu)
3883     (gnus-article-make-menu-bar)
3884     (when gnus-summary-tool-bar-map
3885       (set (make-local-variable 'tool-bar-map) gnus-summary-tool-bar-map)))
3886   (gnus-update-format-specifications nil 'article-mode)
3887   (set (make-local-variable 'page-delimiter) gnus-page-delimiter)
3888   (set (make-local-variable 'gnus-page-broken) nil)
3889   (make-local-variable 'gnus-button-marker-list)
3890   (make-local-variable 'gnus-article-current-summary)
3891   (make-local-variable 'gnus-article-mime-handles)
3892   (make-local-variable 'gnus-article-decoded-p)
3893   (make-local-variable 'gnus-article-mime-handle-alist)
3894   (make-local-variable 'gnus-article-wash-types)
3895   (make-local-variable 'gnus-article-image-alist)
3896   (make-local-variable 'gnus-article-charset)
3897   (make-local-variable 'gnus-article-ignored-charsets)
3898   ;; Prevent recent Emacsen from displaying non-break space as "\ ".
3899   (set (make-local-variable 'nobreak-char-display) nil)
3900   (gnus-set-default-directory)
3901   (buffer-disable-undo)
3902   (setq buffer-read-only t
3903         show-trailing-whitespace nil)
3904   (set-syntax-table gnus-article-mode-syntax-table)
3905   (mm-enable-multibyte)
3906   (gnus-run-mode-hooks 'gnus-article-mode-hook))
3907
3908 (defun gnus-article-setup-buffer ()
3909   "Initialize the article buffer."
3910   (let* ((name (if gnus-single-article-buffer "*Article*"
3911                  (concat "*Article " gnus-newsgroup-name "*")))
3912          (original
3913           (progn (string-match "\\*Article" name)
3914                  (concat " *Original Article"
3915                          (substring name (match-end 0))))))
3916     (setq gnus-article-buffer name)
3917     (setq gnus-original-article-buffer original)
3918     (setq gnus-article-mime-handle-alist nil)
3919     ;; This might be a variable local to the summary buffer.
3920     (unless gnus-single-article-buffer
3921       (save-excursion
3922         (set-buffer gnus-summary-buffer)
3923         (setq gnus-article-buffer name)
3924         (setq gnus-original-article-buffer original)
3925         (gnus-set-global-variables)))
3926     (gnus-article-setup-highlight-words)
3927     ;; Init original article buffer.
3928     (save-excursion
3929       (set-buffer (gnus-get-buffer-create gnus-original-article-buffer))
3930       (mm-enable-multibyte)
3931       (setq major-mode 'gnus-original-article-mode)
3932       (make-local-variable 'gnus-original-article))
3933     (if (and (get-buffer name)
3934              (with-current-buffer name
3935                (if gnus-article-edit-mode
3936                    (if (y-or-n-p "Article mode edit in progress; discard? ")
3937                        (progn
3938                          (set-buffer-modified-p nil)
3939                          (gnus-kill-buffer name)
3940                          (message "")
3941                          nil)
3942                      (error "Action aborted"))
3943                  t)))
3944         (save-excursion
3945           (set-buffer name)
3946           (set (make-local-variable 'gnus-article-edit-mode) nil)
3947           (when gnus-article-mime-handles
3948             (mm-destroy-parts gnus-article-mime-handles)
3949             (setq gnus-article-mime-handles nil))
3950           ;; Set it to nil in article-buffer!
3951           (setq gnus-article-mime-handle-alist nil)
3952           (buffer-disable-undo)
3953           (setq buffer-read-only t)
3954           ;; This list just keeps growing if we don't reset it.
3955           (setq gnus-button-marker-list nil)
3956           (unless (eq major-mode 'gnus-article-mode)
3957             (gnus-article-mode))
3958           (current-buffer))
3959       (save-excursion
3960         (set-buffer (gnus-get-buffer-create name))
3961         (gnus-article-mode)
3962         (make-local-variable 'gnus-summary-buffer)
3963         (gnus-summary-set-local-parameters gnus-newsgroup-name)
3964         (current-buffer)))))
3965
3966 ;; Set article window start at LINE, where LINE is the number of lines
3967 ;; from the head of the article.
3968 (defun gnus-article-set-window-start (&optional line)
3969   (set-window-start
3970    (gnus-get-buffer-window gnus-article-buffer t)
3971    (save-excursion
3972      (set-buffer gnus-article-buffer)
3973      (goto-char (point-min))
3974      (if (not line)
3975          (point-min)
3976        (gnus-message 6 "Moved to bookmark")
3977        (search-forward "\n\n" nil t)
3978        (forward-line line)
3979        (point)))))
3980
3981 (defun gnus-article-prepare (article &optional all-headers header)
3982   "Prepare ARTICLE in article mode buffer.
3983 ARTICLE should either be an article number or a Message-ID.
3984 If ARTICLE is an id, HEADER should be the article headers.
3985 If ALL-HEADERS is non-nil, no headers are hidden."
3986   (save-excursion
3987     ;; Make sure we start in a summary buffer.
3988     (unless (eq major-mode 'gnus-summary-mode)
3989       (set-buffer gnus-summary-buffer))
3990     (setq gnus-summary-buffer (current-buffer))
3991     (let* ((gnus-article (if header (mail-header-number header) article))
3992            (summary-buffer (current-buffer))
3993            (gnus-tmp-internal-hook gnus-article-internal-prepare-hook)
3994            (group gnus-newsgroup-name)
3995            result)
3996       (save-excursion
3997         (gnus-article-setup-buffer)
3998         (set-buffer gnus-article-buffer)
3999         ;; Deactivate active regions.
4000         (when (and (boundp 'transient-mark-mode)
4001                    transient-mark-mode)
4002           (setq mark-active nil))
4003         (if (not (setq result (let ((inhibit-read-only t))
4004                                 (gnus-request-article-this-buffer
4005                                  article group))))
4006             ;; There is no such article.
4007             (save-excursion
4008               (when (and (numberp article)
4009                          (not (memq article gnus-newsgroup-sparse)))
4010                 (setq gnus-article-current
4011                       (cons gnus-newsgroup-name article))
4012                 (set-buffer gnus-summary-buffer)
4013                 (setq gnus-current-article article)
4014                 (if (and (memq article gnus-newsgroup-undownloaded)
4015                          (not (gnus-online (gnus-find-method-for-group
4016                                             gnus-newsgroup-name))))
4017                     (progn
4018                       (gnus-summary-set-agent-mark article)
4019                       (message "Message marked for downloading"))
4020                   (gnus-summary-mark-article article gnus-canceled-mark)
4021                   (unless (memq article gnus-newsgroup-sparse)
4022                     (gnus-error 1 "No such article (may have expired or been canceled)")))))
4023           (if (or (eq result 'pseudo)
4024                   (eq result 'nneething))
4025               (progn
4026                 (save-excursion
4027                   (set-buffer summary-buffer)
4028                   (push article gnus-newsgroup-history)
4029                   (setq gnus-last-article gnus-current-article
4030                         gnus-current-article 0
4031                         gnus-current-headers nil
4032                         gnus-article-current nil)
4033                   (if (eq result 'nneething)
4034                       (gnus-configure-windows 'summary)
4035                     (gnus-configure-windows 'article))
4036                   (gnus-set-global-variables))
4037                 (let ((gnus-article-mime-handle-alist-1
4038                        gnus-article-mime-handle-alist))
4039                   (gnus-set-mode-line 'article)))
4040             ;; The result from the `request' was an actual article -
4041             ;; or at least some text that is now displayed in the
4042             ;; article buffer.
4043             (when (and (numberp article)
4044                        (not (eq article gnus-current-article)))
4045               ;; Seems like a new article has been selected.
4046               ;; `gnus-current-article' must be an article number.
4047               (save-excursion
4048                 (set-buffer summary-buffer)
4049                 (push article gnus-newsgroup-history)
4050                 (setq gnus-last-article gnus-current-article
4051                       gnus-current-article article
4052                       gnus-current-headers
4053                       (gnus-summary-article-header gnus-current-article)
4054                       gnus-article-current
4055                       (cons gnus-newsgroup-name gnus-current-article))
4056                 (unless (vectorp gnus-current-headers)
4057                   (setq gnus-current-headers nil))
4058                 (gnus-summary-goto-subject gnus-current-article)
4059                 (when (gnus-summary-show-thread)
4060                   ;; If the summary buffer really was folded, the
4061                   ;; previous goto may not actually have gone to
4062                   ;; the right article, but the thread root instead.
4063                   ;; So we go again.
4064                   (gnus-summary-goto-subject gnus-current-article))
4065                 (gnus-run-hooks 'gnus-mark-article-hook)
4066                 (gnus-set-mode-line 'summary)
4067                 (when (gnus-visual-p 'article-highlight 'highlight)
4068                   (gnus-run-hooks 'gnus-visual-mark-article-hook))
4069                 ;; Set the global newsgroup variables here.
4070                 (gnus-set-global-variables)
4071                 (setq gnus-have-all-headers
4072                       (or all-headers gnus-show-all-headers))))
4073             (save-excursion
4074               (gnus-configure-windows 'article))
4075             (when (or (numberp article)
4076                       (stringp article))
4077               (gnus-article-prepare-display)
4078               ;; Do page break.
4079               (goto-char (point-min))
4080               (when gnus-break-pages
4081                 (gnus-narrow-to-page)))
4082             (let ((gnus-article-mime-handle-alist-1
4083                    gnus-article-mime-handle-alist))
4084               (gnus-set-mode-line 'article))
4085             (article-goto-body)
4086             (unless (bobp)
4087               (forward-line -1))
4088             (set-window-point (get-buffer-window (current-buffer)) (point))
4089             (gnus-configure-windows 'article)
4090             t))))))
4091
4092 ;;;###autoload
4093 (defun gnus-article-prepare-display ()
4094   "Make the current buffer look like a nice article."
4095   ;; Hooks for getting information from the article.
4096   ;; This hook must be called before being narrowed.
4097   (let ((gnus-article-buffer (current-buffer))
4098         buffer-read-only
4099         (inhibit-read-only t))
4100     (unless (eq major-mode 'gnus-article-mode)
4101       (gnus-article-mode))
4102     (setq buffer-read-only nil
4103           gnus-article-wash-types nil
4104           gnus-article-image-alist nil)
4105     (gnus-run-hooks 'gnus-tmp-internal-hook)
4106     (when gnus-display-mime-function
4107       (funcall gnus-display-mime-function))
4108     (gnus-run-hooks 'gnus-article-prepare-hook)))
4109
4110 ;;;
4111 ;;; Gnus MIME viewing functions
4112 ;;;
4113
4114 (defvar gnus-mime-button-line-format "%{%([%p. %d%T]%)%}%e\n"
4115   "Format of the MIME buttons.
4116
4117 Valid specifiers include:
4118 %t  The MIME type
4119 %T  MIME type, along with additional info
4120 %n  The `name' parameter
4121 %d  The description, if any
4122 %l  The length of the encoded part
4123 %p  The part identifier number
4124 %e  Dots if the part isn't displayed
4125
4126 General format specifiers can also be used.  See Info node
4127 `(gnus)Formatting Variables'.")
4128
4129 (defvar gnus-mime-button-line-format-alist
4130   '((?t gnus-tmp-type ?s)
4131     (?T gnus-tmp-type-long ?s)
4132     (?n gnus-tmp-name ?s)
4133     (?d gnus-tmp-description ?s)
4134     (?p gnus-tmp-id ?s)
4135     (?l gnus-tmp-length ?d)
4136     (?e gnus-tmp-dots ?s)))
4137
4138 (defvar gnus-mime-button-commands
4139   '((gnus-article-press-button "\r" "Toggle Display")
4140     (gnus-mime-view-part "v" "View Interactively...")
4141     (gnus-mime-view-part-as-type "t" "View As Type...")
4142     (gnus-mime-view-part-as-charset "C" "View As charset...")
4143     (gnus-mime-save-part "o" "Save...")
4144     (gnus-mime-save-part-and-strip "\C-o" "Save and Strip")
4145     (gnus-mime-replace-part "r" "Replace part")
4146     (gnus-mime-delete-part "d" "Delete part")
4147     (gnus-mime-copy-part "c" "View As Text, In Other Buffer")
4148     (gnus-mime-inline-part "i" "View As Text, In This Buffer")
4149     (gnus-mime-view-part-internally "E" "View Internally") ;; Why `E'?
4150     (gnus-mime-view-part-externally "e" "View Externally")
4151     (gnus-mime-print-part "p" "Print")
4152     (gnus-mime-pipe-part "|" "Pipe To Command...")
4153     (gnus-mime-action-on-part "." "Take action on the part...")))
4154
4155 (defun gnus-article-mime-part-status ()
4156   (if gnus-article-mime-handle-alist-1
4157       (if (eq 1 (length gnus-article-mime-handle-alist-1))
4158           " (1 part)"
4159         (format " (%d parts)" (length gnus-article-mime-handle-alist-1)))
4160     ""))
4161
4162 (defvar gnus-mime-button-map
4163   (let ((map (make-sparse-keymap)))
4164     (define-key map gnus-mouse-2 'gnus-article-push-button)
4165     (define-key map gnus-down-mouse-3 'gnus-mime-button-menu)
4166     (dolist (c gnus-mime-button-commands)
4167       (define-key map (cadr c) (car c)))
4168     map))
4169
4170 (easy-menu-define
4171   gnus-mime-button-menu gnus-mime-button-map "MIME button menu."
4172   `("MIME Part"
4173     ,@(mapcar (lambda (c)
4174                 (vector (caddr c) (car c) :enable t))
4175               gnus-mime-button-commands)))
4176
4177 (defun gnus-mime-button-menu (event prefix)
4178  "Construct a context-sensitive menu of MIME commands."
4179  (interactive "e\nP")
4180  (save-window-excursion
4181    (let ((pos (event-start event)))
4182      (select-window (posn-window pos))
4183      (goto-char (posn-point pos))
4184      (gnus-article-check-buffer)
4185      (popup-menu gnus-mime-button-menu nil prefix))))
4186
4187 (defun gnus-mime-view-all-parts (&optional handles)
4188   "View all the MIME parts."
4189   (interactive)
4190   (with-current-buffer gnus-article-buffer
4191     (let ((handles (or handles gnus-article-mime-handles))
4192           (mail-parse-charset gnus-newsgroup-charset)
4193           (mail-parse-ignored-charsets
4194            (with-current-buffer gnus-summary-buffer
4195              gnus-newsgroup-ignored-charsets)))
4196       (when handles
4197         (mm-remove-parts handles)
4198         (goto-char (point-min))
4199         (or (search-forward "\n\n") (goto-char (point-max)))
4200         (let ((inhibit-read-only t))
4201           (delete-region (point) (point-max))
4202           (mm-display-parts handles))))))
4203
4204 (defun gnus-article-jump-to-part (n)
4205   "Jump to MIME part N."
4206   (interactive "P")
4207   (pop-to-buffer gnus-article-buffer)
4208   ;; FIXME: why is it necessary?
4209   (sit-for 0)
4210   (let ((parts (length gnus-article-mime-handle-alist)))
4211     (or n (setq n
4212                 (string-to-number
4213                  (read-string ;; Emacs 21 doesn't have `read-number'.
4214                   (format "Jump to part (2..%s): " parts)))))
4215     (unless (and (integerp n) (<= n parts) (>= n 1))
4216       (setq n
4217             (progn
4218               (gnus-message 7 "Invalid part `%s', using %s instead."
4219                             n parts)
4220               parts)))
4221     (gnus-message 9 "Jumping to part %s." n)
4222     (cond ((>= gnus-auto-select-part 1)
4223            (while (and (<= n parts)
4224                        (not (gnus-article-goto-part n)))
4225              (setq n (1+ n))))
4226           ((< gnus-auto-select-part 0)
4227            (while (and (>= n 1)
4228                        (not (gnus-article-goto-part n)))
4229              (setq n (1- n))))
4230           (t
4231            (gnus-article-goto-part n)))))
4232
4233 (eval-when-compile
4234   (defsubst gnus-article-edit-part (handles &optional current-id)
4235     "Edit an article in order to delete a mime part.
4236 This function is exclusively used by `gnus-mime-save-part-and-strip'
4237 and `gnus-mime-delete-part', and not provided at run-time normally."
4238     (gnus-article-edit-article
4239      `(lambda ()
4240         (buffer-disable-undo)
4241         (erase-buffer)
4242         (let ((mail-parse-charset (or gnus-article-charset
4243                                       ',gnus-newsgroup-charset))
4244               (mail-parse-ignored-charsets
4245                (or gnus-article-ignored-charsets
4246                    ',gnus-newsgroup-ignored-charsets))
4247               (mbl mml-buffer-list))
4248           (setq mml-buffer-list nil)
4249           (insert-buffer-substring gnus-original-article-buffer)
4250           (mime-to-mml ',handles)
4251           (setq gnus-article-mime-handles nil)
4252           (let ((mbl1 mml-buffer-list))
4253             (setq mml-buffer-list mbl)
4254             (set (make-local-variable 'mml-buffer-list) mbl1))
4255           (gnus-make-local-hook 'kill-buffer-hook)
4256           (add-hook 'kill-buffer-hook 'mml-destroy-buffers t t)))
4257      `(lambda (no-highlight)
4258         (let ((mail-parse-charset (or gnus-article-charset
4259                                       ',gnus-newsgroup-charset))
4260               (message-options message-options)
4261               (message-options-set-recipient)
4262               (mail-parse-ignored-charsets
4263                (or gnus-article-ignored-charsets
4264                    ',gnus-newsgroup-ignored-charsets)))
4265           (mml-to-mime)
4266           (mml-destroy-buffers)
4267           (remove-hook 'kill-buffer-hook
4268                        'mml-destroy-buffers t)
4269           (kill-local-variable 'mml-buffer-list))
4270         (gnus-summary-edit-article-done
4271          ,(or (mail-header-references gnus-current-headers) "")
4272          ,(gnus-group-read-only-p)
4273          ,gnus-summary-buffer no-highlight))
4274      t)
4275     (gnus-article-edit-done)
4276     (gnus-summary-expand-window)
4277     (gnus-summary-show-article)
4278     (when (and current-id (integerp gnus-auto-select-part))
4279       (gnus-article-jump-to-part
4280        (+ current-id gnus-auto-select-part)))))
4281
4282 (defun gnus-mime-replace-part (file)
4283   "Replace MIME part under point with an external body."
4284   ;; Useful if file has already been saved to disk
4285   (interactive
4286    (list
4287     (mm-with-multibyte
4288       (read-file-name "Replace MIME part with file: "
4289                       (or mm-default-directory default-directory)
4290                       nil nil))))
4291   (gnus-mime-save-part-and-strip file))
4292
4293 (defun gnus-mime-save-part-and-strip (&optional file)
4294   "Save the MIME part under point then replace it with an external body.
4295 If FILE is given, use it for the external part."
4296   (interactive)
4297   (gnus-article-check-buffer)
4298   (when (gnus-group-read-only-p)
4299     (error "The current group does not support deleting of parts"))
4300   (when (mm-complicated-handles gnus-article-mime-handles)
4301     (error "\
4302 The current article has a complicated MIME structure, giving up..."))
4303   (let* ((data (get-text-property (point) 'gnus-data))
4304          (id (get-text-property (point) 'gnus-part))
4305          param
4306          (handles gnus-article-mime-handles))
4307     (unless file
4308       (setq file
4309             (and data (mm-save-part data "Delete MIME part and save to: "))))
4310     (when file
4311       (with-current-buffer (mm-handle-buffer data)
4312         (erase-buffer)
4313         (insert "Content-Type: " (mm-handle-media-type data))
4314         (mml-insert-parameter-string (cdr (mm-handle-type data))
4315                                      '(charset))
4316         (insert "\n")
4317         (insert "Content-ID: " (message-make-message-id) "\n")
4318         (insert "Content-Transfer-Encoding: binary\n")
4319         (insert "\n"))
4320       (setcdr data
4321               (cdr (mm-make-handle nil
4322                                    `("message/external-body"
4323                                      (access-type . "LOCAL-FILE")
4324                                      (name . ,file)))))
4325       ;; (set-buffer gnus-summary-buffer)
4326       (gnus-article-edit-part handles id))))
4327
4328 ;; A function like `gnus-summary-save-parts' (`X m', `<MIME> <Extract all
4329 ;; parts...>') but with stripping would be nice.
4330
4331 (defun gnus-mime-delete-part ()
4332   "Delete the MIME part under point.
4333 Replace it with some information about the removed part."
4334   (interactive)
4335   (gnus-article-check-buffer)
4336   (when (gnus-group-read-only-p)
4337     (error "The current group does not support deleting of parts"))
4338   (when (mm-complicated-handles gnus-article-mime-handles)
4339     (error "\
4340 The current article has a complicated MIME structure, giving up..."))
4341   (when (or gnus-expert-user
4342             (gnus-yes-or-no-p "\
4343 Deleting parts may malfunction or destroy the article; continue? "))
4344     (let* ((data (get-text-property (point) 'gnus-data))
4345            (id (get-text-property (point) 'gnus-part))
4346            (handles gnus-article-mime-handles)
4347            (none "(none)")
4348            (description
4349             (or
4350              (mail-decode-encoded-word-string (or (mm-handle-description data)
4351                                                   none))))
4352            (filename
4353             (or (mail-content-type-get (mm-handle-disposition data) 'filename)
4354                 none))
4355            (type (mm-handle-media-type data)))
4356       (unless data
4357         (error "No MIME part under point"))
4358       (with-current-buffer (mm-handle-buffer data)
4359         (let ((bsize (format "%s" (buffer-size))))
4360           (erase-buffer)
4361           (insert
4362            (concat
4363             ",----\n"
4364             "| The following attachment has been deleted:\n"
4365             "|\n"
4366             "| Type:           " type "\n"
4367             "| Filename:       " filename "\n"
4368             "| Size (encoded): " bsize " Byte\n"
4369             "| Description:    " description "\n"
4370             "`----\n"))
4371           (setcdr data
4372                   (cdr (mm-make-handle
4373                         nil `("text/plain") nil nil
4374                         (list "attachment")
4375                         (format "Deleted attachment (%s bytes)" bsize))))))
4376       ;; (set-buffer gnus-summary-buffer)
4377       (gnus-article-edit-part handles id))))
4378
4379 (defun gnus-mime-save-part ()
4380   "Save the MIME part under point."
4381   (interactive)
4382   (gnus-article-check-buffer)
4383   (let ((data (get-text-property (point) 'gnus-data)))
4384     (when data
4385       (mm-save-part data))))
4386
4387 (defun gnus-mime-pipe-part ()
4388   "Pipe the MIME part under point to a process."
4389   (interactive)
4390   (gnus-article-check-buffer)
4391   (let ((data (get-text-property (point) 'gnus-data)))
4392     (when data
4393       (mm-pipe-part data))))
4394
4395 (defun gnus-mime-view-part ()
4396   "Interactively choose a viewing method for the MIME part under point."
4397   (interactive)
4398   (gnus-article-check-buffer)
4399   (let ((data (get-text-property (point) 'gnus-data)))
4400     (when data
4401       (setq gnus-article-mime-handles
4402             (mm-merge-handles
4403              gnus-article-mime-handles (setq data (copy-sequence data))))
4404       (mm-interactively-view-part data))))
4405
4406 (defun gnus-mime-view-part-as-type-internal ()
4407   (gnus-article-check-buffer)
4408   (let* ((handle (get-text-property (point) 'gnus-data))
4409          (name (or
4410                 ;; Content-Type: foo/bar; name=...
4411                 (mail-content-type-get (mm-handle-type handle) 'name)
4412                 ;; Content-Disposition: attachment; filename=...
4413                 (cdr (assq 'filename (cdr (mm-handle-disposition handle))))))
4414          (def-type (and name (mm-default-file-encoding name))))
4415     (and def-type (cons def-type 0))))
4416
4417 (defun gnus-mime-view-part-as-type (&optional mime-type)
4418   "Choose a MIME media type, and view the part as such."
4419   (interactive)
4420   (unless mime-type
4421     (setq mime-type
4422           (let ((default (gnus-mime-view-part-as-type-internal)))
4423             (completing-read
4424              (format "View as MIME type (default %s): "
4425                      (car default))
4426              (mapcar #'list (mailcap-mime-types))
4427              nil nil nil nil
4428              (car default)))))
4429   (gnus-article-check-buffer)
4430   (let ((handle (get-text-property (point) 'gnus-data)))
4431     (when handle
4432       (setq handle
4433             (mm-make-handle (mm-handle-buffer handle)
4434                             (cons mime-type (cdr (mm-handle-type handle)))
4435                             (mm-handle-encoding handle)
4436                             (mm-handle-undisplayer handle)
4437                             (mm-handle-disposition handle)
4438                             (mm-handle-description handle)
4439                             nil
4440                             (mm-handle-id handle)))
4441       (setq gnus-article-mime-handles
4442             (mm-merge-handles gnus-article-mime-handles handle))
4443       (gnus-mm-display-part handle))))
4444
4445 (defun gnus-mime-copy-part (&optional handle arg)
4446   "Put the MIME part under point into a new buffer.
4447 If `auto-compression-mode' is enabled, compressed files like .gz and .bz2
4448 are decompressed."
4449   (interactive (list nil current-prefix-arg))
4450   (gnus-article-check-buffer)
4451   (unless handle
4452     (setq handle (get-text-property (point) 'gnus-data)))
4453   (when handle
4454     (let ((filename (or (mail-content-type-get (mm-handle-disposition handle)
4455                                                'name)
4456                         (mail-content-type-get (mm-handle-disposition handle)
4457                                                'filename)))
4458           contents dont-decode charset coding-system)
4459       (mm-with-unibyte-buffer
4460         (mm-insert-part handle)
4461         (setq contents (or (condition-case nil
4462                                (mm-decompress-buffer filename nil 'sig)
4463                              (error
4464                               (setq dont-decode t)
4465                               nil))
4466                            (buffer-string))))
4467       (setq filename (cond (filename (file-name-nondirectory filename))
4468                            (dont-decode "*raw data*")
4469                            (t "*decoded*")))
4470       (cond
4471        (dont-decode)
4472        ((not arg)
4473         (unless (setq charset (mail-content-type-get
4474                                (mm-handle-type handle) 'charset))
4475           (unless (setq coding-system (mm-with-unibyte-buffer
4476                                         (insert contents)
4477                                         (mm-find-buffer-file-coding-system)))
4478             (setq charset gnus-newsgroup-charset))))
4479        ((numberp arg)
4480         (setq charset (or (cdr (assq arg
4481                                      gnus-summary-show-article-charset-alist))
4482                           (mm-read-coding-system "Charset: ")))))
4483       (switch-to-buffer (generate-new-buffer filename))
4484       (if (or coding-system
4485               (and charset
4486                    (setq coding-system (mm-charset-to-coding-system charset))
4487                    (not (eq charset 'ascii))))
4488           (progn
4489             (mm-enable-multibyte)
4490             (insert (mm-decode-coding-string contents coding-system))
4491             (setq buffer-file-coding-system
4492                   (if (boundp 'last-coding-system-used)
4493                       (symbol-value 'last-coding-system-used)
4494                     coding-system)))
4495         (mm-disable-multibyte)
4496         (insert contents)
4497         (setq buffer-file-coding-system mm-binary-coding-system))
4498       ;; We do it this way to make `normal-mode' set the appropriate mode.
4499       (unwind-protect
4500           (progn
4501             (setq buffer-file-name (expand-file-name filename))
4502             (normal-mode))
4503         (setq buffer-file-name nil))
4504       (goto-char (point-min)))))
4505
4506 (defun gnus-mime-print-part (&optional handle filename)
4507   "Print the MIME part under point."
4508   (interactive (list nil (ps-print-preprint current-prefix-arg)))
4509   (gnus-article-check-buffer)
4510   (let* ((handle (or handle (get-text-property (point) 'gnus-data)))
4511          (contents (and handle (mm-get-part handle)))
4512          (file (mm-make-temp-file (expand-file-name "mm." mm-tmp-directory)))
4513          (printer (mailcap-mime-info (mm-handle-media-type handle) "print")))
4514     (when contents
4515         (if printer
4516             (unwind-protect
4517                 (progn
4518                   (mm-save-part-to-file handle file)
4519                   (call-process shell-file-name nil
4520                                 (generate-new-buffer " *mm*")
4521                                 nil
4522                                 shell-command-switch
4523                                 (mm-mailcap-command
4524                                  printer file (mm-handle-type handle))))
4525               (delete-file file))
4526           (with-temp-buffer
4527             (insert contents)
4528             (gnus-print-buffer))
4529           (ps-despool filename)))))
4530
4531 (defun gnus-mime-inline-part (&optional handle arg)
4532   "Insert the MIME part under point into the current buffer.
4533 Compressed files like .gz and .bz2 are decompressed."
4534   (interactive (list nil current-prefix-arg))
4535   (gnus-article-check-buffer)
4536   (unless handle
4537     (setq handle (get-text-property (point) 'gnus-data)))
4538   (when handle
4539     (let ((b (point))
4540           (inhibit-read-only t)
4541           contents charset coding-system)
4542       (if (and (not arg) (mm-handle-undisplayer handle))
4543           (mm-remove-part handle)
4544         (mm-with-unibyte-buffer
4545           (mm-insert-part handle)
4546           (setq contents
4547                 (or (mm-decompress-buffer
4548                      (or (mail-content-type-get (mm-handle-disposition handle)
4549                                                 'name)
4550                          (mail-content-type-get (mm-handle-disposition handle)
4551                                                 'filename))
4552                      nil t)
4553                     (buffer-string))))
4554         (cond
4555          ((not arg)
4556           (unless (setq charset (mail-content-type-get
4557                                  (mm-handle-type handle) 'charset))
4558             (unless (setq coding-system
4559                           (mm-with-unibyte-buffer
4560                             (insert contents)
4561                             (mm-find-buffer-file-coding-system)))
4562               (setq charset gnus-newsgroup-charset))))
4563          ((numberp arg)
4564           (if (mm-handle-undisplayer handle)
4565               (mm-remove-part handle))
4566           (setq charset
4567                 (or (cdr (assq arg
4568                                gnus-summary-show-article-charset-alist))
4569                     (mm-read-coding-system "Charset: "))))
4570          (t
4571           (if (mm-handle-undisplayer handle)
4572               (mm-remove-part handle))))
4573         (forward-line 2)
4574         (mm-insert-inline
4575          handle
4576          (if (or coding-system
4577                  (and charset
4578                       (setq coding-system
4579                             (mm-charset-to-coding-system charset))
4580                       (not (eq coding-system 'ascii))))
4581              (mm-decode-coding-string contents coding-system)
4582            (mm-string-to-multibyte contents)))
4583         (goto-char b)))))
4584
4585 (defun gnus-mime-view-part-as-charset (&optional handle arg)
4586   "Insert the MIME part under point into the current buffer using the
4587 specified charset."
4588   (interactive (list nil current-prefix-arg))
4589   (gnus-article-check-buffer)
4590   (let* ((handle (or handle (get-text-property (point) 'gnus-data)))
4591          contents charset
4592          (b (point))
4593          (inhibit-read-only t))
4594     (when handle
4595       (if (mm-handle-undisplayer handle)
4596           (mm-remove-part handle))
4597       (let ((gnus-newsgroup-charset
4598              (or (cdr (assq arg
4599                             gnus-summary-show-article-charset-alist))
4600                  (mm-read-coding-system "Charset: ")))
4601           (gnus-newsgroup-ignored-charsets 'gnus-all))
4602         (gnus-article-press-button)))))
4603
4604 (defun gnus-mime-view-part-externally (&optional handle)
4605   "View the MIME part under point with an external viewer."
4606   (interactive)
4607   (gnus-article-check-buffer)
4608   (let* ((handle (or handle (get-text-property (point) 'gnus-data)))
4609          (mm-user-display-methods nil)
4610          (mm-inlined-types nil)
4611          (mail-parse-charset gnus-newsgroup-charset)
4612          (mail-parse-ignored-charsets
4613           (with-current-buffer gnus-summary-buffer
4614             gnus-newsgroup-ignored-charsets)))
4615     (when handle
4616       (if (mm-handle-undisplayer handle)
4617           (mm-remove-part handle)
4618         (mm-display-part handle)))))
4619
4620 (defun gnus-mime-view-part-internally (&optional handle)
4621   "View the MIME part under point with an internal viewer.
4622 If no internal viewer is available, use an external viewer."
4623   (interactive)
4624   (gnus-article-check-buffer)
4625   (let* ((handle (or handle (get-text-property (point) 'gnus-data)))
4626          (mm-inlined-types '(".*"))
4627          (mm-inline-large-images t)
4628          (mail-parse-charset gnus-newsgroup-charset)
4629          (mail-parse-ignored-charsets
4630           (with-current-buffer gnus-summary-buffer
4631             gnus-newsgroup-ignored-charsets))
4632          (inhibit-read-only t))
4633     (when handle
4634       (if (mm-handle-undisplayer handle)
4635           (mm-remove-part handle)
4636         (mm-display-part handle)))))
4637
4638 (defun gnus-mime-action-on-part (&optional action)
4639   "Do something with the MIME attachment at \(point\)."
4640   (interactive
4641    (list (completing-read "Action: " gnus-mime-action-alist nil t)))
4642   (gnus-article-check-buffer)
4643   (let ((action-pair (assoc action gnus-mime-action-alist)))
4644     (if action-pair
4645         (funcall (cdr action-pair)))))
4646
4647 (defun gnus-article-part-wrapper (n function &optional no-handle interactive)
4648   "Call FUNCTION on MIME part N.
4649 Unless NO-HANDLE, call FUNCTION with N-th MIME handle as it's only argument.
4650 If INTERACTIVE, call FUNCTION interactivly."
4651   (let (window frame)
4652     ;; Check whether the article is displayed.
4653     (unless (and (gnus-buffer-live-p gnus-article-buffer)
4654                  (setq window (get-buffer-window gnus-article-buffer t))
4655                  (frame-visible-p (setq frame (window-frame window))))
4656       (error "No article is displayed"))
4657     (with-current-buffer gnus-article-buffer
4658       ;; Check whether the article displays the right contents.
4659       (unless (with-current-buffer gnus-summary-buffer
4660                 (eq gnus-current-article (gnus-summary-article-number)))
4661         (error "You should select the right article first"))
4662       ;; Check whether the specified part exists.
4663       (when (> n (length gnus-article-mime-handle-alist))
4664         (error "No such part")))
4665     (unless
4666         (progn
4667           ;; To select the window is needed so that the cursor
4668           ;; might be visible on the MIME button.
4669           (select-window (prog1
4670                              window
4671                            (setq window (selected-window))
4672                            ;; Article may be displayed in the other frame.
4673                            (gnus-select-frame-set-input-focus
4674                             (prog1
4675                                 frame
4676                               (setq frame (selected-frame))))))
4677           (when (gnus-article-goto-part n)
4678             ;; We point the cursor and the arrow at the MIME button
4679             ;; when the `function' prompt the user for something.
4680             (let ((cursor-in-non-selected-windows t)
4681                   (overlay-arrow-string "=>")
4682                   (overlay-arrow-position (point-marker)))
4683               (unwind-protect
4684                   (cond
4685                    ((and no-handle interactive)
4686                     (call-interactively function))
4687                    (no-handle
4688                     (funcall function))
4689                    (interactive
4690                     (call-interactively
4691                      function
4692                      (cdr (assq n gnus-article-mime-handle-alist))))
4693                    (t
4694                     (funcall function
4695                              (cdr (assq n gnus-article-mime-handle-alist)))))
4696                 (set-marker overlay-arrow-position nil)
4697                 (unless gnus-auto-select-part
4698                   (gnus-select-frame-set-input-focus frame)
4699                   (select-window window))))
4700             t))
4701       (if gnus-inhibit-mime-unbuttonizing
4702           ;; This is the default though the program shouldn't reach here.
4703           (error "No such part")
4704         ;; The part which doesn't have the MIME button is selected.
4705         ;; So, we display all the buttons and redo it.
4706         (let ((gnus-inhibit-mime-unbuttonizing t))
4707           (gnus-summary-show-article)
4708           (gnus-article-part-wrapper n function no-handle))))))
4709
4710 (defun gnus-article-pipe-part (n)
4711   "Pipe MIME part N, which is the numerical prefix."
4712   (interactive "p")
4713   (gnus-article-part-wrapper n 'mm-pipe-part))
4714
4715 (defun gnus-article-save-part (n)
4716   "Save MIME part N, which is the numerical prefix."
4717   (interactive "p")
4718   (gnus-article-part-wrapper n 'mm-save-part))
4719
4720 (defun gnus-article-interactively-view-part (n)
4721   "View MIME part N interactively, which is the numerical prefix."
4722   (interactive "p")
4723   (gnus-article-part-wrapper n 'mm-interactively-view-part))
4724
4725 (defun gnus-article-copy-part (n)
4726   "Copy MIME part N, which is the numerical prefix."
4727   (interactive "p")
4728   (gnus-article-part-wrapper n 'gnus-mime-copy-part))
4729
4730 (defun gnus-article-view-part-as-charset (n)
4731   "View MIME part N using a specified charset.
4732 N is the numerical prefix."
4733   (interactive "p")
4734   (gnus-article-part-wrapper n 'gnus-mime-view-part-as-charset))
4735
4736 (defun gnus-article-view-part-externally (n)
4737   "View MIME part N externally, which is the numerical prefix."
4738   (interactive "p")
4739   (gnus-article-part-wrapper n 'gnus-mime-view-part-externally))
4740
4741 (defun gnus-article-inline-part (n)
4742   "Inline MIME part N, which is the numerical prefix."
4743   (interactive "p")
4744   (gnus-article-part-wrapper n 'gnus-mime-inline-part))
4745
4746 (defun gnus-article-save-part-and-strip (n)
4747   "Save MIME part N and replace it with an external body.
4748 N is the numerical prefix."
4749   (interactive "p")
4750   (gnus-article-part-wrapper n 'gnus-mime-save-part-and-strip t))
4751
4752 (defun gnus-article-replace-part (n)
4753   "Replace MIME part N with an external body.
4754 N is the numerical prefix."
4755   (interactive "p")
4756   (gnus-article-part-wrapper n 'gnus-mime-replace-part t t))
4757
4758 (defun gnus-article-delete-part (n)
4759   "Delete MIME part N and add some information about the removed part.
4760 N is the numerical prefix."
4761   (interactive "p")
4762   (gnus-article-part-wrapper n 'gnus-mime-delete-part t))
4763
4764 (defun gnus-article-mime-match-handle-first (condition)
4765   (if condition
4766       (let (n)
4767         (dolist (ihandle gnus-article-mime-handle-alist)
4768           (if (and (cond
4769                     ((functionp condition)
4770                      (funcall condition (cdr ihandle)))
4771                     ((eq condition 'undisplayed)
4772                      (not (or (mm-handle-undisplayer (cdr ihandle))
4773                               (equal (mm-handle-media-type (cdr ihandle))
4774                                      "multipart/alternative"))))
4775                     ((eq condition 'undisplayed-alternative)
4776                      (not (mm-handle-undisplayer (cdr ihandle))))
4777                     (t t))
4778                    (gnus-article-goto-part (car ihandle))
4779                    (or (not n) (< (car ihandle) n)))
4780               (setq n (car ihandle))))
4781         (or n 1))
4782     1))
4783
4784 (defun gnus-article-view-part (&optional n)
4785   "View MIME part N, which is the numerical prefix."
4786   (interactive "P")
4787   (with-current-buffer gnus-article-buffer
4788     (or (numberp n) (setq n (gnus-article-mime-match-handle-first
4789                              gnus-article-mime-match-handle-function)))
4790     (when (> n (length gnus-article-mime-handle-alist))
4791       (error "No such part"))
4792     (let ((handle (cdr (assq n gnus-article-mime-handle-alist))))
4793       (when (gnus-article-goto-part n)
4794         (if (equal (car handle) "multipart/alternative")
4795             (gnus-article-press-button)
4796           (when (eq (gnus-mm-display-part handle) 'internal)
4797             (gnus-set-window-start)))))))
4798
4799 (defsubst gnus-article-mime-total-parts ()
4800   (if (bufferp (car gnus-article-mime-handles))
4801       1 ;; single part
4802     (1- (length gnus-article-mime-handles))))
4803
4804 (defun gnus-mm-display-part (handle)
4805   "Display HANDLE and fix MIME button."
4806   (let ((id (get-text-property (point) 'gnus-part))
4807         (point (point))
4808         (inhibit-read-only t))
4809     (forward-line 1)
4810     (prog1
4811         (let ((window (selected-window))
4812               (mail-parse-charset gnus-newsgroup-charset)
4813               (mail-parse-ignored-charsets
4814                (if (gnus-buffer-live-p gnus-summary-buffer)
4815                    (with-current-buffer gnus-summary-buffer
4816                      gnus-newsgroup-ignored-charsets)
4817                  nil)))
4818           (save-excursion
4819             (unwind-protect
4820                 (let ((win (gnus-get-buffer-window (current-buffer) t))
4821                       (beg (point)))
4822                   (when win
4823                     (select-window win))
4824                   (goto-char point)
4825                   (forward-line)
4826                   (if (mm-handle-displayed-p handle)
4827                       ;; This will remove the part.
4828                       (mm-display-part handle)
4829                     (save-restriction
4830                       (narrow-to-region (point)
4831                                         (if (eobp) (point) (1+ (point))))
4832                       (mm-display-part handle)
4833                       ;; We narrow to the part itself and
4834                       ;; then call the treatment functions.
4835                       (goto-char (point-min))
4836                       (forward-line 1)
4837                       (narrow-to-region (point) (point-max))
4838                       (gnus-treat-article
4839                        nil id
4840                        (gnus-article-mime-total-parts)
4841                        (mm-handle-media-type handle)))))
4842               (if (window-live-p window)
4843                   (select-window window)))))
4844       (goto-char point)
4845       (gnus-delete-line)
4846       (gnus-insert-mime-button
4847        handle id (list (mm-handle-displayed-p handle)))
4848       (goto-char point))))
4849
4850 (defun gnus-article-goto-part (n)
4851   "Go to MIME part N."
4852   (gnus-goto-char (text-property-any (point-min) (point-max) 'gnus-part n)))
4853
4854 (defun gnus-insert-mime-button (handle gnus-tmp-id &optional displayed)
4855   (let ((gnus-tmp-name
4856          (or (mail-content-type-get (mm-handle-type handle) 'name)
4857              (mail-content-type-get (mm-handle-disposition handle) 'filename)
4858              (mail-content-type-get (mm-handle-type handle) 'url)
4859              ""))
4860         (gnus-tmp-type (mm-handle-media-type handle))
4861         (gnus-tmp-description
4862          (mail-decode-encoded-word-string (or (mm-handle-description handle)
4863                                               "")))
4864         (gnus-tmp-dots
4865          (if (if displayed (car displayed)
4866                (mm-handle-displayed-p handle))
4867              "" "..."))
4868         (gnus-tmp-length (with-current-buffer (mm-handle-buffer handle)
4869                            (buffer-size)))
4870         gnus-tmp-type-long b e)
4871     (when (string-match ".*/" gnus-tmp-name)
4872       (setq gnus-tmp-name (replace-match "" t t gnus-tmp-name)))
4873     (setq gnus-tmp-type-long (concat gnus-tmp-type
4874                                      (and (not (equal gnus-tmp-name ""))
4875                                           (concat "; " gnus-tmp-name))))
4876     (unless (equal gnus-tmp-description "")
4877       (setq gnus-tmp-type-long (concat " --- " gnus-tmp-type-long)))
4878     (unless (bolp)
4879       (insert "\n"))
4880     (setq b (point))
4881     (gnus-eval-format
4882      gnus-mime-button-line-format gnus-mime-button-line-format-alist
4883      `(keymap ,gnus-mime-button-map
4884               gnus-callback gnus-mm-display-part
4885               gnus-part ,gnus-tmp-id
4886               article-type annotation
4887               gnus-data ,handle))
4888     (setq e (if (bolp)
4889                 ;; Exclude a newline.
4890                 (1- (point))
4891               (point)))
4892     (widget-convert-button
4893      'link b e
4894      :mime-handle handle
4895      :action 'gnus-widget-press-button
4896      :button-keymap gnus-mime-button-map
4897      :help-echo
4898      (lambda (widget/window &optional overlay pos)
4899        ;; Needed to properly clear the message due to a bug in
4900        ;; wid-edit (XEmacs only).
4901        (if (boundp 'help-echo-owns-message)
4902            (setq help-echo-owns-message t))
4903        (format
4904         "%S: %s the MIME part; %S: more options"
4905         (aref gnus-mouse-2 0)
4906         ;; XEmacs will get a single widget arg; Emacs 21 will get
4907         ;; window, overlay, position.
4908         (if (mm-handle-displayed-p
4909              (if overlay
4910                  (with-current-buffer (gnus-overlay-buffer overlay)
4911                    (widget-get (widget-at (gnus-overlay-start overlay))
4912                                :mime-handle))
4913                (widget-get widget/window :mime-handle)))
4914             "hide" "show")
4915         (aref gnus-down-mouse-3 0))))))
4916
4917 (defun gnus-widget-press-button (elems el)
4918   (goto-char (widget-get elems :from))
4919   (gnus-article-press-button))
4920
4921 (defvar gnus-displaying-mime nil)
4922
4923 (defun gnus-display-mime (&optional ihandles)
4924   "Display the MIME parts."
4925   (save-excursion
4926     (save-selected-window
4927       (let ((window (get-buffer-window gnus-article-buffer))
4928             (point (point)))
4929         (when window
4930           (select-window window)
4931           ;; We have to do this since selecting the window
4932           ;; may change the point.  So we set the window point.
4933           (set-window-point window point)))
4934       (let ((handles ihandles)
4935             (inhibit-read-only t)
4936             handle)
4937         (cond (handles)
4938               ((setq handles (mm-dissect-buffer nil gnus-article-loose-mime))
4939                (when gnus-article-emulate-mime
4940                  (mm-uu-dissect-text-parts handles)))
4941               (gnus-article-emulate-mime
4942                (setq handles (mm-uu-dissect))))
4943         (when (and (not ihandles)
4944                    (not gnus-displaying-mime))
4945           ;; Top-level call; we clean up.
4946           (when gnus-article-mime-handles
4947             (mm-destroy-parts gnus-article-mime-handles)
4948             (setq gnus-article-mime-handle-alist nil));; A trick.
4949           (setq gnus-article-mime-handles handles)
4950           ;; We allow users to glean info from the handles.
4951           (when gnus-article-mime-part-function
4952             (gnus-mime-part-function handles)))
4953         (if (and handles
4954                  (or (not (stringp (car handles)))
4955                      (cdr handles)))
4956             (progn
4957               (when (and (not ihandles)
4958                          (not gnus-displaying-mime))
4959                 ;; Clean up for mime parts.
4960                 (article-goto-body)
4961                 (delete-region (point) (point-max)))
4962               (let ((gnus-displaying-mime t))
4963                 (gnus-mime-display-part handles)))
4964           (save-restriction
4965             (article-goto-body)
4966             (narrow-to-region (point) (point-max))
4967             (gnus-treat-article nil 1 1)
4968             (widen)))
4969         (unless ihandles
4970           ;; Highlight the headers.
4971           (save-excursion
4972             (save-restriction
4973               (article-goto-body)
4974               (narrow-to-region (point-min) (point))
4975               (gnus-article-save-original-date
4976                (gnus-treat-article 'head)))))))))
4977
4978 (defcustom gnus-mime-display-multipart-as-mixed nil
4979   "Display \"multipart\" parts as  \"multipart/mixed\".
4980
4981 If t, it overrides nil values of
4982 `gnus-mime-display-multipart-alternative-as-mixed' and
4983 `gnus-mime-display-multipart-related-as-mixed'."
4984   :group 'gnus-article-mime
4985   :type 'boolean)
4986
4987 (defcustom gnus-mime-display-multipart-alternative-as-mixed nil
4988   "Display \"multipart/alternative\" parts as  \"multipart/mixed\"."
4989   :version "22.1"
4990   :group 'gnus-article-mime
4991   :type 'boolean)
4992
4993 (defcustom gnus-mime-display-multipart-related-as-mixed nil
4994   "Display \"multipart/related\" parts as  \"multipart/mixed\".
4995
4996 If displaying \"text/html\" is discouraged \(see
4997 `mm-discouraged-alternatives'\) images or other material inside a
4998 \"multipart/related\" part might be overlooked when this variable is nil."
4999   :version "22.1"
5000   :group 'gnus-article-mime
5001   :type 'boolean)
5002
5003 (defun gnus-mime-display-part (handle)
5004   (cond
5005    ;; Maybe a broken MIME message.
5006    ((null handle))
5007    ;; Single part.
5008    ((not (stringp (car handle)))
5009     (gnus-mime-display-single handle))
5010    ;; User-defined multipart
5011    ((cdr (assoc (car handle) gnus-mime-multipart-functions))
5012     (funcall (cdr (assoc (car handle) gnus-mime-multipart-functions))
5013              handle))
5014    ;; multipart/alternative
5015    ((and (equal (car handle) "multipart/alternative")
5016          (not (or gnus-mime-display-multipart-as-mixed
5017                   gnus-mime-display-multipart-alternative-as-mixed)))
5018     (let ((id (1+ (length gnus-article-mime-handle-alist))))
5019       (push (cons id handle) gnus-article-mime-handle-alist)
5020       (gnus-mime-display-alternative (cdr handle) nil nil id)))
5021    ;; multipart/related
5022    ((and (equal (car handle) "multipart/related")
5023          (not (or gnus-mime-display-multipart-as-mixed
5024                   gnus-mime-display-multipart-related-as-mixed)))
5025     ;;;!!!We should find the start part, but we just default
5026     ;;;!!!to the first part.
5027     ;;(gnus-mime-display-part (cadr handle))
5028     ;;;!!! Most multipart/related is an HTML message plus images.
5029     ;;;!!! Unfortunately we are unable to let W3 display those
5030     ;;;!!! included images, so we just display it as a mixed multipart.
5031     ;;(gnus-mime-display-mixed (cdr handle))
5032     ;;;!!! No, w3 can display everything just fine.
5033     (gnus-mime-display-part (cadr handle)))
5034    ((equal (car handle) "multipart/signed")
5035     (gnus-add-wash-type 'signed)
5036     (gnus-mime-display-security handle))
5037    ((equal (car handle) "multipart/encrypted")
5038     (gnus-add-wash-type 'encrypted)
5039     (gnus-mime-display-security handle))
5040    ;; Other multiparts are handled like multipart/mixed.
5041    (t
5042     (gnus-mime-display-mixed (cdr handle)))))
5043
5044 (defun gnus-mime-part-function (handles)
5045   (if (stringp (car handles))
5046       (mapcar 'gnus-mime-part-function (cdr handles))
5047     (funcall gnus-article-mime-part-function handles)))
5048
5049 (defun gnus-mime-display-mixed (handles)
5050   (mapcar 'gnus-mime-display-part handles))
5051
5052 (defun gnus-mime-display-single (handle)
5053   (let ((type (mm-handle-media-type handle))
5054         (ignored gnus-ignored-mime-types)
5055         (not-attachment t)
5056         (move nil)
5057         display text)
5058     (catch 'ignored
5059       (progn
5060         (while ignored
5061           (when (string-match (pop ignored) type)
5062             (throw 'ignored nil)))
5063         (if (and (setq not-attachment
5064                        (and (not (mm-inline-override-p handle))
5065                             (or (not (mm-handle-disposition handle))
5066                                 (equal (car (mm-handle-disposition handle))
5067                                        "inline")
5068                                 (mm-attachment-override-p handle))))
5069                  (mm-automatic-display-p handle)
5070                  (or (and
5071                       (mm-inlinable-p handle)
5072                       (mm-inlined-p handle))
5073                      (mm-automatic-external-display-p type)))
5074             (setq display t)
5075           (when (equal (mm-handle-media-supertype handle) "text")
5076             (setq text t)))
5077         (let ((id (1+ (length gnus-article-mime-handle-alist)))
5078               beg)
5079           (push (cons id handle) gnus-article-mime-handle-alist)
5080           (when (or (not display)
5081                     (not (gnus-unbuttonized-mime-type-p type)))
5082             (gnus-insert-mime-button
5083              handle id (list (or display (and not-attachment text))))
5084             (gnus-article-insert-newline)
5085             ;; Remember modify the number of forward lines.
5086             (setq move t))
5087           (setq beg (point))
5088           (cond
5089            (display
5090             (when move
5091               (forward-line -1)
5092               (setq beg (point)))
5093             (let ((mail-parse-charset gnus-newsgroup-charset)
5094                   (mail-parse-ignored-charsets
5095                    (save-excursion (condition-case ()
5096                                        (set-buffer gnus-summary-buffer)
5097                                      (error))
5098                                    gnus-newsgroup-ignored-charsets)))
5099               (mm-display-part handle t))
5100             (goto-char (point-max)))
5101            ((and text not-attachment)
5102             (when move
5103               (forward-line -1)
5104               (setq beg (point)))
5105             (gnus-article-insert-newline)
5106             (mm-insert-inline
5107              handle
5108              (let ((charset (mail-content-type-get (mm-handle-type handle)
5109                                                    'charset)))
5110                (cond ((not charset)
5111                       (mm-string-as-multibyte (mm-get-part handle)))
5112                      ((eq charset 'gnus-decoded)
5113                       (with-current-buffer (mm-handle-buffer handle)
5114                         (buffer-string)))
5115                      (t
5116                       (mm-decode-string (mm-get-part handle) charset)))))
5117             (goto-char (point-max))))
5118           ;; Do highlighting.
5119           (save-excursion
5120             (save-restriction
5121               (narrow-to-region beg (point))
5122               (gnus-treat-article
5123                nil id
5124                (gnus-article-mime-total-parts)
5125                (mm-handle-media-type handle)))))))))
5126
5127 (defun gnus-unbuttonized-mime-type-p (type)
5128   "Say whether TYPE is to be unbuttonized."
5129   (unless gnus-inhibit-mime-unbuttonizing
5130     (when (catch 'found
5131             (let ((types gnus-unbuttonized-mime-types))
5132               (while types
5133                 (when (string-match (pop types) type)
5134                   (throw 'found t)))))
5135       (not (catch 'found
5136              (let ((types gnus-buttonized-mime-types))
5137                (while types
5138                  (when (string-match (pop types) type)
5139                    (throw 'found t)))))))))
5140
5141 (defun gnus-article-insert-newline ()
5142   "Insert a newline, but mark it as undeletable."
5143   (gnus-put-text-property
5144    (point) (progn (insert "\n") (point)) 'gnus-undeletable t))
5145
5146 (defun gnus-mime-display-alternative (handles &optional preferred ibegend id)
5147   (let* ((preferred (or preferred (mm-preferred-alternative handles)))
5148          (ihandles handles)
5149          (point (point))
5150          handle (inhibit-read-only t) from props begend not-pref)
5151     (save-window-excursion
5152       (save-restriction
5153         (when ibegend
5154           (narrow-to-region (car ibegend)
5155                             (or (cdr ibegend)
5156                                 (progn
5157                                   (goto-char (car ibegend))
5158                                   (forward-line 2)
5159                                   (point))))
5160           (delete-region (point-min) (point-max))
5161           (mm-remove-parts handles))
5162         (setq begend (list (point-marker)))
5163         ;; Do the toggle.
5164         (unless (setq not-pref (cadr (member preferred ihandles)))
5165           (setq not-pref (car ihandles)))
5166         (when (or ibegend
5167                   (not preferred)
5168                   (not (gnus-unbuttonized-mime-type-p
5169                         "multipart/alternative")))
5170           (gnus-add-text-properties
5171            (setq from (point))
5172            (progn
5173              (insert (format "%d.  " id))
5174              (point))
5175            `(gnus-callback
5176              (lambda (handles)
5177                (unless ,(not ibegend)
5178                  (setq gnus-article-mime-handle-alist
5179                        ',gnus-article-mime-handle-alist))
5180                (gnus-mime-display-alternative
5181                 ',ihandles ',not-pref ',begend ,id))
5182              keymap ,gnus-mime-button-map
5183              ,gnus-mouse-face-prop ,gnus-article-mouse-face
5184              face ,gnus-article-button-face
5185              gnus-part ,id
5186              article-type multipart))
5187           (widget-convert-button 'link from (point)
5188                                  :action 'gnus-widget-press-button
5189                                  :button-keymap gnus-widget-button-keymap)
5190           ;; Do the handles
5191           (while (setq handle (pop handles))
5192             (gnus-add-text-properties
5193              (setq from (point))
5194              (progn
5195                (insert (format "(%c) %-18s"
5196                                (if (equal handle preferred) ?* ? )
5197                                (mm-handle-media-type handle)))
5198                (point))
5199              `(gnus-callback
5200                (lambda (handles)
5201                  (unless ,(not ibegend)
5202                    (setq gnus-article-mime-handle-alist
5203                          ',gnus-article-mime-handle-alist))
5204                  (gnus-mime-display-alternative
5205                   ',ihandles ',handle ',begend ,id))
5206                keymap ,gnus-mime-button-map
5207                ,gnus-mouse-face-prop ,gnus-article-mouse-face
5208                face ,gnus-article-button-face
5209                gnus-part ,id
5210                gnus-data ,handle))
5211             (widget-convert-button 'link from (point)
5212                                    :action 'gnus-widget-press-button
5213                                    :button-keymap gnus-widget-button-keymap)
5214             (insert "  "))
5215           (insert "\n\n"))
5216         (when preferred
5217           (if (stringp (car preferred))
5218               (gnus-display-mime preferred)
5219             (let ((mail-parse-charset gnus-newsgroup-charset)
5220                   (mail-parse-ignored-charsets
5221                    (with-current-buffer gnus-summary-buffer
5222                      gnus-newsgroup-ignored-charsets)))
5223               (mm-display-part preferred)
5224               ;; Do highlighting.
5225               (save-excursion
5226                 (save-restriction
5227                   (narrow-to-region (car begend) (point-max))
5228                   (gnus-treat-article
5229                    nil (length gnus-article-mime-handle-alist)
5230                    (gnus-article-mime-total-parts)
5231                    (mm-handle-media-type handle))))))
5232           (goto-char (point-max))
5233           (setcdr begend (point-marker)))))
5234     (when ibegend
5235       (goto-char point))))
5236
5237 (defconst gnus-article-wash-status-strings
5238   (let ((alist '((cite "c" "Possible hidden citation text"
5239                        " " "All citation text visible")
5240                  (headers "h" "Hidden headers"
5241                           " " "All headers visible.")
5242                  (pgp "p" "Encrypted or signed message status hidden"
5243                       " " "No hidden encryption nor digital signature status")
5244                  (signature "s" "Signature has been hidden"
5245                             " " "Signature is visible")
5246                  (overstrike "o" "Overstrike (^H) characters applied"
5247                              " " "No overstrike characters applied")
5248                  (emphasis "e" "/*_Emphasis_*/ characters applied"
5249                            " " "No /*_emphasis_*/ characters applied")))
5250         result)
5251     (dolist (entry alist result)
5252       (let ((key (nth 0 entry))
5253             (on (copy-sequence (nth 1 entry)))
5254             (on-help (nth 2 entry))
5255             (off (copy-sequence (nth 3 entry)))
5256             (off-help (nth 4 entry)))
5257         (put-text-property 0 1 'help-echo on-help on)
5258         (put-text-property 0 1 'help-echo off-help off)
5259         (push (list key on off) result))))
5260   "Alist of strings describing wash status in the mode line.
5261 Each entry has the form (KEY ON OF), where the KEY is a symbol
5262 representing the particular washing function, ON is the string to use
5263 in the article mode line when the washing function is active, and OFF
5264 is the string to use when it is inactive.")
5265
5266 (defun gnus-article-wash-status-entry (key value)
5267   (let ((entry (assoc key gnus-article-wash-status-strings)))
5268     (if value (nth 1 entry) (nth 2 entry))))
5269
5270 (defun gnus-article-wash-status ()
5271   "Return a string which display status of article washing."
5272   (with-current-buffer gnus-article-buffer
5273     (let ((cite (memq 'cite gnus-article-wash-types))
5274           (headers (memq 'headers gnus-article-wash-types))
5275           (boring (memq 'boring-headers gnus-article-wash-types))
5276           (pgp (memq 'pgp gnus-article-wash-types))
5277           (pem (memq 'pem gnus-article-wash-types))
5278           (signed (memq 'signed gnus-article-wash-types))
5279           (encrypted (memq 'encrypted gnus-article-wash-types))
5280           (signature (memq 'signature gnus-article-wash-types))
5281           (overstrike (memq 'overstrike gnus-article-wash-types))
5282           (emphasis (memq 'emphasis gnus-article-wash-types)))
5283       (concat
5284        (gnus-article-wash-status-entry 'cite cite)
5285        (gnus-article-wash-status-entry 'headers (or headers boring))
5286        (gnus-article-wash-status-entry 'pgp (or pgp pem signed encrypted))
5287        (gnus-article-wash-status-entry 'signature signature)
5288        (gnus-article-wash-status-entry 'overstrike overstrike)
5289        (gnus-article-wash-status-entry 'emphasis emphasis)))))
5290
5291 (defun gnus-add-wash-type (type)
5292   "Add a washing of TYPE to the current status."
5293   (add-to-list 'gnus-article-wash-types type))
5294
5295 (defun gnus-delete-wash-type (type)
5296   "Add a washing of TYPE to the current status."
5297   (setq gnus-article-wash-types (delq type gnus-article-wash-types)))
5298
5299 (defun gnus-add-image (category image)
5300   "Add IMAGE of CATEGORY to the list of displayed images."
5301   (let ((entry (assq category gnus-article-image-alist)))
5302     (unless entry
5303       (setq entry (list category))
5304       (push entry gnus-article-image-alist))
5305     (nconc entry (list image))))
5306
5307 (defun gnus-delete-images (category)
5308   "Delete all images in CATEGORY."
5309   (let ((entry (assq category gnus-article-image-alist)))
5310     (dolist (image (cdr entry))
5311       (gnus-remove-image image category))
5312     (setq gnus-article-image-alist (delq entry gnus-article-image-alist))
5313     (gnus-delete-wash-type category)))
5314
5315 (defalias 'gnus-article-hide-headers-if-wanted 'gnus-article-maybe-hide-headers)
5316
5317 (defun gnus-article-maybe-hide-headers ()
5318   "Hide unwanted headers if `gnus-have-all-headers' is nil.
5319 Provided for backwards compatibility."
5320   (when (and (or (not (gnus-buffer-live-p gnus-summary-buffer))
5321                  (not (with-current-buffer gnus-summary-buffer
5322                         gnus-have-all-headers)))
5323              (not gnus-inhibit-hiding))
5324     (gnus-article-hide-headers)))
5325
5326 ;;; Article savers.
5327
5328 (defun gnus-output-to-file (file-name)
5329   "Append the current article to a file named FILE-NAME."
5330   (let ((artbuf (current-buffer)))
5331     (with-temp-buffer
5332       (insert-buffer-substring artbuf)
5333       ;; Append newline at end of the buffer as separator, and then
5334       ;; save it to file.
5335       (goto-char (point-max))
5336       (insert "\n")
5337       (let ((file-name-coding-system nnmail-pathname-coding-system))
5338         (mm-append-to-file (point-min) (point-max) file-name))
5339       t)))
5340
5341 (defun gnus-narrow-to-page (&optional arg)
5342   "Narrow the article buffer to a page.
5343 If given a numerical ARG, move forward ARG pages."
5344   (interactive "P")
5345   (setq arg (if arg (prefix-numeric-value arg) 0))
5346   (save-excursion
5347     (set-buffer gnus-article-buffer)
5348     (goto-char (point-min))
5349     (widen)
5350     ;; Remove any old next/prev buttons.
5351     (when (gnus-visual-p 'page-marker)
5352       (let ((inhibit-read-only t))
5353         (gnus-remove-text-with-property 'gnus-prev)
5354         (gnus-remove-text-with-property 'gnus-next)))
5355     (if
5356         (cond ((< arg 0)
5357                (re-search-backward page-delimiter nil 'move (1+ (abs arg))))
5358               ((> arg 0)
5359                (re-search-forward page-delimiter nil 'move arg)))
5360         (goto-char (match-end 0))
5361       (save-excursion
5362         (goto-char (point-min))
5363         (setq gnus-page-broken
5364               (and (re-search-forward page-delimiter nil t) t))))
5365     (when gnus-page-broken
5366       (narrow-to-region
5367        (point)
5368        (if (re-search-forward page-delimiter nil 'move)
5369            (match-beginning 0)
5370          (point)))
5371       (when (and (gnus-visual-p 'page-marker)
5372                  (> (point-min) (save-restriction (widen) (point-min))))
5373         (save-excursion
5374           (goto-char (point-min))
5375           (gnus-insert-prev-page-button)))
5376       (when (and (gnus-visual-p 'page-marker)
5377                  (< (point-max) (save-restriction (widen) (point-max))))
5378         (save-excursion
5379           (goto-char (point-max))
5380           (gnus-insert-next-page-button))))))
5381
5382 ;; Article mode commands
5383
5384 (defun gnus-article-goto-next-page ()
5385   "Show the next page of the article."
5386   (interactive)
5387   (when (gnus-article-next-page)
5388     (goto-char (point-min))
5389     (gnus-article-read-summary-keys nil (gnus-character-to-event ?n))))
5390
5391
5392 (defun gnus-article-goto-prev-page ()
5393   "Show the previous page of the article."
5394   (interactive)
5395   (if (bobp)
5396       (gnus-article-read-summary-keys nil (gnus-character-to-event ?p))
5397     (gnus-article-prev-page nil)))
5398
5399 ;; This is cleaner but currently breaks `gnus-pick-mode':
5400 ;;
5401 ;; (defun gnus-article-goto-next-page ()
5402 ;;   "Show the next page of the article."
5403 ;;   (interactive)
5404 ;;   (gnus-eval-in-buffer-window gnus-summary-buffer
5405 ;;     (gnus-summary-next-page)))
5406 ;;
5407 ;; (defun gnus-article-goto-prev-page ()
5408 ;;   "Show the next page of the article."
5409 ;;   (interactive)
5410 ;;   (gnus-eval-in-buffer-window gnus-summary-buffer
5411 ;;     (gnus-summary-prev-page)))
5412
5413 (defun gnus-article-next-page (&optional lines)
5414   "Show the next page of the current article.
5415 If end of article, return non-nil.  Otherwise return nil.
5416 Argument LINES specifies lines to be scrolled up."
5417   (interactive "p")
5418   (move-to-window-line -1)
5419   (if (save-excursion
5420         (end-of-line)
5421         (and (pos-visible-in-window-p)  ;Not continuation line.
5422              (>= (1+ (point)) (point-max)))) ;Allow for trailing newline.
5423       ;; Nothing in this page.
5424       (if (or (not gnus-page-broken)
5425               (save-excursion
5426                 (save-restriction
5427                   (widen)
5428                   (forward-line)
5429                   (eobp)))) ;Real end-of-buffer?
5430           (progn
5431             (when gnus-article-over-scroll
5432               (gnus-article-next-page-1 lines))
5433             t)                  ;Nothing more.
5434         (gnus-narrow-to-page 1)         ;Go to next page.
5435         nil)
5436     ;; More in this page.
5437     (gnus-article-next-page-1 lines)
5438     nil))
5439
5440 (defmacro gnus-article-beginning-of-window ()
5441   "Move point to the beginning of the window.
5442 In Emacs, the point is placed at the line number which `scroll-margin'
5443 specifies."
5444   (if (featurep 'xemacs)
5445       '(move-to-window-line 0)
5446     '(move-to-window-line
5447       (min (max 0 scroll-margin)
5448            (max 1 (- (window-height)
5449                      (if mode-line-format 1 0)
5450                      (if header-line-format 1 0)))))))
5451
5452 (defun gnus-article-next-page-1 (lines)
5453   (when (and (not (featurep 'xemacs))
5454              (numberp lines)
5455              (> lines 0)
5456              (numberp (symbol-value 'scroll-margin))
5457              (> (symbol-value 'scroll-margin) 0))
5458     ;; Protect against the bug that Emacs 21.x hangs up when scrolling up for
5459     ;; too many number of lines if `scroll-margin' is set as two or greater.
5460     (setq lines (min lines
5461                      (max 0 (- (count-lines (window-start) (point-max))
5462                                (symbol-value 'scroll-margin))))))
5463   (condition-case ()
5464       (let ((scroll-in-place nil))
5465         (scroll-up lines))
5466     (end-of-buffer
5467      ;; Long lines may cause an end-of-buffer error.
5468      (goto-char (point-max))))
5469   (gnus-article-beginning-of-window))
5470
5471 (defun gnus-article-prev-page (&optional lines)
5472   "Show previous page of current article.
5473 Argument LINES specifies lines to be scrolled down."
5474   (interactive "p")
5475   (move-to-window-line 0)
5476   (if (and gnus-page-broken
5477            (bobp)
5478            (not (save-restriction (widen) (bobp)))) ;Real beginning-of-buffer?
5479       (progn
5480         (gnus-narrow-to-page -1)        ;Go to previous page.
5481         (goto-char (point-max))
5482         (recenter -1))
5483     (prog1
5484         (condition-case ()
5485             (let ((scroll-in-place nil))
5486               (scroll-down lines))
5487           (beginning-of-buffer
5488            (goto-char (point-min))))
5489       (gnus-article-beginning-of-window))))
5490
5491 (defun gnus-article-only-boring-p ()
5492   "Decide whether there is only boring text remaining in the article.
5493 Something \"interesting\" is a word of at least two letters that does
5494 not have a face in `gnus-article-boring-faces'."
5495   (when (and gnus-article-skip-boring
5496              (boundp 'gnus-article-boring-faces)
5497              (symbol-value 'gnus-article-boring-faces))
5498     (save-excursion
5499       (catch 'only-boring
5500         (while (re-search-forward "\\b\\w\\w" nil t)
5501           (forward-char -1)
5502           (when (not (gnus-intersection
5503                       (gnus-faces-at (point))
5504                       (symbol-value 'gnus-article-boring-faces)))
5505             (throw 'only-boring nil)))
5506         (throw 'only-boring t)))))
5507
5508 (defun gnus-article-refer-article ()
5509   "Read article specified by message-id around point."
5510   (interactive)
5511   (save-excursion
5512     (re-search-backward "[ \t]\\|^" (point-at-bol) t)
5513     (re-search-forward "<?news:<?\\|<" (point-at-eol) t)
5514     (if (re-search-forward "[^@ ]+@[^ \t>]+" (point-at-eol) t)
5515         (let ((msg-id (concat "<" (match-string 0) ">")))
5516           (set-buffer gnus-summary-buffer)
5517           (gnus-summary-refer-article msg-id))
5518       (error "No references around point"))))
5519
5520 (defun gnus-article-show-summary ()
5521   "Reconfigure windows to show summary buffer."
5522   (interactive)
5523   (if (not (gnus-buffer-live-p gnus-summary-buffer))
5524       (error "There is no summary buffer for this article buffer")
5525     (gnus-article-set-globals)
5526     (gnus-configure-windows 'article)
5527     (gnus-summary-goto-subject gnus-current-article)
5528     (gnus-summary-position-point)))
5529
5530 (defun gnus-article-describe-briefly ()
5531   "Describe article mode commands briefly."
5532   (interactive)
5533   (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")))
5534
5535 (defun gnus-article-summary-command ()
5536   "Execute the last keystroke in the summary buffer."
5537   (interactive)
5538   (let ((obuf (current-buffer))
5539         (owin (current-window-configuration))
5540         func)
5541     (switch-to-buffer gnus-article-current-summary 'norecord)
5542     (setq func (lookup-key (current-local-map) (this-command-keys)))
5543     (call-interactively func)
5544     (set-buffer obuf)
5545     (set-window-configuration owin)
5546     (set-window-point (get-buffer-window (current-buffer)) (point))))
5547
5548 (defun gnus-article-summary-command-nosave ()
5549   "Execute the last keystroke in the summary buffer."
5550   (interactive)
5551   (let (func)
5552     (pop-to-buffer gnus-article-current-summary 'norecord)
5553     (setq func (lookup-key (current-local-map) (this-command-keys)))
5554     (call-interactively func)))
5555
5556 (defun gnus-article-check-buffer ()
5557   "Beep if not in an article buffer."
5558   (unless (equal major-mode 'gnus-article-mode)
5559     (error "Command invoked outside of a Gnus article buffer")))
5560
5561 (defun gnus-article-read-summary-keys (&optional arg key not-restore-window)
5562   "Read a summary buffer key sequence and execute it from the article buffer."
5563   (interactive "P")
5564   (gnus-article-check-buffer)
5565   (let ((nosaves
5566          '("q" "Q"  "c" "r" "\C-c\C-f" "m"  "a" "f"
5567            "Zc" "ZC" "ZE" "ZQ" "ZZ" "Zn" "ZR" "ZG" "ZN" "ZP"
5568            "=" "^" "\M-^" "|"))
5569         (nosave-but-article
5570          '("A\r"))
5571         (nosave-in-article
5572          '("\C-d"))
5573         (up-to-top
5574          '("n" "Gn" "p" "Gp"))
5575         keys new-sum-point)
5576     (save-excursion
5577       (set-buffer gnus-article-current-summary)
5578       (let (gnus-pick-mode)
5579         (push (or key last-command-event) unread-command-events)
5580         (setq keys (if (featurep 'xemacs)
5581                        (events-to-keys (read-key-sequence nil))
5582                      (read-key-sequence nil)))))
5583
5584     (message "")
5585
5586     (if (or (member keys nosaves)
5587             (member keys nosave-but-article)
5588             (member keys nosave-in-article))
5589         (let (func)
5590           (save-window-excursion
5591             (pop-to-buffer gnus-article-current-summary 'norecord)
5592             ;; We disable the pick minor mode commands.
5593             (let (gnus-pick-mode)
5594               (setq func (lookup-key (current-local-map) keys))))
5595           (if (or (not func)
5596                   (numberp func))
5597               (ding)
5598             (unless (member keys nosave-in-article)
5599               (set-buffer gnus-article-current-summary))
5600             (call-interactively func)
5601             (setq new-sum-point (point)))
5602           (when (member keys nosave-but-article)
5603             (pop-to-buffer gnus-article-buffer 'norecord)))
5604       ;; These commands should restore window configuration.
5605       (let ((obuf (current-buffer))
5606             (owin (current-window-configuration))
5607             (opoint (point))
5608             win func in-buffer selected new-sum-start new-sum-hscroll)
5609         (cond (not-restore-window
5610                (pop-to-buffer gnus-article-current-summary 'norecord))
5611               ((setq win (get-buffer-window gnus-article-current-summary))
5612                (select-window win))
5613               (t
5614                (switch-to-buffer gnus-article-current-summary 'norecord)))
5615         (setq in-buffer (current-buffer))
5616         ;; We disable the pick minor mode commands.
5617         (if (and (setq func (let (gnus-pick-mode)
5618                               (lookup-key (current-local-map) keys)))
5619                  (functionp func))
5620             (progn
5621               (call-interactively func)
5622               (when (eq win (selected-window))
5623                 (setq new-sum-point (point)
5624                       new-sum-start (window-start win)
5625                       new-sum-hscroll (window-hscroll win)))
5626               (when (eq in-buffer (current-buffer))
5627                 (setq selected (gnus-summary-select-article))
5628                 (set-buffer obuf)
5629                 (unless not-restore-window
5630                   (set-window-configuration owin))
5631                 (when (eq selected 'old)
5632                   (article-goto-body)
5633                   (set-window-start (get-buffer-window (current-buffer))
5634                                     1)
5635                   (set-window-point (get-buffer-window (current-buffer))
5636                                     (point)))
5637                 (when (and (not not-restore-window)
5638                            new-sum-point)
5639                   (set-window-point win new-sum-point)
5640                   (set-window-start win new-sum-start)
5641                   (set-window-hscroll win new-sum-hscroll))))
5642           (set-window-configuration owin)
5643           (ding))))))
5644
5645 (defun gnus-article-describe-key (key)
5646   "Display documentation of the function invoked by KEY.  KEY is a string."
5647   (interactive "kDescribe key: ")
5648   (gnus-article-check-buffer)
5649   (if (eq (key-binding key) 'gnus-article-read-summary-keys)
5650       (save-excursion
5651         (set-buffer gnus-article-current-summary)
5652         (let (gnus-pick-mode)
5653           (if (featurep 'xemacs)
5654               (progn
5655                 (push (elt key 0) unread-command-events)
5656                 (setq key (events-to-keys
5657                            (read-key-sequence "Describe key: "))))
5658             (setq unread-command-events
5659                   (mapcar
5660                    (lambda (x) (if (>= x 128) (list 'meta (- x 128)) x))
5661                    (string-to-list key)))
5662             (setq key (read-key-sequence "Describe key: "))))
5663         (describe-key key))
5664     (describe-key key)))
5665
5666 (defun gnus-article-describe-key-briefly (key &optional insert)
5667   "Display documentation of the function invoked by KEY.  KEY is a string."
5668   (interactive "kDescribe key: \nP")
5669   (gnus-article-check-buffer)
5670   (if (eq (key-binding key) 'gnus-article-read-summary-keys)
5671       (save-excursion
5672         (set-buffer gnus-article-current-summary)
5673         (let (gnus-pick-mode)
5674           (if (featurep 'xemacs)
5675               (progn
5676                 (push (elt key 0) unread-command-events)
5677                 (setq key (events-to-keys
5678                            (read-key-sequence "Describe key: "))))
5679             (setq unread-command-events
5680                   (mapcar
5681                    (lambda (x) (if (>= x 128) (list 'meta (- x 128)) x))
5682                    (string-to-list key)))
5683             (setq key (read-key-sequence "Describe key: "))))
5684         (describe-key-briefly key insert))
5685     (describe-key-briefly key insert)))
5686
5687 (defun gnus-article-reply-with-original (&optional wide)
5688   "Start composing a reply mail to the current message.
5689 The text in the region will be yanked.  If the region isn't active,
5690 the entire article will be yanked."
5691   (interactive "P")
5692   (let ((article (cdr gnus-article-current))
5693         contents)
5694     (if (not (gnus-region-active-p))
5695         (with-current-buffer gnus-summary-buffer
5696           (gnus-summary-reply (list (list article)) wide))
5697       (setq contents (buffer-substring (point) (mark t)))
5698       ;; Deactivate active regions.
5699       (when (and (boundp 'transient-mark-mode)
5700                  transient-mark-mode)
5701         (setq mark-active nil))
5702       (with-current-buffer gnus-summary-buffer
5703         (gnus-summary-reply
5704          (list (list article contents)) wide)))))
5705
5706 (defun gnus-article-followup-with-original ()
5707   "Compose a followup to the current article.
5708 The text in the region will be yanked.  If the region isn't active,
5709 the entire article will be yanked."
5710   (interactive)
5711   (let ((article (cdr gnus-article-current))
5712         contents)
5713       (if (not (gnus-region-active-p))
5714           (with-current-buffer gnus-summary-buffer
5715             (gnus-summary-followup (list (list article))))
5716         (setq contents (buffer-substring (point) (mark t)))
5717         ;; Deactivate active regions.
5718         (when (and (boundp 'transient-mark-mode)
5719                    transient-mark-mode)
5720           (setq mark-active nil))
5721         (with-current-buffer gnus-summary-buffer
5722           (gnus-summary-followup
5723            (list (list article contents)))))))
5724
5725 (defun gnus-article-hide (&optional arg force)
5726   "Hide all the gruft in the current article.
5727 This means that signatures, cited text and (some) headers will be
5728 hidden.
5729 If given a prefix, show the hidden text instead."
5730   (interactive (append (gnus-article-hidden-arg) (list 'force)))
5731   (gnus-article-hide-headers arg)
5732   (gnus-article-hide-list-identifiers arg)
5733   (gnus-article-hide-citation-maybe arg force)
5734   (gnus-article-hide-signature arg))
5735
5736 (defun gnus-article-maybe-highlight ()
5737   "Do some article highlighting if article highlighting is requested."
5738   (when (gnus-visual-p 'article-highlight 'highlight)
5739     (gnus-article-highlight-some)))
5740
5741 (defun gnus-check-group-server ()
5742   ;; Make sure the connection to the server is alive.
5743   (unless (gnus-server-opened
5744            (gnus-find-method-for-group gnus-newsgroup-name))
5745     (gnus-check-server (gnus-find-method-for-group gnus-newsgroup-name))
5746     (gnus-request-group gnus-newsgroup-name t)))
5747
5748 (eval-when-compile
5749   (autoload 'nneething-get-file-name "nneething"))
5750
5751 (defun gnus-request-article-this-buffer (article group)
5752   "Get an article and insert it into this buffer."
5753   (let (do-update-line sparse-header)
5754     (prog1
5755         (save-excursion
5756           (erase-buffer)
5757           (gnus-kill-all-overlays)
5758           (setq group (or group gnus-newsgroup-name))
5759
5760           ;; Using `gnus-request-article' directly will insert the article into
5761           ;; `nntp-server-buffer' - so we'll save some time by not having to
5762           ;; copy it from the server buffer into the article buffer.
5763
5764           ;; We only request an article by message-id when we do not have the
5765           ;; headers for it, so we'll have to get those.
5766           (when (stringp article)
5767             (gnus-read-header article))
5768
5769           ;; If the article number is negative, that means that this article
5770           ;; doesn't belong in this newsgroup (possibly), so we find its
5771           ;; message-id and request it by id instead of number.
5772           (when (and (numberp article)
5773                      gnus-summary-buffer
5774                      (get-buffer gnus-summary-buffer)
5775                      (gnus-buffer-exists-p gnus-summary-buffer))
5776             (save-excursion
5777               (set-buffer gnus-summary-buffer)
5778               (let ((header (gnus-summary-article-header article)))
5779                 (when (< article 0)
5780                   (cond
5781                    ((memq article gnus-newsgroup-sparse)
5782                     ;; This is a sparse gap article.
5783                     (setq do-update-line article)
5784                     (setq article (mail-header-id header))
5785                     (setq sparse-header (gnus-read-header article))
5786                     (setq gnus-newsgroup-sparse
5787                           (delq article gnus-newsgroup-sparse)))
5788                    ((vectorp header)
5789                     ;; It's a real article.
5790                     (setq article (mail-header-id header)))
5791                    (t
5792                     ;; It is an extracted pseudo-article.
5793                     (setq article 'pseudo)
5794                     (gnus-request-pseudo-article header))))
5795
5796                 (let ((method (gnus-find-method-for-group
5797                                gnus-newsgroup-name)))
5798                   (when (and (eq (car method) 'nneething)
5799                              (vectorp header))
5800                     (let ((dir (nneething-get-file-name
5801                                 (mail-header-id header))))
5802                       (when (and (stringp dir)
5803                                  (file-directory-p dir))
5804                         (setq article 'nneething)
5805                         (gnus-group-enter-directory dir))))))))
5806
5807           (cond
5808            ;; Refuse to select canceled articles.
5809            ((and (numberp article)
5810                  gnus-summary-buffer
5811                  (get-buffer gnus-summary-buffer)
5812                  (gnus-buffer-exists-p gnus-summary-buffer)
5813                  (eq (cdr (with-current-buffer gnus-summary-buffer
5814                             (assq article gnus-newsgroup-reads)))
5815                      gnus-canceled-mark))
5816             nil)
5817            ;; We first check `gnus-original-article-buffer'.
5818            ((and (get-buffer gnus-original-article-buffer)
5819                  (numberp article)
5820                  (with-current-buffer gnus-original-article-buffer
5821                    (and (equal (car gnus-original-article) group)
5822                         (eq (cdr gnus-original-article) article))))
5823             (insert-buffer-substring gnus-original-article-buffer)
5824             'article)
5825            ;; Check the backlog.
5826            ((and gnus-keep-backlog
5827                  (gnus-backlog-request-article group article (current-buffer)))
5828             'article)
5829            ;; Check asynchronous pre-fetch.
5830            ((gnus-async-request-fetched-article group article (current-buffer))
5831             (gnus-async-prefetch-next group article gnus-summary-buffer)
5832             (when (and (numberp article) gnus-keep-backlog)
5833               (gnus-backlog-enter-article group article (current-buffer)))
5834             'article)
5835            ;; Check the cache.
5836            ((and gnus-use-cache
5837                  (numberp article)
5838                  (gnus-cache-request-article article group))
5839             'article)
5840            ;; Check the agent cache.
5841            ((gnus-agent-request-article article group)
5842             'article)
5843            ;; Get the article and put into the article buffer.
5844            ((or (stringp article)
5845                 (numberp article))
5846             (let ((gnus-override-method gnus-override-method)
5847                   (methods (and (stringp article)
5848                                 gnus-refer-article-method))
5849                   (backend (car (gnus-find-method-for-group
5850                                  gnus-newsgroup-name)))
5851                   result
5852                   (inhibit-read-only t))
5853               (if (or (not (listp methods))
5854                       (and (symbolp (car methods))
5855                            (assq (car methods) nnoo-definition-alist)))
5856                   (setq methods (list methods)))
5857               (when (and (null gnus-override-method)
5858                          methods)
5859                 (setq gnus-override-method (pop methods)))
5860               (while (not result)
5861                 (when (eq gnus-override-method 'current)
5862                   (setq gnus-override-method
5863                         (with-current-buffer gnus-summary-buffer
5864                           gnus-current-select-method)))
5865                 (erase-buffer)
5866                 (gnus-kill-all-overlays)
5867                 (let ((gnus-newsgroup-name group))
5868                   (gnus-check-group-server))
5869                 (cond
5870                  ((gnus-request-article article group (current-buffer))
5871                   (when (numberp article)
5872                     (gnus-async-prefetch-next group article
5873                                               gnus-summary-buffer)
5874                     (when gnus-keep-backlog
5875                       (gnus-backlog-enter-article
5876                        group article (current-buffer))))
5877                   (setq result 'article))
5878                  (methods
5879                   (setq gnus-override-method (pop methods)))
5880                  ((not (string-match "^400 "
5881                                      (nnheader-get-report backend)))
5882                   ;; If we get 400 server disconnect, reconnect and
5883                   ;; retry; otherwise, assume the article has expired.
5884                   (setq result 'done))))
5885               (and (eq result 'article) 'article)))
5886            ;; It was a pseudo.
5887            (t article)))
5888
5889       ;; Associate this article with the current summary buffer.
5890       (setq gnus-article-current-summary gnus-summary-buffer)
5891
5892       ;; Take the article from the original article buffer
5893       ;; and place it in the buffer it's supposed to be in.
5894       (when (and (get-buffer gnus-article-buffer)
5895                  (equal (buffer-name (current-buffer))
5896                         (buffer-name (get-buffer gnus-article-buffer))))
5897         (save-excursion
5898           (if (get-buffer gnus-original-article-buffer)
5899               (set-buffer gnus-original-article-buffer)
5900             (set-buffer (gnus-get-buffer-create gnus-original-article-buffer))
5901             (buffer-disable-undo)
5902             (setq major-mode 'gnus-original-article-mode)
5903             (setq buffer-read-only t))
5904           (let ((inhibit-read-only t))
5905             (erase-buffer)
5906             (insert-buffer-substring gnus-article-buffer))
5907           (setq gnus-original-article (cons group article)))
5908
5909         ;; Decode charsets.
5910         (run-hooks 'gnus-article-decode-hook)
5911         ;; Mark article as decoded or not.
5912         (setq gnus-article-decoded-p gnus-article-decode-hook))
5913
5914       ;; Update sparse articles.
5915       (when (and do-update-line
5916                  (or (numberp article)
5917                      (stringp article)))
5918         (let ((buf (current-buffer)))
5919           (set-buffer gnus-summary-buffer)
5920           (gnus-summary-update-article do-update-line sparse-header)
5921           (gnus-summary-goto-subject do-update-line nil t)
5922           (set-window-point (gnus-get-buffer-window (current-buffer) t)
5923                             (point))
5924           (set-buffer buf))))))
5925
5926 ;;;
5927 ;;; Article editing
5928 ;;;
5929
5930 (defcustom gnus-article-edit-mode-hook nil
5931   "Hook run in article edit mode buffers."
5932   :group 'gnus-article-various
5933   :type 'hook)
5934
5935 (defvar gnus-article-edit-done-function nil)
5936
5937 (defvar gnus-article-edit-mode-map nil)
5938
5939 ;; Should we be using derived.el for this?
5940 (unless gnus-article-edit-mode-map
5941   (setq gnus-article-edit-mode-map (make-keymap))
5942   (set-keymap-parent gnus-article-edit-mode-map text-mode-map)
5943
5944   (gnus-define-keys gnus-article-edit-mode-map
5945     "\C-c?"    describe-mode
5946     "\C-c\C-c" gnus-article-edit-done
5947     "\C-c\C-k" gnus-article-edit-exit
5948     "\C-c\C-f\C-t" message-goto-to
5949     "\C-c\C-f\C-o" message-goto-from
5950     "\C-c\C-f\C-b" message-goto-bcc
5951     ;;"\C-c\C-f\C-w" message-goto-fcc
5952     "\C-c\C-f\C-c" message-goto-cc
5953     "\C-c\C-f\C-s" message-goto-subject
5954     "\C-c\C-f\C-r" message-goto-reply-to
5955     "\C-c\C-f\C-n" message-goto-newsgroups
5956     "\C-c\C-f\C-d" message-goto-distribution
5957     "\C-c\C-f\C-f" message-goto-followup-to
5958     "\C-c\C-f\C-m" message-goto-mail-followup-to
5959     "\C-c\C-f\C-k" message-goto-keywords
5960     "\C-c\C-f\C-u" message-goto-summary
5961     "\C-c\C-f\C-i" message-insert-or-toggle-importance
5962     "\C-c\C-f\C-a" message-generate-unsubscribed-mail-followup-to
5963     "\C-c\C-b" message-goto-body
5964     "\C-c\C-i" message-goto-signature
5965
5966     "\C-c\C-t" message-insert-to
5967     "\C-c\C-n" message-insert-newsgroups
5968     "\C-c\C-o" message-sort-headers
5969     "\C-c\C-e" message-elide-region
5970     "\C-c\C-v" message-delete-not-region
5971     "\C-c\C-z" message-kill-to-signature
5972     "\M-\r" message-newline-and-reformat
5973     "\C-c\C-a" mml-attach-file
5974     "\C-a" message-beginning-of-line
5975     "\t" message-tab
5976     "\M-;" comment-region)
5977
5978   (gnus-define-keys (gnus-article-edit-wash-map
5979                      "\C-c\C-w" gnus-article-edit-mode-map)
5980     "f" gnus-article-edit-full-stops))
5981
5982 (easy-menu-define
5983   gnus-article-edit-mode-field-menu gnus-article-edit-mode-map ""
5984   '("Field"
5985     ["Fetch To" message-insert-to t]
5986     ["Fetch Newsgroups" message-insert-newsgroups t]
5987     "----"
5988     ["To" message-goto-to t]
5989     ["From" message-goto-from t]
5990     ["Subject" message-goto-subject t]
5991     ["Cc" message-goto-cc t]
5992     ["Reply-To" message-goto-reply-to t]
5993     ["Summary" message-goto-summary t]
5994     ["Keywords" message-goto-keywords t]
5995     ["Newsgroups" message-goto-newsgroups t]
5996     ["Followup-To" message-goto-followup-to t]
5997     ["Mail-Followup-To" message-goto-mail-followup-to t]
5998     ["Distribution" message-goto-distribution t]
5999     ["Body" message-goto-body t]
6000     ["Signature" message-goto-signature t]))
6001
6002 (define-derived-mode gnus-article-edit-mode message-mode "Article Edit"
6003   "Major mode for editing articles.
6004 This is an extended text-mode.
6005
6006 \\{gnus-article-edit-mode-map}"
6007   (make-local-variable 'gnus-article-edit-done-function)
6008   (make-local-variable 'gnus-prev-winconf)
6009   (set (make-local-variable 'font-lock-defaults)
6010        '(message-font-lock-keywords t))
6011   (set (make-local-variable 'mail-header-separator) "")
6012   (set (make-local-variable 'gnus-article-edit-mode) t)
6013   (easy-menu-add message-mode-field-menu message-mode-map)
6014   (mml-mode)
6015   (setq buffer-read-only nil)
6016   (buffer-enable-undo)
6017   (widen))
6018
6019 (defun gnus-article-edit (&optional force)
6020   "Edit the current article.
6021 This will have permanent effect only in mail groups.
6022 If FORCE is non-nil, allow editing of articles even in read-only
6023 groups."
6024   (interactive "P")
6025   (when (and (not force)
6026              (gnus-group-read-only-p))
6027     (error "The current newsgroup does not support article editing"))
6028   (gnus-article-date-original)
6029   (gnus-article-edit-article
6030    'ignore
6031    `(lambda (no-highlight)
6032       'ignore
6033       (gnus-summary-edit-article-done
6034        ,(or (mail-header-references gnus-current-headers) "")
6035        ,(gnus-group-read-only-p) ,gnus-summary-buffer no-highlight))))
6036
6037 (defun gnus-article-edit-article (start-func exit-func &optional quiet)
6038   "Start editing the contents of the current article buffer."
6039   (let ((winconf (current-window-configuration)))
6040     (set-buffer gnus-article-buffer)
6041     (let ((message-auto-save-directory
6042            ;; Don't associate the article buffer with a draft file.
6043            nil))
6044       (gnus-article-edit-mode))
6045     (funcall start-func)
6046     (set-buffer-modified-p nil)
6047     (gnus-configure-windows 'edit-article)
6048     (setq gnus-article-edit-done-function exit-func)
6049     (setq gnus-prev-winconf winconf)
6050     (unless quiet
6051       (gnus-message 6 "C-c C-c to end edits"))))
6052
6053 (defun gnus-article-edit-done (&optional arg)
6054   "Update the article edits and exit."
6055   (interactive "P")
6056   (let ((func gnus-article-edit-done-function)
6057         (buf (current-buffer))
6058         (start (window-start))
6059         (p (point))
6060         (winconf gnus-prev-winconf))
6061     (widen) ;; Widen it in case that users narrowed the buffer.
6062     (funcall func arg)
6063     (set-buffer buf)
6064     ;; The cache and backlog have to be flushed somewhat.
6065     (when gnus-keep-backlog
6066       (gnus-backlog-remove-article
6067        (car gnus-article-current) (cdr gnus-article-current)))
6068     ;; Flush original article as well.
6069     (save-excursion
6070       (when (get-buffer gnus-original-article-buffer)
6071         (set-buffer gnus-original-article-buffer)
6072         (setq gnus-original-article nil)))
6073     (when gnus-use-cache
6074       (gnus-cache-update-article
6075        (car gnus-article-current) (cdr gnus-article-current)))
6076     ;; We remove all text props from the article buffer.
6077     (kill-all-local-variables)
6078     (set-text-properties (point-min) (point-max) nil)
6079     (gnus-article-mode)
6080     (set-window-configuration winconf)
6081     (set-buffer buf)
6082     (set-window-start (get-buffer-window buf) start)
6083     (set-window-point (get-buffer-window buf) (point)))
6084   (gnus-summary-show-article))
6085
6086 (defun gnus-article-edit-exit ()
6087   "Exit the article editing without updating."
6088   (interactive)
6089   (when (or (not (buffer-modified-p))
6090             (yes-or-no-p "Article modified; kill anyway? "))
6091     (let ((curbuf (current-buffer))
6092           (p (point))
6093           (window-start (window-start)))
6094       (erase-buffer)
6095       (if (gnus-buffer-live-p gnus-original-article-buffer)
6096           (insert-buffer-substring gnus-original-article-buffer))
6097       (let ((winconf gnus-prev-winconf))
6098         (kill-all-local-variables)
6099         (gnus-article-mode)
6100         (set-window-configuration winconf)
6101         ;; Tippy-toe some to make sure that point remains where it was.
6102         (save-current-buffer
6103           (set-buffer curbuf)
6104           (set-window-start (get-buffer-window (current-buffer)) window-start)
6105           (goto-char p))))
6106     (gnus-summary-show-article)))
6107
6108 (defun gnus-article-edit-full-stops ()
6109   "Interactively repair spacing at end of sentences."
6110   (interactive)
6111   (save-excursion
6112     (goto-char (point-min))
6113     (search-forward-regexp "^$" nil t)
6114     (let ((case-fold-search nil))
6115       (query-replace-regexp "\\([.!?][])}]* \\)\\([[({A-Z]\\)" "\\1 \\2"))))
6116
6117 ;;;
6118 ;;; Article highlights
6119 ;;;
6120
6121 ;; Written by Per Abrahamsen <abraham@iesd.auc.dk>.
6122
6123 ;;; Internal Variables:
6124
6125 (defcustom gnus-button-url-regexp
6126   (if (string-match "[[:digit:]]" "1") ;; support POSIX?
6127       "\\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:]]\\)"
6128     "\\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\\)\\)")
6129   "Regular expression that matches URLs."
6130   :group 'gnus-article-buttons
6131   :type 'regexp)
6132
6133 (defcustom gnus-button-valid-fqdn-regexp
6134   message-valid-fqdn-regexp
6135   "Regular expression that matches a valid FQDN."
6136   :version "22.1"
6137   :group 'gnus-article-buttons
6138   :type 'regexp)
6139
6140 ;; Regexp suggested by Felix Wiemann in <87oeuomcz9.fsf@news2.ososo.de>
6141 (defcustom gnus-button-valid-localpart-regexp
6142   "[a-z0-9$%(*-=?[_][^<>\")!;:,{}\n\t ]*"
6143   "Regular expression that matches a localpart of mail addresses or MIDs."
6144   :version "22.1"
6145   :group 'gnus-article-buttons
6146   :type 'regexp)
6147
6148 (defcustom gnus-button-man-handler 'manual-entry
6149   "Function to use for displaying man pages.
6150 The function must take at least one argument with a string naming the
6151 man page."
6152   :version "22.1"
6153   :type '(choice (function-item :tag "Man" manual-entry)
6154                  (function-item :tag "Woman" woman)
6155                  (function :tag "Other"))
6156   :group 'gnus-article-buttons)
6157
6158 (defcustom gnus-ctan-url "http://tug.ctan.org/tex-archive/"
6159   "Top directory of a CTAN \(Comprehensive TeX Archive Network\) archive.
6160 If the default site is too slow, try to find a CTAN mirror, see
6161 <URL:http://tug.ctan.org/tex-archive/CTAN.sites?action=/index.html>.  See also
6162 the variable `gnus-button-handle-ctan'."
6163   :version "22.1"
6164   :group 'gnus-article-buttons
6165   :link '(custom-manual "(gnus)Group Parameters")
6166   :type '(choice (const "http://www.tex.ac.uk/tex-archive/")
6167                  (const "http://tug.ctan.org/tex-archive/")
6168                  (const "http://www.dante.de/CTAN/")
6169                  (string :tag "Other")))
6170
6171 (defcustom gnus-button-ctan-handler 'browse-url
6172   "Function to use for displaying CTAN links.
6173 The function must take one argument, the string naming the URL."
6174   :version "22.1"
6175   :type '(choice (function-item :tag "Browse Url" browse-url)
6176                  (function :tag "Other"))
6177   :group 'gnus-article-buttons)
6178
6179 (defcustom gnus-button-handle-ctan-bogus-regexp "^/?tex-archive/\\|^/"
6180   "Bogus strings removed from CTAN URLs."
6181   :version "22.1"
6182   :group 'gnus-article-buttons
6183   :type '(choice (const "^/?tex-archive/\\|/")
6184                  (regexp :tag "Other")))
6185
6186 (defcustom gnus-button-ctan-directory-regexp
6187   (regexp-opt
6188    (list "archive-tools" "biblio" "bibliography" "digests" "documentation"
6189          "dviware" "fonts" "graphics" "help" "indexing" "info" "language"
6190          "languages" "macros" "nonfree" "obsolete" "support" "systems"
6191          "tds" "tools" "usergrps" "web") t)
6192   "Regular expression for ctan directories.
6193 It should match all directories in the top level of `gnus-ctan-url'."
6194   :version "22.1"
6195   :group 'gnus-article-buttons
6196   :type 'regexp)
6197
6198 (defcustom gnus-button-mid-or-mail-regexp
6199   (concat "\\b\\(<?" gnus-button-valid-localpart-regexp "@"
6200           gnus-button-valid-fqdn-regexp
6201           ">?\\)\\b")
6202   "Regular expression that matches a message ID or a mail address."
6203   :version "22.1"
6204   :group 'gnus-article-buttons
6205   :type 'regexp)
6206
6207 (defcustom gnus-button-prefer-mid-or-mail 'gnus-button-mid-or-mail-heuristic
6208   "What to do when the button on a string as \"foo123@bar.invalid\" is pushed.
6209 Strings like this can be either a message ID or a mail address.  If it is one
6210 of the symbols `mid' or `mail', Gnus will always assume that the string is a
6211 message ID or a mail address, respectively.  If this variable is set to the
6212 symbol `ask', always query the user what do do.  If it is a function, this
6213 function will be called with the string as it's only argument.  The function
6214 must return `mid', `mail', `invalid' or `ask'."
6215   :version "22.1"
6216   :group 'gnus-article-buttons
6217   :type '(choice (function-item :tag "Heuristic function"
6218                                 gnus-button-mid-or-mail-heuristic)
6219                  (const ask)
6220                  (const mid)
6221                  (const mail)))
6222
6223 (defcustom gnus-button-mid-or-mail-heuristic-alist
6224   '((-10.0 . ".+\\$.+@")
6225     (-10.0 . "#")
6226     (-10.0 . "\\*")
6227     (-5.0  . "\\+[^+]*\\+.*@") ;; # two plus signs
6228     (-5.0  . "@[Nn][Ee][Ww][Ss]") ;; /\@news/i
6229     (-5.0  . "@.*[Dd][Ii][Aa][Ll][Uu][Pp]") ;; /\@.*dialup/i;
6230     (-1.0  . "^[^a-z]+@")
6231     ;;
6232     (-5.0  . "\\.[0-9][0-9]+.*@") ;; "\.[0-9]{2,}.*\@"
6233     (-5.0  . "[a-z].*[A-Z].*[a-z].*[A-Z].*@") ;; "([a-z].*[A-Z].*){2,}\@"
6234     (-3.0  . "[A-Z][A-Z][a-z][a-z].*@")
6235     (-5.0  . "\\...?.?@") ;; (-5.0 . "\..{1,3}\@")
6236     ;;
6237     (-2.0  . "^[0-9]")
6238     (-1.0  . "^[0-9][0-9]")
6239     ;;
6240     ;; -3.0 /^[0-9][0-9a-fA-F]{2,2}/;
6241     (-3.0  . "^[0-9][0-9a-fA-F][0-9a-fA-F][^0-9a-fA-F]")
6242     ;; -5.0 /^[0-9][0-9a-fA-F]{3,3}/;
6243     (-5.0  . "^[0-9][0-9a-fA-F][0-9a-fA-F][0-9a-fA-F][^0-9a-fA-F]")
6244     ;;
6245     (-3.0  .  "[0-9][0-9][0-9][0-9][0-9][^0-9].*@") ;; "[0-9]{5,}.*\@"
6246     (-3.0  .  "[0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][^0-9].*@")
6247     ;;       "[0-9]{8,}.*\@"
6248     (-3.0
6249      . "[0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9].*@")
6250     ;; "[0-9]{12,}.*\@"
6251     ;; compensation for TDMA dated mail addresses:
6252     (25.0  . "-dated-[0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9]+.*@")
6253     ;;
6254     (-20.0 . "\\.fsf@") ;; Gnus
6255     (-20.0 . "^slrn")
6256     (-20.0 . "^Pine")
6257     (-20.0 . "_-_") ;; Subject change in thread
6258     ;;
6259     (-20.0 . "\\.ln@") ;; leafnode
6260     (-30.0 . "@ID-[0-9]+\\.[a-zA-Z]+\\.dfncis\\.de")
6261     (-30.0 . "@4[Aa][Xx]\\.com") ;; Forte Agent
6262     ;;
6263     ;; (5.0 . "") ;; $local_part_len <= 7
6264     (10.0  . "^[^0-9]+@")
6265     (3.0   . "^[^0-9]+[0-9][0-9]?[0-9]?@")
6266     ;;      ^[^0-9]+[0-9]{1,3}\@ digits only at end of local part
6267     (3.0   . "\@stud")
6268     ;;
6269     (2.0   . "[a-z][a-z][._-][A-Z][a-z].*@")
6270     ;;
6271     (0.5   . "^[A-Z][a-z]")
6272     (0.5   . "^[A-Z][a-z][a-z]")
6273     (1.5   . "^[A-Z][a-z][A-Z][a-z][^a-z]") ;; ^[A-Z][a-z]{3,3}
6274     (2.0   . "^[A-Z][a-z][A-Z][a-z][a-z][^a-z]")) ;; ^[A-Z][a-z]{4,4}
6275   "An alist of \(RATE . REGEXP\) pairs for `gnus-button-mid-or-mail-heuristic'.
6276
6277 A negative RATE indicates a message IDs, whereas a positive indicates a mail
6278 address.  The REGEXP is processed with `case-fold-search' set to nil."
6279   :version "22.1"
6280   :group 'gnus-article-buttons
6281   :type '(repeat (cons (number :tag "Rate")
6282                        (regexp :tag "Regexp"))))
6283
6284 (defun gnus-button-mid-or-mail-heuristic (mid-or-mail)
6285   "Guess whether MID-OR-MAIL is a message ID or a mail address.
6286 Returns `mid' if MID-OR-MAIL is a message IDs, `mail' if it's a mail
6287 address, `ask' if unsure and `invalid' if the string is invalid."
6288   (let ((case-fold-search nil)
6289         (list gnus-button-mid-or-mail-heuristic-alist)
6290         (result 0) rate regexp lpartlen elem)
6291     (setq lpartlen
6292           (length (gnus-replace-in-string mid-or-mail "^\\(.*\\)@.*$" "\\1")))
6293     (gnus-message 8 "`%s', length of local part=`%s'." mid-or-mail lpartlen)
6294     ;; Certain special cases...
6295     (when (string-match
6296            (concat
6297             "^0[0-9]+-[0-9][0-9][0-9][0-9]@t-online\\.de$\\|"
6298             "^[0-9]+\\.[0-9]+@compuserve\\|"
6299             "@public\\.gmane\\.org")
6300            mid-or-mail)
6301       (gnus-message 8 "`%s' is a known mail address." mid-or-mail)
6302       (setq result 'mail))
6303     (when (string-match "@.*@\\| " mid-or-mail)
6304       (gnus-message 8 "`%s' is invalid." mid-or-mail)
6305       (setq result 'invalid))
6306     ;; Nothing more to do, if result is not a number here...
6307     (when (numberp result)
6308       (while list
6309         (setq elem (car list)
6310               rate (car elem)
6311               regexp (cdr elem)
6312               list (cdr list))
6313         (when (string-match regexp mid-or-mail)
6314           (setq result (+ result rate))
6315           (gnus-message
6316            9 "`%s' matched `%s', rate `%s', result `%s'."
6317            mid-or-mail regexp rate result)))
6318       (when (<= lpartlen 7)
6319         (setq result (+ result 5.0))
6320         (gnus-message 9 "`%s' matched (<= lpartlen 7), result `%s'."
6321                       mid-or-mail result))
6322       (when (>= lpartlen 12)
6323         (gnus-message 9 "`%s' matched (>= lpartlen 12)" mid-or-mail)
6324         (cond
6325          ((string-match "[0-9][^0-9]+[0-9].*@" mid-or-mail)
6326           ;; Long local part should contain realname if e-mail address,
6327           ;; too many digits: message-id.
6328           ;; $score -= 5.0 + 0.1 * $local_part_len;
6329           (setq rate (* -1.0 (+ 5.0 (* 0.1 lpartlen))))
6330           (setq result (+ result rate))
6331           (gnus-message
6332            9 "Many digits in `%s', rate `%s', result `%s'."
6333            mid-or-mail rate result))
6334          ((string-match "[^aeiouy][^aeiouy][^aeiouy][^aeiouy]+.*\@"
6335                         mid-or-mail)
6336           ;; Too few vowels [^aeiouy]{4,}.*\@
6337           (setq result (+ result -5.0))
6338           (gnus-message
6339            9 "Few vowels in `%s', rate `%s', result `%s'."
6340            mid-or-mail -5.0 result))
6341          (t
6342           (setq result (+ result 5.0))
6343           (gnus-message
6344            9 "`%s', rate `%s', result `%s'." mid-or-mail 5.0 result)))))
6345     (gnus-message 8 "`%s': Final rate is `%s'." mid-or-mail result)
6346     ;; Maybe we should make this a customizable alist: (condition . 'result)
6347     (cond
6348      ((symbolp result) result)
6349      ;; Now convert number into proper results:
6350      ((< result -10.0) 'mid)
6351      ((> result  10.0) 'mail)
6352      (t 'ask))))
6353
6354 (defun gnus-button-handle-mid-or-mail (mid-or-mail)
6355   (let* ((pref gnus-button-prefer-mid-or-mail) guessed
6356          (url-mid (concat "news" ":" mid-or-mail))
6357          (url-mailto (concat "mailto" ":" mid-or-mail)))
6358     (gnus-message 9 "mid-or-mail=%s" mid-or-mail)
6359     (when (fboundp pref)
6360       (setq guessed
6361             ;; get rid of surrounding angles...
6362             (funcall pref
6363                      (gnus-replace-in-string mid-or-mail "^<\\|>$" "")))
6364       (if (or (eq 'mid guessed) (eq 'mail guessed))
6365           (setq pref guessed)
6366         (setq pref 'ask)))
6367     (if (eq pref 'ask)
6368         (save-window-excursion
6369           (if (y-or-n-p (concat "Is <" mid-or-mail "> a mail address? "))
6370               (setq pref 'mail)
6371             (setq pref 'mid))))
6372     (cond ((eq pref 'mid)
6373            (gnus-message 8 "calling `gnus-button-handle-news' %s" url-mid)
6374            (gnus-button-handle-news url-mid))
6375           ((eq pref 'mail)
6376            (gnus-message 8 "calling `gnus-url-mailto'  %s" url-mailto)
6377            (gnus-url-mailto url-mailto))
6378           (t (gnus-message 3 "Invalid string.")))))
6379
6380 (defun gnus-button-handle-custom (fun arg)
6381   "Call function FUN on argument ARG.
6382 Both FUN and ARG are supposed to be strings.  ARG will be passed
6383 as a symbol to FUN."
6384   (funcall (intern fun) (intern arg)))
6385
6386 (defvar gnus-button-handle-describe-prefix "^\\(C-h\\|<?[Ff]1>?\\)")
6387
6388 ;; FIXME: Maybe we should merge some of the functions that do quite similar
6389 ;; stuff?
6390
6391 (defun gnus-button-handle-describe-function (url)
6392   "Call `describe-function' when pushing the corresponding URL button."
6393   (describe-function
6394    (intern
6395     (gnus-replace-in-string url gnus-button-handle-describe-prefix ""))))
6396
6397 (defun gnus-button-handle-describe-variable (url)
6398   "Call `describe-variable' when pushing the corresponding URL button."
6399   (describe-variable
6400    (intern
6401     (gnus-replace-in-string url gnus-button-handle-describe-prefix ""))))
6402
6403 (defun gnus-button-handle-symbol (url)
6404 "Display help on variable or function.
6405 Calls `describe-variable' or `describe-function'."
6406   (let ((sym (intern url)))
6407     (cond
6408      ((fboundp sym) (describe-function sym))
6409      ((boundp sym) (describe-variable sym))
6410      (t (gnus-message 3 "`%s' is not a known function of variable." url)))))
6411
6412 (defun gnus-button-handle-describe-key (url)
6413   "Call `describe-key' when pushing the corresponding URL button."
6414   (let* ((key-string
6415           (gnus-replace-in-string url gnus-button-handle-describe-prefix ""))
6416          (keys (ignore-errors (eval `(kbd ,key-string)))))
6417     (if keys
6418         (describe-key keys)
6419       (gnus-message 3 "Invalid key sequence in button: %s" key-string))))
6420
6421 (defun gnus-button-handle-apropos (url)
6422   "Call `apropos' when pushing the corresponding URL button."
6423   (apropos (gnus-replace-in-string url gnus-button-handle-describe-prefix "")))
6424
6425 (defun gnus-button-handle-apropos-command (url)
6426   "Call `apropos' when pushing the corresponding URL button."
6427   (apropos-command
6428    (gnus-replace-in-string url gnus-button-handle-describe-prefix "")))
6429
6430 (defun gnus-button-handle-apropos-variable (url)
6431   "Call `apropos' when pushing the corresponding URL button."
6432   (funcall
6433    (if (fboundp 'apropos-variable) 'apropos-variable 'apropos)
6434    (gnus-replace-in-string url gnus-button-handle-describe-prefix "")))
6435
6436 (defun gnus-button-handle-apropos-documentation (url)
6437   "Call `apropos' when pushing the corresponding URL button."
6438   (funcall
6439    (if (fboundp 'apropos-documentation) 'apropos-documentation 'apropos)
6440    (gnus-replace-in-string url gnus-button-handle-describe-prefix "")))
6441
6442 (defun gnus-button-handle-library (url)
6443   "Call `locate-library' when pushing the corresponding URL button."
6444   (gnus-message 9 "url=`%s'" url)
6445   (let* ((lib (locate-library url))
6446          (file (gnus-replace-in-string (or lib "") "\.elc" ".el")))
6447     (if (not lib)
6448         (gnus-message 1 "Cannot locale library `%s'." url)
6449       (find-file-read-only file))))
6450
6451 (defun gnus-button-handle-ctan (url)
6452   "Call `browse-url' when pushing a CTAN URL button."
6453   (funcall
6454    gnus-button-ctan-handler
6455    (concat
6456     gnus-ctan-url
6457     (gnus-replace-in-string url gnus-button-handle-ctan-bogus-regexp ""))))
6458
6459 (defcustom gnus-button-tex-level 5
6460   "*Integer that says how many TeX-related buttons Gnus will show.
6461 The higher the number, the more buttons will appear and the more false
6462 positives are possible.  Note that you can set this variable local to
6463 specific groups.  Setting it higher in TeX groups is probably a good idea.
6464 See Info node `(gnus)Group Parameters' and the variable `gnus-parameters' on
6465 how to set variables in specific groups."
6466   :version "22.1"
6467   :group 'gnus-article-buttons
6468   :link '(custom-manual "(gnus)Group Parameters")
6469   :type 'integer)
6470
6471 (defcustom gnus-button-man-level 5
6472   "*Integer that says how many man-related buttons Gnus will show.
6473 The higher the number, the more buttons will appear and the more false
6474 positives are possible.  Note that you can set this variable local to
6475 specific groups.  Setting it higher in Unix groups is probably a good idea.
6476 See Info node `(gnus)Group Parameters' and the variable `gnus-parameters' on
6477 how to set variables in specific groups."
6478   :version "22.1"
6479   :group 'gnus-article-buttons
6480   :link '(custom-manual "(gnus)Group Parameters")
6481   :type 'integer)
6482
6483 (defcustom gnus-button-emacs-level 5
6484   "*Integer that says how many emacs-related buttons Gnus will show.
6485 The higher the number, the more buttons will appear and the more false
6486 positives are possible.  Note that you can set this variable local to
6487 specific groups.  Setting it higher in Emacs or Gnus related groups is
6488 probably a good idea.  See Info node `(gnus)Group Parameters' and the variable
6489 `gnus-parameters' on how to set variables in specific groups."
6490   :version "22.1"
6491   :group 'gnus-article-buttons
6492   :link '(custom-manual "(gnus)Group Parameters")
6493   :type 'integer)
6494
6495 (defcustom gnus-button-message-level 5
6496   "*Integer that says how many buttons for news or mail messages will appear.
6497 The higher the number, the more buttons will appear and the more false
6498 positives are possible."
6499   ;; mail addresses, MIDs, URLs for news, ...
6500   :version "22.1"
6501   :group 'gnus-article-buttons
6502   :type 'integer)
6503
6504 (defcustom gnus-button-browse-level 5
6505   "*Integer that says how many buttons for browsing will appear.
6506 The higher the number, the more buttons will appear and the more false
6507 positives are possible."
6508   ;; stuff handled by `browse-url' or `gnus-button-embedded-url'
6509   :version "22.1"
6510   :group 'gnus-article-buttons
6511   :type 'integer)
6512
6513 (defcustom gnus-button-alist
6514   '(("<\\(url:[>\n\t ]*?\\)?\\(nntp\\|news\\):[>\n\t ]*\\([^>\n\t ]*@[^>\n\t ]*\\)>"
6515      0 (>= gnus-button-message-level 0) gnus-button-handle-news 3)
6516     ((concat "\\b\\(nntp\\|news\\):\\("
6517              gnus-button-valid-localpart-regexp "@[a-z0-9.-]+[a-z]\\)")
6518      0 t gnus-button-handle-news 2)
6519     ("\\(\\b<\\(url:[>\n\t ]*\\)?\\(nntp\\|news\\):[>\n\t ]*\\(//\\)?\\([^>\n\t ]*\\)>\\)"
6520      1 (>= gnus-button-message-level 0) gnus-button-fetch-group 5)
6521     ("\\b\\(nntp\\|news\\):\\(//\\)?\\([^'\">\n\t ]+\\)"
6522      0 (>= gnus-button-message-level 0) gnus-button-fetch-group 3)
6523     ;; RFC 2392 (Don't allow `/' in domain part --> CID)
6524     ("\\bmid:\\(//\\)?\\([^'\">\n\t ]+@[^'\">\n\t /]+\\)"
6525      0 (>= gnus-button-message-level 0) gnus-button-message-id 2)
6526     ("\\bin\\( +article\\| +message\\)? +\\(<\\([^\n @<>]+@[^\n @<>]+\\)>\\)"
6527      2 (>= gnus-button-message-level 0) gnus-button-message-id 3)
6528     ("\\(<URL: *\\)mailto: *\\([^> \n\t]+\\)>"
6529      0 (>= gnus-button-message-level 0) gnus-url-mailto 2)
6530     ;; RFC 2368 (The mailto URL scheme)
6531     ("\\bmailto:\\([-a-z.@_+0-9%=?&/]+\\)"
6532      0 (>= gnus-button-message-level 0) gnus-url-mailto 1)
6533     ("\\bmailto:\\([^ \n\t]+\\)"
6534      0 (>= gnus-button-message-level 0) gnus-url-mailto 1)
6535     ;; CTAN
6536     ((concat "\\bCTAN:[ \t\n]?[^>)!;:,'\n\t ]*\\("
6537              gnus-button-ctan-directory-regexp
6538              "[^][>)!;:,'\n\t ]+\\)")
6539      0 (>= gnus-button-tex-level 1) gnus-button-handle-ctan 1)
6540     ((concat "\\btex-archive/\\("
6541              gnus-button-ctan-directory-regexp
6542              "/[-_.a-z0-9/]+[-_./a-z0-9]+[/a-z0-9]\\)")
6543      1 (>= gnus-button-tex-level 6) gnus-button-handle-ctan 1)
6544     ((concat
6545       "\\b\\("
6546       gnus-button-ctan-directory-regexp
6547       "/[-_.a-z0-9]+/[-_./a-z0-9]+[/a-z0-9]\\)")
6548      1 (>= gnus-button-tex-level 8) gnus-button-handle-ctan 1)
6549     ;; This is info (home-grown style) <info://foo/bar+baz>
6550     ("\\binfo://\\([^'\">\n\t ]+\\)"
6551      0 (>= gnus-button-emacs-level 1) gnus-button-handle-info-url 1)
6552     ;; Info GNOME style <info:foo#bar_baz>
6553     ("\\binfo:\\([^('\n\t\r \"><][^'\n\t\r \"><]*\\)"
6554      0 (>= gnus-button-emacs-level 1) gnus-button-handle-info-url-gnome 1)
6555     ;; Info KDE style <info:(foo)bar baz>
6556     ("<\\(info:\\(([^)]+)[^>\n\r]*\\)\\)>"
6557      1 (>= gnus-button-emacs-level 1) gnus-button-handle-info-url-kde 2)
6558     ("\\((Info-goto-node\\|(info\\)[ \t\n]*\\(\"[^\"]*\"\\))" 0
6559      (>= gnus-button-emacs-level 1) gnus-button-handle-info-url 2)
6560     ("\\b\\(C-h\\|<?[Ff]1>?\\)[ \t\n]+i[ \t\n]+d?[ \t\n]?m[ \t\n]+\\([^ ]+ ?[^ ]+\\)[ \t\n]+RET"
6561      ;; Info links like `C-h i d m CC Mode RET'
6562      0 (>= gnus-button-emacs-level 1) gnus-button-handle-info-keystrokes 2)
6563     ;; This is custom
6564     ("M-x[ \t\n]\\(customize-[^ ]+\\)[ \t\n]RET[ \t\n]\\([^ ]+\\)[ \t\n]RET" 0
6565      (>= gnus-button-emacs-level 1) gnus-button-handle-custom 1 2)
6566     ;; Emacs help commands
6567     ("M-x[ \t\n]+apropos[ \t\n]+RET[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET"
6568      ;; regexp doesn't match arguments containing ` '.
6569      0 (>= gnus-button-emacs-level 1) gnus-button-handle-apropos 1)
6570     ("M-x[ \t\n]+apropos-command[ \t\n]+RET[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET"
6571      0 (>= gnus-button-emacs-level 1) gnus-button-handle-apropos-command 1)
6572     ("M-x[ \t\n]+apropos-variable[ \t\n]+RET[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET"
6573      0 (>= gnus-button-emacs-level 1) gnus-button-handle-apropos-variable 1)
6574     ("M-x[ \t\n]+apropos-documentation[ \t\n]+RET[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET"
6575      0 (>= gnus-button-emacs-level 1) gnus-button-handle-apropos-documentation 1)
6576     ;; The following entries may lead to many false positives so don't enable
6577     ;; them by default (use a high button level).
6578     ("/\\([a-z][-a-z0-9]+\\.el\\)\\>[^.?]"
6579      ;; Exclude [.?] for URLs in gmane.emacs.cvs
6580      1 (>= gnus-button-emacs-level 8) gnus-button-handle-library 1)
6581     ("`\\([a-z][-a-z0-9]+\\.el\\)'"
6582      1 (>= gnus-button-emacs-level 8) gnus-button-handle-library 1)
6583     ("`\\([a-z][a-z0-9]+-[a-z]+-[-a-z]+\\|\\(gnus\\|message\\)-[-a-z]+\\)'"
6584      0 (>= gnus-button-emacs-level 8) gnus-button-handle-symbol 1)
6585     ("`\\([a-z][a-z0-9]+-[a-z]+\\)'"
6586      0 (>= gnus-button-emacs-level 9) gnus-button-handle-symbol 1)
6587     ("(setq[ \t\n]+\\([a-z][a-z0-9]+-[-a-z0-9]+\\)[ \t\n]+.+)"
6588      1 (>= gnus-button-emacs-level 7) gnus-button-handle-describe-variable 1)
6589     ("\\bM-x[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET"
6590      1 (>= gnus-button-emacs-level 7) gnus-button-handle-describe-function 1)
6591     ("\\b\\(C-h\\|<?[Ff]1>?\\)[ \t\n]+f[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET"
6592      0 (>= gnus-button-emacs-level 1) gnus-button-handle-describe-function 2)
6593     ("\\b\\(C-h\\|<?[Ff]1>?\\)[ \t\n]+v[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET"
6594      0 (>= gnus-button-emacs-level 1) gnus-button-handle-describe-variable 2)
6595     ("`\\(\\b\\(C-h\\|<?[Ff]1>?\\)[ \t\n]+k[ \t\n]+\\([^']+\\)\\)'"
6596      ;; Unlike the other regexps we really have to require quoting
6597      ;; here to determine where it ends.
6598      1 (>= gnus-button-emacs-level 1) gnus-button-handle-describe-key 3)
6599     ;; This is how URLs _should_ be embedded in text (RFC 1738, RFC 2396)...
6600     ("<URL: *\\([^<>]*\\)>"
6601      1 (>= gnus-button-browse-level 0) gnus-button-embedded-url 1)
6602     ;; RFC 2396 (2.4.3., delims) ...
6603     ("\"URL: *\\([^\"]*\\)\""
6604      1 (>= gnus-button-browse-level 0) gnus-button-embedded-url 1)
6605     ;; RFC 2396 (2.4.3., delims) ...
6606     ("\"URL: *\\([^\"]*\\)\""
6607      1 (>= gnus-button-browse-level 0) gnus-button-embedded-url 1)
6608     ;; Raw URLs.
6609     (gnus-button-url-regexp
6610      0 (>= gnus-button-browse-level 0) browse-url 0)
6611     ;; man pages
6612     ("\\b\\([a-z][a-z]+([1-9])\\)\\W"
6613      0 (and (>= gnus-button-man-level 1) (< gnus-button-man-level 3))
6614      gnus-button-handle-man 1)
6615     ;; more man pages: resolv.conf(5), iso_8859-1(7), xterm(1x)
6616     ("\\b\\([a-z][-_.a-z0-9]+([1-9])\\)\\W"
6617      0 (and (>= gnus-button-man-level 3) (< gnus-button-man-level 5))
6618      gnus-button-handle-man 1)
6619     ;; even more: Apache::PerlRun(3pm), PDL::IO::FastRaw(3pm),
6620     ;; SoWWWAnchor(3iv), XSelectInput(3X11), X(1), X(7)
6621     ("\\b\\(\\(?:[a-z][-+_.:a-z0-9]+([1-9][X1a-z]*)\\)\\|\\b\\(?:X([1-9])\\)\\)\\W"
6622      0 (>= gnus-button-man-level 5) gnus-button-handle-man 1)
6623     ;; MID or mail: To avoid too many false positives we don't try to catch
6624     ;; all kind of allowed MIDs or mail addresses.  Domain part must contain
6625     ;; at least one dot.  TLD must contain two or three chars or be a know TLD
6626     ;; (info|name|...).  Put this entry near the _end_ of `gnus-button-alist'
6627     ;; so that non-ambiguous entries (see above) match first.
6628     (gnus-button-mid-or-mail-regexp
6629      0 (>= gnus-button-message-level 5) gnus-button-handle-mid-or-mail 1))
6630   "*Alist of regexps matching buttons in article bodies.
6631
6632 Each entry has the form (REGEXP BUTTON FORM CALLBACK PAR...), where
6633 REGEXP: is the string (case insensitive) matching text around the button (can
6634 also be Lisp expression evaluating to a string),
6635 BUTTON: is the number of the regexp grouping actually matching the button,
6636 FORM: is a Lisp expression which must eval to true for the button to
6637 be added,
6638 CALLBACK: is the function to call when the user push this button, and each
6639 PAR: is a number of a regexp grouping whose text will be passed to CALLBACK.
6640
6641 CALLBACK can also be a variable, in that case the value of that
6642 variable it the real callback function."
6643   :group 'gnus-article-buttons
6644   :type '(repeat (list (choice regexp variable sexp)
6645                        (integer :tag "Button")
6646                        (sexp :tag "Form")
6647                        (function :tag "Callback")
6648                        (repeat :tag "Par"
6649                                :inline t
6650                                (integer :tag "Regexp group")))))
6651
6652 (defcustom gnus-header-button-alist
6653   '(("^\\(References\\|Message-I[Dd]\\|^In-Reply-To\\):" "<[^<>]+>"
6654      0 (>= gnus-button-message-level 0) gnus-button-message-id 0)
6655     ("^\\(From\\|Reply-To\\):" ": *\\(.+\\)$"
6656      1 (>= gnus-button-message-level 0) gnus-button-reply 1)
6657     ("^\\(Cc\\|To\\):" "[^ \t\n<>,()\"]+@[^ \t\n<>,()\"]+"
6658      0 (>= gnus-button-message-level 0) gnus-msg-mail 0)
6659     ("^X-[Uu][Rr][Ll]:" gnus-button-url-regexp
6660      0 (>= gnus-button-browse-level 0) browse-url 0)
6661     ("^Subject:" gnus-button-url-regexp
6662      0 (>= gnus-button-browse-level 0) browse-url 0)
6663     ("^[^:]+:" gnus-button-url-regexp
6664      0 (>= gnus-button-browse-level 0) browse-url 0)
6665     ("^OpenPGP:.*url=" gnus-button-url-regexp
6666      0 (>= gnus-button-browse-level 0) gnus-button-openpgp 0)
6667     ("^[^:]+:" "\\bmailto:\\([-a-z.@_+0-9%=?&/]+\\)"
6668      0 (>= gnus-button-message-level 0) gnus-url-mailto 1)
6669     ("^[^:]+:" "\\(<\\(url: \\)?\\(nntp\\|news\\):\\([^>\n ]*\\)>\\)"
6670      1 (>= gnus-button-message-level 0) gnus-button-message-id 4))
6671   "*Alist of headers and regexps to match buttons in article heads.
6672
6673 This alist is very similar to `gnus-button-alist', except that each
6674 alist has an additional HEADER element first in each entry:
6675
6676 \(HEADER REGEXP BUTTON FORM CALLBACK PAR)
6677
6678 HEADER is a regexp to match a header.  For a fuller explanation, see
6679 `gnus-button-alist'."
6680   :group 'gnus-article-buttons
6681   :group 'gnus-article-headers
6682   :type '(repeat (list (regexp :tag "Header")
6683                        (choice regexp variable)
6684                        (integer :tag "Button")
6685                        (sexp :tag "Form")
6686                        (function :tag "Callback")
6687                        (repeat :tag "Par"
6688                                :inline t
6689                                (integer :tag "Regexp group")))))
6690
6691 ;;; Commands:
6692
6693 (defun gnus-article-push-button (event)
6694   "Check text under the mouse pointer for a callback function.
6695 If the text under the mouse pointer has a `gnus-callback' property,
6696 call it with the value of the `gnus-data' text property."
6697   (interactive "e")
6698   (set-buffer (window-buffer (posn-window (event-start event))))
6699   (let* ((pos (posn-point (event-start event)))
6700          (data (get-text-property pos 'gnus-data))
6701          (fun (get-text-property pos 'gnus-callback)))
6702     (goto-char pos)
6703     (when fun
6704       (funcall fun data))))
6705
6706 (defun gnus-article-press-button ()
6707   "Check text at point for a callback function.
6708 If the text at point has a `gnus-callback' property,
6709 call it with the value of the `gnus-data' text property."
6710   (interactive)
6711   (let ((data (get-text-property (point) 'gnus-data))
6712         (fun (get-text-property (point) 'gnus-callback)))
6713     (when fun
6714       (funcall fun data))))
6715
6716 (defun gnus-article-highlight (&optional force)
6717   "Highlight current article.
6718 This function calls `gnus-article-highlight-headers',
6719 `gnus-article-highlight-citation',
6720 `gnus-article-highlight-signature', and `gnus-article-add-buttons' to
6721 do the highlighting.  See the documentation for those functions."
6722   (interactive (list 'force))
6723   (gnus-article-highlight-headers)
6724   (gnus-article-highlight-citation force)
6725   (gnus-article-highlight-signature)
6726   (gnus-article-add-buttons force)
6727   (gnus-article-add-buttons-to-head))
6728
6729 (defun gnus-article-highlight-some (&optional force)
6730   "Highlight current article.
6731 This function calls `gnus-article-highlight-headers',
6732 `gnus-article-highlight-signature', and `gnus-article-add-buttons' to
6733 do the highlighting.  See the documentation for those functions."
6734   (interactive (list 'force))
6735   (gnus-article-highlight-headers)
6736   (gnus-article-highlight-signature)
6737   (gnus-article-add-buttons))
6738
6739 (defun gnus-article-highlight-headers ()
6740   "Highlight article headers as specified by `gnus-header-face-alist'."
6741   (interactive)
6742   (gnus-with-article-headers
6743     (let (regexp header-face field-face from hpoints fpoints)
6744       (dolist (entry gnus-header-face-alist)
6745         (goto-char (point-min))
6746         (setq regexp (concat "^\\("
6747                              (if (string-equal "" (nth 0 entry))
6748                                  "[^\t ]"
6749                                (nth 0 entry))
6750                              "\\)")
6751               header-face (nth 1 entry)
6752               field-face (nth 2 entry))
6753         (while (and (re-search-forward regexp nil t)
6754                     (not (eobp)))
6755           (beginning-of-line)
6756           (setq from (point))
6757           (unless (search-forward ":" nil t)
6758             (forward-char 1))
6759           (when (and header-face
6760                      (not (memq (point) hpoints)))
6761             (push (point) hpoints)
6762             (gnus-put-text-property from (point) 'face header-face))
6763           (when (and field-face
6764                      (not (memq (setq from (point)) fpoints)))
6765             (push from fpoints)
6766             (if (re-search-forward "^[^ \t]" nil t)
6767                 (forward-char -2)
6768               (goto-char (point-max)))
6769             (gnus-put-text-property from (point) 'face field-face)))))))
6770
6771 (defun gnus-article-highlight-signature ()
6772   "Highlight the signature in an article.
6773 It does this by highlighting everything after
6774 `gnus-signature-separator' using the face `gnus-signature'."
6775   (interactive)
6776   (gnus-with-article-buffer
6777     (let ((inhibit-point-motion-hooks t))
6778       (save-restriction
6779         (when (and gnus-signature-face
6780                    (gnus-article-narrow-to-signature))
6781           (gnus-overlay-put (gnus-make-overlay (point-min) (point-max))
6782                             'face gnus-signature-face)
6783           (widen)
6784           (gnus-article-search-signature)
6785           (let ((start (match-beginning 0))
6786                 (end (set-marker (make-marker) (1+ (match-end 0)))))
6787             (gnus-article-add-button start (1- end) 'gnus-signature-toggle
6788                                      end)))))))
6789
6790 (defun gnus-button-in-region-p (b e prop)
6791   "Say whether PROP exists in the region."
6792   (text-property-not-all b e prop nil))
6793
6794 (defun gnus-article-add-buttons (&optional force)
6795   "Find external references in the article and make buttons of them.
6796 \"External references\" are things like Message-IDs and URLs, as
6797 specified by `gnus-button-alist'."
6798   (interactive (list 'force))
6799   (gnus-with-article-buffer
6800     (let ((inhibit-point-motion-hooks t)
6801           (case-fold-search t)
6802           (alist gnus-button-alist)
6803           beg entry regexp)
6804       ;; Remove all old markers.
6805       (let (marker entry new-list)
6806         (while (setq marker (pop gnus-button-marker-list))
6807           (if (or (< marker (point-min)) (>= marker (point-max)))
6808               (push marker new-list)
6809             (goto-char marker)
6810             (when (setq entry (gnus-button-entry))
6811               (put-text-property (match-beginning (nth 1 entry))
6812                                  (match-end (nth 1 entry))
6813                                  'gnus-callback nil))
6814             (set-marker marker nil)))
6815         (setq gnus-button-marker-list new-list))
6816       ;; We skip the headers.
6817       (article-goto-body)
6818       (setq beg (point))
6819       (while (setq entry (pop alist))
6820         (setq regexp (eval (car entry)))
6821         (goto-char beg)
6822         (while (re-search-forward regexp nil t)
6823           (let* ((start (and entry (match-beginning (nth 1 entry))))
6824                  (end (and entry (match-end (nth 1 entry))))
6825                  (from (match-beginning 0)))
6826             (when (and (or (eq t (nth 2 entry))
6827                            (eval (nth 2 entry)))
6828                        (not (gnus-button-in-region-p
6829                              start end 'gnus-callback)))
6830               ;; That optional form returned non-nil, so we add the
6831               ;; button.
6832               (gnus-article-add-button
6833                start end 'gnus-button-push
6834                (car (push (set-marker (make-marker) from)
6835                           gnus-button-marker-list))))))))))
6836
6837 ;; Add buttons to the head of an article.
6838 (defun gnus-article-add-buttons-to-head ()
6839   "Add buttons to the head of the article."
6840   (interactive)
6841   (gnus-with-article-headers
6842     (let (beg end)
6843       (dolist (entry gnus-header-button-alist)
6844         ;; Each alist entry.
6845         (goto-char (point-min))
6846         (while (re-search-forward (car entry) nil t)
6847           ;; Each header matching the entry.
6848           (setq beg (match-beginning 0))
6849           (setq end (or (and (re-search-forward "^[^ \t]" nil t)
6850                              (match-beginning 0))
6851                         (point-max)))
6852           (goto-char beg)
6853           (while (re-search-forward (eval (nth 1 entry)) end t)
6854             ;; Each match within a header.
6855             (let* ((entry (cdr entry))
6856                    (start (match-beginning (nth 1 entry)))
6857                    (end (match-end (nth 1 entry)))
6858                    (form (nth 2 entry)))
6859               (goto-char (match-end 0))
6860               (when (eval form)
6861                 (gnus-article-add-button
6862                  start end (nth 3 entry)
6863                  (buffer-substring (match-beginning (nth 4 entry))
6864                                    (match-end (nth 4 entry)))))))
6865           (goto-char end))))))
6866
6867 ;;; External functions:
6868
6869 (defun gnus-article-add-button (from to fun &optional data)
6870   "Create a button between FROM and TO with callback FUN and data DATA."
6871   (when gnus-article-button-face
6872     (gnus-overlay-put (gnus-make-overlay from to)
6873                       'face gnus-article-button-face))
6874   (gnus-add-text-properties
6875    from to
6876    (nconc (and gnus-article-mouse-face
6877                (list gnus-mouse-face-prop gnus-article-mouse-face))
6878           (list 'gnus-callback fun)
6879           (and data (list 'gnus-data data))))
6880   (widget-convert-button 'link from to :action 'gnus-widget-press-button
6881                          :button-keymap gnus-widget-button-keymap))
6882
6883 ;;; Internal functions:
6884
6885 (defun gnus-article-set-globals ()
6886   (with-current-buffer gnus-summary-buffer
6887     (gnus-set-global-variables)))
6888
6889 (defun gnus-signature-toggle (end)
6890   (gnus-with-article-buffer
6891     (let ((inhibit-point-motion-hooks t))
6892       (if (text-property-any end (point-max) 'article-type 'signature)
6893           (progn
6894             (gnus-delete-wash-type 'signature)
6895             (gnus-remove-text-properties-when
6896              'article-type 'signature end (point-max)
6897              (cons 'article-type (cons 'signature
6898                                        gnus-hidden-properties))))
6899         (gnus-add-wash-type 'signature)
6900         (gnus-add-text-properties-when
6901          'article-type nil end (point-max)
6902          (cons 'article-type (cons 'signature
6903                                    gnus-hidden-properties)))))
6904     (let ((gnus-article-mime-handle-alist-1 gnus-article-mime-handle-alist))
6905       (gnus-set-mode-line 'article))))
6906
6907 (defun gnus-button-entry ()
6908   ;; Return the first entry in `gnus-button-alist' matching this place.
6909   (let ((alist gnus-button-alist)
6910         (entry nil))
6911     (while alist
6912       (setq entry (pop alist))
6913       (if (looking-at (eval (car entry)))
6914           (setq alist nil)
6915         (setq entry nil)))
6916     entry))
6917
6918 (defun gnus-button-push (marker)
6919   ;; Push button starting at MARKER.
6920   (save-excursion
6921     (goto-char marker)
6922     (let* ((entry (gnus-button-entry))
6923            (inhibit-point-motion-hooks t)
6924            (fun (nth 3 entry))
6925            (args (mapcar (lambda (group)
6926                            (let ((string (match-string group)))
6927                              (set-text-properties
6928                               0 (length string) nil string)
6929                              string))
6930                          (nthcdr 4 entry))))
6931       (cond
6932        ((fboundp fun)
6933         (apply fun args))
6934        ((and (boundp fun)
6935              (fboundp (symbol-value fun)))
6936         (apply (symbol-value fun) args))
6937        (t
6938         (gnus-message 1 "You must define `%S' to use this button"
6939                       (cons fun args)))))))
6940
6941 (defun gnus-parse-news-url (url)
6942   (let (scheme server port group message-id articles)
6943     (with-temp-buffer
6944       (insert url)
6945       (goto-char (point-min))
6946       (when (looking-at "\\([A-Za-z]+\\):")
6947         (setq scheme (match-string 1))
6948         (goto-char (match-end 0)))
6949       (when (looking-at "//\\([^:/]+\\)\\(:?\\)\\([0-9]+\\)?/")
6950         (setq server (match-string 1))
6951         (setq port (if (stringp (match-string 3))
6952                        (string-to-number (match-string 3))
6953                      (match-string 3)))
6954         (goto-char (match-end 0)))
6955
6956       (cond
6957        ((looking-at "\\(.*@.*\\)")
6958         (setq message-id (match-string 1)))
6959        ((looking-at "\\([^/]+\\)/\\([-0-9]+\\)")
6960         (setq group (match-string 1)
6961               articles (split-string (match-string 2) "-")))
6962        ((looking-at "\\([^/]+\\)/?")
6963         (setq group (match-string 1)))
6964        (t
6965         (error "Unknown news URL syntax"))))
6966     (list scheme server port group message-id articles)))
6967
6968 (defun gnus-button-handle-news (url)
6969   "Fetch a news URL."
6970   (destructuring-bind (scheme server port group message-id articles)
6971       (gnus-parse-news-url url)
6972     (cond
6973      (message-id
6974       (save-excursion
6975         (set-buffer gnus-summary-buffer)
6976         (if server
6977             (let ((gnus-refer-article-method
6978                    (nconc (list (list 'nntp server))
6979                           gnus-refer-article-method))
6980                   (nntp-port-number (or port "nntp")))
6981               (gnus-message 7 "Fetching %s with %s"
6982                             message-id gnus-refer-article-method)
6983               (gnus-summary-refer-article message-id))
6984           (gnus-summary-refer-article message-id))))
6985      (group
6986       (gnus-button-fetch-group url)))))
6987
6988 (defun gnus-button-handle-man (url)
6989   "Fetch a man page."
6990   (gnus-message 9 "`%s' `%s'" gnus-button-man-handler url)
6991   (when (eq gnus-button-man-handler 'woman)
6992     (setq url (gnus-replace-in-string url "([1-9][X1a-z]*).*\\'" "")))
6993   (gnus-message 9 "`%s' `%s'" gnus-button-man-handler url)
6994   (funcall gnus-button-man-handler url))
6995
6996 (defun gnus-button-handle-info-url (url)
6997   "Fetch an info URL."
6998   (setq url (mm-subst-char-in-string ?+ ?\  url))
6999   (cond
7000    ((string-match "^\\([^:/]+\\)?/\\(.*\\)" url)
7001     (gnus-info-find-node
7002      (concat "(" (or (gnus-url-unhex-string (match-string 1 url))
7003                      "Gnus")
7004              ")" (gnus-url-unhex-string (match-string 2 url)))))
7005    ((string-match "([^)\"]+)[^\"]+" url)
7006     (setq url
7007           (gnus-replace-in-string
7008            (gnus-replace-in-string url "[\n\t ]+" " ") "\"" ""))
7009     (gnus-info-find-node url))
7010    (t (error "Can't parse %s" url))))
7011
7012 (defun gnus-button-handle-info-url-gnome (url)
7013   "Fetch GNOME style info URL."
7014   (setq url (mm-subst-char-in-string ?_ ?\  url))
7015   (if (string-match "\\([^#]+\\)#?\\(.*\\)" url)
7016       (gnus-info-find-node
7017        (concat "("
7018                (gnus-url-unhex-string
7019                  (match-string 1 url))
7020                ")"
7021                (or (gnus-url-unhex-string
7022                     (match-string 2 url))
7023                    "Top")))
7024     (error "Can't parse %s" url)))
7025
7026 (defun gnus-button-handle-info-url-kde (url)
7027   "Fetch KDE style info URL."
7028   (gnus-info-find-node (gnus-url-unhex-string url)))
7029
7030 (defun gnus-button-handle-info-keystrokes (url)
7031   "Call `info' when pushing the corresponding URL button."
7032   ;; For links like `C-h i d m gnus RET', `C-h i d m CC Mode RET'.
7033   (info)
7034   (Info-directory)
7035   (Info-menu url))
7036
7037 (defun gnus-button-openpgp (url)
7038   "Retrieve and add an OpenPGP key given URL from an OpenPGP header."
7039   (with-temp-buffer
7040     (mm-url-insert-file-contents-external url)
7041     (pgg-snarf-keys-region (point-min) (point-max))
7042     (pgg-display-output-buffer nil nil nil)))
7043
7044 (defun gnus-button-message-id (message-id)
7045   "Fetch MESSAGE-ID."
7046   (with-current-buffer gnus-summary-buffer
7047     (gnus-summary-refer-article message-id)))
7048
7049 (defun gnus-button-fetch-group (address)
7050   "Fetch GROUP specified by ADDRESS."
7051   (if (not (string-match "[:/]" address))
7052       ;; This is just a simple group url.
7053       (gnus-group-read-ephemeral-group address gnus-select-method)
7054     (if (not
7055          (string-match
7056           "^\\([^:/]+\\)\\(:\\([^/]+\\)\\)?/\\([^/]+\\)\\(/\\([0-9]+\\)\\)?"
7057           address))
7058         (error "Can't parse %s" address)
7059       (gnus-group-read-ephemeral-group
7060        (match-string 4 address)
7061        `(nntp ,(match-string 1 address)
7062               (nntp-address ,(match-string 1 address))
7063               (nntp-port-number ,(if (match-end 3)
7064                                      (match-string 3 address)
7065                                    "nntp")))
7066        nil nil nil
7067        (and (match-end 6) (list (string-to-number (match-string 6 address))))))))
7068
7069 (defun gnus-url-parse-query-string (query &optional downcase)
7070   (let (retval pairs cur key val)
7071     (setq pairs (split-string query "&"))
7072     (while pairs
7073       (setq cur (car pairs)
7074             pairs (cdr pairs))
7075       (if (not (string-match "=" cur))
7076           nil                           ; Grace
7077         (setq key (gnus-url-unhex-string (substring cur 0 (match-beginning 0)))
7078               val (gnus-url-unhex-string (substring cur (match-end 0) nil) t))
7079         (if downcase
7080             (setq key (downcase key)))
7081         (setq cur (assoc key retval))
7082         (if cur
7083             (setcdr cur (cons val (cdr cur)))
7084           (setq retval (cons (list key val) retval)))))
7085     retval))
7086
7087 (defun gnus-url-mailto (url)
7088   ;; Send mail to someone
7089   (when (string-match "mailto:/*\\(.*\\)" url)
7090     (setq url (substring url (match-beginning 1) nil)))
7091   (let (to args subject func)
7092     (setq args (gnus-url-parse-query-string
7093                 (if (string-match "^\\?" url)
7094                     (substring url 1)
7095                   (if (string-match "^\\([^?]+\\)\\?\\(.*\\)" url)
7096                       (concat "to=" (match-string 1 url) "&"
7097                               (match-string 2 url))
7098                     (concat "to=" url)))
7099                 t)
7100           subject (cdr-safe (assoc "subject" args)))
7101     (gnus-msg-mail)
7102     (while args
7103       (setq func (intern-soft (concat "message-goto-" (downcase (caar args)))))
7104       (if (fboundp func)
7105           (funcall func)
7106         (message-position-on-field (caar args)))
7107       (insert (gnus-replace-in-string
7108                (mapconcat 'identity (reverse (cdar args)) ", ")
7109                "\r\n" "\n" t))
7110       (setq args (cdr args)))
7111     (if subject
7112         (message-goto-body)
7113       (message-goto-subject))))
7114
7115 (defun gnus-button-embedded-url (address)
7116   "Activate ADDRESS with `browse-url'."
7117   (browse-url (gnus-strip-whitespace address)))
7118
7119 ;;; Next/prev buttons in the article buffer.
7120
7121 (defvar gnus-next-page-line-format "%{%(Next page...%)%}\n")
7122 (defvar gnus-prev-page-line-format "%{%(Previous page...%)%}\n")
7123
7124 (defvar gnus-prev-page-map
7125   (let ((map (make-sparse-keymap)))
7126     (define-key map gnus-mouse-2 'gnus-button-prev-page)
7127     (define-key map "\r" 'gnus-button-prev-page)
7128     map))
7129
7130 (defvar gnus-next-page-map
7131   (let ((map (make-sparse-keymap)))
7132     (unless (>= emacs-major-version 21)
7133       ;; XEmacs doesn't care.
7134       (set-keymap-parent map gnus-article-mode-map))
7135     (define-key map gnus-mouse-2 'gnus-button-next-page)
7136     (define-key map "\r" 'gnus-button-next-page)
7137     map))
7138
7139 (defun gnus-insert-prev-page-button ()
7140   (let ((b (point))
7141         (inhibit-read-only t))
7142     (gnus-eval-format
7143      gnus-prev-page-line-format nil
7144      `(keymap ,gnus-prev-page-map
7145          gnus-prev t
7146          gnus-callback gnus-article-button-prev-page
7147          article-type annotation))
7148     (widget-convert-button
7149      'link b (if (bolp)
7150                  ;; Exclude a newline.
7151                  (1- (point))
7152                (point))
7153      :action 'gnus-button-prev-page
7154      :button-keymap gnus-prev-page-map)))
7155
7156 (defun gnus-button-next-page (&optional args more-args)
7157   "Go to the next page."
7158   (interactive)
7159   (let ((win (selected-window)))
7160     (select-window (gnus-get-buffer-window gnus-article-buffer t))
7161     (gnus-article-next-page)
7162     (select-window win)))
7163
7164 (defun gnus-button-prev-page (&optional args more-args)
7165   "Go to the prev page."
7166   (interactive)
7167   (let ((win (selected-window)))
7168     (select-window (gnus-get-buffer-window gnus-article-buffer t))
7169     (gnus-article-prev-page)
7170     (select-window win)))
7171
7172 (defun gnus-insert-next-page-button ()
7173   (let ((b (point))
7174         (inhibit-read-only t))
7175     (gnus-eval-format gnus-next-page-line-format nil
7176                       `(keymap ,gnus-next-page-map
7177                           gnus-next t
7178                           gnus-callback gnus-article-button-next-page
7179                           article-type annotation))
7180     (widget-convert-button
7181      'link b (if (bolp)
7182                  ;; Exclude a newline.
7183                  (1- (point))
7184                (point))
7185      :action 'gnus-button-next-page
7186      :button-keymap gnus-next-page-map)))
7187
7188 (defun gnus-article-button-next-page (arg)
7189   "Go to the next page."
7190   (interactive "P")
7191   (let ((win (selected-window)))
7192     (select-window (gnus-get-buffer-window gnus-article-buffer t))
7193     (gnus-article-next-page)
7194     (select-window win)))
7195
7196 (defun gnus-article-button-prev-page (arg)
7197   "Go to the prev page."
7198   (interactive "P")
7199   (let ((win (selected-window)))
7200     (select-window (gnus-get-buffer-window gnus-article-buffer t))
7201     (gnus-article-prev-page)
7202     (select-window win)))
7203
7204 (defvar gnus-decode-header-methods
7205   '(mail-decode-encoded-word-region)
7206   "List of methods used to decode headers.
7207
7208 This variable is a list of FUNCTION or (REGEXP . FUNCTION).  If item
7209 is FUNCTION, FUNCTION will be applied to all newsgroups.  If item is a
7210 \(REGEXP . FUNCTION), FUNCTION will be only apply to the newsgroups
7211 whose names match REGEXP.
7212
7213 For example:
7214 \((\"chinese\" . gnus-decode-encoded-word-region-by-guess)
7215  mail-decode-encoded-word-region
7216  (\"chinese\" . rfc1843-decode-region))
7217 ")
7218
7219 (defvar gnus-decode-header-methods-cache nil)
7220
7221 (defun gnus-multi-decode-header (start end)
7222   "Apply the functions from `gnus-encoded-word-methods' that match."
7223   (unless (and gnus-decode-header-methods-cache
7224                (eq gnus-newsgroup-name
7225                    (car gnus-decode-header-methods-cache)))
7226     (setq gnus-decode-header-methods-cache (list gnus-newsgroup-name))
7227     (mapcar (lambda (x)
7228               (if (symbolp x)
7229                   (nconc gnus-decode-header-methods-cache (list x))
7230                 (if (and gnus-newsgroup-name
7231                          (string-match (car x) gnus-newsgroup-name))
7232                     (nconc gnus-decode-header-methods-cache
7233                            (list (cdr x))))))
7234           gnus-decode-header-methods))
7235   (let ((xlist gnus-decode-header-methods-cache))
7236     (pop xlist)
7237     (save-restriction
7238       (narrow-to-region start end)
7239       (while xlist
7240         (funcall (pop xlist) (point-min) (point-max))))))
7241
7242 ;;;
7243 ;;; Treatment top-level handling.
7244 ;;;
7245
7246 (defun gnus-treat-article (condition &optional part-number total-parts type)
7247   (let ((length (- (point-max) (point-min)))
7248         (alist gnus-treatment-function-alist)
7249         (article-goto-body-goes-to-point-min-p t)
7250         (treated-type
7251          (or (not type)
7252              (catch 'found
7253                (let ((list gnus-article-treat-types))
7254                  (while list
7255                    (when (string-match (pop list) type)
7256                      (throw 'found t)))))))
7257         (highlightp (gnus-visual-p 'article-highlight 'highlight))
7258         val elem)
7259     (gnus-run-hooks 'gnus-part-display-hook)
7260     (dolist (elem alist)
7261       (setq val
7262             (save-excursion
7263               (when (gnus-buffer-live-p gnus-summary-buffer)
7264                 (set-buffer gnus-summary-buffer))
7265               (symbol-value (car elem))))
7266       (when (and (or (consp val)
7267                      treated-type)
7268                  (gnus-treat-predicate val)
7269                  (or (not (get (car elem) 'highlight))
7270                      highlightp))
7271         (save-restriction
7272           (funcall (cadr elem)))))))
7273
7274 ;; Dynamic variables.
7275 (eval-when-compile
7276   (defvar part-number)
7277   (defvar total-parts)
7278   (defvar type)
7279   (defvar condition)
7280   (defvar length))
7281
7282 (defun gnus-treat-predicate (val)
7283   (cond
7284    ((null val)
7285     nil)
7286    (condition
7287     (eq condition val))
7288    ((and (listp val)
7289          (stringp (car val)))
7290     (apply 'gnus-or (mapcar `(lambda (s)
7291                                (string-match s ,(or gnus-newsgroup-name "")))
7292                             val)))
7293    ((listp val)
7294     (let ((pred (pop val)))
7295       (cond
7296        ((eq pred 'or)
7297         (apply 'gnus-or (mapcar 'gnus-treat-predicate val)))
7298        ((eq pred 'and)
7299         (apply 'gnus-and (mapcar 'gnus-treat-predicate val)))
7300        ((eq pred 'not)
7301         (not (gnus-treat-predicate (car val))))
7302        ((eq pred 'typep)
7303         (equal (car val) type))
7304        (t
7305         (error "%S is not a valid predicate" pred)))))
7306    ((eq val t)
7307     t)
7308    ((eq val 'head)
7309     nil)
7310    ((eq val 'first)
7311     (eq part-number 1))
7312    ((eq val 'last)
7313     (eq part-number total-parts))
7314    ((numberp val)
7315     (< length val))
7316    (t
7317     (error "%S is not a valid value" val))))
7318
7319 (defun gnus-article-encrypt-body (protocol &optional n)
7320   "Encrypt the article body."
7321   (interactive
7322    (list
7323     (or gnus-article-encrypt-protocol
7324         (completing-read "Encrypt protocol: "
7325                          gnus-article-encrypt-protocol-alist
7326                          nil t))
7327     current-prefix-arg))
7328   (let ((func (cdr (assoc protocol gnus-article-encrypt-protocol-alist))))
7329     (unless func
7330       (error "Can't find the encrypt protocol %s" protocol))
7331     (if (member gnus-newsgroup-name '("nndraft:delayed"
7332                                       "nndraft:drafts"
7333                                       "nndraft:queue"))
7334         (error "Can't encrypt the article in group %s"
7335                gnus-newsgroup-name))
7336     (gnus-summary-iterate n
7337       (save-excursion
7338         (set-buffer gnus-summary-buffer)
7339         (let ((mail-parse-charset gnus-newsgroup-charset)
7340               (mail-parse-ignored-charsets gnus-newsgroup-ignored-charsets)
7341               (summary-buffer gnus-summary-buffer)
7342               references point)
7343           (gnus-set-global-variables)
7344           (when (gnus-group-read-only-p)
7345             (error "The current newsgroup does not support article encrypt"))
7346           (gnus-summary-show-article t)
7347           (setq references
7348               (or (mail-header-references gnus-current-headers) ""))
7349           (set-buffer gnus-article-buffer)
7350           (let* ((inhibit-read-only t)
7351                  (headers
7352                   (mapcar (lambda (field)
7353                             (and (save-restriction
7354                                    (message-narrow-to-head)
7355                                    (goto-char (point-min))
7356                                    (search-forward field nil t))
7357                                  (prog2
7358                                      (message-narrow-to-field)
7359                                      (buffer-string)
7360                                    (delete-region (point-min) (point-max))
7361                                    (widen))))
7362                           '("Content-Type:" "Content-Transfer-Encoding:"
7363                             "Content-Disposition:"))))
7364             (message-narrow-to-head)
7365             (message-remove-header "MIME-Version")
7366             (goto-char (point-max))
7367             (setq point (point))
7368             (insert (apply 'concat headers))
7369             (widen)
7370             (narrow-to-region point (point-max))
7371             (let ((message-options message-options))
7372               (message-options-set 'message-sender user-mail-address)
7373               (message-options-set 'message-recipients user-mail-address)
7374               (message-options-set 'message-sign-encrypt 'not)
7375               (funcall func))
7376             (goto-char (point-min))
7377             (insert "MIME-Version: 1.0\n")
7378             (widen)
7379             (gnus-summary-edit-article-done
7380              references nil summary-buffer t))
7381           (when gnus-keep-backlog
7382             (gnus-backlog-remove-article
7383              (car gnus-article-current) (cdr gnus-article-current)))
7384           (save-excursion
7385             (when (get-buffer gnus-original-article-buffer)
7386               (set-buffer gnus-original-article-buffer)
7387               (setq gnus-original-article nil)))
7388           (when gnus-use-cache
7389             (gnus-cache-update-article
7390              (car gnus-article-current) (cdr gnus-article-current))))))))
7391
7392 (defvar gnus-mime-security-button-line-format "%{%([[%t:%i]%D]%)%}\n"
7393   "The following specs can be used:
7394 %t  The security MIME type
7395 %i  Additional info
7396 %d  Details
7397 %D  Details if button is pressed")
7398
7399 (defvar gnus-mime-security-button-end-line-format "%{%([[End of %t]%D]%)%}\n"
7400   "The following specs can be used:
7401 %t  The security MIME type
7402 %i  Additional info
7403 %d  Details
7404 %D  Details if button is pressed")
7405
7406 (defvar gnus-mime-security-button-line-format-alist
7407   '((?t gnus-tmp-type ?s)
7408     (?i gnus-tmp-info ?s)
7409     (?d gnus-tmp-details ?s)
7410     (?D gnus-tmp-pressed-details ?s)))
7411
7412 (defvar gnus-mime-security-button-commands
7413   '((gnus-article-press-button "\r" "Show Detail")
7414     (undefined "v")
7415     (undefined "t")
7416     (undefined "C")
7417     (gnus-mime-security-save-part "o" "Save...")
7418     (undefined "\C-o")
7419     (undefined "r")
7420     (undefined "d")
7421     (undefined "c")
7422     (undefined "i")
7423     (undefined "E")
7424     (undefined "e")
7425     (undefined "p")
7426     (gnus-mime-security-pipe-part "|" "Pipe To Command...")
7427     (undefined ".")))
7428
7429 (defvar gnus-mime-security-button-map
7430   (let ((map (make-sparse-keymap)))
7431     (define-key map gnus-mouse-2 'gnus-article-push-button)
7432     (define-key map gnus-down-mouse-3 'gnus-mime-security-button-menu)
7433     (dolist (c gnus-mime-security-button-commands)
7434       (define-key map (cadr c) (car c)))
7435     map))
7436
7437 (easy-menu-define
7438   gnus-mime-security-button-menu gnus-mime-security-button-map
7439   "Security button menu."
7440   `("Security Part"
7441     ,@(delq nil
7442             (mapcar (lambda (c)
7443                       (unless (eq (car c) 'undefined)
7444                         (vector (caddr c) (car c) :enable t)))
7445                     gnus-mime-security-button-commands))))
7446
7447 (defun gnus-mime-security-button-menu (event prefix)
7448   "Construct a context-sensitive menu of security commands."
7449   (interactive "e\nP")
7450   (save-window-excursion
7451     (let ((pos (event-start event)))
7452       (select-window (posn-window pos))
7453       (goto-char (posn-point pos))
7454       (gnus-article-check-buffer)
7455       (popup-menu gnus-mime-security-button-menu nil prefix))))
7456
7457 (defvar gnus-mime-security-details-buffer nil)
7458
7459 (defvar gnus-mime-security-button-pressed nil)
7460
7461 (defvar gnus-mime-security-show-details-inline t
7462   "If non-nil, show details in the article buffer.")
7463
7464 (defun gnus-mime-security-verify-or-decrypt (handle)
7465   (mm-remove-parts (cdr handle))
7466   (let ((region (mm-handle-multipart-ctl-parameter handle 'gnus-region))
7467         point (inhibit-read-only t))
7468     (if region
7469         (goto-char (car region)))
7470     (save-restriction
7471       (narrow-to-region (point) (point))
7472       (with-current-buffer (mm-handle-multipart-original-buffer handle)
7473         (let* ((mm-verify-option 'known)
7474                (mm-decrypt-option 'known)
7475                (nparts (mm-possibly-verify-or-decrypt (cdr handle) handle)))
7476           (unless (eq nparts (cdr handle))
7477             (mm-destroy-parts (cdr handle))
7478             (setcdr handle nparts))))
7479       (setq point (point))
7480       (gnus-mime-display-security handle)
7481       (goto-char (point-max)))
7482     (when region
7483       (delete-region (point) (cdr region))
7484       (set-marker (car region) nil)
7485       (set-marker (cdr region) nil))
7486     (goto-char point)))
7487
7488 (defun gnus-mime-security-show-details (handle)
7489   (let ((details (mm-handle-multipart-ctl-parameter handle 'gnus-details)))
7490     (if (not details)
7491         (gnus-message 5 "No details.")
7492       (if gnus-mime-security-show-details-inline
7493           (let ((gnus-mime-security-button-pressed
7494                  (not (get-text-property (point) 'gnus-mime-details)))
7495                 (gnus-mime-security-button-line-format
7496                  (get-text-property (point) 'gnus-line-format))
7497                 (inhibit-read-only t))
7498             (forward-char -1)
7499             (while (eq (get-text-property (point) 'gnus-line-format)
7500                        gnus-mime-security-button-line-format)
7501               (forward-char -1))
7502             (forward-char)
7503             (save-restriction
7504               (narrow-to-region (point) (point))
7505               (gnus-insert-mime-security-button handle))
7506             (delete-region (point)
7507                            (or (text-property-not-all
7508                                 (point) (point-max)
7509                                 'gnus-line-format
7510                                 gnus-mime-security-button-line-format)
7511                                (point-max))))
7512         ;; Not inlined.
7513         (if (gnus-buffer-live-p gnus-mime-security-details-buffer)
7514             (with-current-buffer gnus-mime-security-details-buffer
7515               (erase-buffer)
7516               t)
7517           (setq gnus-mime-security-details-buffer
7518                 (gnus-get-buffer-create "*MIME Security Details*")))
7519         (with-current-buffer gnus-mime-security-details-buffer
7520           (insert details)
7521           (goto-char (point-min)))
7522         (pop-to-buffer gnus-mime-security-details-buffer)))))
7523
7524 (defun gnus-mime-security-press-button (handle)
7525   (save-excursion
7526     (if (mm-handle-multipart-ctl-parameter handle 'gnus-info)
7527         (gnus-mime-security-show-details handle)
7528       (gnus-mime-security-verify-or-decrypt handle))))
7529
7530 (defun gnus-insert-mime-security-button (handle &optional displayed)
7531   (let* ((protocol (mm-handle-multipart-ctl-parameter handle 'protocol))
7532          (gnus-tmp-type
7533           (concat
7534            (or (nth 2 (assoc protocol mm-verify-function-alist))
7535                (nth 2 (assoc protocol mm-decrypt-function-alist))
7536                "Unknown")
7537            (if (equal (car handle) "multipart/signed")
7538                " Signed" " Encrypted")
7539            " Part"))
7540          (gnus-tmp-info
7541           (or (mm-handle-multipart-ctl-parameter handle 'gnus-info)
7542               "Undecided"))
7543          (gnus-tmp-details
7544           (mm-handle-multipart-ctl-parameter handle 'gnus-details))
7545          gnus-tmp-pressed-details
7546          b e)
7547     (setq gnus-tmp-details
7548           (if gnus-tmp-details
7549               (concat "\n" gnus-tmp-details)
7550             ""))
7551     (setq gnus-tmp-pressed-details
7552           (if gnus-mime-security-button-pressed gnus-tmp-details ""))
7553     (unless (bolp)
7554       (insert "\n"))
7555     (setq b (point))
7556     (gnus-eval-format
7557      gnus-mime-security-button-line-format
7558      gnus-mime-security-button-line-format-alist
7559      `(keymap ,gnus-mime-security-button-map
7560          gnus-callback gnus-mime-security-press-button
7561          gnus-line-format ,gnus-mime-security-button-line-format
7562          gnus-mime-details ,gnus-mime-security-button-pressed
7563          article-type annotation
7564          gnus-data ,handle))
7565     (setq e (if (bolp)
7566                 ;; Exclude a newline.
7567                 (1- (point))
7568               (point)))
7569     (widget-convert-button
7570      'link b e
7571      :mime-handle handle
7572      :action 'gnus-widget-press-button
7573      :button-keymap gnus-mime-security-button-map
7574      :help-echo
7575      (lambda (widget/window &optional overlay pos)
7576        ;; Needed to properly clear the message due to a bug in
7577        ;; wid-edit (XEmacs only).
7578        (when (boundp 'help-echo-owns-message)
7579          (setq help-echo-owns-message t))
7580        (format
7581         "%S: show detail; %S: more options"
7582         (aref gnus-mouse-2 0)
7583         (aref gnus-down-mouse-3 0))))))
7584
7585 (defun gnus-mime-display-security (handle)
7586   (save-restriction
7587     (narrow-to-region (point) (point))
7588     (unless (gnus-unbuttonized-mime-type-p (car handle))
7589       (gnus-insert-mime-security-button handle))
7590     (gnus-mime-display-part (cadr handle))
7591     (unless (bolp)
7592       (insert "\n"))
7593     (unless (gnus-unbuttonized-mime-type-p (car handle))
7594       (let ((gnus-mime-security-button-line-format
7595              gnus-mime-security-button-end-line-format))
7596         (gnus-insert-mime-security-button handle)))
7597     (mm-set-handle-multipart-parameter
7598      handle 'gnus-region
7599      (cons (set-marker (make-marker) (point-min))
7600            (set-marker (make-marker) (point-max))))))
7601
7602 (defun gnus-mime-security-run-function (function)
7603   "Run FUNCTION with the security part under point."
7604   (gnus-article-check-buffer)
7605   (let ((data (get-text-property (point) 'gnus-data))
7606         buffer handle)
7607     (when (and (stringp (car-safe data))
7608                (setq buffer (mm-handle-multipart-original-buffer data))
7609                (setq handle (cadr data)))
7610       (if (bufferp (mm-handle-buffer handle))
7611           (progn
7612             (setq handle (cons buffer (copy-sequence (cdr handle))))
7613             (mm-handle-set-undisplayer handle nil))
7614         (setq handle (mm-make-handle
7615                       buffer
7616                       (mm-handle-multipart-ctl-parameter handle 'protocol)
7617                       nil nil nil nil nil nil)))
7618       (funcall function handle))))
7619
7620 (defun gnus-mime-security-save-part ()
7621   "Save the security part under point."
7622   (interactive)
7623   (gnus-mime-security-run-function 'mm-save-part))
7624
7625 (defun gnus-mime-security-pipe-part ()
7626   "Pipe the security part under point to a process."
7627   (interactive)
7628   (gnus-mime-security-run-function 'mm-pipe-part))
7629
7630 (gnus-ems-redefine)
7631
7632 (provide 'gnus-art)
7633
7634 (run-hooks 'gnus-art-load-hook)
7635
7636 ;;; arch-tag: 2654516f-6279-48f9-a83b-05c1fa450c33
7637 ;;; gnus-art.el ends here