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

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