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

   1 ;;; gnus-art.el --- article mode commands for Gnus
   2 ;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002
   3 ;;        Free Software Foundation, Inc.
   4
   5 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
   6 ;; Keywords: news
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software; you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 2, or (at your option)
  13 ;; any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23 ;; Boston, MA 02111-1307, USA.
  24
  25 ;;; Commentary:
  26
  27 ;;; Code:
  28
  29 (eval-when-compile (require 'cl))
  30
  31 (require 'gnus)
  32 (require 'gnus-sum)
  33 (require 'gnus-spec)
  34 (require 'gnus-int)
  35 (require 'gnus-win)
  36 (require 'mm-bodies)
  37 (require 'mail-parse)
  38 (require 'mm-decode)
  39 (require 'mm-view)
  40 (require 'wid-edit)
  41 (require 'mm-uu)
  42
  43 (autoload 'gnus-msg-mail "gnus-msg" nil t)
  44 (autoload 'gnus-button-mailto "gnus-msg")
  45 (autoload 'gnus-button-reply "gnus-msg" nil t)
  46
  47 (defgroup gnus-article nil
  48   "Article display."
  49   :link '(custom-manual "(gnus)The Article Buffer")
  50   :group 'gnus)
  51
  52 (defgroup gnus-article-treat nil
  53   "Treating article parts."
  54   :link '(custom-manual "(gnus)Article Hiding")
  55   :group 'gnus-article)
  56
  57 (defgroup gnus-article-hiding nil
  58   "Hiding article parts."
  59   :link '(custom-manual "(gnus)Article Hiding")
  60   :group 'gnus-article)
  61
  62 (defgroup gnus-article-highlight nil
  63   "Article highlighting."
  64   :link '(custom-manual "(gnus)Article Highlighting")
  65   :group 'gnus-article
  66   :group 'gnus-visual)
  67
  68 (defgroup gnus-article-signature nil
  69   "Article signatures."
  70   :link '(custom-manual "(gnus)Article Signature")
  71   :group 'gnus-article)
  72
  73 (defgroup gnus-article-headers nil
  74   "Article headers."
  75   :link '(custom-manual "(gnus)Hiding Headers")
  76   :group 'gnus-article)
  77
  78 (defgroup gnus-article-washing nil
  79   "Special commands on articles."
  80   :link '(custom-manual "(gnus)Article Washing")
  81   :group 'gnus-article)
  82
  83 (defgroup gnus-article-emphasis nil
  84   "Fontisizing articles."
  85   :link '(custom-manual "(gnus)Article Fontisizing")
  86   :group 'gnus-article)
  87
  88 (defgroup gnus-article-saving nil
  89   "Saving articles."
  90   :link '(custom-manual "(gnus)Saving Articles")
  91   :group 'gnus-article)
  92
  93 (defgroup gnus-article-mime nil
  94   "Worshiping the MIME wonder."
  95   :link '(custom-manual "(gnus)Using MIME")
  96   :group 'gnus-article)
  97
  98 (defgroup gnus-article-buttons nil
  99   "Pushable buttons in the article buffer."
 100   :link '(custom-manual "(gnus)Article Buttons")
 101   :group 'gnus-article)
 102
 103 (defgroup gnus-article-various nil
 104   "Other article options."
 105   :link '(custom-manual "(gnus)Misc Article")
 106   :group 'gnus-article)
 107
 108 (defcustom gnus-ignored-headers
 109   '("^Path:" "^Expires:" "^Date-Received:" "^References:" "^Xref:" "^Lines:"
 110     "^Relay-Version:" "^Message-ID:" "^Approved:" "^Sender:" "^Received:"
 111     "^X-UIDL:" "^MIME-Version:" "^Return-Path:" "^In-Reply-To:"
 112     "^Content-Type:" "^Content-Transfer-Encoding:" "^X-WebTV-Signature:"
 113     "^X-MimeOLE:" "^X-MSMail-Priority:" "^X-Priority:" "^X-Loop:"
 114     "^X-Authentication-Warning:" "^X-MIME-Autoconverted:" "^X-Face"
 115     "^X-Attribution:" "^X-Originating-IP:" "^Delivered-To:"
 116     "^NNTP-[-A-Za-z]+:" "^Distribution:" "^X-no-archive:" "^X-Trace:"
 117     "^X-Complaints-To:" "^X-NNTP-Posting-Host:" "^X-Orig.*:"
 118     "^Abuse-Reports-To:" "^Cache-Post-Path:" "^X-Article-Creation-Date:"
 119     "^X-Poster:" "^X-Mail2News-Path:" "^X-Server-Date:" "^X-Cache:"
 120     "^Originator:" "^X-Problems-To:" "^X-Auth-User:" "^X-Post-Time:"
 121     "^X-Admin:" "^X-UID:" "^Resent-[-A-Za-z]+:" "^X-Mailing-List:"
 122     "^Precedence:" "^Original-[-A-Za-z]+:" "^X-filename:" "^X-Orcpt:"
 123     "^Old-Received:" "^X-Pgp" "^X-Auth:" "^X-From-Line:"
 124     "^X-Gnus-Article-Number:" "^X-Majordomo:" "^X-Url:" "^X-Sender:"
 125     "^MBOX-Line" "^Priority:" "^X400-[-A-Za-z]+:"
 126     "^Status:" "^X-Gnus-Mail-Source:" "^Cancel-Lock:"
 127     "^X-FTN" "^X-EXP32-SerialNo:" "^Encoding:" "^Importance:"
 128     "^Autoforwarded:" "^Original-Encoded-Information-Types:" "^X-Ya-Pop3:"
 129     "^X-Face-Version:" "^X-Vms-To:" "^X-ML-NAME:" "^X-ML-COUNT:"
 130     "^Mailing-List:" "^X-finfo:" "^X-md5sum:" "^X-md5sum-Origin:"
 131     "^X-Sun-Charset:" "^X-Accept-Language:" "^X-Envelope-Sender:"
 132     "^List-[A-Za-z]+:" "^X-Listprocessor-Version:"
 133     "^X-Received:" "^X-Distribute:" "^X-Sequence:" "^X-Juno-Line-Breaks:"
 134     "^X-Notes-Item:" "^X-MS-TNEF-Correlator:" "^x-uunet-gateway:"
 135     "^X-Received:" "^Content-length:" "X-precedence:"
 136     "^X-Authenticated-User:" "^X-Comment" "^X-Report:" "^X-Abuse-Info:"
 137     "^X-HTTP-Proxy:" "^X-Mydeja-Info:" "^X-Copyright" "^X-No-Markup:"
 138     "^X-Abuse-Info:" "^X-From_:" "^X-Accept-Language:" "^Errors-To:"
 139     "^X-BeenThere:" "^X-Mailman-Version:" "^List-Help:" "^List-Post:"
 140     "^List-Subscribe:" "^List-Id:" "^List-Unsubscribe:" "^List-Archive:"
 141      "^X-Content-length:" "^X-Posting-Agent:" "^Original-Received:"
 142      "^X-Request-PGP:" "^X-Fingerprint:" "^X-WRIEnvto:" "^X-WRIEnvfrom:"
 143      "^X-Virus-Scanned:" "^X-Delivery-Agent:" "^Posted-Date:" "^X-Gateway:"
 144      "^X-Local-Origin:" "^X-Local-Destination:" "^X-UserInfo1:"
 145      "^X-Received-Date:")
 146   "*All headers that start with this regexp will be hidden.
 147 This variable can also be a list of regexps of headers to be ignored.
 148 If `gnus-visible-headers' is non-nil, this variable will be ignored."
 149   :type '(choice :custom-show nil
 150                  regexp
 151                  (repeat regexp))
 152   :group 'gnus-article-hiding)
 153
 154 (defcustom gnus-visible-headers
 155   "^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:"
 156   "*All headers that do not match this regexp will be hidden.
 157 This variable can also be a list of regexp of headers to remain visible.
 158 If this variable is non-nil, `gnus-ignored-headers' will be ignored."
 159   :type '(repeat :value-to-internal (lambda (widget value)
 160                                       (custom-split-regexp-maybe value))
 161                  :match (lambda (widget value)
 162                           (or (stringp value)
 163                               (widget-editable-list-match widget value)))
 164                  regexp)
 165   :group 'gnus-article-hiding)
 166
 167 (defcustom gnus-sorted-header-list
 168   '("^From:" "^Subject:" "^Summary:" "^Keywords:" "^Newsgroups:"
 169     "^Followup-To:" "^To:" "^Cc:" "^Date:" "^Organization:")
 170   "*This variable is a list of regular expressions.
 171 If it is non-nil, headers that match the regular expressions will
 172 be placed first in the article buffer in the sequence specified by
 173 this list."
 174   :type '(repeat regexp)
 175   :group 'gnus-article-hiding)
 176
 177 (defcustom gnus-boring-article-headers '(empty followup-to reply-to)
 178   "Headers that are only to be displayed if they have interesting data.
 179 Possible values in this list are:
 180
 181   'empty       Headers with no content.
 182   'newsgroups  Newsgroup identical to Gnus group.
 183   'to-address  To identical to To-address.
 184   'followup-to Followup-to identical to Newsgroups.
 185   'reply-to    Reply-to identical to From.
 186   'date        Date less than four days old.
 187   'long-to     To and/or Cc longer than 1024 characters.
 188   'many-to     Multiple To and/or Cc."
 189   :type '(set (const :tag "Headers with no content." empty)
 190               (const :tag "Newsgroups identical to Gnus group." newsgroups)
 191               (const :tag "To identical to To-address." to-address)
 192               (const :tag "Followup-to identical to Newsgroups." followup-to)
 193               (const :tag "Reply-to identical to From." reply-to)
 194               (const :tag "Date less than four days old." date)
 195               (const :tag "To and/or Cc longer than 1024 characters." long-to)
 196               (const :tag "Multiple To and/or Cc headers." many-to))
 197   :group 'gnus-article-hiding)
 198
 199 (defcustom gnus-signature-separator '("^-- $" "^-- *$")
 200   "Regexp matching signature separator.
 201 This can also be a list of regexps.  In that case, it will be checked
 202 from head to tail looking for a separator.  Searches will be done from
 203 the end of the buffer."
 204   :type '(repeat string)
 205   :group 'gnus-article-signature)
 206
 207 (defcustom gnus-signature-limit nil
 208   "Provide a limit to what is considered a signature.
 209 If it is a number, no signature may not be longer (in characters) than
 210 that number.  If it is a floating point number, no signature may be
 211 longer (in lines) than that number.  If it is a function, the function
 212 will be called without any parameters, and if it returns nil, there is
 213 no signature in the buffer.  If it is a string, it will be used as a
 214 regexp.  If it matches, the text in question is not a signature."
 215   :type '(choice (integer :value 200)
 216                  (number :value 4.0)
 217                  (function :value fun)
 218                  (regexp :value ".*"))
 219   :group 'gnus-article-signature)
 220
 221 (defcustom gnus-hidden-properties '(invisible t intangible t)
 222   "Property list to use for hiding text."
 223   :type 'sexp
 224   :group 'gnus-article-hiding)
 225
 226 ;; Fixme: This isn't the right thing for mixed graphical and and
 227 ;; non-graphical frames in a session.
 228 (defcustom gnus-article-x-face-command
 229   (if (featurep 'xemacs)
 230       (if (or (gnus-image-type-available-p 'xface)
 231               (gnus-image-type-available-p 'pbm))
 232           'gnus-display-x-face-in-from
 233         "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | ee -")
 234     (if (gnus-image-type-available-p 'pbm)
 235         'gnus-display-x-face-in-from
 236       "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | \
 237 display -"))
 238   "*String or function to be executed to display an X-Face header.
 239 If it is a string, the command will be executed in a sub-shell
 240 asynchronously.  The compressed face will be piped to this command."
 241   :type `(choice string
 242                  (function-item gnus-display-x-face-in-from)
 243                  function)
 244   :version "21.1"
 245   :group 'gnus-article-washing)
 246
 247 (defcustom gnus-article-x-face-too-ugly nil
 248   "Regexp matching posters whose face shouldn't be shown automatically."
 249   :type '(choice regexp (const nil))
 250   :group 'gnus-article-washing)
 251
 252 (defcustom gnus-article-banner-alist nil
 253   "Banner alist for stripping.
 254 For example,
 255      ((egroups . \"^[ \\t\\n]*-------------------+\\\\( \\\\(e\\\\|Yahoo! \\\\)Groups Sponsor -+\\\\)?....\\n\\\\(.+\\n\\\\)+\"))"
 256   :version "21.1"
 257   :type '(repeat (cons symbol regexp))
 258   :group 'gnus-article-washing)
 259
 260 (gnus-define-group-parameter
 261  banner
 262  :variable-document
 263  "Alist of regexps (to match group names) and banner."
 264  :variable-group gnus-article-washing
 265  :parameter-type
 266  '(choice :tag "Banner"
 267           :value nil
 268           (const :tag "Remove signature" signature)
 269           (symbol :tag "Item in `gnus-article-banner-alist'" none)
 270           regexp
 271           (const :tag "None" nil))
 272  :parameter-document
 273  "If non-nil, specify how to remove `banners' from articles.
 274
 275 Symbol `signature' means to remove signatures delimited by
 276 `gnus-signature-separator'.  Any other symbol is used to look up a
 277 regular expression to match the banner in `gnus-article-banner-alist'.
 278 A string is used as a regular expression to match the banner
 279 directly.")
 280
 281 (defcustom gnus-emphasis-alist
 282   (let ((format
 283          "\\(\\s-\\|^\\|\\=\\|[-\"]\\|\\s(\\)\\(%s\\(\\w+\\(\\s-+\\w+\\)*[.,]?\\)%s\\)\\(\\([-,.;:!?\"]\\|\\s)\\)+\\s-\\|[?!.]\\s-\\|\\s)\\|\\s-\\)")
 284         (types
 285          '(("\\*" "\\*" bold)
 286            ("_" "_" underline)
 287            ("/" "/" italic)
 288            ("_/" "/_" underline-italic)
 289            ("_\\*" "\\*_" underline-bold)
 290            ("\\*/" "/\\*" bold-italic)
 291            ("_\\*/" "/\\*_" underline-bold-italic))))
 292     `(,@(mapcar
 293          (lambda (spec)
 294            (list
 295             (format format (car spec) (cadr spec))
 296             2 3 (intern (format "gnus-emphasis-%s" (nth 2 spec)))))
 297          types)
 298         ("\\(\\s-\\|^\\)\\(_\\(\\(\\w\\|_[^_]\\)+\\)_\\)\\(\\s-\\|[?!.,;]\\)"
 299          2 3 gnus-emphasis-underline)))
 300   "*Alist that says how to fontify certain phrases.
 301 Each item looks like this:
 302
 303   (\"_\\\\(\\\\w+\\\\)_\" 0 1 'underline)
 304
 305 The first element is a regular expression to be matched.  The second
 306 is a number that says what regular expression grouping used to find
 307 the entire emphasized word.  The third is a number that says what
 308 regexp grouping should be displayed and highlighted.  The fourth
 309 is the face used for highlighting."
 310   :type '(repeat (list :value ("" 0 0 default)
 311                        regexp
 312                        (integer :tag "Match group")
 313                        (integer :tag "Emphasize group")
 314                        face))
 315   :group 'gnus-article-emphasis)
 316
 317 (defcustom gnus-emphasize-whitespace-regexp "^[ \t]+\\|[ \t]*\n"
 318   "A regexp to describe whitespace which should not be emphasized.
 319 Typical values are \"^[ \\t]+\\\\|[ \\t]*\\n\" and \"[ \\t]+\\\\|[ \\t]*\\n\".
 320 The former avoids underlining of leading and trailing whitespace,
 321 and the latter avoids underlining any whitespace at all."
 322   :version "21.1"
 323   :group 'gnus-article-emphasis
 324   :type 'regexp)
 325
 326 (defface gnus-emphasis-bold '((t (:bold t)))
 327   "Face used for displaying strong emphasized text (*word*)."
 328   :group 'gnus-article-emphasis)
 329
 330 (defface gnus-emphasis-italic '((t (:italic t)))
 331   "Face used for displaying italic emphasized text (/word/)."
 332   :group 'gnus-article-emphasis)
 333
 334 (defface gnus-emphasis-underline '((t (:underline t)))
 335   "Face used for displaying underlined emphasized text (_word_)."
 336   :group 'gnus-article-emphasis)
 337
 338 (defface gnus-emphasis-underline-bold '((t (:bold t :underline t)))
 339   "Face used for displaying underlined bold emphasized text (_*word*_)."
 340   :group 'gnus-article-emphasis)
 341
 342 (defface gnus-emphasis-underline-italic '((t (:italic t :underline t)))
 343   "Face used for displaying underlined italic emphasized text (_/word/_)."
 344   :group 'gnus-article-emphasis)
 345
 346 (defface gnus-emphasis-bold-italic '((t (:bold t :italic t)))
 347   "Face used for displaying bold italic emphasized text (/*word*/)."
 348   :group 'gnus-article-emphasis)
 349
 350 (defface gnus-emphasis-underline-bold-italic
 351   '((t (:bold t :italic t :underline t)))
 352   "Face used for displaying underlined bold italic emphasized text.
 353 Esample: (_/*word*/_)."
 354   :group 'gnus-article-emphasis)
 355
 356 (defface gnus-emphasis-highlight-words
 357   '((t (:background "black" :foreground "yellow")))
 358   "Face used for displaying highlighted words."
 359   :group 'gnus-article-emphasis)
 360
 361 (defcustom gnus-article-time-format "%a, %b %d %Y %T %Z"
 362   "Format for display of Date headers in article bodies.
 363 See `format-time-string' for the possible values.
 364
 365 The variable can also be function, which should return a complete Date
 366 header.  The function is called with one argument, the time, which can
 367 be fed to `format-time-string'."
 368   :type '(choice string symbol)
 369   :link '(custom-manual "(gnus)Article Date")
 370   :group 'gnus-article-washing)
 371
 372 (eval-and-compile
 373   (autoload 'mail-extract-address-components "mail-extr"))
 374
 375 (defcustom gnus-save-all-headers t
 376   "*If non-nil, don't remove any headers before saving."
 377   :group 'gnus-article-saving
 378   :type 'boolean)
 379
 380 (defcustom gnus-prompt-before-saving 'always
 381   "*This variable says how much prompting is to be done when saving articles.
 382 If it is nil, no prompting will be done, and the articles will be
 383 saved to the default files.  If this variable is `always', each and
 384 every article that is saved will be preceded by a prompt, even when
 385 saving large batches of articles.  If this variable is neither nil not
 386 `always', there the user will be prompted once for a file name for
 387 each invocation of the saving commands."
 388   :group 'gnus-article-saving
 389   :type '(choice (item always)
 390                  (item :tag "never" nil)
 391                  (sexp :tag "once" :format "%t\n" :value t)))
 392
 393 (defcustom gnus-saved-headers gnus-visible-headers
 394   "Headers to keep if `gnus-save-all-headers' is nil.
 395 If `gnus-save-all-headers' is non-nil, this variable will be ignored.
 396 If that variable is nil, however, all headers that match this regexp
 397 will be kept while the rest will be deleted before saving."
 398   :group 'gnus-article-saving
 399   :type 'regexp)
 400
 401 (defcustom gnus-default-article-saver 'gnus-summary-save-in-rmail
 402   "A function to save articles in your favourite format.
 403 The function must be interactively callable (in other words, it must
 404 be an Emacs command).
 405
 406 Gnus provides the following functions:
 407
 408 * gnus-summary-save-in-rmail (Rmail format)
 409 * gnus-summary-save-in-mail (Unix mail format)
 410 * gnus-summary-save-in-folder (MH folder)
 411 * gnus-summary-save-in-file (article format)
 412 * gnus-summary-save-body-in-file (article body)
 413 * gnus-summary-save-in-vm (use VM's folder format)
 414 * gnus-summary-write-to-file (article format -- overwrite)."
 415   :group 'gnus-article-saving
 416   :type '(radio (function-item gnus-summary-save-in-rmail)
 417                 (function-item gnus-summary-save-in-mail)
 418                 (function-item gnus-summary-save-in-folder)
 419                 (function-item gnus-summary-save-in-file)
 420                 (function-item gnus-summary-save-body-in-file)
 421                 (function-item gnus-summary-save-in-vm)
 422                 (function-item gnus-summary-write-to-file)))
 423
 424 (defcustom gnus-rmail-save-name 'gnus-plain-save-name
 425   "A function generating a file name to save articles in Rmail format.
 426 The function is called with NEWSGROUP, HEADERS, and optional LAST-FILE."
 427   :group 'gnus-article-saving
 428   :type 'function)
 429
 430 (defcustom gnus-mail-save-name 'gnus-plain-save-name
 431   "A function generating a file name to save articles in Unix mail format.
 432 The function is called with NEWSGROUP, HEADERS, and optional LAST-FILE."
 433   :group 'gnus-article-saving
 434   :type 'function)
 435
 436 (defcustom gnus-folder-save-name 'gnus-folder-save-name
 437   "A function generating a file name to save articles in MH folder.
 438 The function is called with NEWSGROUP, HEADERS, and optional LAST-FOLDER."
 439   :group 'gnus-article-saving
 440   :type 'function)
 441
 442 (defcustom gnus-file-save-name 'gnus-numeric-save-name
 443   "A function generating a file name to save articles in article format.
 444 The function is called with NEWSGROUP, HEADERS, and optional
 445 LAST-FILE."
 446   :group 'gnus-article-saving
 447   :type 'function)
 448
 449 (defcustom gnus-split-methods
 450   '((gnus-article-archive-name)
 451     (gnus-article-nndoc-name))
 452   "*Variable used to suggest where articles are to be saved.
 453 For instance, if you would like to save articles related to Gnus in
 454 the file \"gnus-stuff\", and articles related to VM in \"vm-stuff\",
 455 you could set this variable to something like:
 456
 457  '((\"^Subject:.*gnus\\|^Newsgroups:.*gnus\" \"gnus-stuff\")
 458    (\"^Subject:.*vm\\|^Xref:.*vm\" \"vm-stuff\"))
 459
 460 This variable is an alist where the where the key is the match and the
 461 value is a list of possible files to save in if the match is non-nil.
 462
 463 If the match is a string, it is used as a regexp match on the
 464 article.  If the match is a symbol, that symbol will be funcalled
 465 from the buffer of the article to be saved with the newsgroup as the
 466 parameter.  If it is a list, it will be evaled in the same buffer.
 467
 468 If this form or function returns a string, this string will be used as
 469 a possible file name; and if it returns a non-nil list, that list will
 470 be used as possible file names."
 471   :group 'gnus-article-saving
 472   :type '(repeat (choice (list :value (fun) function)
 473                          (cons :value ("" "") regexp (repeat string))
 474                          (sexp :value nil))))
 475
 476 (defcustom gnus-page-delimiter "^\^L"
 477   "*Regexp describing what to use as article page delimiters.
 478 The default value is \"^\^L\", which is a form linefeed at the
 479 beginning of a line."
 480   :type 'regexp
 481   :group 'gnus-article-various)
 482
 483 (defcustom gnus-article-mode-line-format "Gnus: %g [%w] %S%m"
 484   "*The format specification for the article mode line.
 485 See `gnus-summary-mode-line-format' for a closer description.
 486
 487 The following additional specs are available:
 488
 489 %w  The article washing status.
 490 %m  The number of MIME parts in the article."
 491   :type 'string
 492   :group 'gnus-article-various)
 493
 494 (defcustom gnus-article-mode-hook nil
 495   "*A hook for Gnus article mode."
 496   :type 'hook
 497   :group 'gnus-article-various)
 498
 499 (when (featurep 'xemacs)
 500   ;; Extracted from gnus-xmas-define in order to preserve user settings
 501   (when (fboundp 'turn-off-scroll-in-place)
 502     (add-hook 'gnus-article-mode-hook 'turn-off-scroll-in-place))
 503   ;; Extracted from gnus-xmas-redefine in order to preserve user settings
 504   (add-hook 'gnus-article-mode-hook 'gnus-xmas-article-menu-add))
 505
 506 (defcustom gnus-article-menu-hook nil
 507   "*Hook run after the creation of the article mode menu."
 508   :type 'hook
 509   :group 'gnus-article-various)
 510
 511 (defcustom gnus-article-prepare-hook nil
 512   "*A hook called after an article has been prepared in the article buffer."
 513   :type 'hook
 514   :group 'gnus-article-various)
 515
 516 (defcustom gnus-article-hide-pgp-hook nil
 517   "*A hook called after successfully hiding a PGP signature."
 518   :type 'hook
 519   :group 'gnus-article-various)
 520
 521 (defcustom gnus-article-button-face 'bold
 522   "Face used for highlighting buttons in the article buffer.
 523
 524 An article button is a piece of text that you can activate by pressing
 525 `RET' or `mouse-2' above it."
 526   :type 'face
 527   :group 'gnus-article-buttons)
 528
 529 (defcustom gnus-article-mouse-face 'highlight
 530   "Face used for mouse highlighting in the article buffer.
 531
 532 Article buttons will be displayed in this face when the cursor is
 533 above them."
 534   :type 'face
 535   :group 'gnus-article-buttons)
 536
 537 (defcustom gnus-signature-face 'gnus-signature-face
 538   "Face used for highlighting a signature in the article buffer.
 539 Obsolete; use the face `gnus-signature-face' for customizations instead."
 540   :type 'face
 541   :group 'gnus-article-highlight
 542   :group 'gnus-article-signature)
 543
 544 (defface gnus-signature-face
 545   '((t
 546      (:italic t)))
 547   "Face used for highlighting a signature in the article buffer."
 548   :group 'gnus-article-highlight
 549   :group 'gnus-article-signature)
 550
 551 (defface gnus-header-from-face
 552   '((((class color)
 553       (background dark))
 554      (:foreground "spring green"))
 555     (((class color)
 556       (background light))
 557      (:foreground "red3"))
 558     (t
 559      (:italic t)))
 560   "Face used for displaying from headers."
 561   :group 'gnus-article-headers
 562   :group 'gnus-article-highlight)
 563
 564 (defface gnus-header-subject-face
 565   '((((class color)
 566       (background dark))
 567      (:foreground "SeaGreen3"))
 568     (((class color)
 569       (background light))
 570      (:foreground "red4"))
 571     (t
 572      (:bold t :italic t)))
 573   "Face used for displaying subject headers."
 574   :group 'gnus-article-headers
 575   :group 'gnus-article-highlight)
 576
 577 (defface gnus-header-newsgroups-face
 578   '((((class color)
 579       (background dark))
 580      (:foreground "yellow" :italic t))
 581     (((class color)
 582       (background light))
 583      (:foreground "MidnightBlue" :italic t))
 584     (t
 585      (:italic t)))
 586   "Face used for displaying newsgroups headers."
 587   :group 'gnus-article-headers
 588   :group 'gnus-article-highlight)
 589
 590 (defface gnus-header-name-face
 591   '((((class color)
 592       (background dark))
 593      (:foreground "SeaGreen"))
 594     (((class color)
 595       (background light))
 596      (:foreground "maroon"))
 597     (t
 598      (:bold t)))
 599   "Face used for displaying header names."
 600   :group 'gnus-article-headers
 601   :group 'gnus-article-highlight)
 602
 603 (defface gnus-header-content-face
 604   '((((class color)
 605       (background dark))
 606      (:foreground "forest green" :italic t))
 607     (((class color)
 608       (background light))
 609      (:foreground "indianred4" :italic t))
 610     (t
 611      (:italic t)))  "Face used for displaying header content."
 612   :group 'gnus-article-headers
 613   :group 'gnus-article-highlight)
 614
 615 (defcustom gnus-header-face-alist
 616   '(("From" nil gnus-header-from-face)
 617     ("Subject" nil gnus-header-subject-face)
 618     ("Newsgroups:.*," nil gnus-header-newsgroups-face)
 619     ("" gnus-header-name-face gnus-header-content-face))
 620   "*Controls highlighting of article header.
 621
 622 An alist of the form (HEADER NAME CONTENT).
 623
 624 HEADER is a regular expression which should match the name of an
 625 header header and NAME and CONTENT are either face names or nil.
 626
 627 The name of each header field will be displayed using the face
 628 specified by the first element in the list where HEADER match the
 629 header name and NAME is non-nil.  Similarly, the content will be
 630 displayed by the first non-nil matching CONTENT face."
 631   :group 'gnus-article-headers
 632   :group 'gnus-article-highlight
 633   :type '(repeat (list (regexp :tag "Header")
 634                        (choice :tag "Name"
 635                                (item :tag "skip" nil)
 636                                (face :value default))
 637                        (choice :tag "Content"
 638                                (item :tag "skip" nil)
 639                                (face :value default)))))
 640
 641 (defcustom gnus-article-decode-hook
 642   '(article-decode-charset article-decode-encoded-words
 643                            article-decode-group-name)
 644   "*Hook run to decode charsets in articles."
 645   :group 'gnus-article-headers
 646   :type 'hook)
 647
 648 (defcustom gnus-display-mime-function 'gnus-display-mime
 649   "Function to display MIME articles."
 650   :group 'gnus-article-mime
 651   :type 'function)
 652
 653 (defvar gnus-decode-header-function 'mail-decode-encoded-word-region
 654   "Function used to decode headers.")
 655
 656 (defvar gnus-article-dumbquotes-map
 657   '(("\200" "EUR")
 658     ("\202" ",")
 659     ("\203" "f")
 660     ("\204" ",,")
 661     ("\205" "...")
 662     ("\213" "<")
 663     ("\214" "OE")
 664     ("\221" "`")
 665     ("\222" "'")
 666     ("\223" "``")
 667     ("\224" "\"")
 668     ("\225" "*")
 669     ("\226" "-")
 670     ("\227" "--")
 671     ("\231" "(TM)")
 672     ("\233" ">")
 673     ("\234" "oe")
 674     ("\264" "'"))
 675   "Table for MS-to-Latin1 translation.")
 676
 677 (defcustom gnus-ignored-mime-types nil
 678   "List of MIME types that should be ignored by Gnus."
 679   :version "21.1"
 680   :group 'gnus-article-mime
 681   :type '(repeat regexp))
 682
 683 (defcustom gnus-unbuttonized-mime-types '(".*/.*")
 684   "List of MIME types that should not be given buttons when rendered inline.
 685 See also `gnus-buttonized-mime-types' which may override this variable."
 686   :version "21.1"
 687   :group 'gnus-article-mime
 688   :type '(repeat regexp))
 689
 690 (defcustom gnus-buttonized-mime-types nil
 691   "List of MIME types that should be given buttons when rendered inline.
 692 If set, this variable overrides `gnus-unbuttonized-mime-types'.
 693 To see e.g. security buttons you could set this to
 694 `(\"multipart/signed\")'."
 695   :version "21.1"
 696   :group 'gnus-article-mime
 697   :type '(repeat regexp))
 698
 699 (defcustom gnus-body-boundary-delimiter "_"
 700   "String used to delimit header and body.
 701 This variable is used by `gnus-article-treat-body-boundary' which can
 702 be controlled by `gnus-treat-body-boundary'."
 703   :group 'gnus-article-various
 704   :type '(choice (item :tag "None" :value nil)
 705                  string))
 706
 707 (defcustom gnus-picon-databases '("/usr/lib/picon" "/usr/local/faces")
 708   "*Defines the location of the faces database.
 709 For information on obtaining this database of pretty pictures, please
 710 see http://www.cs.indiana.edu/picons/ftp/index.html"
 711   :type 'directory
 712   :group 'gnus-picon)
 713
 714 (defun gnus-picons-installed-p ()
 715   "Say whether picons are installed on your machine."
 716   (let ((installed nil))
 717     (dolist (database gnus-picon-databases)
 718       (when (file-exists-p database)
 719         (setq installed t)))
 720     installed))
 721
 722 (defcustom gnus-article-mime-part-function nil
 723   "Function called with a MIME handle as the argument.
 724 This is meant for people who want to do something automatic based
 725 on parts -- for instance, adding Vcard info to a database."
 726   :group 'gnus-article-mime
 727   :type 'function)
 728
 729 (defcustom gnus-mime-multipart-functions nil
 730   "An alist of MIME types to functions to display them."
 731   :version "21.1"
 732   :group 'gnus-article-mime
 733   :type 'alist)
 734
 735 (defcustom gnus-article-date-lapsed-new-header nil
 736   "Whether the X-Sent and Date headers can coexist.
 737 When using `gnus-treat-date-lapsed', the \"X-Sent:\" header will
 738 either replace the old \"Date:\" header (if this variable is nil), or
 739 be added below it (otherwise)."
 740   :version "21.1"
 741   :group 'gnus-article-headers
 742   :type 'boolean)
 743
 744 (defcustom gnus-article-mime-match-handle-function 'undisplayed-alternative
 745   "Function called with a MIME handle as the argument.
 746 This is meant for people who want to view first matched part.
 747 For `undisplayed-alternative' (default), the first undisplayed
 748 part or alternative part is used.  For `undisplayed', the first
 749 undisplayed part is used.  For a function, the first part which
 750 the function return `t' is used.  For `nil', the first part is
 751 used."
 752   :version "21.1"
 753   :group 'gnus-article-mime
 754   :type '(choice
 755           (item :tag "first" :value nil)
 756           (item :tag "undisplayed" :value undisplayed)
 757           (item :tag "undisplayed or alternative"
 758                 :value undisplayed-alternative)
 759           (function)))
 760
 761 (defcustom gnus-mime-action-alist
 762   '(("save to file" . gnus-mime-save-part)
 763     ("save and strip" . gnus-mime-save-part-and-strip)
 764     ("display as text" . gnus-mime-inline-part)
 765     ("view the part" . gnus-mime-view-part)
 766     ("pipe to command" . gnus-mime-pipe-part)
 767     ("toggle display" . gnus-article-press-button)
 768     ("toggle display" . gnus-article-view-part-as-charset)
 769     ("view as type" . gnus-mime-view-part-as-type)
 770     ("view internally" . gnus-mime-view-part-internally)
 771     ("view externally" . gnus-mime-view-part-externally))
 772   "An alist of actions that run on the MIME attachment."
 773   :group 'gnus-article-mime
 774   :type '(repeat (cons (string :tag "name")
 775                        (function))))
 776
 777 ;;;
 778 ;;; The treatment variables
 779 ;;;
 780
 781 (defvar gnus-part-display-hook nil
 782   "Hook called on parts that are to receive treatment.")
 783
 784 (defvar gnus-article-treat-custom
 785   '(choice (const :tag "Off" nil)
 786            (const :tag "On" t)
 787            (const :tag "Header" head)
 788            (const :tag "Last" last)
 789            (integer :tag "Less")
 790            (repeat :tag "Groups" regexp)
 791            (sexp :tag "Predicate")))
 792
 793 (defvar gnus-article-treat-head-custom
 794   '(choice (const :tag "Off" nil)
 795            (const :tag "Header" head)))
 796
 797 (defvar gnus-article-treat-types '("text/plain")
 798   "Parts to treat.")
 799
 800 (defvar gnus-inhibit-treatment nil
 801   "Whether to inhibit treatment.")
 802
 803 (defcustom gnus-treat-highlight-signature '(or last (typep "text/x-vcard"))
 804   "Highlight the signature.
 805 Valid values are nil, t, `head', `last', an integer or a predicate.
 806 See Info node `(gnus)Customizing Articles'."
 807   :group 'gnus-article-treat
 808   :type gnus-article-treat-custom)
 809 (put 'gnus-treat-highlight-signature 'highlight t)
 810
 811 (defcustom gnus-treat-buttonize 100000
 812   "Add buttons.
 813 Valid values are nil, t, `head', `last', an integer or a predicate.
 814 See Info node `(gnus)Customizing Articles'."
 815   :group 'gnus-article-treat
 816   :type gnus-article-treat-custom)
 817 (put 'gnus-treat-buttonize 'highlight t)
 818
 819 (defcustom gnus-treat-buttonize-head 'head
 820   "Add buttons to the head.
 821 Valid values are nil, t, `head', `last', an integer or a predicate.
 822 See Info node `(gnus)Customizing Articles' for details."
 823   :group 'gnus-article-treat
 824   :type gnus-article-treat-head-custom)
 825 (put 'gnus-treat-buttonize-head 'highlight t)
 826
 827 (defcustom gnus-treat-emphasize
 828   (and (or window-system
 829            (featurep 'xemacs)
 830            (>= (string-to-number emacs-version) 21))
 831        50000)
 832   "Emphasize text.
 833 Valid values are nil, t, `head', `last', an integer or a predicate.
 834 See Info node `(gnus)Customizing Articles' for details."
 835   :group 'gnus-article-treat
 836   :type gnus-article-treat-custom)
 837 (put 'gnus-treat-emphasize 'highlight t)
 838
 839 (defcustom gnus-treat-strip-cr nil
 840   "Remove carriage returns.
 841 Valid values are nil, t, `head', `last', an integer or a predicate.
 842 See Info node `(gnus)Customizing Articles' for details."
 843   :group 'gnus-article-treat
 844   :type gnus-article-treat-custom)
 845
 846 (defcustom gnus-treat-unsplit-urls nil
 847   "Remove newlines from within URLs.
 848 Valid values are nil, t, `head', `last', an integer or a predicate.
 849 See Info node `(gnus)Customizing Articles' for details."
 850   :group 'gnus-article-treat
 851   :type gnus-article-treat-custom)
 852
 853 (defcustom gnus-treat-leading-whitespace nil
 854   "Remove leading whitespace in headers.
 855 Valid values are nil, t, `head', `last', an integer or a predicate.
 856 See Info node `(gnus)Customizing Articles' for details."
 857   :group 'gnus-article-treat
 858   :type gnus-article-treat-custom)
 859
 860 (defcustom gnus-treat-hide-headers 'head
 861   "Hide headers.
 862 Valid values are nil, t, `head', `last', an integer or a predicate.
 863 See Info node `(gnus)Customizing Articles' for details."
 864   :group 'gnus-article-treat
 865   :type gnus-article-treat-head-custom)
 866
 867 (defcustom gnus-treat-hide-boring-headers nil
 868   "Hide boring headers.
 869 Valid values are nil, t, `head', `last', an integer or a predicate.
 870 See Info node `(gnus)Customizing Articles' for details."
 871   :group 'gnus-article-treat
 872   :type gnus-article-treat-head-custom)
 873
 874 (defcustom gnus-treat-hide-signature nil
 875   "Hide the signature.
 876 Valid values are nil, t, `head', `last', an integer or a predicate.
 877 See Info node `(gnus)Customizing Articles' for details."
 878   :group 'gnus-article-treat
 879   :type gnus-article-treat-custom)
 880
 881 (defcustom gnus-treat-fill-article nil
 882   "Fill the article.
 883 Valid values are nil, t, `head', `last', an integer or a predicate.
 884 See Info node `(gnus)Customizing Articles' for details."
 885   :group 'gnus-article-treat
 886   :type gnus-article-treat-custom)
 887
 888 (defcustom gnus-treat-hide-citation nil
 889   "Hide cited text.
 890 Valid values are nil, t, `head', `last', an integer or a predicate.
 891 See Info node `(gnus)Customizing Articles' for details."
 892   :group 'gnus-article-treat
 893   :type gnus-article-treat-custom)
 894
 895 (defcustom gnus-treat-hide-citation-maybe nil
 896   "Hide cited text.
 897 Valid values are nil, t, `head', `last', an integer or a predicate.
 898 See Info node `(gnus)Customizing Articles' for details."
 899   :group 'gnus-article-treat
 900   :type gnus-article-treat-custom)
 901
 902 (defcustom gnus-treat-strip-list-identifiers 'head
 903   "Strip list identifiers from `gnus-list-identifiers`.
 904 Valid values are nil, t, `head', `last', an integer or a predicate.
 905 See Info node `(gnus)Customizing Articles' for details."
 906   :version "21.1"
 907   :group 'gnus-article-treat
 908   :type gnus-article-treat-custom)
 909
 910 (defcustom gnus-treat-strip-pgp t
 911   "Strip PGP signatures.
 912 Valid values are nil, t, `head', `last', an integer or a predicate.
 913 See Info node `(gnus)Customizing Articles' for details."
 914   :group 'gnus-article-treat
 915   :type gnus-article-treat-custom)
 916
 917 (defcustom gnus-treat-strip-pem nil
 918   "Strip PEM signatures.
 919 Valid values are nil, t, `head', `last', an integer or a predicate.
 920 See Info node `(gnus)Customizing Articles' for details."
 921   :group 'gnus-article-treat
 922   :type gnus-article-treat-custom)
 923
 924 (defcustom gnus-treat-strip-banner t
 925   "Strip banners from articles.
 926 The banner to be stripped is specified in the `banner' group parameter.
 927 Valid values are nil, t, `head', `last', an integer or a predicate.
 928 See Info node `(gnus)Customizing Articles' for details."
 929   :group 'gnus-article-treat
 930   :type gnus-article-treat-custom)
 931
 932 (defcustom gnus-treat-highlight-headers 'head
 933   "Highlight the headers.
 934 Valid values are nil, t, `head', `last', an integer or a predicate.
 935 See Info node `(gnus)Customizing Articles' for details."
 936   :group 'gnus-article-treat
 937   :type gnus-article-treat-head-custom)
 938 (put 'gnus-treat-highlight-headers 'highlight t)
 939
 940 (defcustom gnus-treat-highlight-citation t
 941   "Highlight cited text.
 942 Valid values are nil, t, `head', `last', an integer or a predicate.
 943 See Info node `(gnus)Customizing Articles' for details."
 944   :group 'gnus-article-treat
 945   :type gnus-article-treat-custom)
 946 (put 'gnus-treat-highlight-citation 'highlight t)
 947
 948 (defcustom gnus-treat-date-ut nil
 949   "Display the Date in UT (GMT).
 950 Valid values are nil, t, `head', `last', an integer or a predicate.
 951 See Info node `(gnus)Customizing Articles' for details."
 952   :group 'gnus-article-treat
 953   :type gnus-article-treat-head-custom)
 954
 955 (defcustom gnus-treat-date-local nil
 956   "Display the Date in the local timezone.
 957 Valid values are nil, t, `head', `last', an integer or a predicate.
 958 See Info node `(gnus)Customizing Articles' for details."
 959   :group 'gnus-article-treat
 960   :type gnus-article-treat-head-custom)
 961
 962 (defcustom gnus-treat-date-english nil
 963   "Display the Date in a format that can be read aloud in English.
 964 Valid values are nil, t, `head', `last', an integer or a predicate.
 965 See Info node `(gnus)Customizing Articles' for details."
 966   :group 'gnus-article-treat
 967   :type gnus-article-treat-head-custom)
 968
 969 (defcustom gnus-treat-date-lapsed nil
 970   "Display the Date header in a way that says how much time has elapsed.
 971 Valid values are nil, t, `head', `last', an integer or a predicate.
 972 See Info node `(gnus)Customizing Articles' for details."
 973   :group 'gnus-article-treat
 974   :type gnus-article-treat-head-custom)
 975
 976 (defcustom gnus-treat-date-original nil
 977   "Display the date in the original timezone.
 978 Valid values are nil, t, `head', `last', an integer or a predicate.
 979 See Info node `(gnus)Customizing Articles' for details."
 980   :group 'gnus-article-treat
 981   :type gnus-article-treat-head-custom)
 982
 983 (defcustom gnus-treat-date-iso8601 nil
 984   "Display the date in the ISO8601 format.
 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.1"
 988   :group 'gnus-article-treat
 989   :type gnus-article-treat-head-custom)
 990
 991 (defcustom gnus-treat-date-user-defined nil
 992   "Display the date in a user-defined format.
 993 The format is defined by the `gnus-article-time-format' variable.
 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   :type gnus-article-treat-head-custom)
 998
 999 (defcustom gnus-treat-strip-headers-in-body t
1000   "Strip the X-No-Archive header line from the beginning of the body.
1001 Valid values are nil, t, `head', `last', an integer or a predicate.
1002 See Info node `(gnus)Customizing Articles' for details."
1003   :version "21.1"
1004   :group 'gnus-article-treat
1005   :type gnus-article-treat-custom)
1006
1007 (defcustom gnus-treat-strip-trailing-blank-lines nil
1008   "Strip trailing blank lines.
1009 Valid values are nil, t, `head', `last', an integer or a predicate.
1010 See Info node `(gnus)Customizing Articles' for details."
1011   :group 'gnus-article-treat
1012   :type gnus-article-treat-custom)
1013
1014 (defcustom gnus-treat-strip-leading-blank-lines nil
1015   "Strip leading blank lines.
1016 Valid values are nil, t, `head', `last', an integer or a predicate.
1017 See Info node `(gnus)Customizing Articles' for details."
1018   :group 'gnus-article-treat
1019   :type gnus-article-treat-custom)
1020
1021 (defcustom gnus-treat-strip-multiple-blank-lines nil
1022   "Strip multiple blank lines.
1023 Valid values are nil, t, `head', `last', an integer or a predicate.
1024 See Info node `(gnus)Customizing Articles' for details."
1025   :group 'gnus-article-treat
1026   :type gnus-article-treat-custom)
1027
1028 (defcustom gnus-treat-unfold-headers 'head
1029   "Unfold folded header lines.
1030 Valid values are nil, t, `head', `last', an integer or a predicate.
1031 See Info node `(gnus)Customizing Articles' for details."
1032   :group 'gnus-article-treat
1033   :type gnus-article-treat-custom)
1034
1035 (defcustom gnus-treat-fold-headers nil
1036   "Fold headers.
1037 Valid values are nil, t, `head', `last', an integer or a predicate.
1038 See Info node `(gnus)Customizing Articles' for details."
1039   :group 'gnus-article-treat
1040   :type gnus-article-treat-custom)
1041
1042 (defcustom gnus-treat-fold-newsgroups 'head
1043   "Fold the Newsgroups and Followup-To headers.
1044 Valid values are nil, t, `head', `last', an integer or a predicate.
1045 See Info node `(gnus)Customizing Articles' for details."
1046   :group 'gnus-article-treat
1047   :type gnus-article-treat-custom)
1048
1049 (defcustom gnus-treat-overstrike t
1050   "Treat overstrike highlighting.
1051 Valid values are nil, t, `head', `last', an integer or a predicate.
1052 See Info node `(gnus)Customizing Articles' for details."
1053   :group 'gnus-article-treat
1054   :type gnus-article-treat-custom)
1055 (put 'gnus-treat-overstrike 'highlight t)
1056
1057 (defcustom gnus-treat-display-xface
1058   (and (not noninteractive)
1059        (or (and (fboundp 'image-type-available-p)
1060                 (image-type-available-p 'xbm)
1061                 (string-match "^0x" (shell-command-to-string "uncompface")))
1062            (and (featurep 'xemacs)
1063                 (featurep 'xface)))
1064        'head)
1065   "Display X-Face headers.
1066 Valid values are nil, t, `head', `last', an integer or a predicate.
1067 See Info node `(gnus)Customizing Articles' and Info node
1068 `(gnus)X-Face' for details."
1069   :group 'gnus-article-treat
1070   :version "21.1"
1071   :type gnus-article-treat-head-custom)
1072 (put 'gnus-treat-display-xface 'highlight t)
1073
1074 (defcustom gnus-treat-display-grey-xface
1075   (and (not noninteractive)
1076        (string-match "^0x" (shell-command-to-string "uncompface"))
1077        t)
1078   "Display grey X-Face headers.
1079 Valid values are nil, t."
1080   :group 'gnus-article-treat
1081   :version "21.3"
1082   :type 'boolean)
1083 (put 'gnus-treat-display-grey-xface 'highlight t)
1084
1085 (defcustom gnus-treat-display-smileys
1086   (if (or (and (featurep 'xemacs)
1087                (featurep 'xpm))
1088           (and (fboundp 'image-type-available-p)
1089                (image-type-available-p 'pbm)))
1090       t nil)
1091   "Display smileys.
1092 Valid values are nil, t, `head', `last', an integer or a predicate.
1093 See Info node `(gnus)Customizing Articles' and Info node
1094 `(gnus)Smileys' for details."
1095   :group 'gnus-article-treat
1096   :version "21.1"
1097   :type gnus-article-treat-custom)
1098 (put 'gnus-treat-display-smileys 'highlight t)
1099
1100 (defcustom gnus-treat-from-picon
1101   (if (and (gnus-image-type-available-p 'xpm)
1102            (gnus-picons-installed-p))
1103       'head nil)
1104   "Display picons in the From header.
1105 Valid values are nil, t, `head', `last', an integer or a predicate.
1106 See Info node `(gnus)Customizing Articles' and Info node
1107 `(gnus)Picons' for details."
1108   :group 'gnus-article-treat
1109   :type gnus-article-treat-head-custom)
1110 (put 'gnus-treat-from-picon 'highlight t)
1111
1112 (defcustom gnus-treat-mail-picon
1113   (if (and (gnus-image-type-available-p 'xpm)
1114            (gnus-picons-installed-p))
1115       'head nil)
1116   "Display picons in To and Cc headers.
1117 Valid values are nil, t, `head', `last', an integer or a predicate.
1118 See Info node `(gnus)Customizing Articles' and Info node
1119 `(gnus)Picons' for details."
1120   :group 'gnus-article-treat
1121   :type gnus-article-treat-head-custom)
1122 (put 'gnus-treat-mail-picon 'highlight t)
1123
1124 (defcustom gnus-treat-newsgroups-picon
1125   (if (and (gnus-image-type-available-p 'xpm)
1126            (gnus-picons-installed-p))
1127       'head nil)
1128   "Display picons in the Newsgroups and Followup-To headers.
1129 Valid values are nil, t, `head', `last', an integer or a predicate.
1130 See Info node `(gnus)Customizing Articles' and Info node
1131 `(gnus)Picons' for details."
1132   :group 'gnus-article-treat
1133   :type gnus-article-treat-head-custom)
1134 (put 'gnus-treat-newsgroups-picon 'highlight t)
1135
1136 (defcustom gnus-treat-body-boundary
1137   (if (or gnus-treat-newsgroups-picon
1138           gnus-treat-mail-picon
1139           gnus-treat-from-picon)
1140       'head nil)
1141   "Draw a boundary at the end of the headers.
1142 Valid values are nil, t, `head', `last', an integer or a predicate.
1143 See Info node `(gnus)Customizing Articles' for details."
1144   :version "21.1"
1145   :group 'gnus-article-treat
1146   :type gnus-article-treat-custom)
1147
1148 (defcustom gnus-treat-capitalize-sentences nil
1149   "Capitalize sentence-starting words.
1150 Valid values are nil, t, `head', `last', an integer or a predicate.
1151 See Info node `(gnus)Customizing Articles' for details."
1152   :version "21.1"
1153   :group 'gnus-article-treat
1154   :type gnus-article-treat-custom)
1155
1156 (defcustom gnus-treat-fill-long-lines nil
1157   "Fill long lines.
1158 Valid values are nil, t, `head', `last', an integer or a predicate.
1159 See Info node `(gnus)Customizing Articles' for details."
1160   :group 'gnus-article-treat
1161   :type gnus-article-treat-custom)
1162
1163 (defcustom gnus-treat-play-sounds nil
1164   "Play sounds.
1165 Valid values are nil, t, `head', `last', an integer or a predicate.
1166 See Info node `(gnus)Customizing Articles' for details."
1167   :version "21.1"
1168   :group 'gnus-article-treat
1169   :type gnus-article-treat-custom)
1170
1171 (defcustom gnus-treat-translate nil
1172   "Translate articles from one language to another.
1173 Valid values are nil, t, `head', `last', an integer or a predicate.
1174 See Info node `(gnus)Customizing Articles' for details."
1175   :version "21.1"
1176   :group 'gnus-article-treat
1177   :type gnus-article-treat-custom)
1178
1179 (defcustom gnus-treat-x-pgp-sig nil
1180   "Verify X-PGP-Sig.
1181 To automatically treat X-PGP-Sig, set it to head.
1182 Valid values are nil, t, `head', `last', an integer or a predicate.
1183 See Info node `(gnus)Customizing Articles' for details."
1184   :group 'gnus-article-treat
1185   :group 'mime-security
1186   :type gnus-article-treat-custom)
1187
1188 (defvar gnus-article-encrypt-protocol-alist
1189   '(("PGP" . mml2015-self-encrypt)))
1190
1191 ;; Set to nil if more than one protocol added to
1192 ;; gnus-article-encrypt-protocol-alist.
1193 (defcustom gnus-article-encrypt-protocol "PGP"
1194   "The protocol used for encrypt articles.
1195 It is a string, such as \"PGP\". If nil, ask user."
1196   :type 'string
1197   :group 'mime-security)
1198
1199 (defvar gnus-article-wash-function nil
1200   "Function used for converting HTML into text.")
1201
1202 ;;; Internal variables
1203
1204 (defvar gnus-english-month-names
1205   '("January" "February" "March" "April" "May" "June" "July" "August"
1206     "September" "October" "November" "December"))
1207
1208 (defvar article-goto-body-goes-to-point-min-p nil)
1209 (defvar gnus-article-wash-types nil)
1210 (defvar gnus-article-emphasis-alist nil)
1211 (defvar gnus-article-image-alist nil)
1212
1213 (defvar gnus-article-mime-handle-alist-1 nil)
1214 (defvar gnus-treatment-function-alist
1215   '((gnus-treat-x-pgp-sig gnus-article-verify-x-pgp-sig)
1216     (gnus-treat-strip-banner gnus-article-strip-banner)
1217     (gnus-treat-strip-headers-in-body gnus-article-strip-headers-in-body)
1218     (gnus-treat-highlight-signature gnus-article-highlight-signature)
1219     (gnus-treat-buttonize gnus-article-add-buttons)
1220     (gnus-treat-fill-article gnus-article-fill-cited-article)
1221     (gnus-treat-fill-long-lines gnus-article-fill-long-lines)
1222     (gnus-treat-strip-cr gnus-article-remove-cr)
1223     (gnus-treat-unsplit-urls gnus-article-unsplit-urls)
1224     (gnus-treat-date-ut gnus-article-date-ut)
1225     (gnus-treat-date-local gnus-article-date-local)
1226     (gnus-treat-date-english gnus-article-date-english)
1227     (gnus-treat-date-lapsed gnus-article-date-lapsed)
1228     (gnus-treat-date-original gnus-article-date-original)
1229     (gnus-treat-date-user-defined gnus-article-date-user)
1230     (gnus-treat-date-iso8601 gnus-article-date-iso8601)
1231     (gnus-treat-display-xface gnus-article-display-x-face)
1232     (gnus-treat-hide-headers gnus-article-maybe-hide-headers)
1233     (gnus-treat-hide-boring-headers gnus-article-hide-boring-headers)
1234     (gnus-treat-hide-signature gnus-article-hide-signature)
1235     (gnus-treat-strip-list-identifiers gnus-article-hide-list-identifiers)
1236     (gnus-treat-leading-whitespace gnus-article-remove-leading-whitespace)
1237     (gnus-treat-strip-pgp gnus-article-hide-pgp)
1238     (gnus-treat-strip-pem gnus-article-hide-pem)
1239     (gnus-treat-from-picon gnus-treat-from-picon)
1240     (gnus-treat-mail-picon gnus-treat-mail-picon)
1241     (gnus-treat-newsgroups-picon gnus-treat-newsgroups-picon)
1242     (gnus-treat-highlight-headers gnus-article-highlight-headers)
1243     (gnus-treat-highlight-signature gnus-article-highlight-signature)
1244     (gnus-treat-strip-trailing-blank-lines
1245      gnus-article-remove-trailing-blank-lines)
1246     (gnus-treat-strip-leading-blank-lines
1247      gnus-article-strip-leading-blank-lines)
1248     (gnus-treat-strip-multiple-blank-lines
1249      gnus-article-strip-multiple-blank-lines)
1250     (gnus-treat-overstrike gnus-article-treat-overstrike)
1251     (gnus-treat-unfold-headers gnus-article-treat-unfold-headers)
1252     (gnus-treat-fold-headers gnus-article-treat-fold-headers)
1253     (gnus-treat-fold-newsgroups gnus-article-treat-fold-newsgroups)
1254     (gnus-treat-buttonize-head gnus-article-add-buttons-to-head)
1255     (gnus-treat-display-smileys gnus-treat-smiley)
1256     (gnus-treat-capitalize-sentences gnus-article-capitalize-sentences)
1257     (gnus-treat-emphasize gnus-article-emphasize)
1258     (gnus-treat-hide-citation gnus-article-hide-citation)
1259     (gnus-treat-hide-citation-maybe gnus-article-hide-citation-maybe)
1260     (gnus-treat-highlight-citation gnus-article-highlight-citation)
1261     (gnus-treat-body-boundary gnus-article-treat-body-boundary)
1262     (gnus-treat-play-sounds gnus-earcon-display)))
1263
1264 (defvar gnus-article-mime-handle-alist nil)
1265 (defvar article-lapsed-timer nil)
1266 (defvar gnus-article-current-summary nil)
1267
1268 (defvar gnus-article-mode-syntax-table
1269   (let ((table (copy-syntax-table text-mode-syntax-table)))
1270     ;; This causes the citation match run O(2^n).
1271     ;; (modify-syntax-entry ?- "w" table)
1272     (modify-syntax-entry ?> ")" table)
1273     (modify-syntax-entry ?< "(" table)
1274     table)
1275   "Syntax table used in article mode buffers.
1276 Initialized from `text-mode-syntax-table.")
1277
1278 (defvar gnus-save-article-buffer nil)
1279
1280 (defvar gnus-article-mode-line-format-alist
1281   (nconc '((?w (gnus-article-wash-status) ?s)
1282            (?m (gnus-article-mime-part-status) ?s))
1283          gnus-summary-mode-line-format-alist))
1284
1285 (defvar gnus-number-of-articles-to-be-saved nil)
1286
1287 (defvar gnus-inhibit-hiding nil)
1288
1289 ;;; Macros for dealing with the article buffer.
1290
1291 (defmacro gnus-with-article-headers (&rest forms)
1292   `(save-excursion
1293      (set-buffer gnus-article-buffer)
1294      (save-restriction
1295        (let ((buffer-read-only nil)
1296              (inhibit-point-motion-hooks t)
1297              (case-fold-search t))
1298          (article-narrow-to-head)
1299          ,@forms))))
1300
1301 (put 'gnus-with-article-headers 'lisp-indent-function 0)
1302 (put 'gnus-with-article-headers 'edebug-form-spec '(body))
1303
1304 (defmacro gnus-with-article-buffer (&rest forms)
1305   `(save-excursion
1306      (set-buffer gnus-article-buffer)
1307      (let ((buffer-read-only nil))
1308        ,@forms)))
1309
1310 (put 'gnus-with-article-buffer 'lisp-indent-function 0)
1311 (put 'gnus-with-article-buffer 'edebug-form-spec '(body))
1312
1313 (defun gnus-article-goto-header (header)
1314   "Go to HEADER, which is a regular expression."
1315   (re-search-forward (concat "^\\(" header "\\):") nil t))
1316
1317 (defsubst gnus-article-hide-text (b e props)
1318   "Set text PROPS on the B to E region, extending `intangible' 1 past B."
1319   (gnus-add-text-properties-when 'article-type nil b e props)
1320   (when (memq 'intangible props)
1321     (put-text-property
1322      (max (1- b) (point-min))
1323      b 'intangible (cddr (memq 'intangible props)))))
1324
1325 (defsubst gnus-article-unhide-text (b e)
1326   "Remove hidden text properties from region between B and E."
1327   (remove-text-properties b e gnus-hidden-properties)
1328   (when (memq 'intangible gnus-hidden-properties)
1329     (put-text-property (max (1- b) (point-min))
1330                        b 'intangible nil)))
1331
1332 (defun gnus-article-hide-text-type (b e type)
1333   "Hide text of TYPE between B and E."
1334   (gnus-add-wash-type type)
1335   (gnus-article-hide-text
1336    b e (cons 'article-type (cons type gnus-hidden-properties))))
1337
1338 (defun gnus-article-unhide-text-type (b e type)
1339   "Unhide text of TYPE between B and E."
1340   (gnus-delete-wash-type type)
1341   (remove-text-properties
1342    b e (cons 'article-type (cons type gnus-hidden-properties)))
1343   (when (memq 'intangible gnus-hidden-properties)
1344     (put-text-property (max (1- b) (point-min))
1345                        b 'intangible nil)))
1346
1347 (defun gnus-article-hide-text-of-type (type)
1348   "Hide text of TYPE in the current buffer."
1349   (save-excursion
1350     (let ((b (point-min))
1351           (e (point-max)))
1352       (while (setq b (text-property-any b e 'article-type type))
1353         (add-text-properties b (incf b) gnus-hidden-properties)))))
1354
1355 (defun gnus-article-delete-text-of-type (type)
1356   "Delete text of TYPE in the current buffer."
1357   (save-excursion
1358     (let ((b (point-min)))
1359       (while (setq b (text-property-any b (point-max) 'article-type type))
1360         (delete-region
1361          b (or (text-property-not-all b (point-max) 'article-type type)
1362                (point-max)))))))
1363
1364 (defun gnus-article-delete-invisible-text ()
1365   "Delete all invisible text in the current buffer."
1366   (save-excursion
1367     (let ((b (point-min)))
1368       (while (setq b (text-property-any b (point-max) 'invisible t))
1369         (delete-region
1370          b (or (text-property-not-all b (point-max) 'invisible t)
1371                (point-max)))))))
1372
1373 (defun gnus-article-text-type-exists-p (type)
1374   "Say whether any text of type TYPE exists in the buffer."
1375   (text-property-any (point-min) (point-max) 'article-type type))
1376
1377 (defsubst gnus-article-header-rank ()
1378   "Give the rank of the string HEADER as given by `gnus-sorted-header-list'."
1379   (let ((list gnus-sorted-header-list)
1380         (i 0))
1381     (while list
1382       (when (looking-at (car list))
1383         (setq list nil))
1384       (setq list (cdr list))
1385       (incf i))
1386     i))
1387
1388 (defun article-hide-headers (&optional arg delete)
1389   "Hide unwanted headers and possibly sort them as well."
1390   (interactive)
1391   ;; This function might be inhibited.
1392   (unless gnus-inhibit-hiding
1393     (save-excursion
1394       (save-restriction
1395         (let ((buffer-read-only nil)
1396               (case-fold-search t)
1397               (max (1+ (length gnus-sorted-header-list)))
1398               (ignored (when (not gnus-visible-headers)
1399                          (cond ((stringp gnus-ignored-headers)
1400                                 gnus-ignored-headers)
1401                                ((listp gnus-ignored-headers)
1402                                 (mapconcat 'identity gnus-ignored-headers
1403                                            "\\|")))))
1404               (visible
1405                (cond ((stringp gnus-visible-headers)
1406                       gnus-visible-headers)
1407                      ((and gnus-visible-headers
1408                            (listp gnus-visible-headers))
1409                       (mapconcat 'identity gnus-visible-headers "\\|"))))
1410               (inhibit-point-motion-hooks t)
1411               beg)
1412           ;; First we narrow to just the headers.
1413           (article-narrow-to-head)
1414           ;; Hide any "From " lines at the beginning of (mail) articles.
1415           (while (looking-at "From ")
1416             (forward-line 1))
1417           (unless (bobp)
1418             (delete-region (point-min) (point)))
1419           ;; Then treat the rest of the header lines.
1420           ;; Then we use the two regular expressions
1421           ;; `gnus-ignored-headers' and `gnus-visible-headers' to
1422           ;; select which header lines is to remain visible in the
1423           ;; article buffer.
1424           (while (re-search-forward "^[^ \t:]*:" nil t)
1425             (beginning-of-line)
1426             ;; Mark the rank of the header.
1427             (put-text-property
1428              (point) (1+ (point)) 'message-rank
1429              (if (or (and visible (looking-at visible))
1430                      (and ignored
1431                           (not (looking-at ignored))))
1432                  (gnus-article-header-rank)
1433                (+ 2 max)))
1434             (forward-line 1))
1435           (message-sort-headers-1)
1436           (when (setq beg (text-property-any
1437                            (point-min) (point-max) 'message-rank (+ 2 max)))
1438             ;; We delete the unwanted headers.
1439             (gnus-add-wash-type 'headers)
1440             (add-text-properties (point-min) (+ 5 (point-min))
1441                                  '(article-type headers dummy-invisible t))
1442             (delete-region beg (point-max))))))))
1443
1444 (defun article-hide-boring-headers (&optional arg)
1445   "Toggle hiding of headers that aren't very interesting.
1446 If given a negative prefix, always show; if given a positive prefix,
1447 always hide."
1448   (interactive (gnus-article-hidden-arg))
1449   (when (and (not (gnus-article-check-hidden-text 'boring-headers arg))
1450              (not gnus-show-all-headers))
1451     (save-excursion
1452       (save-restriction
1453         (let ((buffer-read-only nil)
1454               (list gnus-boring-article-headers)
1455               (inhibit-point-motion-hooks t)
1456               elem)
1457           (article-narrow-to-head)
1458           (while list
1459             (setq elem (pop list))
1460             (goto-char (point-min))
1461             (cond
1462              ;; Hide empty headers.
1463              ((eq elem 'empty)
1464               (while (re-search-forward "^[^: \t]+:[ \t]*\n[^ \t]" nil t)
1465                 (forward-line -1)
1466                 (gnus-article-hide-text-type
1467                  (progn (beginning-of-line) (point))
1468                  (progn
1469                    (end-of-line)
1470                    (if (re-search-forward "^[^ \t]" nil t)
1471                        (match-beginning 0)
1472                      (point-max)))
1473                  'boring-headers)))
1474              ;; Hide boring Newsgroups header.
1475              ((eq elem 'newsgroups)
1476               (when (gnus-string-equal
1477                      (gnus-fetch-field "newsgroups")
1478                      (gnus-group-real-name
1479                       (if (boundp 'gnus-newsgroup-name)
1480                           gnus-newsgroup-name
1481                         "")))
1482                 (gnus-article-hide-header "newsgroups")))
1483              ((eq elem 'to-address)
1484               (let ((to (message-fetch-field "to"))
1485                     (to-address
1486                      (gnus-parameter-to-address
1487                       (if (boundp 'gnus-newsgroup-name)
1488                           gnus-newsgroup-name ""))))
1489                 (when (and to to-address
1490                            (ignore-errors
1491                              (gnus-string-equal
1492                               ;; only one address in To
1493                               (nth 1 (mail-extract-address-components to))
1494                               to-address)))
1495                   (gnus-article-hide-header "to"))))
1496              ((eq elem 'followup-to)
1497               (when (gnus-string-equal
1498                      (message-fetch-field "followup-to")
1499                      (message-fetch-field "newsgroups"))
1500                 (gnus-article-hide-header "followup-to")))
1501              ((eq elem 'reply-to)
1502               (let ((from (message-fetch-field "from"))
1503                     (reply-to (message-fetch-field "reply-to")))
1504                 (when (and
1505                        from reply-to
1506                        (ignore-errors
1507                          (gnus-string-equal
1508                           (nth 1 (mail-extract-address-components from))
1509                           (nth 1 (mail-extract-address-components reply-to)))))
1510                   (gnus-article-hide-header "reply-to"))))
1511              ((eq elem 'date)
1512               (let ((date (message-fetch-field "date")))
1513                 (when (and date
1514                            (< (days-between (current-time-string) date)
1515                               4))
1516                   (gnus-article-hide-header "date"))))
1517              ((eq elem 'long-to)
1518               (let ((to (message-fetch-field "to"))
1519                     (cc (message-fetch-field "cc")))
1520                 (when (> (length to) 1024)
1521                   (gnus-article-hide-header "to"))
1522                 (when (> (length cc) 1024)
1523                   (gnus-article-hide-header "cc"))))
1524              ((eq elem 'many-to)
1525               (let ((to-count 0)
1526                     (cc-count 0))
1527                 (goto-char (point-min))
1528                 (while (re-search-forward "^to:" nil t)
1529                   (setq to-count (1+ to-count)))
1530                 (when (> to-count 1)
1531                   (while (> to-count 0)
1532                     (goto-char (point-min))
1533                     (save-restriction
1534                       (re-search-forward "^to:" nil nil to-count)
1535                       (forward-line -1)
1536                       (narrow-to-region (point) (point-max))
1537                       (gnus-article-hide-header "to"))
1538                     (setq to-count (1- to-count))))
1539                 (goto-char (point-min))
1540                 (while (re-search-forward "^cc:" nil t)
1541                   (setq cc-count (1+ cc-count)))
1542                 (when (> cc-count 1)
1543                   (while (> cc-count 0)
1544                     (goto-char (point-min))
1545                     (save-restriction
1546                       (re-search-forward "^cc:" nil nil cc-count)
1547                       (forward-line -1)
1548                       (narrow-to-region (point) (point-max))
1549                       (gnus-article-hide-header "cc"))
1550                     (setq cc-count (1- cc-count)))))))))))))
1551
1552 (defun gnus-article-hide-header (header)
1553   (save-excursion
1554     (goto-char (point-min))
1555     (when (re-search-forward (concat "^" header ":") nil t)
1556       (gnus-article-hide-text-type
1557        (progn (beginning-of-line) (point))
1558        (progn
1559          (end-of-line)
1560          (if (re-search-forward "^[^ \t]" nil t)
1561              (match-beginning 0)
1562            (point-max)))
1563        'boring-headers))))
1564
1565 (defvar gnus-article-normalized-header-length 40
1566   "Length of normalized headers.")
1567
1568 (defun article-normalize-headers ()
1569   "Make all header lines 40 characters long."
1570   (interactive)
1571   (let ((buffer-read-only nil)
1572         column)
1573     (save-excursion
1574       (save-restriction
1575         (article-narrow-to-head)
1576         (while (not (eobp))
1577           (cond
1578            ((< (setq column (- (gnus-point-at-eol) (point)))
1579                gnus-article-normalized-header-length)
1580             (end-of-line)
1581             (insert (make-string
1582                      (- gnus-article-normalized-header-length column)
1583                      ? )))
1584            ((> column gnus-article-normalized-header-length)
1585             (gnus-put-text-property
1586              (progn
1587                (forward-char gnus-article-normalized-header-length)
1588                (point))
1589              (gnus-point-at-eol)
1590              'invisible t))
1591            (t
1592             ;; Do nothing.
1593             ))
1594           (forward-line 1))))))
1595
1596 (defun article-treat-dumbquotes ()
1597   "Translate M****s*** sm*rtq**t*s into proper text.
1598 Note that this function guesses whether a character is a sm*rtq**t* or
1599 not, so it should only be used interactively.
1600
1601 Sm*rtq**t*s are M****s***'s unilateral extension to the character map
1602 in an attempt to provide more quoting characters.  If you see
1603 something like \\222 or \\264 where you're expecting some kind of
1604 apostrophe or quotation mark, then try this wash."
1605   (interactive)
1606   (article-translate-strings gnus-article-dumbquotes-map))
1607
1608 (defun article-translate-characters (from to)
1609   "Translate all characters in the body of the article according to FROM and TO.
1610 FROM is a string of characters to translate from; to is a string of
1611 characters to translate to."
1612   (save-excursion
1613     (when (article-goto-body)
1614       (let ((buffer-read-only nil)
1615             (x (make-string 225 ?x))
1616             (i -1))
1617         (while (< (incf i) (length x))
1618           (aset x i i))
1619         (setq i 0)
1620         (while (< i (length from))
1621           (aset x (aref from i) (aref to i))
1622           (incf i))
1623         (translate-region (point) (point-max) x)))))
1624
1625 (defun article-translate-strings (map)
1626   "Translate all string in the body of the article according to MAP.
1627 MAP is an alist where the elements are on the form (\"from\" \"to\")."
1628   (save-excursion
1629     (when (article-goto-body)
1630       (let ((buffer-read-only nil)
1631             elem)
1632         (while (setq elem (pop map))
1633           (save-excursion
1634             (while (search-forward (car elem) nil t)
1635               (replace-match (cadr elem)))))))))
1636
1637 (defun article-treat-overstrike ()
1638   "Translate overstrikes into bold text."
1639   (interactive)
1640   (save-excursion
1641     (when (article-goto-body)
1642       (let ((buffer-read-only nil))
1643         (while (search-forward "\b" nil t)
1644           (let ((next (char-after))
1645                 (previous (char-after (- (point) 2))))
1646             ;; We do the boldification/underlining by hiding the
1647             ;; overstrikes and putting the proper text property
1648             ;; on the letters.
1649             (cond
1650              ((eq next previous)
1651               (gnus-article-hide-text-type (- (point) 2) (point) 'overstrike)
1652               (put-text-property (point) (1+ (point)) 'face 'bold))
1653              ((eq next ?_)
1654               (gnus-article-hide-text-type
1655                (1- (point)) (1+ (point)) 'overstrike)
1656               (put-text-property
1657                (- (point) 2) (1- (point)) 'face 'underline))
1658              ((eq previous ?_)
1659               (gnus-article-hide-text-type (- (point) 2) (point) 'overstrike)
1660               (put-text-property
1661                (point) (1+ (point)) 'face 'underline)))))))))
1662
1663 (defun gnus-article-treat-unfold-headers ()
1664   "Unfold folded message headers.
1665 Only the headers that fit into the current window width will be
1666 unfolded."
1667   (interactive)
1668   (gnus-with-article-headers
1669     (let (length)
1670       (while (not (eobp))
1671         (save-restriction
1672           (mail-header-narrow-to-field)
1673           (let ((header (buffer-substring (point-min) (point-max))))
1674             (with-temp-buffer
1675               (insert header)
1676               (goto-char (point-min))
1677               (while (re-search-forward "\n[\t ]" nil t)
1678                 (replace-match " " t t)))
1679             (setq length (- (point-max) (point-min) 1)))
1680           (when (< length (window-width))
1681             (while (re-search-forward "\n[\t ]" nil t)
1682               (replace-match " " t t)))
1683           (goto-char (point-max)))))))
1684
1685 (defun gnus-article-treat-fold-headers ()
1686   "Fold message headers."
1687   (interactive)
1688   (gnus-with-article-headers
1689     (while (not (eobp))
1690       (save-restriction
1691         (mail-header-narrow-to-field)
1692         (mail-header-fold-field)
1693         (goto-char (point-max))))))
1694
1695 (defun gnus-treat-smiley ()
1696   "Toggle display of textual emoticons (\"smileys\") as small graphical icons."
1697   (interactive)
1698   (gnus-with-article-buffer
1699     (if (memq 'smiley gnus-article-wash-types)
1700         (gnus-delete-images 'smiley)
1701       (article-goto-body)
1702       (let ((images (smiley-region (point) (point-max))))
1703         (when images
1704           (gnus-add-wash-type 'smiley)
1705           (dolist (image images)
1706             (gnus-add-image 'smiley image)))))))
1707
1708 (defun gnus-article-remove-images ()
1709   "Remove all images from the article buffer."
1710   (interactive)
1711   (gnus-with-article-buffer
1712     (dolist (elem gnus-article-image-alist)
1713       (gnus-delete-images (car elem)))))
1714
1715 (defun gnus-article-treat-fold-newsgroups ()
1716   "Unfold folded message headers.
1717 Only the headers that fit into the current window width will be
1718 unfolded."
1719   (interactive)
1720   (gnus-with-article-headers
1721     (while (gnus-article-goto-header "newsgroups\\|followup-to")
1722       (save-restriction
1723         (mail-header-narrow-to-field)
1724         (while (re-search-forward ", *" nil t)
1725           (replace-match ", " t t))
1726         (mail-header-fold-field)
1727         (goto-char (point-max))))))
1728
1729 (defun gnus-article-treat-body-boundary ()
1730   "Place a boundary line at the end of the headers."
1731   (interactive)
1732   (when (and gnus-body-boundary-delimiter
1733              (> (length gnus-body-boundary-delimiter) 0))
1734     (gnus-with-article-headers
1735       (goto-char (point-max))
1736       (let ((start (point)))
1737         (insert "X-Boundary: ")
1738         (gnus-add-text-properties start (point) '(invisible t intangible t))
1739         (insert (let (str)
1740                   (while (>= (1- (window-width)) (length str))
1741                     (setq str (concat str gnus-body-boundary-delimiter)))
1742                   (substring str 0 (1- (window-width))))
1743                 "\n")
1744         (gnus-add-text-properties start (point) '(gnus-decoration 'header))))))
1745
1746 (defun article-fill-long-lines ()
1747   "Fill lines that are wider than the window width."
1748   (interactive)
1749   (save-excursion
1750     (let ((buffer-read-only nil)
1751           (width (window-width (get-buffer-window (current-buffer)))))
1752       (save-restriction
1753         (article-goto-body)
1754         (let ((adaptive-fill-mode nil)) ;Why?  -sm
1755           (while (not (eobp))
1756             (end-of-line)
1757             (when (>= (current-column) (min fill-column width))
1758               (narrow-to-region (point) (gnus-point-at-bol))
1759               (fill-paragraph nil)
1760               (goto-char (point-max))
1761               (widen))
1762             (forward-line 1)))))))
1763
1764 (defun article-capitalize-sentences ()
1765   "Capitalize the first word in each sentence."
1766   (interactive)
1767   (save-excursion
1768     (let ((buffer-read-only nil)
1769           (paragraph-start "^[\n\^L]"))
1770       (article-goto-body)
1771       (while (not (eobp))
1772         (capitalize-word 1)
1773         (forward-sentence)))))
1774
1775 (defun article-remove-cr ()
1776   "Remove trailing CRs and then translate remaining CRs into LFs."
1777   (interactive)
1778   (save-excursion
1779     (let ((buffer-read-only nil))
1780       (goto-char (point-min))
1781       (while (re-search-forward "\r+$" nil t)
1782         (replace-match "" t t))
1783       (goto-char (point-min))
1784       (while (search-forward "\r" nil t)
1785         (replace-match "\n" t t)))))
1786
1787 (defun article-remove-trailing-blank-lines ()
1788   "Remove all trailing blank lines from the article."
1789   (interactive)
1790   (save-excursion
1791     (let ((buffer-read-only nil))
1792       (goto-char (point-max))
1793       (delete-region
1794        (point)
1795        (progn
1796          (while (and (not (bobp))
1797                      (looking-at "^[ \t]*$")
1798                      (not (gnus-annotation-in-region-p
1799                            (point) (gnus-point-at-eol))))
1800            (forward-line -1))
1801          (forward-line 1)
1802          (point))))))
1803
1804 (defun article-display-x-face (&optional force)
1805   "Look for an X-Face header and display it if present."
1806   (interactive (list 'force))
1807   (let ((wash-face-p buffer-read-only)) ;; When type `W f'
1808     (gnus-with-article-headers
1809       ;; Delete the old process, if any.
1810       (when (process-status "article-x-face")
1811         (delete-process "article-x-face"))
1812       (if (memq 'xface gnus-article-wash-types)
1813           ;; We have already displayed X-Faces, so we remove them
1814           ;; instead.
1815           (gnus-delete-images 'xface)
1816         ;; Display X-Faces.
1817         (let (x-faces from face grey)
1818           (save-excursion
1819             (when (and wash-face-p
1820                        (progn
1821                          (goto-char (point-min))
1822                          (not (re-search-forward
1823                                "^X-Face\\(-[0-9]+\\)?:[\t ]*" nil t)))
1824                        (gnus-buffer-live-p gnus-original-article-buffer))
1825               ;; If type `W f', use gnus-original-article-buffer,
1826               ;; otherwise use the current buffer because displaying
1827               ;; RFC822 parts calls this function too.
1828               (set-buffer gnus-original-article-buffer))
1829             (save-restriction
1830               (mail-narrow-to-head)
1831               (if gnus-treat-display-grey-xface
1832                   (progn
1833                     (while (gnus-article-goto-header "X-Face\\(-[0-9]+\\)?")
1834                       (if (match-beginning 2)
1835                           (progn
1836                             (setq grey t)
1837                             (push (cons (- (string-to-number (match-string 2)))
1838                                         (mail-header-field-value))
1839                                   x-faces))
1840                         (push (cons 0 (mail-header-field-value)) x-faces)))
1841                     (dolist (x-face (prog1
1842                                         (if grey
1843                                             (sort x-faces 'car-less-than-car)
1844                                           (nreverse x-faces))
1845                                       (setq x-faces nil)))
1846                       (push (cdr x-face) x-faces)))
1847                 (while (gnus-article-goto-header "X-Face")
1848                   (push (mail-header-field-value) x-faces)))
1849               (setq from (message-fetch-field "from"))))
1850           (if grey
1851               (let ((xpm (gnus-convert-gray-x-face-to-xpm x-faces))
1852                     image)
1853                 (when xpm
1854                   (setq image (gnus-create-image xpm 'xpm t))
1855                   (gnus-article-goto-header "from")
1856                   (when (bobp)
1857                     (insert "From: [no `from' set]\n")
1858                     (forward-char -17))
1859                   (gnus-add-wash-type 'xface)
1860                   (gnus-add-image 'xface image)
1861                   (gnus-put-image image)))
1862             ;; Sending multiple EOFs to xv doesn't work, so we only do a
1863             ;; single external face.
1864             (when (stringp gnus-article-x-face-command)
1865               (setq x-faces (list (car x-faces))))
1866             (while (and (setq face (pop x-faces))
1867                         gnus-article-x-face-command
1868                         (or force
1869                             ;; Check whether this face is censored.
1870                             (not gnus-article-x-face-too-ugly)
1871                             (and gnus-article-x-face-too-ugly from
1872                                  (not (string-match gnus-article-x-face-too-ugly
1873                                                     from)))))
1874               ;; We display the face.
1875               (if (symbolp gnus-article-x-face-command)
1876                   ;; The command is a lisp function, so we call it.
1877                   (if (gnus-functionp gnus-article-x-face-command)
1878                       (funcall gnus-article-x-face-command face)
1879                     (error "%s is not a function" gnus-article-x-face-command))
1880                 ;; The command is a string, so we interpret the command
1881                 ;; as a, well, command, and fork it off.
1882                 (let ((process-connection-type nil))
1883                   (process-kill-without-query
1884                    (start-process
1885                     "article-x-face" nil shell-file-name shell-command-switch
1886                     gnus-article-x-face-command))
1887                   (with-temp-buffer
1888                     (insert face)
1889                     (process-send-region "article-x-face"
1890                                          (point-min) (point-max)))
1891                   (process-send-eof "article-x-face"))))))))))
1892
1893 (defun article-decode-mime-words ()
1894   "Decode all MIME-encoded words in the article."
1895   (interactive)
1896   (save-excursion
1897     (set-buffer gnus-article-buffer)
1898     (let ((inhibit-point-motion-hooks t)
1899           buffer-read-only
1900           (mail-parse-charset gnus-newsgroup-charset)
1901           (mail-parse-ignored-charsets
1902            (save-excursion (set-buffer gnus-summary-buffer)
1903                            gnus-newsgroup-ignored-charsets)))
1904       (mail-decode-encoded-word-region (point-min) (point-max)))))
1905
1906 (defun article-decode-charset (&optional prompt)
1907   "Decode charset-encoded text in the article.
1908 If PROMPT (the prefix), prompt for a coding system to use."
1909   (interactive "P")
1910   (let ((inhibit-point-motion-hooks t) (case-fold-search t)
1911         buffer-read-only
1912         (mail-parse-charset gnus-newsgroup-charset)
1913         (mail-parse-ignored-charsets
1914          (save-excursion (condition-case nil
1915                              (set-buffer gnus-summary-buffer)
1916                            (error))
1917                          gnus-newsgroup-ignored-charsets))
1918         ct cte ctl charset format)
1919   (save-excursion
1920     (save-restriction
1921       (article-narrow-to-head)
1922       (setq ct (message-fetch-field "Content-Type" t)
1923             cte (message-fetch-field "Content-Transfer-Encoding" t)
1924             ctl (and ct (ignore-errors
1925                           (mail-header-parse-content-type ct)))
1926             charset (cond
1927                      (prompt
1928                       (mm-read-coding-system "Charset to decode: "))
1929                      (ctl
1930                       (mail-content-type-get ctl 'charset)))
1931             format (and ctl (mail-content-type-get ctl 'format)))
1932       (when cte
1933         (setq cte (mail-header-strip cte)))
1934       (if (and ctl (not (string-match "/" (car ctl))))
1935           (setq ctl nil))
1936       (goto-char (point-max)))
1937     (forward-line 1)
1938     (save-restriction
1939       (narrow-to-region (point) (point-max))
1940       (when (and (eq mail-parse-charset 'gnus-decoded)
1941                  (eq (mm-body-7-or-8) '8bit))
1942         ;; The text code could have been decoded.
1943         (setq charset mail-parse-charset))
1944       (when (and (or (not ctl)
1945                      (equal (car ctl) "text/plain"))
1946                  (not format)) ;; article with format will decode later.
1947         (mm-decode-body
1948          charset (and cte (intern (downcase
1949                                    (gnus-strip-whitespace cte))))
1950          (car ctl)))))))
1951
1952 (defun article-decode-encoded-words ()
1953   "Remove encoded-word encoding from headers."
1954   (let ((inhibit-point-motion-hooks t)
1955         (mail-parse-charset gnus-newsgroup-charset)
1956         (mail-parse-ignored-charsets
1957          (save-excursion (condition-case nil
1958                              (set-buffer gnus-summary-buffer)
1959                            (error))
1960                          gnus-newsgroup-ignored-charsets))
1961         buffer-read-only)
1962     (save-restriction
1963       (article-narrow-to-head)
1964       (funcall gnus-decode-header-function (point-min) (point-max)))))
1965
1966 (defun article-decode-group-name ()
1967   "Decode group names in `Newsgroups:'."
1968   (let ((inhibit-point-motion-hooks t)
1969         buffer-read-only
1970         (method (gnus-find-method-for-group gnus-newsgroup-name)))
1971     (when (and (or gnus-group-name-charset-method-alist
1972                    gnus-group-name-charset-group-alist)
1973                (gnus-buffer-live-p gnus-original-article-buffer))
1974       (when (nnmail-fetch-field "Newsgroups")
1975         (nnheader-replace-header "Newsgroups"
1976                                  (gnus-decode-newsgroups
1977                                   (with-current-buffer
1978                                       gnus-original-article-buffer
1979                                     (nnmail-fetch-field "Newsgroups"))
1980                                   gnus-newsgroup-name method)))
1981       (when (nnmail-fetch-field "Followup-To")
1982         (nnheader-replace-header "Followup-To"
1983                                  (gnus-decode-newsgroups
1984                                   (with-current-buffer
1985                                       gnus-original-article-buffer
1986                                     (nnmail-fetch-field "Followup-To"))
1987                                   gnus-newsgroup-name method))))))
1988
1989 (defun article-de-quoted-unreadable (&optional force read-charset)
1990   "Translate a quoted-printable-encoded article.
1991 If FORCE, decode the article whether it is marked as quoted-printable
1992 or not.
1993 If READ-CHARSET, ask for a coding system."
1994   (interactive (list 'force current-prefix-arg))
1995   (save-excursion
1996     (let ((buffer-read-only nil) type charset)
1997       (if (gnus-buffer-live-p gnus-original-article-buffer)
1998           (with-current-buffer gnus-original-article-buffer
1999             (setq type
2000                   (gnus-fetch-field "content-transfer-encoding"))
2001             (let* ((ct (gnus-fetch-field "content-type"))
2002                    (ctl (and ct
2003                              (ignore-errors
2004                                (mail-header-parse-content-type ct)))))
2005               (setq charset (and ctl
2006                                  (mail-content-type-get ctl 'charset)))
2007               (if (stringp charset)
2008                   (setq charset (intern (downcase charset)))))))
2009       (if read-charset
2010           (setq charset (mm-read-coding-system "Charset: " charset)))
2011       (unless charset
2012         (setq charset gnus-newsgroup-charset))
2013       (when (or force
2014                 (and type (let ((case-fold-search t))
2015                             (string-match "quoted-printable" type))))
2016         (article-goto-body)
2017         (quoted-printable-decode-region
2018          (point) (point-max) (mm-charset-to-coding-system charset))))))
2019
2020 (defun article-de-base64-unreadable (&optional force read-charset)
2021   "Translate a base64 article.
2022 If FORCE, decode the article whether it is marked as base64 not.
2023 If READ-CHARSET, ask for a coding system."
2024   (interactive (list 'force current-prefix-arg))
2025   (save-excursion
2026     (let ((buffer-read-only nil) type charset)
2027       (if (gnus-buffer-live-p gnus-original-article-buffer)
2028           (with-current-buffer gnus-original-article-buffer
2029             (setq type
2030                   (gnus-fetch-field "content-transfer-encoding"))
2031             (let* ((ct (gnus-fetch-field "content-type"))
2032                    (ctl (and ct
2033                              (ignore-errors
2034                                (mail-header-parse-content-type ct)))))
2035               (setq charset (and ctl
2036                                  (mail-content-type-get ctl 'charset)))
2037               (if (stringp charset)
2038                   (setq charset (intern (downcase charset)))))))
2039       (if read-charset
2040           (setq charset (mm-read-coding-system "Charset: " charset)))
2041       (unless charset
2042         (setq charset gnus-newsgroup-charset))
2043       (when (or force
2044                 (and type (let ((case-fold-search t))
2045                             (string-match "base64" type))))
2046         (article-goto-body)
2047         (save-restriction
2048           (narrow-to-region (point) (point-max))
2049           (base64-decode-region (point-min) (point-max))
2050           (mm-decode-coding-region
2051            (point-min) (point-max) (mm-charset-to-coding-system charset)))))))
2052
2053 (eval-when-compile
2054   (require 'rfc1843))
2055
2056 (defun article-decode-HZ ()
2057   "Translate a HZ-encoded article."
2058   (interactive)
2059   (require 'rfc1843)
2060   (save-excursion
2061     (let ((buffer-read-only nil))
2062       (rfc1843-decode-region (point-min) (point-max)))))
2063
2064 (defun article-unsplit-urls ()
2065   "Remove the newlines that some other mailers insert into URLs."
2066   (interactive)
2067   (save-excursion
2068     (let ((buffer-read-only nil))
2069       (goto-char (point-min))
2070       (while (re-search-forward
2071               "^\\(\\(https?\\|ftp\\)://\\S-+\\)\n\\(\\S-+\\)" nil t)
2072         (replace-match "\\1\\3" t)))))
2073
2074 (defun article-wash-html (&optional read-charset)
2075   "Format an html article.
2076 If READ-CHARSET, ask for a coding system."
2077   (interactive "P")
2078   (save-excursion
2079     (let ((buffer-read-only nil)
2080           charset)
2081       (if (gnus-buffer-live-p gnus-original-article-buffer)
2082           (with-current-buffer gnus-original-article-buffer
2083             (let* ((ct (gnus-fetch-field "content-type"))
2084                    (ctl (and ct
2085                              (ignore-errors
2086                                (mail-header-parse-content-type ct)))))
2087               (setq charset (and ctl
2088                                  (mail-content-type-get ctl 'charset)))
2089               (if (stringp charset)
2090                   (setq charset (intern (downcase charset)))))))
2091       (if read-charset
2092           (setq charset (mm-read-coding-system "Charset: " charset)))
2093       (unless charset
2094         (setq charset gnus-newsgroup-charset))
2095       (article-goto-body)
2096       (save-window-excursion
2097         (save-restriction
2098           (narrow-to-region (point) (point-max))
2099           (let* ((func (or gnus-article-wash-function mm-text-html-renderer))
2100                  (entry (assq func mm-text-html-washer-alist)))
2101             (if entry
2102                 (setq func (cdr entry)))
2103             (cond
2104              ((gnus-functionp func)
2105               (funcall func))
2106              (t
2107               (apply (car func) (cdr func))))))))))
2108
2109 (defun gnus-article-wash-html-with-w3 ()
2110   "Wash the current buffer with w3."
2111   (mm-setup-w3)
2112   (let ((w3-strict-width (window-width))
2113         (url-standalone-mode t)
2114         (url-gateway-unplugged t)
2115         (w3-honor-stylesheets nil)
2116         (w3-delay-image-loads t))
2117     (condition-case var
2118         (w3-region (point-min) (point-max))
2119       (error))))
2120
2121 (defun gnus-article-wash-html-with-w3m ()
2122   "Wash the current buffer with emacs-w3m."
2123   (mm-setup-w3m)
2124   (save-restriction
2125     (narrow-to-region (point) (point-max))
2126     (let ((w3m-safe-url-regexp (if mm-inline-text-html-with-images
2127                                    nil
2128                                  "\\`cid:"))
2129           (w3m-display-inline-images mm-inline-text-html-with-images)
2130           w3m-force-redisplay)
2131       (w3m-region (point-min) (point-max)))
2132     (when mm-inline-text-html-with-w3m-keymap
2133       (add-text-properties
2134        (point-min) (point-max)
2135        (append '(mm-inline-text-html-with-w3m t)
2136                (gnus-local-map-property mm-w3m-mode-map))))))
2137
2138 (defun article-hide-list-identifiers ()
2139   "Remove list identifies from the Subject header.
2140 The `gnus-list-identifiers' variable specifies what to do."
2141   (interactive)
2142   (let ((inhibit-point-motion-hooks t)
2143         (regexp (if (consp gnus-list-identifiers)
2144                     (mapconcat 'identity gnus-list-identifiers " *\\|")
2145                   gnus-list-identifiers))
2146         buffer-read-only)
2147     (when regexp
2148       (save-excursion
2149         (save-restriction
2150           (article-narrow-to-head)
2151           (goto-char (point-min))
2152           (while (re-search-forward
2153                   (concat "^Subject: +\\(R[Ee]: +\\)*\\(" regexp " *\\)")
2154                   nil t)
2155             (delete-region (match-beginning 2) (match-end 0))
2156             (beginning-of-line))
2157           (when (re-search-forward
2158                  "^Subject: +\\(\\(R[Ee]: +\\)+\\)R[Ee]: +" nil t)
2159             (delete-region (match-beginning 1) (match-end 1))))))))
2160
2161 (defun article-hide-pgp ()
2162   "Remove any PGP headers and signatures in the current article."
2163   (interactive)
2164   (save-excursion
2165     (save-restriction
2166       (let ((inhibit-point-motion-hooks t)
2167             buffer-read-only beg end)
2168         (article-goto-body)
2169         ;; Hide the "header".
2170         (when (re-search-forward "^-----BEGIN PGP SIGNED MESSAGE-----\n" nil t)
2171           (gnus-add-wash-type 'pgp)
2172           (delete-region (match-beginning 0) (match-end 0))
2173           ;; Remove armor headers (rfc2440 6.2)
2174           (delete-region (point) (or (re-search-forward "^[ \t]*\n" nil t)
2175                                      (point)))
2176           (setq beg (point))
2177           ;; Hide the actual signature.
2178           (and (search-forward "\n-----BEGIN PGP SIGNATURE-----\n" nil t)
2179                (setq end (1+ (match-beginning 0)))
2180                (delete-region
2181                 end
2182                 (if (search-forward "\n-----END PGP SIGNATURE-----\n" nil t)
2183                     (match-end 0)
2184                   ;; Perhaps we shouldn't hide to the end of the buffer
2185                   ;; if there is no end to the signature?
2186                   (point-max))))
2187           ;; Hide "- " PGP quotation markers.
2188           (when (and beg end)
2189             (narrow-to-region beg end)
2190             (goto-char (point-min))
2191             (while (re-search-forward "^- " nil t)
2192               (delete-region
2193                (match-beginning 0) (match-end 0)))
2194             (widen))
2195           (gnus-run-hooks 'gnus-article-hide-pgp-hook))))))
2196
2197 (defun article-hide-pem (&optional arg)
2198   "Toggle hiding of any PEM headers and signatures in the current article.
2199 If given a negative prefix, always show; if given a positive prefix,
2200 always hide."
2201   (interactive (gnus-article-hidden-arg))
2202   (unless (gnus-article-check-hidden-text 'pem arg)
2203     (save-excursion
2204       (let (buffer-read-only end)
2205         (goto-char (point-min))
2206         ;; Hide the horrendously ugly "header".
2207         (when (and (search-forward
2208                     "\n-----BEGIN PRIVACY-ENHANCED MESSAGE-----\n"
2209                     nil t)
2210                    (setq end (1+ (match-beginning 0))))
2211           (gnus-add-wash-type 'pem)
2212           (gnus-article-hide-text-type
2213            end
2214            (if (search-forward "\n\n" nil t)
2215                (match-end 0)
2216              (point-max))
2217            'pem)
2218           ;; Hide the trailer as well
2219           (when (search-forward "\n-----END PRIVACY-ENHANCED MESSAGE-----\n"
2220                                 nil t)
2221             (gnus-article-hide-text-type
2222              (match-beginning 0) (match-end 0) 'pem)))))))
2223
2224 (defun article-strip-banner ()
2225   "Strip the banner specified by the `banner' group parameter."
2226   (interactive)
2227   (save-excursion
2228     (save-restriction
2229       (let ((inhibit-point-motion-hooks t)
2230             (banner (gnus-parameter-banner gnus-newsgroup-name))
2231             (gnus-signature-limit nil)
2232             buffer-read-only beg end)
2233         (when banner
2234           (article-goto-body)
2235           (cond
2236            ((eq banner 'signature)
2237             (when (gnus-article-narrow-to-signature)
2238               (widen)
2239               (forward-line -1)
2240               (delete-region (point) (point-max))))
2241            ((symbolp banner)
2242             (if (setq banner (cdr (assq banner gnus-article-banner-alist)))
2243                 (while (re-search-forward banner nil t)
2244                   (delete-region (match-beginning 0) (match-end 0)))))
2245            ((stringp banner)
2246             (while (re-search-forward banner nil t)
2247               (delete-region (match-beginning 0) (match-end 0))))))))))
2248
2249 (defun article-babel ()
2250   "Translate article using an online translation service."
2251   (interactive)
2252   (require 'babel)
2253   (save-excursion
2254     (set-buffer gnus-article-buffer)
2255     (when (article-goto-body)
2256       (let* ((buffer-read-only nil)
2257              (start (point))
2258              (end (point-max))
2259              (orig (buffer-substring start end))
2260              (trans (babel-as-string orig)))
2261         (save-restriction
2262           (narrow-to-region start end)
2263           (delete-region start end)
2264           (insert trans))))))
2265
2266 (defun article-hide-signature (&optional arg)
2267   "Hide the signature in the current article.
2268 If given a negative prefix, always show; if given a positive prefix,
2269 always hide."
2270   (interactive (gnus-article-hidden-arg))
2271   (unless (gnus-article-check-hidden-text 'signature arg)
2272     (save-excursion
2273       (save-restriction
2274         (let ((buffer-read-only nil))
2275           (when (gnus-article-narrow-to-signature)
2276             (gnus-article-hide-text-type
2277              (point-min) (point-max) 'signature))))))
2278   (gnus-set-mode-line 'article))
2279
2280 (defun article-strip-headers-in-body ()
2281   "Strip offensive headers from bodies."
2282   (interactive)
2283   (save-excursion
2284     (article-goto-body)
2285     (let ((case-fold-search t))
2286       (when (looking-at "x-no-archive:")
2287         (gnus-delete-line)))))
2288
2289 (defun article-strip-leading-blank-lines ()
2290   "Remove all blank lines from the beginning of the article."
2291   (interactive)
2292   (save-excursion
2293     (let ((inhibit-point-motion-hooks t)
2294           buffer-read-only)
2295       (when (article-goto-body)
2296         (while (and (not (eobp))
2297                     (looking-at "[ \t]*$"))
2298           (gnus-delete-line))))))
2299
2300 (defun article-narrow-to-head ()
2301   "Narrow the buffer to the head of the message.
2302 Point is left at the beginning of the narrowed-to region."
2303   (narrow-to-region
2304    (goto-char (point-min))
2305    (if (search-forward "\n\n" nil 1)
2306        (1- (point))
2307      (point-max)))
2308   (goto-char (point-min)))
2309
2310 (defun article-goto-body ()
2311   "Place point at the start of the body."
2312   (goto-char (point-min))
2313   (cond
2314    ;; This variable is only bound when dealing with separate
2315    ;; MIME body parts.
2316    (article-goto-body-goes-to-point-min-p
2317     t)
2318    ((search-forward "\n\n" nil t)
2319     t)
2320    (t
2321     (goto-char (point-max))
2322     nil)))
2323
2324 (defun article-strip-multiple-blank-lines ()
2325   "Replace consecutive blank lines with one empty line."
2326   (interactive)
2327   (save-excursion
2328     (let ((inhibit-point-motion-hooks t)
2329           buffer-read-only)
2330       ;; First make all blank lines empty.
2331       (article-goto-body)
2332       (while (re-search-forward "^[ \t]+$" nil t)
2333         (unless (gnus-annotation-in-region-p
2334                  (match-beginning 0) (match-end 0))
2335           (replace-match "" nil t)))
2336       ;; Then replace multiple empty lines with a single empty line.
2337       (article-goto-body)
2338       (while (re-search-forward "\n\n\\(\n+\\)" nil t)
2339         (unless (gnus-annotation-in-region-p
2340                  (match-beginning 0) (match-end 0))
2341           (delete-region (match-beginning 1) (match-end 1)))))))
2342
2343 (defun article-strip-leading-space ()
2344   "Remove all white space from the beginning of the lines in the article."
2345   (interactive)
2346   (save-excursion
2347     (let ((inhibit-point-motion-hooks t)
2348           buffer-read-only)
2349       (article-goto-body)
2350       (while (re-search-forward "^[ \t]+" nil t)
2351         (replace-match "" t t)))))
2352
2353 (defun article-strip-trailing-space ()
2354   "Remove all white space from the end of the lines in the article."
2355   (interactive)
2356   (save-excursion
2357     (let ((inhibit-point-motion-hooks t)
2358           buffer-read-only)
2359       (article-goto-body)
2360       (while (re-search-forward "[ \t]+$" nil t)
2361         (replace-match "" t t)))))
2362
2363 (defun article-strip-blank-lines ()
2364   "Strip leading, trailing and multiple blank lines."
2365   (interactive)
2366   (article-strip-leading-blank-lines)
2367   (article-remove-trailing-blank-lines)
2368   (article-strip-multiple-blank-lines))
2369
2370 (defun article-strip-all-blank-lines ()
2371   "Strip all blank lines."
2372   (interactive)
2373   (save-excursion
2374     (let ((inhibit-point-motion-hooks t)
2375           buffer-read-only)
2376       (article-goto-body)
2377       (while (re-search-forward "^[ \t]*\n" nil t)
2378         (replace-match "" t t)))))
2379
2380 (defun gnus-article-narrow-to-signature ()
2381   "Narrow to the signature; return t if a signature is found, else nil."
2382   (let ((inhibit-point-motion-hooks t))
2383     (when (gnus-article-search-signature)
2384       (forward-line 1)
2385       ;; Check whether we have some limits to what we consider
2386       ;; to be a signature.
2387       (let ((limits (if (listp gnus-signature-limit) gnus-signature-limit
2388                       (list gnus-signature-limit)))
2389             limit limited)
2390         (while (setq limit (pop limits))
2391           (if (or (and (integerp limit)
2392                        (< (- (point-max) (point)) limit))
2393                   (and (floatp limit)
2394                        (< (count-lines (point) (point-max)) limit))
2395                   (and (gnus-functionp limit)
2396                        (funcall limit))
2397                   (and (stringp limit)
2398                        (not (re-search-forward limit nil t))))
2399               ()                        ; This limit did not succeed.
2400             (setq limited t
2401                   limits nil)))
2402         (unless limited
2403           (narrow-to-region (point) (point-max))
2404           t)))))
2405
2406 (defun gnus-article-search-signature ()
2407   "Search the current buffer for the signature separator.
2408 Put point at the beginning of the signature separator."
2409   (let ((cur (point)))
2410     (goto-char (point-max))
2411     (if (if (stringp gnus-signature-separator)
2412             (re-search-backward gnus-signature-separator nil t)
2413           (let ((seps gnus-signature-separator))
2414             (while (and seps
2415                         (not (re-search-backward (car seps) nil t)))
2416               (pop seps))
2417             seps))
2418         t
2419       (goto-char cur)
2420       nil)))
2421
2422 (defun gnus-article-hidden-arg ()
2423   "Return the current prefix arg as a number, or 0 if no prefix."
2424   (list (if current-prefix-arg
2425             (prefix-numeric-value current-prefix-arg)
2426           0)))
2427
2428 (defun gnus-article-check-hidden-text (type arg)
2429   "Return nil if hiding is necessary.
2430 Arg can be nil or a number.  nil and positive means hide, negative
2431 means show, 0 means toggle."
2432   (save-excursion
2433     (save-restriction
2434       (let ((hide (gnus-article-hidden-text-p type)))
2435         (cond
2436          ((or (null arg)
2437               (> arg 0))
2438           nil)
2439          ((< arg 0)
2440           (gnus-article-show-hidden-text type)
2441           t)
2442          (t
2443           (if (eq hide 'hidden)
2444               (progn
2445                 (gnus-article-show-hidden-text type)
2446                 t)
2447             nil)))))))
2448
2449 (defun gnus-article-hidden-text-p (type)
2450   "Say whether the current buffer contains hidden text of type TYPE."
2451   (let ((pos (text-property-any (point-min) (point-max) 'article-type type)))
2452     (while (and pos
2453                 (not (get-text-property pos 'invisible))
2454                 (not (get-text-property pos 'dummy-invisible)))
2455       (setq pos
2456             (text-property-any (1+ pos) (point-max) 'article-type type)))
2457     (if pos
2458         'hidden
2459       nil)))
2460
2461 (defun gnus-article-show-hidden-text (type &optional dummy)
2462   "Show all hidden text of type TYPE.
2463 Originally it is hide instead of DUMMY."
2464   (let ((buffer-read-only nil)
2465         (inhibit-point-motion-hooks t))
2466     (gnus-remove-text-properties-when
2467      'article-type type
2468      (point-min) (point-max)
2469      (cons 'article-type (cons type
2470                                gnus-hidden-properties)))
2471     (gnus-delete-wash-type type)))
2472
2473 (defconst article-time-units
2474   `((year . ,(* 365.25 24 60 60))
2475     (week . ,(* 7 24 60 60))
2476     (day . ,(* 24 60 60))
2477     (hour . ,(* 60 60))
2478     (minute . 60)
2479     (second . 1))
2480   "Mapping from time units to seconds.")
2481
2482 (defun article-date-ut (&optional type highlight header)
2483   "Convert DATE date to universal time in the current article.
2484 If TYPE is `local', convert to local time; if it is `lapsed', output
2485 how much time has lapsed since DATE.  For `lapsed', the value of
2486 `gnus-article-date-lapsed-new-header' says whether the \"X-Sent:\" header
2487 should replace the \"Date:\" one, or should be added below it."
2488   (interactive (list 'ut t))
2489   (let* ((header (or header
2490                      (message-fetch-field "date")
2491                      ""))
2492          (tdate-regexp "^Date:[ \t]\\|^X-Sent:[ \t]")
2493          (date-regexp
2494           (cond
2495            ((not gnus-article-date-lapsed-new-header)
2496             tdate-regexp)
2497            ((eq type 'lapsed)
2498             "^X-Sent:[ \t]")
2499            (t
2500             "^Date:[ \t]")))
2501          (date (if (vectorp header) (mail-header-date header)
2502                  header))
2503          (inhibit-point-motion-hooks t)
2504          pos
2505          bface eface)
2506     (save-excursion
2507       (save-restriction
2508         (article-narrow-to-head)
2509         (when (re-search-forward tdate-regexp nil t)
2510           (setq bface (get-text-property (gnus-point-at-bol) 'face)
2511                 date (or (get-text-property (gnus-point-at-bol)
2512                                             'original-date)
2513                          date)
2514                 eface (get-text-property (1- (gnus-point-at-eol)) 'face))
2515           (forward-line 1))
2516         (when (and date (not (string= date "")))
2517           (goto-char (point-min))
2518           (let ((buffer-read-only nil))
2519             ;; Delete any old Date headers.
2520             (while (re-search-forward date-regexp nil t)
2521               (if pos
2522                   (delete-region (progn (beginning-of-line) (point))
2523                                  (progn (forward-line 1) (point)))
2524                 (delete-region (progn (beginning-of-line) (point))
2525                                (progn (end-of-line) (point)))
2526                 (setq pos (point))))
2527             (when (and (not pos) (re-search-forward tdate-regexp nil t))
2528               (forward-line 1))
2529             (if pos (goto-char pos))
2530             (insert (article-make-date-line date (or type 'ut)))
2531             (when (not pos)
2532               (insert "\n")
2533               (forward-line -1))
2534             ;; Do highlighting.
2535             (beginning-of-line)
2536             (when (looking-at "\\([^:]+\\): *\\(.*\\)$")
2537               (put-text-property (match-beginning 1) (1+ (match-end 1))
2538                                  'original-date date)
2539               (put-text-property (match-beginning 1) (1+ (match-end 1))
2540                                  'face bface)
2541               (put-text-property (match-beginning 2) (match-end 2)
2542                                  'face eface))))))))
2543
2544 (defun article-make-date-line (date type)
2545   "Return a DATE line of TYPE."
2546   (unless (memq type '(local ut original user iso8601 lapsed english))
2547     (error "Unknown conversion type: %s" type))
2548   (condition-case ()
2549       (let ((time (date-to-time date)))
2550         (cond
2551          ;; Convert to the local timezone.
2552          ((eq type 'local)
2553           (let ((tz (car (current-time-zone time))))
2554             (format "Date: %s %s%02d%02d" (current-time-string time)
2555                     (if (> tz 0) "+" "-") (/ (abs tz) 3600)
2556                     (/ (% (abs tz) 3600) 60))))
2557          ;; Convert to Universal Time.
2558          ((eq type 'ut)
2559           (concat "Date: "
2560                   (current-time-string
2561                    (let* ((e (parse-time-string date))
2562                           (tm (apply 'encode-time e))
2563                           (ms (car tm))
2564                           (ls (- (cadr tm) (car (current-time-zone time)))))
2565                      (cond ((< ls 0) (list (1- ms) (+ ls 65536)))
2566                            ((> ls 65535) (list (1+ ms) (- ls 65536)))
2567                            (t (list ms ls)))))
2568                   " UT"))
2569          ;; Get the original date from the article.
2570          ((eq type 'original)
2571           (concat "Date: " (if (string-match "\n+$" date)
2572                                (substring date 0 (match-beginning 0))
2573                              date)))
2574          ;; Let the user define the format.
2575          ((eq type 'user)
2576           (if (gnus-functionp gnus-article-time-format)
2577               (funcall gnus-article-time-format time)
2578             (concat
2579              "Date: "
2580              (format-time-string gnus-article-time-format time))))
2581          ;; ISO 8601.
2582          ((eq type 'iso8601)
2583           (let ((tz (car (current-time-zone time))))
2584             (concat
2585              "Date: "
2586              (format-time-string "%Y%m%dT%H%M%S" time)
2587              (format "%s%02d%02d"
2588                      (if (> tz 0) "+" "-") (/ (abs tz) 3600)
2589                      (/ (% (abs tz) 3600) 60)))))
2590          ;; Do an X-Sent lapsed format.
2591          ((eq type 'lapsed)
2592           ;; If the date is seriously mangled, the timezone functions are
2593           ;; liable to bug out, so we ignore all errors.
2594           (let* ((now (current-time))
2595                  (real-time (subtract-time now time))
2596                  (real-sec (and real-time
2597                                 (+ (* (float (car real-time)) 65536)
2598                                    (cadr real-time))))
2599                  (sec (and real-time (abs real-sec)))
2600                  num prev)
2601             (cond
2602              ((null real-time)
2603               "X-Sent: Unknown")
2604              ((zerop sec)
2605               "X-Sent: Now")
2606              (t
2607               (concat
2608                "X-Sent: "
2609                ;; This is a bit convoluted, but basically we go
2610                ;; through the time units for years, weeks, etc,
2611                ;; and divide things to see whether that results
2612                ;; in positive answers.
2613                (mapconcat
2614                 (lambda (unit)
2615                   (if (zerop (setq num (ffloor (/ sec (cdr unit)))))
2616                       ;; The (remaining) seconds are too few to
2617                       ;; be divided into this time unit.
2618                       ""
2619                     ;; It's big enough, so we output it.
2620                     (setq sec (- sec (* num (cdr unit))))
2621                     (prog1
2622                         (concat (if prev ", " "") (int-to-string
2623                                                    (floor num))
2624                                 " " (symbol-name (car unit))
2625                                 (if (> num 1) "s" ""))
2626                       (setq prev t))))
2627                 article-time-units "")
2628                ;; If dates are odd, then it might appear like the
2629                ;; article was sent in the future.
2630                (if (> real-sec 0)
2631                    " ago"
2632                  " in the future"))))))
2633          ;; Display the date in proper English
2634          ((eq type 'english)
2635           (let ((dtime (decode-time time)))
2636             (concat
2637              "Date: the "
2638              (number-to-string (nth 3 dtime))
2639              (let ((digit (% (nth 3 dtime) 10)))
2640                (cond
2641                 ((memq (nth 3 dtime) '(11 12 13)) "th")
2642                 ((= digit 1) "st")
2643                 ((= digit 2) "nd")
2644                 ((= digit 3) "rd")
2645                 (t "th")))
2646              " of "
2647              (nth (1- (nth 4 dtime)) gnus-english-month-names)
2648              " "
2649              (number-to-string (nth 5 dtime))
2650              " at "
2651              (format "%02d" (nth 2 dtime))
2652              ":"
2653              (format "%02d" (nth 1 dtime)))))))
2654         (error
2655          (format "Date: %s (from Oort)" date))))
2656
2657 (defun article-date-local (&optional highlight)
2658   "Convert the current article date to the local timezone."
2659   (interactive (list t))
2660   (article-date-ut 'local highlight))
2661
2662 (defun article-date-english (&optional highlight)
2663   "Convert the current article date to something that is proper English."
2664   (interactive (list t))
2665   (article-date-ut 'english highlight))
2666
2667 (defun article-date-original (&optional highlight)
2668   "Convert the current article date to what it was originally.
2669 This is only useful if you have used some other date conversion
2670 function and want to see what the date was before converting."
2671   (interactive (list t))
2672   (article-date-ut 'original highlight))
2673
2674 (defun article-date-lapsed (&optional highlight)
2675   "Convert the current article date to time lapsed since it was sent."
2676   (interactive (list t))
2677   (article-date-ut 'lapsed highlight))
2678
2679 (defun article-update-date-lapsed ()
2680   "Function to be run from a timer to update the lapsed time line."
2681   (let (deactivate-mark)
2682     (save-excursion
2683       (ignore-errors
2684         (walk-windows
2685          (lambda (w)
2686            (set-buffer (window-buffer w))
2687            (when (eq major-mode 'gnus-article-mode)
2688              (goto-char (point-min))
2689              (when (re-search-forward "^X-Sent:" nil t)
2690                (article-date-lapsed t))))
2691          nil 'visible)))))
2692
2693 (defun gnus-start-date-timer (&optional n)
2694   "Start a timer to update the X-Sent header in the article buffers.
2695 The numerical prefix says how frequently (in seconds) the function
2696 is to run."
2697   (interactive "p")
2698   (unless n
2699     (setq n 1))
2700   (gnus-stop-date-timer)
2701   (setq article-lapsed-timer
2702         (nnheader-run-at-time 1 n 'article-update-date-lapsed)))
2703
2704 (defun gnus-stop-date-timer ()
2705   "Stop the X-Sent timer."
2706   (interactive)
2707   (when article-lapsed-timer
2708     (nnheader-cancel-timer article-lapsed-timer)
2709     (setq article-lapsed-timer nil)))
2710
2711 (defun article-date-user (&optional highlight)
2712   "Convert the current article date to the user-defined format.
2713 This format is defined by the `gnus-article-time-format' variable."
2714   (interactive (list t))
2715   (article-date-ut 'user highlight))
2716
2717 (defun article-date-iso8601 (&optional highlight)
2718   "Convert the current article date to ISO8601."
2719   (interactive (list t))
2720   (article-date-ut 'iso8601 highlight))
2721
2722 ;; (defun article-show-all ()
2723 ;;   "Show all hidden text in the article buffer."
2724 ;;   (interactive)
2725 ;;   (save-excursion
2726 ;;     (let ((buffer-read-only nil))
2727 ;;       (gnus-article-unhide-text (point-min) (point-max)))))
2728
2729 (defun article-remove-leading-whitespace ()
2730   "Remove excessive whitespace from all headers."
2731   (interactive)
2732   (save-excursion
2733     (save-restriction
2734       (let ((buffer-read-only nil))
2735         (article-narrow-to-head)
2736         (goto-char (point-min))
2737         (while (re-search-forward "^[^ :]+: \\([ \t]+\\)" nil t)
2738           (delete-region (match-beginning 1) (match-end 1)))))))
2739
2740 (defun article-emphasize (&optional arg)
2741   "Emphasize text according to `gnus-emphasis-alist'."
2742   (interactive (gnus-article-hidden-arg))
2743   (unless (gnus-article-check-hidden-text 'emphasis arg)
2744     (save-excursion
2745       (let ((alist (or
2746                     (condition-case nil
2747                         (with-current-buffer gnus-summary-buffer
2748                           gnus-article-emphasis-alist)
2749                       (error))
2750                     gnus-emphasis-alist))
2751             (buffer-read-only nil)
2752             (props (append '(article-type emphasis)
2753                            gnus-hidden-properties))
2754             regexp elem beg invisible visible face)
2755         (article-goto-body)
2756         (setq beg (point))
2757         (while (setq elem (pop alist))
2758           (goto-char beg)
2759           (setq regexp (car elem)
2760                 invisible (nth 1 elem)
2761                 visible (nth 2 elem)
2762                 face (nth 3 elem))
2763           (while (re-search-forward regexp nil t)
2764             (when (and (match-beginning visible) (match-beginning invisible))
2765               (gnus-article-hide-text
2766                (match-beginning invisible) (match-end invisible) props)
2767               (gnus-article-unhide-text-type
2768                (match-beginning visible) (match-end visible) 'emphasis)
2769               (gnus-put-overlay-excluding-newlines
2770                (match-beginning visible) (match-end visible) 'face face)
2771               (gnus-add-wash-type 'emphasis)
2772               (goto-char (match-end invisible)))))))))
2773
2774 (defun gnus-article-setup-highlight-words (&optional highlight-words)
2775   "Setup newsgroup emphasis alist."
2776   (unless gnus-article-emphasis-alist
2777     (let ((name (and gnus-newsgroup-name
2778                      (gnus-group-real-name gnus-newsgroup-name))))
2779       (make-local-variable 'gnus-article-emphasis-alist)
2780       (setq gnus-article-emphasis-alist
2781             (nconc
2782              (let ((alist gnus-group-highlight-words-alist) elem highlight)
2783                (while (setq elem (pop alist))
2784                  (when (and name (string-match (car elem) name))
2785                    (setq alist nil
2786                          highlight (copy-sequence (cdr elem)))))
2787                highlight)
2788              (copy-sequence highlight-words)
2789              (if gnus-newsgroup-name
2790                  (copy-sequence (gnus-group-find-parameter
2791                                  gnus-newsgroup-name 'highlight-words t)))
2792              gnus-emphasis-alist)))))
2793
2794 (eval-when-compile
2795   (defvar gnus-summary-article-menu)
2796   (defvar gnus-summary-post-menu))
2797
2798 ;;; Saving functions.
2799
2800 (defun gnus-article-save (save-buffer file &optional num)
2801   "Save the currently selected article."
2802   (unless gnus-save-all-headers
2803     ;; Remove headers according to `gnus-saved-headers'.
2804     (let ((gnus-visible-headers
2805            (or gnus-saved-headers gnus-visible-headers))
2806           (gnus-article-buffer save-buffer))
2807       (save-excursion
2808         (set-buffer save-buffer)
2809         (article-hide-headers 1 t))))
2810   (save-window-excursion
2811     (if (not gnus-default-article-saver)
2812         (error "No default saver is defined")
2813       ;; !!! Magic!  The saving functions all save
2814       ;; `gnus-save-article-buffer' (or so they think), but we
2815       ;; bind that variable to our save-buffer.
2816       (set-buffer gnus-article-buffer)
2817       (let* ((gnus-save-article-buffer save-buffer)
2818              (filename
2819               (cond
2820                ((not gnus-prompt-before-saving) 'default)
2821                ((eq gnus-prompt-before-saving 'always) nil)
2822                (t file)))
2823              (gnus-number-of-articles-to-be-saved
2824               (when (eq gnus-prompt-before-saving t)
2825                 num)))                  ; Magic
2826         (set-buffer gnus-article-current-summary)
2827         (funcall gnus-default-article-saver filename)))))
2828
2829 (defun gnus-read-save-file-name (prompt &optional filename
2830                                         function group headers variable)
2831   (let ((default-name
2832           (funcall function group headers (symbol-value variable)))
2833         result)
2834     (setq result
2835           (expand-file-name
2836            (cond
2837             ((eq filename 'default)
2838              default-name)
2839             ((eq filename t)
2840              default-name)
2841             (filename filename)
2842             (t
2843              (let* ((split-name (gnus-get-split-value gnus-split-methods))
2844                     (prompt
2845                      (format prompt
2846                              (if (and gnus-number-of-articles-to-be-saved
2847                                       (> gnus-number-of-articles-to-be-saved 1))
2848                                  (format "these %d articles"
2849                                          gnus-number-of-articles-to-be-saved)
2850                                "this article")))
2851                     (file
2852                      ;; Let the split methods have their say.
2853                      (cond
2854                       ;; No split name was found.
2855                       ((null split-name)
2856                        (read-file-name
2857                         (concat prompt " (default "
2858                                 (file-name-nondirectory default-name) ") ")
2859                         (file-name-directory default-name)
2860                         default-name))
2861                       ;; A single group name is returned.
2862                       ((stringp split-name)
2863                        (setq default-name
2864                              (funcall function split-name headers
2865                                       (symbol-value variable)))
2866                        (read-file-name
2867                         (concat prompt " (default "
2868                                 (file-name-nondirectory default-name) ") ")
2869                         (file-name-directory default-name)
2870                         default-name))
2871                       ;; A single split name was found
2872                       ((= 1 (length split-name))
2873                        (let* ((name (expand-file-name
2874                                      (car split-name)
2875                                      gnus-article-save-directory))
2876                               (dir (cond ((file-directory-p name)
2877                                           (file-name-as-directory name))
2878                                          ((file-exists-p name) name)
2879                                          (t gnus-article-save-directory))))
2880                          (read-file-name
2881                           (concat prompt " (default " name ") ")
2882                           dir name)))
2883                       ;; A list of splits was found.
2884                       (t
2885                        (setq split-name (nreverse split-name))
2886                        (let (result)
2887                          (let ((file-name-history
2888                                 (nconc split-name file-name-history)))
2889                            (setq result
2890                                  (expand-file-name
2891                                   (read-file-name
2892                                    (concat prompt " (`M-p' for defaults) ")
2893                                    gnus-article-save-directory
2894                                    (car split-name))
2895                                   gnus-article-save-directory)))
2896                          (car (push result file-name-history)))))))
2897                ;; Create the directory.
2898                (gnus-make-directory (file-name-directory file))
2899       ;; If we have read a directory, we append the default file name.
2900                (when (file-directory-p file)
2901                  (setq file (expand-file-name (file-name-nondirectory
2902                                                default-name)
2903                                               (file-name-as-directory file))))
2904                ;; Possibly translate some characters.
2905                (nnheader-translate-file-chars file))))))
2906     (gnus-make-directory (file-name-directory result))
2907     (set variable result)))
2908
2909 (defun gnus-article-archive-name (group)
2910   "Return the first instance of an \"Archive-name\" in the current buffer."
2911   (let ((case-fold-search t))
2912     (when (re-search-forward "archive-name: *\\([^ \n\t]+\\)[ \t]*$" nil t)
2913       (nnheader-concat gnus-article-save-directory
2914                        (match-string 1)))))
2915
2916 (defun gnus-article-nndoc-name (group)
2917   "If GROUP is an nndoc group, return the name of the parent group."
2918   (when (eq (car (gnus-find-method-for-group group)) 'nndoc)
2919     (gnus-group-get-parameter group 'save-article-group)))
2920
2921 (defun gnus-summary-save-in-rmail (&optional filename)
2922   "Append this article to Rmail file.
2923 Optional argument FILENAME specifies file name.
2924 Directory to save to is default to `gnus-article-save-directory'."
2925   (setq filename (gnus-read-save-file-name
2926                   "Save %s in rmail file:" filename
2927                   gnus-rmail-save-name gnus-newsgroup-name
2928                   gnus-current-headers 'gnus-newsgroup-last-rmail))
2929   (gnus-eval-in-buffer-window gnus-save-article-buffer
2930     (save-excursion
2931       (save-restriction
2932         (widen)
2933         (gnus-output-to-rmail filename))))
2934   filename)
2935
2936 (defun gnus-summary-save-in-mail (&optional filename)
2937   "Append this article to Unix mail file.
2938 Optional argument FILENAME specifies file name.
2939 Directory to save to is default to `gnus-article-save-directory'."
2940   (setq filename (gnus-read-save-file-name
2941                   "Save %s in Unix mail file:" filename
2942                   gnus-mail-save-name gnus-newsgroup-name
2943                   gnus-current-headers 'gnus-newsgroup-last-mail))
2944   (gnus-eval-in-buffer-window gnus-save-article-buffer
2945     (save-excursion
2946       (save-restriction
2947         (widen)
2948         (if (and (file-readable-p filename)
2949                  (mail-file-babyl-p filename))
2950             (rmail-output-to-rmail-file filename t)
2951           (gnus-output-to-mail filename)))))
2952   filename)
2953
2954 (defun gnus-summary-save-in-file (&optional filename overwrite)
2955   "Append this article to file.
2956 Optional argument FILENAME specifies file name.
2957 Directory to save to is default to `gnus-article-save-directory'."
2958   (setq filename (gnus-read-save-file-name
2959                   "Save %s in file:" filename
2960                   gnus-file-save-name gnus-newsgroup-name
2961                   gnus-current-headers 'gnus-newsgroup-last-file))
2962   (gnus-eval-in-buffer-window gnus-save-article-buffer
2963     (save-excursion
2964       (save-restriction
2965         (widen)
2966         (when (and overwrite
2967                    (file-exists-p filename))
2968           (delete-file filename))
2969         (gnus-output-to-file filename))))
2970   filename)
2971
2972 (defun gnus-summary-write-to-file (&optional filename)
2973   "Write this article to a file, overwriting it if the file exists.
2974 Optional argument FILENAME specifies file name.
2975 The directory to save in defaults to `gnus-article-save-directory'."
2976   (gnus-summary-save-in-file nil t))
2977
2978 (defun gnus-summary-save-body-in-file (&optional filename)
2979   "Append this article body to a file.
2980 Optional argument FILENAME specifies file name.
2981 The directory to save in defaults to `gnus-article-save-directory'."
2982   (setq filename (gnus-read-save-file-name
2983                   "Save %s body in file:" filename
2984                   gnus-file-save-name gnus-newsgroup-name
2985                   gnus-current-headers 'gnus-newsgroup-last-file))
2986   (gnus-eval-in-buffer-window gnus-save-article-buffer
2987     (save-excursion
2988       (save-restriction
2989         (widen)
2990         (when (article-goto-body)
2991           (narrow-to-region (point) (point-max)))
2992         (gnus-output-to-file filename))))
2993   filename)
2994
2995 (defun gnus-summary-save-in-pipe (&optional command)
2996   "Pipe this article to subprocess."
2997   (setq command
2998         (cond ((and (eq command 'default)
2999                     gnus-last-shell-command)
3000                gnus-last-shell-command)
3001               ((stringp command)
3002                command)
3003               (t (read-string
3004                   (format
3005                    "Shell command on %s: "
3006                    (if (and gnus-number-of-articles-to-be-saved
3007                             (> gnus-number-of-articles-to-be-saved 1))
3008                        (format "these %d articles"
3009                                gnus-number-of-articles-to-be-saved)
3010                      "this article"))
3011                   gnus-last-shell-command))))
3012   (when (string-equal command "")
3013     (if gnus-last-shell-command
3014         (setq command gnus-last-shell-command)
3015       (error "A command is required")))
3016   (gnus-eval-in-buffer-window gnus-article-buffer
3017     (save-restriction
3018       (widen)
3019       (shell-command-on-region (point-min) (point-max) command nil)))
3020   (setq gnus-last-shell-command command))
3021
3022 (defun gnus-summary-pipe-to-muttprint (&optional command)
3023   "Pipe this article to muttprint."
3024   (setq command (read-string
3025                  "Print using command: " gnus-summary-muttprint-program
3026                  nil gnus-summary-muttprint-program))
3027   (gnus-summary-save-in-pipe command))
3028
3029 ;;; Article file names when saving.
3030
3031 (defun gnus-capitalize-newsgroup (newsgroup)
3032   "Capitalize NEWSGROUP name."
3033   (when (not (zerop (length newsgroup)))
3034     (concat (char-to-string (upcase (aref newsgroup 0)))
3035             (substring newsgroup 1))))
3036
3037 (defun gnus-Numeric-save-name (newsgroup headers &optional last-file)
3038   "Generate file name from NEWSGROUP, HEADERS, and optional LAST-FILE.
3039 If variable `gnus-use-long-file-name' is non-nil, it is ~/News/News.group/num.
3040 Otherwise, it is like ~/News/news/group/num."
3041   (let ((default
3042           (expand-file-name
3043            (concat (if (gnus-use-long-file-name 'not-save)
3044                        (gnus-capitalize-newsgroup newsgroup)
3045                      (gnus-newsgroup-directory-form newsgroup))
3046                    "/" (int-to-string (mail-header-number headers)))
3047            gnus-article-save-directory)))
3048     (if (and last-file
3049              (string-equal (file-name-directory default)
3050                            (file-name-directory last-file))
3051              (string-match "^[0-9]+$" (file-name-nondirectory last-file)))
3052         default
3053       (or last-file default))))
3054
3055 (defun gnus-numeric-save-name (newsgroup headers &optional last-file)
3056   "Generate file name from NEWSGROUP, HEADERS, and optional LAST-FILE.
3057 If variable `gnus-use-long-file-name' is non-nil, it is
3058 ~/News/news.group/num.  Otherwise, it is like ~/News/news/group/num."
3059   (let ((default
3060           (expand-file-name
3061            (concat (if (gnus-use-long-file-name 'not-save)
3062                        newsgroup
3063                      (gnus-newsgroup-directory-form newsgroup))
3064                    "/" (int-to-string (mail-header-number headers)))
3065            gnus-article-save-directory)))
3066     (if (and last-file
3067              (string-equal (file-name-directory default)
3068                            (file-name-directory last-file))
3069              (string-match "^[0-9]+$" (file-name-nondirectory last-file)))
3070         default
3071       (or last-file default))))
3072
3073 (defun gnus-plain-save-name (newsgroup headers &optional last-file)
3074   "Generate file name from NEWSGROUP, HEADERS, and optional LAST-FILE.
3075 If variable `gnus-use-long-file-name' is non-nil, it is
3076 ~/News/news.group.  Otherwise, it is like ~/News/news/group/news."
3077   (or last-file
3078       (expand-file-name
3079        (if (gnus-use-long-file-name 'not-save)
3080            newsgroup
3081          (file-relative-name
3082           (expand-file-name "news" (gnus-newsgroup-directory-form newsgroup))
3083           default-directory))
3084        gnus-article-save-directory)))
3085
3086 (defun gnus-sender-save-name (newsgroup headers &optional last-file)
3087   "Generate file name from sender."
3088   (let ((from (mail-header-from headers)))
3089     (expand-file-name
3090      (if (and from (string-match "\\([^ <]+\\)@" from))
3091          (match-string 1 from)
3092        "nobody")
3093      gnus-article-save-directory)))
3094
3095 (defun article-verify-x-pgp-sig ()
3096   "Verify X-PGP-Sig."
3097   (interactive)
3098   (if (gnus-buffer-live-p gnus-original-article-buffer)
3099       (let ((sig (with-current-buffer gnus-original-article-buffer
3100                    (gnus-fetch-field "X-PGP-Sig")))
3101             items info headers)
3102         (when (and sig
3103                    mml2015-use
3104                    (mml2015-clear-verify-function))
3105           (with-temp-buffer
3106             (insert-buffer gnus-original-article-buffer)
3107             (setq items (split-string sig))
3108             (message-narrow-to-head)
3109             (let ((inhibit-point-motion-hooks t)
3110                   (case-fold-search t))
3111               ;; Don't verify multiple headers.
3112               (setq headers (mapconcat (lambda (header)
3113                                          (concat header ": "
3114                                                  (mail-fetch-field header) "\n"))
3115                                        (split-string (nth 1 items) ",") "")))
3116             (delete-region (point-min) (point-max))
3117             (insert "-----BEGIN PGP SIGNED MESSAGE-----\n\n")
3118             (insert "X-Signed-Headers: " (nth 1 items) "\n")
3119             (insert headers)
3120             (widen)
3121             (forward-line)
3122             (while (not (eobp))
3123               (if (looking-at "^-")
3124                   (insert "- "))
3125               (forward-line))
3126             (insert "\n-----BEGIN PGP SIGNATURE-----\n")
3127             (insert "Version: " (car items) "\n\n")
3128             (insert (mapconcat 'identity (cddr items) "\n"))
3129             (insert "\n-----END PGP SIGNATURE-----\n")
3130             (let ((mm-security-handle (list (format "multipart/signed"))))
3131               (mml2015-clean-buffer)
3132               (let ((coding-system-for-write (or gnus-newsgroup-charset
3133                                                  'iso-8859-1)))
3134                 (funcall (mml2015-clear-verify-function)))
3135               (setq info
3136                     (or (mm-handle-multipart-ctl-parameter
3137                          mm-security-handle 'gnus-details)
3138                         (mm-handle-multipart-ctl-parameter
3139                          mm-security-handle 'gnus-info)))))
3140           (when info
3141             (let (buffer-read-only bface eface)
3142               (save-restriction
3143                 (message-narrow-to-head)
3144                 (goto-char (point-max))
3145                 (forward-line -1)
3146                 (setq bface (get-text-property (gnus-point-at-bol) 'face)
3147                       eface (get-text-property (1- (gnus-point-at-eol)) 'face))
3148                 (message-remove-header "X-Gnus-PGP-Verify")
3149                 (if (re-search-forward "^X-PGP-Sig:" nil t)
3150                     (forward-line)
3151                   (goto-char (point-max)))
3152                 (narrow-to-region (point) (point))
3153                 (insert "X-Gnus-PGP-Verify: " info "\n")
3154                 (goto-char (point-min))
3155                 (forward-line)
3156                 (while (not (eobp))
3157                   (if (not (looking-at "^[ \t]"))
3158                       (insert " "))
3159                   (forward-line))
3160                 ;; Do highlighting.
3161                 (goto-char (point-min))
3162                 (when (looking-at "\\([^:]+\\): *")
3163                   (put-text-property (match-beginning 1) (1+ (match-end 1))
3164                                      'face bface)
3165                   (put-text-property (match-end 0) (point-max)
3166                                      'face eface)))))))))
3167
3168 (defun article-verify-cancel-lock ()
3169   "Verify Cancel-Lock header."
3170   (interactive)
3171   (if (gnus-buffer-live-p gnus-original-article-buffer)
3172       (canlock-verify gnus-original-article-buffer)))
3173
3174 (eval-and-compile
3175   (mapcar
3176    (lambda (func)
3177      (let (afunc gfunc)
3178        (if (consp func)
3179            (setq afunc (car func)
3180                  gfunc (cdr func))
3181          (setq afunc func
3182                gfunc (intern (format "gnus-%s" func))))
3183        (defalias gfunc
3184          (when (fboundp afunc)
3185            `(lambda (&optional interactive &rest args)
3186               ,(documentation afunc t)
3187               (interactive (list t))
3188               (save-excursion
3189                 (set-buffer gnus-article-buffer)
3190                 (if interactive
3191                     (call-interactively ',afunc)
3192                   (apply ',afunc args))))))))
3193    '(article-hide-headers
3194      article-verify-x-pgp-sig
3195      article-verify-cancel-lock
3196      article-hide-boring-headers
3197      article-treat-overstrike
3198      article-fill-long-lines
3199      article-capitalize-sentences
3200      article-remove-cr
3201      article-remove-leading-whitespace
3202      article-display-x-face
3203      article-de-quoted-unreadable
3204      article-de-base64-unreadable
3205      article-decode-HZ
3206      article-wash-html
3207      article-unsplit-urls
3208      article-hide-list-identifiers
3209      article-hide-pgp
3210      article-strip-banner
3211      article-babel
3212      article-hide-pem
3213      article-hide-signature
3214      article-strip-headers-in-body
3215      article-remove-trailing-blank-lines
3216      article-strip-leading-blank-lines
3217      article-strip-multiple-blank-lines
3218      article-strip-leading-space
3219      article-strip-trailing-space
3220      article-strip-blank-lines
3221      article-strip-all-blank-lines
3222      article-replace-with-quoted-text
3223      article-date-local
3224      article-date-english
3225      article-date-iso8601
3226      article-date-original
3227      article-date-ut
3228      article-decode-mime-words
3229      article-decode-charset
3230      article-decode-encoded-words
3231      article-date-user
3232      article-date-lapsed
3233      article-emphasize
3234      article-treat-dumbquotes
3235      article-normalize-headers
3236 ;;     (article-show-all . gnus-article-show-all-headers)
3237      )))
3238 \f
3239 ;;;
3240 ;;; Gnus article mode
3241 ;;;
3242
3243 (put 'gnus-article-mode 'mode-class 'special)
3244
3245 (set-keymap-parent gnus-article-mode-map widget-keymap)
3246
3247 (gnus-define-keys gnus-article-mode-map
3248   " " gnus-article-goto-next-page
3249   "\177" gnus-article-goto-prev-page
3250   [delete] gnus-article-goto-prev-page
3251   [backspace] gnus-article-goto-prev-page
3252   "\C-c^" gnus-article-refer-article
3253   "h" gnus-article-show-summary
3254   "s" gnus-article-show-summary
3255   "\C-c\C-m" gnus-article-mail
3256   "?" gnus-article-describe-briefly
3257   "e" gnus-summary-edit-article
3258   "<" beginning-of-buffer
3259   ">" end-of-buffer
3260   "\C-c\C-i" gnus-info-find-node
3261   "\C-c\C-b" gnus-bug
3262   "R" gnus-article-reply-with-original
3263   "F" gnus-article-followup-with-original
3264   "\C-hk" gnus-article-describe-key
3265   "\C-hc" gnus-article-describe-key-briefly
3266
3267   "\C-d" gnus-article-read-summary-keys
3268   "\M-*" gnus-article-read-summary-keys
3269   "\M-#" gnus-article-read-summary-keys
3270   "\M-^" gnus-article-read-summary-keys
3271   "\M-g" gnus-article-read-summary-keys)
3272
3273 (substitute-key-definition
3274  'undefined 'gnus-article-read-summary-keys gnus-article-mode-map)
3275
3276 (defun gnus-article-make-menu-bar ()
3277   (unless (boundp 'gnus-article-commands-menu)
3278     (gnus-summary-make-menu-bar))
3279   (gnus-turn-off-edit-menu 'article)
3280   (unless (boundp 'gnus-article-article-menu)
3281     (easy-menu-define
3282      gnus-article-article-menu gnus-article-mode-map ""
3283      '("Article"
3284        ["Scroll forwards" gnus-article-goto-next-page t]
3285        ["Scroll backwards" gnus-article-goto-prev-page t]
3286        ["Show summary" gnus-article-show-summary t]
3287        ["Fetch Message-ID at point" gnus-article-refer-article t]
3288        ["Mail to address at point" gnus-article-mail t]
3289        ["Send a bug report" gnus-bug t]))
3290
3291     (easy-menu-define
3292      gnus-article-treatment-menu gnus-article-mode-map ""
3293      ;; Fixme: this should use :active (and maybe :visible).
3294      '("Treatment"
3295        ["Hide headers" gnus-article-hide-headers t]
3296        ["Hide signature" gnus-article-hide-signature t]
3297        ["Hide citation" gnus-article-hide-citation t]
3298        ["Treat overstrike" gnus-article-treat-overstrike t]
3299        ["Remove carriage return" gnus-article-remove-cr t]
3300        ["Remove leading whitespace" gnus-article-remove-leading-whitespace t]
3301        ["Remove quoted-unreadable" gnus-article-de-quoted-unreadable t]
3302        ["Remove base64" gnus-article-de-base64-unreadable t]
3303        ["Treat html" gnus-article-wash-html t]
3304        ["Remove newlines from within URLs" gnus-article-unsplit-urls t]
3305        ["Decode HZ" gnus-article-decode-HZ t]))
3306
3307     ;; Note "Commands" menu is defined in gnus-sum.el for consistency
3308
3309     ;; Note "Post" menu is defined in gnus-sum.el for consistency
3310
3311     (gnus-run-hooks 'gnus-article-menu-hook)))
3312
3313 ;; Fixme: do something for the Emacs tool bar in Article mode a la
3314 ;; Summary.
3315
3316 (defun gnus-article-mode ()
3317   "Major mode for displaying an article.
3318
3319 All normal editing commands are switched off.
3320
3321 The following commands are available in addition to all summary mode
3322 commands:
3323 \\<gnus-article-mode-map>
3324 \\[gnus-article-next-page]\t Scroll the article one page forwards
3325 \\[gnus-article-prev-page]\t Scroll the article one page backwards
3326 \\[gnus-article-refer-article]\t Go to the article referred to by an article id near point
3327 \\[gnus-article-show-summary]\t Display the summary buffer
3328 \\[gnus-article-mail]\t Send a reply to the address near point
3329 \\[gnus-article-describe-briefly]\t Describe the current mode briefly
3330 \\[gnus-info-find-node]\t Go to the Gnus info node"
3331   (interactive)
3332   (gnus-simplify-mode-line)
3333   (setq mode-name "Article")
3334   (setq major-mode 'gnus-article-mode)
3335   (make-local-variable 'minor-mode-alist)
3336   (use-local-map gnus-article-mode-map)
3337   (when (gnus-visual-p 'article-menu 'menu)
3338     (gnus-article-make-menu-bar))
3339   (gnus-update-format-specifications nil 'article-mode)
3340   (set (make-local-variable 'page-delimiter) gnus-page-delimiter)
3341   (make-local-variable 'gnus-page-broken)
3342   (make-local-variable 'gnus-button-marker-list)
3343   (make-local-variable 'gnus-article-current-summary)
3344   (make-local-variable 'gnus-article-mime-handles)
3345   (make-local-variable 'gnus-article-decoded-p)
3346   (make-local-variable 'gnus-article-mime-handle-alist)
3347   (make-local-variable 'gnus-article-wash-types)
3348   (make-local-variable 'gnus-article-image-alist)
3349   (make-local-variable 'gnus-article-charset)
3350   (make-local-variable 'gnus-article-ignored-charsets)
3351   (gnus-set-default-directory)
3352   (buffer-disable-undo)
3353   (setq buffer-read-only t)
3354   (set-syntax-table gnus-article-mode-syntax-table)
3355   (mm-enable-multibyte)
3356   (gnus-run-hooks 'gnus-article-mode-hook))
3357
3358 (defun gnus-article-setup-buffer ()
3359   "Initialize the article buffer."
3360   (let* ((name (if gnus-single-article-buffer "*Article*"
3361                  (concat "*Article " gnus-newsgroup-name "*")))
3362          (original
3363           (progn (string-match "\\*Article" name)
3364                  (concat " *Original Article"
3365                          (substring name (match-end 0))))))
3366     (setq gnus-article-buffer name)
3367     (setq gnus-original-article-buffer original)
3368     (setq gnus-article-mime-handle-alist nil)
3369     ;; This might be a variable local to the summary buffer.
3370     (unless gnus-single-article-buffer
3371       (save-excursion
3372         (set-buffer gnus-summary-buffer)
3373         (setq gnus-article-buffer name)
3374         (setq gnus-original-article-buffer original)
3375         (gnus-set-global-variables)))
3376     (gnus-article-setup-highlight-words)
3377     ;; Init original article buffer.
3378     (save-excursion
3379       (set-buffer (gnus-get-buffer-create gnus-original-article-buffer))
3380       (mm-enable-multibyte)
3381       (setq major-mode 'gnus-original-article-mode)
3382       (make-local-variable 'gnus-original-article))
3383     (if (get-buffer name)
3384         (save-excursion
3385           (set-buffer name)
3386           (when gnus-article-mime-handles
3387             (mm-destroy-parts gnus-article-mime-handles)
3388             (setq gnus-article-mime-handles nil))
3389           ;; Set it to nil in article-buffer!
3390           (setq gnus-article-mime-handle-alist nil)
3391           (buffer-disable-undo)
3392           (setq buffer-read-only t)
3393           (unless (eq major-mode 'gnus-article-mode)
3394             (gnus-article-mode))
3395           (current-buffer))
3396       (save-excursion
3397         (set-buffer (gnus-get-buffer-create name))
3398         (gnus-article-mode)
3399         (make-local-variable 'gnus-summary-buffer)
3400         (gnus-summary-set-local-parameters gnus-newsgroup-name)
3401         (current-buffer)))))
3402
3403 ;; Set article window start at LINE, where LINE is the number of lines
3404 ;; from the head of the article.
3405 (defun gnus-article-set-window-start (&optional line)
3406   (set-window-start
3407    (gnus-get-buffer-window gnus-article-buffer t)
3408    (save-excursion
3409      (set-buffer gnus-article-buffer)
3410      (goto-char (point-min))
3411      (if (not line)
3412          (point-min)
3413        (gnus-message 6 "Moved to bookmark")
3414        (search-forward "\n\n" nil t)
3415        (forward-line line)
3416        (point)))))
3417
3418 (defun gnus-article-prepare (article &optional all-headers header)
3419   "Prepare ARTICLE in article mode buffer.
3420 ARTICLE should either be an article number or a Message-ID.
3421 If ARTICLE is an id, HEADER should be the article headers.
3422 If ALL-HEADERS is non-nil, no headers are hidden."
3423   (save-excursion
3424     ;; Make sure we start in a summary buffer.
3425     (unless (eq major-mode 'gnus-summary-mode)
3426       (set-buffer gnus-summary-buffer))
3427     (setq gnus-summary-buffer (current-buffer))
3428     (let* ((gnus-article (if header (mail-header-number header) article))
3429            (summary-buffer (current-buffer))
3430            (gnus-tmp-internal-hook gnus-article-internal-prepare-hook)
3431            (group gnus-newsgroup-name)
3432            result)
3433       (save-excursion
3434         (gnus-article-setup-buffer)
3435         (set-buffer gnus-article-buffer)
3436         ;; Deactivate active regions.
3437         (when (and (boundp 'transient-mark-mode)
3438                    transient-mark-mode)
3439           (setq mark-active nil))
3440         (if (not (setq result (let ((buffer-read-only nil))
3441                                 (gnus-request-article-this-buffer
3442                                  article group))))
3443             ;; There is no such article.
3444             (save-excursion
3445               (when (and (numberp article)
3446                          (not (memq article gnus-newsgroup-sparse)))
3447                 (setq gnus-article-current
3448                       (cons gnus-newsgroup-name article))
3449                 (set-buffer gnus-summary-buffer)
3450                 (setq gnus-current-article article)
3451                 (if (eq (gnus-article-mark article) gnus-undownloaded-mark)
3452                     (progn
3453                       (gnus-summary-set-agent-mark article)
3454                       (message "Message marked for downloading"))
3455                   (gnus-summary-mark-article article gnus-canceled-mark)
3456                   (unless (memq article gnus-newsgroup-sparse)
3457                     (gnus-error 1 "No such article (may have expired or been canceled)")))))
3458           (if (or (eq result 'pseudo)
3459                   (eq result 'nneething))
3460               (progn
3461                 (save-excursion
3462                   (set-buffer summary-buffer)
3463                   (push article gnus-newsgroup-history)
3464                   (setq gnus-last-article gnus-current-article
3465                         gnus-current-article 0
3466                         gnus-current-headers nil
3467                         gnus-article-current nil)
3468                   (if (eq result 'nneething)
3469                       (gnus-configure-windows 'summary)
3470                     (gnus-configure-windows 'article))
3471                   (gnus-set-global-variables))
3472                 (let ((gnus-article-mime-handle-alist-1
3473                        gnus-article-mime-handle-alist))
3474                   (gnus-set-mode-line 'article)))
3475             ;; The result from the `request' was an actual article -
3476             ;; or at least some text that is now displayed in the
3477             ;; article buffer.
3478             (when (and (numberp article)
3479                        (not (eq article gnus-current-article)))
3480               ;; Seems like a new article has been selected.
3481               ;; `gnus-current-article' must be an article number.
3482               (save-excursion
3483                 (set-buffer summary-buffer)
3484                 (push article gnus-newsgroup-history)
3485                 (setq gnus-last-article gnus-current-article
3486                       gnus-current-article article
3487                       gnus-current-headers
3488                       (gnus-summary-article-header gnus-current-article)
3489                       gnus-article-current
3490                       (cons gnus-newsgroup-name gnus-current-article))
3491                 (unless (vectorp gnus-current-headers)
3492                   (setq gnus-current-headers nil))
3493                 (gnus-summary-goto-subject gnus-current-article)
3494                 (when (gnus-summary-show-thread)
3495                   ;; If the summary buffer really was folded, the
3496                   ;; previous goto may not actually have gone to
3497                   ;; the right article, but the thread root instead.
3498                   ;; So we go again.
3499                   (gnus-summary-goto-subject gnus-current-article))
3500                 (gnus-run-hooks 'gnus-mark-article-hook)
3501                 (gnus-set-mode-line 'summary)
3502                 (when (gnus-visual-p 'article-highlight 'highlight)
3503                   (gnus-run-hooks 'gnus-visual-mark-article-hook))
3504                 ;; Set the global newsgroup variables here.
3505                 (gnus-set-global-variables)
3506                 (setq gnus-have-all-headers
3507                       (or all-headers gnus-show-all-headers))))
3508             (save-excursion
3509               (gnus-configure-windows 'article))
3510             (when (or (numberp article)
3511                       (stringp article))
3512               (gnus-article-prepare-display)
3513               ;; Do page break.
3514               (goto-char (point-min))
3515               (setq gnus-page-broken
3516                     (when gnus-break-pages
3517                       (gnus-narrow-to-page)
3518                       t)))
3519             (let ((gnus-article-mime-handle-alist-1
3520                    gnus-article-mime-handle-alist))
3521               (gnus-set-mode-line 'article))
3522             (article-goto-body)
3523             (set-window-point (get-buffer-window (current-buffer)) (point))
3524             (gnus-configure-windows 'article)
3525             t))))))
3526
3527 ;;;###autoload
3528 (defun gnus-article-prepare-display ()
3529   "Make the current buffer look like a nice article."
3530   ;; Hooks for getting information from the article.
3531   ;; This hook must be called before being narrowed.
3532   (let ((gnus-article-buffer (current-buffer))
3533         buffer-read-only)
3534     (unless (eq major-mode 'gnus-article-mode)
3535       (gnus-article-mode))
3536     (setq buffer-read-only nil
3537           gnus-article-wash-types nil
3538           gnus-article-image-alist nil)
3539     (gnus-run-hooks 'gnus-tmp-internal-hook)
3540     (when gnus-display-mime-function
3541       (funcall gnus-display-mime-function))
3542     (gnus-run-hooks 'gnus-article-prepare-hook)))
3543
3544 ;;;
3545 ;;; Gnus MIME viewing functions
3546 ;;;
3547
3548 (defvar gnus-mime-button-line-format "%{%([%p. %d%T]%)%}%e\n"
3549   "Format of the MIME buttons.
3550
3551 Valid specifiers include:
3552 %t  The MIME type
3553 %T  MIME type, along with additional info
3554 %n  The `name' parameter
3555 %d  The description, if any
3556 %l  The length of the encoded part
3557 %p  The part identifier number
3558 %e  Dots if the part isn't displayed
3559
3560 General format specifiers can also be used.  See
3561 (gnus)Formatting Variables.")
3562
3563 (defvar gnus-mime-button-line-format-alist
3564   '((?t gnus-tmp-type ?s)
3565     (?T gnus-tmp-type-long ?s)
3566     (?n gnus-tmp-name ?s)
3567     (?d gnus-tmp-description ?s)
3568     (?p gnus-tmp-id ?s)
3569     (?l gnus-tmp-length ?d)
3570     (?e gnus-tmp-dots ?s)))
3571
3572 (defvar gnus-mime-button-commands
3573   '((gnus-article-press-button "\r" "Toggle Display")
3574     (gnus-mime-view-part "v" "View Interactively...")
3575     (gnus-mime-view-part-as-type "t" "View As Type...")
3576     (gnus-mime-view-part-as-charset "C" "View As charset...")
3577     (gnus-mime-save-part "o" "Save...")
3578     (gnus-mime-save-part-and-strip "\C-o" "Save and Strip")
3579     (gnus-mime-copy-part "c" "View As Text, In Other Buffer")
3580     (gnus-mime-inline-part "i" "View As Text, In This Buffer")
3581     (gnus-mime-view-part-internally "E" "View Internally")
3582     (gnus-mime-view-part-externally "e" "View Externally")
3583     (gnus-mime-print-part "p" "Print")
3584     (gnus-mime-pipe-part "|" "Pipe To Command...")
3585     (gnus-mime-action-on-part "." "Take action on the part")))
3586
3587 (defun gnus-article-mime-part-status ()
3588   (if gnus-article-mime-handle-alist-1
3589       (if (eq 1 (length gnus-article-mime-handle-alist-1))
3590           " (1 part)"
3591         (format " (%d parts)" (length gnus-article-mime-handle-alist-1)))
3592     ""))
3593
3594 (defvar gnus-mime-button-map
3595   (let ((map (make-sparse-keymap)))
3596     (unless (>= (string-to-number emacs-version) 21)
3597       ;; XEmacs doesn't care.
3598       (set-keymap-parent map gnus-article-mode-map))
3599     (define-key map gnus-mouse-2 'gnus-article-push-button)
3600     (define-key map gnus-down-mouse-3 'gnus-mime-button-menu)
3601     (dolist (c gnus-mime-button-commands)
3602       (define-key map (cadr c) (car c)))
3603     map))
3604
3605 (defun gnus-mime-button-menu (event)
3606   "Construct a context-sensitive menu of MIME commands."
3607   (interactive "e")
3608   (save-window-excursion
3609     (let ((pos (event-start event)))
3610       (select-window (posn-window pos))
3611       (goto-char (posn-point pos))
3612       (gnus-article-check-buffer)
3613       (let ((response (x-popup-menu
3614                        t `("MIME Part"
3615                            ("" ,@(mapcar (lambda (c)
3616                                            (cons (caddr c) (car c)))
3617                                          gnus-mime-button-commands))))))
3618         (if response
3619             (call-interactively response))))))
3620
3621 (defun gnus-mime-view-all-parts (&optional handles)
3622   "View all the MIME parts."
3623   (interactive)
3624   (save-current-buffer
3625     (set-buffer gnus-article-buffer)
3626     (let ((handles (or handles gnus-article-mime-handles))
3627           (mail-parse-charset gnus-newsgroup-charset)
3628           (mail-parse-ignored-charsets
3629            (with-current-buffer gnus-summary-buffer
3630              gnus-newsgroup-ignored-charsets)))
3631       (when handles
3632         (mm-remove-parts handles)
3633         (goto-char (point-min))
3634         (or (search-forward "\n\n") (goto-char (point-max)))
3635         (let (buffer-read-only)
3636           (delete-region (point) (point-max))
3637           (mm-display-parts handles))))))
3638
3639 (defun gnus-mime-save-part-and-strip ()
3640   "Save the MIME part under point then replace it with an external body."
3641   (interactive)
3642   (gnus-article-check-buffer)
3643   (let* ((data (get-text-property (point) 'gnus-data))
3644          file param
3645          (handles gnus-article-mime-handles))
3646     (if (mm-multiple-handles gnus-article-mime-handles)
3647         (error "This function is not implemented"))
3648     (setq file (and data (mm-save-part data)))
3649     (when file
3650       (with-current-buffer (mm-handle-buffer data)
3651         (erase-buffer)
3652         (insert "Content-Type: " (mm-handle-media-type data))
3653         (mml-insert-parameter-string (cdr (mm-handle-type data))
3654                                      '(charset))
3655         (insert "\n")
3656         (insert "Content-ID: " (message-make-message-id) "\n")
3657         (insert "Content-Transfer-Encoding: binary\n")
3658         (insert "\n"))
3659       (setcdr data
3660               (cdr (mm-make-handle nil
3661                                    `("message/external-body"
3662                                      (access-type . "LOCAL-FILE")
3663                                      (name . ,file)))))
3664       (set-buffer gnus-summary-buffer)
3665       (gnus-article-edit-article
3666        `(lambda ()
3667            (erase-buffer)
3668            (let ((mail-parse-charset (or gnus-article-charset
3669                                          ',gnus-newsgroup-charset))
3670                  (mail-parse-ignored-charsets
3671                   (or gnus-article-ignored-charsets
3672                       ',gnus-newsgroup-ignored-charsets))
3673                  (mbl mml-buffer-list))
3674              (setq mml-buffer-list nil)
3675              (insert-buffer gnus-original-article-buffer)
3676              (mime-to-mml ',handles)
3677              (setq gnus-article-mime-handles nil)
3678              (let ((mbl1 mml-buffer-list))
3679                (setq mml-buffer-list mbl)
3680                (set (make-local-variable 'mml-buffer-list) mbl1))
3681              ;; LOCAL argument of add-hook differs between GNU Emacs
3682              ;; and XEmacs. make-local-hook makes sure they are local.
3683              (make-local-hook 'kill-buffer-hook)
3684              (add-hook 'kill-buffer-hook 'mml-destroy-buffers t t)))
3685        `(lambda (no-highlight)
3686           (let ((mail-parse-charset (or gnus-article-charset
3687                                         ',gnus-newsgroup-charset))
3688                 (message-options message-options)
3689                 (message-options-set-recipient)
3690                 (mail-parse-ignored-charsets
3691                  (or gnus-article-ignored-charsets
3692                      ',gnus-newsgroup-ignored-charsets)))
3693            (mml-to-mime)
3694            (mml-destroy-buffers)
3695            (remove-hook 'kill-buffer-hook
3696                         'mml-destroy-buffers t)
3697            (kill-local-variable 'mml-buffer-list))
3698           (gnus-summary-edit-article-done
3699            ,(or (mail-header-references gnus-current-headers) "")
3700            ,(gnus-group-read-only-p)
3701            ,gnus-summary-buffer no-highlight))))))
3702
3703 (defun gnus-mime-save-part ()
3704   "Save the MIME part under point."
3705   (interactive)
3706   (gnus-article-check-buffer)
3707   (let ((data (get-text-property (point) 'gnus-data)))
3708     (when data
3709       (mm-save-part data))))
3710
3711 (defun gnus-mime-pipe-part ()
3712   "Pipe the MIME part under point to a process."
3713   (interactive)
3714   (gnus-article-check-buffer)
3715   (let ((data (get-text-property (point) 'gnus-data)))
3716     (when data
3717       (mm-pipe-part data))))
3718
3719 (defun gnus-mime-view-part ()
3720   "Interactively choose a viewing method for the MIME part under point."
3721   (interactive)
3722   (gnus-article-check-buffer)
3723   (let ((data (get-text-property (point) 'gnus-data)))
3724     (when data
3725       (setq gnus-article-mime-handles
3726             (mm-merge-handles
3727              gnus-article-mime-handles (setq data (copy-sequence data))))
3728       (mm-interactively-view-part data))))
3729
3730 (defun gnus-mime-view-part-as-type-internal ()
3731   (gnus-article-check-buffer)
3732   (let* ((name (mail-content-type-get
3733                 (mm-handle-type (get-text-property (point) 'gnus-data))
3734                 'name))
3735          (def-type (and name (mm-default-file-encoding name))))
3736     (and def-type (cons def-type 0))))
3737
3738 (defun gnus-mime-view-part-as-type (&optional mime-type)
3739   "Choose a MIME media type, and view the part as such."
3740   (interactive)
3741   (unless mime-type
3742     (setq mime-type (completing-read
3743                      "View as MIME type: "
3744                      (mapcar #'list (mailcap-mime-types))
3745                      nil nil
3746                      (gnus-mime-view-part-as-type-internal))))
3747   (gnus-article-check-buffer)
3748   (let ((handle (get-text-property (point) 'gnus-data)))
3749     (when handle
3750       (setq handle
3751             (mm-make-handle (mm-handle-buffer handle)
3752                             (cons mime-type (cdr (mm-handle-type handle)))
3753                             (mm-handle-encoding handle)
3754                             (mm-handle-undisplayer handle)
3755                             (mm-handle-disposition handle)
3756                             (mm-handle-description handle)
3757                             nil
3758                             (mm-handle-id handle)))
3759       (setq gnus-article-mime-handles
3760             (mm-merge-handles gnus-article-mime-handles handle))
3761       (gnus-mm-display-part handle))))
3762
3763 (defun gnus-mime-copy-part (&optional handle)
3764   "Put the MIME part under point into a new buffer."
3765   (interactive)
3766   (gnus-article-check-buffer)
3767   (let* ((handle (or handle (get-text-property (point) 'gnus-data)))
3768          (contents (and handle (mm-get-part handle)))
3769          (base (and handle
3770                     (file-name-nondirectory
3771                      (or
3772                       (mail-content-type-get (mm-handle-type handle) 'name)
3773                       (mail-content-type-get (mm-handle-type handle)
3774                                              'filename)
3775                       "*decoded*"))))
3776          (buffer (and base (generate-new-buffer base))))
3777     (when contents
3778       (switch-to-buffer buffer)
3779       (insert contents)
3780       ;; We do it this way to make `normal-mode' set the appropriate mode.
3781       (unwind-protect
3782           (progn
3783             (setq buffer-file-name (expand-file-name base))
3784             (normal-mode))
3785         (setq buffer-file-name nil))
3786       (goto-char (point-min)))))
3787
3788 (defun gnus-mime-print-part (&optional handle filename)
3789   "Print the MIME part under point."
3790   (interactive (list nil (ps-print-preprint current-prefix-arg)))
3791   (gnus-article-check-buffer)
3792   (let* ((handle (or handle (get-text-property (point) 'gnus-data)))
3793          (contents (and handle (mm-get-part handle)))
3794          (file (make-temp-name (expand-file-name "mm." mm-tmp-directory)))
3795          (printer (mailcap-mime-info (mm-handle-type handle) "print")))
3796     (when contents
3797         (if printer
3798             (unwind-protect
3799                 (progn
3800                   (with-temp-file file
3801                     (insert contents))
3802                   (call-process shell-file-name nil
3803                                 (generate-new-buffer " *mm*")
3804                                 nil
3805                                 shell-command-switch
3806                                 (mm-mailcap-command
3807                                  printer file (mm-handle-type handle))))
3808               (delete-file file))
3809           (with-temp-buffer
3810             (insert contents)
3811             (gnus-print-buffer))
3812           (ps-despool filename)))))
3813
3814 (defun gnus-mime-inline-part (&optional handle arg)
3815   "Insert the MIME part under point into the current buffer."
3816   (interactive (list nil current-prefix-arg))
3817   (gnus-article-check-buffer)
3818   (let* ((handle (or handle (get-text-property (point) 'gnus-data)))
3819          contents charset
3820          (b (point))
3821          buffer-read-only)
3822     (when handle
3823       (if (and (not arg) (mm-handle-undisplayer handle))
3824           (mm-remove-part handle)
3825         (setq contents (mm-get-part handle))
3826         (cond
3827          ((not arg)
3828           (setq charset (or (mail-content-type-get
3829                              (mm-handle-type handle) 'charset)
3830                             gnus-newsgroup-charset)))
3831          ((numberp arg)
3832           (if (mm-handle-undisplayer handle)
3833               (mm-remove-part handle))
3834           (setq charset
3835                 (or (cdr (assq arg
3836                                gnus-summary-show-article-charset-alist))
3837                     (mm-read-coding-system "Charset: ")))))
3838         (forward-line 2)
3839         (mm-insert-inline handle
3840                           (if (and charset
3841                                    (setq charset (mm-charset-to-coding-system
3842                                                   charset))
3843                                    (not (eq charset 'ascii)))
3844                               (mm-decode-coding-string contents charset)
3845                             contents))
3846         (goto-char b)))))
3847
3848 (defun gnus-mime-view-part-as-charset (&optional handle arg)
3849   "Insert the MIME part under point into the current buffer using the
3850 specified charset."
3851   (interactive (list nil current-prefix-arg))
3852   (gnus-article-check-buffer)
3853   (let* ((handle (or handle (get-text-property (point) 'gnus-data)))
3854          contents charset
3855          (b (point))
3856          buffer-read-only)
3857     (when handle
3858       (if (mm-handle-undisplayer handle)
3859           (mm-remove-part handle))
3860       (let ((gnus-newsgroup-charset
3861              (or (cdr (assq arg
3862                             gnus-summary-show-article-charset-alist))
3863                  (mm-read-coding-system "Charset: ")))
3864           (gnus-newsgroup-ignored-charsets 'gnus-all))
3865         (gnus-article-press-button)))))
3866
3867 (defun gnus-mime-view-part-externally (&optional handle)
3868   "View the MIME part under point with an external viewer."
3869   (interactive)
3870   (gnus-article-check-buffer)
3871   (let* ((handle (or handle (get-text-property (point) 'gnus-data)))
3872          (mm-user-display-methods nil)
3873          (mm-inlined-types nil)
3874          (mail-parse-charset gnus-newsgroup-charset)
3875          (mail-parse-ignored-charsets
3876           (save-excursion (set-buffer gnus-summary-buffer)
3877                           gnus-newsgroup-ignored-charsets)))
3878     (when handle
3879       (if (mm-handle-undisplayer handle)
3880           (mm-remove-part handle)
3881         (mm-display-part handle)))))
3882
3883 (defun gnus-mime-view-part-internally (&optional handle)
3884   "View the MIME part under point with an internal viewer.
3885 If no internal viewer is available, use an external viewer."
3886   (interactive)
3887   (gnus-article-check-buffer)
3888   (let* ((handle (or handle (get-text-property (point) 'gnus-data)))
3889          (mm-inlined-types '(".*"))
3890          (mm-inline-large-images t)
3891          (mail-parse-charset gnus-newsgroup-charset)
3892          (mail-parse-ignored-charsets
3893           (save-excursion (set-buffer gnus-summary-buffer)
3894                           gnus-newsgroup-ignored-charsets)))
3895     (when handle
3896       (if (mm-handle-undisplayer handle)
3897           (mm-remove-part handle)
3898         (mm-display-part handle)))))
3899
3900 (defun gnus-mime-action-on-part (&optional action)
3901   "Do something with the MIME attachment at \(point\)."
3902   (interactive
3903    (list (completing-read "Action: " gnus-mime-action-alist)))
3904   (gnus-article-check-buffer)
3905   (let ((action-pair (assoc action gnus-mime-action-alist)))
3906     (if action-pair
3907         (funcall (cdr action-pair)))))
3908
3909 (defun gnus-article-part-wrapper (n function)
3910   (save-current-buffer
3911     (set-buffer gnus-article-buffer)
3912     (when (> n (length gnus-article-mime-handle-alist))
3913       (error "No such part"))
3914     (gnus-article-goto-part n)
3915     (let ((handle (cdr (assq n gnus-article-mime-handle-alist))))
3916       (funcall function handle))))
3917
3918 (defun gnus-article-pipe-part (n)
3919   "Pipe MIME part N, which is the numerical prefix."
3920   (interactive "p")
3921   (gnus-article-part-wrapper n 'mm-pipe-part))
3922
3923 (defun gnus-article-save-part (n)
3924   "Save MIME part N, which is the numerical prefix."
3925   (interactive "p")
3926   (gnus-article-part-wrapper n 'mm-save-part))
3927
3928 (defun gnus-article-interactively-view-part (n)
3929   "View MIME part N interactively, which is the numerical prefix."
3930   (interactive "p")
3931   (gnus-article-part-wrapper n 'mm-interactively-view-part))
3932
3933 (defun gnus-article-copy-part (n)
3934   "Copy MIME part N, which is the numerical prefix."
3935   (interactive "p")
3936   (gnus-article-part-wrapper n 'gnus-mime-copy-part))
3937
3938 (defun gnus-article-view-part-as-charset (n)
3939   "Copy MIME part N, which is the numerical prefix."
3940   (interactive "p")
3941   (gnus-article-part-wrapper n 'gnus-mime-view-part-as-charset))
3942
3943 (defun gnus-article-view-part-externally (n)
3944   "View MIME part N externally, which is the numerical prefix."
3945   (interactive "p")
3946   (gnus-article-part-wrapper n 'gnus-mime-view-part-externally))
3947
3948 (defun gnus-article-inline-part (n)
3949   "Inline MIME part N, which is the numerical prefix."
3950   (interactive "p")
3951   (gnus-article-part-wrapper n 'gnus-mime-inline-part))
3952
3953 (defun gnus-article-mime-match-handle-first (condition)
3954   (if condition
3955       (let ((alist gnus-article-mime-handle-alist) ihandle n)
3956         (while (setq ihandle (pop alist))
3957           (if (and (cond
3958                     ((functionp condition)
3959                      (funcall condition (cdr ihandle)))
3960                     ((eq condition 'undisplayed)
3961                      (not (or (mm-handle-undisplayer (cdr ihandle))
3962                               (equal (mm-handle-media-type (cdr ihandle))
3963                                      "multipart/alternative"))))
3964                     ((eq condition 'undisplayed-alternative)
3965                      (not (mm-handle-undisplayer (cdr ihandle))))
3966                     (t t))
3967                    (gnus-article-goto-part (car ihandle))
3968                    (or (not n) (< (car ihandle) n)))
3969               (setq n (car ihandle))))
3970         (or n 1))
3971     1))
3972
3973 (defun gnus-article-view-part (&optional n)
3974   "View MIME part N, which is the numerical prefix."
3975   (interactive "P")
3976   (save-current-buffer
3977     (set-buffer gnus-article-buffer)
3978     (or (numberp n) (setq n (gnus-article-mime-match-handle-first
3979                              gnus-article-mime-match-handle-function)))
3980     (when (> n (length gnus-article-mime-handle-alist))
3981       (error "No such part"))
3982     (let ((handle (cdr (assq n gnus-article-mime-handle-alist))))
3983       (when (gnus-article-goto-part n)
3984         (if (equal (car handle) "multipart/alternative")
3985             (gnus-article-press-button)
3986           (when (eq (gnus-mm-display-part handle) 'internal)
3987             (gnus-set-window-start)))))))
3988
3989 (defsubst gnus-article-mime-total-parts ()
3990   (if (bufferp (car gnus-article-mime-handles))
3991       1 ;; single part
3992     (1- (length gnus-article-mime-handles))))
3993
3994 (defun gnus-mm-display-part (handle)
3995   "Display HANDLE and fix MIME button."
3996   (let ((id (get-text-property (point) 'gnus-part))
3997         (point (point))
3998         buffer-read-only)
3999     (forward-line 1)
4000     (prog1
4001         (let ((window (selected-window))
4002               (mail-parse-charset gnus-newsgroup-charset)
4003               (mail-parse-ignored-charsets
4004                (if (gnus-buffer-live-p gnus-summary-buffer)
4005                    (save-excursion
4006                      (set-buffer gnus-summary-buffer)
4007                      gnus-newsgroup-ignored-charsets)
4008                  nil)))
4009           (save-excursion
4010             (unwind-protect
4011                 (let ((win (gnus-get-buffer-window (current-buffer) t))
4012                       (beg (point)))
4013                   (when win
4014                     (select-window win))
4015                   (goto-char point)
4016                   (forward-line)
4017                   (if (mm-handle-displayed-p handle)
4018                       ;; This will remove the part.
4019                       (mm-display-part handle)
4020                     (save-restriction
4021                       (narrow-to-region (point)
4022                                         (if (eobp) (point) (1+ (point))))
4023                       (mm-display-part handle)
4024                       ;; We narrow to the part itself and
4025                       ;; then call the treatment functions.
4026                       (goto-char (point-min))
4027                       (forward-line 1)
4028                       (narrow-to-region (point) (point-max))
4029                       (gnus-treat-article
4030                        nil id
4031                        (gnus-article-mime-total-parts)
4032                        (mm-handle-media-type handle)))))
4033               (if (window-live-p window)
4034                   (select-window window)))))
4035       (goto-char point)
4036       (delete-region (gnus-point-at-bol) (progn (forward-line 1) (point)))
4037       (gnus-insert-mime-button
4038        handle id (list (mm-handle-displayed-p handle)))
4039       (goto-char point))))
4040
4041 (defun gnus-article-goto-part (n)
4042   "Go to MIME part N."
4043   (let ((point (text-property-any (point-min) (point-max) 'gnus-part n)))
4044     (when point
4045       (goto-char point))))
4046
4047 (defun gnus-insert-mime-button (handle gnus-tmp-id &optional displayed)
4048   (let ((gnus-tmp-name
4049          (or (mail-content-type-get (mm-handle-type handle) 'name)
4050              (mail-content-type-get (mm-handle-disposition handle) 'filename)
4051              (mail-content-type-get (mm-handle-type handle) 'url)
4052              ""))
4053         (gnus-tmp-type (mm-handle-media-type handle))
4054         (gnus-tmp-description
4055          (mail-decode-encoded-word-string (or (mm-handle-description handle)
4056                                               "")))
4057         (gnus-tmp-dots
4058          (if (if displayed (car displayed)
4059                (mm-handle-displayed-p handle))
4060              "" "..."))
4061         (gnus-tmp-length (with-current-buffer (mm-handle-buffer handle)
4062                            (buffer-size)))
4063         gnus-tmp-type-long b e)
4064     (when (string-match ".*/" gnus-tmp-name)
4065       (setq gnus-tmp-name (replace-match "" t t gnus-tmp-name)))
4066     (setq gnus-tmp-type-long (concat gnus-tmp-type
4067                                      (and (not (equal gnus-tmp-name ""))
4068                                           (concat "; " gnus-tmp-name))))
4069     (unless (equal gnus-tmp-description "")
4070       (setq gnus-tmp-type-long (concat " --- " gnus-tmp-type-long)))
4071     (unless (bolp)
4072       (insert "\n"))
4073     (setq b (point))
4074     (gnus-eval-format
4075      gnus-mime-button-line-format gnus-mime-button-line-format-alist
4076      `(,@(gnus-local-map-property gnus-mime-button-map)
4077          gnus-callback gnus-mm-display-part
4078          gnus-part ,gnus-tmp-id
4079          article-type annotation
4080          gnus-data ,handle))
4081     (setq e (point))
4082     (widget-convert-button
4083      'link b e
4084      :mime-handle handle
4085      :action 'gnus-widget-press-button
4086      :button-keymap gnus-mime-button-map
4087      :help-echo
4088      (lambda (widget/window &optional overlay pos)
4089        ;; Needed to properly clear the message due to a bug in
4090        ;; wid-edit (XEmacs only).
4091        (if (boundp 'help-echo-owns-message)
4092            (setq help-echo-owns-message t))
4093        (format
4094         "%S: %s the MIME part; %S: more options"
4095         (aref gnus-mouse-2 0)
4096         ;; XEmacs will get a single widget arg; Emacs 21 will get
4097         ;; window, overlay, position.
4098         (if (mm-handle-displayed-p
4099              (if overlay
4100                  (with-current-buffer (gnus-overlay-buffer overlay)
4101                    (widget-get (widget-at (gnus-overlay-start overlay))
4102                                :mime-handle))
4103                (widget-get widget/window :mime-handle)))
4104             "hide" "show")
4105         (aref gnus-down-mouse-3 0))))))
4106
4107 (defun gnus-widget-press-button (elems el)
4108   (goto-char (widget-get elems :from))
4109   (gnus-article-press-button))
4110
4111 (defvar gnus-displaying-mime nil)
4112
4113 (defun gnus-display-mime (&optional ihandles)
4114   "Display the MIME parts."
4115   (save-excursion
4116     (save-selected-window
4117       (let ((window (get-buffer-window gnus-article-buffer))
4118             (point (point)))
4119         (when window
4120           (select-window window)
4121           ;; We have to do this since selecting the window
4122           ;; may change the point.  So we set the window point.
4123           (set-window-point window point)))
4124       (let* ((handles (or ihandles (mm-dissect-buffer
4125                                     nil gnus-article-loose-mime)
4126                           (mm-uu-dissect)))
4127              buffer-read-only handle name type b e display)
4128         (when (and (not ihandles)
4129                    (not gnus-displaying-mime))
4130           ;; Top-level call; we clean up.
4131           (when gnus-article-mime-handles
4132             (mm-destroy-parts gnus-article-mime-handles)
4133             (setq gnus-article-mime-handle-alist nil));; A trick.
4134           (setq gnus-article-mime-handles handles)
4135           ;; We allow users to glean info from the handles.
4136           (when gnus-article-mime-part-function
4137             (gnus-mime-part-function handles)))
4138         (if (and handles
4139                  (or (not (stringp (car handles)))
4140                      (cdr handles)))
4141             (progn
4142               (when (and (not ihandles)
4143                          (not gnus-displaying-mime))
4144                 ;; Clean up for mime parts.
4145                 (article-goto-body)
4146                 (delete-region (point) (point-max)))
4147               (let ((gnus-displaying-mime t))
4148                 (gnus-mime-display-part handles)))
4149           (save-restriction
4150             (article-goto-body)
4151             (narrow-to-region (point) (point-max))
4152             (gnus-treat-article nil 1 1)
4153             (widen)))
4154         (unless ihandles
4155           ;; Highlight the headers.
4156           (save-excursion
4157             (save-restriction
4158               (article-goto-body)
4159               (narrow-to-region (point-min) (point))
4160               (gnus-treat-article 'head))))))))
4161
4162 (defvar gnus-mime-display-multipart-as-mixed nil)
4163 (defvar gnus-mime-display-multipart-alternative-as-mixed nil)
4164 (defvar gnus-mime-display-multipart-related-as-mixed nil)
4165
4166 (defun gnus-mime-display-part (handle)
4167   (cond
4168    ;; Single part.
4169    ((not (stringp (car handle)))
4170     (gnus-mime-display-single handle))
4171    ;; User-defined multipart
4172    ((cdr (assoc (car handle) gnus-mime-multipart-functions))
4173     (funcall (cdr (assoc (car handle) gnus-mime-multipart-functions))
4174              handle))
4175    ;; multipart/alternative
4176    ((and (equal (car handle) "multipart/alternative")
4177          (not (or gnus-mime-display-multipart-as-mixed
4178                   gnus-mime-display-multipart-alternative-as-mixed)))
4179     (let ((id (1+ (length gnus-article-mime-handle-alist))))
4180       (push (cons id handle) gnus-article-mime-handle-alist)
4181       (gnus-mime-display-alternative (cdr handle) nil nil id)))
4182    ;; multipart/related
4183    ((and (equal (car handle) "multipart/related")
4184          (not (or gnus-mime-display-multipart-as-mixed
4185                   gnus-mime-display-multipart-related-as-mixed)))
4186     ;;;!!!We should find the start part, but we just default
4187     ;;;!!!to the first part.
4188     ;;(gnus-mime-display-part (cadr handle))
4189     ;;;!!! Most multipart/related is an HTML message plus images.
4190     ;;;!!! Unfortunately we are unable to let W3 display those
4191     ;;;!!! included images, so we just display it as a mixed multipart.
4192     ;;(gnus-mime-display-mixed (cdr handle))
4193     ;;;!!! No, w3 can display everything just fine.
4194     (gnus-mime-display-part (cadr handle)))
4195    ((equal (car handle) "multipart/signed")
4196     (gnus-add-wash-type 'signed)
4197     (gnus-mime-display-security handle))
4198    ((equal (car handle) "multipart/encrypted")
4199     (gnus-add-wash-type 'encrypted)
4200     (gnus-mime-display-security handle))
4201    ;; Other multiparts are handled like multipart/mixed.
4202    (t
4203     (gnus-mime-display-mixed (cdr handle)))))
4204
4205 (defun gnus-mime-part-function (handles)
4206   (if (stringp (car handles))
4207       (mapcar 'gnus-mime-part-function (cdr handles))
4208     (funcall gnus-article-mime-part-function handles)))
4209
4210 (defun gnus-mime-display-mixed (handles)
4211   (mapcar 'gnus-mime-display-part handles))
4212
4213 (defun gnus-mime-display-single (handle)
4214   (let ((type (mm-handle-media-type handle))
4215         (ignored gnus-ignored-mime-types)
4216         (not-attachment t)
4217         (move nil)
4218         display text)
4219     (catch 'ignored
4220       (progn
4221         (while ignored
4222           (when (string-match (pop ignored) type)
4223             (throw 'ignored nil)))
4224         (if (and (setq not-attachment
4225                        (and (not (mm-inline-override-p handle))
4226                             (or (not (mm-handle-disposition handle))
4227                                 (equal (car (mm-handle-disposition handle))
4228                                        "inline")
4229                                 (mm-attachment-override-p handle))))
4230                  (mm-automatic-display-p handle)
4231                  (or (and
4232                       (mm-inlinable-p handle)
4233                       (mm-inlined-p handle))
4234                      (mm-automatic-external-display-p type)))
4235             (setq display t)
4236           (when (equal (mm-handle-media-supertype handle) "text")
4237             (setq text t)))
4238         (let ((id (1+ (length gnus-article-mime-handle-alist)))
4239               beg)
4240           (push (cons id handle) gnus-article-mime-handle-alist)
4241           (when (or (not display)
4242                     (not (gnus-unbuttonized-mime-type-p type)))
4243             ;(gnus-article-insert-newline)
4244             (gnus-insert-mime-button
4245              handle id (list (or display (and not-attachment text))))
4246             (gnus-article-insert-newline)
4247             ;(gnus-article-insert-newline)
4248             ;; Remember modify the number of forward lines.
4249             (setq move t))
4250           (setq beg (point))
4251           (cond
4252            (display
4253             (when move
4254               (forward-line -1)
4255               (setq beg (point)))
4256             (let ((mail-parse-charset gnus-newsgroup-charset)
4257                   (mail-parse-ignored-charsets
4258                    (save-excursion (condition-case ()
4259                                        (set-buffer gnus-summary-buffer)
4260                                      (error))
4261                                    gnus-newsgroup-ignored-charsets)))
4262               (mm-display-part handle t))
4263             (goto-char (point-max)))
4264            ((and text not-attachment)
4265             (when move
4266               (forward-line -1)
4267               (setq beg (point)))
4268             (gnus-article-insert-newline)
4269             (mm-insert-inline handle (mm-get-part handle))
4270             (goto-char (point-max))))
4271           ;; Do highlighting.
4272           (save-excursion
4273             (save-restriction
4274               (narrow-to-region beg (point))
4275               (gnus-treat-article
4276                nil id
4277                (gnus-article-mime-total-parts)
4278                (mm-handle-media-type handle)))))))))
4279
4280 (defun gnus-unbuttonized-mime-type-p (type)
4281   "Say whether TYPE is to be unbuttonized."
4282   (unless gnus-inhibit-mime-unbuttonizing
4283     (when (catch 'found
4284             (let ((types gnus-unbuttonized-mime-types))
4285               (while types
4286                 (when (string-match (pop types) type)
4287                   (throw 'found t)))))
4288       (not (catch 'found
4289              (let ((types gnus-buttonized-mime-types))
4290                (while types
4291                  (when (string-match (pop types) type)
4292                    (throw 'found t)))))))))
4293
4294 (defun gnus-article-insert-newline ()
4295   "Insert a newline, but mark it as undeletable."
4296   (gnus-put-text-property
4297    (point) (progn (insert "\n") (point)) 'gnus-undeletable t))
4298
4299 (defun gnus-mime-display-alternative (handles &optional preferred ibegend id)
4300   (let* ((preferred (or preferred (mm-preferred-alternative handles)))
4301          (ihandles handles)
4302          (point (point))
4303          handle buffer-read-only from props begend not-pref)
4304     (save-window-excursion
4305       (save-restriction
4306         (when ibegend
4307           (narrow-to-region (car ibegend)
4308                             (or (cdr ibegend)
4309                                 (progn
4310                                   (goto-char (car ibegend))
4311                                   (forward-line 2)
4312                                   (point))))
4313           (delete-region (point-min) (point-max))
4314           (mm-remove-parts handles))
4315         (setq begend (list (point-marker)))
4316         ;; Do the toggle.
4317         (unless (setq not-pref (cadr (member preferred ihandles)))
4318           (setq not-pref (car ihandles)))
4319         (when (or ibegend
4320                   (not preferred)
4321                   (not (gnus-unbuttonized-mime-type-p
4322                         "multipart/alternative")))
4323           (gnus-add-text-properties
4324            (setq from (point))
4325            (progn
4326              (insert (format "%d.  " id))
4327              (point))
4328            `(gnus-callback
4329              (lambda (handles)
4330                (unless ,(not ibegend)
4331                  (setq gnus-article-mime-handle-alist
4332                        ',gnus-article-mime-handle-alist))
4333                (gnus-mime-display-alternative
4334                 ',ihandles ',not-pref ',begend ,id))
4335              ,@(gnus-local-map-property gnus-mime-button-map)
4336              ,gnus-mouse-face-prop ,gnus-article-mouse-face
4337              face ,gnus-article-button-face
4338              gnus-part ,id
4339              gnus-data ,handle))
4340           (widget-convert-button 'link from (point)
4341                                  :action 'gnus-widget-press-button
4342                                  :button-keymap gnus-widget-button-keymap)
4343           ;; Do the handles
4344           (while (setq handle (pop handles))
4345             (gnus-add-text-properties
4346              (setq from (point))
4347              (progn
4348                (insert (format "(%c) %-18s"
4349                                (if (equal handle preferred) ?* ? )
4350                                (mm-handle-media-type handle)))
4351                (point))
4352              `(gnus-callback
4353                (lambda (handles)
4354                  (unless ,(not ibegend)
4355                    (setq gnus-article-mime-handle-alist
4356                          ',gnus-article-mime-handle-alist))
4357                  (gnus-mime-display-alternative
4358                   ',ihandles ',handle ',begend ,id))
4359                ,@(gnus-local-map-property gnus-mime-button-map)
4360                ,gnus-mouse-face-prop ,gnus-article-mouse-face
4361                face ,gnus-article-button-face
4362                gnus-part ,id
4363                gnus-data ,handle))
4364             (widget-convert-button 'link from (point)
4365                                    :action 'gnus-widget-press-button
4366                                    :button-keymap gnus-widget-button-keymap)
4367             (insert "  "))
4368           (insert "\n\n"))
4369         (when preferred
4370           (if (stringp (car preferred))
4371               (gnus-display-mime preferred)
4372             (let ((mail-parse-charset gnus-newsgroup-charset)
4373                   (mail-parse-ignored-charsets
4374                    (save-excursion (set-buffer gnus-summary-buffer)
4375                                    gnus-newsgroup-ignored-charsets)))
4376               (mm-display-part preferred)
4377               ;; Do highlighting.
4378               (save-excursion
4379                 (save-restriction
4380                   (narrow-to-region (car begend) (point-max))
4381                   (gnus-treat-article
4382                    nil (length gnus-article-mime-handle-alist)
4383                    (gnus-article-mime-total-parts)
4384                    (mm-handle-media-type handle))))))
4385           (goto-char (point-max))
4386           (setcdr begend (point-marker)))))
4387     (when ibegend
4388       (goto-char point))))
4389
4390 (defconst gnus-article-wash-status-strings
4391   (let ((alist '((cite "c" "Possible hidden citation text"
4392                        " " "All citation text visible")
4393                  (headers "h" "Hidden headers"
4394                           " " "All headers visible.")
4395                  (pgp "p" "Encrypted or signed message status hidden"
4396                       " " "No hidden encryption nor digital signature status")
4397                  (signature "s" "Signature has been hidden"
4398                             " " "Signature is visible")
4399                  (overstrike "o" "Overstrike (^H) characters applied"
4400                              " " "No overstrike characters applied")
4401                  (emphasis "e" "/*_Emphasis_*/ characters applied"
4402                            " " "No /*_emphasis_*/ characters applied")))
4403         result)
4404     (dolist (entry alist result)
4405       (let ((key (nth 0 entry))
4406             (on (copy-sequence (nth 1 entry)))
4407             (on-help (nth 2 entry))
4408             (off (copy-sequence (nth 3 entry)))
4409             (off-help (nth 4 entry)))
4410         (put-text-property 0 1 'help-echo on-help on)
4411         (put-text-property 0 1 'help-echo off-help off)
4412         (push (list key on off) result))))
4413   "Alist of strings describing wash status in the mode line.
4414 Each entry has the form (KEY ON OF), where the KEY is a symbol
4415 representing the particular washing function, ON is the string to use
4416 in the article mode line when the washing function is active, and OFF
4417 is the string to use when it is inactive.")
4418
4419 (defun gnus-article-wash-status-entry (key value)
4420   (let ((entry (assoc key gnus-article-wash-status-strings)))
4421     (if value (nth 1 entry) (nth 2 entry))))
4422
4423 (defun gnus-article-wash-status ()
4424   "Return a string which display status of article washing."
4425   (save-excursion
4426     (set-buffer gnus-article-buffer)
4427     (let ((cite (memq 'cite gnus-article-wash-types))
4428           (headers (memq 'headers gnus-article-wash-types))
4429           (boring (memq 'boring-headers gnus-article-wash-types))
4430           (pgp (memq 'pgp gnus-article-wash-types))
4431           (pem (memq 'pem gnus-article-wash-types))
4432           (signed (memq 'signed gnus-article-wash-types))
4433           (encrypted (memq 'encrypted gnus-article-wash-types))
4434           (signature (memq 'signature gnus-article-wash-types))
4435           (overstrike (memq 'overstrike gnus-article-wash-types))
4436           (emphasis (memq 'emphasis gnus-article-wash-types)))
4437       (concat
4438        (gnus-article-wash-status-entry 'cite cite)
4439        (gnus-article-wash-status-entry 'headers (or headers boring))
4440        (gnus-article-wash-status-entry 'pgp (or pgp pem signed encrypted))
4441        (gnus-article-wash-status-entry 'signature signature)
4442        (gnus-article-wash-status-entry 'overstrike overstrike)
4443        (gnus-article-wash-status-entry 'emphasis emphasis)))))
4444
4445 (defun gnus-add-wash-type (type)
4446   "Add a washing of TYPE to the current status."
4447   (add-to-list 'gnus-article-wash-types type))
4448
4449 (defun gnus-delete-wash-type (type)
4450   "Add a washing of TYPE to the current status."
4451   (setq gnus-article-wash-types (delq type gnus-article-wash-types)))
4452
4453 (defun gnus-add-image (category image)
4454   "Add IMAGE of CATEGORY to the list of displayed images."
4455   (let ((entry (assq category gnus-article-image-alist)))
4456     (unless entry
4457       (setq entry (list category))
4458       (push entry gnus-article-image-alist))
4459     (nconc entry (list image))))
4460
4461 (defun gnus-delete-images (category)
4462   "Delete all images in CATEGORY."
4463   (let ((entry (assq category gnus-article-image-alist)))
4464     (dolist (image (cdr entry))
4465       (gnus-remove-image image))
4466     (setq gnus-article-image-alist (delq entry gnus-article-image-alist))
4467     (gnus-delete-wash-type category)))
4468
4469 (defalias 'gnus-article-hide-headers-if-wanted 'gnus-article-maybe-hide-headers)
4470
4471 (defun gnus-article-maybe-hide-headers ()
4472   "Hide unwanted headers if `gnus-have-all-headers' is nil.
4473 Provided for backwards compatibility."
4474   (when (and (or (not (gnus-buffer-live-p gnus-summary-buffer))
4475                  (not (save-excursion (set-buffer gnus-summary-buffer)
4476                                       gnus-have-all-headers)))
4477              (not gnus-inhibit-hiding))
4478     (gnus-article-hide-headers)))
4479
4480 ;;; Article savers.
4481
4482 (defun gnus-output-to-file (file-name)
4483   "Append the current article to a file named FILE-NAME."
4484   (let ((artbuf (current-buffer)))
4485     (with-temp-buffer
4486       (insert-buffer-substring artbuf)
4487       ;; Append newline at end of the buffer as separator, and then
4488       ;; save it to file.
4489       (goto-char (point-max))
4490       (insert "\n")
4491       (let ((file-name-coding-system nnmail-pathname-coding-system))
4492         (mm-append-to-file (point-min) (point-max) file-name))
4493       t)))
4494
4495 (defun gnus-narrow-to-page (&optional arg)
4496   "Narrow the article buffer to a page.
4497 If given a numerical ARG, move forward ARG pages."
4498   (interactive "P")
4499   (setq arg (if arg (prefix-numeric-value arg) 0))
4500   (save-excursion
4501     (set-buffer gnus-article-buffer)
4502     (goto-char (point-min))
4503     (widen)
4504     ;; Remove any old next/prev buttons.
4505     (when (gnus-visual-p 'page-marker)
4506       (let ((buffer-read-only nil))
4507         (gnus-remove-text-with-property 'gnus-prev)
4508         (gnus-remove-text-with-property 'gnus-next)))
4509     (when
4510         (cond ((< arg 0)
4511                (re-search-backward page-delimiter nil 'move (1+ (abs arg))))
4512               ((> arg 0)
4513                (re-search-forward page-delimiter nil 'move arg)))
4514       (goto-char (match-end 0)))
4515     (narrow-to-region
4516      (point)
4517      (if (re-search-forward page-delimiter nil 'move)
4518          (match-beginning 0)
4519        (point)))
4520     (when (and (gnus-visual-p 'page-marker)
4521                (not (= (point-min) 1)))
4522       (save-excursion
4523         (goto-char (point-min))
4524         (gnus-insert-prev-page-button)))
4525     (when (and (gnus-visual-p 'page-marker)
4526                (< (+ (point-max) 2) (buffer-size)))
4527       (save-excursion
4528         (goto-char (point-max))
4529         (gnus-insert-next-page-button)))))
4530
4531 ;; Article mode commands
4532
4533 (defun gnus-article-goto-next-page ()
4534   "Show the next page of the article."
4535   (interactive)
4536   (when (gnus-article-next-page)
4537     (goto-char (point-min))
4538     (gnus-article-read-summary-keys nil (gnus-character-to-event ?n))))
4539
4540 (defun gnus-article-goto-prev-page ()
4541   "Show the next page of the article."
4542   (interactive)
4543   (if (bobp) (gnus-article-read-summary-keys nil (gnus-character-to-event ?p))
4544     (gnus-article-prev-page nil)))
4545
4546 (defun gnus-article-next-page (&optional lines)
4547   "Show the next page of the current article.
4548 If end of article, return non-nil.  Otherwise return nil.
4549 Argument LINES specifies lines to be scrolled up."
4550   (interactive "p")
4551   (move-to-window-line -1)
4552   (if (save-excursion
4553         (end-of-line)
4554         (and (pos-visible-in-window-p)  ;Not continuation line.
4555              (eobp)))
4556       ;; Nothing in this page.
4557       (if (or (not gnus-page-broken)
4558               (save-excursion
4559                 (save-restriction
4560                   (widen) (forward-line 1) (eobp)))) ;Real end-of-buffer?
4561           t                             ;Nothing more.
4562         (gnus-narrow-to-page 1)         ;Go to next page.
4563         nil)
4564     ;; More in this page.
4565     (let ((scroll-in-place nil))
4566       (condition-case ()
4567           (scroll-up lines)
4568         (end-of-buffer
4569          ;; Long lines may cause an end-of-buffer error.
4570          (goto-char (point-max)))))
4571     (move-to-window-line 0)
4572     nil))
4573
4574 (defun gnus-article-prev-page (&optional lines)
4575   "Show previous page of current article.
4576 Argument LINES specifies lines to be scrolled down."
4577   (interactive "p")
4578   (move-to-window-line 0)
4579   (if (and gnus-page-broken
4580            (bobp)
4581            (not (save-restriction (widen) (bobp)))) ;Real beginning-of-buffer?
4582       (progn
4583         (gnus-narrow-to-page -1)        ;Go to previous page.
4584         (goto-char (point-max))
4585         (recenter -1))
4586     (let ((scroll-in-place nil))
4587       (prog1
4588           (condition-case ()
4589               (scroll-down lines)
4590             (beginning-of-buffer
4591              (goto-char (point-min))))
4592         (move-to-window-line 0)))))
4593
4594 (defun gnus-article-refer-article ()
4595   "Read article specified by message-id around point."
4596   (interactive)
4597   (let ((point (point)))
4598     (search-forward ">" nil t)          ;Move point to end of "<....>".
4599     (if (re-search-backward "\\(<[^<> \t\n]+>\\)" nil t)
4600         (let ((message-id (match-string 1)))
4601           (goto-char point)
4602           (set-buffer gnus-summary-buffer)
4603           (gnus-summary-refer-article message-id))
4604       (goto-char (point))
4605       (error "No references around point"))))
4606
4607 (defun gnus-article-show-summary ()
4608   "Reconfigure windows to show summary buffer."
4609   (interactive)
4610   (if (not (gnus-buffer-live-p gnus-summary-buffer))
4611       (error "There is no summary buffer for this article buffer")
4612     (gnus-article-set-globals)
4613     (gnus-configure-windows 'article)
4614     (gnus-summary-goto-subject gnus-current-article)
4615     (gnus-summary-position-point)))
4616
4617 (defun gnus-article-describe-briefly ()
4618   "Describe article mode commands briefly."
4619   (interactive)
4620   (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")))
4621
4622 (defun gnus-article-summary-command ()
4623   "Execute the last keystroke in the summary buffer."
4624   (interactive)
4625   (let ((obuf (current-buffer))
4626         (owin (current-window-configuration))
4627         func)
4628     (switch-to-buffer gnus-article-current-summary 'norecord)
4629     (setq func (lookup-key (current-local-map) (this-command-keys)))
4630     (call-interactively func)
4631     (set-buffer obuf)
4632     (set-window-configuration owin)
4633     (set-window-point (get-buffer-window (current-buffer)) (point))))
4634
4635 (defun gnus-article-summary-command-nosave ()
4636   "Execute the last keystroke in the summary buffer."
4637   (interactive)
4638   (let (func)
4639     (pop-to-buffer gnus-article-current-summary 'norecord)
4640     (setq func (lookup-key (current-local-map) (this-command-keys)))
4641     (call-interactively func)))
4642
4643 (defun gnus-article-check-buffer ()
4644   "Beep if not in an article buffer."
4645   (unless (equal major-mode 'gnus-article-mode)
4646     (error "Command invoked outside of a Gnus article buffer")))
4647
4648 (defun gnus-article-read-summary-keys (&optional arg key not-restore-window)
4649   "Read a summary buffer key sequence and execute it from the article buffer."
4650   (interactive "P")
4651   (gnus-article-check-buffer)
4652   (let ((nosaves
4653          '("q" "Q"  "c" "r" "\C-c\C-f" "m"  "a" "f"
4654            "Zc" "ZC" "ZE" "ZQ" "ZZ" "Zn" "ZR" "ZG" "ZN" "ZP"
4655            "=" "^" "\M-^" "|"))
4656         (nosave-but-article
4657          '("A\r"))
4658         (nosave-in-article
4659          '("\C-d"))
4660         (up-to-top
4661          '("n" "Gn" "p" "Gp"))
4662         keys new-sum-point)
4663     (save-excursion
4664       (set-buffer gnus-article-current-summary)
4665       (let (gnus-pick-mode)
4666         (push (or key last-command-event) unread-command-events)
4667         (setq keys (if (featurep 'xemacs)
4668                        (events-to-keys (read-key-sequence nil))
4669                      (read-key-sequence nil)))))
4670
4671     (message "")
4672
4673     (if (or (member keys nosaves)
4674             (member keys nosave-but-article)
4675             (member keys nosave-in-article))
4676         (let (func)
4677           (save-window-excursion
4678             (pop-to-buffer gnus-article-current-summary 'norecord)
4679             ;; We disable the pick minor mode commands.
4680             (let (gnus-pick-mode)
4681               (setq func (lookup-key (current-local-map) keys))))
4682           (if (or (not func)
4683                   (numberp func))
4684               (ding)
4685             (unless (member keys nosave-in-article)
4686               (set-buffer gnus-article-current-summary))
4687             (call-interactively func)
4688             (setq new-sum-point (point)))
4689           (when (member keys nosave-but-article)
4690             (pop-to-buffer gnus-article-buffer 'norecord)))
4691       ;; These commands should restore window configuration.
4692       (let ((obuf (current-buffer))
4693             (owin (current-window-configuration))
4694             (opoint (point))
4695             (summary gnus-article-current-summary)
4696             func in-buffer selected)
4697         (if not-restore-window
4698             (pop-to-buffer summary 'norecord)
4699           (switch-to-buffer summary 'norecord))
4700         (setq in-buffer (current-buffer))
4701         ;; We disable the pick minor mode commands.
4702         (if (and (setq func (let (gnus-pick-mode)
4703                               (lookup-key (current-local-map) keys)))
4704                  (functionp func))
4705             (progn
4706               (call-interactively func)
4707               (setq new-sum-point (point))
4708               (when (eq in-buffer (current-buffer))
4709                 (setq selected (gnus-summary-select-article))
4710                 (set-buffer obuf)
4711                 (unless not-restore-window
4712                   (set-window-configuration owin))
4713                 (when (eq selected 'old)
4714                   (article-goto-body)
4715                   (set-window-start (get-buffer-window (current-buffer))
4716                                     1)
4717                   (set-window-point (get-buffer-window (current-buffer))
4718                                     (point)))
4719                 (let ((win (get-buffer-window gnus-article-current-summary)))
4720                   (when win
4721                     (set-window-point win new-sum-point))))    )
4722           (switch-to-buffer gnus-article-buffer)
4723           (ding))))))
4724
4725 (defun gnus-article-describe-key (key)
4726   "Display documentation of the function invoked by KEY.  KEY is a string."
4727   (interactive "kDescribe key: ")
4728   (gnus-article-check-buffer)
4729   (if (eq (key-binding key) 'gnus-article-read-summary-keys)
4730       (save-excursion
4731         (set-buffer gnus-article-current-summary)
4732         (let (gnus-pick-mode)
4733           (if (featurep 'xemacs)
4734               (progn
4735                 (push (elt key 0) unread-command-events)
4736                 (setq key (events-to-keys
4737                            (read-key-sequence "Describe key: "))))
4738             (setq unread-command-events
4739                   (mapcar
4740                    (lambda (x) (if (>= x 128) (list 'meta (- x 128)) x))
4741                    (string-to-list key)))
4742             (setq key (read-key-sequence "Describe key: "))))
4743         (describe-key key))
4744     (describe-key key)))
4745
4746 (defun gnus-article-describe-key-briefly (key &optional insert)
4747   "Display documentation of the function invoked by KEY.  KEY is a string."
4748   (interactive "kDescribe key: \nP")
4749   (gnus-article-check-buffer)
4750   (if (eq (key-binding key) 'gnus-article-read-summary-keys)
4751       (save-excursion
4752         (set-buffer gnus-article-current-summary)
4753         (let (gnus-pick-mode)
4754           (if (featurep 'xemacs)
4755               (progn
4756                 (push (elt key 0) unread-command-events)
4757                 (setq key (events-to-keys
4758                            (read-key-sequence "Describe key: "))))
4759             (setq unread-command-events
4760                   (mapcar
4761                    (lambda (x) (if (>= x 128) (list 'meta (- x 128)) x))
4762                    (string-to-list key)))
4763             (setq key (read-key-sequence "Describe key: "))))
4764         (describe-key-briefly key insert))
4765     (describe-key-briefly key insert)))
4766
4767 (defun gnus-article-reply-with-original (&optional wide)
4768   "Start composing a reply mail to the current message.
4769 The text in the region will be yanked.  If the region isn't active,
4770 the entire article will be yanked."
4771   (interactive "P")
4772   (let ((article (cdr gnus-article-current)) cont)
4773     (if (not (mark t))
4774         (gnus-summary-reply (list (list article)) wide)
4775       (setq cont (buffer-substring (point) (mark t)))
4776       ;; Deactivate active regions.
4777       (when (and (boundp 'transient-mark-mode)
4778                  transient-mark-mode)
4779         (setq mark-active nil))
4780       (gnus-summary-reply
4781        (list (list article cont)) wide))))
4782
4783 (defun gnus-article-followup-with-original ()
4784   "Compose a followup to the current article.
4785 The text in the region will be yanked.  If the region isn't active,
4786 the entire article will be yanked."
4787   (interactive)
4788   (let ((article (cdr gnus-article-current))
4789         cont)
4790     (if (not (mark t))
4791         (gnus-summary-followup (list (list article)))
4792       (setq cont (buffer-substring (point) (mark t)))
4793       ;; Deactivate active regions.
4794       (when (and (boundp 'transient-mark-mode)
4795                  transient-mark-mode)
4796         (setq mark-active nil))
4797       (gnus-summary-followup
4798        (list (list article cont))))))
4799
4800 (defun gnus-article-hide (&optional arg force)
4801   "Hide all the gruft in the current article.
4802 This means that PGP stuff, signatures, cited text and (some)
4803 headers will be hidden.
4804 If given a prefix, show the hidden text instead."
4805   (interactive (append (gnus-article-hidden-arg) (list 'force)))
4806   (gnus-article-hide-headers arg)
4807   (gnus-article-hide-list-identifiers arg)
4808   (gnus-article-hide-pgp arg)
4809   (gnus-article-hide-citation-maybe arg force)
4810   (gnus-article-hide-signature arg))
4811
4812 (defun gnus-article-maybe-highlight ()
4813   "Do some article highlighting if article highlighting is requested."
4814   (when (gnus-visual-p 'article-highlight 'highlight)
4815     (gnus-article-highlight-some)))
4816
4817 (defun gnus-check-group-server ()
4818   ;; Make sure the connection to the server is alive.
4819   (unless (gnus-server-opened
4820            (gnus-find-method-for-group gnus-newsgroup-name))
4821     (gnus-check-server (gnus-find-method-for-group gnus-newsgroup-name))
4822     (gnus-request-group gnus-newsgroup-name t)))
4823
4824 (eval-when-compile
4825   (autoload 'nneething-get-file-name "nneething"))
4826
4827 (defun gnus-request-article-this-buffer (article group)
4828   "Get an article and insert it into this buffer."
4829   (let (do-update-line sparse-header)
4830     (prog1
4831         (save-excursion
4832           (erase-buffer)
4833           (gnus-kill-all-overlays)
4834           (setq group (or group gnus-newsgroup-name))
4835
4836           ;; Using `gnus-request-article' directly will insert the article into
4837           ;; `nntp-server-buffer' - so we'll save some time by not having to
4838           ;; copy it from the server buffer into the article buffer.
4839
4840           ;; We only request an article by message-id when we do not have the
4841           ;; headers for it, so we'll have to get those.
4842           (when (stringp article)
4843             (gnus-read-header article))
4844
4845           ;; If the article number is negative, that means that this article
4846           ;; doesn't belong in this newsgroup (possibly), so we find its
4847           ;; message-id and request it by id instead of number.
4848           (when (and (numberp article)
4849                      gnus-summary-buffer
4850                      (get-buffer gnus-summary-buffer)
4851                      (gnus-buffer-exists-p gnus-summary-buffer))
4852             (save-excursion
4853               (set-buffer gnus-summary-buffer)
4854               (let ((header (gnus-summary-article-header article)))
4855                 (when (< article 0)
4856                   (cond
4857                    ((memq article gnus-newsgroup-sparse)
4858                     ;; This is a sparse gap article.
4859                     (setq do-update-line article)
4860                     (setq article (mail-header-id header))
4861                     (setq sparse-header (gnus-read-header article))
4862                     (setq gnus-newsgroup-sparse
4863                           (delq article gnus-newsgroup-sparse)))
4864                    ((vectorp header)
4865                     ;; It's a real article.
4866                     (setq article (mail-header-id header)))
4867                    (t
4868                     ;; It is an extracted pseudo-article.
4869                     (setq article 'pseudo)
4870                     (gnus-request-pseudo-article header))))
4871
4872                 (let ((method (gnus-find-method-for-group
4873                                gnus-newsgroup-name)))
4874                   (when (and (eq (car method) 'nneething)
4875                              (vectorp header))
4876                     (let ((dir (nneething-get-file-name
4877                                 (mail-header-id header))))
4878                       (when (and (stringp dir)
4879                                  (file-directory-p dir))
4880                         (setq article 'nneething)
4881                         (gnus-group-enter-directory dir))))))))
4882
4883           (cond
4884            ;; Refuse to select canceled articles.
4885            ((and (numberp article)
4886                  gnus-summary-buffer
4887                  (get-buffer gnus-summary-buffer)
4888                  (gnus-buffer-exists-p gnus-summary-buffer)
4889                  (eq (cdr (save-excursion
4890                             (set-buffer gnus-summary-buffer)
4891                             (assq article gnus-newsgroup-reads)))
4892                      gnus-canceled-mark))
4893             nil)
4894            ;; We first check `gnus-original-article-buffer'.
4895            ((and (get-buffer gnus-original-article-buffer)
4896                  (numberp article)
4897                  (save-excursion
4898                    (set-buffer gnus-original-article-buffer)
4899                    (and (equal (car gnus-original-article) group)
4900                         (eq (cdr gnus-original-article) article))))
4901             (insert-buffer-substring gnus-original-article-buffer)
4902             'article)
4903            ;; Check the backlog.
4904            ((and gnus-keep-backlog
4905                  (gnus-backlog-request-article group article (current-buffer)))
4906             'article)
4907            ;; Check asynchronous pre-fetch.
4908            ((gnus-async-request-fetched-article group article (current-buffer))
4909             (gnus-async-prefetch-next group article gnus-summary-buffer)
4910             (when (and (numberp article) gnus-keep-backlog)
4911               (gnus-backlog-enter-article group article (current-buffer)))
4912             'article)
4913            ;; Check the cache.
4914            ((and gnus-use-cache
4915                  (numberp article)
4916                  (gnus-cache-request-article article group))
4917             'article)
4918            ;; Check the agent cache.
4919            ((and gnus-agent gnus-agent-cache gnus-plugged
4920                  (numberp article)
4921                  (gnus-agent-request-article article group))
4922             'article)
4923            ;; Get the article and put into the article buffer.
4924            ((or (stringp article)
4925                 (numberp article))
4926             (let ((gnus-override-method gnus-override-method)
4927                   (methods (and (stringp article)
4928                                 gnus-refer-article-method))
4929                   result
4930                   (buffer-read-only nil))
4931               (if (or (not (listp methods))
4932                       (and (symbolp (car methods))
4933                            (assq (car methods) nnoo-definition-alist)))
4934                   (setq methods (list methods)))
4935               (when (and (null gnus-override-method)
4936                          methods)
4937                 (setq gnus-override-method (pop methods)))
4938               (while (not result)
4939                 (when (eq gnus-override-method 'current)
4940                   (setq gnus-override-method
4941                         (with-current-buffer gnus-summary-buffer
4942                           gnus-current-select-method)))
4943                 (erase-buffer)
4944                 (gnus-kill-all-overlays)
4945                 (let ((gnus-newsgroup-name group))
4946                   (gnus-check-group-server))
4947                 (when (gnus-request-article article group (current-buffer))
4948                   (when (numberp article)
4949                     (gnus-async-prefetch-next group article
4950                                               gnus-summary-buffer)
4951                     (when gnus-keep-backlog
4952                       (gnus-backlog-enter-article
4953                        group article (current-buffer))))
4954                   (setq result 'article))
4955                 (if (not result)
4956                     (if methods
4957                         (setq gnus-override-method (pop methods))
4958                       (setq result 'done))))
4959               (and (eq result 'article) 'article)))
4960            ;; It was a pseudo.
4961            (t article)))
4962
4963       ;; Associate this article with the current summary buffer.
4964       (setq gnus-article-current-summary gnus-summary-buffer)
4965
4966       ;; Take the article from the original article buffer
4967       ;; and place it in the buffer it's supposed to be in.
4968       (when (and (get-buffer gnus-article-buffer)
4969                  (equal (buffer-name (current-buffer))
4970                         (buffer-name (get-buffer gnus-article-buffer))))
4971         (save-excursion
4972           (if (get-buffer gnus-original-article-buffer)
4973               (set-buffer gnus-original-article-buffer)
4974             (set-buffer (gnus-get-buffer-create gnus-original-article-buffer))
4975             (buffer-disable-undo)
4976             (setq major-mode 'gnus-original-article-mode)
4977             (setq buffer-read-only t))
4978           (let (buffer-read-only)
4979             (erase-buffer)
4980             (insert-buffer-substring gnus-article-buffer))
4981           (setq gnus-original-article (cons group article)))
4982
4983         ;; Decode charsets.
4984         (run-hooks 'gnus-article-decode-hook)
4985         ;; Mark article as decoded or not.
4986         (setq gnus-article-decoded-p gnus-article-decode-hook))
4987
4988       ;; Update sparse articles.
4989       (when (and do-update-line
4990                  (or (numberp article)
4991                      (stringp article)))
4992         (let ((buf (current-buffer)))
4993           (set-buffer gnus-summary-buffer)
4994           (gnus-summary-update-article do-update-line sparse-header)
4995           (gnus-summary-goto-subject do-update-line nil t)
4996           (set-window-point (gnus-get-buffer-window (current-buffer) t)
4997                             (point))
4998           (set-buffer buf))))))
4999
5000 ;;;
5001 ;;; Article editing
5002 ;;;
5003
5004 (defcustom gnus-article-edit-mode-hook nil
5005   "Hook run in article edit mode buffers."
5006   :group 'gnus-article-various
5007   :type 'hook)
5008
5009 (defvar gnus-article-edit-done-function nil)
5010
5011 (defvar gnus-article-edit-mode-map nil)
5012
5013 ;; Should we be using derived.el for this?
5014 (unless gnus-article-edit-mode-map
5015   (setq gnus-article-edit-mode-map (make-keymap))
5016   (set-keymap-parent gnus-article-edit-mode-map text-mode-map)
5017
5018
5019   (gnus-define-keys gnus-article-edit-mode-map
5020     "\C-c?"    describe-mode
5021     "\C-c\C-c" gnus-article-edit-done
5022     "\C-c\C-k" gnus-article-edit-exit
5023     "\C-c\C-f\C-t" message-goto-to
5024     "\C-c\C-f\C-o" message-goto-from
5025     "\C-c\C-f\C-b" message-goto-bcc
5026     ;;"\C-c\C-f\C-w" message-goto-fcc
5027     "\C-c\C-f\C-c" message-goto-cc
5028     "\C-c\C-f\C-s" message-goto-subject
5029     "\C-c\C-f\C-r" message-goto-reply-to
5030     "\C-c\C-f\C-n" message-goto-newsgroups
5031     "\C-c\C-f\C-d" message-goto-distribution
5032     "\C-c\C-f\C-f" message-goto-followup-to
5033     "\C-c\C-f\C-m" message-goto-mail-followup-to
5034     "\C-c\C-f\C-k" message-goto-keywords
5035     "\C-c\C-f\C-u" message-goto-summary
5036     "\C-c\C-f\C-i" message-insert-or-toggle-importance
5037     "\C-c\C-f\C-a" message-gen-unsubscribed-mft
5038     "\C-c\C-b" message-goto-body
5039     "\C-c\C-i" message-goto-signature
5040
5041     "\C-c\C-t" message-insert-to
5042     "\C-c\C-n" message-insert-newsgroups
5043     "\C-c\C-o" message-sort-headers
5044     "\C-c\C-e" message-elide-region
5045     "\C-c\C-v" message-delete-not-region
5046     "\C-c\C-z" message-kill-to-signature
5047     "\M-\r" message-newline-and-reformat
5048     "\C-c\C-a" mml-attach-file
5049     "\C-a" message-beginning-of-line
5050     "\t" message-tab
5051     "\M-;" comment-region)
5052
5053   (gnus-define-keys (gnus-article-edit-wash-map
5054                      "\C-c\C-w" gnus-article-edit-mode-map)
5055     "f" gnus-article-edit-full-stops))
5056
5057 (easy-menu-define
5058   gnus-article-edit-mode-field-menu gnus-article-edit-mode-map ""
5059   '("Field"
5060     ["Fetch To" message-insert-to t]
5061     ["Fetch Newsgroups" message-insert-newsgroups t]
5062     "----"
5063     ["To" message-goto-to t]
5064     ["From" message-goto-from t]
5065     ["Subject" message-goto-subject t]
5066     ["Cc" message-goto-cc t]
5067     ["Reply-To" message-goto-reply-to t]
5068     ["Summary" message-goto-summary t]
5069     ["Keywords" message-goto-keywords t]
5070     ["Newsgroups" message-goto-newsgroups t]
5071     ["Followup-To" message-goto-followup-to t]
5072     ["Mail-Followup-To" message-goto-mail-followup-to t]
5073     ["Distribution" message-goto-distribution t]
5074     ["Body" message-goto-body t]
5075     ["Signature" message-goto-signature t]))
5076
5077 (define-derived-mode gnus-article-edit-mode text-mode "Article Edit"
5078   "Major mode for editing articles.
5079 This is an extended text-mode.
5080
5081 \\{gnus-article-edit-mode-map}"
5082   (make-local-variable 'gnus-article-edit-done-function)
5083   (make-local-variable 'gnus-prev-winconf)
5084   (set (make-local-variable 'font-lock-defaults)
5085        '(message-font-lock-keywords t))
5086   (set (make-local-variable 'mail-header-separator) "")
5087   (easy-menu-add message-mode-field-menu message-mode-map)
5088   (mml-mode)
5089   (setq buffer-read-only nil)
5090   (buffer-enable-undo)
5091   (widen))
5092
5093 (defun gnus-article-edit (&optional force)
5094   "Edit the current article.
5095 This will have permanent effect only in mail groups.
5096 If FORCE is non-nil, allow editing of articles even in read-only
5097 groups."
5098   (interactive "P")
5099   (when (and (not force)
5100              (gnus-group-read-only-p))
5101     (error "The current newsgroup does not support article editing"))
5102   (gnus-article-date-original)
5103   (gnus-article-edit-article
5104    'ignore
5105    `(lambda (no-highlight)
5106       'ignore
5107       (gnus-summary-edit-article-done
5108        ,(or (mail-header-references gnus-current-headers) "")
5109        ,(gnus-group-read-only-p) ,gnus-summary-buffer no-highlight))))
5110
5111 (defun gnus-article-edit-article (start-func exit-func)
5112   "Start editing the contents of the current article buffer."
5113   (let ((winconf (current-window-configuration)))
5114     (set-buffer gnus-article-buffer)
5115     (gnus-article-edit-mode)
5116     (funcall start-func)
5117     (set-buffer-modified-p nil)
5118     (gnus-configure-windows 'edit-article)
5119     (setq gnus-article-edit-done-function exit-func)
5120     (setq gnus-prev-winconf winconf)
5121     (gnus-message 6 "C-c C-c to end edits")))
5122
5123 (defun gnus-article-edit-done (&optional arg)
5124   "Update the article edits and exit."
5125   (interactive "P")
5126   (let ((func gnus-article-edit-done-function)
5127         (buf (current-buffer))
5128         (start (window-start))
5129         (p (point))
5130         (winconf gnus-prev-winconf))
5131     (funcall func arg)
5132     (set-buffer buf)
5133     ;; The cache and backlog have to be flushed somewhat.
5134     (when gnus-keep-backlog
5135       (gnus-backlog-remove-article
5136        (car gnus-article-current) (cdr gnus-article-current)))
5137     ;; Flush original article as well.
5138     (save-excursion
5139       (when (get-buffer gnus-original-article-buffer)
5140         (set-buffer gnus-original-article-buffer)
5141         (setq gnus-original-article nil)))
5142     (when gnus-use-cache
5143       (gnus-cache-update-article
5144        (car gnus-article-current) (cdr gnus-article-current)))
5145     ;; We remove all text props from the article buffer.
5146     (kill-all-local-variables)
5147     (gnus-set-text-properties (point-min) (point-max) nil)
5148     (gnus-article-mode)
5149     (set-window-configuration winconf)
5150     (set-buffer buf)
5151     (set-window-start (get-buffer-window buf) start)
5152     (set-window-point (get-buffer-window buf) (point))))
5153
5154 (defun gnus-article-edit-exit ()
5155   "Exit the article editing without updating."
5156   (interactive)
5157   (when (or (not (buffer-modified-p))
5158             (yes-or-no-p "Article modified; kill anyway? "))
5159     (let ((curbuf (current-buffer))
5160           (p (point))
5161           (window-start (window-start)))
5162       (erase-buffer)
5163       (if (gnus-buffer-live-p gnus-original-article-buffer)
5164           (insert-buffer gnus-original-article-buffer))
5165       (let ((winconf gnus-prev-winconf))
5166         (gnus-article-mode)
5167         (set-window-configuration winconf)
5168         ;; Tippy-toe some to make sure that point remains where it was.
5169         (save-current-buffer
5170           (set-buffer curbuf)
5171           (set-window-start (get-buffer-window (current-buffer)) window-start)
5172           (goto-char p))))))
5173
5174 (defun gnus-article-edit-full-stops ()
5175   "Interactively repair spacing at end of sentences."
5176   (interactive)
5177   (save-excursion
5178     (goto-char (point-min))
5179     (search-forward-regexp "^$" nil t)
5180     (let ((case-fold-search nil))
5181       (query-replace-regexp "\\([.!?][])}]* \\)\\([[({A-Z]\\)" "\\1 \\2"))))
5182
5183 ;;;
5184 ;;; Article highlights
5185 ;;;
5186
5187 ;; Written by Per Abrahamsen <abraham@iesd.auc.dk>.
5188
5189 ;;; Internal Variables:
5190
5191 (defcustom gnus-button-url-regexp "\\b\\(\\(www\\.\\|\\(s?https?\\|ftp\\|file\\|gopher\\|news\\|telnet\\|wais\\|mailto\\|info\\):\\)\\(//[-a-zA-Z0-9_.]+:[0-9]*\\)?\\([-a-zA-Z0-9_=!?#$@~`%&*+|\\/:;.,]\\|\\w\\)+\\([-a-zA-Z0-9_=#$@~`%&*+|\\/]\\|\\w\\)\\)"
5192   "Regular expression that matches URLs."
5193   :group 'gnus-article-buttons
5194   :type 'regexp)
5195
5196 (defcustom gnus-button-alist
5197   `(("<\\(url:[>\n\t ]*?\\)?\\(nntp\\|news\\):[>\n\t ]*\\([^>\n\t ]*@[^>\n\t ]*\\)>"
5198      0 t gnus-button-handle-news 3)
5199     ("\\b\\(nntp\\|news\\):\\([^>\n\t ]*@[^>)!;:,\n\t ]*\\)" 0 t
5200      gnus-button-handle-news 2)
5201     ("\\(\\b<\\(url:[>\n\t ]*\\)?news:[>\n\t ]*\\(//\\)?\\([^>\n\t ]*\\)>\\)"
5202      1 t
5203      gnus-button-fetch-group 4)
5204     ("\\bnews:\\(//\\)?\\([^'\">\n\t ]+\\)" 0 t gnus-button-fetch-group 2)
5205     ("\\bin\\( +article\\| +message\\)? +\\(<\\([^\n @<>]+@[^\n @<>]+\\)>\\)" 2
5206      t gnus-button-message-id 3)
5207     ("\\(<URL: *\\)mailto: *\\([^> \n\t]+\\)>" 0 t gnus-url-mailto 2)
5208     ("mailto:\\([-a-zA-Z.@_+0-9%=?]+\\)" 0 t gnus-url-mailto 1)
5209     ("\\bmailto:\\([^ \n\t]+\\)" 0 t gnus-url-mailto 1)
5210     ;; This is info
5211     ("\\binfo:\\(//\\)?\\([^'\">\n\t ]+\\)" 0 t
5212      gnus-button-handle-info 2)
5213     ;; This is how URLs _should_ be embedded in text...
5214     ("<URL: *\\([^<>]*\\)>" 1 t gnus-button-embedded-url 1)
5215     ;; Raw URLs.
5216     (,gnus-button-url-regexp 0 t browse-url 0))
5217   "*Alist of regexps matching buttons in article bodies.
5218
5219 Each entry has the form (REGEXP BUTTON FORM CALLBACK PAR...), where
5220 REGEXP: is the string matching text around the button,
5221 BUTTON: is the number of the regexp grouping actually matching the button,
5222 FORM: is a lisp expression which must eval to true for the button to
5223 be added,
5224 CALLBACK: is the function to call when the user push this button, and each
5225 PAR: is a number of a regexp grouping whose text will be passed to CALLBACK.
5226
5227 CALLBACK can also be a variable, in that case the value of that
5228 variable it the real callback function."
5229   :group 'gnus-article-buttons
5230   :type '(repeat (list regexp
5231                        (integer :tag "Button")
5232                        (sexp :tag "Form")
5233                        (function :tag "Callback")
5234                        (repeat :tag "Par"
5235                                :inline t
5236                                (integer :tag "Regexp group")))))
5237
5238 (defcustom gnus-header-button-alist
5239   `(("^\\(References\\|Message-I[Dd]\\):" "<[^<>]+>"
5240      0 t gnus-button-message-id 0)
5241     ("^\\(From\\|Reply-To\\):" ": *\\(.+\\)$" 1 t gnus-button-reply 1)
5242     ("^\\(Cc\\|To\\):" "[^ \t\n<>,()\"]+@[^ \t\n<>,()\"]+"
5243      0 t gnus-button-mailto 0)
5244     ("^X-[Uu][Rr][Ll]:" ,gnus-button-url-regexp 0 t browse-url 0)
5245     ("^Subject:" ,gnus-button-url-regexp 0 t browse-url 0)
5246     ("^[^:]+:" ,gnus-button-url-regexp 0 t browse-url 0)
5247     ("^[^:]+:" "\\bmailto:\\([-a-zA-Z.@_+0-9%=?]+\\)" 0 t gnus-url-mailto 1)
5248     ("^[^:]+:" "\\(<\\(url: \\)?news:\\([^>\n ]*\\)>\\)" 1 t
5249      gnus-button-message-id 3))
5250   "*Alist of headers and regexps to match buttons in article heads.
5251
5252 This alist is very similar to `gnus-button-alist', except that each
5253 alist has an additional HEADER element first in each entry:
5254
5255 \(HEADER REGEXP BUTTON FORM CALLBACK PAR)
5256
5257 HEADER is a regexp to match a header.  For a fuller explanation, see
5258 `gnus-button-alist'."
5259   :group 'gnus-article-buttons
5260   :group 'gnus-article-headers
5261   :type '(repeat (list (regexp :tag "Header")
5262                        regexp
5263                        (integer :tag "Button")
5264                        (sexp :tag "Form")
5265                        (function :tag "Callback")
5266                        (repeat :tag "Par"
5267                                :inline t
5268                                (integer :tag "Regexp group")))))
5269
5270 (defvar gnus-button-regexp nil)
5271 (defvar gnus-button-marker-list nil)
5272 ;; Regexp matching any of the regexps from `gnus-button-alist'.
5273
5274 (defvar gnus-button-last nil)
5275 ;; The value of `gnus-button-alist' when `gnus-button-regexp' was build.
5276
5277 ;;; Commands:
5278
5279 (defun gnus-article-push-button (event)
5280   "Check text under the mouse pointer for a callback function.
5281 If the text under the mouse pointer has a `gnus-callback' property,
5282 call it with the value of the `gnus-data' text property."
5283   (interactive "e")
5284   (set-buffer (window-buffer (posn-window (event-start event))))
5285   (let* ((pos (posn-point (event-start event)))
5286          (data (get-text-property pos 'gnus-data))
5287          (fun (get-text-property pos 'gnus-callback)))
5288     (goto-char pos)
5289     (when fun
5290       (funcall fun data))))
5291
5292 (defun gnus-article-press-button ()
5293   "Check text at point for a callback function.
5294 If the text at point has a `gnus-callback' property,
5295 call it with the value of the `gnus-data' text property."
5296   (interactive)
5297   (let* ((data (get-text-property (point) 'gnus-data))
5298          (fun (get-text-property (point) 'gnus-callback)))
5299     (when fun
5300       (funcall fun data))))
5301
5302 (defun gnus-article-highlight (&optional force)
5303   "Highlight current article.
5304 This function calls `gnus-article-highlight-headers',
5305 `gnus-article-highlight-citation',
5306 `gnus-article-highlight-signature', and `gnus-article-add-buttons' to
5307 do the highlighting.  See the documentation for those functions."
5308   (interactive (list 'force))
5309   (gnus-article-highlight-headers)
5310   (gnus-article-highlight-citation force)
5311   (gnus-article-highlight-signature)
5312   (gnus-article-add-buttons force)
5313   (gnus-article-add-buttons-to-head))
5314
5315 (defun gnus-article-highlight-some (&optional force)
5316   "Highlight current article.
5317 This function calls `gnus-article-highlight-headers',
5318 `gnus-article-highlight-signature', and `gnus-article-add-buttons' to
5319 do the highlighting.  See the documentation for those functions."
5320   (interactive (list 'force))
5321   (gnus-article-highlight-headers)
5322   (gnus-article-highlight-signature)
5323   (gnus-article-add-buttons))
5324
5325 (defun gnus-article-highlight-headers ()
5326   "Highlight article headers as specified by `gnus-header-face-alist'."
5327   (interactive)
5328   (save-excursion
5329     (set-buffer gnus-article-buffer)
5330     (save-restriction
5331       (let ((alist gnus-header-face-alist)
5332             (buffer-read-only nil)
5333             (case-fold-search t)
5334             (inhibit-point-motion-hooks t)
5335             entry regexp header-face field-face from hpoints fpoints)
5336         (article-narrow-to-head)
5337         (while (setq entry (pop alist))
5338           (goto-char (point-min))
5339           (setq regexp (concat "^\\("
5340                                (if (string-equal "" (nth 0 entry))
5341                                    "[^\t ]"
5342                                  (nth 0 entry))
5343                                "\\)")
5344                 header-face (nth 1 entry)
5345                 field-face (nth 2 entry))
5346           (while (and (re-search-forward regexp nil t)
5347                       (not (eobp)))
5348             (beginning-of-line)
5349             (setq from (point))
5350             (unless (search-forward ":" nil t)
5351               (forward-char 1))
5352             (when (and header-face
5353                        (not (memq (point) hpoints)))
5354               (push (point) hpoints)
5355               (gnus-put-text-property from (point) 'face header-face))
5356             (when (and field-face
5357                        (not (memq (setq from (point)) fpoints)))
5358               (push from fpoints)
5359               (if (re-search-forward "^[^ \t]" nil t)
5360                   (forward-char -2)
5361                 (goto-char (point-max)))
5362               (gnus-put-text-property from (point) 'face field-face))))))))
5363
5364 (defun gnus-article-highlight-signature ()
5365   "Highlight the signature in an article.
5366 It does this by highlighting everything after
5367 `gnus-signature-separator' using `gnus-signature-face'."
5368   (interactive)
5369   (save-excursion
5370     (set-buffer gnus-article-buffer)
5371     (let ((buffer-read-only nil)
5372           (inhibit-point-motion-hooks t))
5373       (save-restriction
5374         (when (and gnus-signature-face
5375                    (gnus-article-narrow-to-signature))
5376           (gnus-overlay-put (gnus-make-overlay (point-min) (point-max))
5377                             'face gnus-signature-face)
5378           (widen)
5379           (gnus-article-search-signature)
5380           (let ((start (match-beginning 0))
5381                 (end (set-marker (make-marker) (1+ (match-end 0)))))
5382             (gnus-article-add-button start (1- end) 'gnus-signature-toggle
5383                                      end)))))))
5384
5385 (defun gnus-button-in-region-p (b e prop)
5386   "Say whether PROP exists in the region."
5387   (text-property-not-all b e prop nil))
5388
5389 (defun gnus-article-add-buttons (&optional force)
5390   "Find external references in the article and make buttons of them.
5391 \"External references\" are things like Message-IDs and URLs, as
5392 specified by `gnus-button-alist'."
5393   (interactive (list 'force))
5394   (save-excursion
5395     (set-buffer gnus-article-buffer)
5396     (let ((buffer-read-only nil)
5397           (inhibit-point-motion-hooks t)
5398           (case-fold-search t)
5399           (alist gnus-button-alist)
5400           beg entry regexp)
5401       ;; Remove all old markers.
5402       (let (marker entry new-list)
5403         (while (setq marker (pop gnus-button-marker-list))
5404           (if (or (< marker (point-min)) (>= marker (point-max)))
5405               (push marker new-list)
5406             (goto-char marker)
5407             (when (setq entry (gnus-button-entry))
5408               (put-text-property (match-beginning (nth 1 entry))
5409                                  (match-end (nth 1 entry))
5410                                  'gnus-callback nil))
5411             (set-marker marker nil)))
5412         (setq gnus-button-marker-list new-list))
5413       ;; We skip the headers.
5414       (article-goto-body)
5415       (setq beg (point))
5416       (while (setq entry (pop alist))
5417         (setq regexp (car entry))
5418         (goto-char beg)
5419         (while (re-search-forward regexp nil t)
5420           (let* ((start (and entry (match-beginning (nth 1 entry))))
5421                  (end (and entry (match-end (nth 1 entry))))
5422                  (from (match-beginning 0)))
5423             (when (and (or (eq t (nth 2 entry))
5424                            (eval (nth 2 entry)))
5425                        (not (gnus-button-in-region-p
5426                              start end 'gnus-callback)))
5427               ;; That optional form returned non-nil, so we add the
5428               ;; button.
5429               (gnus-article-add-button
5430                start end 'gnus-button-push
5431                (car (push (set-marker (make-marker) from)
5432                           gnus-button-marker-list))))))))))
5433
5434 ;; Add buttons to the head of an article.
5435 (defun gnus-article-add-buttons-to-head ()
5436   "Add buttons to the head of the article."
5437   (interactive)
5438   (save-excursion
5439     (set-buffer gnus-article-buffer)
5440     (save-restriction
5441       (let ((buffer-read-only nil)
5442             (inhibit-point-motion-hooks t)
5443             (case-fold-search t)
5444             (alist gnus-header-button-alist)
5445             entry beg end)
5446         (article-narrow-to-head)
5447         (while alist
5448           ;; Each alist entry.
5449           (setq entry (car alist)
5450                 alist (cdr alist))
5451           (goto-char (point-min))
5452           (while (re-search-forward (car entry) nil t)
5453             ;; Each header matching the entry.
5454             (setq beg (match-beginning 0))
5455             (setq end (or (and (re-search-forward "^[^ \t]" nil t)
5456                                (match-beginning 0))
5457                           (point-max)))
5458             (goto-char beg)
5459             (while (re-search-forward (nth 1 entry) end t)
5460               ;; Each match within a header.
5461               (let* ((entry (cdr entry))
5462                      (start (match-beginning (nth 1 entry)))
5463                      (end (match-end (nth 1 entry)))
5464                      (form (nth 2 entry)))
5465                 (goto-char (match-end 0))
5466                 (when (eval form)
5467                   (gnus-article-add-button
5468                    start end (nth 3 entry)
5469                    (buffer-substring (match-beginning (nth 4 entry))
5470                                      (match-end (nth 4 entry)))))))
5471             (goto-char end)))))))
5472
5473 ;;; External functions:
5474
5475 (defun gnus-article-add-button (from to fun &optional data)
5476   "Create a button between FROM and TO with callback FUN and data DATA."
5477   (when gnus-article-button-face
5478     (gnus-overlay-put (gnus-make-overlay from to)
5479                       'face gnus-article-button-face))
5480   (gnus-add-text-properties
5481    from to
5482    (nconc (and gnus-article-mouse-face
5483                (list gnus-mouse-face-prop gnus-article-mouse-face))
5484           (list 'gnus-callback fun)
5485           (and data (list 'gnus-data data))))
5486   (widget-convert-button 'link from to :action 'gnus-widget-press-button
5487                          :button-keymap gnus-widget-button-keymap))
5488
5489 ;;; Internal functions:
5490
5491 (defun gnus-article-set-globals ()
5492   (save-excursion
5493     (set-buffer gnus-summary-buffer)
5494     (gnus-set-global-variables)))
5495
5496 (defun gnus-signature-toggle (end)
5497   (save-excursion
5498     (set-buffer gnus-article-buffer)
5499     (let ((buffer-read-only nil)
5500           (inhibit-point-motion-hooks t))
5501       (if (text-property-any end (point-max) 'article-type 'signature)
5502           (progn
5503             (gnus-delete-wash-type 'signature)
5504             (gnus-remove-text-properties-when
5505              'article-type 'signature end (point-max)
5506              (cons 'article-type (cons 'signature
5507                                        gnus-hidden-properties))))
5508         (gnus-add-wash-type 'signature)
5509         (gnus-add-text-properties-when
5510          'article-type nil end (point-max)
5511          (cons 'article-type (cons 'signature
5512                                    gnus-hidden-properties)))))
5513     (let ((gnus-article-mime-handle-alist-1 gnus-article-mime-handle-alist))
5514       (gnus-set-mode-line 'article))))
5515
5516 (defun gnus-button-entry ()
5517   ;; Return the first entry in `gnus-button-alist' matching this place.
5518   (let ((alist gnus-button-alist)
5519         (entry nil))
5520     (while alist
5521       (setq entry (pop alist))
5522       (if (looking-at (car entry))
5523           (setq alist nil)
5524         (setq entry nil)))
5525     entry))
5526
5527 (defun gnus-button-push (marker)
5528   ;; Push button starting at MARKER.
5529   (save-excursion
5530     (goto-char marker)
5531     (let* ((entry (gnus-button-entry))
5532            (inhibit-point-motion-hooks t)
5533            (fun (nth 3 entry))
5534            (args (mapcar (lambda (group)
5535                            (let ((string (match-string group)))
5536                              (gnus-set-text-properties
5537                               0 (length string) nil string)
5538                              string))
5539                          (nthcdr 4 entry))))
5540       (cond
5541        ((fboundp fun)
5542         (apply fun args))
5543        ((and (boundp fun)
5544              (fboundp (symbol-value fun)))
5545         (apply (symbol-value fun) args))
5546        (t
5547         (gnus-message 1 "You must define `%S' to use this button"
5548                       (cons fun args)))))))
5549
5550 (defun gnus-parse-news-url (url)
5551   (let (scheme server group message-id articles)
5552     (with-temp-buffer
5553       (insert url)
5554       (goto-char (point-min))
5555       (when (looking-at "\\([A-Za-z]+\\):")
5556         (setq scheme (match-string 1))
5557         (goto-char (match-end 0)))
5558       (when (looking-at "//\\([^/]+\\)/")
5559         (setq server (match-string 1))
5560         (goto-char (match-end 0)))
5561
5562       (cond
5563        ((looking-at "\\(.*@.*\\)")
5564         (setq message-id (match-string 1)))
5565        ((looking-at "\\([^/]+\\)/\\([-0-9]+\\)")
5566         (setq group (match-string 1)
5567               articles (split-string (match-string 2) "-")))
5568        ((looking-at "\\([^/]+\\)/?")
5569         (setq group (match-string 1)))
5570        (t
5571         (error "Unknown news URL syntax"))))
5572     (list scheme server group message-id articles)))
5573
5574 (defun gnus-button-handle-news (url)
5575   "Fetch a news URL."
5576   (destructuring-bind (scheme server group message-id articles)
5577       (gnus-parse-news-url url)
5578     (cond
5579      (message-id
5580       (save-excursion
5581         (set-buffer gnus-summary-buffer)
5582         (if server
5583             (let ((gnus-refer-article-method (list (list 'nntp server))))
5584               (gnus-summary-refer-article message-id))
5585           (gnus-summary-refer-article message-id))))
5586      (group
5587       (gnus-button-fetch-group url)))))
5588
5589 (defun gnus-button-handle-info (url)
5590   "Fetch an info URL."
5591   (if (string-match
5592        "^\\([^:/]+\\)?/\\(.*\\)"
5593        url)
5594       (gnus-info-find-node
5595        (concat "(" (or (gnus-url-unhex-string (match-string 1 url))
5596                        "Gnus")
5597                ")"
5598                (gnus-url-unhex-string (match-string 2 url))))
5599     (error "Can't parse %s" url)))
5600
5601 (defun gnus-button-message-id (message-id)
5602   "Fetch MESSAGE-ID."
5603   (save-excursion
5604     (set-buffer gnus-summary-buffer)
5605     (gnus-summary-refer-article message-id)))
5606
5607 (defun gnus-button-fetch-group (address)
5608   "Fetch GROUP specified by ADDRESS."
5609   (if (not (string-match "[:/]" address))
5610       ;; This is just a simple group url.
5611       (gnus-group-read-ephemeral-group address gnus-select-method)
5612     (if (not
5613          (string-match
5614           "^\\([^:/]+\\)\\(:\\([^/]+\\)\\)?/\\([^/]+\\)\\(/\\([0-9]+\\)\\)?"
5615           address))
5616         (error "Can't parse %s" address)
5617       (gnus-group-read-ephemeral-group
5618        (match-string 4 address)
5619        `(nntp ,(match-string 1 address)
5620               (nntp-address ,(match-string 1 address))
5621               (nntp-port-number ,(if (match-end 3)
5622                                      (match-string 3 address)
5623                                    "nntp")))
5624        nil nil nil
5625        (and (match-end 6) (list (string-to-int (match-string 6 address))))))))
5626
5627 (defun gnus-url-parse-query-string (query &optional downcase)
5628   (let (retval pairs cur key val)
5629     (setq pairs (split-string query "&"))
5630     (while pairs
5631       (setq cur (car pairs)
5632             pairs (cdr pairs))
5633       (if (not (string-match "=" cur))
5634           nil                           ; Grace
5635         (setq key (gnus-url-unhex-string (substring cur 0 (match-beginning 0)))
5636               val (gnus-url-unhex-string (substring cur (match-end 0) nil) t))
5637         (if downcase
5638             (setq key (downcase key)))
5639         (setq cur (assoc key retval))
5640         (if cur
5641             (setcdr cur (cons val (cdr cur)))
5642           (setq retval (cons (list key val) retval)))))
5643     retval))
5644
5645 (defun gnus-url-mailto (url)
5646   ;; Send mail to someone
5647   (when (string-match "mailto:/*\\(.*\\)" url)
5648     (setq url (substring url (match-beginning 1) nil)))
5649   (let (to args subject func)
5650     (if (string-match (regexp-quote "?") url)
5651         (setq to (gnus-url-unhex-string (substring url 0 (match-beginning 0)))
5652               args (gnus-url-parse-query-string
5653                     (substring url (match-end 0) nil) t))
5654       (setq to (gnus-url-unhex-string url)))
5655     (setq args (cons (list "to" to) args)
5656           subject (cdr-safe (assoc "subject" args)))
5657     (gnus-msg-mail)
5658     (while args
5659       (setq func (intern-soft (concat "message-goto-" (downcase (caar args)))))
5660       (if (fboundp func)
5661           (funcall func)
5662         (message-position-on-field (caar args)))
5663       (insert (mapconcat 'identity (cdar args) ", "))
5664       (setq args (cdr args)))
5665     (if subject
5666         (message-goto-body)
5667       (message-goto-subject))))
5668
5669 (defun gnus-button-embedded-url (address)
5670   "Activate ADDRESS with `browse-url'."
5671   (browse-url (gnus-strip-whitespace address)))
5672
5673 ;;; Next/prev buttons in the article buffer.
5674
5675 (defvar gnus-next-page-line-format "%{%(Next page...%)%}\n")
5676 (defvar gnus-prev-page-line-format "%{%(Previous page...%)%}\n")
5677
5678 (defvar gnus-prev-page-map
5679   (let ((map (make-sparse-keymap)))
5680     (unless (>= emacs-major-version 21)
5681       ;; XEmacs doesn't care.
5682       (set-keymap-parent map gnus-article-mode-map))
5683     (define-key map gnus-mouse-2 'gnus-button-prev-page)
5684     (define-key map "\r" 'gnus-button-prev-page)
5685     map))
5686
5687 (defun gnus-insert-prev-page-button ()
5688   (let ((b (point))
5689         (buffer-read-only nil))
5690     (gnus-eval-format
5691      gnus-prev-page-line-format nil
5692      `(,@(gnus-local-map-property gnus-prev-page-map)
5693          gnus-prev t
5694          gnus-callback gnus-article-button-prev-page
5695          article-type annotation))
5696     (widget-convert-button
5697      'link b (point)
5698      :action 'gnus-button-prev-page
5699      :button-keymap gnus-prev-page-map)))
5700
5701 (defvar gnus-prev-page-map
5702   (let ((map (make-sparse-keymap)))
5703     (unless (>= emacs-major-version 21)
5704       ;; XEmacs doesn't care.
5705       (set-keymap-parent map gnus-article-mode-map))
5706     (define-key map gnus-mouse-2 'gnus-button-prev-page)
5707     (define-key map "\r" 'gnus-button-prev-page)
5708     map))
5709
5710 (defvar gnus-next-page-map
5711   (let ((map (make-sparse-keymap)))
5712     (unless (>= emacs-major-version 21)
5713       ;; XEmacs doesn't care.
5714       (set-keymap-parent map gnus-article-mode-map))
5715     (define-key map gnus-mouse-2 'gnus-button-next-page)
5716     (define-key map "\r" 'gnus-button-next-page)
5717     map))
5718
5719 (defun gnus-button-next-page (&optional args more-args)
5720   "Go to the next page."
5721   (interactive)
5722   (let ((win (selected-window)))
5723     (select-window (gnus-get-buffer-window gnus-article-buffer t))
5724     (gnus-article-next-page)
5725     (select-window win)))
5726
5727 (defun gnus-button-prev-page (&optional args more-args)
5728   "Go to the prev page."
5729   (interactive)
5730   (let ((win (selected-window)))
5731     (select-window (gnus-get-buffer-window gnus-article-buffer t))
5732     (gnus-article-prev-page)
5733     (select-window win)))
5734
5735 (defun gnus-insert-next-page-button ()
5736   (let ((b (point))
5737         (buffer-read-only nil))
5738     (gnus-eval-format gnus-next-page-line-format nil
5739                       `(,@(gnus-local-map-property gnus-next-page-map)
5740                           gnus-next t
5741                           gnus-callback gnus-article-button-next-page
5742                           article-type annotation))
5743     (widget-convert-button
5744      'link b (point)
5745      :action 'gnus-button-next-page
5746      :button-keymap gnus-next-page-map)))
5747
5748 (defun gnus-article-button-next-page (arg)
5749   "Go to the next page."
5750   (interactive "P")
5751   (let ((win (selected-window)))
5752     (select-window (gnus-get-buffer-window gnus-article-buffer t))
5753     (gnus-article-next-page)
5754     (select-window win)))
5755
5756 (defun gnus-article-button-prev-page (arg)
5757   "Go to the prev page."
5758   (interactive "P")
5759   (let ((win (selected-window)))
5760     (select-window (gnus-get-buffer-window gnus-article-buffer t))
5761     (gnus-article-prev-page)
5762     (select-window win)))
5763
5764 (defvar gnus-decode-header-methods
5765   '(mail-decode-encoded-word-region)
5766   "List of methods used to decode headers.
5767
5768 This variable is a list of FUNCTION or (REGEXP . FUNCTION).  If item
5769 is FUNCTION, FUNCTION will be apply to all newsgroups.  If item is a
5770 (REGEXP . FUNCTION), FUNCTION will be only apply to thes newsgroups
5771 whose names match REGEXP.
5772
5773 For example:
5774 ((\"chinese\" . gnus-decode-encoded-word-region-by-guess)
5775  mail-decode-encoded-word-region
5776  (\"chinese\" . rfc1843-decode-region))
5777 ")
5778
5779 (defvar gnus-decode-header-methods-cache nil)
5780
5781 (defun gnus-multi-decode-header (start end)
5782   "Apply the functions from `gnus-encoded-word-methods' that match."
5783   (unless (and gnus-decode-header-methods-cache
5784                (eq gnus-newsgroup-name
5785                    (car gnus-decode-header-methods-cache)))
5786     (setq gnus-decode-header-methods-cache (list gnus-newsgroup-name))
5787     (mapcar (lambda (x)
5788               (if (symbolp x)
5789                   (nconc gnus-decode-header-methods-cache (list x))
5790                 (if (and gnus-newsgroup-name
5791                          (string-match (car x) gnus-newsgroup-name))
5792                     (nconc gnus-decode-header-methods-cache
5793                            (list (cdr x))))))
5794           gnus-decode-header-methods))
5795   (let ((xlist gnus-decode-header-methods-cache))
5796     (pop xlist)
5797     (save-restriction
5798       (narrow-to-region start end)
5799       (while xlist
5800         (funcall (pop xlist) (point-min) (point-max))))))
5801
5802 ;;;
5803 ;;; Treatment top-level handling.
5804 ;;;
5805
5806 (defun gnus-treat-article (condition &optional part-number total-parts type)
5807   (let ((length (- (point-max) (point-min)))
5808         (alist gnus-treatment-function-alist)
5809         (article-goto-body-goes-to-point-min-p t)
5810         (treated-type
5811          (or (not type)
5812              (catch 'found
5813                (let ((list gnus-article-treat-types))
5814                  (while list
5815                    (when (string-match (pop list) type)
5816                      (throw 'found t)))))))
5817         (highlightp (gnus-visual-p 'article-highlight 'highlight))
5818         val elem)
5819     (gnus-run-hooks 'gnus-part-display-hook)
5820     (while (setq elem (pop alist))
5821       (setq val
5822             (save-excursion
5823               (if (gnus-buffer-live-p gnus-summary-buffer)
5824                   (set-buffer gnus-summary-buffer))
5825               (symbol-value (car elem))))
5826       (when (and (or (consp val)
5827                      treated-type)
5828                  (gnus-treat-predicate val)
5829                  (or (not (get (car elem) 'highlight))
5830                      highlightp))
5831         (save-restriction
5832           (funcall (cadr elem)))))))
5833
5834 ;; Dynamic variables.
5835 (eval-when-compile
5836   (defvar part-number)
5837   (defvar total-parts)
5838   (defvar type)
5839   (defvar condition)
5840   (defvar length))
5841
5842 (defun gnus-treat-predicate (val)
5843   (cond
5844    ((null val)
5845     nil)
5846    ((and (listp val)
5847          (stringp (car val)))
5848     (apply 'gnus-or (mapcar `(lambda (s)
5849                                (string-match s ,(or gnus-newsgroup-name "")))
5850                             val)))
5851    ((listp val)
5852     (let ((pred (pop val)))
5853       (cond
5854        ((eq pred 'or)
5855         (apply 'gnus-or (mapcar 'gnus-treat-predicate val)))
5856        ((eq pred 'and)
5857         (apply 'gnus-and (mapcar 'gnus-treat-predicate val)))
5858        ((eq pred 'not)
5859         (not (gnus-treat-predicate (car val))))
5860        ((eq pred 'typep)
5861         (equal (car val) type))
5862        (t
5863         (error "%S is not a valid predicate" pred)))))
5864    (condition
5865     (eq condition val))
5866    ((eq val t)
5867     t)
5868    ((eq val 'head)
5869     nil)
5870    ((eq val 'last)
5871     (eq part-number total-parts))
5872    ((numberp val)
5873     (< length val))
5874    (t
5875     (error "%S is not a valid value" val))))
5876
5877 (defun gnus-article-encrypt-body (protocol &optional n)
5878   "Encrypt the article body."
5879   (interactive
5880    (list
5881     (or gnus-article-encrypt-protocol
5882         (completing-read "Encrypt protocol: "
5883                          gnus-article-encrypt-protocol-alist
5884                          nil t))
5885     current-prefix-arg))
5886   (let ((func (cdr (assoc protocol gnus-article-encrypt-protocol-alist))))
5887     (unless func
5888       (error (format "Can't find the encrypt protocol %s" protocol)))
5889     (if (equal gnus-newsgroup-name "nndraft:drafts")
5890         (error "Can't encrypt the article in group nndraft:drafts"))
5891     (if (equal gnus-newsgroup-name "nndraft:queue")
5892         (error "Don't encrypt the article in group nndraft:queue"))
5893     (gnus-summary-iterate n
5894       (save-excursion
5895         (set-buffer gnus-summary-buffer)
5896         (let ((mail-parse-charset gnus-newsgroup-charset)
5897               (mail-parse-ignored-charsets gnus-newsgroup-ignored-charsets)
5898               (summary-buffer gnus-summary-buffer)
5899               references point)
5900           (gnus-set-global-variables)
5901           (when (gnus-group-read-only-p)
5902             (error "The current newsgroup does not support article encrypt"))
5903           (gnus-summary-show-article t)
5904           (setq references
5905               (or (mail-header-references gnus-current-headers) ""))
5906           (set-buffer gnus-article-buffer)
5907           (let* ((buffer-read-only nil)
5908                  (headers
5909                   (mapcar (lambda (field)
5910                             (and (save-restriction
5911                                    (message-narrow-to-head)
5912                                    (goto-char (point-min))
5913                                    (search-forward field nil t))
5914                                  (prog2
5915                                      (message-narrow-to-field)
5916                                      (buffer-substring (point-min) (point-max))
5917                                    (delete-region (point-min) (point-max))
5918                                    (widen))))
5919                           '("Content-Type:" "Content-Transfer-Encoding:"
5920                             "Content-Disposition:"))))
5921             (message-narrow-to-head)
5922             (message-remove-header "MIME-Version")
5923             (goto-char (point-max))
5924             (setq point (point))
5925             (insert (apply 'concat headers))
5926             (widen)
5927             (narrow-to-region point (point-max))
5928             (let ((message-options message-options))
5929               (message-options-set 'message-sender user-mail-address)
5930               (message-options-set 'message-recipients user-mail-address)
5931               (message-options-set 'message-sign-encrypt 'not)
5932               (funcall func))
5933             (goto-char (point-min))
5934             (insert "MIME-Version: 1.0\n")
5935             (widen)
5936             (gnus-summary-edit-article-done
5937              references nil summary-buffer t))
5938           (when gnus-keep-backlog
5939             (gnus-backlog-remove-article
5940              (car gnus-article-current) (cdr gnus-article-current)))
5941           (save-excursion
5942             (when (get-buffer gnus-original-article-buffer)
5943               (set-buffer gnus-original-article-buffer)
5944               (setq gnus-original-article nil)))
5945           (when gnus-use-cache
5946             (gnus-cache-update-article
5947              (car gnus-article-current) (cdr gnus-article-current))))))))
5948
5949 (defvar gnus-mime-security-button-line-format "%{%([[%t:%i]%D]%)%}\n"
5950   "The following specs can be used:
5951 %t  The security MIME type
5952 %i  Additional info
5953 %d  Details
5954 %D  Details if button is pressed")
5955
5956 (defvar gnus-mime-security-button-end-line-format "%{%([[End of %t]%D]%)%}\n"
5957   "The following specs can be used:
5958 %t  The security MIME type
5959 %i  Additional info
5960 %d  Details
5961 %D  Details if button is pressed")
5962
5963 (defvar gnus-mime-security-button-line-format-alist
5964   '((?t gnus-tmp-type ?s)
5965     (?i gnus-tmp-info ?s)
5966     (?d gnus-tmp-details ?s)
5967     (?D gnus-tmp-pressed-details ?s)))
5968
5969 (defvar gnus-mime-security-button-map
5970   (let ((map (make-sparse-keymap)))
5971     (unless (>= (string-to-number emacs-version) 21)
5972       (set-keymap-parent map gnus-article-mode-map))
5973     (define-key map gnus-mouse-2 'gnus-article-push-button)
5974     (define-key map "\r" 'gnus-article-press-button)
5975     map))
5976
5977 (defvar gnus-mime-security-details-buffer nil)
5978
5979 (defvar gnus-mime-security-button-pressed nil)
5980
5981 (defvar gnus-mime-security-show-details-inline t
5982   "If non-nil, show details in the article buffer.")
5983
5984 (defun gnus-mime-security-verify-or-decrypt (handle)
5985   (mm-remove-parts (cdr handle))
5986   (let ((region (mm-handle-multipart-ctl-parameter handle 'gnus-region))
5987         point buffer-read-only)
5988     (if region
5989         (goto-char (car region)))
5990     (save-restriction
5991       (narrow-to-region (point) (point))
5992       (with-current-buffer (mm-handle-multipart-original-buffer handle)
5993         (let* ((mm-verify-option 'known)
5994                (mm-decrypt-option 'known)
5995                (nparts (mm-possibly-verify-or-decrypt (cdr handle) handle)))
5996           (unless (eq nparts (cdr handle))
5997             (mm-destroy-parts (cdr handle))
5998             (setcdr handle nparts))))
5999       (setq point (point))
6000       (gnus-mime-display-security handle)
6001       (goto-char (point-max)))
6002     (when region
6003       (delete-region (point) (cdr region))
6004       (set-marker (car region) nil)
6005       (set-marker (cdr region) nil))
6006     (goto-char point)))
6007
6008 (defun gnus-mime-security-show-details (handle)
6009   (let ((details (mm-handle-multipart-ctl-parameter handle 'gnus-details)))
6010     (if details
6011         (if gnus-mime-security-show-details-inline
6012             (let ((gnus-mime-security-button-pressed t)
6013                   (gnus-mime-security-button-line-format
6014                    (get-text-property (point) 'gnus-line-format))
6015                 buffer-read-only)
6016               (forward-char -1)
6017               (while (eq (get-text-property (point) 'gnus-line-format)
6018                          gnus-mime-security-button-line-format)
6019                 (forward-char -1))
6020               (forward-char)
6021               (save-restriction
6022                 (narrow-to-region (point) (point))
6023                 (gnus-insert-mime-security-button handle))
6024               (delete-region (point)
6025                              (or (text-property-not-all
6026                                   (point) (point-max)
6027                                   'gnus-line-format
6028                                   gnus-mime-security-button-line-format)
6029                                  (point-max))))
6030           (if (gnus-buffer-live-p gnus-mime-security-details-buffer)
6031               (with-current-buffer gnus-mime-security-details-buffer
6032                 (erase-buffer)
6033                 t)
6034             (setq gnus-mime-security-details-buffer
6035                   (gnus-get-buffer-create "*MIME Security Details*")))
6036           (with-current-buffer gnus-mime-security-details-buffer
6037             (insert details)
6038             (goto-char (point-min)))
6039           (pop-to-buffer gnus-mime-security-details-buffer))
6040       (gnus-message 5 "No details."))))
6041
6042 (defun gnus-mime-security-press-button (handle)
6043   (if (mm-handle-multipart-ctl-parameter handle 'gnus-info)
6044       (gnus-mime-security-show-details handle)
6045     (gnus-mime-security-verify-or-decrypt handle)))
6046
6047 (defun gnus-insert-mime-security-button (handle &optional displayed)
6048   (let* ((protocol (mm-handle-multipart-ctl-parameter handle 'protocol))
6049          (gnus-tmp-type
6050           (concat
6051            (or (nth 2 (assoc protocol mm-verify-function-alist))
6052                (nth 2 (assoc protocol mm-decrypt-function-alist))
6053                "Unknown")
6054            (if (equal (car handle) "multipart/signed")
6055                " Signed" " Encrypted")
6056            " Part"))
6057          (gnus-tmp-info
6058           (or (mm-handle-multipart-ctl-parameter handle 'gnus-info)
6059               "Undecided"))
6060          (gnus-tmp-details
6061           (mm-handle-multipart-ctl-parameter handle 'gnus-details))
6062          gnus-tmp-pressed-details
6063          b e)
6064     (setq gnus-tmp-details
6065           (if gnus-tmp-details
6066               (concat "\n" gnus-tmp-details) ""))
6067     (setq gnus-tmp-pressed-details
6068           (if gnus-mime-security-button-pressed gnus-tmp-details ""))
6069     (unless (bolp)
6070       (insert "\n"))
6071     (setq b (point))
6072     (gnus-eval-format
6073      gnus-mime-security-button-line-format
6074      gnus-mime-security-button-line-format-alist
6075      `(,@(gnus-local-map-property gnus-mime-security-button-map)
6076          gnus-callback gnus-mime-security-press-button
6077          gnus-line-format ,gnus-mime-security-button-line-format
6078          article-type annotation
6079          gnus-data ,handle))
6080     (setq e (point))
6081     (widget-convert-button
6082      'link b e
6083      :mime-handle handle
6084      :action 'gnus-widget-press-button
6085      :button-keymap gnus-mime-security-button-map
6086      :help-echo
6087      (lambda (widget/window &optional overlay pos)
6088        ;; Needed to properly clear the message due to a bug in
6089        ;; wid-edit (XEmacs only).
6090        (if (boundp 'help-echo-owns-message)
6091            (setq help-echo-owns-message t))
6092        (format
6093         "%S: show detail"
6094         (aref gnus-mouse-2 0))))))
6095
6096 (defun gnus-mime-display-security (handle)
6097   (save-restriction
6098     (narrow-to-region (point) (point))
6099     (unless (gnus-unbuttonized-mime-type-p (car handle))
6100       (gnus-insert-mime-security-button handle))
6101     (gnus-mime-display-mixed (cdr handle))
6102     (unless (bolp)
6103       (insert "\n"))
6104     (unless (gnus-unbuttonized-mime-type-p (car handle))
6105       (let ((gnus-mime-security-button-line-format
6106              gnus-mime-security-button-end-line-format))
6107         (gnus-insert-mime-security-button handle)))
6108     (mm-set-handle-multipart-parameter
6109      handle 'gnus-region
6110      (cons (set-marker (make-marker) (point-min))
6111            (set-marker (make-marker) (point-max))))))
6112
6113 (gnus-ems-redefine)
6114
6115 (provide 'gnus-art)
6116
6117 (run-hooks 'gnus-art-load-hook)
6118
6119 ;;; gnus-art.el ends here