git.chise.org Git - elisp/gnus.git-/blob - lisp/gnus-art.el

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