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