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