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