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