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

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